diff options
Diffstat (limited to '.emacs.d')
30 files changed, 24174 insertions, 0 deletions
diff --git a/.emacs.d/.gitignore b/.emacs.d/.gitignore new file mode 100644 index 0000000..d90d7da --- /dev/null +++ b/.emacs.d/.gitignore @@ -0,0 +1,5 @@ +tramp +elpa +bookmarks +abbrev_defs +custom.el diff --git a/.emacs.d/elisp/autopair.el b/.emacs.d/elisp/autopair.el new file mode 100644 index 0000000..ba322e3 --- /dev/null +++ b/.emacs.d/elisp/autopair.el @@ -0,0 +1,1069 @@ +;;; autopair.el --- Automagically pair braces and quotes like TextMate + +;; Copyright (C) 2009,2010 Joao Tavora + +;; Author: Joao Tavora <joaotavora [at] gmail.com> +;; Keywords: convenience, emulations +;; X-URL: http://autopair.googlecode.com +;; URL: http://autopair.googlecode.com +;; EmacsWiki: AutoPairs +;; Version: 0.4 +;; Revision: $Rev$ ($LastChangedDate$) + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Another stab at making braces and quotes pair like in +;; TextMate: +;; +;; * Opening braces/quotes are autopaired; +;; * Closing braces/quotes are autoskipped; +;; * Backspacing an opening brace/quote autodeletes its adjacent pair. +;; * Newline between newly-opened brace pairs open an extra indented line. +;; +;; Autopair deduces from the current syntax table which characters to +;; pair, skip or delete. +;; +;;; Installation: +;; +;; (require 'autopair) +;; (autopair-global-mode) ;; to enable in all buffers +;; +;; To enable autopair in just some types of buffers, comment out the +;; `autopair-global-mode' and put autopair-mode in some major-mode +;; hook, like: +;; +;; (add-hook 'c-mode-common-hook #'(lambda () (autopair-mode))) +;; +;; Alternatively, do use `autopair-global-mode' and create +;; *exceptions* using the `autopair-dont-activate' local variable, +;; like: +;; +;; (add-hook 'c-mode-common-hook #'(lambda () (setq autopair-dont-activate t))) +;; +;;; Use: +;; +;; The extension works by rebinding the braces and quotes keys, but +;; can still be minimally intrusive, since the original binding is +;; always called as if autopair did not exist. +;; +;; The decision of which keys to actually rebind is taken at +;; minor-mode activation time, based on the current major mode's +;; syntax tables. To achieve this kind of behaviour, an emacs +;; variable `emulation-mode-map-alists' was used. +;; +;; If you set `autopair-pair-criteria' and `autopair-skip-criteria' to +;; 'help-balance (which, by the way, is the default), braces are not +;; autopaired/autoskiped in all situations; the decision to autopair +;; or autoskip a brace is taken according to the following table: +;; +;; +---------+------------+-----------+-------------------+ +;; | 1234567 | autopair? | autoskip? | notes | +;; +---------+------------+-----------+-------------------+ +;; | (()) | yyyyyyy | ---yy-- | balanced | +;; +---------+------------+-----------+-------------------+ +;; | (())) | ------y | ---yyy- | too many closings | +;; +---------+------------+-----------+-------------------+ +;; | ((()) | yyyyyyy | ------- | too many openings | +;; +---------+------------+-----------+-------------------+ +;; +;; The table is read like this: in a buffer with 7 characters laid out +;; like the first column, an "y" marks points where an opening brace +;; is autopaired and in which places would a closing brace be +;; autoskipped. +;; +;; Quote pairing tries to support similar "intelligence", but is less +;; deterministic. Some inside-string or inside-comment situations may +;; not always behave how you intend them to. +;; +;; The variable `autopair-autowrap' tells autopair to automatically +;; wrap the selection region with the delimiters you're trying to +;; insert. This is done conditionally based of syntaxes of the two +;; ends of the selection region. It is compatible with `cua-mode's +;; typing-deletes-selection behaviour. This feature is probably still +;; a little unstable, hence `autopair-autowrap' defaults to nil. +;; +;; If you find the paren-blinking annoying, turn `autopair-blink' to +;; nil. +;; +;; For lisp-programming you might also like `autopair-skip-whitespace'. +;; +;; For further customization have a look at `autopair-dont-pair', +;; `autopair-handle-action-fns' and `autopair-extra-pairs'. +;; +;; `autopair-dont-pair' lets you define special cases of characters +;; you don't want paired. Its default value skips pairing +;; single-quote characters when inside a comment literal, even if the +;; language syntax tables does pair these characters. +;; +;; (defvar autopair-dont-pair `(:string (?') :comment (?')) +;; +;; As a further example, to also prevent the '{' (opening brace) +;; character from being autopaired in C++ comments use this in your +;; .emacs. +;; +;; (add-hook 'c++-mode-hook +;; #'(lambda () +;; (push ?{ +;; (getf autopair-dont-pair :comment)))) +;; +;; `autopair-handle-action-fns' lets you override/extend the actions +;; taken by autopair after it decides something must be paired,skipped +;; or deleted. To work with triple quoting in python mode, you can use +;; this for example: +;; +;; (add-hook 'python-mode-hook +;; #'(lambda () +;; (setq autopair-handle-action-fns +;; (list #'autopair-default-handle-action +;; #'autopair-python-triple-quote-action)))) +;; +;; It's also useful to deal with latex's mode use of the "paired +;; delimiter" syntax class. +;; +;; (add-hook 'latex-mode-hook +;; #'(lambda () +;; (set (make-local-variable 'autopair-handle-action-fns) +;; (list #'autopair-default-handle-action +;; #'autopair-latex-mode-paired-delimiter-action)))) +;; +;; `autopair-extra-pairs' lets you define extra pairing and skipping +;; behaviour for pairs not programmed into the syntax table. Watch +;; out, this is work-in-progress, a little unstable and does not help +;; balancing at all. To have '<' and '>' pair in c++-mode buffers, but +;; only in code, use: +;; +;; (add-hook 'c++-mode-hook +;; #'(lambda () +;; (push '(?< . ?>) +;; (getf autopair-extra-pairs :code)))) +;; +;; if you program in emacs-lisp you might also like the following to +;; pair backtick and quote +;; +;; (add-hook 'emacs-lisp-mode-hook +;; #'(lambda () +;; (push '(?` . ?') +;; (getf autopair-extra-pairs :comment)) +;; (push '(?` . ?') +;; (getf autopair-extra-pairs :string)))) +;; +;;; Bugs: +;; +;; * Quote pairing/skipping inside comments is not perfect... +;; +;; * See the last section on monkey-patching for the `defadvice' +;; tricks used to make `autopair-autowrap' work with `cua-mode' and +;; `delete-selection-mode'. +;; +;;; Credit: +;; +;; Thanks Ed Singleton for early testing. +;; +;;; Code: + +;; requires +(require 'cl) + +;; variables +(defvar autopair-pair-criteria 'help-balance + "How to decide whether to pair opening brackets or quotes. + +Set this to 'always to always pair, or 'help-balance to be more +criterious when pairing.") + +(defvar autopair-skip-criteria 'help-balance + "How to decide whether to skip closing brackets or quotes. + +Set this to 'always to always skip, or 'help-balance to be more +criterious when skipping.") + +(defvar autopair-emulation-alist nil + "A dinamic keymap for autopair set mostly from the current + syntax table.") + +(defvar autopair-dont-activate nil + "Control activation of `autopair-global-mode'. + +Set this to a non-nil value to skip activation of `autopair-mode' +in certain contexts. If however the value satisfies `functionp' +and is a function of no arguments, the function is called and it is +the return value that decides.") +(make-variable-buffer-local 'autopair-dont-activate) + +(defvar autopair-extra-pairs nil + "Extra pairs for which to use pairing. + +It's a Common-lisp-style even-numbered property list, each pair +of elements being of the form (TYPE , PAIRS). PAIRS is a mixed +list whose elements are cons cells, which look like cells look +like (OPENING . CLOSING). Autopair pairs these like +parenthesis. + +TYPE can be one of: + +:string : whereby PAIRS will be considered only when inside a + string literal + +:comment : whereby PAIRS will be considered only when inside a comment + +:code : whereby PAIRS will be considered only when outisde a + string and a comment. + +:everywhere : whereby PAIRS will be considered in all situations + +In Emacs-lisp, this might be useful + +(add-hook 'emacs-lisp-mode-hook + #'(lambda () + (setq autopair-extra-pairs `(:comment ((?`. ?')))))) + + +Note that this does *not* work for single characters, +e.x. characters you want to behave as quotes. See the +docs/source comments for more details.") + +(make-variable-buffer-local 'autopair-extra-pairs) + +(defvar autopair-dont-pair `(:string (?') :comment (?')) + "Characters for which to skip any pairing behaviour. + +This variable overrides `autopair-pair-criteria' and +`autopair-extra-pairs'. It does not + (currently) affect the skipping behaviour. + +It's a Common-lisp-style even-numbered property list, each pair +of elements being of the form (TYPE , CHARS). CHARS is a list of +characters and TYPE can be one of: + +:string : whereby characters in CHARS will not be autopaired when + inside a string literal + +:comment : whereby characters in CHARS will not be autopaired when + inside a comment + +:never : whereby characters in CHARS won't even have their + bindings replaced by autopair's. This particular option + should be used for troubleshooting and requires + `autopair-mode' to be restarted to have any effect.") +(make-variable-buffer-local 'autopair-dont-pair) + +(defvar autopair-action nil + "Autopair action decided on by last interactive autopair command, or nil. + +When autopair decides on an action this is a list whose first +three elements are (ACTION PAIR POS-BEFORE). + +ACTION is one of `opening', `insert-quote', `skip-quote', +`backspace', `newline' or `paired-delimiter'. PAIR is the pair of +the `autopair-inserted' character, if applicable. POS-BEFORE is +value of point before action command took place .") + + +(defvar autopair-wrap-action nil + "Autowrap action decided on by autopair, if any. + +When autopair decides on an action this is a list whose first +three elements are (ACTION PAIR POS-BEFORE REGION-BEFORE). + +ACTION can only be `wrap' currently. PAIR and POS-BEFORE +delimiter are as in `autopair-action'. REGION-BEFORE is a cons +cell with the bounds of the region before the command takes +place") + +(defvar autopair-handle-action-fns '() + "Autopair handlers to run *instead* of the default handler. + +Each element is a function taking three arguments (ACTION, PAIR +and POS-BEFORE), which are the three elements of the +`autopair-action' variable, which see. + +If non-nil, these functions are called *instead* of the single +function `autopair-default-handle-action', so use this variable +to specify special behaviour. To also run the default behaviour, +be sure to include `autopair-default-handle-action' in the +list, or call it from your handlers.") +(make-variable-buffer-local 'autopair-handle-action-fns) + +(defvar autopair-handle-wrap-action-fns '() + "Autopair wrap handlers to run *instead* of the default handler. + +Each element is a function taking four arguments (ACTION, PAIR, +POS-BEFORE and REGION-BEFORE), which are the three elements of the +`autopair-wrap-action' variable, which see. + +If non-nil, these functions are called *instead* of the single +function `autopair-default-handle-wrap-action', so use this +variable to specify special behaviour. To also run the default +behaviour, be sure to include `autopair-default-handle-wrap-action' in +the list, or call it in your handlers.") +(make-variable-buffer-local 'autopair-handle-wrap-action-fns) + +(defvar autopair-inserted nil + "Delimiter inserted by last interactive autopair command. + +This is calculated with `autopair-calculate-inserted', which see.") + +(defun autopair-calculate-inserted () + "Attempts to guess the delimiter the current command is inserting. + +For now, simply returns `last-command-event'" + last-command-event) + +;; minor mode and global mode +;; +(define-globalized-minor-mode autopair-global-mode autopair-mode autopair-on) + +(defun autopair-on () (unless (or buffer-read-only + (if (functionp autopair-dont-activate) + (funcall autopair-dont-activate) + autopair-dont-activate)) + (autopair-mode 1))) + +(define-minor-mode autopair-mode + "Automagically pair braces and quotes like in TextMate." + nil " pair" nil + (cond (autopair-mode + ;; Setup the dynamic emulation keymap + ;; + (let ((map (make-sparse-keymap))) + (define-key map [remap delete-backward-char] 'autopair-backspace) + (define-key map [remap backward-delete-char-untabify] 'autopair-backspace) + (define-key map (kbd "<backspace>") 'autopair-backspace) + (define-key map [backspace] 'autopair-backspace) + (define-key map (kbd "DEL") 'autopair-backspace) + (define-key map [return] 'autopair-newline) + (define-key map (kbd "RET") 'autopair-newline) + (dotimes (char 256) ;; only searches the first 256 chars, + ;; TODO: is this enough/toomuch/stupid? + (unless (member char + (getf autopair-dont-pair :never)) + (let* ((syntax-entry (aref (syntax-table) char)) + (class (and syntax-entry + (syntax-class syntax-entry))) + (pair (and syntax-entry + (cdr syntax-entry)))) + (cond ((eq class (car (string-to-syntax "("))) + ;; syntax classes "opening parens" and "close parens" + (define-key map (string char) 'autopair-insert-opening) + (define-key map (string pair) 'autopair-skip-close-maybe)) + ((eq class (car (string-to-syntax "\""))) + ;; syntax class "string quote + (define-key map (string char) 'autopair-insert-or-skip-quote)) + ((eq class (car (string-to-syntax "$"))) + ;; syntax class "paired-delimiter" + ;; + ;; Apropos this class, see Issues 18, 25 and + ;; elisp info node "35.2.1 Table of Syntax + ;; Classes". The fact that it supresses + ;; syntatic properties in the delimited region + ;; dictates that deciding to autopair/autoskip + ;; can't really be as clean as the string + ;; delimiter. + ;; + ;; Apparently, only `TeX-mode' uses this, so + ;; the best is to bind this to + ;; `autopair-insert-or-skip-paired-delimiter' + ;; which defers any decision making to + ;; mode-specific post-command handler + ;; functions. + ;; + (define-key map (string char) 'autopair-insert-or-skip-paired-delimiter)))))) + ;; read `autopair-extra-pairs' + (dolist (pairs-list (remove-if-not #'listp autopair-extra-pairs)) + (dolist (pair pairs-list) + (define-key map (string (car pair)) 'autopair-extra-insert-opening) + (define-key map (string (cdr pair)) 'autopair-extra-skip-close-maybe))) + + (set (make-local-variable 'autopair-emulation-alist) (list (cons t map)))) + + (setq autopair-action nil) + (setq autopair-wrap-action nil) + (add-hook 'emulation-mode-map-alists 'autopair-emulation-alist 'append) + (add-hook 'post-command-hook 'autopair-post-command-handler nil 'local)) + (t + (setq autopair-emulation-alist nil) + (remove-hook 'emulation-mode-map-alists 'autopair-emulation-alist) + (remove-hook 'post-command-hook 'autopair-post-command-handler 'local)))) + +;; helper functions +;; +(defun autopair-syntax-ppss () + "Calculate syntax info relevant to autopair. + +A list of four elements is returned: + +- SYNTAX-INFO is either the result `syntax-ppss' or the result of + calling `parse-partial-sexp' with the appropriate + bounds (previously calculated with `syntax-ppss'. + +- WHERE-SYM can be one of the symbols :string, :comment or :code. + +- QUICK-SYNTAX-INFO is always the result returned by `syntax-ppss'. + +- BOUNDS are the boudaries of the current string or comment if + we're currently inside one." + (let* ((quick-syntax-info (syntax-ppss)) + (string-or-comment-start (nth 8 quick-syntax-info))) + (cond (;; inside a string, recalculate + (nth 3 quick-syntax-info) + (list (parse-partial-sexp (1+ string-or-comment-start) (point)) + :string + quick-syntax-info + (cons string-or-comment-start + (condition-case nil + (scan-sexps string-or-comment-start 1) + (error nil))))) + ((nth 4 quick-syntax-info) + (list (parse-partial-sexp (1+ (nth 8 quick-syntax-info)) (point)) + :comment + quick-syntax-info)) + (t + (list quick-syntax-info + :code + quick-syntax-info))))) + +(defun autopair-find-pair (delim &optional closing) + (when (and delim + (integerp delim)) + (let ((syntax-entry (aref (syntax-table) delim))) + (cond ((eq (syntax-class syntax-entry) (car (string-to-syntax "("))) + (cdr syntax-entry)) + ((or (eq (syntax-class syntax-entry) (car (string-to-syntax "\""))) + (eq (syntax-class syntax-entry) (car (string-to-syntax "$")))) + delim) + ((and (not closing) + (eq (syntax-class syntax-entry) (car (string-to-syntax ")")))) + (cdr syntax-entry)) + (autopair-extra-pairs + (some #'(lambda (pair-list) + (some #'(lambda (pair) + (cond ((eq (cdr pair) delim) (car pair)) + ((eq (car pair) delim) (cdr pair)))) + pair-list)) + (remove-if-not #'listp autopair-extra-pairs))))))) + +(defun autopair-calculate-wrap-action () + (when (and transient-mark-mode mark-active) + (when (> (point) (mark)) + (exchange-point-and-mark)) + (save-excursion + (let* ((region-before (cons (region-beginning) + (region-end))) + (point-before (point)) + (start-syntax (syntax-ppss (car region-before))) + (end-syntax (syntax-ppss (cdr region-before)))) + (when (or (not (eq autopair-autowrap 'help-balance)) + (and (eq (nth 0 start-syntax) (nth 0 end-syntax)) + (eq (nth 3 start-syntax) (nth 3 end-syntax)))) + (list 'wrap (or (second autopair-action) + (autopair-find-pair autopair-inserted)) + point-before + region-before)))))) + +(defun autopair-original-binding () + (or (key-binding `[,autopair-inserted]) + (key-binding (this-single-command-keys)) + (key-binding fallback-keys))) + +(defun autopair-fallback (&optional fallback-keys) + (let* ((autopair-emulation-alist nil) + (beyond-cua (let ((cua--keymap-alist nil)) + (autopair-original-binding))) + (beyond-autopair (autopair-original-binding))) + (when autopair-autowrap + (setq autopair-wrap-action (autopair-calculate-wrap-action))) + + (setq this-original-command beyond-cua) + ;; defer to "paredit-mode" if that is installed and running + (when (and (featurep 'paredit) + (string-match "paredit" (symbol-name beyond-cua))) + (setq autopair-action nil)) + (let ((cua-delete-selection (not autopair-autowrap)) + (blink-matching-paren (not autopair-action))) + (call-interactively beyond-autopair)))) + +(defvar autopair-autowrap 'help-balance + "If non-nil autopair attempts to wrap the selected region. + +This is also done in an optimistic \"try-to-balance\" fashion. +Set this to to 'help-balance to be more criterious when wrapping.") + +(defvar autopair-skip-whitespace nil + "If non-nil also skip over whitespace when skipping closing delimiters. + +If set to 'chomp, this will be most useful in lisp-like languages where you want +lots of )))))....") + +(defvar autopair-blink (if (boundp 'blink-matching-paren) + blink-matching-paren + t) + "If non-nil autopair blinks matching delimiters.") + +(defvar autopair-blink-delay 0.1 + "Autopair's blink-the-delimiter delay.") + +(defun autopair-document-bindings (&optional fallback-keys) + (concat + "Works by scheduling possible autopair behaviour, then calls +original command as if autopair didn't exist" + (when (eq this-command 'describe-key) + (let* ((autopair-emulation-alist nil) + (command (or (key-binding (this-single-command-keys)) + (key-binding fallback-keys)))) + (when command + (format ", which in this case is `%s'" command)))) + ".")) + +(defun autopair-escaped-p (syntax-info) + (nth 5 syntax-info)) + +(defun autopair-exception-p (where-sym exception-where-sym blacklist &optional fn) + (and (or (eq exception-where-sym :everywhere) + (eq exception-where-sym where-sym)) + (member autopair-inserted + (if fn + (mapcar fn (getf blacklist exception-where-sym)) + (getf blacklist exception-where-sym))))) + +(defun autopair-up-list (syntax-info &optional closing) + "Try to uplist as much as possible, moving point. + +Return nil if something prevented uplisting. + +Otherwise return a cons of char positions of the starting +delimiter and end delimiters of the last list we just came out +of. If we aren't inside any lists return a cons of current point. + +If inside nested lists of mixed parethesis types, finding a +matching parenthesis of a mixed-type is considered OK (non-nil is +returned) and uplisting stops there." + (condition-case nil + (let ((howmany (car syntax-info)) + (retval (cons (point) + (point)))) + (while (and (> howmany 0) + (condition-case err + (progn + (scan-sexps (point) (- (point-max))) + (error err)) + (error (let ((opening (and closing + (autopair-find-pair closing)))) + (setq retval (cons (fourth err) + (point))) + (or (not opening) + (eq opening (char-after (fourth err)))))))) + (goto-char (scan-lists (point) 1 1)) + (decf howmany)) + retval) + (error nil))) + +;; interactive commands and their associated predicates +;; +(defun autopair-insert-or-skip-quote () + (interactive) + (setq autopair-inserted (autopair-calculate-inserted)) + (let* ((syntax-triplet (autopair-syntax-ppss)) + (syntax-info (first syntax-triplet)) + (where-sym (second syntax-triplet)) + (orig-info (third syntax-triplet)) + ;; inside-string may the quote character itself or t if this + ;; is a "generically terminated string" + (inside-string (and (eq where-sym :string) + (fourth orig-info))) + (escaped-p (autopair-escaped-p syntax-info)) + + ) + (cond (;; decides whether to skip the quote... + ;; + (and (not escaped-p) + (eq autopair-inserted (char-after (point))) + (or + ;; ... if we're already inside a string and the + ;; string starts with the character just inserted, + ;; or it's a generically terminated string + (and inside-string + (or (eq inside-string t) + (eq autopair-inserted inside-string))) + ;; ... if we're in a comment and ending a string + ;; (the inside-string criteria does not work + ;; here...) + (and (eq where-sym :comment) + (condition-case nil + (eq autopair-inserted (char-after (scan-sexps (1+ (point)) -1))) + (error nil))))) + (setq autopair-action (list 'skip-quote autopair-inserted (point)))) + (;; decides whether to pair, i.e do *not* pair the quote if... + ;; + (not + (or + escaped-p + ;; ... inside a generic string + (eq inside-string t) + ;; ... inside an unterminated string started by this char + (autopair-in-unterminated-string-p syntax-triplet) + ;; ... uplisting forward causes an error which leaves us + ;; inside an unterminated string started by this char + (condition-case err + (progn (save-excursion (up-list)) nil) + (error + (autopair-in-unterminated-string-p (save-excursion + (goto-char (fourth err)) + (autopair-syntax-ppss))))) + (autopair-in-unterminated-string-p (save-excursion + (goto-char (point-max)) + (autopair-syntax-ppss))) + ;; ... comment-disable or string-disable are true here. + ;; The latter is only useful if we're in a string + ;; terminated by a character other than + ;; `autopair-inserted'. + (some #'(lambda (sym) + (autopair-exception-p where-sym sym autopair-dont-pair)) + '(:comment :string)))) + (setq autopair-action (list 'insert-quote autopair-inserted (point))))) + (autopair-fallback))) + +(put 'autopair-insert-or-skip-quote 'function-documentation + '(concat "Insert or possibly skip over a quoting character.\n\n" + (autopair-document-bindings))) + +(defun autopair-in-unterminated-string-p (autopair-triplet) + (and (eq autopair-inserted (fourth (third autopair-triplet))) + (condition-case nil (progn (scan-sexps (ninth (third autopair-triplet)) 1) nil) (error t)))) + + +(defun autopair-insert-opening () + (interactive) + (setq autopair-inserted (autopair-calculate-inserted)) + (when (autopair-pair-p) + (setq autopair-action (list 'opening (autopair-find-pair autopair-inserted) (point)))) + (autopair-fallback)) +(put 'autopair-insert-opening 'function-documentation + '(concat "Insert opening delimiter and possibly automatically close it.\n\n" + (autopair-document-bindings))) + +(defun autopair-skip-close-maybe () + (interactive) + (setq autopair-inserted (autopair-calculate-inserted)) + (when (autopair-skip-p) + (setq autopair-action (list 'closing (autopair-find-pair autopair-inserted) (point)))) + (autopair-fallback)) +(put 'autopair-skip-close-maybe 'function-documentation + '(concat "Insert or possibly skip over a closing delimiter.\n\n" + (autopair-document-bindings))) + +(defun autopair-backspace () + (interactive) + (setq autopair-inserted (autopair-calculate-inserted)) + (when (char-before) + (setq autopair-action (list 'backspace (autopair-find-pair (char-before) 'closing) (point)))) + (autopair-fallback (kbd "DEL"))) +(put 'autopair-backspace 'function-documentation + '(concat "Possibly delete a pair of paired delimiters.\n\n" + (autopair-document-bindings (kbd "DEL")))) + +(defun autopair-newline () + (interactive) + (setq autopair-inserted (autopair-calculate-inserted)) + (let ((pair (autopair-find-pair (char-before)))) + (when (and pair + (eq (char-syntax pair) ?\)) + (eq (char-after) pair)) + (setq autopair-action (list 'newline pair (point)))) + (autopair-fallback (kbd "RET")))) +(put 'autopair-newline 'function-documentation + '(concat "Do a smart newline when right between parenthesis.\n +In other words, insert an extra newline along with the one inserted normally +by this command. Then place point after the first, indented.\n\n" + (autopair-document-bindings (kbd "RET")))) + +(defun autopair-skip-p () + (let* ((syntax-triplet (autopair-syntax-ppss)) + (syntax-info (first syntax-triplet)) + (orig-point (point))) + (cond ((eq autopair-skip-criteria 'help-balance) + (save-excursion + (let ((pos-pair (autopair-up-list syntax-info autopair-inserted))) + ;; if `autopair-up-list' returned something valid, we + ;; probably want to skip but only if on of the following is true. + ;; + ;; 1. it returned a cons of equal values (we're not inside any list + ;; + ;; 2. up-listing stopped at a list that contains our original point + ;; + ;; 3. up-listing stopped at a list that does not + ;; contain out original point but its starting + ;; delimiter matches the one we expect. + (and pos-pair + (or (eq (car pos-pair) (cdr pos-pair)) + (< orig-point (cdr pos-pair)) + (eq (char-after (car pos-pair)) + (autopair-find-pair autopair-inserted))))))) + ((eq autopair-skip-criteria 'need-opening) + (save-excursion + (condition-case err + (progn + (backward-list) + t) + (error nil)))) + (t + t)))) + +(defun autopair-pair-p () + (let* ((syntax-triplet (autopair-syntax-ppss)) + (syntax-info (first syntax-triplet)) + (where-sym (second syntax-triplet)) + (orig-point (point))) + (and (not (some #'(lambda (sym) + (autopair-exception-p where-sym sym autopair-dont-pair)) + '(:string :comment :code :everywhere))) + (cond ((eq autopair-pair-criteria 'help-balance) + (and (not (autopair-escaped-p syntax-info)) + (save-excursion + (let ((pos-pair (autopair-up-list syntax-info)) + (prev-point (point-max)) + (expected-closing (autopair-find-pair autopair-inserted))) + (condition-case err + (progn + (while (not (eq prev-point (point))) + (setq prev-point (point)) + (forward-sexp)) + t) + (error + ;; if `forward-sexp' (called byp + ;; `autopair-forward') returned an error. + ;; typically we don't want to autopair, + ;; unless one of the following occurs: + ;; + (cond (;; 1. The error is *not* of type "containing + ;; expression ends prematurely", which means + ;; we're in the "too-many-openings" situation + ;; and thus want to autopair. + (not (string-match "prematurely" (second err))) + t) + (;; 2. We stopped at a closing parenthesis. Do + ;; autopair if we're in a mixed parens situation, + ;; i.e. the last list jumped over was started by + ;; the paren we're trying to match + ;; (`autopair-inserted') and ended by a different + ;; parens, or the closing paren we stopped at is + ;; also different from the expected. The second + ;; `scan-lists' places point at the closing of the + ;; last list we forwarded over. + ;; + (condition-case err + (prog1 + (eq (char-after (scan-lists (point) -1 0)) + autopair-inserted) + (goto-char (scan-lists (point) -1 -1))) + (error t)) + + (or + ;; mixed () ] for input (, yes autopair + (not (eq expected-closing (char-after (third err)))) + ;; mixed (] ) for input (, yes autopair + (not (eq expected-closing (char-after (point)))) + ;; ()) for input (, not mixed + ;; hence no autopair + )) + (t + nil)) + ;; (eq (fourth err) (point-max)) + )))))) + ((eq autopair-pair-criteria 'always) + t) + (t + (not (autopair-escaped-p))))))) + +;; post-command-hook stuff +;; +(defun autopair-post-command-handler () + "Performs pairing and wrapping based on `autopair-action' and +`autopair-wrap-action'. " + (when (and autopair-wrap-action + (notany #'null autopair-wrap-action)) + + (if autopair-handle-wrap-action-fns + (condition-case err + (mapc #'(lambda (fn) + (apply fn autopair-wrap-action)) + autopair-handle-wrap-action-fns) + (error (progn + (message "[autopair] error running custom `autopair-handle-wrap-action-fns', switching autopair off") + (autopair-mode -1)))) + (apply #'autopair-default-handle-wrap-action autopair-wrap-action)) + (setq autopair-wrap-action nil)) + + (when (and autopair-action + (notany #'null autopair-action)) + (if autopair-handle-action-fns + (condition-case err + (mapc #'(lambda (fn) + (funcall fn (first autopair-action) (second autopair-action) (third autopair-action))) + autopair-handle-action-fns) + (error (progn + (message "[autopair] error running custom `autopair-handle-action-fns', switching autopair off") + (autopair-mode -1)))) + (apply #'autopair-default-handle-action autopair-action)) + (setq autopair-action nil))) + +(defun autopair-blink-matching-open () + (let ((blink-matching-paren autopair-blink) + (show-paren-mode nil) + (blink-matching-delay autopair-blink-delay)) + (blink-matching-open))) + +(defun autopair-blink (&optional pos) + (when autopair-blink + (if pos + (save-excursion + (goto-char pos) + (sit-for autopair-blink-delay)) + (sit-for autopair-blink-delay)))) + +(defun autopair-default-handle-action (action pair pos-before) + ;;(message "action is %s" action) + (condition-case err + (cond (;; automatically insert closing delimiter + (and (eq 'opening action) + (not (eq pair (char-before)))) + (insert pair) + (autopair-blink) + (backward-char 1)) + (;; automatically insert closing quote delimiter + (eq 'insert-quote action) + (insert pair) + (autopair-blink) + (backward-char 1)) + (;; automatically skip oper closer quote delimiter + (and (eq 'skip-quote action) + (eq pair (char-after (point)))) + (delete-char 1) + (autopair-blink-matching-open)) + (;; skip over newly-inserted-but-existing closing delimiter + ;; (normal case) + (eq 'closing action) + (let ((skipped 0)) + (when autopair-skip-whitespace + (setq skipped (save-excursion (skip-chars-forward "\s\n\t")))) + (when (eq autopair-inserted (char-after (+ (point) skipped))) + (backward-delete-char 1) + (unless (zerop skipped) (autopair-blink (+ (point) skipped))) + (if (eq autopair-skip-whitespace 'chomp) + (delete-char skipped) + (forward-char skipped)) + (forward-char)) + (autopair-blink-matching-open))) + (;; autodelete closing delimiter + (and (eq 'backspace action) + (eq pair (char-after (point)))) + (delete-char 1)) + (;; opens an extra line after point, then indents + (and (eq 'newline action) + (eq pair (char-after (point)))) + (save-excursion + (newline-and-indent)) + (indent-according-to-mode) + (when (or (and (boundp 'global-hl-line-mode) + global-hl-line-mode) + (and (boundp 'hl-line-mode) + hl-line-mode)) + (hl-line-unhighlight) (hl-line-highlight)))) + (error + (message "[autopair] Ignored error in `autopair-default-handle-action'")))) + +(defun autopair-default-handle-wrap-action (action pair pos-before region-before) + "Default handler for the wrapping action in `autopair-wrap'" + (condition-case err + (when (eq 'wrap action) + (let ((delete-active-region nil)) + (cond + ((eq 'opening (first autopair-action)) + (goto-char (1+ (cdr region-before))) + (insert pair) + (autopair-blink) + (goto-char (1+ (car region-before)))) + (;; wraps + (eq 'closing (first autopair-action)) + (delete-backward-char 1) + (insert pair) + (goto-char (1+ (cdr region-before))) + (insert autopair-inserted)) + ((eq 'insert-quote (first autopair-action)) + (goto-char (1+ (cdr region-before))) + (insert pair) + (autopair-blink)) + (t + (delete-backward-char 1) + (goto-char (cdr region-before)) + (insert autopair-inserted))) + (setq autopair-action nil))) + (error + (message "[autopair] Ignored error in `autopair-default-handle-wrap-action'")))) + + +;; example python triple quote helper +;; +(defun autopair-python-triple-quote-action (action pair pos-before) + (cond ((and (eq 'insert-quote action) + (>= (point) 3) + (string= (buffer-substring (- (point) 3) + (point)) + (make-string 3 pair))) + (save-excursion (insert (make-string 2 pair)))) + ((and (eq 'backspace action) + (>= (point) 2) + (<= (point) (- (point-max) 2)) + (string= (buffer-substring (- (point) 2) + (+ (point) 2)) + (make-string 4 pair))) + (delete-region (- (point) 2) + (+ (point) 2))) + ((and (eq 'skip-quote action) + (<= (point) (- (point-max) 2)) + (string= (buffer-substring (point) + (+ (point) 2)) + (make-string 2 pair))) + (forward-char 2)) + (t + t))) + +;; example latex paired-delimiter helper +;; +(defun autopair-latex-mode-paired-delimiter-action (action pair pos-before) + "Pair or skip latex's \"paired delimiter\" syntax in math mode. Added AucText support, thanks Massimo Lauria" + (when (eq action 'paired-delimiter) + (when (eq (char-before) pair) + (if (and (or + (eq (get-text-property pos-before 'face) 'tex-math) + (eq (get-text-property (- pos-before 1) 'face) 'font-latex-math-face) + (member 'font-latex-math-face (get-text-property (- pos-before 1) 'face))) + (eq (char-after) pair)) + (cond ((and (eq (char-after) pair) + (eq (char-after (1+ (point))) pair)) + ;; double skip + (delete-char 1) + (forward-char)) + ((eq (char-before pos-before) pair) + ;; doube insert + (insert pair) + (backward-char)) + (t + ;; simple skip + (delete-char 1))) + (insert pair) + (backward-char))))) + +;; Commands and predicates for the autopair-extra* feature +;; + +(defun autopair-extra-insert-opening () + (interactive) + (setq autopair-inserted (autopair-calculate-inserted)) + (when (autopair-extra-pair-p) + (setq autopair-action (list 'opening (autopair-find-pair autopair-inserted) (point)))) + (autopair-fallback)) +(put 'autopair-extra-insert-opening 'function-documentation + '(concat "Insert (an extra) opening delimiter and possibly automatically close it.\n\n" + (autopair-document-bindings))) + +(defun autopair-extra-skip-close-maybe () + (interactive) + (setq autopair-inserted (autopair-calculate-inserted)) + (when (autopair-extra-skip-p) + (setq autopair-action (list 'closing autopair-inserted (point)))) + (autopair-fallback)) +(put 'autopair-extra-skip-close-maybe 'function-documentation + '(concat "Insert or possibly skip over a (and extra) closing delimiter.\n\n" + (autopair-document-bindings))) + +(defun autopair-extra-pair-p () + (let* ((syntax-triplet (autopair-syntax-ppss)) + (syntax-info (first syntax-triplet)) + (where-sym (second syntax-triplet))) + (some #'(lambda (sym) + (autopair-exception-p where-sym sym autopair-extra-pairs #'car)) + '(:everywhere :comment :string :code)))) + +(defun autopair-extra-skip-p () + (let* ((syntax-triplet (autopair-syntax-ppss)) + (syntax-info (first syntax-triplet)) + (where-sym (second syntax-triplet)) + (orig-point (point))) + (and (eq (char-after (point)) autopair-inserted) + (some #'(lambda (sym) + (autopair-exception-p where-sym sym autopair-extra-pairs #'cdr)) + '(:comment :string :code :everywhere)) + (save-excursion + (condition-case err + (backward-sexp (point-max)) + (error + (goto-char (third err)))) + (search-forward (make-string 1 (autopair-find-pair autopair-inserted)) + orig-point + 'noerror))))) + +;; Commands and tex-mode specific handler functions for the "paired +;; delimiter" syntax class. +;; +(defun autopair-insert-or-skip-paired-delimiter () + " insert or skip a character paired delimiter" + (interactive) + (setq autopair-inserted (autopair-calculate-inserted)) + (setq autopair-action (list 'paired-delimiter autopair-inserted (point))) + (autopair-fallback)) + +(put 'autopair-insert-or-skip-paired-delimiter 'function-documentation + '(concat "Insert or possibly skip over a character with a syntax-class of \"paired delimiter\"." + (autopair-document-bindings))) + + + +;; monkey-patching: Compatibility with delete-selection-mode and cua-mode +;; +;; Ideally one would be able to use functions as the value of the +;; 'delete-selection properties of the autopair commands. The function +;; would return non-nil when no wrapping should/could be performed. +;; +;; Until then use some `defadvice' i.e. monkey-patching, which relies +;; on these features' implementation details. +;; +(put 'autopair-insert-opening 'delete-selection t) +(put 'autopair-skip-close-maybe 'delete-selection t) +(put 'autopair-insert-or-skip-quote 'delete-selection t) +(put 'autopair-extra-insert-opening 'delete-selection t) +(put 'autopair-extra-skip-close-maybe 'delete-selection t) +(put 'autopair-backspace 'delete-selection 'supersede) +(put 'autopair-newline 'delete-selection t) + +(defun autopair-should-autowrap () + (let ((name (symbol-name this-command))) + (and autopair-mode + (not (eq this-command 'autopair-backspace)) + (string-match "^autopair" (symbol-name this-command)) + (autopair-calculate-wrap-action)))) + +(defadvice cua--pre-command-handler-1 (around autopair-override activate) + "Don't actually do anything if autopair is about to autowrap. " + (unless (autopair-should-autowrap) ad-do-it)) + +(defadvice delete-selection-pre-hook (around autopair-override activate) + "Don't actually do anything if autopair is about to autowrap. " + (unless (autopair-should-autowrap) ad-do-it)) + + +(provide 'autopair) +;;; autopair.el ends here +;; diff --git a/.emacs.d/elisp/batch-mode.el b/.emacs.d/elisp/batch-mode.el new file mode 100644 index 0000000..dcc156a --- /dev/null +++ b/.emacs.d/elisp/batch-mode.el @@ -0,0 +1,156 @@ +;;; batch-mode.el --- major mode for editing ESRI batch scrips +;;; Copyright (C) 2002, Agnar Renolen <agnar.renolen@emap.no> +;;; Modified (c) 2009, Matthew Fidler <matthew.fidler at gmail.com> +;;; Fixed indents (and labels) + +;; batch-mode.el is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +;; This is version 1.0 of 21 August 2002. + +;;; Comentary: + +;; The batch-mode provides syntax hilighting and auto-indentation for +;; DOS batch files (.bat). and auto-idendation. + +;; Agnar Renolen, <agnar.renolen@emap.no> + +;;; Code: + +(defgroup batch nil + "Major mode for editing batch code" + :prefix "batch-" + :group 'languages) + +; (defvar batch-mode-hook nil +; "Hooks called when batch mode fires up." +; :type 'hook +; :group 'batch) + +(defvar batch-mode-map nil + "Keymap used with batch code") + +(defcustom batch-indent-level 4 + "Amount by which batch subexpressions are indented." + :type 'integer + :group 'batch) + +(defvar batch-font-lock-keywords + (eval-when-compile + (list + ; since we can't specify batch comments through the syntax table, + ; we have to specify it here, and override whatever is highlighted + '( "^[ \t]*rem\\>.*" (0 font-lock-comment-face t)) + + ; since the argument to the echo command is a string, we format it + ; as a string + '( "\\<echo\\>[ \t]*\\(.*\\)" (1 font-lock-string-face t)) + + ; the argument of the goto statement is a label + '( "\\<goto\\>[ \t]*\\([a-zA-Z0-9_]+\\)" (1 + font-lock-constant-face)) + + ; the keywords of batch (which are not built-in commands) + (concat "\\<\\(cmdextversion\\|" + "d\\(efined\\|isableextensions\\|o\\)\\|" + "e\\(lse\\|n\\(ableextensions\\|dlocal\\)" + "\\|qu\\|rrorlevel\\|xist\\)\\|for\\|" + "goto\\|i[fn]\\|n\\(eq\\|ot\\)\\|setlocal\\)\\>") + + ; built-in DOS commands + (cons (concat "\\<\\(a\\(ssoc\\|t\\(\\|trib\\)\\)\\|break\\|" + "c\\(a\\(cls\\|ll\\)\\|d\\|h\\(cp\\|dir\\|k\\(" + "dsk\\|ntfs\\)\\)\\|ls\\|md\\|o\\(lor\\|mp\\(\\|act\\)" + "\\|nvert\\|py\\)\\)\\|d\\(ate\\|el\\|i\\(" + "r\\|skco\\(mp\\|py\\)\\)\\|oskey\\)\\|" + "e\\(cho\\|rase\\|xit\\)\\|" + "f\\(c\\|ind\\(\\|str\\)\\|for\\(\\|mot\\)\\|type\\)\\|" + "graftabl\\|help\\|label\\|" + "m\\(d\\|mkdir\\|o[dvr]e\\)\\|p\\(a\\(th\\|use\\)" + "\\|opd\\|r\\(int\\|opmt\\)\\|ushd\\)\\|" + "r\\(d\\|e\\(cover\\|n\\(\\|ame\\)\\|place\\)\\|mdir\\)\\|" + "s\\(et\\|hift\\|ort\\|tart\\|ubst\\)\\|" + "t\\(i\\(me\\|tle\\)\\|ree\\|ype\\)\\|" + "v\\(er\\(\\|ify\\)\\|ol\\)\\|xcopy\\)\\>") + 'font-lock-builtin-face) + + ; variables are embeded in percent chars + '( "%[a-zA-Z0-9_]+%?" . font-lock-variable-name-face) + ; labels are formatted as constants + '( ":[a-zA-Z0-9_]+" . font-lock-constant-face) + + ; command line switches are hilighted as type-face + '( "[-/][a-zA-Z0-9_]+" . font-lock-type-face) + + ; variables set should also be hilighted with variable-name-face + '( "\\<set\\>[ \t]*\\([a-zA-Z0-9_]+\\)" (1 font-lock-variable-name-face)) + ))) + + +;;;###autoload +(defun batch-mode () + "Major mode for editing batch scripts." + (interactive) + (kill-all-local-variables) + (setq major-mode 'batch-mode) + (setq mode-name "Avenue") + (set (make-local-variable 'indent-line-function) 'batch-indent-line) + (set (make-local-variable 'comment-start) "rem") + (set (make-local-variable 'comment-start-skip) "rem[ \t]*") + (set (make-local-variable 'font-lock-defaults) + '(batch-font-lock-keywords nil t nil)) + (run-hooks 'batch-mode-hook)) + +(defun batch-indent-line () + "Indent current line as batch script" + (let ((indent (batch-calculate-indent)) + beg shift-amt + (old-pos (- (point-max) (point)))) + (beginning-of-line) + (setq beg (point)) + (skip-chars-forward " \t") + (if (looking-at ")") + (setq indent (max (- indent batch-indent-level)))) + (message "prev indent: %d" indent) + (setq shift-amt (- indent (current-column))) + (if (not (zerop shift-amt)) + (progn + (delete-region beg (point)) + ; ArcView replaces tabs with single spaces, so we only insert + ; spaces to make indentation correct in ArcView. + (insert-char ? indent) + (if (> (- (point-max) old-pos) (point)) + (goto-char (- (point-max) old-pos))))) + shift-amt)) + +(defun batch-calculate-indent () + "Return appropriate indentation for the current line as batch code." + (save-excursion + (beginning-of-line) + (current-indentation) + (if (bobp) + 0 + (if (re-search-backward "^[ \t]*[^ \t\n\r]" nil t) + (if (looking-at "[ \t]*\\()[ \t]*else\\|for\\|if\\)\\>[^(\n]*([^)\n]*") + (+ (current-indentation) batch-indent-level) + (if (looking-at "[ \t]*[^(]*)[ \t]*") + (- (current-indentation) batch-indent-level) + (current-indentation))) + 0)))) + +(add-to-list 'auto-mode-alist '("\\.bat\\'" . batch-mode)) + +(provide 'batch-mode) + +;;; batch-mode.el ends here diff --git a/.emacs.d/elisp/cmake-mode.el b/.emacs.d/elisp/cmake-mode.el new file mode 100644 index 0000000..2f51f83 --- /dev/null +++ b/.emacs.d/elisp/cmake-mode.el @@ -0,0 +1,339 @@ +;============================================================================= +; CMake - Cross Platform Makefile Generator +; Copyright 2000-2009 Kitware, Inc., Insight Software Consortium +; +; Distributed under the OSI-approved BSD License (the "License"); +; see accompanying file Copyright.txt for details. +; +; This software is distributed WITHOUT ANY WARRANTY; without even the +; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +; See the License for more information. +;============================================================================= +;;; cmake-mode.el --- major-mode for editing CMake sources + +;------------------------------------------------------------------------------ + +;;; Commentary: + +;; Provides syntax highlighting and indentation for CMakeLists.txt and +;; *.cmake source files. +;; +;; Add this code to your .emacs file to use the mode: +;; +;; (setq load-path (cons (expand-file-name "/dir/with/cmake-mode") load-path)) +;; (require 'cmake-mode) +;; (setq auto-mode-alist +;; (append '(("CMakeLists\\.txt\\'" . cmake-mode) +;; ("\\.cmake\\'" . cmake-mode)) +;; auto-mode-alist)) + +;------------------------------------------------------------------------------ + +;;; Code: +;; +;; cmake executable variable used to run cmake --help-command +;; on commands in cmake-mode +;; +;; cmake-command-help Written by James Bigler +;; + +(defcustom cmake-mode-cmake-executable "cmake" + "*The name of the cmake executable. + +This can be either absolute or looked up in $PATH. You can also +set the path with these commands: + (setenv \"PATH\" (concat (getenv \"PATH\") \";C:\\\\Program Files\\\\CMake 2.8\\\\bin\")) + (setenv \"PATH\" (concat (getenv \"PATH\") \":/usr/local/cmake/bin\"))" + :type 'file + :group 'cmake) +;; +;; Regular expressions used by line indentation function. +;; +(defconst cmake-regex-blank "^[ \t]*$") +(defconst cmake-regex-comment "#.*") +(defconst cmake-regex-paren-left "(") +(defconst cmake-regex-paren-right ")") +(defconst cmake-regex-argument-quoted + "\"\\([^\"\\\\]\\|\\\\\\(.\\|\n\\)\\)*\"") +(defconst cmake-regex-argument-unquoted + "\\([^ \t\r\n()#\"\\\\]\\|\\\\.\\)\\([^ \t\r\n()#\\\\]\\|\\\\.\\)*") +(defconst cmake-regex-token (concat "\\(" cmake-regex-comment + "\\|" cmake-regex-paren-left + "\\|" cmake-regex-paren-right + "\\|" cmake-regex-argument-unquoted + "\\|" cmake-regex-argument-quoted + "\\)")) +(defconst cmake-regex-indented (concat "^\\(" + cmake-regex-token + "\\|" "[ \t\r\n]" + "\\)*")) +(defconst cmake-regex-block-open + "^\\(IF\\|MACRO\\|FOREACH\\|ELSE\\|ELSEIF\\|WHILE\\|FUNCTION\\)$") +(defconst cmake-regex-block-close + "^[ \t]*\\(ENDIF\\|ENDFOREACH\\|ENDMACRO\\|ELSE\\|ELSEIF\\|ENDWHILE\\|ENDFUNCTION\\)[ \t]*(") + +;------------------------------------------------------------------------------ + +;; +;; Helper functions for line indentation function. +;; +(defun cmake-line-starts-inside-string () + "Determine whether the beginning of the current line is in a string." + (if (save-excursion + (beginning-of-line) + (let ((parse-end (point))) + (beginning-of-buffer) + (nth 3 (parse-partial-sexp (point) parse-end)) + ) + ) + t + nil + ) + ) + +(defun cmake-find-last-indented-line () + "Move to the beginning of the last line that has meaningful indentation." + (let ((point-start (point)) + region) + (forward-line -1) + (setq region (buffer-substring-no-properties (point) point-start)) + (while (and (not (bobp)) + (or (looking-at cmake-regex-blank) + (not (and (string-match cmake-regex-indented region) + (= (length region) (match-end 0)))))) + (forward-line -1) + (setq region (buffer-substring-no-properties (point) point-start)) + ) + ) + ) + +;------------------------------------------------------------------------------ + +;; +;; Line indentation function. +;; +(defun cmake-indent () + "Indent current line as CMAKE code." + (interactive) + (if (cmake-line-starts-inside-string) + () + (if (bobp) + (cmake-indent-line-to 0) + (let (cur-indent) + + (save-excursion + (beginning-of-line) + + (let ((point-start (point)) + token) + + ; Search back for the last indented line. + (cmake-find-last-indented-line) + + ; Start with the indentation on this line. + (setq cur-indent (current-indentation)) + + ; Search forward counting tokens that adjust indentation. + (while (re-search-forward cmake-regex-token point-start t) + (setq token (match-string 0)) + (if (string-match (concat "^" cmake-regex-paren-left "$") token) + (setq cur-indent (+ cur-indent cmake-tab-width)) + ) + (if (string-match (concat "^" cmake-regex-paren-right "$") token) + (setq cur-indent (- cur-indent cmake-tab-width)) + ) + (if (and + (string-match cmake-regex-block-open token) + (looking-at (concat "[ \t]*" cmake-regex-paren-left)) + ) + (setq cur-indent (+ cur-indent cmake-tab-width)) + ) + ) + (goto-char point-start) + + ; If this is the end of a block, decrease indentation. + (if (looking-at cmake-regex-block-close) + (setq cur-indent (- cur-indent cmake-tab-width)) + ) + ) + ) + + ; Indent this line by the amount selected. + (if (< cur-indent 0) + (cmake-indent-line-to 0) + (cmake-indent-line-to cur-indent) + ) + ) + ) + ) + ) + +(defun cmake-point-in-indendation () + (string-match "^[ \\t]*$" (buffer-substring (point-at-bol) (point)))) + +(defun cmake-indent-line-to (column) + "Indent the current line to COLUMN. +If point is within the existing indentation it is moved to the end of +the indentation. Otherwise it retains the same position on the line" + (if (cmake-point-in-indendation) + (indent-line-to column) + (save-excursion (indent-line-to column)))) + +;------------------------------------------------------------------------------ + +;; +;; Helper functions for buffer +;; +(defun unscreamify-cmake-buffer () + "Convert all CMake commands to lowercase in buffer." + (interactive) + (setq save-point (point)) + (goto-char (point-min)) + (while (re-search-forward "^\\([ \t]*\\)\\(\\w+\\)\\([ \t]*(\\)" nil t) + (replace-match + (concat + (match-string 1) + (downcase (match-string 2)) + (match-string 3)) + t)) + (goto-char save-point) + ) + +;------------------------------------------------------------------------------ + +;; +;; Keyword highlighting regex-to-face map. +;; +(defconst cmake-font-lock-keywords + (list '("^[ \t]*\\(\\w+\\)[ \t]*(" 1 font-lock-function-name-face)) + "Highlighting expressions for CMAKE mode." + ) + +;------------------------------------------------------------------------------ + +;; +;; Syntax table for this mode. Initialize to nil so that it is +;; regenerated when the cmake-mode function is called. +;; +(defvar cmake-mode-syntax-table nil "Syntax table for cmake-mode.") +(setq cmake-mode-syntax-table nil) + +;; +;; User hook entry point. +;; +(defvar cmake-mode-hook nil) + +;; +;; Indentation increment. +;; +(defvar cmake-tab-width 2) + +;------------------------------------------------------------------------------ + +;; +;; CMake mode startup function. +;; +(defun cmake-mode () + "Major mode for editing CMake listfiles." + (interactive) + (kill-all-local-variables) + (setq major-mode 'cmake-mode) + (setq mode-name "CMAKE") + + ; Create the syntax table + (setq cmake-mode-syntax-table (make-syntax-table)) + (set-syntax-table cmake-mode-syntax-table) + (modify-syntax-entry ?_ "w" cmake-mode-syntax-table) + (modify-syntax-entry ?\( "()" cmake-mode-syntax-table) + (modify-syntax-entry ?\) ")(" cmake-mode-syntax-table) + (modify-syntax-entry ?# "<" cmake-mode-syntax-table) + (modify-syntax-entry ?\n ">" cmake-mode-syntax-table) + + ; Setup font-lock mode. + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults '(cmake-font-lock-keywords)) + + ; Setup indentation function. + (make-local-variable 'indent-line-function) + (setq indent-line-function 'cmake-indent) + + ; Setup comment syntax. + (make-local-variable 'comment-start) + (setq comment-start "#") + + ; Run user hooks. + (run-hooks 'cmake-mode-hook)) + +; Help mode starts here + + +(defun cmake-command-run (type &optional topic) + "Runs the command cmake with the arguments specified. The +optional argument topic will be appended to the argument list." + (interactive "s") + (let* ((bufname (concat "*CMake" type (if topic "-") topic "*")) + (buffer (get-buffer bufname)) + ) + (if buffer + (display-buffer buffer 'not-this-window) + ;; Buffer doesn't exist. Create it and fill it + (setq buffer (generate-new-buffer bufname)) + (setq command (concat cmake-mode-cmake-executable " " type " " topic)) + (message "Running %s" command) + ;; We don't want the contents of the shell-command running to the + ;; minibuffer, so turn it off. A value of nil means don't automatically + ;; resize mini-windows. + (setq resize-mini-windows-save resize-mini-windows) + (setq resize-mini-windows nil) + (shell-command command buffer) + ;; Save the original window, so that we can come back to it later. + ;; save-excursion doesn't seem to work for this. + (setq window (selected-window)) + ;; We need to select it so that we can apply special modes to it + (select-window (display-buffer buffer 'not-this-window)) + (cmake-mode) + (toggle-read-only t) + ;; Restore the original window + (select-window window) + (setq resize-mini-windows resize-mini-windows-save) + ) + ) + ) + +(defun cmake-help-list-commands () + "Prints out a list of the cmake commands." + (interactive) + (cmake-command-run "--help-command-list") + ) + +(defvar cmake-help-command-history nil "Topic read history.") + +(require 'thingatpt) +(defun cmake-get-topic (type) + "Gets the topic from the minibuffer input. The default is the word the cursor is on." + (interactive) + (let* ((default-entry (word-at-point)) + (input (read-string + (format "CMake %s (default %s): " type default-entry) ; prompt + nil ; initial input + 'cmake-help-command-history ; command history + default-entry ; default-value + ))) + (if (string= input "") + (error "No argument given") + input)) + ) + + +(defun cmake-help-command () + "Prints out the help message corresponding to the command the cursor is on." + (interactive) + (setq command (cmake-get-topic "command")) + (cmake-command-run "--help-command" (downcase command)) + ) + + +; This file provides cmake-mode. +(provide 'cmake-mode) + +;;; cmake-mode.el ends here diff --git a/.emacs.d/elisp/column-marker.el b/.emacs.d/elisp/column-marker.el new file mode 100644 index 0000000..97a7d07 --- /dev/null +++ b/.emacs.d/elisp/column-marker.el @@ -0,0 +1,259 @@ +;;; column-marker.el --- Highlight certain character columns +;; +;; Filename: column-marker.el +;; Description: Highlight certain character columns +;; Author: Rick Bielawski <rbielaws@i1.net> +;; Maintainer: Rick Bielawski <rbielaws@i1.net> +;; Created: Tue Nov 22 10:26:03 2005 +;; Version: +;; Last-Updated: Fri Jan 22 11:28:48 2010 (-0800) +;; By: dradams +;; Update #: 312 +;; Keywords: tools convenience highlight +;; Compatibility: GNU Emacs 21, GNU Emacs 22, GNU Emacs 23 +;; +;; Features that might be required by this library: +;; +;; None +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; Highlights the background at a given character column. +;; +;; Commands `column-marker-1', `column-marker-2', and +;; `column-marker-3' each highlight a given column (using different +;; background colors, by default). +;; +;; - With no prefix argument, each highlights the current column +;; (where the cursor is). +;; +;; - With a non-negative numeric prefix argument, each highlights that +;; column. +;; +;; - With plain `C-u' (no number), each turns off its highlighting. +;; +;; - With `C-u C-u', each turns off all column highlighting. +;; +;; If two commands highlight the same column, the last-issued +;; highlighting command shadows the other - only the last-issued +;; highlighting is seen. If that "topmost" highlighting is then +;; turned off, the other highlighting for that column then shows +;; through. +;; +;; Examples: +;; +;; M-x column-marker-1 highlights the column where the cursor is, in +;; face `column-marker-1'. +;; +;; C-u 70 M-x column-marker-2 highlights column 70 in face +;; `column-marker-2'. +;; +;; C-u 70 M-x column-marker-3 highlights column 70 in face +;; `column-marker-3'. The face `column-marker-2' highlighting no +;; longer shows. +;; +;; C-u M-x column-marker-3 turns off highlighting for column-marker-3, +;; so face `column-marker-2' highlighting shows again for column 70. +;; +;; C-u C-u M-x column-marker-1 (or -2 or -3) erases all column +;; highlighting. +;; +;; These commands use `font-lock-fontify-buffer', so syntax +;; highlighting (`font-lock-mode') must be turned on. There might be +;; a performance impact during refontification. +;; +;; +;; Installation: Place this file on your load path, and put this in +;; your init file (`.emacs'): +;; +;; (require 'column-marker) +;; +;; Other init file suggestions (examples): +;; +;; ;; Highlight column 80 in foo mode. +;; (add-hook 'foo-mode-hook (lambda () (interactive) (column-marker-1 80))) +;; +;; ;; Use `C-c m' interactively to highlight with face `column-marker-1'. +;; (global-set-key [?\C-c ?m] 'column-marker-1) +;; +;; +;; Please report any bugs! +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Change log: +;; +;; 2009/12/10 dadams +;; column-marker-internal: Quote the face. Thx to Johan Bockgård. +;; 2009/12/09 dadams +;; column-marker-find: fset a symbol to the function, and return the symbol. +;; 2008/01/21 dadams +;; Renamed faces by dropping suffix "-face". +;; 2006/08/18 dadams +;; column-marker-create: Add newlines to doc-string sentences. +;; 2005/12/31 dadams +;; column-marker-create: Add marker to column-marker-vars inside the defun, +;; so it is done in the right buffer, updating column-marker-vars buffer-locally. +;; column-marker-find: Corrected comment. Changed or to progn for clarity. +;; 2005/12/29 dadams +;; Updated wrt new version of column-marker.el (multi-column characters). +;; Corrected stray occurrences of column-marker-here to column-marker-1. +;; column-marker-vars: Added make-local-variable. +;; column-marker-create: Changed positive to non-negative. +;; column-marker-internal: Turn off marker when col is negative, not < 1. +;; 2005-12-29 RGB +;; column-marker.el now supports multi-column characters. +;; 2005/11/21 dadams +;; Combined static and dynamic. +;; Use separate faces for each marker. Different interactive spec. +;; 2005/10/19 RGB +;; Initial release of column-marker.el. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth +;; Floor, Boston, MA 02110-1301, USA. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Code: + +;;;;;;;;;;;;;;;;;;;;;; + + +(defface column-marker-1 '((t (:background "gray"))) + "Face used for a column marker. Usually a background color." + :group 'faces) + +(defvar column-marker-1-face 'column-marker-1 + "Face used for a column marker. Usually a background color. +Changing this directly affects only new markers.") + +(defface column-marker-2 '((t (:background "cyan3"))) + "Face used for a column marker. Usually a background color." + :group 'faces) + +(defvar column-marker-2-face 'column-marker-2 + "Face used for a column marker. Usually a background color. +Changing this directly affects only new markers." ) + +(defface column-marker-3 '((t (:background "orchid3"))) + "Face used for a column marker. Usually a background color." + :group 'faces) + +(defvar column-marker-3-face 'column-marker-3 + "Face used for a column marker. Usually a background color. +Changing this directly affects only new markers." ) + +(defvar column-marker-vars () + "List of all internal column-marker variables") +(make-variable-buffer-local 'column-marker-vars) ; Buffer local in all buffers. + +(defmacro column-marker-create (var &optional face) + "Define a column marker named VAR. +FACE is the face to use. If nil, then face `column-marker-1' is used." + (setq face (or face 'column-marker-1)) + `(progn + ;; define context variable ,VAR so marker can be removed if desired + (defvar ,var () + "Buffer local. Used internally to store column marker spec.") + ;; context must be buffer local since font-lock is + (make-variable-buffer-local ',var) + ;; Define wrapper function named ,VAR to call `column-marker-internal' + (defun ,var (arg) + ,(concat "Highlight column with face `" (symbol-name face) + "'.\nWith no prefix argument, highlight current column.\n" + "With non-negative numeric prefix arg, highlight that column number.\n" + "With plain `C-u' (no number), turn off this column marker.\n" + "With `C-u C-u' or negative prefix arg, turn off all column-marker highlighting.") + (interactive "P") + (unless (memq ',var column-marker-vars) (push ',var column-marker-vars)) + (cond ((null arg) ; Default: highlight current column. + (column-marker-internal ',var (1+ (current-column)) ,face)) + ((consp arg) + (if (= 4 (car arg)) + (column-marker-internal ',var nil) ; `C-u': Remove this column highlighting. + (dolist (var column-marker-vars) + (column-marker-internal var nil)))) ; `C-u C-u': Remove all column highlighting. + ((and (integerp arg) (>= arg 0)) ; `C-u 70': Highlight that column. + (column-marker-internal ',var (1+ (prefix-numeric-value arg)) ,face)) + (t ; `C-u -40': Remove all column highlighting. + (dolist (var column-marker-vars) + (column-marker-internal var nil))))))) + +(defun column-marker-find (col) + "Defines a function to locate a character in column COL. +Returns the function symbol, named `column-marker-move-to-COL'." + (let ((fn-symb (intern (format "column-marker-move-to-%d" col)))) + (fset `,fn-symb + `(lambda (end) + (let ((start (point))) + (when (> end (point-max)) (setq end (point-max))) + + ;; Try to keep `move-to-column' from going backward, though it still can. + (unless (< (current-column) ,col) (forward-line 1)) + + ;; Again, don't go backward. Try to move to correct column. + (when (< (current-column) ,col) (move-to-column ,col)) + + ;; If not at target column, try to move to it. + (while (and (< (current-column) ,col) (< (point) end) + (= 0 (+ (forward-line 1) (current-column)))) ; Should be bol. + (move-to-column ,col)) + + ;; If at target column, not past end, and not prior to start, + ;; then set match data and return t. Otherwise go to start + ;; and return nil. + (if (and (= ,col (current-column)) (<= (point) end) (> (point) start)) + (progn (set-match-data (list (1- (point)) (point))) + t) ; Return t. + (goto-char start) + nil)))) ; Return nil. + fn-symb)) + +(defun column-marker-internal (sym col &optional face) + "SYM is the symbol for holding the column marker context. +COL is the column in which a marker should be set. +Supplying nil or 0 for COL turns off the marker. +FACE is the face to use. If nil, then face `column-marker-1' is used." + (setq face (or face 'column-marker-1)) + (when (symbol-value sym) ; Remove any previously set column marker + (font-lock-remove-keywords nil (symbol-value sym)) + (set sym nil)) + (when (or (listp col) (< col 0)) (setq col nil)) ; Allow nonsense stuff to turn off the marker + (when col ; Generate a new column marker + (set sym `((,(column-marker-find col) (0 ',face prepend t)))) + (font-lock-add-keywords nil (symbol-value sym) t)) + (font-lock-fontify-buffer)) + +;; If you need more markers you can create your own similarly. +;; All markers can be in use at once, and each is buffer-local, +;; so there is no good reason to define more unless you need more +;; markers in a single buffer. +(column-marker-create column-marker-1 column-marker-1-face) +(column-marker-create column-marker-2 column-marker-2-face) +(column-marker-create column-marker-3 column-marker-3-face) + +;;;###autoload +(autoload 'column-marker-1 "column-marker" "Highlight a column." t) + +;;;;;;;;;;;;;;;;;; + +(provide 'column-marker) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; column-marker.el ends here diff --git a/.emacs.d/elisp/csharp-mode.el b/.emacs.d/elisp/csharp-mode.el new file mode 100644 index 0000000..9cd7914 --- /dev/null +++ b/.emacs.d/elisp/csharp-mode.el @@ -0,0 +1,1977 @@ +;;; csharp-mode.el --- C# mode derived mode + +;; Author: Dylan R. E. Moonfire +;; Maintainer: Dylan R. E. Moonfire <contact@mfgames.com> +;; Created: Feburary 2005 +;; Modified: February 2010 +;; Version: 0.7.4 - Dino Chiesa <dpchiesa@hotmail.com> +;; Keywords: c# languages oop mode + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; +;; This is a separate mode to implement the C# constructs and +;; font-locking. It is based on the java-mode example from cc-mode. +;; +;; csharp-mode requires CC Mode 5.30 or later. It works with +;; cc-mode 5.31.3, which is current at this time. +;; +;; Features: +;; +;; - font-lock and indent of C# syntax including: +;; all c# keywords and major syntax +;; attributes that decorate methods, classes, fields, properties +;; enum types +;; #if/#endif #region/#endregion +;; instance initializers +;; anonymous functions and methods +;; verbatim literal strings (those that begin with @) +;; generics +;; +;; - automagic code-doc generation when you type three slashes. +;; +;; - intelligent inserttion of matched pairs of curly braces. +;; +;; - sets the compiler regex for next-error, for csc.exe output. +;; +;; + + +;;; To use: +;; +;; put this in your .emacs: +;; +;; (autoload 'csharp-mode "csharp-mode" "Major mode for editing C# code." t) +;; +;; or: +;; +;; (require 'csharp-mode) +;; +;; +;; AND: +;; +;; (setq auto-mode-alist +;; (append '(("\\.cs$" . csharp-mode)) auto-mode-alist)) +;; (defun my-csharp-mode-fn () +;; "function that runs when csharp-mode is initialized for a buffer." +;; ...insert your code here... +;; ...most commonly, your custom key bindings ... +;; ) +;; (add-hook 'csharp-mode-hook 'my-csharp-mode-fn t) +;; +;; + + +;;; Bugs: +;; +;; Namespaces in the using statements are not fontified. Should do in +;; c-basic-matchers-before or c-basic-matchers-after. +;; +;; Method names with a preceding attribute are not fontified. +;; +;; Field/Prop names inside object initializers are fontified only +;; if the null constructor is used, with no parens. +;; +;; This code doesn't seem to work when you compile it, then +;; load/require in the emacs file. You will get an error (error +;; "`c-lang-defconst' must be used in a file") which happens because +;; cc-mode doesn't think it is in a buffer while loading directly +;; from the init. However, if you call it based on a file extension, +;; it works properly. Interestingly enough, this doesn't happen if +;; you don't byte-compile cc-mode. +;; +;; +;; +;; Todo: +;; +;; Get csharp-mode.el accepted as part of the emacs standard distribution. +;; Must contact monnier at iro.umontreal.ca to make this happen. +;; +;; +;; +;; Acknowledgements: +;; +;; Thanks to Alan Mackenzie and Stefan Monnier for answering questions +;; and making suggestions. +;; +;; + +;;; Versions: +;; +;; 0.1.0 - Initial release. +;; 0.2.0 - Fixed the identification on the "enum" keyword. +;; - Fixed the font-lock on the "base" keyword +;; 0.3.0 - Added a regex to fontify attributes. It isn't the +;; the best method, but it handles single-like attributes +;; well. +;; - Got "super" not to fontify as a keyword. +;; - Got extending classes and interfaces to fontify as something. +;; 0.4.0 - Removed the attribute matching because it broke more than +;; it fixed. +;; - Corrected a bug with namespace not being properly identified +;; and treating the class level as an inner object, which screwed +;; up formatting. +;; - Added "partial" to the keywords. +;; 0.5.0 - Found bugs with compiled cc-mode and loading from init files. +;; - Updated the eval-when-compile to code to let the mode be +;; compiled. +;; 0.6.0 - Added the c-filter-ops patch for 5.31.1 which made that +;; function in cc-langs.el unavailable. +;; - Added a csharp-lineup-region for indention #region and +;; #endregion block differently. +;; 0.7.0 - Added autoload so update-directory-autoloads works +;; (Thank you, Nikolaj Schumacher) +;; - Fontified the entire #region and #endregion lines. +;; - Initial work to get get, set, add, remove font-locked. +;; 0.7.1 - Added option to indent #if/endif with code +;; - Fixed c-opt-cpp-prefix defn (it must not include the BOL +;; char (^). +;; - proper fontification and indent of classes that inherit +;; (previously the colon was confusing the parser) +;; - reclassified namespace as a block beginner +;; - removed $ as a legal symbol char - not legal in C#. +;; - added struct to c-class-decl-kwds so indent is correct +;; within a struct. +;; 0.7.2 - Added automatic codedoc insertion. +;; 0.7.3 - Instance initializers (new Type { ... } ) and +;; (new Type() { ...} ) are now indented properly. +;; - proper fontification and indent of enums as brace-list-*, +;; including special treatment for enums that explicitly +;; inherit from an int type. Previously the colon was +;; confusing the parser. +;; - proper fontification of verbatim literal strings, +;; including those that end in slash. This edge case was not +;; handled at all before; it is now handled correctly. +;; - code cleanup and organization; removed the linefeed. +;; - intelligent curly-brace insertion +;; 0.7.4 - added a C# style +;; - using is now a keyword and gets fontified +;; - fixed a bug that had crept into the codedoc insertion +;; + + +(require 'cc-mode) + +(message (concat "Loading " load-file-name)) + + +;; ================================================================== +;; c# upfront stuff +;; ================================================================== + +;; This is a copy of the function in cc-mode which is used to handle +;; the eval-when-compile which is needed during other times. +(defun c-filter-ops (ops opgroup-filter op-filter &optional xlate) + ;; See cc-langs.el, a direct copy. + (unless (listp (car-safe ops)) + (setq ops (list ops))) + (cond ((eq opgroup-filter t) + (setq opgroup-filter (lambda (opgroup) t))) + ((not (functionp opgroup-filter)) + (setq opgroup-filter `(lambda (opgroup) + (memq opgroup ',opgroup-filter))))) + (cond ((eq op-filter t) + (setq op-filter (lambda (op) t))) + ((stringp op-filter) + (setq op-filter `(lambda (op) + (string-match ,op-filter op))))) + (unless xlate + (setq xlate 'identity)) + (c-with-syntax-table (c-lang-const c-mode-syntax-table) + (delete-duplicates + (mapcan (lambda (opgroup) + (when (if (symbolp (car opgroup)) + (when (funcall opgroup-filter (car opgroup)) + (setq opgroup (cdr opgroup)) + t) + t) + (mapcan (lambda (op) + (when (funcall op-filter op) + (let ((res (funcall xlate op))) + (if (listp res) res (list res))))) + opgroup))) + ops) + :test 'equal))) + + + +;; These are only required at compile time to get the sources for the +;; language constants. (The cc-fonts require and the font-lock +;; related constants could additionally be put inside an +;; (eval-after-load "font-lock" ...) but then some trickery is +;; necessary to get them compiled.) +(eval-when-compile + (let ((load-path + (if (and (boundp 'byte-compile-dest-file) + (stringp byte-compile-dest-file)) + (cons (file-name-directory byte-compile-dest-file) load-path) + load-path))) + (load "cc-mode" nil t) + (load "cc-fonts" nil t) + (load "cc-langs" nil t))) + +(eval-and-compile + ;; Make our mode known to the language constant system. Use Java + ;; mode as the fallback for the constants we don't change here. + ;; This needs to be done also at compile time since the language + ;; constants are evaluated then. + (c-add-language 'csharp-mode 'java-mode)) + +;; ================================================================== +;; end of c# upfront stuff +;; ================================================================== + + + + + +;; ================================================================== +;; csharp-mode utility and feature defuns +;; ================================================================== + +;; Indention: csharp-mode follows normal indention rules except for +;; when indenting the #region and #endregion blocks. This function +;; defines a custom indention to indent the #region blocks properly +;; + +(defun csharp-lineup-region (langelem) + "Indent all #region and #endregion blocks inline with code while +retaining normal column-zero indention for #if and the other +processing blocks. + +To use this indenting just put the following in your emacs file: + (c-set-offset 'cpp-macro 'csharp-lineup-region) + +An alternative is to use `csharp-lineup-if-and-region'. +" + + (save-excursion + (back-to-indentation) + (if (re-search-forward "#\\(end\\)?region" (c-point 'eol) [0]) 0 [0]))) + + + +(defun csharp-lineup-if-and-region (langelem) + +"Indent all #region/endregion blocks and #if/endif blocks inline +with code while retaining normal column-zero indention for any +other processing blocks. + +To use this indenting just put the following in your emacs file: + (c-set-offset 'cpp-macro 'csharp-lineup-if-and-region) + +Another option is to use `csharp-lineup-region'. + +" + (save-excursion + (back-to-indentation) + (if (re-search-forward "#\\(\\(end\\)?\\(if\\|region\\)\\|else\\)" (c-point 'eol) [0]) 0 [0]))) + + + + + +(defun csharp-insert-open-brace () + "Intelligently insert a pair of curly braces. This fn is most +often bound to the open-curly brace, with + + (local-set-key (kbd \"{\") 'csharp-insert-open-brace) + +The default binding for an open curly brace in cc-modes is often +`c-electric-brace' or `skeleton-pair-insert-maybe'. The former +can be configured to insert newlines around braces in various +syntactic positions. The latter inserts a pair of braces and +then does not insert a newline, and does not indent. + +This fn provides another option, with some additional +intelligence for csharp-mode. When you type an open curly, the +appropriate pair of braces appears, with spacing and indent set +in a context-sensitive manner. + +Within a string literal, you just get a pair of braces, and point +is set between them. Following an equals sign, you get a pair of +braces, with a semincolon appended. Otherwise, you +get the open brace on a new line, with the closing brace on the +line following. + +There may be another way to get this to happen appropriately just within emacs, +but I could not figure out how to do it. So I wrote this alternative. +" + (interactive) + (let + (tpoint + (in-string (string= (csharp-in-literal) "string")) + (preceding3 + (save-excursion + (and + (skip-chars-backward " ") + (> (- (point) 2) (point-min)) + (buffer-substring-no-properties (point) (- (point) 3))))) + (one-word-back + (save-excursion + (backward-word 2) + (thing-at-point 'word)))) + + (cond + + ;; Case 1: inside a string literal? + ;; -------------------------------------------- + ;; If so, then just insert a pair of braces and put the point + ;; between them. The most common case is a format string for + ;; String.Format() or Console.WriteLine(). + (in-string + (self-insert-command 1) + (insert "}") + (backward-char)) + + ;; Case 2: the open brace starts an array initializer. + ;; -------------------------------------------- + ;; When the last non-space was an equals sign or square brackets, + ;; then it's an initializer. + ((save-excursion + (backward-sexp) + (looking-at "\\(\\w+\\b *=\\|[[]]+\\)")) + (self-insert-command 1) + (insert " };") + (backward-char 3)) + + ;; Case 3: the open brace starts an instance initializer + ;; -------------------------------------------- + ;; If one-word-back was "new", then it's an object initializer. + ((string= one-word-back "new") + (save-excursion + (message "object initializer") + (setq tpoint (point)) ;; prepare to indent-region later + (newline) + (self-insert-command 1) + (newline-and-indent) + (newline) + (insert "};") + (c-indent-region tpoint (point)) + (previous-line) + (indent-according-to-mode) + (end-of-line) + (setq tpoint (point))) + (goto-char tpoint)) + + ;; Case 4: a lambda initialier. + ;; -------------------------------------------- + ;; If the open curly follows =>, then it's a lambda initializer. + ((string= (substring preceding3 -2) "=>") + (message "lambda init") + (self-insert-command 1) + (insert " }") + (backward-char 2)) + + ;; else, it's a new scope. (if, while, class, etc) + (t + (save-excursion + (message "new scope") + (set-mark (point)) ;; prepare to indent-region later + ;; check if the prior sexp is on the same line + (if (save-excursion + (let ((curline (line-number-at-pos)) + (aftline (progn + (backward-sexp) + (line-number-at-pos)))) + (= curline aftline))) + (newline-and-indent)) + (self-insert-command 1) + (c-indent-line-or-region) + (end-of-line) + (newline) + (insert "}") + ;;(c-indent-command) ;; not sure of the difference here + (c-indent-line-or-region) + (previous-line) + (end-of-line) + (newline-and-indent) + ;; point ends up on an empty line, within the braces, properly indented + (setq tpoint (point))) + + (goto-char tpoint))))) + + + + +;; ================================================================== +;; end of csharp-mode utility and feature defuns +;; ================================================================== + + + + + + +;; ================================================================== +;; c# values for "language constants" defined in cc-langs.el +;; ================================================================== + + +;; Java uses a series of regexes to change the font-lock for class +;; references. The problem comes in because Java uses Pascal (leading +;; space in names, SomeClass) for class and package names, but +;; Camel-casing (initial lowercase, upper case in words, +;; i.e. someVariable) for variables. The notation suggested by EMCA for C# is +;; to use Pascal notation for everything, except inner variables. So, +;; the Java regex and formatting produces very wrong results in C#. +;;(error (byte-compile-dest-file)) +;;(error (c-get-current-file)) +(c-lang-defconst c-opt-after-id-concat-key + csharp (if (c-lang-const c-opt-identifier-concat-key) + (c-lang-const c-symbol-start))) + +(c-lang-defconst c-basic-matchers-before + csharp `( + ;;;; Font-lock the attributes by searching for the + ;;;; appropriate regex and marking it as TODO. + ;;,`(,(concat "\\(" csharp-attribute-regex "\\)") + ;; 0 font-lock-function-name-face) + + ;; Put a warning face on the opener of unclosed strings that + ;; can't span lines. Later font + ;; lock packages have a `font-lock-syntactic-face-function' for + ;; this, but it doesn't give the control we want since any + ;; fontification done inside the function will be + ;; unconditionally overridden. + ,(c-make-font-lock-search-function + ;; Match a char before the string starter to make + ;; `c-skip-comments-and-strings' work correctly. + (concat ".\\(" c-string-limit-regexp "\\)") + '((c-font-lock-invalid-string))) + + ;; Fontify keyword constants. + ,@(when (c-lang-const c-constant-kwds) + (let ((re (c-make-keywords-re nil + (c-lang-const c-constant-kwds)))) + `((eval . (list ,(concat "\\<\\(" re "\\)\\>") + 1 c-constant-face-name))))) + + ;; Fontify all keywords except the primitive types. + ,`(,(concat "\\<" (c-lang-const c-regular-keywords-regexp)) + 1 font-lock-keyword-face) + + ;; Fontify leading identifiers in fully qualified names like + ;; "Foo.Bar". + ,@(when (c-lang-const c-opt-identifier-concat-key) + `((,(byte-compile + `(lambda (limit) + (while (re-search-forward + ,(concat "\\(\\<" ; 1 + "\\(" (c-lang-const c-symbol-key) + "\\)" ; 2 + "[ \t\n\r\f\v]*" + (c-lang-const + c-opt-identifier-concat-key) + "[ \t\n\r\f\v]*" + "\\)" + "\\(" + (c-lang-const + c-opt-after-id-concat-key) + "\\)") + limit t) + (unless (progn + (goto-char (match-beginning 0)) + (c-skip-comments-and-strings limit)) + (or (get-text-property (match-beginning 2) 'face) + (c-put-font-lock-face (match-beginning 2) + (match-end 2) + c-reference-face-name)) + (goto-char (match-end 1))))))))) + )) + + + +;; C# does not allow a leading qualifier operator. It also doesn't +;; allow the ".*" construct of Java. So, we redo this regex without +;; the "\\|\\*" regex. +(c-lang-defconst c-identifier-key + csharp (concat "\\(" (c-lang-const c-symbol-key) "\\)" ; 1 + (concat "\\(" + "[ \t\n\r\f\v]*" + (c-lang-const c-opt-identifier-concat-key) + "[ \t\n\r\f\v]*" + (concat "\\(" + "\\(" (c-lang-const c-symbol-key) "\\)" + "\\)") + "\\)*"))) + +;; C# has a few rules that are slightly different than Java for +;; operators. This also removed the Java's "super" and replaces it +;; with the C#'s "base". +(c-lang-defconst c-operators + csharp `((prefix "base"))) + + +;; C# uses CPP-like prefixes to mark #define, #region/endregion, +;; #if/else/endif, and #pragma. This regexp matches the prefix, +;; not including the beginning-of-line (BOL), and not including +;; the term after the prefix (define, pragma, etc). This regexp says +;; whitespace, followed by the prefix, followed by maybe more whitespace. + +(c-lang-defconst c-opt-cpp-prefix + csharp "\\s *#\\s *") + + +;; there are no message directives in C# +(c-lang-defconst c-cpp-message-directives + csharp nil) + +(c-lang-defconst c-cpp-expr-directives + csharp '("if")) + +(c-lang-defconst c-opt-cpp-macro-define + csharp "define") + +;; $ is not a legal char in an identifier in C#. So we need to +;; create a csharp-specific definition of this constant. +(c-lang-defconst c-symbol-chars + csharp (concat c-alnum "_")) + + +(c-lang-defconst c-colon-type-list-kwds + csharp '("class")) + +(c-lang-defconst c-block-prefix-disallowed-chars + + ;; Allow ':' for inherit list starters. + csharp (set-difference (c-lang-const c-block-prefix-disallowed-chars) + '(?: ?,))) + + +(c-lang-defconst c-assignment-operators + csharp '("=" "*=" "/=" "%=" "+=" "-=" ">>=" "<<=" "&=" "^=" "|=")) + +(c-lang-defconst c-primitive-type-kwds + ;; ECMA-344, S8 + csharp '("object" "string" "sbyte" "short" "int" "long" "byte" + "ushort" "uint" "ulong" "float" "double" "bool" "char" + "decimal" "void")) + +;; The keywords that define that the following is a type, such as a +;; class definition. +(c-lang-defconst c-type-prefix-kwds + ;; ECMA-344, S? + csharp '("class" "interface" "struct")) ;; no enum here. + ;; we want enum to be a brace list. + + +;; Type modifier keywords. They appear anywhere in types, but modify +;; instead of create one. +(c-lang-defconst c-type-modifier-kwds + ;; EMCA-344, S? + csharp '("readonly" "const")) + + +;; Tue, 20 Apr 2010 16:02 +;; need to vverify that this works for lambdas... +(c-lang-defconst c-special-brace-lists + csharp '((?{ . ?}) )) + + + +;; dinoch +;; Thu, 22 Apr 2010 18:54 +;; +;; No idea why this isn't getting set properly in the first place. +;; In cc-langs.el, it is set to the union of a bunch of things, none +;; of which include "new", or "enum". +;; +;; But somehow both of those show up in the resulting derived regexp. +;; This breaks indentation of instance initializers, such as +;; +;; var x = new Foo { ... }; +;; +;; Based on my inspection, the existing c-lang-defconst should work! +;; I don't know how to fix this c-lang-defconst, so I am re-setting this +;; variable here, to provide the regex explicitly. +;; +(c-lang-defconst c-decl-block-key + + csharp '"\\(namespace\\)\\([^[:alnum:]_]\\|$\\)\\|\\(class\\|interface\\|struct\\)\\([^[:alnum:]_]\\|$\\)" + ) + + + +;; Thu, 22 Apr 2010 14:29 +;; I want this to handle var x = new Foo[] { ... }; +;; not sure if necessary. +(c-lang-defconst c-inexpr-brace-list-kwds + csharp '("new")) + + +;; ;;(c-lang-defconst c-inexpr-class-kwds +;; ;; csharp '("new")) + + + +(c-lang-defconst c-class-decl-kwds + ;; EMCA-344, S? + csharp '("class" "interface" "struct" )) ;; no "enum"!! + + +;; The various modifiers used for class and method descriptions. +(c-lang-defconst c-modifier-kwds + csharp '("public" "partial" "private" "const" "abstract" + "protected" "ref" "out" "static" "virtual" + "override" "params" "internal")) + + +;; Thu, 22 Apr 2010 23:02 +;; Based on inspection of the cc-mode code, the c-protection-kwds +;; c-lang-const is used only for objective-c. So the value is +;; irrelevant for csharp. +(c-lang-defconst c-protection-kwds + csharp nil + ;; csharp '("private" "protected" "public" "internal") +) + + +;; Define the keywords that can have something following after them. +(c-lang-defconst c-type-list-kwds + csharp '("struct" "class" "interface" "is" "as" + "delegate" "event" "set" "get" "add" "remove")) + + +;; This allows the classes after the : in the class declartion to be +;; fontified. +(c-lang-defconst c-typeless-decl-kwds + csharp '(":")) + +;; Sets up the enum to handle the list properly, and also the new +;; keyword to handle object initializers. This requires a modified +;; c-basic-matchers-after (see above) in order to correctly fontify C# +;; 3.0 object initializers. +(c-lang-defconst c-brace-list-decl-kwds + csharp '("enum" "new")) + + +;; Statement keywords followed directly by a substatement. +;; catch is not one of them. +(c-lang-defconst c-block-stmt-1-kwds + csharp '("do" "try" "finally")) + + +;; Statement keywords followed by a paren sexp and then by a substatement. +(c-lang-defconst c-block-stmt-2-kwds + csharp '("for" "if" "switch" "while" "catch" "foreach" "using" + "checked" "unchecked" "lock")) + + +;; Statements that break out of braces +(c-lang-defconst c-simple-stmt-kwds + csharp '("return" "continue" "break" "throw" "goto" )) + +;; Statements that allow a label +;; TODO? +(c-lang-defconst c-before-label-kwds + csharp nil) + +;; Constant keywords +(c-lang-defconst c-constant-kwds + csharp '("true" "false" "null")) + +;; Keywords that start "primary expressions." +(c-lang-defconst c-primary-expr-kwds + csharp '("this" "base")) + +;; Treat namespace as an outer block so class indenting +;; works properly. +(c-lang-defconst c-other-block-decl-kwds + csharp '("namespace")) + +(c-lang-defconst c-other-kwds + csharp '("in" "sizeof" "typeof" "is" "as" "yield" + "where" "select" "from")) + +(c-lang-defconst c-overloadable-operators + ;; EMCA-344, S14.2.1 + csharp '("+" "-" "*" "/" "%" "&" "|" "^" + "<<" ">>" "==" "!=" ">" "<" ">=" "<=")) + + +;; This c-cpp-matchers stuff is used for fontification. +;; see cc-font.el +;; + +;; There's no preprocessor in C#, but there are still compiler +;; directives to fontify: "#pragma", #region/endregion, #define, #undef, +;; #if/else/endif. (The definitions for the extra keywords above are +;; enough to incorporate them into the fontification regexps for types +;; and keywords, so no additional font-lock patterns are required for +;; keywords.) + +(c-lang-defconst c-cpp-matchers + csharp (cons + ;; Use the eval form for `font-lock-keywords' to be able to use + ;; the `c-preprocessor-face-name' variable that maps to a + ;; suitable face depending on the (X)Emacs version. + '(eval . (list "^\\s *\\(#pragma\\|undef\\|define\\)\\>\\(.*\\)" + (list 1 c-preprocessor-face-name) + '(2 font-lock-string-face))) + ;; There are some other things in `c-cpp-matchers' besides the + ;; preprocessor support, so include it. + (c-lang-const c-cpp-matchers))) + +(defcustom csharp-font-lock-extra-types nil + "*List of extra types (aside from the type keywords) to recognize in C# mode. +Each list item should be a regexp matching a single identifier." + :type 'list :group 'csharp) + +(defconst csharp-font-lock-keywords-1 (c-lang-const c-matchers-1 csharp) + "Minimal highlighting for C# mode.") + +(defconst csharp-font-lock-keywords-2 (c-lang-const c-matchers-2 csharp) + "Fast normal highlighting for C# mode.") + +(defconst csharp-font-lock-keywords-3 (c-lang-const c-matchers-3 csharp) + "Accurate normal highlighting for C# mode.") + +(defvar csharp-font-lock-keywords csharp-font-lock-keywords-3 + "Default expressions to highlight in C# mode.") + +(defvar csharp-mode-syntax-table nil + "Syntax table used in csharp-mode buffers.") +(or csharp-mode-syntax-table + (setq csharp-mode-syntax-table + (funcall (c-lang-const c-make-mode-syntax-table csharp)))) + +(defvar csharp-mode-abbrev-table nil + "Abbreviation table used in csharp-mode buffers.") +(c-define-abbrev-table 'csharp-mode-abbrev-table + ;; Keywords that if they occur first on a line might alter the + ;; syntactic context, and which therefore should trig reindentation + ;; when they are completed. + '(("else" "else" c-electric-continued-statement 0) + ("while" "while" c-electric-continued-statement 0) + ("catch" "catch" c-electric-continued-statement 0) + ("finally" "finally" c-electric-continued-statement 0))) + +(defvar csharp-mode-map (let ((map (c-make-inherited-keymap))) + ;; Add bindings which are only useful for C# + map) + "Keymap used in csharp-mode buffers.") + + +;; TODO +;; Defines our constant for finding attributes. +;;(defconst csharp-attribute-regex "\\[\\([XmlType]+\\)(") +;;(defconst csharp-attribute-regex "\\[\\(.\\)") +;; This doesn't work because the string regex happens before this point +;; and getting the font-locking to work before and after is fairly difficult +;;(defconst csharp-attribute-regex +;; (concat +;; "\\[[a-zA-Z][ \ta-zA-Z0-9.]+" +;; "\\((.*\\)?" +;;)) + + +;; ================================================================== +;; end of c# values for "language constants" defined in cc-langs.el +;; ================================================================== + + + + +;; ================================================================== +;; C# code-doc insertion magic +;; ================================================================== +;; +;; In Visual Studio, if you type three slashes, it immediately expands into +;; an inline code-documentation fragment. The following method does the +;; same thing. +;; +;; This is the kind of thing that could be handled by YASnippet or +;; another similarly flexible snippet framework. But I don't want to +;; introduce a dependency on yasnippet to csharp-mode. So the capability +;; must live within csharp-mode itself. + +(defun csharp-maybe-insert-codedoc (arg) + + "Insert an xml code documentation template as appropriate, when +typing slashes. This fn gets bound to / (the slash key), in +csharp-mode. If the slash being inserted is not the third +consecutive slash, the slash is inserted as normal. If it is the +third consecutive slash, then a xml code documentation template +may be inserted in some cases. For example, + + a <summary> template is inserted if the prior line is empty, + or contains only an open curly brace; + a <remarks> template is inserted if the prior word + closes the <summary> element; + a <returns> template is inserted if the prior word + closes the <remarks> element; + an <example> template is inserted if the prior word closes + the <returns> element; + a <para> template is inserted if the prior word closes + a <para> element. + +In all other cases the slash is inserted as normal. + +If you want the default cc-mode behavior, which implies no automatic +insertion of xml code documentation templates, then use this in +your `csharp-mode-hook' function: + + (local-set-key (kbd \"/\") 'c-electric-slash) + + " + (interactive "*p") + ;;(message "csharp-maybe-insert-codedoc") + (let ( + (cur-point (point)) + (char last-command-char) + (cb0 (char-before (- (point) 0))) + (cb1 (char-before (- (point) 1))) + is-first-non-whitespace + did-auto-insert + ) + + ;; check if two prior chars were slash + (if (and + (= char ?/) + cb0 (= ?/ cb0) + cb1 (= ?/ cb1) + ) + + (progn + ;;(message "yes - this is the third consecutive slash") + (setq is-first-non-whitespace + (save-excursion + (back-to-indentation) + (= cur-point (+ (point) 2)))) + + (if is-first-non-whitespace + ;; This is a 3-slash sequence. It is the first non-whitespace text + ;; on the line. Now we need to examine the surrounding context + ;; in order to determine which xml cod doc template to insert. + (let (word-back char0 char1 + word-fore char-0 char-1 + text-to-insert ;; text to insert in lieu of slash + fn-to-call ;; func to call after inserting text + (preceding-line-is-empty (or + (= (line-number-at-pos) 1) + (save-excursion + (previous-line) + (beginning-of-line) + (looking-at "[ \t]*$\\|[ \t]*{[ \t]*$")))) + (flavor 0) ;; used only for diagnostic purposes + ) + + ;;(message "starting a 3-slash comment") + ;; get the prior word, and the 2 chars preceding it. + (backward-word) + + (setq word-back (thing-at-point 'word) + char0 (char-before (- (point) 0)) + char1 (char-before (- (point) 1))) + + ;; restore prior position + (goto-char cur-point) + + ;; get the following word, and the 2 chars preceding it. + (forward-word) + (backward-word) + (setq word-fore (thing-at-point 'word) + char-0 (char-before (- (point) 0)) + char-1 (char-before (- (point) 1))) + + ;; restore prior position again + (goto-char cur-point) + + (cond + ;; The preceding line is empty, or all whitespace, or + ;; contains only an open-curly. In this case, insert a + ;; summary element pair. + (preceding-line-is-empty + (setq text-to-insert "/ <summary>\n/// \n/// </summary>" + flavor 1) ) + + ;; The preceding word closed a summary element. In this case, + ;; if the forward word does not open a remarks element, then + ;; insert a remarks element. + ((and (string-equal word-back "summary") (eq char0 ?/) (eq char1 ?<)) + (if (not (and (string-equal word-fore "remarks") (eq char-0 ?<))) + (setq text-to-insert "/ <remarks>\n/// <para>\n/// \n/// </para>\n/// </remarks>" + flavor 2))) + + ;; The preceding word closed the remarks section. In this case, + ;; insert an example element. + ((and (string-equal word-back "remarks") (eq char0 ?/) (eq char1 ?<)) + (setq text-to-insert "/ <example>\n/// \n/// </example>" + flavor 3)) + + ;; The preceding word closed the example section. In this + ;; case, insert an returns element. This isn't always + ;; correct, because sometimes the xml code doc is attached to + ;; a class or a property, neither of which has a return + ;; value. A more intelligent implementation would inspect the + ;; syntax state and only inject a returns element if + ;; appropriate. + ((and (string-equal word-back "example") (eq char0 ?/) (eq char1 ?<)) + (setq text-to-insert "/ <returns></returns>" + fn-to-call (lambda () + (backward-word) + (backward-char) + (backward-char) + (c-indent-line-or-region) + ) + flavor 4)) + + ;; The preceding word opened the remarks section, or it + ;; closed a para section. In this case, insert a para + ;; element, using appropriate indentation with respect to the + ;; prior tag. + ((or + (and (string-equal word-back "remarks") (eq char0 ?<) (or (eq char1 32) (eq char1 9))) + (and (string-equal word-back "para") (eq char0 ?/) (eq char1 ?<))) + + (let (prior-point spacer) + (save-excursion + (backward-word) + (backward-char) + (backward-char) + (setq prior-point (point)) + (skip-chars-backward "\t ") + (setq spacer (buffer-substring (point) prior-point)) + ;;(message (format "pt(%d) prior(%d) spacer(%s)" (point) prior-point spacer)) + ) + + (if (string-equal word-back "remarks") + (setq spacer (concat spacer " "))) + + (setq text-to-insert (format "/%s<para>\n///%s \n///%s</para>" + spacer spacer spacer) + flavor 6))) + + ;; The preceding word opened a para element. In this case, if + ;; the forward word does not close the para element, then + ;; close the para element. + ;; -- + ;; This is a nice idea but flawed. Suppose I have a para element with some + ;; text in it. If I position the cursor at the first line, then type 3 slashes, + ;; I get a close-element, and that would be inappropriate. Not sure I can + ;; easily solve that problem, so the best thing might be to simply punt, and + ;; require people to close their own elements. + ;; + ;; ( (and (string-equal word-back "para") (eq char0 60) (or (eq char1 32) (eq char1 9))) + ;; (if (not (and (string-equal word-fore "para") (eq char-0 47) (eq char-1 60) )) + ;; (setq text-to-insert "/ \n/// </para>\n///" + ;; fn-to-call (lambda () + ;; (previous-line) + ;; (end-of-line) + ;; ) + ;; flavor 7) ) + ;; ) + + ;; the default case - do nothing + (t nil)) + + (if text-to-insert + (progn + ;;(message (format "inserting special text (f(%d))" flavor)) + + ;; set the flag, that we actually inserted text + (setq did-auto-insert t) + + ;; save point of beginning of insertion + (setq cur-point (point)) + + ;; actually insert the text + (insert text-to-insert) + + ;; indent the inserted string, and re-position point, either through + ;; the case-specific fn, or via the default progn. + (if fn-to-call + (funcall fn-to-call) + + (let ((newline-count 0) (pos 0) ix) + + ;; count the number of newlines in the inserted string + (while (string-match "\n" text-to-insert pos) + (setq pos (match-end 0) + newline-count (+ newline-count 1) ) + ) + + ;; indent what we just inserted + (c-indent-region cur-point (point) t) + + ;; move up n/2 lines. This assumes that the + ;; inserted text is ~symmetric about the halfway point. + ;; The assumption holds if the xml code doc uses a + ;; begin-elt and end-elt on a new line all by themselves, + ;; and a blank line in between them where the point should be. + ;; A more intelligent implementation would use a specific + ;; marker string, like @@DOT, to note the desired point. + (previous-line (/ newline-count 2)) + (end-of-line))))))))) + + (if (not did-auto-insert) + (self-insert-command (prefix-numeric-value arg))))) + +;; ================================================================== +;; end of c# code-doc insertion magic +;; ================================================================== + + + + +;; ================================================================== +;; c# fontification extensions +;; ================================================================== +;; Commentary: +;; +;; The purpose of the following code is to fix font-lock for C#, +;; specifically for the verbatim-literal strings. C# is a cc-mode +;; language and strings are handled mostly like other c-based +;; languages. The one exception is the verbatim-literal string, which +;; uses the syntax @"...". +;; +;; `parse-partial-sexp' treats those strings as just regular strings, +;; with the @ a non-string character. This is fine, except when the +;; verblit string ends in a slash, in which case, font-lock breaks from +;; that point onward in the buffer. +;; +;; This is an attempt to fix that. +;; +;; The idea is to scan the buffer in full for verblit strings, and apply the +;; appropriate syntax-table text properties for verblit strings. Also setting +;; `parse-sexp-lookup-properties' to t tells `parse-partial-sexp' +;; to use the syntax-table text properties set up by the scan as it does +;; its parse. +;; +;; Also need to re-scan after any changes in the buffer, but on a more +;; limited region. +;; + + +;; ;; I don't remember what this is supposed to do, +;; ;; or how I figured out the value. +;; ;; +;; (defconst csharp-font-lock-syntactic-keywords +;; '(("\\(@\\)\\(\"\\)[^\"]*\\(\"\\)\\(\"\\)[^\"]*\\(\"\\)[^\"]" +;; (1 '(6)) (2 '(7)) (3 '(1)) (4 '(1)) (5 '(7)) +;; )) +;; "Highlighting of verbatim literal strings. See also the variable +;; `font-lock-keywords'.") + + + +;; Allow this: +;; (csharp-log 3 "csharp: scan...'%s'" state) + +(defvar csharp-log-level 0 + "The current log level for CSharp-specific operations. +This is used in particular by the verbatim-literal +string scanning. + +Most other csharp functions are not instrumented. +0 = NONE, 1 = Info, 2 = VERBOSE, 3 = DEBUG, 4 = SHUTUP ALREADY. ") + +(defun csharp-log (level text &rest args) + "Log a message at level LEVEL. +If LEVEL is higher than `csharp-log-level', the message is +ignored. Otherwise, it is printed using `message'. +TEXT is a format control string, and the remaining arguments ARGS +are the string substitutions (see `format')." + (if (<= level csharp-log-level) + (let* ((msg (apply 'format text args))) + (message "%s" msg) + ))) + + + +(defun csharp-max-beginning-of-stmt () + "Return the greater of `c-beginning-of-statement-1' and +`c-beginning-of-statement' . I don't understand why both of +these methods are necessary or why they differ. But they do." + + (let (dash + nodash + (curpos (point))) + + ;; I think this may need a save-excursion... + ;; Calling c-beginning-of-statement-1 resets the point! + + (setq dash (progn (c-beginning-of-statement-1) (point))) + (csharp-log 3 "C#: max-bostmt dash(%d)" dash) + (goto-char curpos) + + (setq nodash (progn (c-beginning-of-statement 1) (point))) + (csharp-log 3 "C#: max-bostmt nodash(%d)" nodash) + (goto-char curpos) + + (max dash nodash))) + + +(defun csharp-in-literal (&optional lim detect-cpp) + "Return the type of literal point is in, if any. +Basically this works like `c-in-literal' except it doesn't +use or fill the cache (`c-in-literal-cache'). + +The return value is `c' if in a C-style comment, `c++' if in a C++ +style comment, `string' if in a string literal, `pound' if DETECT-CPP +is non-nil and in a preprocessor line, or nil if somewhere else. +Optional LIM is used as the backward limit of the search. If omitted, +or nil, `c-beginning-of-syntax' is used. + +Note that this function might do hidden buffer changes. See the +comment at the start of cc-engine.el for more info." + + (let ((rtn + (save-excursion + (let* ((pos (point)) + (lim (or lim (progn + (c-beginning-of-syntax) + (point)))) + (state (parse-partial-sexp lim pos))) + (csharp-log 4 "C#: parse lim(%d) state: %s" lim (prin1-to-string state)) + (cond + ((elt state 3) + (csharp-log 4 "C#: in literal string (%d)" pos) + 'string) + ((elt state 4) + (csharp-log 4 "C#: in literal comment (%d)" pos) + (if (elt state 7) 'c++ 'c)) + ((and detect-cpp (c-beginning-of-macro lim)) 'pound) + (t nil)))))) + rtn)) + + +(defun csharp-set-vliteral-syntax-table-properties (beg end) + "Scan the buffer text between BEG and END, a verbatim literal +string, setting and clearing syntax-table text properties where +necessary. + +We need to modify the default syntax-table text property in these cases: + (backslash) - is not an escape inside a verbatim literal string. + (double-quote) - can be a literal quote, when doubled. + +BEG is the @ delimiter. END is the 'old' position of the ending quote. + +see http://www.sunsite.ualberta.ca/Documentation/Gnu/emacs-lisp-ref-21-2.7/html_node/elisp_592.html +for the list of syntax table numeric codes. + +" + + (csharp-log 3 "C#: set-vlit-syntax-table: beg(%d) end(%d)" beg end) + + (if (and (> beg 0) (> end 0)) + + (let ((curpos beg) + (state 0)) + + (c-clear-char-properties beg end 'syntax-table) + + (while (<= curpos end) + + (cond + ((= state 0) + (if (= (char-after curpos) ?@) + (progn + (c-put-char-property curpos 'syntax-table '(3)) ; (6) = expression prefix, (3) = symbol + ;;(message (format "C#: set-s-t: prefix pos(%d) chr(%c)" beg (char-after beg))) + ) + ) + (setq state (+ 1 state))) + + ((= state 1) + (if (= (char-after curpos) ?\") + (progn + (c-put-char-property curpos 'syntax-table '(7)) ; (7) = string quote + ;;(message (format "C#: set-s-t: open quote pos(%d) chr(%c)" + ;; curpos (char-after curpos))) + )) + (setq state (+ 1 state))) + + ((= state 2) + (cond + ;; handle backslash + ((= (char-after curpos) ?\\) + (c-put-char-property curpos 'syntax-table '(2)) ; (1) = punctuation, (2) = word + ;;(message (format "C#: set-s-t: backslash word pos(%d) chr(%c)" curpos (char-after curpos))) + ) + + ;; doubled double-quote + ((and + (= (char-after curpos) ?\") + (= (char-after (+ 1 curpos)) ?\")) + (c-put-char-property curpos 'syntax-table '(2)) ; (1) = punctuation, (2) = word + (c-put-char-property (+ 1 curpos) 'syntax-table '(2)) ; (1) = punctuation + ;;(message (format "C#: set-s-t: double doublequote pos(%d) chr(%c)" curpos (char-after curpos))) + (setq curpos (+ curpos 1)) + ) + + ;; a single double-quote, which should be a string terminator + ((= (char-after curpos) ?\") + (c-put-char-property curpos 'syntax-table '(7)) ; (7) = string quote + ;;(message (format "C#: set-s-t: close quote pos(%d) chr(%c)" curpos (char-after curpos))) + ;;go no further + (setq state (+ 1 state))) + + ;; everything else + (t + ;;(message (format "C#: set-s-t: none pos(%d) chr(%c)" curpos (char-after curpos))) + nil)))) + ;; next char + (setq curpos (+ curpos 1)))))) + + + +(defun csharp-end-of-verbatim-literal-string (&optional lim) + "Moves to and returns the position of the end quote of the verbatim literal +string. When calling, point should be on the @ of the verblit string. +If it is not, then no movement is performed and `point' is returned. + +This function ignores text properties. In fact it is the +underlying scanner used to set the text properties in a C# buffer. +" + + (csharp-log 3 "C#: end-of-vlit-string: point(%d) c(%c)" (point) (char-after)) + + (let (curpos + (max (or lim (point-max)))) + + (if (not (looking-at "@\"")) + (point) + (forward-char 2) ;; pass up the @ sign and first quote + (setq curpos (point)) + + ;; Within a verbatim literal string, a doubled double-quote + ;; escapes the double-quote." + (while (and ;; process characters... + (or ;; while... + (not (eq (char-after curpos) ?\")) ;; it's not a quote + (eq (char-after (+ curpos 1)) ?\")) ;; or, its a double (double) quote + (< curpos max)) ;; and we're not done yet + + (cond + ((and (eq (char-after curpos) ?\") ;; it's a double-quote. + (eq (char-after (+ curpos 1)) ?\")) + (setq curpos (+ 2 curpos))) ;; Skip 2 + (t ;; anything else + (setq curpos (+ 1 curpos))))) ;; skip fwd 1 + curpos))) + + + + +(defun csharp-scan-for-verbatim-literals-and-set-props (&optional beg end) + +"Scans the buffer, between BEG and END, for verbatim literal +strings, and sets override text properties on each string to +allow proper syntax highlighting, indenting, and cursor movement. + +BEG and END define the limits of the scan. When nil, they +default to `point-min' and `point-max' respectively. + +Setting text properties generally causes the buffer to be marked +as modified, but this fn suppresses that via the +`c-buffer-save-state' macro, for any changes in text properties +that it makes. This fn also ignores the read-only setting on a +buffer, using the same macro. + +This fn is called when a csharp-mode buffer is loaded, with BEG +and END set to nil, to do a full scan. It is also called on +every buffer change, with the BEG and END set to the values for +the change. + +The return value is nil if the buffer was not a csharp-mode +buffer. Otherwise it is the last cursor position examined by the +scan. +" + + (if (not (c-major-mode-is 'csharp-mode)) ;; don't scan if not csharp mode + nil + (save-excursion + (c-save-buffer-state + ((curpos (or beg (point-min))) + (lastpos (or end (point-max))) + (state 0) (start 0) (cycle 0) + literal eos limits) + + (csharp-log 3 "C#: scan") + (goto-char curpos) + + (while (and (< curpos lastpos) (< cycle 10000)) + (cond + + ;; Case 1: current char is a @ sign + ;; -------------------------------------------- + ;; Check to see if it demarks the beginning of a verblit + ;; string. + ((= ?@ (char-after curpos)) + + ;; are we in a comment? a string? Maybe the @ is a prefix + ;; to allow the use of a reserved word as a symbol. Let's find out. + + ;; not sure why I need both of the following. + (syntax-ppss-flush-cache 1) + (parse-partial-sexp 1 curpos) + (goto-char curpos) + (setq literal (csharp-in-literal)) + (cond + + ;; Case 1.A: it's a @ within a string. + ;; -------------------------------------------- + ;; This should never happen, because this scanner hops over strings. + ;; But it might happen if the scan starts at an odd place. + ((eq literal 'string) nil) + + ;; Case 1.B: The @ is within a comment. Hop over it. + ((and (memq literal '(c c++)) + ;; This is a kludge for XEmacs where we use + ;; `buffer-syntactic-context', which doesn't correctly + ;; recognize "\*/" to end a block comment. + ;; `parse-partial-sexp' which is used by + ;; `c-literal-limits' will however do that in most + ;; versions, which results in that we get nil from + ;; `c-literal-limits' even when `c-in-literal' claims + ;; we're inside a comment. + ;;(setq limits (c-literal-limits start))) + (setq limits (c-literal-limits))) + + ;; advance to the end of the comment + (if limits + (progn + (csharp-log 4 "C#: scan: jump end comment A (%d)" (cdr limits)) + (setq curpos (cdr limits))))) + + + ;; Case 1.B: curpos is at least 2 chars before the last + ;; position to examine, and, the following char is a + ;; double-quote (ASCII 34). + ;; -------------------------------------------- + ;; This looks like the beginning of a verbatim string + ;; literal. + ((and (< (+ 2 curpos) lastpos) + (= ?\" (char-after (+ 1 curpos)))) + + (setq eos (csharp-end-of-verbatim-literal-string)) + ;; set override syntax properties on the verblit string + (csharp-set-vliteral-syntax-table-properties curpos eos) + + (csharp-log 4 "C#: scan: jump end verblit string (%d)" eos) + (setq curpos eos)))) + + + ;; Case 2: current char is a double-quote. + ;; -------------------------------------------- + ;; If this is a string, we hop over it, on the assumption that + ;; this scanner need not bother with regular literal strings, which + ;; get the proper syntax with the generic approach. + ;; If in a comment, hop over the comment. + ((= ?\" (char-after curpos)) + (goto-char curpos) + (setq literal (c-in-literal)) + (cond + + ;; Case 2.A: a quote within a string + ;; -------------------------------------------- + ;; This shouldn't happen, because we hop over strings. + ;; But it might. + ((eq literal 'string) nil) + + ;; Case 2.B: a quote within a comment + ;; -------------------------------------------- + ((and (memq literal '(c c++)) + ;; This is a kludge for XEmacs where we use + ;; `buffer-syntactic-context', which doesn't correctly + ;; recognize "\*/" to end a block comment. + ;; `parse-partial-sexp' which is used by + ;; `c-literal-limits' will however do that in most + ;; versions, which results in that we get nil from + ;; `c-literal-limits' even when `c-in-literal' claims + ;; we're inside a comment. + ;;(setq limits (c-literal-limits start))) + (setq limits (c-literal-limits))) + + ;; advance to the end of the comment + (if limits + (progn + (setq curpos (cdr limits)) + (csharp-log 3 "C#: scan: jump end comment B (%s)" curpos)))) + + + ;; Case 2.C: Not in a comment, and not in a string. + ;; -------------------------------------------- + ;; This is the beginning of a literal (but not verbatim) string. + (t + (forward-char 1) ;; pass up the quote + (if (consp (setq limits (c-literal-limits))) + (progn + (csharp-log 4 "C#: scan: jump end literal (%d)" (cdr limits)) + (setq curpos (cdr limits)))))))) + + (setq cycle (+ 1 cycle)) + (setq curpos (+ 1 curpos)) + (c-safe (goto-char curpos))))))) + + +(defun csharp-before-font-lock (beg end old-len) + "Adjust`syntax-table' properties on the region affected by the change +in a csharp-mode buffer. + +This function is the C# value for `c-before-font-lock-function'. +It intended to be called only by the cc-mode runtime. + +It prepares the buffer for font locking, hence must get called +before `font-lock-after-change-function'. + +It does hidden buffer changes. + +BEG, END and OLD-LEN have the same meaning here as for any +after-change function. + +Point is undefined both before and after this function call. +The return value is meaningless, and is ignored by cc-mode. +" + (let ((start-scan (progn + (c-beginning-of-statement 1) + (point)))) + (csharp-scan-for-verbatim-literals-and-set-props start-scan end))) + + + +(c-lang-defconst c-before-font-lock-function + csharp 'csharp-before-font-lock) + +;; ================================================================== +;; end of c# fontification extensions +;; ================================================================== + + + + + +;; ================================================================== +;; C#-specific optimizations of cc-mode funcs +;; ================================================================== + + +;; There's never a need to check for C-style macro definitions in +;; a C# buffer. +(defadvice c-beginning-of-macro (around + csharp-mode-advice-1 + compile activate) + (if (c-major-mode-is 'csharp-mode) + nil + ad-do-it) + ) + + +;; There's never a need to move over an Obj-C directive in csharp mode +(defadvice c-forward-objc-directive (around + csharp-mode-advice-2 + compile activate) + (if (c-major-mode-is 'csharp-mode) + nil + ad-do-it) + ) + +;; ================================================================== +;; end of C#-specific optimizations of cc-mode funcs +;; ================================================================== + + + + + + + + +;; ================================================================== +;; c# - monkey-patching of basic parsing logic +;; ================================================================== +;; +;; Here, the model redefines two defuns to add special cases for csharp +;; mode. These primarily deal with indentation of instance +;; initializers, which are somewhat unique to C#. I couldn't figure out +;; how to get cc-mode to do what C# needs, without modifying these +;; defuns. +;; + +(defun c-looking-at-inexpr-block (lim containing-sexp &optional check-at-end) + ;; Return non-nil if we're looking at the beginning of a block + ;; inside an expression. The value returned is actually a cons of + ;; either 'inlambda, 'inexpr-statement or 'inexpr-class and the + ;; position of the beginning of the construct. + ;; + ;; LIM limits the backward search. CONTAINING-SEXP is the start + ;; position of the closest containing list. If it's nil, the + ;; containing paren isn't used to decide whether we're inside an + ;; expression or not. If both LIM and CONTAINING-SEXP are used, LIM + ;; needs to be farther back. + ;; + ;; If CHECK-AT-END is non-nil then extra checks at the end of the + ;; brace block might be done. It should only be used when the + ;; construct can be assumed to be complete, i.e. when the original + ;; starting position was further down than that. + ;; + ;; This function might do hidden buffer changes. + + (save-excursion + (let ((res 'maybe) passed-paren + (closest-lim (or containing-sexp lim (point-min))) + ;; Look at the character after point only as a last resort + ;; when we can't disambiguate. + (block-follows (and (eq (char-after) ?{) (point)))) + + (while (and (eq res 'maybe) + (progn (c-backward-syntactic-ws) + (> (point) closest-lim)) + (not (bobp)) + (progn (backward-char) + (looking-at "[\]\).]\\|\\w\\|\\s_")) + (c-safe (forward-char) + (goto-char (scan-sexps (point) -1)))) + + (setq res + (if (looking-at c-keywords-regexp) + (let ((kw-sym (c-keyword-sym (match-string 1)))) + (cond + ((and block-follows + (c-keyword-member kw-sym 'c-inexpr-class-kwds)) + (and (not (eq passed-paren ?\[)) + + ;; dinoch Thu, 22 Apr 2010 18:20 + ;; ============================================ + ;; looking at new MyType() { ... } + ;; means this is a brace list, so, return nil, + ;; implying NOT looking-at-inexpr-block + (not + (and (c-major-mode-is 'csharp-mode) + (looking-at "new\s+\\([[:alnum:]_]+\\)\\b"))) + + (or (not (looking-at c-class-key)) + ;; If the class instantiation is at the start of + ;; a statement, we don't consider it an + ;; in-expression class. + (let ((prev (point))) + (while (and + (= (c-backward-token-2 1 nil closest-lim) 0) + (eq (char-syntax (char-after)) ?w)) + (setq prev (point))) + (goto-char prev) + (not (c-at-statement-start-p))) + ;; Also, in Pike we treat it as an + ;; in-expression class if it's used in an + ;; object clone expression. + (save-excursion + (and check-at-end + (c-major-mode-is 'pike-mode) + (progn (goto-char block-follows) + (zerop (c-forward-token-2 1 t))) + (eq (char-after) ?\()))) + (cons 'inexpr-class (point)))) + ((c-keyword-member kw-sym 'c-inexpr-block-kwds) + (when (not passed-paren) + (cons 'inexpr-statement (point)))) + ((c-keyword-member kw-sym 'c-lambda-kwds) + (when (or (not passed-paren) + (eq passed-paren ?\()) + (cons 'inlambda (point)))) + ((c-keyword-member kw-sym 'c-block-stmt-kwds) + nil) + (t + 'maybe))) + + (if (looking-at "\\s(") + (if passed-paren + (if (and (eq passed-paren ?\[) + (eq (char-after) ?\[)) + ;; Accept several square bracket sexps for + ;; Java array initializations. + 'maybe) + (setq passed-paren (char-after)) + 'maybe) + 'maybe)))) + + (if (eq res 'maybe) + (when (and c-recognize-paren-inexpr-blocks + block-follows + containing-sexp + (eq (char-after containing-sexp) ?\()) + (goto-char containing-sexp) + (if (or (save-excursion + (c-backward-syntactic-ws lim) + (and (> (point) (or lim (point-min))) + (c-on-identifier))) + (and c-special-brace-lists + (c-looking-at-special-brace-list))) + nil + (cons 'inexpr-statement (point)))) + + res)))) + + + + +(defconst csharp-enum-decl-re + (concat + "\\<enum\\>\s+\\([[:alnum:]_]+\\)\s*:\s*" + "\\(" + (c-make-keywords-re nil + (list "sbyte" "byte" "short" "ushort" "int" "uint" "long" "ulong")) + "\\)") + "Regex that captures an enum declaration in C#" + ) + + + +(defun c-inside-bracelist-p (containing-sexp paren-state) + ;; return the buffer position of the beginning of the brace list + ;; statement if we're inside a brace list, otherwise return nil. + ;; CONTAINING-SEXP is the buffer pos of the innermost containing + ;; paren. PAREN-STATE is the remainder of the state of enclosing + ;; braces + ;; + ;; N.B.: This algorithm can potentially get confused by cpp macros + ;; placed in inconvenient locations. It's a trade-off we make for + ;; speed. + ;; + ;; This function might do hidden buffer changes. + (or + ;; This will pick up brace list declarations. + (c-safe + (save-excursion + (goto-char containing-sexp) + (c-forward-sexp -1) + (let (bracepos) + (if (and (or (looking-at c-brace-list-key) + + (progn (c-forward-sexp -1) + (looking-at c-brace-list-key)) + + ;; dinoch Thu, 22 Apr 2010 18:20 + ;; ============================================ + ;; looking enum Foo : int + ;; means this is a brace list, so, return nil, + ;; implying NOT looking-at-inexpr-block + + (and (c-major-mode-is 'csharp-mode) + (progn + (c-forward-sexp -1) + (looking-at csharp-enum-decl-re)))) + + (setq bracepos (c-down-list-forward (point))) + (not (c-crosses-statement-barrier-p (point) + (- bracepos 2)))) + (point))))) + ;; this will pick up array/aggregate init lists, even if they are nested. + (save-excursion + (let ((class-key + ;; Pike can have class definitions anywhere, so we must + ;; check for the class key here. + (and (c-major-mode-is 'pike-mode) + c-decl-block-key)) + bufpos braceassignp lim next-containing) + (while (and (not bufpos) + containing-sexp) + (when paren-state + (if (consp (car paren-state)) + (setq lim (cdr (car paren-state)) + paren-state (cdr paren-state)) + (setq lim (car paren-state))) + (when paren-state + (setq next-containing (car paren-state) + paren-state (cdr paren-state)))) + (goto-char containing-sexp) + (if (c-looking-at-inexpr-block next-containing next-containing) + ;; We're in an in-expression block of some kind. Do not + ;; check nesting. We deliberately set the limit to the + ;; containing sexp, so that c-looking-at-inexpr-block + ;; doesn't check for an identifier before it. + (setq containing-sexp nil) + ;; see if the open brace is preceded by = or [...] in + ;; this statement, but watch out for operator= + (setq braceassignp 'dontknow) + (c-backward-token-2 1 t lim) + ;; Checks to do only on the first sexp before the brace. + (when (and c-opt-inexpr-brace-list-key + (eq (char-after) ?\[)) + ;; In Java, an initialization brace list may follow + ;; directly after "new Foo[]", so check for a "new" + ;; earlier. + (while (eq braceassignp 'dontknow) + (setq braceassignp + (cond ((/= (c-backward-token-2 1 t lim) 0) nil) + ((looking-at c-opt-inexpr-brace-list-key) t) + ((looking-at "\\sw\\|\\s_\\|[.[]") + ;; Carry on looking if this is an + ;; identifier (may contain "." in Java) + ;; or another "[]" sexp. + 'dontknow) + (t nil))))) + ;; Checks to do on all sexps before the brace, up to the + ;; beginning of the statement. + (while (eq braceassignp 'dontknow) + (cond ((eq (char-after) ?\;) + (setq braceassignp nil)) + ((and class-key + (looking-at class-key)) + (setq braceassignp nil)) + ((eq (char-after) ?=) + ;; We've seen a =, but must check earlier tokens so + ;; that it isn't something that should be ignored. + (setq braceassignp 'maybe) + (while (and (eq braceassignp 'maybe) + (zerop (c-backward-token-2 1 t lim))) + (setq braceassignp + (cond + ;; Check for operator = + ((and c-opt-op-identifier-prefix + (looking-at c-opt-op-identifier-prefix)) + nil) + ;; Check for `<opchar>= in Pike. + ((and (c-major-mode-is 'pike-mode) + (or (eq (char-after) ?`) + ;; Special case for Pikes + ;; `[]=, since '[' is not in + ;; the punctuation class. + (and (eq (char-after) ?\[) + (eq (char-before) ?`)))) + nil) + ((looking-at "\\s.") 'maybe) + ;; make sure we're not in a C++ template + ;; argument assignment + ((and + (c-major-mode-is 'c++-mode) + (save-excursion + (let ((here (point)) + (pos< (progn + (skip-chars-backward "^<>") + (point)))) + (and (eq (char-before) ?<) + (not (c-crosses-statement-barrier-p + pos< here)) + (not (c-in-literal)) + )))) + nil) + (t t)))))) + (if (and (eq braceassignp 'dontknow) + (/= (c-backward-token-2 1 t lim) 0)) + (setq braceassignp nil))) + (if (not braceassignp) + (if (eq (char-after) ?\;) + ;; Brace lists can't contain a semicolon, so we're done. + (setq containing-sexp nil) + ;; Go up one level. + (setq containing-sexp next-containing + lim nil + next-containing nil)) + ;; we've hit the beginning of the aggregate list + (c-beginning-of-statement-1 + (c-most-enclosing-brace paren-state)) + (setq bufpos (point)))) + ) + bufpos)) + )) + +;; ================================================================== +;; end of monkey-patching of basic parsing logic +;; ================================================================== + + + + +;;(easy-menu-define csharp-menu csharp-mode-map "C# Mode Commands" +;; ;; Can use `csharp' as the language for `c-mode-menu' +;; ;; since its definition covers any language. In +;; ;; this case the language is used to adapt to the +;; ;; nonexistence of a cpp pass and thus removing some +;; ;; irrelevant menu alternatives. +;; (cons "C#" (c-lang-const c-mode-menu csharp))) + +;;; Autoload mode trigger +;;;###autoload +(add-to-list 'auto-mode-alist '("\\.cs$" . csharp-mode)) + + + +(c-add-style "C#" + '("Java" + (c-basic-offset . 4) + (c-comment-only-line-offset . (0 . 0)) + (c-offsets-alist . ( + (access-label . -) + (arglist-close . c-lineup-arglist) + (arglist-cont . 0) + (arglist-cont-nonempty . c-lineup-arglist) + (arglist-intro . c-lineup-arglist-intro-after-paren) + (block-close . 0) + (block-open . 0) + (brace-entry-open . 0) + (brace-list-close . 0) + (brace-list-entry . 0) + (brace-list-intro . +) + (brace-list-open . +) + (c . c-lineup-C-comments) + (case-label . +) + (catch-clause . 0) + (class-close . 0) + (class-open . 0) + (comment-intro . c-lineup-comment) + (cpp-macro . 0) + (cpp-macro-cont . c-lineup-dont-change) + (defun-block-intro . +) + (defun-close . 0) + (defun-open . 0) + (do-while-closure . 0) + (else-clause . 0) + (extern-lang-close . 0) + (extern-lang-open . 0) + (friend . 0) + (func-decl-cont . +) + (inclass . +) + (inexpr-class . +) + (inexpr-statement . 0) + (inextern-lang . +) + (inher-cont . c-lineup-multi-inher) + (inher-intro . +) + (inlambda . c-lineup-inexpr-block) + (inline-close . 0) + (inline-open . 0) + (innamespace . +) + (knr-argdecl . 0) + (knr-argdecl-intro . 5) + (label . 0) + (lambda-intro-cont . +) + (member-init-cont . c-lineup-multi-inher) + (member-init-intro . +) + (namespace-close . 0) + (namespace-open . 0) + (statement . 0) + (statement-block-intro . +) + (statement-case-intro . +) + (statement-case-open . +) + (statement-cont . +) + (stream-op . c-lineup-streamop) + (string . c-lineup-dont-change) + (substatement . +) + (substatement-open . 0) + (template-args-cont c-lineup-template-args +) + (topmost-intro . 0) + (topmost-intro-cont . 0) + )) + )) + + + + +;; Custom variables +;;;###autoload +(defcustom csharp-mode-hook nil + "*Hook called by `csharp-mode'." + :type 'hook + :group 'c) + + + +;;; The entry point into the mode +;;;###autoload +(defun csharp-mode () + "Major mode for editing C# code. This mode is derived from CC Mode to +support C#. + +The hook `c-mode-common-hook' is run with no args at mode +initialization, then `csharp-mode-hook'. + +This mode will automatically add a regexp for Csc.exe error and warning +messages to the `compilation-error-regexp-alist'. + +Key bindings: +\\{csharp-mode-map}" + (interactive) + (kill-all-local-variables) + (make-local-variable 'beginning-of-defun-function) + (make-local-variable 'end-of-defun-function) + (c-initialize-cc-mode t) + (set-syntax-table csharp-mode-syntax-table) + + ;; define underscore as part of a word in the Csharp syntax table + (modify-syntax-entry ?_ "w" csharp-mode-syntax-table) + + ;; define @ as an expression prefix in Csharp syntax table + (modify-syntax-entry ?@ "'" csharp-mode-syntax-table) + + (setq major-mode 'csharp-mode + mode-name "C#" + local-abbrev-table csharp-mode-abbrev-table + abbrev-mode t) + (use-local-map csharp-mode-map) + + ;; `c-init-language-vars' is a macro that is expanded at compile + ;; time to a large `setq' with all the language variables and their + ;; customized values for our language. + (c-init-language-vars csharp-mode) + + + ;; `c-common-init' initializes most of the components of a CC Mode + ;; buffer, including setup of the mode menu, font-lock, etc. + ;; There's also a lower level routine `c-basic-common-init' that + ;; only makes the necessary initialization to get the syntactic + ;; analysis and similar things working. + (c-common-init 'csharp-mode) + + + ;; csc.exe, the C# Compiler, produces errors like this: + ;; file.cs(6,18): error SC1006: Name of constructor must match name of class + + (add-hook 'compilation-mode-hook + (lambda () + (setq compilation-error-regexp-alist + (cons ' ("^[ \t]*\\([A-Za-z0-9][^(]+\\.cs\\)(\\([0-9]+\\)[,]\\([0-9]+\\)) ?: \\(error\\|warning\\) CS[0-9]+:" 1 2 3) + compilation-error-regexp-alist)))) + + ;; to allow next-error to work with csc.exe: + (setq compilation-scroll-output t) + + ;; allow fill-paragraph to work on xml code doc + (set (make-local-variable 'paragraph-separate) + "[ \t]*\\(//+\\|\\**\\)\\([ \t]+\\|[ \t]+<.+?>\\)$\\|^\f") + + + (c-run-mode-hooks 'c-mode-common-hook 'csharp-mode-hook) + + + ;; Need the following for parse-partial-sexp to work properly with + ;; verbatim literal strings Setting this var to non-nil tells + ;; `parse-partial-sexp' to pay attention to the syntax text + ;; properties on the text in the buffer. If csharp-mode attaches + ;; text syntax to @"..." then, `parse-partial-sexp' will treat those + ;; strings accordingly. + (set (make-local-variable 'parse-sexp-lookup-properties) + t) + + ;; scan the entire buffer for verblit strings + (csharp-scan-for-verbatim-literals-and-set-props nil nil) + + + (local-set-key (kbd "/") 'csharp-maybe-insert-codedoc) + (local-set-key (kbd "{") 'csharp-insert-open-brace) + + (c-update-modeline)) + + + +(message (concat "Done loading " load-file-name)) + + +(provide 'csharp-mode) + +;;; csharp-mode.el ends here +;;MD5: 4EDCB2ECE38841F407C7ED3DA8354E15 diff --git a/.emacs.d/elisp/functions.el b/.emacs.d/elisp/functions.el new file mode 100644 index 0000000..6472c82 --- /dev/null +++ b/.emacs.d/elisp/functions.el @@ -0,0 +1,45 @@ +(defun what-face (pos) + "Find out which face the current position uses" + (interactive "d") + (let ((face (or (get-char-property (point) 'read-face-name) + (get-char-property (point) 'face)))) + (if face + (message "Face: %s" face) + (message "No face at %d" pos)))) + +(defun my-comp-finish-function (buf str) + "Don't show compilation window if everything went ok" + (if (string-match "exited abnormally" str) + ;; there were errors + (message "compilation errors, press C-x ` to visit") + ;; no errors, make the compilation window go away in 0.5 seconds + (run-at-time 0.5 nil 'delete-windows-on bu) + (message "NO COMPILATION ERRORS!"))) + +(defun bh/hide-other () + (interactive) + (save-excursion + (org-back-to-heading) + (org-shifttab) + (org-reveal) + (org-cycle))) + +(defun bh/go-to-scratch () + (interactive) + (switch-to-buffer "*scratch*") + (delete-other-windows)) + +(defun bh/untabify () + (interactive) + (untabify (point-min) (point-max))) + +(defun bh/killframe () + (interactive) + (unless (buffer-modified-p) + (kill-buffer (current-buffer))) + (delete-frame)) + +(defun show-whitespace () + (whitespace-mode t)) + +(provide 'functions) diff --git a/.emacs.d/elisp/git-commit-mode b/.emacs.d/elisp/git-commit-mode new file mode 160000 +Subproject ec88948e06f787fcc1c3b9951930ef00b25d0b8 diff --git a/.emacs.d/elisp/git.el b/.emacs.d/elisp/git.el new file mode 100644 index 0000000..65c95d9 --- /dev/null +++ b/.emacs.d/elisp/git.el @@ -0,0 +1,1705 @@ +;;; git.el --- A user interface for git + +;; Copyright (C) 2005, 2006, 2007, 2008, 2009 Alexandre Julliard <julliard@winehq.org> + +;; Version: 1.0 + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2 of +;; the License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be +;; useful, but WITHOUT ANY WARRANTY; without even the implied +;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. See the GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public +;; License along with this program; if not, write to the Free +;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, +;; MA 02111-1307 USA + +;;; Commentary: + +;; This file contains an interface for the git version control +;; system. It provides easy access to the most frequently used git +;; commands. The user interface is as far as possible identical to +;; that of the PCL-CVS mode. +;; +;; To install: put this file on the load-path and place the following +;; in your .emacs file: +;; +;; (require 'git) +;; +;; To start: `M-x git-status' +;; +;; TODO +;; - diff against other branch +;; - renaming files from the status buffer +;; - creating tags +;; - fetch/pull +;; - revlist browser +;; - git-show-branch browser +;; + +;;; Compatibility: +;; +;; This file works on GNU Emacs 21 or later. It may work on older +;; versions but this is not guaranteed. +;; +;; It may work on XEmacs 21, provided that you first install the ewoc +;; and log-edit packages. +;; + +(eval-when-compile (require 'cl)) +(require 'ewoc) +(require 'log-edit) +(require 'easymenu) + + +;;;; Customizations +;;;; ------------------------------------------------------------ + +(defgroup git nil + "A user interface for the git versioning system." + :group 'tools) + +(defcustom git-committer-name nil + "User name to use for commits. +The default is to fall back to the repository config, +then to `add-log-full-name' and then to `user-full-name'." + :group 'git + :type '(choice (const :tag "Default" nil) + (string :tag "Name"))) + +(defcustom git-committer-email nil + "Email address to use for commits. +The default is to fall back to the git repository config, +then to `add-log-mailing-address' and then to `user-mail-address'." + :group 'git + :type '(choice (const :tag "Default" nil) + (string :tag "Email"))) + +(defcustom git-commits-coding-system nil + "Default coding system for the log message of git commits." + :group 'git + :type '(choice (const :tag "From repository config" nil) + (coding-system))) + +(defcustom git-append-signed-off-by nil + "Whether to append a Signed-off-by line to the commit message before editing." + :group 'git + :type 'boolean) + +(defcustom git-reuse-status-buffer t + "Whether `git-status' should try to reuse an existing buffer +if there is already one that displays the same directory." + :group 'git + :type 'boolean) + +(defcustom git-per-dir-ignore-file ".gitignore" + "Name of the per-directory ignore file." + :group 'git + :type 'string) + +(defcustom git-show-uptodate nil + "Whether to display up-to-date files." + :group 'git + :type 'boolean) + +(defcustom git-show-ignored nil + "Whether to display ignored files." + :group 'git + :type 'boolean) + +(defcustom git-show-unknown t + "Whether to display unknown files." + :group 'git + :type 'boolean) + + +(defface git-status-face + '((((class color) (background light)) (:foreground "purple")) + (((class color) (background dark)) (:foreground "salmon"))) + "Git mode face used to highlight added and modified files." + :group 'git) + +(defface git-unmerged-face + '((((class color) (background light)) (:foreground "red" :bold t)) + (((class color) (background dark)) (:foreground "red" :bold t))) + "Git mode face used to highlight unmerged files." + :group 'git) + +(defface git-unknown-face + '((((class color) (background light)) (:foreground "goldenrod" :bold t)) + (((class color) (background dark)) (:foreground "goldenrod" :bold t))) + "Git mode face used to highlight unknown files." + :group 'git) + +(defface git-uptodate-face + '((((class color) (background light)) (:foreground "grey60")) + (((class color) (background dark)) (:foreground "grey40"))) + "Git mode face used to highlight up-to-date files." + :group 'git) + +(defface git-ignored-face + '((((class color) (background light)) (:foreground "grey60")) + (((class color) (background dark)) (:foreground "grey40"))) + "Git mode face used to highlight ignored files." + :group 'git) + +(defface git-mark-face + '((((class color) (background light)) (:foreground "red" :bold t)) + (((class color) (background dark)) (:foreground "tomato" :bold t))) + "Git mode face used for the file marks." + :group 'git) + +(defface git-header-face + '((((class color) (background light)) (:foreground "blue")) + (((class color) (background dark)) (:foreground "blue"))) + "Git mode face used for commit headers." + :group 'git) + +(defface git-separator-face + '((((class color) (background light)) (:foreground "brown")) + (((class color) (background dark)) (:foreground "brown"))) + "Git mode face used for commit separator." + :group 'git) + +(defface git-permission-face + '((((class color) (background light)) (:foreground "green" :bold t)) + (((class color) (background dark)) (:foreground "green" :bold t))) + "Git mode face used for permission changes." + :group 'git) + + +;;;; Utilities +;;;; ------------------------------------------------------------ + +(defconst git-log-msg-separator "--- log message follows this line ---") + +(defvar git-log-edit-font-lock-keywords + `(("^\\(Author:\\|Date:\\|Merge:\\|Signed-off-by:\\)\\(.*\\)$" + (1 font-lock-keyword-face) + (2 font-lock-function-name-face)) + (,(concat "^\\(" (regexp-quote git-log-msg-separator) "\\)$") + (1 font-lock-comment-face)))) + +(defun git-get-env-strings (env) + "Build a list of NAME=VALUE strings from a list of environment strings." + (mapcar (lambda (entry) (concat (car entry) "=" (cdr entry))) env)) + +(defun git-call-process (buffer &rest args) + "Wrapper for call-process that sets environment strings." + (apply #'call-process "git" nil buffer nil args)) + +(defun git-call-process-display-error (&rest args) + "Wrapper for call-process that displays error messages." + (let* ((dir default-directory) + (buffer (get-buffer-create "*Git Command Output*")) + (ok (with-current-buffer buffer + (let ((default-directory dir) + (buffer-read-only nil)) + (erase-buffer) + (eq 0 (apply #'git-call-process (list buffer t) args)))))) + (unless ok (display-message-or-buffer buffer)) + ok)) + +(defun git-call-process-string (&rest args) + "Wrapper for call-process that returns the process output as a string, +or nil if the git command failed." + (with-temp-buffer + (and (eq 0 (apply #'git-call-process t args)) + (buffer-string)))) + +(defun git-call-process-string-display-error (&rest args) + "Wrapper for call-process that displays error message and returns +the process output as a string, or nil if the git command failed." + (with-temp-buffer + (if (eq 0 (apply #'git-call-process (list t t) args)) + (buffer-string) + (display-message-or-buffer (current-buffer)) + nil))) + +(defun git-run-process-region (buffer start end program args) + "Run a git process with a buffer region as input." + (let ((output-buffer (current-buffer)) + (dir default-directory)) + (with-current-buffer buffer + (cd dir) + (apply #'call-process-region start end program + nil (list output-buffer t) nil args)))) + +(defun git-run-command-buffer (buffer-name &rest args) + "Run a git command, sending the output to a buffer named BUFFER-NAME." + (let ((dir default-directory) + (buffer (get-buffer-create buffer-name))) + (message "Running git %s..." (car args)) + (with-current-buffer buffer + (let ((default-directory dir) + (buffer-read-only nil)) + (erase-buffer) + (apply #'git-call-process buffer args))) + (message "Running git %s...done" (car args)) + buffer)) + +(defun git-run-command-region (buffer start end env &rest args) + "Run a git command with specified buffer region as input." + (with-temp-buffer + (if (eq 0 (if env + (git-run-process-region + buffer start end "env" + (append (git-get-env-strings env) (list "git") args)) + (git-run-process-region buffer start end "git" args))) + (buffer-string) + (display-message-or-buffer (current-buffer)) + nil))) + +(defun git-run-hook (hook env &rest args) + "Run a git hook and display its output if any." + (let ((dir default-directory) + (hook-name (expand-file-name (concat ".git/hooks/" hook)))) + (or (not (file-executable-p hook-name)) + (let (status (buffer (get-buffer-create "*Git Hook Output*"))) + (with-current-buffer buffer + (erase-buffer) + (cd dir) + (setq status + (if env + (apply #'call-process "env" nil (list buffer t) nil + (append (git-get-env-strings env) (list hook-name) args)) + (apply #'call-process hook-name nil (list buffer t) nil args)))) + (display-message-or-buffer buffer) + (eq 0 status))))) + +(defun git-get-string-sha1 (string) + "Read a SHA1 from the specified string." + (and string + (string-match "[0-9a-f]\\{40\\}" string) + (match-string 0 string))) + +(defun git-get-committer-name () + "Return the name to use as GIT_COMMITTER_NAME." + ; copied from log-edit + (or git-committer-name + (git-config "user.name") + (and (boundp 'add-log-full-name) add-log-full-name) + (and (fboundp 'user-full-name) (user-full-name)) + (and (boundp 'user-full-name) user-full-name))) + +(defun git-get-committer-email () + "Return the email address to use as GIT_COMMITTER_EMAIL." + ; copied from log-edit + (or git-committer-email + (git-config "user.email") + (and (boundp 'add-log-mailing-address) add-log-mailing-address) + (and (fboundp 'user-mail-address) (user-mail-address)) + (and (boundp 'user-mail-address) user-mail-address))) + +(defun git-get-commits-coding-system () + "Return the coding system to use for commits." + (let ((repo-config (git-config "i18n.commitencoding"))) + (or git-commits-coding-system + (and repo-config + (fboundp 'locale-charset-to-coding-system) + (locale-charset-to-coding-system repo-config)) + 'utf-8))) + +(defun git-get-logoutput-coding-system () + "Return the coding system used for git-log output." + (let ((repo-config (or (git-config "i18n.logoutputencoding") + (git-config "i18n.commitencoding")))) + (or git-commits-coding-system + (and repo-config + (fboundp 'locale-charset-to-coding-system) + (locale-charset-to-coding-system repo-config)) + 'utf-8))) + +(defun git-escape-file-name (name) + "Escape a file name if necessary." + (if (string-match "[\n\t\"\\]" name) + (concat "\"" + (mapconcat (lambda (c) + (case c + (?\n "\\n") + (?\t "\\t") + (?\\ "\\\\") + (?\" "\\\"") + (t (char-to-string c)))) + name "") + "\"") + name)) + +(defun git-success-message (text files) + "Print a success message after having handled FILES." + (let ((n (length files))) + (if (equal n 1) + (message "%s %s" text (car files)) + (message "%s %d files" text n)))) + +(defun git-get-top-dir (dir) + "Retrieve the top-level directory of a git tree." + (let ((cdup (with-output-to-string + (with-current-buffer standard-output + (cd dir) + (unless (eq 0 (git-call-process t "rev-parse" "--show-cdup")) + (error "cannot find top-level git tree for %s." dir)))))) + (expand-file-name (concat (file-name-as-directory dir) + (car (split-string cdup "\n")))))) + +;stolen from pcl-cvs +(defun git-append-to-ignore (file) + "Add a file name to the ignore file in its directory." + (let* ((fullname (expand-file-name file)) + (dir (file-name-directory fullname)) + (name (file-name-nondirectory fullname)) + (ignore-name (expand-file-name git-per-dir-ignore-file dir)) + (created (not (file-exists-p ignore-name)))) + (save-window-excursion + (set-buffer (find-file-noselect ignore-name)) + (goto-char (point-max)) + (unless (zerop (current-column)) (insert "\n")) + (insert "/" name "\n") + (sort-lines nil (point-min) (point-max)) + (save-buffer)) + (when created + (git-call-process nil "update-index" "--add" "--" (file-relative-name ignore-name))) + (git-update-status-files (list (file-relative-name ignore-name))))) + +; propertize definition for XEmacs, stolen from erc-compat +(eval-when-compile + (unless (fboundp 'propertize) + (defun propertize (string &rest props) + (let ((string (copy-sequence string))) + (while props + (put-text-property 0 (length string) (nth 0 props) (nth 1 props) string) + (setq props (cddr props))) + string)))) + +;;;; Wrappers for basic git commands +;;;; ------------------------------------------------------------ + +(defun git-rev-parse (rev) + "Parse a revision name and return its SHA1." + (git-get-string-sha1 + (git-call-process-string "rev-parse" rev))) + +(defun git-config (key) + "Retrieve the value associated to KEY in the git repository config file." + (let ((str (git-call-process-string "config" key))) + (and str (car (split-string str "\n"))))) + +(defun git-symbolic-ref (ref) + "Wrapper for the git-symbolic-ref command." + (let ((str (git-call-process-string "symbolic-ref" ref))) + (and str (car (split-string str "\n"))))) + +(defun git-update-ref (ref newval &optional oldval reason) + "Update a reference by calling git-update-ref." + (let ((args (and oldval (list oldval)))) + (when newval (push newval args)) + (push ref args) + (when reason + (push reason args) + (push "-m" args)) + (unless newval (push "-d" args)) + (apply 'git-call-process-display-error "update-ref" args))) + +(defun git-for-each-ref (&rest specs) + "Return a list of refs using git-for-each-ref. +Each entry is a cons of (SHORT-NAME . FULL-NAME)." + (let (refs) + (with-temp-buffer + (apply #'git-call-process t "for-each-ref" "--format=%(refname)" specs) + (goto-char (point-min)) + (while (re-search-forward "^[^/\n]+/[^/\n]+/\\(.+\\)$" nil t) + (push (cons (match-string 1) (match-string 0)) refs))) + (nreverse refs))) + +(defun git-read-tree (tree &optional index-file) + "Read a tree into the index file." + (let ((process-environment + (append (and index-file (list (concat "GIT_INDEX_FILE=" index-file))) process-environment))) + (apply 'git-call-process-display-error "read-tree" (if tree (list tree))))) + +(defun git-write-tree (&optional index-file) + "Call git-write-tree and return the resulting tree SHA1 as a string." + (let ((process-environment + (append (and index-file (list (concat "GIT_INDEX_FILE=" index-file))) process-environment))) + (git-get-string-sha1 + (git-call-process-string-display-error "write-tree")))) + +(defun git-commit-tree (buffer tree parent) + "Create a commit and possibly update HEAD. +Create a commit with the message in BUFFER using the tree with hash TREE. +Use PARENT as the parent of the new commit. If PARENT is the current \"HEAD\", +update the \"HEAD\" reference to the new commit." + (let ((author-name (git-get-committer-name)) + (author-email (git-get-committer-email)) + (subject "commit (initial): ") + author-date log-start log-end args coding-system-for-write) + (when parent + (setq subject "commit: ") + (push "-p" args) + (push parent args)) + (with-current-buffer buffer + (goto-char (point-min)) + (if + (setq log-start (re-search-forward (concat "^" (regexp-quote git-log-msg-separator) "\n") nil t)) + (save-restriction + (narrow-to-region (point-min) log-start) + (goto-char (point-min)) + (when (re-search-forward "^Author: +\\(.*?\\) *<\\(.*\\)> *$" nil t) + (setq author-name (match-string 1) + author-email (match-string 2))) + (goto-char (point-min)) + (when (re-search-forward "^Date: +\\(.*\\)$" nil t) + (setq author-date (match-string 1))) + (goto-char (point-min)) + (when (re-search-forward "^Merge: +\\(.*\\)" nil t) + (setq subject "commit (merge): ") + (dolist (parent (split-string (match-string 1) " +" t)) + (push "-p" args) + (push parent args)))) + (setq log-start (point-min))) + (setq log-end (point-max)) + (goto-char log-start) + (when (re-search-forward ".*$" nil t) + (setq subject (concat subject (match-string 0)))) + (setq coding-system-for-write buffer-file-coding-system)) + (let ((commit + (git-get-string-sha1 + (let ((env `(("GIT_AUTHOR_NAME" . ,author-name) + ("GIT_AUTHOR_EMAIL" . ,author-email) + ("GIT_COMMITTER_NAME" . ,(git-get-committer-name)) + ("GIT_COMMITTER_EMAIL" . ,(git-get-committer-email))))) + (when author-date (push `("GIT_AUTHOR_DATE" . ,author-date) env)) + (apply #'git-run-command-region + buffer log-start log-end env + "commit-tree" tree (nreverse args)))))) + (when commit (git-update-ref "HEAD" commit parent subject)) + commit))) + +(defun git-empty-db-p () + "Check if the git db is empty (no commit done yet)." + (not (eq 0 (git-call-process nil "rev-parse" "--verify" "HEAD")))) + +(defun git-get-merge-heads () + "Retrieve the merge heads from the MERGE_HEAD file if present." + (let (heads) + (when (file-readable-p ".git/MERGE_HEAD") + (with-temp-buffer + (insert-file-contents ".git/MERGE_HEAD" nil nil nil t) + (goto-char (point-min)) + (while (re-search-forward "[0-9a-f]\\{40\\}" nil t) + (push (match-string 0) heads)))) + (nreverse heads))) + +(defun git-get-commit-description (commit) + "Get a one-line description of COMMIT." + (let ((coding-system-for-read (git-get-logoutput-coding-system))) + (let ((descr (git-call-process-string "log" "--max-count=1" "--pretty=oneline" commit))) + (if (and descr (string-match "\\`\\([0-9a-f]\\{40\\}\\) *\\(.*\\)$" descr)) + (concat (substring (match-string 1 descr) 0 10) " - " (match-string 2 descr)) + descr)))) + +;;;; File info structure +;;;; ------------------------------------------------------------ + +; fileinfo structure stolen from pcl-cvs +(defstruct (git-fileinfo + (:copier nil) + (:constructor git-create-fileinfo (state name &optional old-perm new-perm rename-state orig-name marked)) + (:conc-name git-fileinfo->)) + marked ;; t/nil + state ;; current state + name ;; file name + old-perm new-perm ;; permission flags + rename-state ;; rename or copy state + orig-name ;; original name for renames or copies + needs-update ;; whether file needs to be updated + needs-refresh) ;; whether file needs to be refreshed + +(defvar git-status nil) + +(defun git-set-fileinfo-state (info state) + "Set the state of a file info." + (unless (eq (git-fileinfo->state info) state) + (setf (git-fileinfo->state info) state + (git-fileinfo->new-perm info) (git-fileinfo->old-perm info) + (git-fileinfo->rename-state info) nil + (git-fileinfo->orig-name info) nil + (git-fileinfo->needs-update info) nil + (git-fileinfo->needs-refresh info) t))) + +(defun git-status-filenames-map (status func files &rest args) + "Apply FUNC to the status files names in the FILES list. +The list must be sorted." + (when files + (let ((file (pop files)) + (node (ewoc-nth status 0))) + (while (and file node) + (let* ((info (ewoc-data node)) + (name (git-fileinfo->name info))) + (if (string-lessp name file) + (setq node (ewoc-next status node)) + (if (string-equal name file) + (apply func info args)) + (setq file (pop files)))))))) + +(defun git-set-filenames-state (status files state) + "Set the state of a list of named files. The list must be sorted" + (when files + (git-status-filenames-map status #'git-set-fileinfo-state files state) + (unless state ;; delete files whose state has been set to nil + (ewoc-filter status (lambda (info) (git-fileinfo->state info)))))) + +(defun git-state-code (code) + "Convert from a string to a added/deleted/modified state." + (case (string-to-char code) + (?M 'modified) + (?? 'unknown) + (?A 'added) + (?D 'deleted) + (?U 'unmerged) + (?T 'modified) + (t nil))) + +(defun git-status-code-as-string (code) + "Format a git status code as string." + (case code + ('modified (propertize "Modified" 'face 'git-status-face)) + ('unknown (propertize "Unknown " 'face 'git-unknown-face)) + ('added (propertize "Added " 'face 'git-status-face)) + ('deleted (propertize "Deleted " 'face 'git-status-face)) + ('unmerged (propertize "Unmerged" 'face 'git-unmerged-face)) + ('uptodate (propertize "Uptodate" 'face 'git-uptodate-face)) + ('ignored (propertize "Ignored " 'face 'git-ignored-face)) + (t "? "))) + +(defun git-file-type-as-string (old-perm new-perm) + "Return a string describing the file type based on its permissions." + (let* ((old-type (lsh (or old-perm 0) -9)) + (new-type (lsh (or new-perm 0) -9)) + (str (case new-type + (64 ;; file + (case old-type + (64 nil) + (80 " (type change symlink -> file)") + (112 " (type change subproject -> file)"))) + (80 ;; symlink + (case old-type + (64 " (type change file -> symlink)") + (112 " (type change subproject -> symlink)") + (t " (symlink)"))) + (112 ;; subproject + (case old-type + (64 " (type change file -> subproject)") + (80 " (type change symlink -> subproject)") + (t " (subproject)"))) + (72 nil) ;; directory (internal, not a real git state) + (0 ;; deleted or unknown + (case old-type + (80 " (symlink)") + (112 " (subproject)"))) + (t (format " (unknown type %o)" new-type))))) + (cond (str (propertize str 'face 'git-status-face)) + ((eq new-type 72) "/") + (t "")))) + +(defun git-rename-as-string (info) + "Return a string describing the copy or rename associated with INFO, or an empty string if none." + (let ((state (git-fileinfo->rename-state info))) + (if state + (propertize + (concat " (" + (if (eq state 'copy) "copied from " + (if (eq (git-fileinfo->state info) 'added) "renamed from " + "renamed to ")) + (git-escape-file-name (git-fileinfo->orig-name info)) + ")") 'face 'git-status-face) + ""))) + +(defun git-permissions-as-string (old-perm new-perm) + "Format a permission change as string." + (propertize + (if (or (not old-perm) + (not new-perm) + (eq 0 (logand ?\111 (logxor old-perm new-perm)))) + " " + (if (eq 0 (logand ?\111 old-perm)) "+x" "-x")) + 'face 'git-permission-face)) + +(defun git-fileinfo-prettyprint (info) + "Pretty-printer for the git-fileinfo structure." + (let ((old-perm (git-fileinfo->old-perm info)) + (new-perm (git-fileinfo->new-perm info))) + (insert (concat " " (if (git-fileinfo->marked info) (propertize "*" 'face 'git-mark-face) " ") + " " (git-status-code-as-string (git-fileinfo->state info)) + " " (git-permissions-as-string old-perm new-perm) + " " (git-escape-file-name (git-fileinfo->name info)) + (git-file-type-as-string old-perm new-perm) + (git-rename-as-string info))))) + +(defun git-update-node-fileinfo (node info) + "Update the fileinfo of the specified node. The names are assumed to match already." + (let ((data (ewoc-data node))) + (setf + ;; preserve the marked flag + (git-fileinfo->marked info) (git-fileinfo->marked data) + (git-fileinfo->needs-update data) nil) + (when (not (equal info data)) + (setf (git-fileinfo->needs-refresh info) t + (ewoc-data node) info)))) + +(defun git-insert-info-list (status infolist files) + "Insert a sorted list of file infos in the status buffer, replacing existing ones if any." + (let* ((info (pop infolist)) + (node (ewoc-nth status 0)) + (name (and info (git-fileinfo->name info))) + remaining) + (while info + (let ((nodename (and node (git-fileinfo->name (ewoc-data node))))) + (while (and files (string-lessp (car files) name)) + (push (pop files) remaining)) + (when (and files (string-equal (car files) name)) + (setq files (cdr files))) + (cond ((not nodename) + (setq node (ewoc-enter-last status info)) + (setq info (pop infolist)) + (setq name (and info (git-fileinfo->name info)))) + ((string-lessp nodename name) + (setq node (ewoc-next status node))) + ((string-equal nodename name) + ;; preserve the marked flag + (git-update-node-fileinfo node info) + (setq info (pop infolist)) + (setq name (and info (git-fileinfo->name info)))) + (t + (setq node (ewoc-enter-before status node info)) + (setq info (pop infolist)) + (setq name (and info (git-fileinfo->name info))))))) + (nconc (nreverse remaining) files))) + +(defun git-run-diff-index (status files) + "Run git-diff-index on FILES and parse the results into STATUS. +Return the list of files that haven't been handled." + (let (infolist) + (with-temp-buffer + (apply #'git-call-process t "diff-index" "-z" "-M" "HEAD" "--" files) + (goto-char (point-min)) + (while (re-search-forward + ":\\([0-7]\\{6\\}\\) \\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} [0-9a-f]\\{40\\} \\(\\([ADMUT]\\)\0\\([^\0]+\\)\\|\\([CR]\\)[0-9]*\0\\([^\0]+\\)\0\\([^\0]+\\)\\)\0" + nil t 1) + (let ((old-perm (string-to-number (match-string 1) 8)) + (new-perm (string-to-number (match-string 2) 8)) + (state (or (match-string 4) (match-string 6))) + (name (or (match-string 5) (match-string 7))) + (new-name (match-string 8))) + (if new-name ; copy or rename + (if (eq ?C (string-to-char state)) + (push (git-create-fileinfo 'added new-name old-perm new-perm 'copy name) infolist) + (push (git-create-fileinfo 'deleted name 0 0 'rename new-name) infolist) + (push (git-create-fileinfo 'added new-name old-perm new-perm 'rename name) infolist)) + (push (git-create-fileinfo (git-state-code state) name old-perm new-perm) infolist))))) + (setq infolist (sort (nreverse infolist) + (lambda (info1 info2) + (string-lessp (git-fileinfo->name info1) + (git-fileinfo->name info2))))) + (git-insert-info-list status infolist files))) + +(defun git-find-status-file (status file) + "Find a given file in the status ewoc and return its node." + (let ((node (ewoc-nth status 0))) + (while (and node (not (string= file (git-fileinfo->name (ewoc-data node))))) + (setq node (ewoc-next status node))) + node)) + +(defun git-run-ls-files (status files default-state &rest options) + "Run git-ls-files on FILES and parse the results into STATUS. +Return the list of files that haven't been handled." + (let (infolist) + (with-temp-buffer + (apply #'git-call-process t "ls-files" "-z" (append options (list "--") files)) + (goto-char (point-min)) + (while (re-search-forward "\\([^\0]*?\\)\\(/?\\)\0" nil t 1) + (let ((name (match-string 1))) + (push (git-create-fileinfo default-state name 0 + (if (string-equal "/" (match-string 2)) (lsh ?\110 9) 0)) + infolist)))) + (setq infolist (nreverse infolist)) ;; assume it is sorted already + (git-insert-info-list status infolist files))) + +(defun git-run-ls-files-cached (status files default-state) + "Run git-ls-files -c on FILES and parse the results into STATUS. +Return the list of files that haven't been handled." + (let (infolist) + (with-temp-buffer + (apply #'git-call-process t "ls-files" "-z" "-s" "-c" "--" files) + (goto-char (point-min)) + (while (re-search-forward "\\([0-7]\\{6\\}\\) [0-9a-f]\\{40\\} 0\t\\([^\0]+\\)\0" nil t) + (let* ((new-perm (string-to-number (match-string 1) 8)) + (old-perm (if (eq default-state 'added) 0 new-perm)) + (name (match-string 2))) + (push (git-create-fileinfo default-state name old-perm new-perm) infolist)))) + (setq infolist (nreverse infolist)) ;; assume it is sorted already + (git-insert-info-list status infolist files))) + +(defun git-run-ls-unmerged (status files) + "Run git-ls-files -u on FILES and parse the results into STATUS." + (with-temp-buffer + (apply #'git-call-process t "ls-files" "-z" "-u" "--" files) + (goto-char (point-min)) + (let (unmerged-files) + (while (re-search-forward "[0-7]\\{6\\} [0-9a-f]\\{40\\} [123]\t\\([^\0]+\\)\0" nil t) + (push (match-string 1) unmerged-files)) + (setq unmerged-files (nreverse unmerged-files)) ;; assume it is sorted already + (git-set-filenames-state status unmerged-files 'unmerged)))) + +(defun git-get-exclude-files () + "Get the list of exclude files to pass to git-ls-files." + (let (files + (config (git-config "core.excludesfile"))) + (when (file-readable-p ".git/info/exclude") + (push ".git/info/exclude" files)) + (when (and config (file-readable-p config)) + (push config files)) + files)) + +(defun git-run-ls-files-with-excludes (status files default-state &rest options) + "Run git-ls-files on FILES with appropriate --exclude-from options." + (let ((exclude-files (git-get-exclude-files))) + (apply #'git-run-ls-files status files default-state "--directory" "--no-empty-directory" + (concat "--exclude-per-directory=" git-per-dir-ignore-file) + (append options (mapcar (lambda (f) (concat "--exclude-from=" f)) exclude-files))))) + +(defun git-update-status-files (&optional files mark-files) + "Update the status of FILES from the index. +The FILES list must be sorted." + (unless git-status (error "Not in git-status buffer.")) + ;; set the needs-update flag on existing files + (if files + (git-status-filenames-map + git-status (lambda (info) (setf (git-fileinfo->needs-update info) t)) files) + (ewoc-map (lambda (info) (setf (git-fileinfo->needs-update info) t) nil) git-status) + (git-call-process nil "update-index" "--refresh") + (when git-show-uptodate + (git-run-ls-files-cached git-status nil 'uptodate))) + (let ((remaining-files + (if (git-empty-db-p) ; we need some special handling for an empty db + (git-run-ls-files-cached git-status files 'added) + (git-run-diff-index git-status files)))) + (git-run-ls-unmerged git-status files) + (when (or remaining-files (and git-show-unknown (not files))) + (setq remaining-files (git-run-ls-files-with-excludes git-status remaining-files 'unknown "-o"))) + (when (or remaining-files (and git-show-ignored (not files))) + (setq remaining-files (git-run-ls-files-with-excludes git-status remaining-files 'ignored "-o" "-i"))) + (unless files + (setq remaining-files (git-get-filenames (ewoc-collect git-status #'git-fileinfo->needs-update)))) + (when remaining-files + (setq remaining-files (git-run-ls-files-cached git-status remaining-files 'uptodate))) + (git-set-filenames-state git-status remaining-files nil) + (when mark-files (git-mark-files git-status files)) + (git-refresh-files) + (git-refresh-ewoc-hf git-status))) + +(defun git-mark-files (status files) + "Mark all the specified FILES, and unmark the others." + (let ((file (and files (pop files))) + (node (ewoc-nth status 0))) + (while node + (let ((info (ewoc-data node))) + (if (and file (string-equal (git-fileinfo->name info) file)) + (progn + (unless (git-fileinfo->marked info) + (setf (git-fileinfo->marked info) t) + (setf (git-fileinfo->needs-refresh info) t)) + (setq file (pop files)) + (setq node (ewoc-next status node))) + (when (git-fileinfo->marked info) + (setf (git-fileinfo->marked info) nil) + (setf (git-fileinfo->needs-refresh info) t)) + (if (and file (string-lessp file (git-fileinfo->name info))) + (setq file (pop files)) + (setq node (ewoc-next status node)))))))) + +(defun git-marked-files () + "Return a list of all marked files, or if none a list containing just the file at cursor position." + (unless git-status (error "Not in git-status buffer.")) + (or (ewoc-collect git-status (lambda (info) (git-fileinfo->marked info))) + (list (ewoc-data (ewoc-locate git-status))))) + +(defun git-marked-files-state (&rest states) + "Return a sorted list of marked files that are in the specified states." + (let ((files (git-marked-files)) + result) + (dolist (info files) + (when (memq (git-fileinfo->state info) states) + (push info result))) + (nreverse result))) + +(defun git-refresh-files () + "Refresh all files that need it and clear the needs-refresh flag." + (unless git-status (error "Not in git-status buffer.")) + (ewoc-map + (lambda (info) + (let ((refresh (git-fileinfo->needs-refresh info))) + (setf (git-fileinfo->needs-refresh info) nil) + refresh)) + git-status) + ; move back to goal column + (when goal-column (move-to-column goal-column))) + +(defun git-refresh-ewoc-hf (status) + "Refresh the ewoc header and footer." + (let ((branch (git-symbolic-ref "HEAD")) + (head (if (git-empty-db-p) "Nothing committed yet" + (git-get-commit-description "HEAD"))) + (merge-heads (git-get-merge-heads))) + (ewoc-set-hf status + (format "Directory: %s\nBranch: %s\nHead: %s%s\n" + default-directory + (if branch + (if (string-match "^refs/heads/" branch) + (substring branch (match-end 0)) + branch) + "none (detached HEAD)") + head + (if merge-heads + (concat "\nMerging: " + (mapconcat (lambda (str) (git-get-commit-description str)) merge-heads "\n ")) + "")) + (if (ewoc-nth status 0) "" " No changes.")))) + +(defun git-get-filenames (files) + (mapcar (lambda (info) (git-fileinfo->name info)) files)) + +(defun git-update-index (index-file files) + "Run git-update-index on a list of files." + (let ((process-environment (append (and index-file (list (concat "GIT_INDEX_FILE=" index-file))) + process-environment)) + added deleted modified) + (dolist (info files) + (case (git-fileinfo->state info) + ('added (push info added)) + ('deleted (push info deleted)) + ('modified (push info modified)))) + (and + (or (not added) (apply #'git-call-process-display-error "update-index" "--add" "--" (git-get-filenames added))) + (or (not deleted) (apply #'git-call-process-display-error "update-index" "--remove" "--" (git-get-filenames deleted))) + (or (not modified) (apply #'git-call-process-display-error "update-index" "--" (git-get-filenames modified)))))) + +(defun git-run-pre-commit-hook () + "Run the pre-commit hook if any." + (unless git-status (error "Not in git-status buffer.")) + (let ((files (git-marked-files-state 'added 'deleted 'modified))) + (or (not files) + (not (file-executable-p ".git/hooks/pre-commit")) + (let ((index-file (make-temp-file "gitidx"))) + (unwind-protect + (let ((head-tree (unless (git-empty-db-p) (git-rev-parse "HEAD^{tree}")))) + (git-read-tree head-tree index-file) + (git-update-index index-file files) + (git-run-hook "pre-commit" `(("GIT_INDEX_FILE" . ,index-file)))) + (delete-file index-file)))))) + +(defun git-do-commit () + "Perform the actual commit using the current buffer as log message." + (interactive) + (let ((buffer (current-buffer)) + (index-file (make-temp-file "gitidx"))) + (with-current-buffer log-edit-parent-buffer + (if (git-marked-files-state 'unmerged) + (message "You cannot commit unmerged files, resolve them first.") + (unwind-protect + (let ((files (git-marked-files-state 'added 'deleted 'modified)) + head tree head-tree) + (unless (git-empty-db-p) + (setq head (git-rev-parse "HEAD") + head-tree (git-rev-parse "HEAD^{tree}"))) + (message "Running git commit...") + (when + (and + (git-read-tree head-tree index-file) + (git-update-index nil files) ;update both the default index + (git-update-index index-file files) ;and the temporary one + (setq tree (git-write-tree index-file))) + (if (or (not (string-equal tree head-tree)) + (yes-or-no-p "The tree was not modified, do you really want to perform an empty commit? ")) + (let ((commit (git-commit-tree buffer tree head))) + (when commit + (condition-case nil (delete-file ".git/MERGE_HEAD") (error nil)) + (condition-case nil (delete-file ".git/MERGE_MSG") (error nil)) + (with-current-buffer buffer (erase-buffer)) + (git-update-status-files (git-get-filenames files)) + (git-call-process nil "rerere") + (git-call-process nil "gc" "--auto") + (message "Committed %s." commit) + (git-run-hook "post-commit" nil))) + (message "Commit aborted.")))) + (delete-file index-file)))))) + + +;;;; Interactive functions +;;;; ------------------------------------------------------------ + +(defun git-mark-file () + "Mark the file that the cursor is on and move to the next one." + (interactive) + (unless git-status (error "Not in git-status buffer.")) + (let* ((pos (ewoc-locate git-status)) + (info (ewoc-data pos))) + (setf (git-fileinfo->marked info) t) + (ewoc-invalidate git-status pos) + (ewoc-goto-next git-status 1))) + +(defun git-unmark-file () + "Unmark the file that the cursor is on and move to the next one." + (interactive) + (unless git-status (error "Not in git-status buffer.")) + (let* ((pos (ewoc-locate git-status)) + (info (ewoc-data pos))) + (setf (git-fileinfo->marked info) nil) + (ewoc-invalidate git-status pos) + (ewoc-goto-next git-status 1))) + +(defun git-unmark-file-up () + "Unmark the file that the cursor is on and move to the previous one." + (interactive) + (unless git-status (error "Not in git-status buffer.")) + (let* ((pos (ewoc-locate git-status)) + (info (ewoc-data pos))) + (setf (git-fileinfo->marked info) nil) + (ewoc-invalidate git-status pos) + (ewoc-goto-prev git-status 1))) + +(defun git-mark-all () + "Mark all files." + (interactive) + (unless git-status (error "Not in git-status buffer.")) + (ewoc-map (lambda (info) (unless (git-fileinfo->marked info) + (setf (git-fileinfo->marked info) t))) git-status) + ; move back to goal column after invalidate + (when goal-column (move-to-column goal-column))) + +(defun git-unmark-all () + "Unmark all files." + (interactive) + (unless git-status (error "Not in git-status buffer.")) + (ewoc-map (lambda (info) (when (git-fileinfo->marked info) + (setf (git-fileinfo->marked info) nil) + t)) git-status) + ; move back to goal column after invalidate + (when goal-column (move-to-column goal-column))) + +(defun git-toggle-all-marks () + "Toggle all file marks." + (interactive) + (unless git-status (error "Not in git-status buffer.")) + (ewoc-map (lambda (info) (setf (git-fileinfo->marked info) (not (git-fileinfo->marked info))) t) git-status) + ; move back to goal column after invalidate + (when goal-column (move-to-column goal-column))) + +(defun git-next-file (&optional n) + "Move the selection down N files." + (interactive "p") + (unless git-status (error "Not in git-status buffer.")) + (ewoc-goto-next git-status n)) + +(defun git-prev-file (&optional n) + "Move the selection up N files." + (interactive "p") + (unless git-status (error "Not in git-status buffer.")) + (ewoc-goto-prev git-status n)) + +(defun git-next-unmerged-file (&optional n) + "Move the selection down N unmerged files." + (interactive "p") + (unless git-status (error "Not in git-status buffer.")) + (let* ((last (ewoc-locate git-status)) + (node (ewoc-next git-status last))) + (while (and node (> n 0)) + (when (eq 'unmerged (git-fileinfo->state (ewoc-data node))) + (setq n (1- n)) + (setq last node)) + (setq node (ewoc-next git-status node))) + (ewoc-goto-node git-status last))) + +(defun git-prev-unmerged-file (&optional n) + "Move the selection up N unmerged files." + (interactive "p") + (unless git-status (error "Not in git-status buffer.")) + (let* ((last (ewoc-locate git-status)) + (node (ewoc-prev git-status last))) + (while (and node (> n 0)) + (when (eq 'unmerged (git-fileinfo->state (ewoc-data node))) + (setq n (1- n)) + (setq last node)) + (setq node (ewoc-prev git-status node))) + (ewoc-goto-node git-status last))) + +(defun git-insert-file (file) + "Insert file(s) into the git-status buffer." + (interactive "fInsert file: ") + (git-update-status-files (list (file-relative-name file)))) + +(defun git-add-file () + "Add marked file(s) to the index cache." + (interactive) + (let ((files (git-get-filenames (git-marked-files-state 'unknown 'ignored 'unmerged)))) + ;; FIXME: add support for directories + (unless files + (push (file-relative-name (read-file-name "File to add: " nil nil t)) files)) + (when (apply 'git-call-process-display-error "update-index" "--add" "--" files) + (git-update-status-files files) + (git-success-message "Added" files)))) + +(defun git-ignore-file () + "Add marked file(s) to the ignore list." + (interactive) + (let ((files (git-get-filenames (git-marked-files-state 'unknown)))) + (unless files + (push (file-relative-name (read-file-name "File to ignore: " nil nil t)) files)) + (dolist (f files) (git-append-to-ignore f)) + (git-update-status-files files) + (git-success-message "Ignored" files))) + +(defun git-remove-file () + "Remove the marked file(s)." + (interactive) + (let ((files (git-get-filenames (git-marked-files-state 'added 'modified 'unknown 'uptodate 'ignored)))) + (unless files + (push (file-relative-name (read-file-name "File to remove: " nil nil t)) files)) + (if (yes-or-no-p + (if (cdr files) + (format "Remove %d files? " (length files)) + (format "Remove %s? " (car files)))) + (progn + (dolist (name files) + (ignore-errors + (if (file-directory-p name) + (delete-directory name) + (delete-file name)))) + (when (apply 'git-call-process-display-error "update-index" "--remove" "--" files) + (git-update-status-files files) + (git-success-message "Removed" files))) + (message "Aborting")))) + +(defun git-revert-file () + "Revert changes to the marked file(s)." + (interactive) + (let ((files (git-marked-files-state 'added 'deleted 'modified 'unmerged)) + added modified) + (when (and files + (yes-or-no-p + (if (cdr files) + (format "Revert %d files? " (length files)) + (format "Revert %s? " (git-fileinfo->name (car files)))))) + (dolist (info files) + (case (git-fileinfo->state info) + ('added (push (git-fileinfo->name info) added)) + ('deleted (push (git-fileinfo->name info) modified)) + ('unmerged (push (git-fileinfo->name info) modified)) + ('modified (push (git-fileinfo->name info) modified)))) + ;; check if a buffer contains one of the files and isn't saved + (dolist (file modified) + (let ((buffer (get-file-buffer file))) + (when (and buffer (buffer-modified-p buffer)) + (error "Buffer %s is modified. Please kill or save modified buffers before reverting." (buffer-name buffer))))) + (let ((ok (and + (or (not added) + (apply 'git-call-process-display-error "update-index" "--force-remove" "--" added)) + (or (not modified) + (apply 'git-call-process-display-error "checkout" "HEAD" modified)))) + (names (git-get-filenames files))) + (git-update-status-files names) + (when ok + (dolist (file modified) + (let ((buffer (get-file-buffer file))) + (when buffer (with-current-buffer buffer (revert-buffer t t t))))) + (git-success-message "Reverted" names)))))) + +(defun git-remove-handled () + "Remove handled files from the status list." + (interactive) + (ewoc-filter git-status + (lambda (info) + (case (git-fileinfo->state info) + ('ignored git-show-ignored) + ('uptodate git-show-uptodate) + ('unknown git-show-unknown) + (t t)))) + (unless (ewoc-nth git-status 0) ; refresh header if list is empty + (git-refresh-ewoc-hf git-status))) + +(defun git-toggle-show-uptodate () + "Toogle the option for showing up-to-date files." + (interactive) + (if (setq git-show-uptodate (not git-show-uptodate)) + (git-refresh-status) + (git-remove-handled))) + +(defun git-toggle-show-ignored () + "Toogle the option for showing ignored files." + (interactive) + (if (setq git-show-ignored (not git-show-ignored)) + (progn + (message "Inserting ignored files...") + (git-run-ls-files-with-excludes git-status nil 'ignored "-o" "-i") + (git-refresh-files) + (git-refresh-ewoc-hf git-status) + (message "Inserting ignored files...done")) + (git-remove-handled))) + +(defun git-toggle-show-unknown () + "Toogle the option for showing unknown files." + (interactive) + (if (setq git-show-unknown (not git-show-unknown)) + (progn + (message "Inserting unknown files...") + (git-run-ls-files-with-excludes git-status nil 'unknown "-o") + (git-refresh-files) + (git-refresh-ewoc-hf git-status) + (message "Inserting unknown files...done")) + (git-remove-handled))) + +(defun git-expand-directory (info) + "Expand the directory represented by INFO to list its files." + (when (eq (lsh (git-fileinfo->new-perm info) -9) ?\110) + (let ((dir (git-fileinfo->name info))) + (git-set-filenames-state git-status (list dir) nil) + (git-run-ls-files-with-excludes git-status (list (concat dir "/")) 'unknown "-o") + (git-refresh-files) + (git-refresh-ewoc-hf git-status) + t))) + +(defun git-setup-diff-buffer (buffer) + "Setup a buffer for displaying a diff." + (let ((dir default-directory)) + (with-current-buffer buffer + (diff-mode) + (goto-char (point-min)) + (setq default-directory dir) + (setq buffer-read-only t))) + (display-buffer buffer) + ; shrink window only if it displays the status buffer + (when (eq (window-buffer) (current-buffer)) + (shrink-window-if-larger-than-buffer))) + +(defun git-diff-file () + "Diff the marked file(s) against HEAD." + (interactive) + (let ((files (git-marked-files))) + (git-setup-diff-buffer + (apply #'git-run-command-buffer "*git-diff*" "diff-index" "-p" "-M" "HEAD" "--" (git-get-filenames files))))) + +(defun git-diff-file-merge-head (arg) + "Diff the marked file(s) against the first merge head (or the nth one with a numeric prefix)." + (interactive "p") + (let ((files (git-marked-files)) + (merge-heads (git-get-merge-heads))) + (unless merge-heads (error "No merge in progress")) + (git-setup-diff-buffer + (apply #'git-run-command-buffer "*git-diff*" "diff-index" "-p" "-M" + (or (nth (1- arg) merge-heads) "HEAD") "--" (git-get-filenames files))))) + +(defun git-diff-unmerged-file (stage) + "Diff the marked unmerged file(s) against the specified stage." + (let ((files (git-marked-files))) + (git-setup-diff-buffer + (apply #'git-run-command-buffer "*git-diff*" "diff-files" "-p" stage "--" (git-get-filenames files))))) + +(defun git-diff-file-base () + "Diff the marked unmerged file(s) against the common base file." + (interactive) + (git-diff-unmerged-file "-1")) + +(defun git-diff-file-mine () + "Diff the marked unmerged file(s) against my pre-merge version." + (interactive) + (git-diff-unmerged-file "-2")) + +(defun git-diff-file-other () + "Diff the marked unmerged file(s) against the other's pre-merge version." + (interactive) + (git-diff-unmerged-file "-3")) + +(defun git-diff-file-combined () + "Do a combined diff of the marked unmerged file(s)." + (interactive) + (git-diff-unmerged-file "-c")) + +(defun git-diff-file-idiff () + "Perform an interactive diff on the current file." + (interactive) + (let ((files (git-marked-files-state 'added 'deleted 'modified))) + (unless (eq 1 (length files)) + (error "Cannot perform an interactive diff on multiple files.")) + (let* ((filename (car (git-get-filenames files))) + (buff1 (find-file-noselect filename)) + (buff2 (git-run-command-buffer (concat filename ".~HEAD~") "cat-file" "blob" (concat "HEAD:" filename)))) + (ediff-buffers buff1 buff2)))) + +(defun git-log-file () + "Display a log of changes to the marked file(s)." + (interactive) + (let* ((files (git-marked-files)) + (coding-system-for-read git-commits-coding-system) + (buffer (apply #'git-run-command-buffer "*git-log*" "rev-list" "--pretty" "HEAD" "--" (git-get-filenames files)))) + (with-current-buffer buffer + ; (git-log-mode) FIXME: implement log mode + (goto-char (point-min)) + (setq buffer-read-only t)) + (display-buffer buffer))) + +(defun git-log-edit-files () + "Return a list of marked files for use in the log-edit buffer." + (with-current-buffer log-edit-parent-buffer + (git-get-filenames (git-marked-files-state 'added 'deleted 'modified)))) + +(defun git-log-edit-diff () + "Run a diff of the current files being committed from a log-edit buffer." + (with-current-buffer log-edit-parent-buffer + (git-diff-file))) + +(defun git-append-sign-off (name email) + "Append a Signed-off-by entry to the current buffer, avoiding duplicates." + (let ((sign-off (format "Signed-off-by: %s <%s>" name email)) + (case-fold-search t)) + (goto-char (point-min)) + (unless (re-search-forward (concat "^" (regexp-quote sign-off)) nil t) + (goto-char (point-min)) + (unless (re-search-forward "^Signed-off-by: " nil t) + (setq sign-off (concat "\n" sign-off))) + (goto-char (point-max)) + (insert sign-off "\n")))) + +(defun git-setup-log-buffer (buffer &optional merge-heads author-name author-email subject date msg) + "Setup the log buffer for a commit." + (unless git-status (error "Not in git-status buffer.")) + (let ((dir default-directory) + (committer-name (git-get-committer-name)) + (committer-email (git-get-committer-email)) + (sign-off git-append-signed-off-by)) + (with-current-buffer buffer + (cd dir) + (erase-buffer) + (insert + (propertize + (format "Author: %s <%s>\n%s%s" + (or author-name committer-name) + (or author-email committer-email) + (if date (format "Date: %s\n" date) "") + (if merge-heads + (format "Merge: %s\n" + (mapconcat 'identity merge-heads " ")) + "")) + 'face 'git-header-face) + (propertize git-log-msg-separator 'face 'git-separator-face) + "\n") + (when subject (insert subject "\n\n")) + (cond (msg (insert msg "\n")) + ((file-readable-p ".git/rebase-apply/msg") + (insert-file-contents ".git/rebase-apply/msg")) + ((file-readable-p ".git/MERGE_MSG") + (insert-file-contents ".git/MERGE_MSG"))) + ; delete empty lines at end + (goto-char (point-min)) + (when (re-search-forward "\n+\\'" nil t) + (replace-match "\n" t t)) + (when sign-off (git-append-sign-off committer-name committer-email))) + buffer)) + +(define-derived-mode git-log-edit-mode log-edit-mode "Git-Log-Edit" + "Major mode for editing git log messages. + +Set up git-specific `font-lock-keywords' for `log-edit-mode'." + (set (make-local-variable 'font-lock-defaults) + '(git-log-edit-font-lock-keywords t t))) + +(defun git-commit-file () + "Commit the marked file(s), asking for a commit message." + (interactive) + (unless git-status (error "Not in git-status buffer.")) + (when (git-run-pre-commit-hook) + (let ((buffer (get-buffer-create "*git-commit*")) + (coding-system (git-get-commits-coding-system)) + author-name author-email subject date) + (when (eq 0 (buffer-size buffer)) + (when (file-readable-p ".git/rebase-apply/info") + (with-temp-buffer + (insert-file-contents ".git/rebase-apply/info") + (goto-char (point-min)) + (when (re-search-forward "^Author: \\(.*\\)\nEmail: \\(.*\\)$" nil t) + (setq author-name (match-string 1)) + (setq author-email (match-string 2))) + (goto-char (point-min)) + (when (re-search-forward "^Subject: \\(.*\\)$" nil t) + (setq subject (match-string 1))) + (goto-char (point-min)) + (when (re-search-forward "^Date: \\(.*\\)$" nil t) + (setq date (match-string 1))))) + (git-setup-log-buffer buffer (git-get-merge-heads) author-name author-email subject date)) + (if (boundp 'log-edit-diff-function) + (log-edit 'git-do-commit nil '((log-edit-listfun . git-log-edit-files) + (log-edit-diff-function . git-log-edit-diff)) buffer 'git-log-edit-mode) + (log-edit 'git-do-commit nil 'git-log-edit-files buffer + 'git-log-edit-mode)) + (setq paragraph-separate (concat (regexp-quote git-log-msg-separator) "$\\|Author: \\|Date: \\|Merge: \\|Signed-off-by: \\|\f\\|[ ]*$")) + (setq buffer-file-coding-system coding-system) + (re-search-forward (regexp-quote (concat git-log-msg-separator "\n")) nil t)))) + +(defun git-setup-commit-buffer (commit) + "Setup the commit buffer with the contents of COMMIT." + (let (parents author-name author-email subject date msg) + (with-temp-buffer + (let ((coding-system (git-get-logoutput-coding-system))) + (git-call-process t "log" "-1" "--pretty=medium" "--abbrev=40" commit) + (goto-char (point-min)) + (when (re-search-forward "^Merge: *\\(.*\\)$" nil t) + (setq parents (cdr (split-string (match-string 1) " +")))) + (when (re-search-forward "^Author: *\\(.*\\) <\\(.*\\)>$" nil t) + (setq author-name (match-string 1)) + (setq author-email (match-string 2))) + (when (re-search-forward "^Date: *\\(.*\\)$" nil t) + (setq date (match-string 1))) + (while (re-search-forward "^ \\(.*\\)$" nil t) + (push (match-string 1) msg)) + (setq msg (nreverse msg)) + (setq subject (pop msg)) + (while (and msg (zerop (length (car msg))) (pop msg))))) + (git-setup-log-buffer (get-buffer-create "*git-commit*") + parents author-name author-email subject date + (mapconcat #'identity msg "\n")))) + +(defun git-get-commit-files (commit) + "Retrieve a sorted list of files modified by COMMIT." + (let (files) + (with-temp-buffer + (git-call-process t "diff-tree" "-m" "-r" "-z" "--name-only" "--no-commit-id" "--root" commit) + (goto-char (point-min)) + (while (re-search-forward "\\([^\0]*\\)\0" nil t 1) + (push (match-string 1) files))) + (sort files #'string-lessp))) + +(defun git-read-commit-name (prompt &optional default) + "Ask for a commit name, with completion for local branch, remote branch and tag." + (completing-read prompt + (list* "HEAD" "ORIG_HEAD" "FETCH_HEAD" (mapcar #'car (git-for-each-ref))) + nil nil nil nil default)) + +(defun git-checkout (branch &optional merge) + "Checkout a branch, tag, or any commit. +Use a prefix arg if git should merge while checking out." + (interactive + (list (git-read-commit-name "Checkout: ") + current-prefix-arg)) + (unless git-status (error "Not in git-status buffer.")) + (let ((args (list branch "--"))) + (when merge (push "-m" args)) + (when (apply #'git-call-process-display-error "checkout" args) + (git-update-status-files)))) + +(defun git-branch (branch) + "Create a branch from the current HEAD and switch to it." + (interactive (list (git-read-commit-name "Branch: "))) + (unless git-status (error "Not in git-status buffer.")) + (if (git-rev-parse (concat "refs/heads/" branch)) + (if (yes-or-no-p (format "Branch %s already exists, replace it? " branch)) + (and (git-call-process-display-error "branch" "-f" branch) + (git-call-process-display-error "checkout" branch)) + (message "Canceled.")) + (git-call-process-display-error "checkout" "-b" branch)) + (git-refresh-ewoc-hf git-status)) + +(defun git-amend-commit () + "Undo the last commit on HEAD, and set things up to commit an +amended version of it." + (interactive) + (unless git-status (error "Not in git-status buffer.")) + (when (git-empty-db-p) (error "No commit to amend.")) + (let* ((commit (git-rev-parse "HEAD")) + (files (git-get-commit-files commit))) + (when (if (git-rev-parse "HEAD^") + (git-call-process-display-error "reset" "--soft" "HEAD^") + (and (git-update-ref "ORIG_HEAD" commit) + (git-update-ref "HEAD" nil commit))) + (git-update-status-files files t) + (git-setup-commit-buffer commit) + (git-commit-file)))) + +(defun git-cherry-pick-commit (arg) + "Cherry-pick a commit." + (interactive (list (git-read-commit-name "Cherry-pick commit: "))) + (unless git-status (error "Not in git-status buffer.")) + (let ((commit (git-rev-parse (concat arg "^0")))) + (unless commit (error "Not a valid commit '%s'." arg)) + (when (git-rev-parse (concat commit "^2")) + (error "Cannot cherry-pick a merge commit.")) + (let ((files (git-get-commit-files commit)) + (ok (git-call-process-display-error "cherry-pick" "-n" commit))) + (git-update-status-files files ok) + (with-current-buffer (git-setup-commit-buffer commit) + (goto-char (point-min)) + (if (re-search-forward "^\n*Signed-off-by:" nil t 1) + (goto-char (match-beginning 0)) + (goto-char (point-max))) + (insert "(cherry picked from commit " commit ")\n")) + (when ok (git-commit-file))))) + +(defun git-revert-commit (arg) + "Revert a commit." + (interactive (list (git-read-commit-name "Revert commit: "))) + (unless git-status (error "Not in git-status buffer.")) + (let ((commit (git-rev-parse (concat arg "^0")))) + (unless commit (error "Not a valid commit '%s'." arg)) + (when (git-rev-parse (concat commit "^2")) + (error "Cannot revert a merge commit.")) + (let ((files (git-get-commit-files commit)) + (subject (git-get-commit-description commit)) + (ok (git-call-process-display-error "revert" "-n" commit))) + (git-update-status-files files ok) + (when (string-match "^[0-9a-f]+ - \\(.*\\)$" subject) + (setq subject (match-string 1 subject))) + (git-setup-log-buffer (get-buffer-create "*git-commit*") + (git-get-merge-heads) nil nil (format "Revert \"%s\"" subject) nil + (format "This reverts commit %s.\n" commit)) + (when ok (git-commit-file))))) + +(defun git-find-file () + "Visit the current file in its own buffer." + (interactive) + (unless git-status (error "Not in git-status buffer.")) + (let ((info (ewoc-data (ewoc-locate git-status)))) + (unless (git-expand-directory info) + (find-file (git-fileinfo->name info)) + (when (eq 'unmerged (git-fileinfo->state info)) + (smerge-mode 1))))) + +(defun git-find-file-other-window () + "Visit the current file in its own buffer in another window." + (interactive) + (unless git-status (error "Not in git-status buffer.")) + (let ((info (ewoc-data (ewoc-locate git-status)))) + (find-file-other-window (git-fileinfo->name info)) + (when (eq 'unmerged (git-fileinfo->state info)) + (smerge-mode)))) + +(defun git-find-file-imerge () + "Visit the current file in interactive merge mode." + (interactive) + (unless git-status (error "Not in git-status buffer.")) + (let ((info (ewoc-data (ewoc-locate git-status)))) + (find-file (git-fileinfo->name info)) + (smerge-ediff))) + +(defun git-view-file () + "View the current file in its own buffer." + (interactive) + (unless git-status (error "Not in git-status buffer.")) + (let ((info (ewoc-data (ewoc-locate git-status)))) + (view-file (git-fileinfo->name info)))) + +(defun git-refresh-status () + "Refresh the git status buffer." + (interactive) + (unless git-status (error "Not in git-status buffer.")) + (message "Refreshing git status...") + (git-update-status-files) + (message "Refreshing git status...done")) + +(defun git-status-quit () + "Quit git-status mode." + (interactive) + (bury-buffer)) + +;;;; Major Mode +;;;; ------------------------------------------------------------ + +(defvar git-status-mode-hook nil + "Run after `git-status-mode' is setup.") + +(defvar git-status-mode-map nil + "Keymap for git major mode.") + +(defvar git-status nil + "List of all files managed by the git-status mode.") + +(unless git-status-mode-map + (let ((map (make-keymap)) + (commit-map (make-sparse-keymap)) + (diff-map (make-sparse-keymap)) + (toggle-map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "?" 'git-help) + (define-key map "h" 'git-help) + (define-key map " " 'git-next-file) + (define-key map "a" 'git-add-file) + (define-key map "c" 'git-commit-file) + (define-key map "\C-c" commit-map) + (define-key map "d" diff-map) + (define-key map "=" 'git-diff-file) + (define-key map "f" 'git-find-file) + (define-key map "\r" 'git-find-file) + (define-key map "g" 'git-refresh-status) + (define-key map "i" 'git-ignore-file) + (define-key map "I" 'git-insert-file) + (define-key map "l" 'git-log-file) + (define-key map "m" 'git-mark-file) + (define-key map "M" 'git-mark-all) + (define-key map "n" 'git-next-file) + (define-key map "N" 'git-next-unmerged-file) + (define-key map "o" 'git-find-file-other-window) + (define-key map "p" 'git-prev-file) + (define-key map "P" 'git-prev-unmerged-file) + (define-key map "q" 'git-status-quit) + (define-key map "r" 'git-remove-file) + (define-key map "t" toggle-map) + (define-key map "T" 'git-toggle-all-marks) + (define-key map "u" 'git-unmark-file) + (define-key map "U" 'git-revert-file) + (define-key map "v" 'git-view-file) + (define-key map "x" 'git-remove-handled) + (define-key map "\C-?" 'git-unmark-file-up) + (define-key map "\M-\C-?" 'git-unmark-all) + ; the commit submap + (define-key commit-map "\C-a" 'git-amend-commit) + (define-key commit-map "\C-b" 'git-branch) + (define-key commit-map "\C-o" 'git-checkout) + (define-key commit-map "\C-p" 'git-cherry-pick-commit) + (define-key commit-map "\C-v" 'git-revert-commit) + ; the diff submap + (define-key diff-map "b" 'git-diff-file-base) + (define-key diff-map "c" 'git-diff-file-combined) + (define-key diff-map "=" 'git-diff-file) + (define-key diff-map "e" 'git-diff-file-idiff) + (define-key diff-map "E" 'git-find-file-imerge) + (define-key diff-map "h" 'git-diff-file-merge-head) + (define-key diff-map "m" 'git-diff-file-mine) + (define-key diff-map "o" 'git-diff-file-other) + ; the toggle submap + (define-key toggle-map "u" 'git-toggle-show-uptodate) + (define-key toggle-map "i" 'git-toggle-show-ignored) + (define-key toggle-map "k" 'git-toggle-show-unknown) + (define-key toggle-map "m" 'git-toggle-all-marks) + (setq git-status-mode-map map)) + (easy-menu-define git-menu git-status-mode-map + "Git Menu" + `("Git" + ["Refresh" git-refresh-status t] + ["Commit" git-commit-file t] + ["Checkout..." git-checkout t] + ["New Branch..." git-branch t] + ["Cherry-pick Commit..." git-cherry-pick-commit t] + ["Revert Commit..." git-revert-commit t] + ("Merge" + ["Next Unmerged File" git-next-unmerged-file t] + ["Prev Unmerged File" git-prev-unmerged-file t] + ["Interactive Merge File" git-find-file-imerge t] + ["Diff Against Common Base File" git-diff-file-base t] + ["Diff Combined" git-diff-file-combined t] + ["Diff Against Merge Head" git-diff-file-merge-head t] + ["Diff Against Mine" git-diff-file-mine t] + ["Diff Against Other" git-diff-file-other t]) + "--------" + ["Add File" git-add-file t] + ["Revert File" git-revert-file t] + ["Ignore File" git-ignore-file t] + ["Remove File" git-remove-file t] + ["Insert File" git-insert-file t] + "--------" + ["Find File" git-find-file t] + ["View File" git-view-file t] + ["Diff File" git-diff-file t] + ["Interactive Diff File" git-diff-file-idiff t] + ["Log" git-log-file t] + "--------" + ["Mark" git-mark-file t] + ["Mark All" git-mark-all t] + ["Unmark" git-unmark-file t] + ["Unmark All" git-unmark-all t] + ["Toggle All Marks" git-toggle-all-marks t] + ["Hide Handled Files" git-remove-handled t] + "--------" + ["Show Uptodate Files" git-toggle-show-uptodate :style toggle :selected git-show-uptodate] + ["Show Ignored Files" git-toggle-show-ignored :style toggle :selected git-show-ignored] + ["Show Unknown Files" git-toggle-show-unknown :style toggle :selected git-show-unknown] + "--------" + ["Quit" git-status-quit t]))) + + +;; git mode should only run in the *git status* buffer +(put 'git-status-mode 'mode-class 'special) + +(defun git-status-mode () + "Major mode for interacting with Git. +Commands: +\\{git-status-mode-map}" + (kill-all-local-variables) + (buffer-disable-undo) + (setq mode-name "git status" + major-mode 'git-status-mode + goal-column 17 + buffer-read-only t) + (use-local-map git-status-mode-map) + (let ((buffer-read-only nil)) + (erase-buffer) + (let ((status (ewoc-create 'git-fileinfo-prettyprint "" ""))) + (set (make-local-variable 'git-status) status)) + (set (make-local-variable 'list-buffers-directory) default-directory) + (make-local-variable 'git-show-uptodate) + (make-local-variable 'git-show-ignored) + (make-local-variable 'git-show-unknown) + (run-hooks 'git-status-mode-hook))) + +(defun git-find-status-buffer (dir) + "Find the git status buffer handling a specified directory." + (let ((list (buffer-list)) + (fulldir (expand-file-name dir)) + found) + (while (and list (not found)) + (let ((buffer (car list))) + (with-current-buffer buffer + (when (and list-buffers-directory + (string-equal fulldir (expand-file-name list-buffers-directory)) + (eq major-mode 'git-status-mode)) + (setq found buffer)))) + (setq list (cdr list))) + found)) + +(defun git-status (dir) + "Entry point into git-status mode." + (interactive "DSelect directory: ") + (setq dir (git-get-top-dir dir)) + (if (file-directory-p (concat (file-name-as-directory dir) ".git")) + (let ((buffer (or (and git-reuse-status-buffer (git-find-status-buffer dir)) + (create-file-buffer (expand-file-name "*git-status*" dir))))) + (switch-to-buffer buffer) + (cd dir) + (git-status-mode) + (git-refresh-status) + (goto-char (point-min)) + (add-hook 'after-save-hook 'git-update-saved-file)) + (message "%s is not a git working tree." dir))) + +(defun git-update-saved-file () + "Update the corresponding git-status buffer when a file is saved. +Meant to be used in `after-save-hook'." + (let* ((file (expand-file-name buffer-file-name)) + (dir (condition-case nil (git-get-top-dir (file-name-directory file)) (error nil))) + (buffer (and dir (git-find-status-buffer dir)))) + (when buffer + (with-current-buffer buffer + (let ((filename (file-relative-name file dir))) + ; skip files located inside the .git directory + (unless (string-match "^\\.git/" filename) + (git-call-process nil "add" "--refresh" "--" filename) + (git-update-status-files (list filename)))))))) + +(defun git-help () + "Display help for Git mode." + (interactive) + (describe-function 'git-status-mode)) + +(provide 'git) +;;; git.el ends here diff --git a/.emacs.d/elisp/go-mode.el b/.emacs.d/elisp/go-mode.el new file mode 100644 index 0000000..059f783 --- /dev/null +++ b/.emacs.d/elisp/go-mode.el @@ -0,0 +1,544 @@ +;;; go-mode.el --- Major mode for the Go programming language + +;;; Commentary: + +;; For installation instructions, see go-mode-load.el + +;;; To do: + +;; * Indentation is *almost* identical to gofmt +;; ** We think struct literal keys are labels and outdent them +;; ** We disagree on the indentation of function literals in arguments +;; ** There are bugs with the close brace of struct literals +;; * Highlight identifiers according to their syntactic context: type, +;; variable, function call, or tag +;; * Command for adding an import +;; ** Check if it's already there +;; ** Factor/unfactor the import line +;; ** Alphabetize +;; * Remove unused imports +;; ** This is hard, since I have to be aware of shadowing to do it +;; right +;; * Format region using gofmt + +;;; Code: + +(eval-when-compile (require 'cl)) + +(defvar go-mode-syntax-table + (let ((st (make-syntax-table))) + ;; Add _ to :word: character class + (modify-syntax-entry ?_ "w" st) + + ;; Operators (punctuation) + (modify-syntax-entry ?+ "." st) + (modify-syntax-entry ?- "." st) + (modify-syntax-entry ?* "." st) + (modify-syntax-entry ?/ "." st) + (modify-syntax-entry ?% "." st) + (modify-syntax-entry ?& "." st) + (modify-syntax-entry ?| "." st) + (modify-syntax-entry ?^ "." st) + (modify-syntax-entry ?! "." st) + (modify-syntax-entry ?= "." st) + (modify-syntax-entry ?< "." st) + (modify-syntax-entry ?> "." st) + + ;; Strings + (modify-syntax-entry ?\" "\"" st) + (modify-syntax-entry ?\' "\"" st) + (modify-syntax-entry ?` "\"" st) + (modify-syntax-entry ?\\ "\\" st) + + ;; Comments + (modify-syntax-entry ?/ ". 124b" st) + (modify-syntax-entry ?* ". 23" st) + (modify-syntax-entry ?\n "> b" st) + (modify-syntax-entry ?\^m "> b" st) + + st) + "Syntax table for Go mode.") + +(defvar go-mode-keywords + '("break" "default" "func" "interface" "select" + "case" "defer" "go" "map" "struct" + "chan" "else" "goto" "package" "switch" + "const" "fallthrough" "if" "range" "type" + "continue" "for" "import" "return" "var") + "All keywords in the Go language. Used for font locking and +some syntax analysis.") + +(defvar go-mode-font-lock-keywords + (let ((builtins '("cap" "close" "closed" "len" "make" "new" + "panic" "panicln" "print" "println")) + (constants '("nil" "true" "false" "iota")) + (type-name "\\s *\\(?:[*(]\\s *\\)*\\(?:\\w+\\s *\\.\\s *\\)?\\(\\w+\\)") + ) + `((,(regexp-opt go-mode-keywords 'words) . font-lock-keyword-face) + (,(regexp-opt builtins 'words) . font-lock-builtin-face) + (,(regexp-opt constants 'words) . font-lock-constant-face) + ;; Function names in declarations + ("\\<func\\>\\s *\\(\\w+\\)" 1 font-lock-function-name-face) + ;; Function names in methods are handled by function call pattern + ;; Function names in calls + ;; XXX Doesn't match if function name is surrounded by parens + ("\\(\\w+\\)\\s *(" 1 font-lock-function-name-face) + ;; Type names + ("\\<type\\>\\s *\\(\\w+\\)" 1 font-lock-type-face) + (,(concat "\\<type\\>\\s *\\w+\\s *" type-name) 1 font-lock-type-face) + ;; Arrays/slices/map value type + ;; XXX Wrong. Marks 0 in expression "foo[0] * x" +;; (,(concat "]" type-name) 1 font-lock-type-face) + ;; Map key type + (,(concat "\\<map\\s *\\[" type-name) 1 font-lock-type-face) + ;; Channel value type + (,(concat "\\<chan\\>\\s *\\(?:<-\\)?" type-name) 1 font-lock-type-face) + ;; new/make type + (,(concat "\\<\\(?:new\\|make\\)\\>\\(?:\\s \\|)\\)*(" type-name) 1 font-lock-type-face) + ;; Type conversion + (,(concat "\\.\\s *(" type-name) 1 font-lock-type-face) + ;; Method receiver type + (,(concat "\\<func\\>\\s *(\\w+\\s +" type-name) 1 font-lock-type-face) + ;; Labels + ;; XXX Not quite right. Also marks compound literal fields. + ("^\\s *\\(\\w+\\)\\s *:\\(\\S.\\|$\\)" 1 font-lock-constant-face) + ("\\<\\(goto\\|break\\|continue\\)\\>\\s *\\(\\w+\\)" 2 font-lock-constant-face))) + "Basic font lock keywords for Go mode. Highlights keywords, +built-ins, functions, and some types.") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Key map +;; + +(defvar go-mode-map + (let ((m (make-sparse-keymap))) + (define-key m "}" #'go-mode-insert-and-indent) + (define-key m ")" #'go-mode-insert-and-indent) + (define-key m ":" #'go-mode-delayed-electric) + ;; In case we get : indentation wrong, correct ourselves + (define-key m "=" #'go-mode-insert-and-indent) + m) + "Keymap used by Go mode to implement electric keys.") + +(defun go-mode-insert-and-indent (key) + "Invoke the global binding of KEY, then reindent the line." + + (interactive (list (this-command-keys))) + (call-interactively (lookup-key (current-global-map) key)) + (indent-according-to-mode)) + +(defvar go-mode-delayed-point nil + "The point following the previous insertion if the insertion +was a delayed electric key. Used to communicate between +`go-mode-delayed-electric' and `go-mode-delayed-electric-hook'.") +(make-variable-buffer-local 'go-mode-delayed-point) + +(defun go-mode-delayed-electric (p) + "Perform electric insertion, but delayed by one event. + +This inserts P into the buffer, as usual, then waits for another key. +If that second key causes a buffer modification starting at the +point after the insertion of P, reindents the line containing P." + + (interactive "p") + (self-insert-command p) + (setq go-mode-delayed-point (point))) + +(defun go-mode-delayed-electric-hook (b e l) + "An after-change-function that implements `go-mode-delayed-electric'." + + (when (and go-mode-delayed-point + (= go-mode-delayed-point b)) + (save-excursion + (save-match-data + (goto-char go-mode-delayed-point) + (indent-according-to-mode)))) + (setq go-mode-delayed-point nil)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Parser +;; + +(defvar go-mode-mark-cs-end 1 + "The point at which the comment/string cache ends. The buffer +will be marked from the beginning up to this point (that is, up +to and including character (1- go-mode-mark-cs-end)).") +(make-variable-buffer-local 'go-mode-mark-cs-end) + +(defvar go-mode-mark-cs-state nil + "The `parse-partial-sexp' state of the comment/string parser as +of the point `go-mode-mark-cs-end'.") +(make-variable-buffer-local 'go-mode-mark-cs-state) + +(defvar go-mode-mark-nesting-end 1 + "The point at which the nesting cache ends. The buffer will be +marked from the beginning up to this point.") +(make-variable-buffer-local 'go-mode-mark-nesting-end) + +(defun go-mode-mark-clear-cache (b e l) + "An after-change-function that clears the comment/string and +nesting caches from the modified point on." + + (save-restriction + (widen) + (when (< b go-mode-mark-cs-end) + (remove-text-properties b (min go-mode-mark-cs-end (point-max)) '(go-mode-cs nil)) + (setq go-mode-mark-cs-end b + go-mode-mark-cs-state nil)) + + (when (< b go-mode-mark-nesting-end) + (remove-text-properties b (min go-mode-mark-nesting-end (point-max)) '(go-mode-nesting nil)) + (setq go-mode-mark-nesting-end b)))) + +(defmacro go-mode-parser (&rest body) + "Evaluate BODY in an environment set up for parsers that use +text properties to mark text. This inhibits changes to the undo +list or the buffer's modification status and inhibits calls to +the modification hooks. It also saves the excursion and +restriction and widens the buffer, since most parsers are +context-sensitive." + + (let ((modified-var (make-symbol "modified"))) + `(let ((buffer-undo-list t) + (,modified-var (buffer-modified-p)) + (inhibit-modification-hooks t) + (inhibit-read-only t)) + (save-excursion + (save-restriction + (widen) + (unwind-protect + (progn ,@body) + (set-buffer-modified-p ,modified-var))))))) + +(defsubst go-mode-cs (&optional pos) + "Return the comment/string state at point POS. If point is +inside a comment or string (including the delimiters), this +returns a pair (START . END) indicating the extents of the +comment or string." + + (unless pos + (setq pos (point))) + (if (= pos 1) + nil + (when (> pos go-mode-mark-cs-end) + (go-mode-mark-cs pos)) + (get-text-property (- pos 1) 'go-mode-cs))) + +(defun go-mode-mark-cs (end) + "Mark comments and strings up to point END. Don't call this +directly; use `go-mode-cs'." + + (setq end (min end (point-max))) + (go-mode-parser + (let* ((pos go-mode-mark-cs-end) + (state (or go-mode-mark-cs-state (syntax-ppss pos)))) + ;; Mark comments and strings + (when (nth 8 state) + ;; Get to the beginning of the comment/string + (setq pos (nth 8 state) + state nil)) + (while (> end pos) + ;; Find beginning of comment/string + (while (and (> end pos) + (progn + (setq state (parse-partial-sexp pos end nil nil state 'syntax-table) + pos (point)) + (not (nth 8 state))))) + ;; Find end of comment/string + (let ((start (nth 8 state))) + (when start + (setq state (parse-partial-sexp pos (point-max) nil nil state 'syntax-table) + pos (point)) + ;; Mark comment + (put-text-property start (- pos 1) 'go-mode-cs (cons start pos)) + (when nil + (put-text-property start (- pos 1) 'face + `((:background "midnight blue"))))))) + ;; Update state + (setq go-mode-mark-cs-end pos + go-mode-mark-cs-state state)))) + +(defsubst go-mode-nesting (&optional pos) + "Return the nesting at point POS. The nesting is a list +of (START . END) pairs for all braces, parens, and brackets +surrounding POS, starting at the inner-most nesting. START is +the location of the open character. END is the location of the +close character or nil if the nesting scanner has not yet +encountered the close character." + + (unless pos + (setq pos (point))) + (if (= pos 1) + '() + (when (> pos go-mode-mark-nesting-end) + (go-mode-mark-nesting pos)) + (get-text-property (- pos 1) 'go-mode-nesting))) + +(defun go-mode-mark-nesting (pos) + "Mark nesting up to point END. Don't call this directly; use +`go-mode-nesting'." + + (go-mode-cs pos) + (go-mode-parser + ;; Mark depth + (goto-char go-mode-mark-nesting-end) + (let ((nesting (go-mode-nesting)) + (last (point))) + (while (< last pos) + ;; Find the next depth-changing character + (skip-chars-forward "^(){}[]" pos) + ;; Mark everything up to this character with the current + ;; nesting + (put-text-property last (point) 'go-mode-nesting nesting) + (when nil + (let ((depth (length nesting))) + (put-text-property last (point) 'face + `((:background + ,(format "gray%d" (* depth 10))))))) + (setq last (point)) + ;; Update nesting + (unless (eobp) + (let ((ch (unless (go-mode-cs) (char-after)))) + (forward-char 1) + (case ch + ((?\( ?\{ ?\[) + (setq nesting (cons (cons (- (point) 1) nil) + nesting))) + ((?\) ?\} ?\]) + (when nesting + (setcdr (car nesting) (- (point) 1)) + (setq nesting (cdr nesting)))))))) + ;; Update state + (setq go-mode-mark-nesting-end last)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Indentation +;; + +(defvar go-mode-non-terminating-keywords-regexp + (let* ((kws go-mode-keywords) + (kws (remove "break" kws)) + (kws (remove "continue" kws)) + (kws (remove "fallthrough" kws)) + (kws (remove "return" kws))) + (regexp-opt kws 'words)) + "Regular expression matching all Go keywords that *do not* +implicitly terminate a statement.") + +(defun go-mode-semicolon-p () + "True iff point immediately follows either an explicit or +implicit semicolon. Point should immediately follow the last +token on the line." + + ;; #Semicolons + (case (char-before) + ((?\;) t) + ;; String literal + ((?' ?\" ?`) t) + ;; One of the operators and delimiters ++, --, ), ], or } + ((?+) (eq (char-before (1- (point))) ?+)) + ((?-) (eq (char-before (1- (point))) ?-)) + ((?\) ?\] ?\}) t) + ;; An identifier or one of the keywords break, continue, + ;; fallthrough, or return or a numeric literal + (otherwise + (save-excursion + (when (/= (skip-chars-backward "[:word:]_") 0) + (not (looking-at go-mode-non-terminating-keywords-regexp))))))) + +(defun go-mode-indentation () + "Compute the ideal indentation level of the current line. + +To the first order, this is the brace depth of the current line, +plus parens that follow certain keywords. case, default, and +labels are outdented one level, and continuation lines are +indented one level." + + (save-excursion + (back-to-indentation) + (let ((cs (go-mode-cs))) + ;; Treat comments and strings differently only if the beginning + ;; of the line is contained within them + (when (and cs (= (point) (car cs))) + (setq cs nil)) + ;; What type of context am I in? + (cond + ((and cs (save-excursion + (goto-char (car cs)) + (looking-at "\\s\""))) + ;; Inside a multi-line string. Don't mess with indentation. + nil) + (cs + ;; Inside a general comment + (goto-char (car cs)) + (forward-char 1) + (current-column)) + (t + ;; Not in a multi-line string or comment + (let ((indent 0) + (inside-indenting-paren nil)) + ;; Count every enclosing brace, plus parens that follow + ;; import, const, var, or type and indent according to + ;; depth. This simple rule does quite well, but also has a + ;; very large extent. It would be better if we could mimic + ;; some nearby indentation. + (save-excursion + (skip-chars-forward "})") + (let ((first t)) + (dolist (nest (go-mode-nesting)) + (case (char-after (car nest)) + ((?\{) + (incf indent tab-width)) + ((?\() + (goto-char (car nest)) + (forward-comment (- (buffer-size))) + ;; Really just want the token before + (when (looking-back "\\<import\\|const\\|var\\|type" + (max (- (point) 7) (point-min))) + (incf indent tab-width) + (when first + (setq inside-indenting-paren t))))) + (setq first nil)))) + + ;; case, default, and labels are outdented 1 level + (when (looking-at "\\<case\\>\\|\\<default\\>\\|\\w+\\s *:\\(\\S.\\|$\\)") + (decf indent tab-width)) + + ;; Continuation lines are indented 1 level + (forward-comment (- (buffer-size))) + (when (case (char-before) + ((nil ?\{ ?:) + ;; At the beginning of a block or the statement + ;; following a label. + nil) + ((?\() + ;; Usually a continuation line in an expression, + ;; unless this paren is part of a factored + ;; declaration. + (not inside-indenting-paren)) + ((?,) + ;; Could be inside a literal. We're a little + ;; conservative here and consider any comma within + ;; curly braces (as opposed to parens) to be a + ;; literal separator. This will fail to recognize + ;; line-breaks in parallel assignments as + ;; continuation lines. + (let ((depth (go-mode-nesting))) + (and depth + (not (eq (char-after (caar depth)) ?\{))))) + (t + ;; We're in the middle of a block. Did the + ;; previous line end with an implicit or explicit + ;; semicolon? + (not (go-mode-semicolon-p)))) + (incf indent tab-width)) + + (max indent 0))))))) + +(defun go-mode-indent-line () + "Indent the current line according to `go-mode-indentation'." + (interactive) + + (let ((col (go-mode-indentation))) + (when col + (let ((offset (- (current-column) (current-indentation)))) + (indent-line-to col) + (when (> offset 0) + (forward-char offset)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Go mode +;; + +;;;###autoload +(define-derived-mode go-mode prog-mode "Go" + "Major mode for editing Go source text. + +This provides basic syntax highlighting for keywords, built-ins, +functions, and some types. It also provides indentation that is +\(almost) identical to gofmt." + + ;; Font lock + (set (make-local-variable 'font-lock-defaults) + '(go-mode-font-lock-keywords nil nil nil nil)) + + ;; Remove stale text properties + (save-restriction + (widen) + (remove-text-properties 1 (point-max) + '(go-mode-cs nil go-mode-nesting nil))) + + ;; Reset the syntax mark caches + (setq go-mode-mark-cs-end 1 + go-mode-mark-cs-state nil + go-mode-mark-nesting-end 1) + (add-hook 'after-change-functions #'go-mode-mark-clear-cache nil t) + + ;; Indentation + (set (make-local-variable 'indent-line-function) + #'go-mode-indent-line) + (add-hook 'after-change-functions #'go-mode-delayed-electric-hook nil t) + + ;; Comments + (set (make-local-variable 'comment-start) "// ") + (set (make-local-variable 'comment-end) "") + + ;; Go style + (setq indent-tabs-mode t)) + +;;;###autoload +(add-to-list 'auto-mode-alist (cons "\\.go$" #'go-mode)) + +(defun go-mode-reload () + "Reload go-mode.el and put the current buffer into Go mode. +Useful for development work." + + (interactive) + (unload-feature 'go-mode) + (require 'go-mode) + (go-mode)) + +;;;###autoload +(defun gofmt () + "Pipe the current buffer through the external tool `gofmt`. +Replace the current buffer on success; display errors on failure." + + (interactive) + (let ((srcbuf (current-buffer))) + (with-temp-buffer + (let ((outbuf (current-buffer)) + (errbuf (get-buffer-create "*Gofmt Errors*")) + (coding-system-for-read 'utf-8) ;; use utf-8 with subprocesses + (coding-system-for-write 'utf-8)) + (with-current-buffer errbuf (erase-buffer)) + (with-current-buffer srcbuf + (save-restriction + (let (deactivate-mark) + (widen) + (if (= 0 (shell-command-on-region (point-min) (point-max) "gofmt" + outbuf nil errbuf)) + ;; gofmt succeeded: replace the current buffer with outbuf, + ;; restore the mark and point, and discard errbuf. + (let ((old-mark (mark t)) (old-point (point))) + (erase-buffer) + (insert-buffer-substring outbuf) + (goto-char (min old-point (point-max))) + (if old-mark (push-mark (min old-mark (point-max)) t)) + (kill-buffer errbuf)) + + ;; gofmt failed: display the errors + (display-buffer errbuf))))) + + ;; Collapse any window opened on outbuf if shell-command-on-region + ;; displayed it. + (delete-windows-on outbuf))))) + +;;;###autoload +(defun gofmt-before-save () + "Add this to .emacs to run gofmt on the current buffer when saving: + (add-hook 'before-save-hook #'gofmt-before-save)" + + (interactive) + (when (eq major-mode 'go-mode) (gofmt))) + +(provide 'go-mode) diff --git a/.emacs.d/elisp/graphviz-dot-mode.el b/.emacs.d/elisp/graphviz-dot-mode.el new file mode 100644 index 0000000..6691d0e --- /dev/null +++ b/.emacs.d/elisp/graphviz-dot-mode.el @@ -0,0 +1,946 @@ +;;; graphviz-dot-mode.el --- Mode for the dot-language used by graphviz (att). + +;; Copyright (C) 2002 - 2011 Pieter Pareit <pieter.pareit@gmail.com> + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2 of +;; the License, or (at your option) any later version. + +;; This program is distributed in the hope that it will be +;; useful, but WITHOUT ANY WARRANTY; without even the implied +;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +;; PURPOSE. See the GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public +;; License along with this program; if not, write to the Free +;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, +;; MA 02111-1307 USA + +;; Authors: Pieter Pareit <pieter.pareit@gmail.com> +;; Rubens Ramos <rubensr AT users.sourceforge.net> +;; Eric Anderson http://www.ece.cmu.edu/~andersoe/ +;; Maintainer: Pieter Pareit <pieter.pareit@gmail.com> +;; Homepage: http://users.skynet.be/ppareit/projects/graphviz-dot-mode/graphviz-dot-mode.html +;; Created: 28 Oct 2002 +;; Last modified: 09 march 2011 +;; Version: 0.3.7 +;; Keywords: mode dot dot-language dotlanguage graphviz graphs att + +;;; Commentary: +;; Use this mode for editing files in the dot-language (www.graphviz.org and +;; http://www.research.att.com/sw/tools/graphviz/). +;; +;; To use graphviz-dot-mode, add +;; (load-file "PATH_TO_FILE/graphviz-dot-mode.el") +;; to your ~/.emacs(.el) or ~/.xemacs/init.el +;; +;; The graphviz-dot-mode will do font locking, indentation, preview of graphs +;; and eases compilation/error location. There is support for both GNU Emacs +;; and XEmacs. +;; +;; Font locking is automatic, indentation uses the same commands as +;; other modes, tab, M-j and C-M-q. Insertion of comments uses the +;; same commands as other modes, M-; . You can compile a file using +;; M-x compile or C-c c, after that M-x next-error will also work. +;; There is support for viewing an generated image with C-c p. + +;;; Todo: +;; * cleanup the mess of graphviz-dot-compilation-parse-errors. +;; * electric indentation is fundamentally broken, because +;; {...} are also used for record nodes. You could argue, I suppose, that +;; many diagrams don't need those, but it would be worth having a note (and +;; it makes sense that the default is now for electric indentation to be +;; off). +;; * lines that start with # are comments, lines that start with one or more +;; whitespaces and then a # should give an error. + +;;; History: + +;; Version 0.3.7 Tim Allen +;; 09/03/2011: * fix spaces in file names when compiling +;; Version 0.3.6 maintenance +;; 19/02/2011: * .gv is the new extension (Pander) +;; * comments can start with # (Pander) +;; * highlight of new keywords (Pander) +;; Version 0.3.5 bug (or at least feature I dislike) fix +;; 11/11/2010: Eric Anderson http://www.ece.cmu.edu/~andersoe/ +;; * Preserve indentation across blank (whitespace-only) lines +;; Version 0.3.4 bug fixes +;; 24/02/2005: * fixed a bug in graphviz-dot-preview +;; Version 0.3.3 bug fixes +;; 13/02/2005: Reuben Thomas <rrt AT sc3d.org> +;; * add graphviz-dot-indent-width +;; Version 0.3.2 bug fixes +;; 25/03/2004: Rubens Ramos <rubensr AT users.sourceforge.net> +;; * semi-colons and brackets are added when electric +;; behaviour is disabled. +;; * electric characters do not behave electrically inside +;; comments or strings. +;; * default for electric-braces is disabled now (makes more +;; sense I guess). +;; * using read-from-minibuffer instead of read-shell-command +;; for emacs. +;; * Fixed test for easymenu, so that it works on older +;; versions of XEmacs. +;; * Fixed indentation error when trying to indent last brace +;; of an empty graph. +;; * region-active-p does not exist in emacs (21.2 at least), +;; so removed from code +;; * Added uncomment menu option +;; Version 0.3.1 bug fixes +;; 03/03/2004: * backward-word needs argument for older emacs +;; Version 0.3 added features and fixed bugs +;; 10/01/2004: fixed a bug in graphviz-dot-indent-graph +;; 08/01/2004: Rubens Ramos <rubensr AT users.sourceforge.net> +;; * added customization support +;; * Now it works on XEmacs and Emacs +;; * Added support to use an external Viewer +;; * Now things do not break when dot mode is entered +;; when there is no buffer name, but the side effect is +;; that in this case, the compilation command is not +;; correct. +;; * Preview works on XEmacs and emacs. +;; * Electric indentation on newline +;; * Minor changes to indentation +;; * Added keyword completion (but could be A LOT better) +;; * There are still a couple of ugly hacks. Look for 'RR'. +;; Version 0.2 added features +;; 11/11/2002: added preview support. +;; 10/11/2002: indent a graph or subgraph at once with C-M-q. +;; 08/11/2002: relaxed rules for indentation, the may now be extra chars +;; after beginning of graph (comment's for example). +;; Version 0.1.2 bug fixes and naming issues +;; 06/11/2002: renamed dot-font-lock-defaults to dot-font-lock-keywords. +;; added some documentation to dot-colors. +;; provided a much better way to handle my max-specpdl-size +;; problem. +;; added an extra autoload cookie (hope this helps, as I don't +;; yet use autoload myself) +;; Version 0.1.1 bug fixes +;; 06/11/2002: added an missing attribute, for font-locking to work. +;; fixed the regex generating, so that it only recognizes +;; whole words +;; 05/11/2002: there can now be extra white space chars after an '{'. +;; 04/11/2002: Why I use max-specpdl-size is now documented, and old value +;; gets restored. +;; Version 0.1 initial release +;; 02/11/2002: implemented parser for *compilation* of a .dot file. +;; 01/11/2002: implemented compilation of an .dot file. +;; 31/10/2002: added syntax-table to the mode. +;; 30/10/2002: implemented indentation code. +;; 29/10/2002: implemented all of font-lock. +;; 28/10/2002: derived graphviz-dot-mode from fundamental-mode, started +;; implementing font-lock. + +;;; Code: + +(defconst graphviz-dot-mode-version "0.3.6" + "Version of `graphviz-dot-mode.el'.") + +(defgroup graphviz nil + "Major mode for editing Graphviz Dot files" + :group 'tools) + +(defun graphviz-dot-customize () + "Run \\[customize-group] for the `graphviz' group." + (interactive) + (customize-group 'graphviz)) + +(defvar graphviz-dot-mode-abbrev-table nil + "Abbrev table in use in Graphviz Dot mode buffers.") +(define-abbrev-table 'graphviz-dot-mode-abbrev-table ()) + +(defcustom graphviz-dot-dot-program "dot" + "*Location of the dot program. This is used by `compile'." + :type 'string + :group 'graphviz) + +(defcustom graphviz-dot-view-command "doted %s" + "*External program to run on the buffer. You can use `%s' in this string, +and it will be substituted by the buffer name." + :type 'string + :group 'graphviz) + +(defcustom graphviz-dot-view-edit-command nil + "*Whether to allow the user to edit the command to run an external +viewer." + :type 'boolean + :group 'graphviz) + +(defcustom graphviz-dot-save-before-view t + "*If not nil, M-x graphviz-dot-view saves the current buffer before running +the command." + :type 'boolean + :group 'graphviz) + +(defcustom graphviz-dot-auto-indent-on-newline t + "*If not nil, `electric-graphviz-dot-terminate-line' is executed in a line is terminated." + :type 'boolean + :group 'graphviz) + +(defcustom graphviz-dot-indent-width default-tab-width + "*Indentation width in Graphviz Dot mode buffers." + :type 'integer + :group 'graphviz) + +(defcustom graphviz-dot-auto-indent-on-braces nil + "*If not nil, `electric-graphviz-dot-open-brace' and `electric-graphviz-dot-close-brace' are executed when { or } are typed" + :type 'boolean + :group 'graphviz) + +(defcustom graphviz-dot-auto-indent-on-semi t + "*If not nil, `electric-graphviz-dot-semi' is executed when semicolon is typed" + :type 'boolean + :group 'graphviz) + +(defcustom graphviz-dot-preview-extension "png" + "*The extension to use for the compilation and preview commands. The format +for the compilation command is +`dot -T<extension> file.dot > file.<extension>'." + :type 'string + :group 'graphviz) + +(defcustom graphviz-dot-toggle-completions nil + "*Non-nil means that repeated use of \ +\\<graphviz-dot-mode-map>\\[graphviz-dot-complete-word] will toggle the possible +completions in the minibuffer. Normally, when there is more than one possible +completion, a buffer will display all completions." + :type 'boolean + :group 'graphviz) + +(defcustom graphviz-dot-delete-completions nil + "*Non-nil means that the completion buffer is automatically deleted when a +key is pressed." + :type 'boolean + :group 'graphviz) + +(defcustom graphviz-dot-attr-keywords + '("graph" "digraph" "subgraph" "node" "edge" "strict" "rankdir" + "size" "page" "Damping" "Epsilon" "URL" "arrowhead" "arrowsize" + "arrowtail" "bb" "bgcolor" "bottomlabel" "center" "clusterrank" + "color" "comment" "compound" "concentrate" "constraint" "decorate" + "dim" "dir" "distortion" "fillcolor" "fixedsize" "fontcolor" + "fontname" "fontpath" "fontsize" "group" "headURL" "headlabel" + "headport" "height" "label" "labelangle" "labeldistance" "labelfloat" + "labelfontcolor" "labelfontname" "labelfontsize" "labeljust" + "labelloc" "layer" "layers" "len" "lhead" "lp" "ltail" "margin" + "maxiter" "mclimit" "minlen" "model" "nodesep" "normalize" "nslimit" + "nslimit1" "ordering" "orientation" "overlap" "pack" "pagedir" + "pencolor" "peripheries" "pin" "pos" "quantum" "rank" "ranksep" + "ratio" "rects" "regular" "remincross" "rotate" "samehead" "sametail" + "samplepoint" "searchsize" "sep" "shape" "shapefile" "showboxes" + "sides" "skew" "splines" "start" "style" "stylesheet" "tailURL" + "taillabel" "tailport" "toplabel" "vertices" "voro_margin" "weight" + "z" "width" "penwidth" "mindist" "scale" "patch" "root") + "*Keywords for attribute names in a graph. This is used by the auto +completion code. The actual completion tables are built when the mode +is loaded, so changes to this are not immediately visible. +Check http://www.graphviz.org/doc/schema/attributes.xml on new releases." + :type '(repeat (string :tag "Keyword")) + :group 'graphviz) + +(defcustom graphviz-dot-value-keywords + '("true" "false" "normal" "inv" "dot" "invdot" "odot" "invodot" + "none" "tee" "empty" "invempty" "diamond" "odiamond" "box" "obox" + "open" "crow" "halfopen" "local" "global" "none" "forward" "back" + "both" "none" "BL" "BR" "TL" "TR" "RB" "RT" "LB" "LT" ":n" ":ne" ":e" + ":se" ":s" ":sw" ":w" ":nw" "same" "min" "source" "max" "sink" "LR" + "box" "polygon" "ellipse" "circle" "point" "egg" "triangle" + "plaintext" "diamond" "trapezium" "parallelogram" "house" "hexagon" + "octagon" "doublecircle" "doubleoctagon" "tripleoctagon" "invtriangle" + "invtrapezium" "invhouse" "Mdiamond" "Msquare" "Mcircle" "record" + "Mrecord" "dashed" "dotted" "solid" "invis" "bold" "filled" + "diagonals" "rounded" ) + "*Keywords for attribute values. This is used by the auto completion +code. The actual completion tables are built when the mode is loaded, +so changes to this are not immediately visible." + :type '(repeat (string :tag "Keyword")) + :group 'graphviz) + +;;; Font-locking: +(defvar graphviz-dot-colors-list + '(aliceblue antiquewhite antiquewhite1 antiquewhite2 + antiquewhite3 antiquewhite4 aquamarine aquamarine1 + aquamarine2 aquamarine3 aquamarine4 azure azure1 + azure2 azure3 azure4 beige bisque bisque1 bisque2 + bisque3 bisque4 black blanchedalmond blue blue1 + blue2 blue3 blue4 blueviolet brown brown1 brown2 + brown3 brown4 burlywood burlywood1 burlywood2 + burlywood3 burlywood4 cadetblue cadetblue1 + cadetblue2 cadetblue3 cadetblue4 chartreuse + chartreuse1 chartreuse2 chartreuse3 chartreuse4 + chocolate chocolate1 chocolate2 chocolate3 chocolate4 + coral coral1 coral2 coral3 coral4 cornflowerblue + cornsilk cornsilk1 cornsilk2 cornsilk3 cornsilk4 + crimson cyan cyan1 cyan2 cyan3 cyan4 darkgoldenrod + darkgoldenrod1 darkgoldenrod2 darkgoldenrod3 + darkgoldenrod4 darkgreen darkkhaki darkolivegreen + darkolivegreen1 darkolivegreen2 darkolivegreen3 + darkolivegreen4 darkorange darkorange1 darkorange2 + darkorange3 darkorange4 darkorchid darkorchid1 + darkorchid2 darkorchid3 darkorchid4 darksalmon + darkseagreen darkseagreen1 darkseagreen2 + darkseagreen3 darkseagreen4 darkslateblue + darkslategray darkslategray1 darkslategray2 + darkslategray3 darkslategray4 darkslategrey + darkturquoise darkviolet deeppink deeppink1 + deeppink2 deeppink3 deeppink4 deepskyblue + deepskyblue1 deepskyblue2 deepskyblue3 deepskyblue4 + dimgray dimgrey dodgerblue dodgerblue1 dodgerblue2 + dodgerblue3 dodgerblue4 firebrick firebrick1 + firebrick2 firebrick3 firebrick4 floralwhite + forestgreen gainsboro ghostwhite gold gold1 gold2 + gold3 gold4 goldenrod goldenrod1 goldenrod2 + goldenrod3 goldenrod4 gray gray0 gray1 gray10 gray100 + gray11 gray12 gray13 gray14 gray15 gray16 gray17 + gray18 gray19 gray2 gray20 gray21 gray22 gray23 + gray24 gray25 gray26 gray27 gray28 gray29 gray3 + gray30 gray31 gray32 gray33 gray34 gray35 gray36 + gray37 gray38 gray39 gray4 gray40 gray41 gray42 + gray43 gray44 gray45 gray46 gray47 gray48 gray49 + gray5 gray50 gray51 gray52 gray53 gray54 gray55 + gray56 gray57 gray58 gray59 gray6 gray60 gray61 + gray62 gray63 gray64 gray65 gray66 gray67 gray68 + gray69 gray7 gray70 gray71 gray72 gray73 gray74 + gray75 gray76 gray77 gray78 gray79 gray8 gray80 + gray81 gray82 gray83 gray84 gray85 gray86 gray87 + gray88 gray89 gray9 gray90 gray91 gray92 gray93 + gray94 gray95 gray96 gray97 gray98 gray99 green + green1 green2 green3 green4 greenyellow grey grey0 + grey1 grey10 grey100 grey11 grey12 grey13 grey14 + grey15 grey16 grey17 grey18 grey19 grey2 grey20 + grey21 grey22 grey23 grey24 grey25 grey26 grey27 + grey28 grey29 grey3 grey30 grey31 grey32 grey33 + grey34 grey35 grey36 grey37 grey38 grey39 grey4 + grey40 grey41 grey42 grey43 grey44 grey45 grey46 + grey47 grey48 grey49 grey5 grey50 grey51 grey52 + grey53 grey54 grey55 grey56 grey57 grey58 grey59 + grey6 grey60 grey61 grey62 grey63 grey64 grey65 + grey66 grey67 grey68 grey69 grey7 grey70 grey71 + grey72 grey73 grey74 grey75 grey76 grey77 grey78 + grey79 grey8 grey80 grey81 grey82 grey83 grey84 + grey85 grey86 grey87 grey88 grey89 grey9 grey90 + grey91 grey92 grey93 grey94 grey95 grey96 grey97 + grey98 grey99 honeydew honeydew1 honeydew2 honeydew3 + honeydew4 hotpink hotpink1 hotpink2 hotpink3 hotpink4 + indianred indianred1 indianred2 indianred3 indianred4 + indigo ivory ivory1 ivory2 ivory3 ivory4 khaki khaki1 + khaki2 khaki3 khaki4 lavender lavenderblush + lavenderblush1 lavenderblush2 lavenderblush3 + lavenderblush4 lawngreen lemonchiffon lemonchiffon1 + lemonchiffon2 lemonchiffon3 lemonchiffon4 lightblue + lightblue1 lightblue2 lightblue3 lightblue4 + lightcoral lightcyan lightcyan1 lightcyan2 lightcyan3 + lightcyan4 lightgoldenrod lightgoldenrod1 + lightgoldenrod2 lightgoldenrod3 lightgoldenrod4 + lightgoldenrodyellow lightgray lightgrey lightpink + lightpink1 lightpink2 lightpink3 lightpink4 + lightsalmon lightsalmon1 lightsalmon2 lightsalmon3 + lightsalmon4 lightseagreen lightskyblue lightskyblue1 + lightskyblue2 lightskyblue3 lightskyblue4 + lightslateblue lightslategray lightslategrey + lightsteelblue lightsteelblue1 lightsteelblue2 + lightsteelblue3 lightsteelblue4 lightyellow + lightyellow1 lightyellow2 lightyellow3 lightyellow4 + limegreen linen magenta magenta1 magenta2 magenta3 + magenta4 maroon maroon1 maroon2 maroon3 maroon4 + mediumaquamarine mediumblue mediumorchid + mediumorchid1 mediumorchid2 mediumorchid3 + mediumorchid4 mediumpurple mediumpurple1 + mediumpurple2 mediumpurple3 mediumpurple4 + mediumseagreen mediumslateblue mediumspringgreen + mediumturquoise mediumvioletred midnightblue + mintcream mistyrose mistyrose1 mistyrose2 mistyrose3 + mistyrose4 moccasin navajowhite navajowhite1 + navajowhite2 navajowhite3 navajowhite4 navy navyblue + oldlace olivedrab olivedrap olivedrab1 olivedrab2 + olivedrap3 oragne palegoldenrod palegreen palegreen1 + palegreen2 palegreen3 palegreen4 paleturquoise + paleturquoise1 paleturquoise2 paleturquoise3 + paleturquoise4 palevioletred palevioletred1 + palevioletred2 palevioletred3 palevioletred4 + papayawhip peachpuff peachpuff1 peachpuff2 + peachpuff3 peachpuff4 peru pink pink1 pink2 pink3 + pink4 plum plum1 plum2 plum3 plum4 powderblue + purple purple1 purple2 purple3 purple4 red red1 red2 + red3 red4 rosybrown rosybrown1 rosybrown2 rosybrown3 + rosybrown4 royalblue royalblue1 royalblue2 royalblue3 + royalblue4 saddlebrown salmon salmon1 salmon2 salmon3 + salmon4 sandybrown seagreen seagreen1 seagreen2 + seagreen3 seagreen4 seashell seashell1 seashell2 + seashell3 seashell4 sienna sienna1 sienna2 sienna3 + sienna4 skyblue skyblue1 skyblue2 skyblue3 skyblue4 + slateblue slateblue1 slateblue2 slateblue3 slateblue4 + slategray slategray1 slategray2 slategray3 slategray4 + slategrey snow snow1 snow2 snow3 snow4 springgreen + springgreen1 springgreen2 springgreen3 springgreen4 + steelblue steelblue1 steelblue2 steelblue3 steelblue4 + tan tan1 tan2 tan3 tan4 thistle thistle1 thistle2 + thistle3 thistle4 tomato tomato1 tomato2 tomato3 + tomato4 transparent turquoise turquoise1 turquoise2 + turquoise3 turquoise4 violet violetred violetred1 + violetred2 violetred3 violetred4 wheat wheat1 wheat2 + wheat3 wheat4 white whitesmoke yellow yellow1 yellow2 + yellow3 yellow4 yellowgreen) + "Possible color constants in the dot language. +The list of constant is available at http://www.research.att.com/~erg/graphviz\ +/info/colors.html") + + +(defvar graphviz-dot-color-keywords + (mapcar 'symbol-name graphviz-dot-colors-list)) + +(defvar graphviz-attr-keywords + (mapcar '(lambda (elm) (cons elm 0)) graphviz-dot-attr-keywords)) + +(defvar graphviz-value-keywords + (mapcar '(lambda (elm) (cons elm 0)) graphviz-dot-value-keywords)) + +(defvar graphviz-color-keywords + (mapcar '(lambda (elm) (cons elm 0)) graphviz-dot-color-keywords)) + +;;; Key map +(defvar graphviz-dot-mode-map () + "Keymap used in Graphviz Dot mode.") + +(if graphviz-dot-mode-map + () + (let ((map (make-sparse-keymap))) + (define-key map "\r" 'electric-graphviz-dot-terminate-line) + (define-key map "{" 'electric-graphviz-dot-open-brace) + (define-key map "}" 'electric-graphviz-dot-close-brace) + (define-key map ";" 'electric-graphviz-dot-semi) + (define-key map "\M-\t" 'graphviz-dot-complete-word) + (define-key map "\C-\M-q" 'graphviz-dot-indent-graph) + (define-key map "\C-cp" 'graphviz-dot-preview) + (define-key map "\C-cc" 'compile) + (define-key map "\C-cv" 'graphviz-dot-view) + (define-key map "\C-c\C-c" 'comment-region) + (define-key map "\C-c\C-u" 'graphviz-dot-uncomment-region) + (setq graphviz-dot-mode-map map) + )) + +;;; Syntax table +(defvar graphviz-dot-mode-syntax-table nil + "Syntax table for `graphviz-dot-mode'.") + +(if graphviz-dot-mode-syntax-table + () + (let ((st (make-syntax-table))) + (modify-syntax-entry ?/ ". 124b" st) + (modify-syntax-entry ?* ". 23" st) + (modify-syntax-entry ?\n "> b" st) + (modify-syntax-entry ?= "." st) + (modify-syntax-entry ?_ "_" st) + (modify-syntax-entry ?- "_" st) + (modify-syntax-entry ?> "." st) + (modify-syntax-entry ?[ "(" st) + (modify-syntax-entry ?] ")" st) + (modify-syntax-entry ?\" "\"" st) + (setq graphviz-dot-mode-syntax-table st) + )) + +(defvar graphviz-dot-font-lock-keywords + `(("\\(:?di\\|sub\\)?graph \\(\\sw+\\)" + (2 font-lock-function-name-face)) + (,(regexp-opt graphviz-dot-value-keywords 'words) + . font-lock-reference-face) + ;; to build the font-locking for the colors, + ;; we need more room for max-specpdl-size, + ;; after that we take the list of symbols, + ;; convert them to a list of strings, and make + ;; an optimized regexp from them + (,(let ((max-specpdl-size (max max-specpdl-size 1200))) + (regexp-opt graphviz-dot-color-keywords)) + . font-lock-string-face) + (,(concat + (regexp-opt graphviz-dot-attr-keywords 'words) + "[ \\t\\n]*=") + ;; RR - ugly, really, but I dont know why xemacs does not work + ;; if I change the next car to "1"... + (0 font-lock-variable-name-face))) + "Keyword highlighting specification for `graphviz-dot-mode'.") + +;;;###autoload +(defun graphviz-dot-mode () + "Major mode for the dot language. \\<graphviz-dot-mode-map> +TAB indents for graph lines. + +\\[graphviz-dot-indent-graph]\t- Indentaion function. +\\[graphviz-dot-preview]\t- Previews graph in a buffer. +\\[graphviz-dot-view]\t- Views graph in an external viewer. +\\[graphviz-dot-indent-line]\t- Indents current line of code. +\\[graphviz-dot-complete-word]\t- Completes the current word. +\\[electric-graphviz-dot-terminate-line]\t- Electric newline. +\\[electric-graphviz-dot-open-brace]\t- Electric open braces. +\\[electric-graphviz-dot-close-brace]\t- Electric close braces. +\\[electric-graphviz-dot-semi]\t- Electric semi colons. + +Variables specific to this mode: + + graphviz-dot-dot-program (default `dot') + Location of the dot program. + graphviz-dot-view-command (default `doted %s') + Command to run when `graphviz-dot-view' is executed. + graphviz-dot-view-edit-command (default nil) + If the user should be asked to edit the view command. + graphviz-dot-save-before-view (default t) + Automatically save current buffer berore `graphviz-dot-view'. + graphviz-dot-preview-extension (default `png') + File type to use for `graphviz-dot-preview'. + graphviz-dot-auto-indent-on-newline (default t) + Whether to run `electric-graphviz-dot-terminate-line' when + newline is entered. + graphviz-dot-auto-indent-on-braces (default t) + Whether to run `electric-graphviz-dot-open-brace' and + `electric-graphviz-dot-close-brace' when braces are + entered. + graphviz-dot-auto-indent-on-semi (default t) + Whether to run `electric-graphviz-dot-semi' when semi colon + is typed. + graphviz-dot-toggle-completions (default nil) + If completions should be displayed in the buffer instead of a + completion buffer when \\[graphviz-dot-complete-word] is + pressed repeatedly. + +This mode can be customized by running \\[graphviz-dot-customize]. + +Turning on Graphviz Dot mode calls the value of the variable +`graphviz-dot-mode-hook' with no args, if that value is non-nil." + (interactive) + (kill-all-local-variables) + (use-local-map graphviz-dot-mode-map) + (setq major-mode 'graphviz-dot-mode) + (setq mode-name "dot") + (setq local-abbrev-table graphviz-dot-mode-abbrev-table) + (set-syntax-table graphviz-dot-mode-syntax-table) + (set (make-local-variable 'indent-line-function) 'graphviz-dot-indent-line) + (set (make-local-variable 'comment-start) "//") + (set (make-local-variable 'comment-start-skip) "/\\*+ *\\|//+ *") + (modify-syntax-entry ?# "< b" graphviz-dot-mode-syntax-table) + (modify-syntax-entry ?\n "> b" graphviz-dot-mode-syntax-table) + (set (make-local-variable 'font-lock-defaults) + '(graphviz-dot-font-lock-keywords)) + ;; RR - If user is running this in the scratch buffer, there is no + ;; buffer file name... + (if (buffer-file-name) + (set (make-local-variable 'compile-command) + (concat graphviz-dot-dot-program + " -T" graphviz-dot-preview-extension " " + "\"" buffer-file-name "\"" + " > \"" + (file-name-sans-extension + buffer-file-name) + "." graphviz-dot-preview-extension "\""))) + (set (make-local-variable 'compilation-parse-errors-function) + 'graphviz-dot-compilation-parse-errors) + (if dot-menu + (easy-menu-add dot-menu)) + (run-hooks 'graphviz-dot-mode-hook) + ) + +;;;; Menu definitions + +(defvar dot-menu nil + "Menu for Graphviz Dot Mode. +This menu will get created automatically if you have the `easymenu' +package. Note that the latest X/Emacs releases contain this package.") + +(and (condition-case nil + (require 'easymenu) + (error nil)) + (easy-menu-define + dot-menu graphviz-dot-mode-map "Graphviz Mode menu" + '("Graphviz" + ["Indent Graph" graphviz-dot-indent-graph t] + ["Comment Out Region" comment-region (mark)] + ["Uncomment Region" graphviz-dot-uncomment-region (mark)] + "-" + ["Compile" compile t] + ["Preview" graphviz-dot-preview + (and (buffer-file-name) + (not (buffer-modified-p)))] + ["External Viewer" graphviz-dot-view (buffer-file-name)] + "-" + ["Customize..." graphviz-dot-customize t] + ))) + +;;;; Compilation + +;; note on graphviz-dot-compilation-parse-errors: +;; It would nicer if we could just use compilation-error-regexp-alist +;; to do that, 3 options: +;; - still write dot-compilation-parse-errors, don't build +;; a return list, but modify the *compilation* buffer +;; in a way compilation-error-regexp-alist recognizes the +;; format. +;; to do that, I should globally change compilation-parse-function +;; to this function, and call the old value of comp..-parse-fun.. +;; to provide the return value. +;; two drawbacks are that, every compilation would be run through +;; this function (performance) and that in autoload there would +;; be a chance that this function would not yet be known. +;; - let the compilation run through a filter that would +;; modify the output of dot or neato: +;; dot -Tpng input.dot | filter +;; drawback: ugly, extra work for user, extra decency ... +;; no-option +;; - modify dot and neato !!! (PP:15/02/2005 seems to have happend, +;; so version 0.4.0 should clean this mess up!) +(defun graphviz-dot-compilation-parse-errors (limit-search find-at-least) + "Parse the current buffer for dot errors. +See variable `compilation-parse-errors-functions' for interface." + (interactive) + (save-excursion + (set-buffer "*compilation*") + (goto-char (point-min)) + (setq compilation-error-list nil) + (let (buffer-of-error) + (while (not (eobp)) + (cond + ((looking-at "^dot\\( -[^ ]+\\)* \\(.*\\)") + (setq buffer-of-error (find-file-noselect + (buffer-substring-no-properties + (nth 4 (match-data t)) + (nth 5 (match-data t)))))) + ((looking-at ".*:.*line \\([0-9]+\\)") + (let ((line-of-error + (string-to-number (buffer-substring-no-properties + (nth 2 (match-data t)) + (nth 3 (match-data t)))))) + (setq compilation-error-list + (cons + (cons + (point-marker) + (save-excursion + (set-buffer buffer-of-error) + (goto-line line-of-error) + (beginning-of-line) + (point-marker))) + compilation-error-list)))) + (t t)) + (forward-line 1)) ))) + +;;;; +;;;; Indentation +;;;; +(defun graphviz-dot-uncomment-region (begin end) + "Uncomments a region of code." + (interactive "r") + (comment-region begin end '(4))) + +(defun graphviz-dot-indent-line () + "Indent current line of dot code." + (interactive) + (if (bolp) + (graphviz-dot-real-indent-line) + (save-excursion + (graphviz-dot-real-indent-line)))) + +(defun graphviz-dot-get-indendation() + "Return current line's indentation" + (interactive) + (message "Current indentation is %d." + (current-indentation)) + (current-indentation)) + +(defun graphviz-dot-real-indent-line () + "Indent current line of dot code." + (beginning-of-line) + (cond + ((bobp) + ;; simple case, indent to 0 + (indent-line-to 0)) + ((looking-at "^[ \t]*}[ \t]*$") + ;; block closing, deindent relative to previous line + (indent-line-to (save-excursion + (forward-line -1) + (max 0 (- (current-indentation) graphviz-dot-indent-width))))) + ;; other cases need to look at previous lines + (t + (indent-line-to (save-excursion + (forward-line -1) + (cond + ((looking-at "\\(^.*{[^}]*$\\)") + ;; previous line opened a block + ;; indent to that line + (+ (current-indentation) graphviz-dot-indent-width)) + ((and (not (looking-at ".*\\[.*\\].*")) + (looking-at ".*\\[.*")) ; TODO:PP : can be 1 regex + ;; previous line started filling + ;; attributes, intend to that start + (search-forward "[") + (current-column)) + ((and (not (looking-at ".*\\[.*\\].*")) + (looking-at ".*\\].*")) ; TODO:PP : " + ;; previous line stopped filling + ;; attributes, find the line that started + ;; filling them and indent to that line + (while (or (looking-at ".*\\[.*\\].*") + (not (looking-at ".*\\[.*"))) ; TODO:PP : " + (forward-line -1)) + (current-indentation)) + (t + ;; default case, indent the + ;; same as previous NON-BLANK line + ;; (or the first line, if there are no previous non-blank lines) + (while (and (< (point-min) (point)) + (looking-at "^\[ \t\]*$")) + (forward-line -1)) + (current-indentation)) ))) ))) + +(defun graphviz-dot-indent-graph () + "Indent the graph/digraph/subgraph where point is at. +This will first teach the beginning of the graph were point is at, and +then indent this and each subgraph in it." + (interactive) + (save-excursion + ;; position point at start of graph + (while (not (or (looking-at "\\(^.*{[^}]*$\\)") (bobp))) + (forward-line -1)) + ;; bracket { one +; bracket } one - + (let ((bracket-count 0)) + (while + (progn + (cond + ;; update bracket-count + ((looking-at "\\(^.*{[^}]*$\\)") + (setq bracket-count (+ bracket-count 1))) + ;; update bracket-count + ((looking-at "^[ \t]*}[ \t]*$") + (setq bracket-count (- bracket-count 1)))) + ;; indent this line and move on + (graphviz-dot-indent-line) + (forward-line 1) + ;; as long as we are not completed or at end of buffer + (and (> bracket-count 0) (not (eobp)))))))) + +;;;; +;;;; Electric indentation +;;;; +(defun graphviz-dot-comment-or-string-p () + (let ((state (parse-partial-sexp (point-min) (point)))) + (or (nth 4 state) (nth 3 state)))) + +(defun graphviz-dot-newline-and-indent () + (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (graphviz-dot-indent-line)) + (delete-horizontal-space) + (newline) + (graphviz-dot-indent-line)) + +(defun electric-graphviz-dot-terminate-line () + "Terminate line and indent next line." + (interactive) + (if graphviz-dot-auto-indent-on-newline + (graphviz-dot-newline-and-indent) + (newline))) + +(defun electric-graphviz-dot-open-brace () + "Terminate line and indent next line." + (interactive) + (insert "{") + (if (and graphviz-dot-auto-indent-on-braces + (not (graphviz-dot-comment-or-string-p))) + (graphviz-dot-newline-and-indent))) + +(defun electric-graphviz-dot-close-brace () + "Terminate line and indent next line." + (interactive) + (insert "}") + (if (and graphviz-dot-auto-indent-on-braces + (not (graphviz-dot-comment-or-string-p))) + (progn + (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (graphviz-dot-indent-line)) + (newline) + (graphviz-dot-indent-line)))) + +(defun electric-graphviz-dot-semi () + "Terminate line and indent next line." + (interactive) + (insert ";") + (if (and graphviz-dot-auto-indent-on-semi + (not (graphviz-dot-comment-or-string-p))) + (graphviz-dot-newline-and-indent))) + +;;;; +;;;; Preview +;;;; +(defun graphviz-dot-preview () + "Shows an example of the current dot file in an emacs buffer. +This assumes that we are running GNU Emacs or XEmacs under a windowing system. +See `image-file-name-extensions' for customizing the files that can be +loaded in GNU Emacs, and `image-formats-alist' for XEmacs." + (interactive) + ;; unsafe to compile ourself, ask it to the user + (if (buffer-modified-p) + (message "Buffer needs to be compiled.") + (if (string-match "XEmacs" emacs-version) + ;; things are easier in XEmacs... + (find-file-other-window (concat (file-name-sans-extension + buffer-file-name) + "." graphviz-dot-preview-extension)) + ;; run through all the extensions for images + (let ((l image-file-name-extensions)) + (while + (let ((f (concat (file-name-sans-extension (buffer-file-name)) + "." + (car l)))) + ;; see if a file matches, might be best also to check + ;; if file is up to date TODO:PP + (if (file-exists-p f) + (progn (auto-image-file-mode 1) + ;; OK, this is ugly, I would need to + ;; know how I can reload a file in an existing buffer + (if (get-buffer "*preview*") + (kill-buffer "*preview*")) + (set-buffer (find-file-noselect f)) + (rename-buffer "*preview*") + (display-buffer (get-buffer "*preview*")) + ;; stop iterating + '()) + ;; will stop iterating when l is nil + (setq l (cdr l))))) + ;; each extension tested and nothing found, let user know + (when (eq l '()) + (message "No image found.")))))) + +;;;; +;;;; View +;;;; +(defun graphviz-dot-view () + "Runs an external viewer. This creates an external process every time it +is executed. If `graphviz-dot-save-before-view' is set, the current +buffer is saved before the command is executed." + (interactive) + (let ((cmd (if graphviz-dot-view-edit-command + (if (string-match "XEmacs" emacs-version) + (read-shell-command "View command: " + (format graphviz-dot-view-command + (buffer-file-name))) + (read-from-minibuffer "View command: " + (format graphviz-dot-view-command + (buffer-file-name)))) + (format graphviz-dot-view-command (buffer-file-name))))) + (if graphviz-dot-save-before-view + (save-buffer)) + (setq novaproc (start-process-shell-command + (downcase mode-name) nil cmd)) + (message (format "Executing `%s'..." cmd)))) + +;;;; +;;;; Completion +;;;; +(defvar graphviz-dot-str nil) +(defvar graphviz-dot-all nil) +(defvar graphviz-dot-pred nil) +(defvar graphviz-dot-buffer-to-use nil) +(defvar graphviz-dot-flag nil) + +(defun graphviz-dot-get-state () + "Returns the syntax state of the current point." + (let ((state (parse-partial-sexp (point-min) (point)))) + (cond + ((nth 4 state) 'comment) + ((nth 3 state) 'string) + ((not (nth 1 state)) 'out) + (t (save-excursion + (skip-chars-backward "^[,=\\[]{};") + (backward-char) + (cond + ((looking-at "[\\[,]{};") 'attribute) + ((looking-at "=") (progn + (backward-word 1) + (if (looking-at "[a-zA-Z]*color") + 'color + 'value))) + (t 'other))))))) + +(defun graphviz-dot-get-keywords () + "Return possible completions for a word" + (let ((state (graphviz-dot-get-state))) + (cond + ((equal state 'comment) ()) + ((equal state 'string) ()) + ((equal state 'out) graphviz-attr-keywords) + ((equal state 'value) graphviz-value-keywords) + ((equal state 'color) graphviz-color-keywords) + ((equal state 'attribute) graphviz-attr-keywords) + (t graphviz-attr-keywords)))) + +(defvar graphviz-dot-last-word-numb 0) +(defvar graphviz-dot-last-word-shown nil) +(defvar graphviz-dot-last-completions nil) + +(defun graphviz-dot-complete-word () + "Complete word at current point." + (interactive) + (let* ((b (save-excursion (skip-chars-backward "a-zA-Z0-9_") (point))) + (e (save-excursion (skip-chars-forward "a-zA-Z0-9_") (point))) + (graphviz-dot-str (buffer-substring b e)) + (allcomp (if (and graphviz-dot-toggle-completions + (string= graphviz-dot-last-word-shown + graphviz-dot-str)) + graphviz-dot-last-completions + (all-completions graphviz-dot-str + (graphviz-dot-get-keywords)))) + (match (if graphviz-dot-toggle-completions + "" (try-completion + graphviz-dot-str (mapcar '(lambda (elm) + (cons elm 0)) allcomp))))) + ;; Delete old string + (delete-region b e) + + ;; Toggle-completions inserts whole labels + (if graphviz-dot-toggle-completions + (progn + ;; Update entry number in list + (setq graphviz-dot-last-completions allcomp + graphviz-dot-last-word-numb + (if (>= graphviz-dot-last-word-numb (1- (length allcomp))) + 0 + (1+ graphviz-dot-last-word-numb))) + (setq graphviz-dot-last-word-shown + (elt allcomp graphviz-dot-last-word-numb)) + ;; Display next match or same string if no match was found + (if (not (null allcomp)) + (insert "" graphviz-dot-last-word-shown) + (insert "" graphviz-dot-str) + (message "(No match)"))) + ;; The other form of completion does not necessarily do that. + + ;; Insert match if found, or the original string if no match + (if (or (null match) (equal match 't)) + (progn (insert "" graphviz-dot-str) + (message "(No match)")) + (insert "" match)) + ;; Give message about current status of completion + (cond ((equal match 't) + (if (not (null (cdr allcomp))) + (message "(Complete but not unique)") + (message "(Sole completion)"))) + ;; Display buffer if the current completion didn't help + ;; on completing the label. + ((and (not (null (cdr allcomp))) (= (length graphviz-dot-str) + (length match))) + (with-output-to-temp-buffer "*Completions*" + (display-completion-list allcomp)) + ;; Wait for a keypress. Then delete *Completion* window + (momentary-string-display "" (point)) + (if graphviz-dot-delete-completions + (delete-window + (get-buffer-window (get-buffer "*Completions*")))) + ))))) + +;;;###autoload +(add-to-list 'auto-mode-alist '("\\.dot\\'" . graphviz-dot-mode)) +(add-to-list 'auto-mode-alist '("\\.gv\\'" . graphviz-dot-mode)) + +;;; graphviz-dot-mode.el ends here + diff --git a/.emacs.d/elisp/htmlize.el b/.emacs.d/elisp/htmlize.el new file mode 100644 index 0000000..2b1d9a7 --- /dev/null +++ b/.emacs.d/elisp/htmlize.el @@ -0,0 +1,1671 @@ +;; htmlize.el -- Convert buffer text and decorations to HTML. + +;; Copyright (C) 1997-2003,2005,2006,2009,2011 Hrvoje Niksic + +;; Author: Hrvoje Niksic <hniksic@xemacs.org> +;; Keywords: hypermedia, extensions +;; Version: 1.39 + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This package converts the buffer text and the associated +;; decorations to HTML. Mail to <hniksic@xemacs.org> to discuss +;; features and additions. All suggestions are more than welcome. + +;; To use it, just switch to the buffer you want HTML-ized and type +;; `M-x htmlize-buffer'. You will be switched to a new buffer that +;; contains the resulting HTML code. You can edit and inspect this +;; buffer, or you can just save it with C-x C-w. `M-x htmlize-file' +;; will find a file, fontify it, and save the HTML version in +;; FILE.html, without any additional intervention. `M-x +;; htmlize-many-files' allows you to htmlize any number of files in +;; the same manner. `M-x htmlize-many-files-dired' does the same for +;; files marked in a dired buffer. + +;; htmlize supports three types of HTML output, selected by setting +;; `htmlize-output-type': `css', `inline-css', and `font'. In `css' +;; mode, htmlize uses cascading style sheets to specify colors; it +;; generates classes that correspond to Emacs faces and uses <span +;; class=FACE>...</span> to color parts of text. In this mode, the +;; produced HTML is valid under the 4.01 strict DTD, as confirmed by +;; the W3C validator. `inline-css' is like `css', except the CSS is +;; put directly in the STYLE attribute of the SPAN element, making it +;; possible to paste the generated HTML to other documents. In `font' +;; mode, htmlize uses <font color="...">...</font> to colorize HTML, +;; which is not standard-compliant, but works better in older +;; browsers. `css' mode is the default. + +;; You can also use htmlize from your Emacs Lisp code. When called +;; non-interactively, `htmlize-buffer' and `htmlize-region' will +;; return the resulting HTML buffer, but will not change current +;; buffer or move the point. + +;; htmlize aims for compatibility with Emacsen 21 and later. Please +;; let me know if it doesn't work on the version of XEmacs or GNU +;; Emacs that you are using. The package relies on the presence of CL +;; extensions, especially for cross-emacs compatibility; please don't +;; try to remove that dependency. Yes, I know I require `cl' at +;; runtime, and I prefer it that way. When byte-compiling under GNU +;; Emacs, you're likely to get a few warnings; just ignore them. + +;; The latest version is available as a git repository at: +;; +;; <http://fly.srk.fer.hr/~hniksic/emacs/htmlize.git> +;; +;; The snapshot of the latest release can be obtained at: +;; +;; <http://fly.srk.fer.hr/~hniksic/emacs/htmlize.el.cgi> +;; +;; You can find a sample of htmlize's output (possibly generated with +;; an older version) at: +;; +;; <http://fly.srk.fer.hr/~hniksic/emacs/htmlize.el.html> + +;; Thanks go to the many people who have sent reports and contributed +;; comments, suggestions, and fixes. They include Ron Gut, Bob +;; Weiner, Toni Drabik, Peter Breton, Thomas Vogels, Juri Linkov, +;; Maciek Pasternacki, and many others. + +;; User quotes: "You sir, are a sick, sick, _sick_ person. :)" +;; -- Bill Perry, author of Emacs/W3 + + +;;; Code: + +(require 'cl) +(eval-when-compile + (if (string-match "XEmacs" emacs-version) + (byte-compiler-options + (warnings (- unresolved)))) + (defvar font-lock-auto-fontify) + (defvar font-lock-support-mode) + (defvar global-font-lock-mode)) + +(defconst htmlize-version "1.39") + +(defgroup htmlize nil + "Convert buffer text and faces to HTML." + :group 'hypermedia) + +(defcustom htmlize-head-tags "" + "*Additional tags to insert within HEAD of the generated document." + :type 'string + :group 'htmlize) + +(defcustom htmlize-output-type 'css + "*Output type of generated HTML, one of `css', `inline-css', or `font'. +When set to `css' (the default), htmlize will generate a style sheet +with description of faces, and use it in the HTML document, specifying +the faces in the actual text with <span class=\"FACE\">. + +When set to `inline-css', the style will be generated as above, but +placed directly in the STYLE attribute of the span ELEMENT: <span +style=\"STYLE\">. This makes it easier to paste the resulting HTML to +other documents. + +When set to `font', the properties will be set using layout tags +<font>, <b>, <i>, <u>, and <strike>. + +`css' output is normally preferred, but `font' is still useful for +supporting old, pre-CSS browsers, and both `inline-css' and `font' for +easier embedding of colorized text in foreign HTML documents (no style +sheet to carry around)." + :type '(choice (const css) (const inline-css) (const font)) + :group 'htmlize) + +(defcustom htmlize-generate-hyperlinks t + "*Non-nil means generate the hyperlinks for URLs and mail addresses. +This is on by default; set it to nil if you don't want htmlize to +insert hyperlinks in the resulting HTML. (In which case you can still +do your own hyperlinkification from htmlize-after-hook.)" + :type 'boolean + :group 'htmlize) + +(defcustom htmlize-hyperlink-style " + a { + color: inherit; + background-color: inherit; + font: inherit; + text-decoration: inherit; + } + a:hover { + text-decoration: underline; + } +" + "*The CSS style used for hyperlinks when in CSS mode." + :type 'string + :group 'htmlize) + +(defcustom htmlize-replace-form-feeds t + "*Non-nil means replace form feeds in source code with HTML separators. +Form feeds are the ^L characters at line beginnings that are sometimes +used to separate sections of source code. If this variable is set to +`t', form feed characters are replaced with the <hr> separator. If this +is a string, it specifies the replacement to use. Note that <pre> is +temporarily closed before the separator is inserted, so the default +replacement is effectively \"</pre><hr /><pre>\". If you specify +another replacement, don't forget to close and reopen the <pre> if you +want the output to remain valid HTML. + +If you need more elaborate processing, set this to nil and use +htmlize-after-hook." + :type 'boolean + :group 'htmlize) + +(defcustom htmlize-html-charset nil + "*The charset declared by the resulting HTML documents. +When non-nil, causes htmlize to insert the following in the HEAD section +of the generated HTML: + + <meta http-equiv=\"Content-Type\" content=\"text/html; charset=CHARSET\"> + +where CHARSET is the value you've set for htmlize-html-charset. Valid +charsets are defined by MIME and include strings like \"iso-8859-1\", +\"iso-8859-15\", \"utf-8\", etc. + +If you are using non-Latin-1 charsets, you might need to set this for +your documents to render correctly. Also, the W3C validator requires +submitted HTML documents to declare a charset. So if you care about +validation, you can use this to prevent the validator from bitching. + +Needless to say, if you set this, you should actually make sure that +the buffer is in the encoding you're claiming it is in. (Under Mule +that is done by ensuring the correct \"file coding system\" for the +buffer.) If you don't understand what that means, this option is +probably not for you." + :type '(choice (const :tag "Unset" nil) + string) + :group 'htmlize) + +(defcustom htmlize-convert-nonascii-to-entities (featurep 'mule) + "*Whether non-ASCII characters should be converted to HTML entities. + +When this is non-nil, characters with codes in the 128-255 range will be +considered Latin 1 and rewritten as \"&#CODE;\". Characters with codes +above 255 will be converted to \"&#UCS;\", where UCS denotes the Unicode +code point of the character. If the code point cannot be determined, +the character will be copied unchanged, as would be the case if the +option were nil. + +When the option is nil, the non-ASCII characters are copied to HTML +without modification. In that case, the web server and/or the browser +must be set to understand the encoding that was used when saving the +buffer. (You might also want to specify it by setting +`htmlize-html-charset'.) + +Note that in an HTML entity \"&#CODE;\", CODE is always a UCS code point, +which has nothing to do with the charset the page is in. For example, +\"©\" *always* refers to the copyright symbol, regardless of charset +specified by the META tag or the charset sent by the HTTP server. In +other words, \"©\" is exactly equivalent to \"©\". + +By default, entity conversion is turned on for Mule-enabled Emacsen and +turned off otherwise. This is because Mule knows the charset of +non-ASCII characters in the buffer. A non-Mule Emacs cannot tell +whether a character with code 0xA9 represents Latin 1 copyright symbol, +Latin 2 \"S with caron\", or something else altogether. Setting this to +t without Mule means asserting that 128-255 characters always mean Latin +1. + +For most people htmlize will work fine with this option left at the +default setting; don't change it unless you know what you're doing." + :type 'sexp + :group 'htmlize) + +(defcustom htmlize-ignore-face-size 'absolute + "*Whether face size should be ignored when generating HTML. +If this is nil, face sizes are used. If set to t, sizes are ignored +If set to `absolute', only absolute size specifications are ignored. +Please note that font sizes only work with CSS-based output types." + :type '(choice (const :tag "Don't ignore" nil) + (const :tag "Ignore all" t) + (const :tag "Ignore absolute" absolute)) + :group 'htmlize) + +(defcustom htmlize-css-name-prefix "" + "*The prefix used for CSS names. +The CSS names that htmlize generates from face names are often too +generic for CSS files; for example, `font-lock-type-face' is transformed +to `type'. Use this variable to add a prefix to the generated names. +The string \"htmlize-\" is an example of a reasonable prefix." + :type 'string + :group 'htmlize) + +(defcustom htmlize-use-rgb-txt t + "*Whether `rgb.txt' should be used to convert color names to RGB. + +This conversion means determining, for instance, that the color +\"IndianRed\" corresponds to the (205, 92, 92) RGB triple. `rgb.txt' +is the X color database that maps hundreds of color names to such RGB +triples. When this variable is non-nil, `htmlize' uses `rgb.txt' to +look up color names. + +If this variable is nil, htmlize queries Emacs for RGB components of +colors using `color-instance-rgb-components' and `x-color-values'. +This can yield incorrect results on non-true-color displays. + +If the `rgb.txt' file is not found (which will be the case if you're +running Emacs on non-X11 systems), this option is ignored." + :type 'boolean + :group 'htmlize) + +(defcustom htmlize-html-major-mode nil + "The mode the newly created HTML buffer will be put in. +Set this to nil if you prefer the default (fundamental) mode." + :type '(radio (const :tag "No mode (fundamental)" nil) + (function-item html-mode) + (function :tag "User-defined major mode")) + :group 'htmlize) + +(defvar htmlize-before-hook nil + "Hook run before htmlizing a buffer. +The hook functions are run in the source buffer (not the resulting HTML +buffer).") + +(defvar htmlize-after-hook nil + "Hook run after htmlizing a buffer. +Unlike `htmlize-before-hook', these functions are run in the generated +HTML buffer. You may use them to modify the outlook of the final HTML +output.") + +(defvar htmlize-file-hook nil + "Hook run by `htmlize-file' after htmlizing a file, but before saving it.") + +(defvar htmlize-buffer-places) + +;;; Some cross-Emacs compatibility. + +;; I try to conditionalize on features rather than Emacs version, but +;; in some cases checking against the version *is* necessary. +(defconst htmlize-running-xemacs (string-match "XEmacs" emacs-version)) + +;; We need a function that efficiently finds the next change of a +;; property regardless of whether the change occurred because of a +;; text property or an extent/overlay. +(cond + (htmlize-running-xemacs + (defun htmlize-next-change (pos prop &optional limit) + (if prop + (next-single-property-change pos prop nil (or limit (point-max))) + (next-property-change pos nil (or limit (point-max))))) + (defun htmlize-next-face-change (pos &optional limit) + (htmlize-next-change pos 'face limit))) + ((fboundp 'next-single-char-property-change) + ;; GNU Emacs 21+ + (defun htmlize-next-change (pos prop &optional limit) + (if prop + (next-single-char-property-change pos prop nil limit) + (next-char-property-change pos limit))) + (defun htmlize-overlay-faces-at (pos) + (delq nil (mapcar (lambda (o) (overlay-get o 'face)) (overlays-at pos)))) + (defun htmlize-next-face-change (pos &optional limit) + ;; (htmlize-next-change pos 'face limit) would skip over entire + ;; overlays that specify the `face' property, even when they + ;; contain smaller text properties that also specify `face'. + ;; Emacs display engine merges those faces, and so must we. + (or limit + (setq limit (point-max))) + (let ((next-prop (next-single-property-change pos 'face nil limit)) + (overlay-faces (htmlize-overlay-faces-at pos))) + (while (progn + (setq pos (next-overlay-change pos)) + (and (< pos next-prop) + (equal overlay-faces (htmlize-overlay-faces-at pos))))) + (min pos next-prop)))) + (t + (error "htmlize requires next-single-property-change or \ +next-single-char-property-change"))) + +;;; Transformation of buffer text: HTML escapes, untabification, etc. + +(defvar htmlize-basic-character-table + ;; Map characters in the 0-127 range to either one-character strings + ;; or to numeric entities. + (let ((table (make-vector 128 ?\0))) + ;; Map characters in the 32-126 range to themselves, others to + ;; &#CODE entities; + (dotimes (i 128) + (setf (aref table i) (if (and (>= i 32) (<= i 126)) + (char-to-string i) + (format "&#%d;" i)))) + ;; Set exceptions manually. + (setf + ;; Don't escape newline, carriage return, and TAB. + (aref table ?\n) "\n" + (aref table ?\r) "\r" + (aref table ?\t) "\t" + ;; Escape &, <, and >. + (aref table ?&) "&" + (aref table ?<) "<" + (aref table ?>) ">" + ;; Not escaping '"' buys us a measurable speedup. It's only + ;; necessary to quote it for strings used in attribute values, + ;; which htmlize doesn't do. + ;(aref table ?\") """ + ) + table)) + +;; A cache of HTML representation of non-ASCII characters. Depending +;; on the setting of `htmlize-convert-nonascii-to-entities', this maps +;; non-ASCII characters to either "&#<code>;" or "<char>" (mapconcat's +;; mapper must always return strings). It's only filled as characters +;; are encountered, so that in a buffer with e.g. French text, it will +;; only ever contain French accented characters as keys. It's cleared +;; on each entry to htmlize-buffer-1 to allow modifications of +;; `htmlize-convert-nonascii-to-entities' to take effect. +(defvar htmlize-extended-character-cache (make-hash-table :test 'eq)) + +(defun htmlize-protect-string (string) + "HTML-protect string, escaping HTML metacharacters and I18N chars." + ;; Only protecting strings that actually contain unsafe or non-ASCII + ;; chars removes a lot of unnecessary funcalls and consing. + (if (not (string-match "[^\r\n\t -%'-;=?-~]" string)) + string + (mapconcat (lambda (char) + (cond + ((< char 128) + ;; ASCII: use htmlize-basic-character-table. + (aref htmlize-basic-character-table char)) + ((gethash char htmlize-extended-character-cache) + ;; We've already seen this char; return the cached + ;; string. + ) + ((not htmlize-convert-nonascii-to-entities) + ;; If conversion to entities is not desired, always + ;; copy the char literally. + (setf (gethash char htmlize-extended-character-cache) + (char-to-string char))) + ((< char 256) + ;; Latin 1: no need to call encode-char. + (setf (gethash char htmlize-extended-character-cache) + (format "&#%d;" char))) + ((encode-char char 'ucs) + ;; Must check if encode-char works for CHAR; + ;; it fails for Arabic and possibly elsewhere. + (setf (gethash char htmlize-extended-character-cache) + (format "&#%d;" (encode-char char 'ucs)))) + (t + ;; encode-char doesn't work for this char. Copy it + ;; unchanged and hope for the best. + (setf (gethash char htmlize-extended-character-cache) + (char-to-string char))))) + string ""))) + +(defconst htmlize-ellipsis "...") +(put-text-property 0 (length htmlize-ellipsis) 'htmlize-ellipsis t htmlize-ellipsis) + +(defun htmlize-match-inv-spec (inv) + (member* inv buffer-invisibility-spec + :key (lambda (i) + (if (symbolp i) i (car i))))) + +(defun htmlize-decode-invisibility-spec (invisible) + ;; Return t, nil, or `ellipsis', depending on how invisible text should be inserted. + + (if (not (listp buffer-invisibility-spec)) + ;; If buffer-invisibility-spec is not a list, then all + ;; characters with non-nil `invisible' property are visible. + (not invisible) + + ;; Otherwise, the value of a non-nil `invisible' property can be: + ;; 1. a symbol -- make the text invisible if it matches + ;; buffer-invisibility-spec. + ;; 2. a list of symbols -- make the text invisible if + ;; any symbol in the list matches + ;; buffer-invisibility-spec. + ;; If the match of buffer-invisibility-spec has a non-nil + ;; CDR, replace the invisible text with an ellipsis. + (let ((match (if (symbolp invisible) + (htmlize-match-inv-spec invisible) + (some #'htmlize-match-inv-spec invisible)))) + (cond ((null match) t) + ((cdr-safe (car match)) 'ellipsis) + (t nil))))) + +(defun htmlize-buffer-substring-no-invisible (beg end) + ;; Like buffer-substring-no-properties, but don't copy invisible + ;; parts of the region. Where buffer-substring-no-properties + ;; mandates an ellipsis to be shown, htmlize-ellipsis is inserted. + (let ((pos beg) + visible-list invisible show last-show next-change) + ;; Iterate over the changes in the `invisible' property and filter + ;; out the portions where it's non-nil, i.e. where the text is + ;; invisible. + (while (< pos end) + (setq invisible (get-char-property pos 'invisible) + next-change (htmlize-next-change pos 'invisible end) + show (htmlize-decode-invisibility-spec invisible)) + (cond ((eq show t) + (push (buffer-substring-no-properties pos next-change) visible-list)) + ((and (eq show 'ellipsis) + (not (eq last-show 'ellipsis)) + ;; Conflate successive ellipses. + (push htmlize-ellipsis visible-list)))) + (setq pos next-change last-show show)) + (if (= (length visible-list) 1) + ;; If VISIBLE-LIST consists of only one element, return it and + ;; avoid creating a new string. + (car visible-list) + (apply #'concat (nreverse visible-list))))) + +(defun htmlize-trim-ellipsis (text) + ;; Remove htmlize-ellipses ("...") from the beginning of TEXT if it + ;; starts with it. It checks for the special property of the + ;; ellipsis so it doesn't work on ordinary text that begins with + ;; "...". + (if (get-text-property 0 'htmlize-ellipsis text) + (substring text (length htmlize-ellipsis)) + text)) + +(defconst htmlize-tab-spaces + ;; A table of strings with spaces. (aref htmlize-tab-spaces 5) is + ;; like (make-string 5 ?\ ), except it doesn't cons. + (let ((v (make-vector 32 nil))) + (dotimes (i (length v)) + (setf (aref v i) (make-string i ?\ ))) + v)) + +(defun htmlize-untabify (text start-column) + "Untabify TEXT, assuming it starts at START-COLUMN." + (let ((column start-column) + (last-match 0) + (chunk-start 0) + chunks match-pos tab-size) + (while (string-match "[\t\n]" text last-match) + (setq match-pos (match-beginning 0)) + (cond ((eq (aref text match-pos) ?\t) + ;; Encountered a tab: create a chunk of text followed by + ;; the expanded tab. + (push (substring text chunk-start match-pos) chunks) + ;; Increase COLUMN by the length of the text we've + ;; skipped since last tab or newline. (Encountering + ;; newline resets it.) + (incf column (- match-pos last-match)) + ;; Calculate tab size based on tab-width and COLUMN. + (setq tab-size (- tab-width (% column tab-width))) + ;; Expand the tab. + (push (aref htmlize-tab-spaces tab-size) chunks) + (incf column tab-size) + (setq chunk-start (1+ match-pos))) + (t + ;; Reset COLUMN at beginning of line. + (setq column 0))) + (setq last-match (1+ match-pos))) + ;; If no chunks have been allocated, it means there have been no + ;; tabs to expand. Return TEXT unmodified. + (if (null chunks) + text + (when (< chunk-start (length text)) + ;; Push the remaining chunk. + (push (substring text chunk-start) chunks)) + ;; Generate the output from the available chunks. + (apply #'concat (nreverse chunks))))) + +(defun htmlize-extract-text (beg end trailing-ellipsis) + ;; Extract buffer text, sans the invisible parts. Then + ;; untabify it and escape the HTML metacharacters. + (let ((text (htmlize-buffer-substring-no-invisible beg end))) + (when trailing-ellipsis + (setq text (htmlize-trim-ellipsis text))) + ;; If TEXT ends up empty, don't change trailing-ellipsis. + (when (> (length text) 0) + (setq trailing-ellipsis + (get-text-property (1- (length text)) + 'htmlize-ellipsis text))) + (setq text (htmlize-untabify text (current-column))) + (setq text (htmlize-protect-string text)) + (values text trailing-ellipsis))) + +(defun htmlize-despam-address (string) + "Replace every occurrence of '@' in STRING with @. +`htmlize-make-hyperlinks' uses this to spam-protect mailto links +without modifying their meaning." + ;; Suggested by Ville Skytta. + (while (string-match "@" string) + (setq string (replace-match "@" nil t string))) + string) + +(defun htmlize-make-hyperlinks () + "Make hyperlinks in HTML." + ;; Function originally submitted by Ville Skytta. Rewritten by + ;; Hrvoje Niksic, then modified by Ville Skytta and Hrvoje Niksic. + (goto-char (point-min)) + (while (re-search-forward + "<\\(\\(mailto:\\)?\\([-=+_.a-zA-Z0-9]+@[-_.a-zA-Z0-9]+\\)\\)>" + nil t) + (let ((address (match-string 3)) + (link-text (match-string 1))) + (delete-region (match-beginning 0) (match-end 0)) + (insert "<<a href=\"mailto:" + (htmlize-despam-address address) + "\">" + (htmlize-despam-address link-text) + "</a>>"))) + (goto-char (point-min)) + (while (re-search-forward "<\\(\\(URL:\\)?\\([a-zA-Z]+://[^;]+\\)\\)>" + nil t) + (let ((url (match-string 3)) + (link-text (match-string 1))) + (delete-region (match-beginning 0) (match-end 0)) + (insert "<<a href=\"" url "\">" link-text "</a>>")))) + +;; Tests for htmlize-make-hyperlinks: + +;; <mailto:hniksic@xemacs.org> +;; <http://fly.srk.fer.hr> +;; <URL:http://www.xemacs.org> +;; <http://www.mail-archive.com/bbdb-info@xemacs.org/> +;; <hniksic@xemacs.org> +;; <xalan-dev-sc.10148567319.hacuhiucknfgmpfnjcpg-john=doe.com@xml.apache.org> + +(defun htmlize-defang-local-variables () + ;; Juri Linkov reports that an HTML-ized "Local variables" can lead + ;; visiting the HTML to fail with "Local variables list is not + ;; properly terminated". He suggested changing the phrase to + ;; syntactically equivalent HTML that Emacs doesn't recognize. + (goto-char (point-min)) + (while (search-forward "Local Variables:" nil t) + (replace-match "Local Variables:" nil t))) + + +;;; Color handling. + +(if (fboundp 'locate-file) + (defalias 'htmlize-locate-file 'locate-file) + (defun htmlize-locate-file (file path) + (dolist (dir path nil) + (when (file-exists-p (expand-file-name file dir)) + (return (expand-file-name file dir)))))) + +(defvar htmlize-x-library-search-path + '("/usr/X11R6/lib/X11/" + "/usr/X11R5/lib/X11/" + "/usr/lib/X11R6/X11/" + "/usr/lib/X11R5/X11/" + "/usr/local/X11R6/lib/X11/" + "/usr/local/X11R5/lib/X11/" + "/usr/local/lib/X11R6/X11/" + "/usr/local/lib/X11R5/X11/" + "/usr/X11/lib/X11/" + "/usr/lib/X11/" + "/usr/local/lib/X11/" + "/usr/X386/lib/X11/" + "/usr/x386/lib/X11/" + "/usr/XFree86/lib/X11/" + "/usr/unsupported/lib/X11/" + "/usr/athena/lib/X11/" + "/usr/local/x11r5/lib/X11/" + "/usr/lpp/Xamples/lib/X11/" + "/usr/openwin/lib/X11/" + "/usr/openwin/share/lib/X11/")) + +(defun htmlize-get-color-rgb-hash (&optional rgb-file) + "Return a hash table mapping X color names to RGB values. +The keys in the hash table are X11 color names, and the values are the +#rrggbb RGB specifications, extracted from `rgb.txt'. + +If RGB-FILE is nil, the function will try hard to find a suitable file +in the system directories. + +If no rgb.txt file is found, return nil." + (let ((rgb-file (or rgb-file (htmlize-locate-file + "rgb.txt" + htmlize-x-library-search-path))) + (hash nil)) + (when rgb-file + (with-temp-buffer + (insert-file-contents rgb-file) + (setq hash (make-hash-table :test 'equal)) + (while (not (eobp)) + (cond ((looking-at "^\\s-*\\([!#]\\|$\\)") + ;; Skip comments and empty lines. + ) + ((looking-at + "[ \t]*\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\(.*\\)") + (setf (gethash (downcase (match-string 4)) hash) + (format "#%02x%02x%02x" + (string-to-number (match-string 1)) + (string-to-number (match-string 2)) + (string-to-number (match-string 3))))) + (t + (error + "Unrecognized line in %s: %s" + rgb-file + (buffer-substring (point) (progn (end-of-line) (point)))))) + (forward-line 1)))) + hash)) + +;; Compile the RGB map when loaded. On systems where rgb.txt is +;; missing, the value of the variable will be nil, and rgb.txt will +;; not be used. +(defvar htmlize-color-rgb-hash (htmlize-get-color-rgb-hash)) + +;;; Face handling. + +(defun htmlize-face-specifies-property (face prop) + ;; Return t if face specifies PROP, as opposed to it being inherited + ;; from the default face. The problem with e.g. + ;; `face-foreground-instance' is that it returns an instance for + ;; EVERY face because every face inherits from the default face. + ;; However, we'd like htmlize-face-{fore,back}ground to return nil + ;; when called with a face that doesn't specify its own foreground + ;; or background. + (or (eq face 'default) + (assq 'global (specifier-spec-list (face-property face prop))))) + +(defun htmlize-face-color-internal (face fg) + ;; Used only under GNU Emacs. Return the color of FACE, but don't + ;; return "unspecified-fg" or "unspecified-bg". If the face is + ;; `default' and the color is unspecified, look up the color in + ;; frame parameters. + (let* ((function (if fg #'face-foreground #'face-background)) + color) + (if (>= emacs-major-version 22) + ;; For GNU Emacs 22+ set INHERIT to get the inherited values. + (setq color (funcall function face nil t)) + (setq color (funcall function face)) + ;; For GNU Emacs 21 (which has `face-attribute'): if the color + ;; is nil, recursively check for the face's parent. + (when (and (null color) + (fboundp 'face-attribute) + (face-attribute face :inherit) + (not (eq (face-attribute face :inherit) 'unspecified))) + (setq color (htmlize-face-color-internal + (face-attribute face :inherit) fg)))) + (when (and (eq face 'default) (null color)) + (setq color (cdr (assq (if fg 'foreground-color 'background-color) + (frame-parameters))))) + (when (or (eq color 'unspecified) + (equal color "unspecified-fg") + (equal color "unspecified-bg")) + (setq color nil)) + (when (and (eq face 'default) + (null color)) + ;; Assuming black on white doesn't seem right, but I can't think + ;; of anything better to do. + (setq color (if fg "black" "white"))) + color)) + +(defun htmlize-face-foreground (face) + ;; Return the name of the foreground color of FACE. If FACE does + ;; not specify a foreground color, return nil. + (cond (htmlize-running-xemacs + ;; XEmacs. + (and (htmlize-face-specifies-property face 'foreground) + (color-instance-name (face-foreground-instance face)))) + (t + ;; GNU Emacs. + (htmlize-face-color-internal face t)))) + +(defun htmlize-face-background (face) + ;; Return the name of the background color of FACE. If FACE does + ;; not specify a background color, return nil. + (cond (htmlize-running-xemacs + ;; XEmacs. + (and (htmlize-face-specifies-property face 'background) + (color-instance-name (face-background-instance face)))) + (t + ;; GNU Emacs. + (htmlize-face-color-internal face nil)))) + +;; Convert COLOR to the #RRGGBB string. If COLOR is already in that +;; format, it's left unchanged. + +(defun htmlize-color-to-rgb (color) + (let ((rgb-string nil)) + (cond ((null color) + ;; Ignore nil COLOR because it means that the face is not + ;; specifying any color. Hence (htmlize-color-to-rgb nil) + ;; returns nil. + ) + ((string-match "\\`#" color) + ;; The color is already in #rrggbb format. + (setq rgb-string color)) + ((and htmlize-use-rgb-txt + htmlize-color-rgb-hash) + ;; Use of rgb.txt is requested, and it's available on the + ;; system. Use it. + (setq rgb-string (gethash (downcase color) htmlize-color-rgb-hash))) + (t + ;; We're getting the RGB components from Emacs. + (let ((rgb + ;; Here I cannot conditionalize on (fboundp ...) + ;; because ps-print under some versions of GNU Emacs + ;; defines its own dummy version of + ;; `color-instance-rgb-components'. + (if htmlize-running-xemacs + (mapcar (lambda (arg) + (/ arg 256)) + (color-instance-rgb-components + (make-color-instance color))) + (mapcar (lambda (arg) + (/ arg 256)) + (x-color-values color))))) + (when rgb + (setq rgb-string (apply #'format "#%02x%02x%02x" rgb)))))) + ;; If RGB-STRING is still nil, it means the color cannot be found, + ;; for whatever reason. In that case just punt and return COLOR. + ;; Most browsers support a decent set of color names anyway. + (or rgb-string color))) + +;; We store the face properties we care about into an +;; `htmlize-fstruct' type. That way we only have to analyze face +;; properties, which can be time consuming, once per each face. The +;; mapping between Emacs faces and htmlize-fstructs is established by +;; htmlize-make-face-map. The name "fstruct" refers to variables of +;; type `htmlize-fstruct', while the term "face" is reserved for Emacs +;; faces. + +(defstruct htmlize-fstruct + foreground ; foreground color, #rrggbb + background ; background color, #rrggbb + size ; size + boldp ; whether face is bold + italicp ; whether face is italic + underlinep ; whether face is underlined + overlinep ; whether face is overlined + strikep ; whether face is struck through + css-name ; CSS name of face + ) + +(defun htmlize-face-emacs21-attr (fstruct attr value) + ;; For ATTR and VALUE, set the equivalent value in FSTRUCT. + (case attr + (:foreground + (setf (htmlize-fstruct-foreground fstruct) (htmlize-color-to-rgb value))) + (:background + (setf (htmlize-fstruct-background fstruct) (htmlize-color-to-rgb value))) + (:height + (setf (htmlize-fstruct-size fstruct) value)) + (:weight + (when (string-match (symbol-name value) "bold") + (setf (htmlize-fstruct-boldp fstruct) t))) + (:slant + (setf (htmlize-fstruct-italicp fstruct) (or (eq value 'italic) + (eq value 'oblique)))) + (:bold + (setf (htmlize-fstruct-boldp fstruct) value)) + (:italic + (setf (htmlize-fstruct-italicp fstruct) value)) + (:underline + (setf (htmlize-fstruct-underlinep fstruct) value)) + (:overline + (setf (htmlize-fstruct-overlinep fstruct) value)) + (:strike-through + (setf (htmlize-fstruct-strikep fstruct) value)))) + +(defun htmlize-face-size (face) + ;; The size (height) of FACE, taking inheritance into account. + ;; Only works in Emacs 21 and later. + (let ((size-list + (loop + for f = face then (face-attribute f :inherit) + until (or (not f) (eq f 'unspecified)) + for h = (face-attribute f :height) + collect (if (eq h 'unspecified) nil h)))) + (reduce 'htmlize-merge-size (cons nil size-list)))) + +(defun htmlize-face-css-name (face) + ;; Generate the css-name property for the given face. Emacs places + ;; no restrictions on the names of symbols that represent faces -- + ;; any characters may be in the name, even control chars. We try + ;; hard to beat the face name into shape, both esthetically and + ;; according to CSS1 specs. + (let ((name (downcase (symbol-name face)))) + (when (string-match "\\`font-lock-" name) + ;; font-lock-FOO-face -> FOO. + (setq name (replace-match "" t t name))) + (when (string-match "-face\\'" name) + ;; Drop the redundant "-face" suffix. + (setq name (replace-match "" t t name))) + (while (string-match "[^-a-zA-Z0-9]" name) + ;; Drop the non-alphanumerics. + (setq name (replace-match "X" t t name))) + (when (string-match "\\`[-0-9]" name) + ;; CSS identifiers may not start with a digit. + (setq name (concat "X" name))) + ;; After these transformations, the face could come out empty. + (when (equal name "") + (setq name "face")) + ;; Apply the prefix. + (concat htmlize-css-name-prefix name))) + +(defun htmlize-face-to-fstruct (face) + "Convert Emacs face FACE to fstruct." + (let ((fstruct (make-htmlize-fstruct + :foreground (htmlize-color-to-rgb + (htmlize-face-foreground face)) + :background (htmlize-color-to-rgb + (htmlize-face-background face))))) + (if htmlize-running-xemacs + ;; XEmacs doesn't provide a way to detect whether a face is + ;; bold or italic, so we need to examine the font instance. + (let* ((font-instance (face-font-instance face)) + (props (font-instance-properties font-instance))) + (when (equalp (cdr (assq 'WEIGHT_NAME props)) "bold") + (setf (htmlize-fstruct-boldp fstruct) t)) + (when (or (equalp (cdr (assq 'SLANT props)) "i") + (equalp (cdr (assq 'SLANT props)) "o")) + (setf (htmlize-fstruct-italicp fstruct) t)) + (setf (htmlize-fstruct-strikep fstruct) + (face-strikethru-p face)) + (setf (htmlize-fstruct-underlinep fstruct) + (face-underline-p face))) + ;; GNU Emacs + (dolist (attr '(:weight :slant :underline :overline :strike-through)) + (let ((value (if (>= emacs-major-version 22) + ;; Use the INHERIT arg in GNU Emacs 22. + (face-attribute face attr nil t) + ;; Otherwise, fake it. + (let ((face face)) + (while (and (eq (face-attribute face attr) + 'unspecified) + (not (eq (face-attribute face :inherit) + 'unspecified))) + (setq face (face-attribute face :inherit))) + (face-attribute face attr))))) + (when (and value (not (eq value 'unspecified))) + (htmlize-face-emacs21-attr fstruct attr value))))) + ;(let ((size (htmlize-face-size face))) + ; (unless (eql size 1.0) ; ignore non-spec + ; (setf (htmlize-fstruct-size fstruct) size)))) + (setf (htmlize-fstruct-css-name fstruct) (htmlize-face-css-name face)) + fstruct)) + +(defmacro htmlize-copy-attr-if-set (attr-list dest source) + ;; Generate code with the following pattern: + ;; (progn + ;; (when (htmlize-fstruct-ATTR source) + ;; (setf (htmlize-fstruct-ATTR dest) (htmlize-fstruct-ATTR source))) + ;; ...) + ;; for the given list of boolean attributes. + (cons 'progn + (loop for attr in attr-list + for attr-sym = (intern (format "htmlize-fstruct-%s" attr)) + collect `(when (,attr-sym ,source) + (setf (,attr-sym ,dest) (,attr-sym ,source)))))) + +(defun htmlize-merge-size (merged next) + ;; Calculate the size of the merge of MERGED and NEXT. + (cond ((null merged) next) + ((integerp next) next) + ((null next) merged) + ((floatp merged) (* merged next)) + ((integerp merged) (round (* merged next))))) + +(defun htmlize-merge-two-faces (merged next) + (htmlize-copy-attr-if-set + (foreground background boldp italicp underlinep overlinep strikep) + merged next) + (setf (htmlize-fstruct-size merged) + (htmlize-merge-size (htmlize-fstruct-size merged) + (htmlize-fstruct-size next))) + merged) + +(defun htmlize-merge-faces (fstruct-list) + (cond ((null fstruct-list) + ;; Nothing to do, return a dummy face. + (make-htmlize-fstruct)) + ((null (cdr fstruct-list)) + ;; Optimize for the common case of a single face, simply + ;; return it. + (car fstruct-list)) + (t + (reduce #'htmlize-merge-two-faces + (cons (make-htmlize-fstruct) fstruct-list))))) + +;; GNU Emacs 20+ supports attribute lists in `face' properties. For +;; example, you can use `(:foreground "red" :weight bold)' as an +;; overlay's "face", or you can even use a list of such lists, etc. +;; We call those "attrlists". +;; +;; htmlize supports attrlist by converting them to fstructs, the same +;; as with regular faces. + +(defun htmlize-attrlist-to-fstruct (attrlist) + ;; Like htmlize-face-to-fstruct, but accepts an ATTRLIST as input. + (let ((fstruct (make-htmlize-fstruct))) + (cond ((eq (car attrlist) 'foreground-color) + ;; ATTRLIST is (foreground-color . COLOR) + (setf (htmlize-fstruct-foreground fstruct) + (htmlize-color-to-rgb (cdr attrlist)))) + ((eq (car attrlist) 'background-color) + ;; ATTRLIST is (background-color . COLOR) + (setf (htmlize-fstruct-background fstruct) + (htmlize-color-to-rgb (cdr attrlist)))) + (t + ;; ATTRLIST is a plist. + (while attrlist + (let ((attr (pop attrlist)) + (value (pop attrlist))) + (when (and value (not (eq value 'unspecified))) + (htmlize-face-emacs21-attr fstruct attr value)))))) + (setf (htmlize-fstruct-css-name fstruct) "ATTRLIST") + fstruct)) + +(defun htmlize-face-list-p (face-prop) + "Return non-nil if FACE-PROP is a list of faces, nil otherwise." + ;; If not for attrlists, this would return (listp face-prop). This + ;; way we have to be more careful because attrlist is also a list! + (cond + ((eq face-prop nil) + ;; FACE-PROP being nil means empty list (no face), so return t. + t) + ((symbolp face-prop) + ;; A symbol other than nil means that it's only one face, so return + ;; nil. + nil) + ((not (consp face-prop)) + ;; Huh? Not a symbol or cons -- treat it as a single element. + nil) + (t + ;; We know that FACE-PROP is a cons: check whether it looks like an + ;; ATTRLIST. + (let* ((car (car face-prop)) + (attrlist-p (and (symbolp car) + (or (eq car 'foreground-color) + (eq car 'background-color) + (eq (aref (symbol-name car) 0) ?:))))) + ;; If FACE-PROP is not an ATTRLIST, it means it's a list of + ;; faces. + (not attrlist-p))))) + +(defun htmlize-make-face-map (faces) + ;; Return a hash table mapping Emacs faces to htmlize's fstructs. + ;; The keys are either face symbols or attrlists, so the test + ;; function must be `equal'. + (let ((face-map (make-hash-table :test 'equal)) + css-names) + (dolist (face faces) + (unless (gethash face face-map) + ;; Haven't seen FACE yet; convert it to an fstruct and cache + ;; it. + (let ((fstruct (if (symbolp face) + (htmlize-face-to-fstruct face) + (htmlize-attrlist-to-fstruct face)))) + (setf (gethash face face-map) fstruct) + (let* ((css-name (htmlize-fstruct-css-name fstruct)) + (new-name css-name) + (i 0)) + ;; Uniquify the face's css-name by using NAME-1, NAME-2, + ;; etc. + (while (member new-name css-names) + (setq new-name (format "%s-%s" css-name (incf i)))) + (unless (equal new-name css-name) + (setf (htmlize-fstruct-css-name fstruct) new-name)) + (push new-name css-names))))) + face-map)) + +(defun htmlize-unstringify-face (face) + "If FACE is a string, return it interned, otherwise return it unchanged." + (if (stringp face) + (intern face) + face)) + +(defun htmlize-faces-in-buffer () + "Return a list of faces used in the current buffer. +Under XEmacs, this returns the set of faces specified by the extents +with the `face' property. (This covers text properties as well.) Under +GNU Emacs, it returns the set of faces specified by the `face' text +property and by buffer overlays that specify `face'." + (let (faces) + ;; Testing for (fboundp 'map-extents) doesn't work because W3 + ;; defines `map-extents' under FSF. + (if htmlize-running-xemacs + (let (face-prop) + (map-extents (lambda (extent ignored) + (setq face-prop (extent-face extent) + ;; FACE-PROP can be a face or a list of + ;; faces. + faces (if (listp face-prop) + (union face-prop faces) + (adjoin face-prop faces))) + nil) + nil + ;; Specify endpoints explicitly to respect + ;; narrowing. + (point-min) (point-max) nil nil 'face)) + ;; FSF Emacs code. + ;; Faces used by text properties. + (let ((pos (point-min)) face-prop next) + (while (< pos (point-max)) + (setq face-prop (get-text-property pos 'face) + next (or (next-single-property-change pos 'face) (point-max))) + ;; FACE-PROP can be a face/attrlist or a list thereof. + (setq faces (if (htmlize-face-list-p face-prop) + (nunion (mapcar #'htmlize-unstringify-face face-prop) + faces :test 'equal) + (adjoin (htmlize-unstringify-face face-prop) + faces :test 'equal))) + (setq pos next))) + ;; Faces used by overlays. + (dolist (overlay (overlays-in (point-min) (point-max))) + (let ((face-prop (overlay-get overlay 'face))) + ;; FACE-PROP can be a face/attrlist or a list thereof. + (setq faces (if (htmlize-face-list-p face-prop) + (nunion (mapcar #'htmlize-unstringify-face face-prop) + faces :test 'equal) + (adjoin (htmlize-unstringify-face face-prop) + faces :test 'equal)))))) + faces)) + +;; htmlize-faces-at-point returns the faces in use at point. The +;; faces are sorted by increasing priority, i.e. the last face takes +;; precedence. +;; +;; Under XEmacs, this returns all the faces in all the extents at +;; point. Under GNU Emacs, this returns all the faces in the `face' +;; property and all the faces in the overlays at point. + +(cond (htmlize-running-xemacs + (defun htmlize-faces-at-point () + (let (extent extent-list face-list face-prop) + (while (setq extent (extent-at (point) nil 'face extent)) + (push extent extent-list)) + ;; extent-list is in reverse display order, meaning that + ;; smallest ones come last. That is the order we want, + ;; except it can be overridden by the `priority' property. + (setq extent-list (stable-sort extent-list #'< + :key #'extent-priority)) + (dolist (extent extent-list) + (setq face-prop (extent-face extent)) + ;; extent's face-list is in reverse order from what we + ;; want, but the `nreverse' below will take care of it. + (setq face-list (if (listp face-prop) + (append face-prop face-list) + (cons face-prop face-list)))) + (nreverse face-list)))) + (t + (defun htmlize-faces-at-point () + (let (all-faces) + ;; Faces from text properties. + (let ((face-prop (get-text-property (point) 'face))) + (setq all-faces (if (htmlize-face-list-p face-prop) + (nreverse (mapcar #'htmlize-unstringify-face + face-prop)) + (list (htmlize-unstringify-face face-prop))))) + ;; Faces from overlays. + (let ((overlays + ;; Collect overlays at point that specify `face'. + (delete-if-not (lambda (o) + (overlay-get o 'face)) + (overlays-at (point)))) + list face-prop) + ;; Sort the overlays so the smaller (more specific) ones + ;; come later. The number of overlays at each one + ;; position should be very small, so the sort shouldn't + ;; slow things down. + (setq overlays (sort* overlays + ;; Sort by ascending... + #'< + ;; ...overlay size. + :key (lambda (o) + (- (overlay-end o) + (overlay-start o))))) + ;; Overlay priorities, if present, override the above + ;; established order. Larger overlay priority takes + ;; precedence and therefore comes later in the list. + (setq overlays (stable-sort + overlays + ;; Reorder (stably) by acending... + #'< + ;; ...overlay priority. + :key (lambda (o) + (or (overlay-get o 'priority) 0)))) + (dolist (overlay overlays) + (setq face-prop (overlay-get overlay 'face)) + (setq list (if (htmlize-face-list-p face-prop) + (nconc (nreverse (mapcar + #'htmlize-unstringify-face + face-prop)) + list) + (cons (htmlize-unstringify-face face-prop) list)))) + ;; Under "Merging Faces" the manual explicitly states + ;; that faces specified by overlays take precedence over + ;; faces specified by text properties. + (setq all-faces (nconc all-faces list))) + all-faces)))) + +;; htmlize supports generating HTML in several flavors, some of which +;; use CSS, and others the <font> element. We take an OO approach and +;; define "methods" that indirect to the functions that depend on +;; `htmlize-output-type'. The currently used methods are `doctype', +;; `insert-head', `body-tag', and `insert-text'. Not all output types +;; define all methods. +;; +;; Methods are called either with (htmlize-method METHOD ARGS...) +;; special form, or by accessing the function with +;; (htmlize-method-function 'METHOD) and calling (funcall FUNCTION). +;; The latter form is useful in tight loops because `htmlize-method' +;; conses. + +(defmacro htmlize-method (method &rest args) + ;; Expand to (htmlize-TYPE-METHOD ...ARGS...). TYPE is the value of + ;; `htmlize-output-type' at run time. + `(funcall (htmlize-method-function ',method) ,@args)) + +(defun htmlize-method-function (method) + ;; Return METHOD's function definition for the current output type. + ;; The returned object can be safely funcalled. + (let ((sym (intern (format "htmlize-%s-%s" htmlize-output-type method)))) + (indirect-function (if (fboundp sym) + sym + (let ((default (intern (concat "htmlize-default-" + (symbol-name method))))) + (if (fboundp default) + default + 'ignore)))))) + +(defvar htmlize-memoization-table (make-hash-table :test 'equal)) + +(defmacro htmlize-memoize (key generator) + "Return the value of GENERATOR, memoized as KEY. +That means that GENERATOR will be evaluated and returned the first time +it's called with the same value of KEY. All other times, the cached +\(memoized) value will be returned." + (let ((value (gensym))) + `(let ((,value (gethash ,key htmlize-memoization-table))) + (unless ,value + (setq ,value ,generator) + (setf (gethash ,key htmlize-memoization-table) ,value)) + ,value))) + +;;; Default methods. + +(defun htmlize-default-doctype () + nil ; no doc-string + ;; Note that the `font' output is technically invalid under this DTD + ;; because the DTD doesn't allow embedding <font> in <pre>. + "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01//EN\">" + ) + +(defun htmlize-default-body-tag (face-map) + nil ; no doc-string + "<body>") + +;;; CSS based output support. + +;; Internal function; not a method. +(defun htmlize-css-specs (fstruct) + (let (result) + (when (htmlize-fstruct-foreground fstruct) + (push (format "color: %s;" (htmlize-fstruct-foreground fstruct)) + result)) + (when (htmlize-fstruct-background fstruct) + (push (format "background-color: %s;" + (htmlize-fstruct-background fstruct)) + result)) + (let ((size (htmlize-fstruct-size fstruct))) + (when (and size (not (eq htmlize-ignore-face-size t))) + (cond ((floatp size) + (push (format "font-size: %d%%;" (* 100 size)) result)) + ((not (eq htmlize-ignore-face-size 'absolute)) + (push (format "font-size: %spt;" (/ size 10.0)) result))))) + (when (htmlize-fstruct-boldp fstruct) + (push "font-weight: bold;" result)) + (when (htmlize-fstruct-italicp fstruct) + (push "font-style: italic;" result)) + (when (htmlize-fstruct-underlinep fstruct) + (push "text-decoration: underline;" result)) + (when (htmlize-fstruct-overlinep fstruct) + (push "text-decoration: overline;" result)) + (when (htmlize-fstruct-strikep fstruct) + (push "text-decoration: line-through;" result)) + (nreverse result))) + +(defun htmlize-css-insert-head (buffer-faces face-map) + (insert " <style type=\"text/css\">\n <!--\n") + (insert " body {\n " + (mapconcat #'identity + (htmlize-css-specs (gethash 'default face-map)) + "\n ") + "\n }\n") + (dolist (face (sort* (copy-list buffer-faces) #'string-lessp + :key (lambda (f) + (htmlize-fstruct-css-name (gethash f face-map))))) + (let* ((fstruct (gethash face face-map)) + (cleaned-up-face-name + (let ((s + ;; Use `prin1-to-string' rather than `symbol-name' + ;; to get the face name because the "face" can also + ;; be an attrlist, which is not a symbol. + (prin1-to-string face))) + ;; If the name contains `--' or `*/', remove them. + (while (string-match "--" s) + (setq s (replace-match "-" t t s))) + (while (string-match "\\*/" s) + (setq s (replace-match "XX" t t s))) + s)) + (specs (htmlize-css-specs fstruct))) + (insert " ." (htmlize-fstruct-css-name fstruct)) + (if (null specs) + (insert " {") + (insert " {\n /* " cleaned-up-face-name " */\n " + (mapconcat #'identity specs "\n "))) + (insert "\n }\n"))) + (insert htmlize-hyperlink-style + " -->\n </style>\n")) + +(defun htmlize-css-insert-text (text fstruct-list buffer) + ;; Insert TEXT colored with FACES into BUFFER. In CSS mode, this is + ;; easy: just nest the text in one <span class=...> tag for each + ;; face in FSTRUCT-LIST. + (dolist (fstruct fstruct-list) + (princ "<span class=\"" buffer) + (princ (htmlize-fstruct-css-name fstruct) buffer) + (princ "\">" buffer)) + (princ text buffer) + (dolist (fstruct fstruct-list) + (ignore fstruct) ; shut up the byte-compiler + (princ "</span>" buffer))) + +;; `inline-css' output support. + +(defun htmlize-inline-css-body-tag (face-map) + (format "<body style=\"%s\">" + (mapconcat #'identity (htmlize-css-specs (gethash 'default face-map)) + " "))) + +(defun htmlize-inline-css-insert-text (text fstruct-list buffer) + (let* ((merged (htmlize-merge-faces fstruct-list)) + (style (htmlize-memoize + merged + (let ((specs (htmlize-css-specs merged))) + (and specs + (mapconcat #'identity (htmlize-css-specs merged) " ")))))) + (when style + (princ "<span style=\"" buffer) + (princ style buffer) + (princ "\">" buffer)) + (princ text buffer) + (when style + (princ "</span>" buffer)))) + +;;; `font' tag based output support. + +(defun htmlize-font-body-tag (face-map) + (let ((fstruct (gethash 'default face-map))) + (format "<body text=\"%s\" bgcolor=\"%s\">" + (htmlize-fstruct-foreground fstruct) + (htmlize-fstruct-background fstruct)))) + +(defun htmlize-font-insert-text (text fstruct-list buffer) + ;; In `font' mode, we use the traditional HTML means of altering + ;; presentation: <font> tag for colors, <b> for bold, <u> for + ;; underline, and <strike> for strike-through. + (let* ((merged (htmlize-merge-faces fstruct-list)) + (markup (htmlize-memoize + merged + (cons (concat + (and (htmlize-fstruct-foreground merged) + (format "<font color=\"%s\">" (htmlize-fstruct-foreground merged))) + (and (htmlize-fstruct-boldp merged) "<b>") + (and (htmlize-fstruct-italicp merged) "<i>") + (and (htmlize-fstruct-underlinep merged) "<u>") + (and (htmlize-fstruct-strikep merged) "<strike>")) + (concat + (and (htmlize-fstruct-strikep merged) "</strike>") + (and (htmlize-fstruct-underlinep merged) "</u>") + (and (htmlize-fstruct-italicp merged) "</i>") + (and (htmlize-fstruct-boldp merged) "</b>") + (and (htmlize-fstruct-foreground merged) "</font>")))))) + (princ (car markup) buffer) + (princ text buffer) + (princ (cdr markup) buffer))) + +(defun htmlize-buffer-1 () + ;; Internal function; don't call it from outside this file. Htmlize + ;; current buffer, writing the resulting HTML to a new buffer, and + ;; return it. Unlike htmlize-buffer, this doesn't change current + ;; buffer or use switch-to-buffer. + (save-excursion + ;; Protect against the hook changing the current buffer. + (save-excursion + (run-hooks 'htmlize-before-hook)) + ;; Convince font-lock support modes to fontify the entire buffer + ;; in advance. + (htmlize-ensure-fontified) + (clrhash htmlize-extended-character-cache) + (clrhash htmlize-memoization-table) + (let* ((buffer-faces (htmlize-faces-in-buffer)) + (face-map (htmlize-make-face-map (adjoin 'default buffer-faces))) + ;; Generate the new buffer. It's important that it inherits + ;; default-directory from the current buffer. + (htmlbuf (generate-new-buffer (if (buffer-file-name) + (htmlize-make-file-name + (file-name-nondirectory + (buffer-file-name))) + "*html*"))) + (places (gensym)) + (title (if (buffer-file-name) + (file-name-nondirectory (buffer-file-name)) + (buffer-name)))) + ;; Initialize HTMLBUF and insert the HTML prolog. + (with-current-buffer htmlbuf + (buffer-disable-undo) + (insert (htmlize-method doctype) ?\n + (format "<!-- Created by htmlize-%s in %s mode. -->\n" + htmlize-version htmlize-output-type) + "<html>\n ") + (put places 'head-start (point-marker)) + (insert "<head>\n" + " <title>" (htmlize-protect-string title) "</title>\n" + (if htmlize-html-charset + (format (concat " <meta http-equiv=\"Content-Type\" " + "content=\"text/html; charset=%s\">\n") + htmlize-html-charset) + "") + htmlize-head-tags) + (htmlize-method insert-head buffer-faces face-map) + (insert " </head>") + (put places 'head-end (point-marker)) + (insert "\n ") + (put places 'body-start (point-marker)) + (insert (htmlize-method body-tag face-map) + "\n ") + (put places 'content-start (point-marker)) + (insert "<pre>\n")) + (let ((insert-text-method + ;; Get the inserter method, so we can funcall it inside + ;; the loop. Not calling `htmlize-method' in the loop + ;; body yields a measurable speed increase. + (htmlize-method-function 'insert-text)) + ;; Declare variables used in loop body outside the loop + ;; because it's faster to establish `let' bindings only + ;; once. + next-change text face-list fstruct-list trailing-ellipsis) + ;; This loop traverses and reads the source buffer, appending + ;; the resulting HTML to HTMLBUF with `princ'. This method is + ;; fast because: 1) it doesn't require examining the text + ;; properties char by char (htmlize-next-face-change is used + ;; to move between runs with the same face), and 2) it doesn't + ;; require buffer switches, which are slow in Emacs. + (goto-char (point-min)) + (while (not (eobp)) + (setq next-change (htmlize-next-face-change (point))) + ;; Get faces in use between (point) and NEXT-CHANGE, and + ;; convert them to fstructs. + (setq face-list (htmlize-faces-at-point) + fstruct-list (delq nil (mapcar (lambda (f) + (gethash f face-map)) + face-list))) + (multiple-value-setq (text trailing-ellipsis) + (htmlize-extract-text (point) next-change trailing-ellipsis)) + ;; Don't bother writing anything if there's no text (this + ;; happens in invisible regions). + (when (> (length text) 0) + ;; Insert the text, along with the necessary markup to + ;; represent faces in FSTRUCT-LIST. + (funcall insert-text-method text fstruct-list htmlbuf)) + (goto-char next-change))) + + ;; Insert the epilog and post-process the buffer. + (with-current-buffer htmlbuf + (insert "</pre>") + (put places 'content-end (point-marker)) + (insert "\n </body>") + (put places 'body-end (point-marker)) + (insert "\n</html>\n") + (when htmlize-generate-hyperlinks + (htmlize-make-hyperlinks)) + (htmlize-defang-local-variables) + (when htmlize-replace-form-feeds + ;; Change each "\n^L" to "<hr />". + (goto-char (point-min)) + (let ((source + ;; ^L has already been escaped, so search for that. + (htmlize-protect-string "\n\^L")) + (replacement + (if (stringp htmlize-replace-form-feeds) + htmlize-replace-form-feeds + "</pre><hr /><pre>"))) + (while (search-forward source nil t) + (replace-match replacement t t)))) + (goto-char (point-min)) + (when htmlize-html-major-mode + ;; What sucks about this is that the minor modes, most notably + ;; font-lock-mode, won't be initialized. Oh well. + (funcall htmlize-html-major-mode)) + (set (make-local-variable 'htmlize-buffer-places) + (symbol-plist places)) + (run-hooks 'htmlize-after-hook) + (buffer-enable-undo)) + htmlbuf))) + +;; Utility functions. + +(defmacro htmlize-with-fontify-message (&rest body) + ;; When forcing fontification of large buffers in + ;; htmlize-ensure-fontified, inform the user that he is waiting for + ;; font-lock, not for htmlize to finish. + `(progn + (if (> (buffer-size) 65536) + (message "Forcing fontification of %s..." + (buffer-name (current-buffer)))) + ,@body + (if (> (buffer-size) 65536) + (message "Forcing fontification of %s...done" + (buffer-name (current-buffer)))))) + +(defun htmlize-ensure-fontified () + ;; If font-lock is being used, ensure that the "support" modes + ;; actually fontify the buffer. If font-lock is not in use, we + ;; don't care because, except in htmlize-file, we don't force + ;; font-lock on the user. + (when (and (boundp 'font-lock-mode) + font-lock-mode) + ;; In part taken from ps-print-ensure-fontified in GNU Emacs 21. + (cond + ((and (boundp 'jit-lock-mode) + (symbol-value 'jit-lock-mode)) + (htmlize-with-fontify-message + (jit-lock-fontify-now (point-min) (point-max)))) + ((and (boundp 'lazy-lock-mode) + (symbol-value 'lazy-lock-mode)) + (htmlize-with-fontify-message + (lazy-lock-fontify-region (point-min) (point-max)))) + ((and (boundp 'lazy-shot-mode) + (symbol-value 'lazy-shot-mode)) + (htmlize-with-fontify-message + ;; lazy-shot is amazing in that it must *refontify* the region, + ;; even if the whole buffer has already been fontified. <sigh> + (lazy-shot-fontify-region (point-min) (point-max)))) + ;; There's also fast-lock, but we don't need to handle specially, + ;; I think. fast-lock doesn't really defer fontification, it + ;; just saves it to an external cache so it's not done twice. + ))) + + +;;;###autoload +(defun htmlize-buffer (&optional buffer) + "Convert BUFFER to HTML, preserving colors and decorations. + +The generated HTML is available in a new buffer, which is returned. +When invoked interactively, the new buffer is selected in the current +window. The title of the generated document will be set to the buffer's +file name or, if that's not available, to the buffer's name. + +Note that htmlize doesn't fontify your buffers, it only uses the +decorations that are already present. If you don't set up font-lock or +something else to fontify your buffers, the resulting HTML will be +plain. Likewise, if you don't like the choice of colors, fix the mode +that created them, or simply alter the faces it uses." + (interactive) + (let ((htmlbuf (with-current-buffer (or buffer (current-buffer)) + (htmlize-buffer-1)))) + (when (interactive-p) + (switch-to-buffer htmlbuf)) + htmlbuf)) + +;;;###autoload +(defun htmlize-region (beg end) + "Convert the region to HTML, preserving colors and decorations. +See `htmlize-buffer' for details." + (interactive "r") + ;; Don't let zmacs region highlighting end up in HTML. + (when (fboundp 'zmacs-deactivate-region) + (zmacs-deactivate-region)) + (let ((htmlbuf (save-restriction + (narrow-to-region beg end) + (htmlize-buffer-1)))) + (when (interactive-p) + (switch-to-buffer htmlbuf)) + htmlbuf)) + +(defun htmlize-region-for-paste (beg end) + "Htmlize the region and return just the HTML as a string. +This forces the `inline-css' style and only returns the HTML body, +but without the BODY tag. This should make it useful for inserting +the text to another HTML buffer." + (let* ((htmlize-output-type 'inline-css) + (htmlbuf (htmlize-region beg end))) + (unwind-protect + (with-current-buffer htmlbuf + (buffer-substring (plist-get htmlize-buffer-places 'content-start) + (plist-get htmlize-buffer-places 'content-end))) + (kill-buffer htmlbuf)))) + +(defun htmlize-make-file-name (file) + "Make an HTML file name from FILE. + +In its default implementation, this simply appends `.html' to FILE. +This function is called by htmlize to create the buffer file name, and +by `htmlize-file' to create the target file name. + +More elaborate transformations are conceivable, such as changing FILE's +extension to `.html' (\"file.c\" -> \"file.html\"). If you want them, +overload this function to do it and htmlize will comply." + (concat file ".html")) + +;; Older implementation of htmlize-make-file-name that changes FILE's +;; extension to ".html". +;(defun htmlize-make-file-name (file) +; (let ((extension (file-name-extension file)) +; (sans-extension (file-name-sans-extension file))) +; (if (or (equal extension "html") +; (equal extension "htm") +; (equal sans-extension "")) +; (concat file ".html") +; (concat sans-extension ".html")))) + +;;;###autoload +(defun htmlize-file (file &optional target) + "Load FILE, fontify it, convert it to HTML, and save the result. + +Contents of FILE are inserted into a temporary buffer, whose major mode +is set with `normal-mode' as appropriate for the file type. The buffer +is subsequently fontified with `font-lock' and converted to HTML. Note +that, unlike `htmlize-buffer', this function explicitly turns on +font-lock. If a form of highlighting other than font-lock is desired, +please use `htmlize-buffer' directly on buffers so highlighted. + +Buffers currently visiting FILE are unaffected by this function. The +function does not change current buffer or move the point. + +If TARGET is specified and names a directory, the resulting file will be +saved there instead of to FILE's directory. If TARGET is specified and +does not name a directory, it will be used as output file name." + (interactive (list (read-file-name + "HTML-ize file: " + nil nil nil (and (buffer-file-name) + (file-name-nondirectory + (buffer-file-name)))))) + (let ((output-file (if (and target (not (file-directory-p target))) + target + (expand-file-name + (htmlize-make-file-name (file-name-nondirectory file)) + (or target (file-name-directory file))))) + ;; Try to prevent `find-file-noselect' from triggering + ;; font-lock because we'll fontify explicitly below. + (font-lock-mode nil) + (font-lock-auto-fontify nil) + (global-font-lock-mode nil) + ;; Ignore the size limit for the purposes of htmlization. + (font-lock-maximum-size nil) + ;; Disable font-lock support modes. This will only work in + ;; more recent Emacs versions, so htmlize-buffer-1 still needs + ;; to call htmlize-ensure-fontified. + (font-lock-support-mode nil)) + (with-temp-buffer + ;; Insert FILE into the temporary buffer. + (insert-file-contents file) + ;; Set the file name so normal-mode and htmlize-buffer-1 pick it + ;; up. Restore it afterwards so with-temp-buffer's kill-buffer + ;; doesn't complain about killing a modified buffer. + (let ((buffer-file-name file)) + ;; Set the major mode for the sake of font-lock. + (normal-mode) + (font-lock-mode 1) + (unless font-lock-mode + ;; In GNU Emacs (font-lock-mode 1) doesn't force font-lock, + ;; contrary to the documentation. This seems to work. + (font-lock-fontify-buffer)) + ;; htmlize the buffer and save the HTML. + (with-current-buffer (htmlize-buffer-1) + (unwind-protect + (progn + (run-hooks 'htmlize-file-hook) + (write-region (point-min) (point-max) output-file)) + (kill-buffer (current-buffer))))))) + ;; I haven't decided on a useful return value yet, so just return + ;; nil. + nil) + +;;;###autoload +(defun htmlize-many-files (files &optional target-directory) + "Convert FILES to HTML and save the corresponding HTML versions. + +FILES should be a list of file names to convert. This function calls +`htmlize-file' on each file; see that function for details. When +invoked interactively, you are prompted for a list of files to convert, +terminated with RET. + +If TARGET-DIRECTORY is specified, the HTML files will be saved to that +directory. Normally, each HTML file is saved to the directory of the +corresponding source file." + (interactive + (list + (let (list file) + ;; Use empty string as DEFAULT because setting DEFAULT to nil + ;; defaults to the directory name, which is not what we want. + (while (not (equal (setq file (read-file-name + "HTML-ize file (RET to finish): " + (and list (file-name-directory + (car list))) + "" t)) + "")) + (push file list)) + (nreverse list)))) + ;; Verify that TARGET-DIRECTORY is indeed a directory. If it's a + ;; file, htmlize-file will use it as target, and that doesn't make + ;; sense. + (and target-directory + (not (file-directory-p target-directory)) + (error "target-directory must name a directory: %s" target-directory)) + (dolist (file files) + (htmlize-file file target-directory))) + +;;;###autoload +(defun htmlize-many-files-dired (arg &optional target-directory) + "HTMLize dired-marked files." + (interactive "P") + (htmlize-many-files (dired-get-marked-files nil arg) target-directory)) + +(provide 'htmlize) + +;;; htmlize.el ends here diff --git a/.emacs.d/elisp/ide-skel.el b/.emacs.d/elisp/ide-skel.el new file mode 100644 index 0000000..90be871 --- /dev/null +++ b/.emacs.d/elisp/ide-skel.el @@ -0,0 +1,4016 @@ +;; ide-skel.el --- IDE skeleton for Emacs Lisp hackers + +;; Copyright (C) 2008 Peter Karpiuk, Scott Tiger S.A. + +;; Author: Peter Karpiuk <piotr.karpiuk (at) gmail (dot) com> +;; Maintainer: Peter Karpiuk <piotr.karpiuk (at) gmail (dot) com> +;; Created: 24 Apr 2008 +;; Version 0.6.0 +;; Keywords: ide speedbar + +;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;; Ide-skel is a skeleton (or framework) of IDE for Emacs users. +;; Like Eclipse, it can be used as is with some predefined plugins +;; on board, but is designed to extend by Emacs Lisp programmers to +;; suite their own needs. Emacs 22 only, tested under Linux only +;; (under Windows ide-skel.el will rather not work, sorry). +;; +;; ** Configuration in .emacs +;; +;; (require 'ide-skel) +;; +;; ;; optional, but useful - see Emacs Manual +;; (partial-completion-mode) +;; (icomplete-mode) +;; +;; ;; for convenience +;; (global-set-key [f4] 'ide-skel-proj-find-files-by-regexp) +;; (global-set-key [f5] 'ide-skel-proj-grep-files-by-regexp) +;; (global-set-key [f10] 'ide-skel-toggle-left-view-window) +;; (global-set-key [f11] 'ide-skel-toggle-bottom-view-window) +;; (global-set-key [f12] 'ide-skel-toggle-right-view-window) +;; (global-set-key [C-next] 'tabbar-backward) +;; (global-set-key [C-prior] 'tabbar-forward) +;; +;; ** Side view windows +;; +;; Left and right view windows are "speedbars" - they are embedded +;; inside main Emacs frame and can be open/closed independently. +;; Right view window summarizes information related to the current +;; editor buffer - it can present content of such buffer in another +;; way (eg. Imenu tree), or show an extra panel for buffer major +;; mode operations (see SQL*Plus mode plugin example). Left view +;; window contains buffers such like buffer list (yet another, +;; popular way for switching buffers), filesystem/project browser +;; for easy navigation, or Info documentation browser, +;; or... whatever you wish. +;; +;; Side view windows are special - they cannot take focus and we can +;; operate on it only with mouse (!). Some window operations like +;; delete-other-windows (C-x 1) are slighty modified to treat side +;; view windows specially. +;; +;; ** Bottom view window +;; +;; Let auxiliary buffers (*shell*, *Messages*, *Help*, *Compilation* +;; and another buffers with '*' in name) pop up/show in bottom +;; window only. BUT, if you want, you can open any buffer in any +;; window (except side windows) as usual - that's only nice +;; heuristic, not pressure. +;; +;; Bottom view window remembers last selected buffer within it, so +;; if you close this window and open later, it will show you buffer +;; which you expect. +;; +;; ** Tabbars +;; +;; Ide-skel uses (great) tabbar.el package with some modifications: +;; +;; - there is no division into major mode groups (like in +;; Eclipse), +;; +;; - side view windows, bottom view window and editor windows have +;; different tabsets, +;; +;; - you can scroll tabs with mouse wheel, +;; +;; - the Home button in window left corner acts as window menu +;; (you can add your items to it in your plugin), +;; +;; - mouse-3 click on tab kills its buffer +;; +;; * Project +;; +;; Here, "project" means a directory tree checked out from CVS or +;; SVN. One project can contain source files of many types. When +;; we edit any project file, Emacs can easily find the project root +;; directory simply by looking at filesystem. +;; +;; So, we can execute many commands (grep, find, replace) on all +;; project source files or on all project source files of the same +;; type as file edited now (see Project menu). Ide-skel package +;; also automatically configures partial-completion-mode for project +;; edited now. +;; +;; There is no configuration for concrete projects needed (and +;; that's great advantage in my opinion). + +;; If you find this package useful, send me a postcard to address: +;; +;; Peter Karpiuk +;; Scott Tiger S.A. +;; ul. Gawinskiego 8 +;; 01-645 Warsaw +;; Poland + + +;; * Notes for Emacs Lisp hackers +;; +;; Each side window buffer should have: +;; +;; - name that begins with space, +;; +;; - tab label (string) - buffer local IDE-SKEL-TABBAR-TAB-LABEL +;; variable, +;; +;; - keep condition function (IDE-SKEL-KEEP-CONDITION-FUNCTION), +;; +;; - menu (IDE-SKEL-TABBAR-MENU-FUNCTION) - optional. +;; +;; Side window buffer is enabled (can be choosed by mouse click on +;; his tab) if it has buffer local variable IDE-SKEL-TABBAR-ENABLED +;; set to non-nil. There may be many live side window buffers, but +;; unavailable in current context ("context" means buffer edited in +;; editor window) if they have IDE-SKEL-TABBAR-ENABLED set to nil. +;; +;; Hiding side window operation disables all window buffers. "Show +;; side window" event handler should enable (and maybe create) side +;; window buffers based on current context. When you switch to +;; other buffer in editor window (switching the context), all side +;; window buffers for which keep condition function returns nil are +;; disabled. Handlers for EDITOR-BUFFER-CHANGED event should enable +;; (and maybe create) additional buffers based on current context. +;; +;; ** Side window events +;; +;; Event handlers should be implemented as an abnormal hook: +;; +;; ide-skel-side-view-window-functions +;; +;; It should be function with parameters +;; +;; - side: symbol LEFT or RIGHT +;; +;; - event-type: symbol for event: +;; SHOW/EDITOR-BUFFER-CHANGED/TAB-CHANGE/HIDE +;; +;; - list (optional): event parameters specific for event type. +;; +;; Events are send only for opened (existing and visible) windows. +;; +;; Hook functions are called in order until one of them returns +;; non-nil. +;; +;; *** Show +;; +;; After side window open. Event handler should enable (and maybe +;; create) buffers appropriate for current context. After event +;; handle, if no side window buffer is selected, there will be +;; selected one of them. No parameters. +;; +;; *** Editor Buffer Changed +;; +;; After editor buffer changed (aka context switch). +;; +;; Before event, buffers for which keep condition function returns +;; nil, are disabled. Event handler should enable (and maybe +;; create) buffers appropriate for new context. +;; +;; Parameters: before-buffer current-buffer. +;; +;; *** Tab Change +;; +;; Before side window buffer change (as result of mouse click on tab +;; or ide-skel-side-window-switch-to-buffer function call). +;; Parameters: current-buffer new-buffer +;; +;; *** Hide +;; +;; Before side window hiding. After event handling, all side window +;; buffers are disabled. +;; +;; *** Functions & vars +;; +;; In plugins, you can use variables with self-descriptive names: +;; +;; ide-skel-selected-frame +;; ide-skel-current-editor-window +;; ide-skel-current-editor-buffer +;; ide-skel-current-left-view-window +;; ide-skel-current-right-view-window +;; +;; Moreover, when user selects another buffer to edit, the +;; +;; ide-skel-editor-buffer-changed-hook +;; +;; hook is run. It is similar to "editor buffer changed" event, but +;; has no parameters and is run even when all side windows are +;; closed. +;; +;; **** Functions +;; +;; ide-skel-side-window-switch-to-buffer (side-window buffer) +;; Switch buffer in side window (please use only this function for +;; this operation). +;; +;; ide-skel-get-side-view-buffer-create (name side-sym tab-label +;; help-string keep-condition-function) +;; Create new buffer for side view window. NAME should begin with +;; space, side sym should be LEFT or RIGHT. +;; +;; **** Local variables in side window buffers +;; +;; ide-skel-tabbar-tab-label +;; ide-skel-tabbar-tab-help-string +;; ide-skel-tabbar-menu-function +;; ide-skel-tabbar-enabled +;; ide-skel-keep-condition-function + +(require 'cl) +(require 'complete) +(require 'tree-widget) +(require 'tabbar) +(require 'recentf) + +(defgroup ide-skel nil + "Ide Skeleton" + :group 'tools + :version 21) + +(defcustom ide-skel-tabbar-hidden-buffer-names-regexp-list '("^TAGS" "^diary$") + "Buffer name that matches any of this regexps, will have no tab." + :group 'ide-skel + :tag "Hidden Buffer Names Regexp List" + :type '(repeat regexp) + :initialize 'custom-initialize-default + :set (lambda (symbol value) + (when tabbar-mode + (tabbar-init-tabsets-store)) + (set-default symbol value))) + +(defcustom ide-skel-bottom-view-buffer-names-regexps '("\\*.*\\*") + "Buffers with names matched by one of this regexps will be shown in bottom view." + :group 'ide-skel + :tag "Bottom View Buffer Names Regexps" + :type '(repeat regexp) + :initialize 'custom-initialize-default + :set (lambda (symbol value) + (when tabbar-mode + (tabbar-init-tabsets-store)) + (set-default symbol value)) + ) + +(defcustom ide-skel-bottom-view-buffer-names-disallowed-regexps '("\\*info\\*" "\\*Backtrace\\*") + "Buffers with names matched by one of this regexps will NOT be shown in bottom view." + :group 'ide-skel + :tag "Bottom View Buffer Names Disallowed Regexps" + :type '(repeat regexp) + :initialize 'custom-initialize-default + :set (lambda (symbol value) + (when tabbar-mode + (tabbar-init-tabsets-store)) + (set-default symbol value)) + ) + +(defconst ide-skel-left-view-window-tabset-name "LeftView") +(defconst ide-skel-right-view-window-tabset-name "RightView") +(defconst ide-skel-bottom-view-window-tabset-name "BottomView") +(defconst ide-skel-editor-window-tabset-name "Editor") + +(defun ide-skel-shine-color (color percent) + (when (equal color "unspecified-bg") + (setq color (if (< percent 0) "white" "black"))) + (apply 'format "#%02x%02x%02x" + (mapcar (lambda (value) + (min 65535 (max 0 (* (+ (/ value 650) percent) 650)))) + (color-values color)))) + +(defun ide-skel-color-percentage (color) + (truncate (* (/ (/ (reduce '+ (color-values color)) 3.0) 65535.0) 100.0))) + +(defun ide-skel-shine-face-background (face-sym percent) + (when (>= (ide-skel-color-percentage (face-background 'default)) 50) + (setq percent (- percent))) + (set-face-attribute face-sym nil + :background (ide-skel-shine-color (face-background 'default) percent))) + +(defun ide-skel-shine-face-foreground (face-sym percent) + (when (>= (ide-skel-color-percentage (face-foreground 'default)) 50) + (setq percent (- percent))) + (set-face-attribute face-sym nil + :foreground (ide-skel-shine-color (face-foreground 'default) percent))) + + +(defvar ide-skel-tabbar-tab-label-max-width 25 + "Max width for tab label. Nil means no limit. If label width is too big, it will be shortened with ... inside.") + +(defvar ide-skel-tabbar-tab-label nil + "Tab name. Local for buffer in side view window.") +(make-variable-buffer-local 'ide-skel-tabbar-tab-label) + +(defvar ide-skel-tabbar-tab-help-string nil + "Tooltip text for tab in side view window. Buffer local.") +(make-variable-buffer-local 'ide-skel-tabbar-tab-help-string) + +(defvar ide-skel-tabset-name nil) +(make-variable-buffer-local 'ide-skel-tabset-name) + +(defvar ide-skel-tabbar-menu-function nil) +(make-variable-buffer-local 'ide-skel-tabbar-menu-function) + +(defvar ide-skel-tabbar-enabled nil) +(make-variable-buffer-local 'ide-skel-tabbar-enabled) + +(defvar ide-skel-keep-condition-function nil) +(make-variable-buffer-local 'ide-skel-keep-condition-function) + +(defvar ide-skel-current-left-view-window nil) +(defvar ide-skel-current-right-view-window nil) +(defvar ide-skel-current-editor-window nil) +(defvar ide-skel-current-editor-buffer nil) +(defvar ide-skel-selected-frame nil) + +(defconst ide-skel-left-view-window-xpm "\ +/* XPM */ +static char * left_view_xpm[] = { +\"24 24 145 2\", +\" c None\", +\". c #000000\", +\"+ c #FBFED6\", +\"@ c #F3F6CE\", +\"# c #EBEEC7\", +\"$ c #E3E7BF\", +\"% c #DCE0B9\", +\"& c #D5D9B2\", +\"* c #FFFFFF\", +\"= c #FDFDFD\", +\"- c #F9F9F9\", +\"; c #F4F4F4\", +\"> c #DDDDDD\", +\", c #F2F5CD\", +\"' c #E4E8C0\", +\") c #DDE1BA\", +\"! c #D7DAB4\", +\"~ c #D1D4AE\", +\"{ c #FEFEFE\", +\"] c #FBFBFB\", +\"^ c #F8F8F8\", +\"/ c #F5F5F5\", +\"( c #F2F2F2\", +\"_ c #DBDBDB\", +\": c #E9EDC5\", +\"< c #D8DBB5\", +\"[ c #D2D5AF\", +\"} c #CDD0AA\", +\"| c #FCFCFC\", +\"1 c #F6F6F6\", +\"2 c #F3F3F3\", +\"3 c #F0F0F0\", +\"4 c #DADADA\", +\"5 c #E1E5BD\", +\"6 c #CDD0AB\", +\"7 c #C8CCA6\", +\"8 c #FAFAFA\", +\"9 c #F7F7F7\", +\"0 c #EFEFEF\", +\"a c #D9D9D9\", +\"b c #DADDB6\", +\"c c #C4C7A2\", +\"d c #EDEDED\", +\"e c #D7D7D7\", +\"f c #D3D6B0\", +\"g c #CFD3AD\", +\"h c #CBCFA9\", +\"i c #C8CBA6\", +\"j c #C0C39F\", +\"k c #F1F1F1\", +\"l c #EEEEEE\", +\"m c #ECECEC\", +\"n c #D6D6D6\", +\"o c #C9CDA7\", +\"p c #C6C9A4\", +\"q c #C3C6A1\", +\"r c #BFC39E\", +\"s c #BCBF9B\", +\"t c #EAEAEA\", +\"u c #D4D4D4\", +\"v c #C7CAA5\", +\"w c #C1C5A0\", +\"x c #BEC29D\", +\"y c #BBBF9B\", +\"z c #B9BC98\", +\"A c #EBEBEB\", +\"B c #E8E8E8\", +\"C c #D3D3D3\", +\"D c #C2C5A0\", +\"E c #BDC09C\", +\"F c #BABE99\", +\"G c #B8BB97\", +\"H c #B5B895\", +\"I c #E9E9E9\", +\"J c #E7E7E7\", +\"K c #D1D1D1\", +\"L c #BBBE9A\", +\"M c #B7BA96\", +\"N c #B4B794\", +\"O c #B2B592\", +\"P c #E5E5E5\", +\"Q c #D0D0D0\", +\"R c #B3B693\", +\"S c #B1B491\", +\"T c #AFB28F\", +\"U c #E3E3E3\", +\"V c #CECECE\", +\"W c #B4B793\", +\"X c #B0B390\", +\"Y c #AEB18F\", +\"Z c #ACAF8D\", +\"` c #E6E6E6\", +\" . c #E4E4E4\", +\".. c #E2E2E2\", +\"+. c #CDCDCD\", +\"@. c #ADB08E\", +\"#. c #ABAE8C\", +\"$. c #AAAD8B\", +\"%. c #E0E0E0\", +\"&. c #CBCBCB\", +\"*. c #A9AC8A\", +\"=. c #A7AA89\", +\"-. c #DEDEDE\", +\";. c #CACACA\", +\">. c #ABAE8B\", +\",. c #A8AB89\", +\"'. c #A6A988\", +\"). c #A5A887\", +\"!. c #C8C8C8\", +\"~. c #A7AA88\", +\"{. c #A6A987\", +\"]. c #A4A786\", +\"^. c #A3A685\", +\"/. c #DFDFDF\", +\"(. c #C7C7C7\", +\"_. c #A5A886\", +\":. c #A2A584\", +\"<. c #A1A483\", +\"[. c #C6C6C6\", +\"}. c #A4A785\", +\"|. c #A0A382\", +\"1. c #9FA282\", +\"2. c #D8D8D8\", +\"3. c #C4C4C4\", +\"4. c #A3A684\", +\"5. c #A2A484\", +\"6. c #A0A383\", +\"7. c #9EA181\", +\"8. c #9DA080\", +\"9. c #C3C3C3\", +\"0. c #8D8F72\", +\"a. c #8C8E72\", +\"b. c #8B8D71\", +\"c. c #8A8C70\", +\"d. c #898B6F\", +\"e. c #888A6F\", +\"f. c #C5C5C5\", +\"g. c #C2C2C2\", +\"h. c #C1C1C1\", +\"i. c #C0C0C0\", +\"j. c #BEBEBE\", +\"k. c #BDBDBD\", +\"l. c #BBBBBB\", +\"m. c #BABABA\", +\"n. c #ABABAB\", +\" \", +\" . . . . . . . . . . . . . . . . . . . . . . \", +\". + @ # $ % & . * * * * * * * * * * = - ; ; > . \", +\". , # ' ) ! ~ . * * * * * * * * * { ] ^ / ( _ . \", +\". : $ ) < [ } . * * * * * * * * * | - 1 2 3 4 . \", +\". 5 % ! [ 6 7 . * * * * * * * * = 8 9 ; 3 0 a . \", +\". b & ~ } 7 c . * * * * * * * { ] ^ / ( 0 d e . \", +\". f g h i c j . * * * * * * * | - 1 2 k l m n . \", +\". } o p q r s . * * * * * * = 8 9 ; 3 0 m t u . \", +\". v c w x y z . * * * * * = 8 9 / ( 0 d A B C . \", +\". D r E F G H . * * * * { ] ^ / 2 3 l A I J K . \", +\". E L z M N O . * * * { ] ^ 1 2 3 l m I J P Q . \", +\". z M H R S T . * * { ] ^ 1 2 k l m t B P U V . \", +\". H W O X Y Z . * = ] ^ 1 2 k 0 m t B ` ...+.. \", +\". O X T @.#.$.. = 8 ^ 1 2 k 0 m t B ` ...%.&.. \", +\". T @.Z $.*.=.. 8 9 / 2 k 0 m t B ` ...%.-.;.. \", +\". Z >.*.,.'.).. 9 / 2 3 l m t B ` ...%.-.> !.. \", +\". *.,.~.{.].^.. ; ( 3 l m t B ` ...%./.> _ (.. \", +\". ~.{._.^.:.<.. k 0 l m t B ` ...%./.> _ a [.. \", +\". _.}.:.<.|.1.. 0 d A I B ` ...%./.> _ a 2.3.. \", +\". 4.5.6.1.7.8.. m A I J P ...%.-.> _ a 2.n 9.. \", +\". 0.a.b.c.d.e.. +.&.;.!.(.f.3.g.h.i.j.k.l.m.n.. \", +\" . . . . . . . . . . . . . . . . . . . . . . \", +\" \"}; +" + "XPM format image used as left view window icon") + +(defconst ide-skel-left-view-window-image + (create-image ide-skel-left-view-window-xpm 'xpm t)) + +(defconst ide-skel-right-view-window-xpm "\ +/* XPM */ +static char * right_view_xpm[] = { +\"24 24 125 2\", +\" c None\", +\". c #000000\", +\"+ c #FFFFFF\", +\"@ c #A8AB89\", +\"# c #A6A987\", +\"$ c #A4A785\", +\"% c #A2A484\", +\"& c #A0A282\", +\"* c #919376\", +\"= c #A7AA88\", +\"- c #A5A886\", +\"; c #A2A584\", +\"> c #A0A383\", +\", c #9FA181\", +\"' c #909275\", +\") c #A3A685\", +\"! c #A1A483\", +\"~ c #9FA282\", +\"{ c #9DA080\", +\"] c #8F9174\", +\"^ c #A4A786\", +\"/ c #A0A382\", +\"( c #9EA181\", +\"_ c #9C9F7F\", +\": c #8E9073\", +\"< c #FEFEFE\", +\"[ c #9B9E7F\", +\"} c #8D8F73\", +\"| c #FCFCFC\", +\"1 c #A1A484\", +\"2 c #9EA180\", +\"3 c #9A9D7E\", +\"4 c #8C8E72\", +\"5 c #FDFDFD\", +\"6 c #FAFAFA\", +\"7 c #9B9E7E\", +\"8 c #999C7D\", +\"9 c #8B8D71\", +\"0 c #F7F7F7\", +\"a c #9FA281\", +\"b c #9A9C7D\", +\"c c #989B7C\", +\"d c #8A8C70\", +\"e c #FBFBFB\", +\"f c #F8F8F8\", +\"g c #F5F5F5\", +\"h c #9C9E7F\", +\"i c #9A9D7D\", +\"j c #979A7B\", +\"k c #898B70\", +\"l c #F6F6F6\", +\"m c #F3F3F3\", +\"n c #999C7C\", +\"o c #96997A\", +\"p c #888A6F\", +\"q c #F1F1F1\", +\"r c #9B9D7E\", +\"s c #989A7B\", +\"t c #959779\", +\"u c #87896E\", +\"v c #EFEFEF\", +\"w c #959879\", +\"x c #949678\", +\"y c #86886D\", +\"z c #ECECEC\", +\"A c #97997B\", +\"B c #949778\", +\"C c #939577\", +\"D c #85876C\", +\"E c #EAEAEA\", +\"F c #95987A\", +\"G c #919476\", +\"H c #84876C\", +\"I c #F9F9F9\", +\"J c #F0F0F0\", +\"K c #EEEEEE\", +\"L c #E8E8E8\", +\"M c #949779\", +\"N c #939578\", +\"O c #929476\", +\"P c #909375\", +\"Q c #83866B\", +\"R c #F4F4F4\", +\"S c #F2F2F2\", +\"T c #E6E6E6\", +\"U c #939678\", +\"V c #929477\", +\"W c #909376\", +\"X c #8F9275\", +\"Y c #82856A\", +\"Z c #E4E4E4\", +\"` c #8E9174\", +\" . c #818469\", +\".. c #EDEDED\", +\"+. c #EBEBEB\", +\"@. c #E9E9E9\", +\"#. c #E2E2E2\", +\"$. c #8D9073\", +\"%. c #808368\", +\"&. c #E7E7E7\", +\"*. c #E5E5E5\", +\"=. c #E0E0E0\", +\"-. c #8C8F72\", +\";. c #7F8268\", +\">. c #D6D6D6\", +\",. c #D5D5D5\", +\"'. c #D4D4D4\", +\"). c #D2D2D2\", +\"!. c #D1D1D1\", +\"~. c #D0D0D0\", +\"{. c #CECECE\", +\"]. c #CDCDCD\", +\"^. c #CBCBCB\", +\"/. c #CACACA\", +\"(. c #C8C8C8\", +\"_. c #C7C7C7\", +\":. c #C5C5C5\", +\"<. c #C4C4C4\", +\"[. c #C2C2C2\", +\"}. c #7D8066\", +\"|. c #7C7F65\", +\"1. c #7B7E64\", +\"2. c #7B7D64\", +\"3. c #7A7C63\", +\"4. c #70725B\", +\" \", +\" . . . . . . . . . . . . . . . . . . . . . . \", +\". + + + + + + + + + + + + + + + . @ # $ % & * . \", +\". + + + + + + + + + + + + + + + . = - ; > , ' . \", +\". + + + + + + + + + + + + + + + . # ) ! ~ { ] . \", +\". + + + + + + + + + + + + + + + . ^ ; / ( _ : . \", +\". + + + + + + + + + + + + + + < . ) ! ~ { [ } . \", +\". + + + + + + + + + + + + + + | . 1 & 2 _ 3 4 . \", +\". + + + + + + + + + + + + + 5 6 . > ( _ 7 8 9 . \", +\". + + + + + + + + + + + + 5 6 0 . a { 7 b c d . \", +\". + + + + + + + + + + + < e f g . { h i c j k . \", +\". + + + + + + + + + + < e f l m . _ 3 n j o p . \", +\". + + + + + + + + + < e f l m q . r 8 s o t u . \", +\". + + + + + + + + 5 e f l m q v . 8 c o w x y . \", +\". + + + + + + + 5 6 f l m q v z . c A w B C D . \", +\". + + + + + < | 6 0 g m q v z E . A F B C G H . \", +\". + + + + 5 e I 0 g m J K z E L . F M N O P Q . \", +\". + + < | 6 f l R S J K z E L T . M U V W X Y . \", +\". < 5 e I 0 g m q v K z E L T Z . U V * X ` .. \", +\". e I f l R S q v ..+.@.L T Z #.. V * X ` $.%.. \", +\". f l g m q J K z +.@.&.*.Z #.=.. W X ` $.-.;.. \", +\". >.,.'.).!.~.{.].^./.(._.:.<.[.. }.|.1.2.3.4.. \", +\" . . . . . . . . . . . . . . . . . . . . . . \", +\" \"}; +" + "XPM format image used as right view window icon") + +(defconst ide-skel-right-view-window-image + (create-image ide-skel-right-view-window-xpm 'xpm t)) + +(defconst ide-skel-bottom-view-window-xpm "\ +/* XPM */ +static char * bottom_view_xpm[] = { +\"24 24 130 2\", +\" c None\", +\". c #000000\", +\"+ c #FFFFFF\", +\"@ c #FDFDFD\", +\"# c #F9F9F9\", +\"$ c #F6F6F6\", +\"% c #F4F4F4\", +\"& c #DDDDDD\", +\"* c #FEFEFE\", +\"= c #FBFBFB\", +\"- c #F8F8F8\", +\"; c #F5F5F5\", +\"> c #F2F2F2\", +\", c #DBDBDB\", +\"' c #FCFCFC\", +\") c #F3F3F3\", +\"! c #F0F0F0\", +\"~ c #DADADA\", +\"{ c #FAFAFA\", +\"] c #F7F7F7\", +\"^ c #F1F1F1\", +\"/ c #EFEFEF\", +\"( c #D9D9D9\", +\"_ c #EDEDED\", +\": c #D7D7D7\", +\"< c #EEEEEE\", +\"[ c #ECECEC\", +\"} c #D6D6D6\", +\"| c #EAEAEA\", +\"1 c #D4D4D4\", +\"2 c #EBEBEB\", +\"3 c #E8E8E8\", +\"4 c #D3D3D3\", +\"5 c #E9E9E9\", +\"6 c #E7E7E7\", +\"7 c #D1D1D1\", +\"8 c #E5E5E5\", +\"9 c #D0D0D0\", +\"0 c #E3E3E3\", +\"a c #CECECE\", +\"b c #E6E6E6\", +\"c c #E4E4E4\", +\"d c #E2E2E2\", +\"e c #CDCDCD\", +\"f c #E0E0E0\", +\"g c #CBCBCB\", +\"h c #CCCFAB\", +\"i c #CACDAA\", +\"j c #C8CBA8\", +\"k c #C7CAA7\", +\"l c #C5C8A5\", +\"m c #C3C6A4\", +\"n c #C2C5A3\", +\"o c #C0C3A1\", +\"p c #BEC1A0\", +\"q c #BDBF9E\", +\"r c #BBBE9D\", +\"s c #B9BC9B\", +\"t c #B8BA9A\", +\"u c #B6B999\", +\"v c #B4B797\", +\"w c #B3B596\", +\"x c #B1B495\", +\"y c #B0B293\", +\"z c #AEB192\", +\"A c #ADAF91\", +\"B c #ABAE8F\", +\"C c #9C9E82\", +\"D c #C9CCA8\", +\"E c #C6C9A6\", +\"F c #C4C7A5\", +\"G c #C1C4A2\", +\"H c #BFC2A1\", +\"I c #BEC19F\", +\"J c #BCBF9E\", +\"K c #BABD9C\", +\"L c #B7BA9A\", +\"M c #B6B998\", +\"N c #ABAE90\", +\"O c #AAAD8E\", +\"P c #9A9D81\", +\"Q c #C2C4A2\", +\"R c #BFC1A0\", +\"S c #BDC09F\", +\"T c #BCBE9D\", +\"U c #B9BB9B\", +\"V c #B7BA99\", +\"W c #B6B898\", +\"X c #B1B494\", +\"Y c #A9AB8D\", +\"Z c #999C80\", +\"` c #C1C3A2\", +\" . c #BFC2A0\", +\".. c #B9BC9C\", +\"+. c #B8BB9A\", +\"@. c #B7B999\", +\"#. c #B5B898\", +\"$. c #B4B697\", +\"%. c #B2B596\", +\"&. c #AAAD8F\", +\"*. c #A7AA8C\", +\"=. c #989B80\", +\"-. c #BDC09E\", +\";. c #B3B696\", +\">. c #B2B595\", +\",. c #B1B394\", +\"'. c #AFB293\", +\"). c #A6A98B\", +\"!. c #97997F\", +\"~. c #A7A98C\", +\"{. c #A6A88B\", +\"]. c #A4A78A\", +\"^. c #A3A689\", +\"/. c #A2A588\", +\"(. c #A1A487\", +\"_. c #A0A286\", +\":. c #9FA185\", +\"<. c #9EA084\", +\"[. c #9D9F83\", +\"}. c #9B9E82\", +\"|. c #999B80\", +\"1. c #989A7F\", +\"2. c #97997E\", +\"3. c #96987D\", +\"4. c #95977D\", +\"5. c #94967C\", +\"6. c #92957B\", +\"7. c #91947A\", +\"8. c #909279\", +\"9. c #85876F\", +\" \", +\" . . . . . . . . . . . . . . . . . . . . . . \", +\". + + + + + + + + + + + + + + + + + @ # $ % & . \", +\". + + + + + + + + + + + + + + + + * = - ; > , . \", +\". + + + + + + + + + + + + + + + + ' # $ ) ! ~ . \", +\". + + + + + + + + + + + + + + + @ { ] % ^ / ( . \", +\". + + + + + + + + + + + + + + * = - ; > ! _ : . \", +\". + + + + + + + + + + + + + + ' # $ ) / < [ } . \", +\". + + + + + + + + + + + + + @ { ] % ^ < [ | 1 . \", +\". + + + + + + + + + + + + @ { ] ; > / _ 2 3 4 . \", +\". + + + + + + + + + + + * = - ; > ! < 2 5 6 7 . \", +\". + + + + + + + + + + * = - $ ) ! < [ 5 6 8 9 . \", +\". + + + + + + + + + * = - $ ) ^ < [ | 3 8 0 a . \", +\". + + + + + + + + @ = - $ ) ^ / [ | 3 b c d e . \", +\". + + + + + + + @ { - $ ) ^ / [ | 3 b c d f g . \", +\". . . . . . . . . . . . . . . . . . . . . . . . \", +\". h i j k l m n o p q r s t u v w x y z A B C . \", +\". D k E F n G H I J K s L M v w x y z A N O P . \", +\". E F m Q o R S T K U V W v w X y z A N O Y Z . \", +\". m n ` .I J r ..+.@.#.$.%.X y z A N &.Y *.=.. \", +\". G H p -.T K s t u #.;.>.,.'.z A N O Y *.).!.. \", +\". ~.{.].^./.(._.:.<.[.}.P |.1.2.3.4.5.6.7.8.9.. \", +\" . . . . . . . . . . . . . . . . . . . . . . \", +\" \"}; +" + "XPM format image used as bottom view window icon") + +(defconst ide-skel-bottom-view-window-image + (create-image ide-skel-bottom-view-window-xpm 'xpm t)) + +(defvar ide-skel-win--win2-switch t) + +(defvar ide-skel-win--minibuffer-selected-p nil) + +;; (copy-win-node w) +;; (win-node-corner-pos w) +;; (make-win-node :corner-pos 0 :buffer b :horiz-scroll 0 :point 0 :mark nil :divisions nil) +;; (win-node-p w) +(defstruct win-node + "Window configuration tree node." + (corner-pos nil) ; pair - original position of left top window corner + (buf-corner-pos 1) ; position within the buffer at the upper left of the window + buffer ; the buffer window displays + (horiz-scroll 0) ; amount of horizontal scrolling, in columns + (point 1) ; point + (mark nil) ; the mark + (edges nil) ; (window-edges) + (cursor-priority nil) + (fixed-size nil) + (divisions nil)) ; children (list of division) + +(defstruct division + "Podzial okienka" + win-node ; winnode for window after division + horizontal-p ; division horizontal or vertical + percent) ; 0.0-1.0: width/height of parent after division + +(defvar sel-window nil) +(defvar sel-priority nil) + +(defvar ide-skel-ommited-windows nil) + +(defvar ide-skel--fixed-size-windows nil) + +;; args: 'left/right 'show/editor-buffer-changed/hide/tab-change &rest buffer... +(defvar ide-skel-side-view-window-functions nil) + +(defvar ide-skel-editor-buffer-changed-hook nil) + +(defvar ide-skel-last-buffer-change-event nil) +(defvar ide-skel-last-selected-window-or-buffer nil) + +(defcustom ide-skel-bottom-view-window-size 0.35 + "Default bottom view window height in characters (int >= 5) or percent of Emacs frame height (0.0 - 1.0)" + :group 'ide-skel + :tag "Default Bottom View Window Height" + :type (list 'restricted-sexp + :match-alternatives (list (lambda (value) + (or (and (floatp value) + (> value 0.0) + (< value 1.0)) + (and (integerp value) + (>= value 5))))))) + +(defcustom ide-skel-bottom-view-on-left-view t + "Non-nil if bottom view lies partially on left view." + :group 'ide-skel + :tag "Bottom View on Left View" + :type '(boolean) + :initialize 'custom-initialize-default + :set (lambda (symbol value) + (let ((is-bottom-view-window (ide-skel-get-bottom-view-window))) + (when is-bottom-view-window + (ide-skel-hide-bottom-view-window)) + (unwind-protect + (set-default symbol value) + (when is-bottom-view-window + (ide-skel-show-bottom-view-window)))))) + +(defcustom ide-skel-bottom-view-on-right-view t + "Non-nil if bottom view lies partially on right view." + :group 'ide-skel + :tag "Bottom View on Right View" + :type '(boolean) + :initialize 'custom-initialize-default + :set (lambda (symbol value) + (let ((is-bottom-view-window (ide-skel-get-bottom-view-window))) + (when is-bottom-view-window + (ide-skel-hide-bottom-view-window)) + (unwind-protect + (set-default symbol value) + (when is-bottom-view-window + (ide-skel-show-bottom-view-window)))))) + +(defconst ide-skel-unexpected-bottom-view-window-buffer-names '("*Completions*" "*Compile-Log*")) + +(defvar ide-skel--last-bottom-view-buffer-name nil) + +(defvar ide-skel-was-scratch nil) + +(defvar ide-skel-bottom-view-window-oper-in-progress nil) + +(defvar ide-skel--current-side-windows (cons nil nil)) + +(defcustom ide-skel-left-view-window-width 25 + "Default width of left view window." + :group 'ide-skel + :tag "Default Left View Window Width" + :type '(integer) + :initialize 'custom-initialize-default + :set (lambda (symbol value) + (let ((is-left-view-window (ide-skel-get-left-view-window))) + (when is-left-view-window + (ide-skel-hide-left-view-window)) + (unwind-protect + (set-default symbol value) + (when is-left-view-window + (ide-skel-show-left-view-window)))))) + +(defcustom ide-skel-right-view-window-width 30 + "Default width of right view window." + :group 'ide-skel + :tag "Default Right View Window Width" + :type '(integer) + :initialize 'custom-initialize-default + :set (lambda (symbol value) + (let ((is-right-view-window (ide-skel-get-right-view-window))) + (when is-right-view-window + (ide-skel-hide-right-view-window)) + (unwind-protect + (set-default symbol value) + (when is-right-view-window + (ide-skel-show-right-view-window)))))) + +(defcustom ide-skel-side-view-display-cursor nil + "Non-nil if cursor should be displayed in side view windows" + :group 'ide-skel + :tag "Side View Display Cursor" + :type 'boolean) + +(defvar ide-skel-highlight-face 'ide-skel-highlight-face) +(defface ide-skel-highlight-face + (list + (list '((background light)) + (append (list :inherit 'variable-pitch :background (ide-skel-shine-color (face-background 'default) -70) :foreground (face-background 'default)) + (when (>= emacs-major-version 22) '(:box (:style released-button))))) + (list '((background dark)) + (append (list :inherit 'variable-pitch :background (ide-skel-shine-color (face-background 'default) +70) :foreground (face-background 'default)) + (when (>= emacs-major-version 22) '(:box (:style released-button))))) + '(t (:inherit default))) + "Face for selection in side views." + :group 'ide-skel) + +;;; buffer -> alist +;;; :imenu-buffer +;;; :default-left-tab-label, :default-right-tab-label +(defvar ide-skel-context-properties (make-hash-table :test 'eq)) + +(defvar ide-skel-last-left-view-window-tab-label nil) +(defvar ide-skel-last-right-view-window-tab-label nil) + +(defvar ide-skel-buffer-list-buffer nil) +(defvar ide-skel-buffer-list nil) + +(defvar ide-skel-buffer-list-tick nil) + +(defconst ide-skel-tree-widget-open-xpm "\ +/* XPM */ +static char *open[] = { +/* columns rows colors chars-per-pixel */ +\"11 15 49 1\", +\" c #4D084D080B7B\", +\". c #5A705A700DBB\", +\"X c #7B647B6404B5\", +\"o c #7818781810F1\", +\"O c #7E1E7E1E16D4\", +\"+ c #5EB75D2D6FCF\", +\"@ c #5FD85D2D6FCF\", +\"# c #60415D2D6FCF\", +\"$ c #88BD88BD068F\", +\"% c #8A5D8A5D0969\", +\"& c #82F782F71033\", +\"* c #841B841B1157\", +\"= c #87BC87BC1125\", +\"- c #878787871696\", +\"; c #87D587BE172E\", +\": c #87C187C11812\", +\"> c #895A895A1B9C\", +\", c #8A0A8A0A1C10\", +\"< c #8E5B8DF21DE7\", +\"1 c #95DF95DF1A5F\", +\"2 c #95CC95CC1B5B\", +\"3 c #98D498D41EE5\", +\"4 c #9BBB9BBB2414\", +\"5 c #9BBB9BBB2622\", +\"6 c #9CDF9CDF2696\", +\"7 c #984C984C281C\", +\"8 c #9EA19EA129C1\", +\"9 c #A060A0602B4B\", +\"0 c #A3BAA3BA3148\", +\"q c #A78AA78A36FD\", +\"w c #A7BBA7BB38D9\", +\"e c #A7B7A7B73B03\", +\"r c #AB1AAB1A3B03\", +\"t c #ABD7ABD73C6C\", +\"y c #AFC5AFC54435\", +\"u c #B5D2B5D24A67\", +\"i c #B659B6594AEE\", +\"p c #B959B9595378\", +\"a c #BBCEBBCE5267\", +\"s c #BE64BE645A53\", +\"d c #C2D2C2D26078\", +\"f c #C43BC43B60D8\", +\"g c #C42EC42E60EE\", +\"h c #C44FC44F60EC\", +\"j c #C73BC73B66E7\", +\"k c #C65DC65D697B\", +\"l c #CECECECE7676\", +\"z c #D02CD02C7B7B\", +\"x c None\", +/* pixels */ +\"xxxxxxxxxxx\", +\"xxxxxxxxxxx\", +\"xxxxxxxxxxx\", +\"xxxxxxxxxxx\", +\"x,> xxxxxxx\", +\"6zlpw07xxxx\", +\"5k32211=oxx\", +\"49ryuasfexx\", +\"$8yuasgdOxx\", +\"%qiashjtxxx\", +\"X&*<;-:.xxx\", +\"xxx@xxxxxxx\", +\"xxx#xxxxxxx\", +\"xxx+xxxxxxx\", +\"xxx+xxxxxxx\" +}; +") + +(defconst ide-skel-tree-widget-open-image + (create-image ide-skel-tree-widget-open-xpm 'xpm t)) + +(defconst ide-skel-tree-widget-no-handle-xpm "\ +/* XPM */ +static char *no_handle[] = { +/* columns rows colors chars-per-pixel */ +\"7 15 1 1\", +\" c None\", +/* pixels */ +\" \", +\" \", +\" \", +\" \", +\" \", +\" \", +\" \", +\" \", +\" \", +\" \", +\" \", +\" \", +\" \", +\" \", +\" \" +}; +") + +(defconst ide-skel-tree-widget-no-handle-image + (create-image ide-skel-tree-widget-no-handle-xpm 'xpm t)) + +(defconst ide-skel-tree-widget-no-guide-xpm "\ +/* XPM */ +static char *no_guide[] = { +/* columns rows colors chars-per-pixel */ +\"4 15 1 1\", +\" c None\", +/* pixels */ +\" \", +\" \", +\" \", +\" \", +\" \", +\" \", +\" \", +\" \", +\" \", +\" \", +\" \", +\" \", +\" \", +\" \", +\" \" +}; +") + +(defconst ide-skel-tree-widget-no-guide-image + (create-image ide-skel-tree-widget-no-guide-xpm 'xpm t)) + +(defconst ide-skel-tree-widget-leaf-xpm "\ +/* XPM */ +static char *leaf[] = { +/* columns rows colors chars-per-pixel */ +\"11 15 42 1\", +\" c #224222422242\", +\". c #254525452545\", +\"X c #272727272727\", +\"o c #31DA31DA31DA\", +\"O c #4CAC4CAC4CAC\", +\"+ c #4F064F064F06\", +\"@ c #506050605060\", +\"# c #511651165116\", +\"$ c #57D657D657D6\", +\"% c #59A559A559A5\", +\"& c #5AAC5AAC5AAC\", +\"* c #5D5A5D5A5D5A\", +\"= c #5F025F025F02\", +\"- c #60C660C660C6\", +\"; c #617D617D617D\", +\": c #63D363D363D3\", +\"> c #8B908B908B90\", +\", c #8E3C8E3C8E3C\", +\"< c #8F588F588F58\", +\"1 c #93FC93FC93FC\", +\"2 c #949194919491\", +\"3 c #96AD96AD96AD\", +\"4 c #991899189918\", +\"5 c #99EA99EA99EA\", +\"6 c #9B619B619B61\", +\"7 c #9CD69CD69CD6\", +\"8 c #9E769E769E76\", +\"9 c #9FA59FA59FA5\", +\"0 c #A0C3A0C3A0C3\", +\"q c #A293A293A293\", +\"w c #A32EA32EA32E\", +\"e c #A480A480A480\", +\"r c #A5A5A5A5A5A5\", +\"t c #A755A755A755\", +\"y c #AA39AA39AA39\", +\"u c #AC77AC77AC77\", +\"i c #B1B7B1B7B1B7\", +\"p c #B283B283B283\", +\"a c #B7B7B7B7B7B7\", +\"s c #BD02BD02BD02\", +\"d c gray74\", +\"f c None\", +/* pixels */ +\"fffffffffff\", +\"fffffffffff\", +\"fffffffffff\", +\"XXXXfffffff\", +\"%,25#offfff\", +\"*6qr$&.ffff\", +\"=1<3>wOffff\", +\";6648a@ffff\", +\";wweys#ffff\", +\":970ed#ffff\", +\"-tuipp+ffff\", +\"XXXXXX ffff\", +\"fffffffffff\", +\"fffffffffff\", +\"fffffffffff\" +}; +") + +(defconst ide-skel-tree-widget-leaf-image + (create-image ide-skel-tree-widget-leaf-xpm 'xpm t)) + +(defconst ide-skel-tree-widget-handle-xpm "\ +/* XPM */ +static char *handle[] = { +/* columns rows colors chars-per-pixel */ +\"7 15 2 1\", +\" c #56D752D36363\", +\". c None\", +/* pixels */ +\".......\", +\".......\", +\".......\", +\".......\", +\".......\", +\".......\", +\".......\", +\" \", +\".......\", +\".......\", +\".......\", +\".......\", +\".......\", +\".......\", +\".......\" +}; +") + +(defconst ide-skel-tree-widget-handle-image + (create-image ide-skel-tree-widget-handle-xpm 'xpm t)) + +(defconst ide-skel-tree-widget-guide-xpm "\ +/* XPM */ +static char *guide[] = { +/* columns rows colors chars-per-pixel */ +\"4 15 2 1\", +\" c #73C96E6E8484\", +\". c None\", +/* pixels */ +\"... \", +\"... \", +\"... \", +\"... \", +\"... \", +\"... \", +\"... \", +\"... \", +\"... \", +\"... \", +\"... \", +\"... \", +\"... \", +\"... \", +\"... \" +}; +") + +(defconst ide-skel-tree-widget-guide-image + (create-image ide-skel-tree-widget-guide-xpm 'xpm t)) + +(defconst ide-skel-tree-widget-end-guide-xpm "\ +/* XPM */ +static char *end_guide[] = { +/* columns rows colors chars-per-pixel */ +\"4 15 2 1\", +\" c #73C96E6E8484\", +\". c None\", +/* pixels */ +\"... \", +\"... \", +\"... \", +\"... \", +\"... \", +\"... \", +\"... \", +\"... \", +\"....\", +\"....\", +\"....\", +\"....\", +\"....\", +\"....\", +\"....\" +}; +") + +(defconst ide-skel-tree-widget-end-guide-image + (create-image ide-skel-tree-widget-end-guide-xpm 'xpm t)) + +(defconst ide-skel-tree-widget-empty-xpm "\ +/* XPM */ +static char *empty[] = { +/* columns rows colors chars-per-pixel */ +\"11 15 39 1\", +\" c #2BCF2BCF2BCF\", +\". c #31F831F831F8\", +\"X c #3F283F283F28\", +\"o c #41B141B141B1\", +\"O c #467946794679\", +\"+ c #476747674767\", +\"@ c #484648464846\", +\"# c #498749874987\", +\"$ c #4B684B684B68\", +\"% c #524F524F524F\", +\"& c #52D352D352D3\", +\"* c #554155415541\", +\"= c #561C561C561C\", +\"- c #598659865986\", +\"; c #5D775D775D77\", +\": c #5E7E5E7E5E7E\", +\"> c #60CE60CE60CE\", +\", c #615161516151\", +\"< c #61F361F361F3\", +\"1 c #642464246424\", +\"2 c #654865486548\", +\"3 c #678767876787\", +\"4 c #68D868D868D8\", +\"5 c #699569956995\", +\"6 c #6D556D556D55\", +\"7 c #6FB56FB56FB5\", +\"8 c #72CF72CF72CF\", +\"9 c #731073107310\", +\"0 c #757775777577\", +\"q c #7B747B747B74\", +\"w c #809080908090\", +\"e c #81F281F281F2\", +\"r c #820D820D820D\", +\"t c #84F984F984F9\", +\"y c #858285828582\", +\"u c #95E295E295E2\", +\"i c #9FFF9FFF9FFF\", +\"p c #A5A5A5A5A5A5\", +\"a c None\", +/* pixels */ +\"aaaaaaaaaaa\", +\"aaaaaaaaaaa\", +\"aaaaaaaaaaa\", +\"aaaaaaaaaaa\", +\"a&% aaaaaaa\", +\",piy76<aaaa\", +\">u-===*#oaa\", +\":14690qe3aa\", +\"+;680qewOaa\", +\"@290qrt5aaa\", +\"XO+@#$$.aaa\", +\"aaaaaaaaaaa\", +\"aaaaaaaaaaa\", +\"aaaaaaaaaaa\", +\"aaaaaaaaaaa\" +}; +") + +(defconst ide-skel-tree-widget-empty-image + (create-image ide-skel-tree-widget-empty-xpm 'xpm t)) + +(defconst ide-skel-tree-widget-close-xpm "\ +/* XPM */ +static char *close[] = { +/* columns rows colors chars-per-pixel */ +\"11 15 45 1\", +\" c #4EA14EA10DFA\", +\". c #5AA05AA00C52\", +\"X c #75297529068F\", +\"o c #7B647B6404B5\", +\"O c #8B888B880B91\", +\"+ c #8EDE8EDE0F5F\", +\"@ c #82F782F71033\", +\"# c #83A683A61157\", +\"$ c #84AD84AD13BC\", +\"% c #857985791489\", +\"& c #868086801590\", +\"* c #8A8A8A8A1697\", +\"= c #878787871812\", +\"- c #885388531936\", +\"; c #8BAB8BAB17B8\", +\": c #8CCC8CCC1A7D\", +\"> c #8DB68DB61BC4\", +\", c #90EC90EC11D0\", +\"< c #9161916114B5\", +\"1 c #92A292A2163F\", +\"2 c #8E8B8E8B2150\", +\"3 c #8F0F8F0F2274\", +\"4 c #9AF79AF72386\", +\"5 c #9D289D282655\", +\"6 c #9ED19ED1286E\", +\"7 c #9F599F592912\", +\"8 c #A31DA31D2D82\", +\"9 c #A3DDA3DD2DA2\", +\"0 c #A144A1442ED2\", +\"q c #A828A82833B4\", +\"w c #AB38AB383AEB\", +\"e c #AD21AD213DC2\", +\"r c #AD6DAD6D3E56\", +\"t c #AFFCAFFC4481\", +\"y c #B0AAB0AA429F\", +\"u c #B1B1B1B144E8\", +\"i c #B51DB51D4A5F\", +\"p c #B535B5354A8A\", +\"a c #B56FB56F4AEE\", +\"s c #B7B0B7B0525B\", +\"d c #BD14BD1459B1\", +\"f c #BFACBFAC5C55\", +\"g c #C5D9C5D965F7\", +\"h c #C85FC85F6D04\", +\"j c None\", +/* pixels */ +\"jjjjjjjjjjj\", +\"jjjjjjjjjjj\", +\"jjjjjjjjjjj\", +\"jjjjjjjjjjj\", +\"j32 jjjjjjj\", +\"1uy84570.jj\", +\"O69wtpsd*jj\", +\"+qrtpsdf;jj\", +\",etisdfg:jj\", +\"<tasdfgh>jj\", +\"o@#$%&=-Xjj\", +\"jjjjjjjjjjj\", +\"jjjjjjjjjjj\", +\"jjjjjjjjjjj\", +\"jjjjjjjjjjj\" +}; +") + +(defconst ide-skel-tree-widget-close-image + (create-image ide-skel-tree-widget-close-xpm 'xpm t)) + +(define-widget 'ide-skel-imenu-internal-node-widget 'tree-widget + "Internal node widget.") + +(define-widget 'ide-skel-imenu-leaf-widget 'push-button + "Leaf widget." + :format "%[%t%]\n" + :button-face 'variable-pitch + ) + +(defvar ide-skel-imenu-sorted nil) +(make-variable-buffer-local 'ide-skel-imenu-sorted) + +(defvar ide-skel-imenu-editor-buffer nil) +(make-variable-buffer-local 'ide-skel-imenu-editor-buffer) + +(defvar ide-skel-imenu-open-paths nil) +(make-variable-buffer-local 'ide-skel-imenu-open-paths) + +(defface imenu-side-view-face '((t :inherit variable-pitch :height 0.8)) + "Default face used in right view for imenu" + :group 'ide-skel) + +(define-widget 'ide-skel-info-tree-dir-widget 'tree-widget + "Directory Tree widget." + :expander 'ide-skel-info-tree-expand-dir + :notify 'ide-skel-info-open + :indent 0) + +(define-widget 'ide-skel-info-tree-file-widget 'push-button + "File widget." + :format "%[%t%]%d\n" + :button-face 'variable-pitch + :notify 'ide-skel-info-file-open) + +(defvar ide-skel-info-open-paths nil) +(make-variable-buffer-local 'ide-skel-info-open-paths) + +(defvar ide-skel-info-root-node nil) +(make-variable-buffer-local 'ide-skel-info-root-node) + +(defvar ide-skel-info-buffer nil) + +(define-widget 'ide-skel-dir-tree-dir-widget 'tree-widget + "Directory Tree widget." + :expander 'ide-skel-dir-tree-expand-dir + :notify 'ide-skel-dir-open + :indent 0) + +(define-widget 'ide-skel-dir-tree-file-widget 'push-button + "File widget." + :format "%[%t%]%d\n" + :button-face 'variable-pitch + :notify 'ide-skel-file-open) + +(defvar ide-skel-dir-open-paths nil) +(make-variable-buffer-local 'ide-skel-dir-open-paths) + +(defvar ide-skel-dir-root-dir "/") +(make-variable-buffer-local 'ide-skel-dir-root-dir) + +(defvar ide-skel-dir-buffer nil) + +(defconst ide-skel-cvs-dir-regexp "\\(\\.svn\\|CVS\\)$") + +(defstruct ide-skel-project + root-path + include-file-path ; for PC-include-file-path variable +) + +(defvar ide-skel-projects nil) + +(defvar ide-skel-proj-find-results-buffer-name "*Proj find*") + +(defvar ide-skel-project-menu + '("Project" + :filter ide-skel-project-menu) + "Menu for CVS/SVN projects") + +(defvar ide-skel-proj-find-project-files-history nil) +(defvar ide-skel-proj-grep-project-files-history nil) + +(defvar ide-skel-proj-ignored-extensions '("semantic.cache")) + +(defvar ide-skel-all-text-files-flag nil) + +(defvar ide-skel-proj-grep-header nil) + +(defvar ide-skel-proj-old-compilation-exit-message-function nil) +(make-variable-buffer-local 'ide-skel-proj-old-compilation-exit-message-function) + +(defvar ide-skel-proj-grep-mode-map nil) + +(defvar ide-skel-proj-grep-replace-history nil) + +;;; + +(copy-face 'mode-line 'mode-line-inactive) + +(define-key tree-widget-button-keymap [drag-mouse-1] 'ignore) + +(defun ide-skel-tabbar-tab-label (tab) + "Return a label for TAB. +That is, a string used to represent it on the tab bar." + (let* ((object (tabbar-tab-value tab)) + (tabset (tabbar-tab-tabset tab)) + (label (format " %s " + (or (and (bufferp object) + (with-current-buffer object ide-skel-tabbar-tab-label)) ; local in buffer + object)))) + (when (and (not (memq tabset (list (tabbar-get-tabset ide-skel-left-view-window-tabset-name) + (tabbar-get-tabset ide-skel-right-view-window-tabset-name)))) + (numberp ide-skel-tabbar-tab-label-max-width) + (> ide-skel-tabbar-tab-label-max-width 0)) + (setq label (tabbar-shorten label ide-skel-tabbar-tab-label-max-width))) + label)) + +(defun ide-skel-tabbar-help-on-tab (tab) + "Return the help string shown when mouse is onto TAB." + (let ((tabset (tabbar-tab-tabset tab)) + (object (tabbar-tab-value tab))) + (or (when (bufferp object) + (with-current-buffer object + (or ide-skel-tabbar-tab-help-string ; local in buffer + (buffer-file-name)))) + "mouse-1: switch to buffer\nmouse-2: delete other windows\nmouse-3: kill buffer"))) + +(defun ide-skel-tabbar-buffer-groups () + "Return the list of group names the current buffer belongs to." + (if (and (ide-skel-side-view-buffer-p (current-buffer)) + (or (not ide-skel-tabbar-tab-label) + (not ide-skel-tabbar-enabled))) + nil + (let ((result (list (or ide-skel-tabset-name ; local in current buffer + (when (ide-skel-bottom-view-buffer-p (current-buffer)) ide-skel-bottom-view-window-tabset-name) + ide-skel-editor-window-tabset-name)))) + (dolist (window (copy-list (window-list nil 1))) + (when (eq (window-buffer window) (current-buffer)) + (let ((tabset-name (ide-skel-get-tabset-name-for-window window))) + (unless (member tabset-name result) + (push tabset-name result))))) + result))) + +(defun ide-skel-tabbar-buffer-tabs () + "Return the buffers to display on the tab bar, in a tab set." + ;; (message "ide-skel-tabbar-buffer-tabs %S" (current-buffer)) + (tabbar-buffer-update-groups) + (let* ((window (selected-window)) + (tabset (tabbar-get-tabset (ide-skel-get-tabset-name-for-window window)))) + (when (not (tabbar-get-tab (current-buffer) tabset)) + (tabbar-add-tab tabset (current-buffer) t)) + (tabbar-select-tab-value (current-buffer) tabset) + tabset)) + +(defun ide-skel-tabbar-buffer-list () + "Return the list of buffers to show in tabs. +The current buffer is always included." + (ide-skel-tabbar-faces-adapt) + (delq t + (mapcar #'(lambda (b) + (let ((buffer-name (buffer-name b))) + (cond + ((and (ide-skel-side-view-buffer-p b) + (with-current-buffer b + (or (not ide-skel-tabbar-tab-label) + (not ide-skel-tabbar-enabled)))) + t) + ;; Always include the current buffer. + ((eq (current-buffer) b) b) + ;; accept if buffer has tabset name + ((with-current-buffer b ide-skel-tabset-name) b) + ;; remove if matches any regexp from ide-skel-tabbar-hidden-buffer-names-regexp-list + ((not (null (some (lambda (regexp) + (string-match regexp buffer-name)) + ide-skel-tabbar-hidden-buffer-names-regexp-list))) + t) + ;; accept if buffer has filename + ((buffer-file-name b) b) + ;; remove if name starts with space + ((and (char-equal ?\ (aref (buffer-name b) 0)) + (not (ide-skel-side-view-buffer-p b))) + t) + ;; accept otherwise + (b)))) + (buffer-list (selected-frame))))) + +(defun ide-skel-get-tabset-name-for-window (window) + (cond ((eq (ide-skel-get-left-view-window) window) ide-skel-left-view-window-tabset-name) + ((eq (ide-skel-get-right-view-window) window) ide-skel-right-view-window-tabset-name) + ((eq (ide-skel-get-bottom-view-window) window) ide-skel-bottom-view-window-tabset-name) + (t ide-skel-editor-window-tabset-name))) + +(defun ide-skel-tabbar-select-tab (event tab) + "On mouse EVENT, select TAB." + (let* ((mouse-button (event-basic-type event)) + (buffer (tabbar-tab-value tab)) + (tabset-name (and (buffer-live-p buffer) + (with-current-buffer buffer ide-skel-tabset-name))) + (left-tabset (equal tabset-name ide-skel-left-view-window-tabset-name)) + (right-tabset (equal tabset-name ide-skel-right-view-window-tabset-name))) + (cond + ((eq mouse-button 'mouse-1) + (cond (left-tabset (ide-skel-side-window-switch-to-buffer ide-skel-current-left-view-window buffer)) + (right-tabset (ide-skel-side-window-switch-to-buffer ide-skel-current-right-view-window buffer)) + (t (switch-to-buffer buffer)))) + ((and (eq mouse-button 'mouse-2) + (not left-tabset) + (not right-tabset)) + (switch-to-buffer buffer) + (delete-other-windows)) + ((and (eq mouse-button 'mouse-3) + (not left-tabset) + (not right-tabset)) + (kill-buffer buffer))) + ;; Disable group mode. + (set 'tabbar-buffer-group-mode nil))) + +(defun ide-skel-tabbar-buffer-kill-buffer-hook () + "Hook run just before actually killing a buffer. +In Tabbar mode, try to switch to a buffer in the current tab bar, +after the current buffer has been killed. Try first the buffer in tab +after the current one, then the buffer in tab before. On success, put +the sibling buffer in front of the buffer list, so it will be selected +first." + (let ((buffer-to-kill (current-buffer))) + (save-selected-window + (save-current-buffer + ;; cannot kill buffer from any side view window + (when (and (eq header-line-format tabbar-header-line-format) + (not (ide-skel-side-view-buffer-p (current-buffer)))) + (dolist (window (copy-list (window-list nil 1))) + (when (eq buffer-to-kill (window-buffer window)) + (select-window window) + (let ((bl (tabbar-tab-values (funcall tabbar-current-tabset-function))) + found sibling) + (while (and bl (not found)) + (if (equal buffer-to-kill (car bl)) + (setq found t) + (setq sibling (car bl))) + (setq bl (cdr bl))) + (setq sibling (or sibling (car bl))) + (if (and sibling + (not (eq sibling buffer-to-kill)) + (buffer-live-p sibling)) + ;; Move sibling buffer in front of the buffer list. + (switch-to-buffer sibling) + (let ((next-buffer (ide-skel--find-buffer-for-bottom-view-window))) + (when (eq next-buffer buffer-to-kill) + (setq next-buffer (some (lambda (buf) + (if (or (eq buf buffer-to-kill) + (ide-skel-side-view-buffer-p buf) + (ide-skel-hidden-buffer-name-p (buffer-name buf))) + nil + buf)) + (buffer-list (selected-frame))))) + (when next-buffer + (switch-to-buffer next-buffer) + (tabbar-current-tabset t)))))))))))) + +(defun ide-skel-tabbar-inhibit-function () + "Inhibit display of the tab bar in specified windows, that is +in `checkdoc' status windows and in windows with its own header +line." + (let ((result (tabbar-default-inhibit-function)) + (sw (selected-window))) + (when (and result + (ide-skel-side-view-window-p sw)) + (setq result nil)) + (when (not (eq header-line-format tabbar-header-line-format)) + (setq result t)) + result)) + +(defun ide-skel-tabbar-home-function (event) + (let* ((window (posn-window (event-start event))) + (is-view-window (ide-skel-side-view-window-p window)) + (buffer (window-buffer window)) + extra-commands + (normal-window-counter 0)) + (dolist (win (copy-list (window-list nil 1))) + (unless (ide-skel-side-view-window-p win) + (incf normal-window-counter))) + (with-selected-window window + (when (and is-view-window + ide-skel-tabbar-menu-function) + (setq extra-commands (funcall ide-skel-tabbar-menu-function))) + (let ((close-p (when (or is-view-window + (> normal-window-counter 1)) + (list '(close "Close" t)))) + (maximize-p (when (and (not is-view-window) + (> normal-window-counter 1)) + (list '(maximize "Maximize" t))))) + (when (or close-p maximize-p) + (let ((user-selection + (car (x-popup-menu event (append (list 'keymap) close-p maximize-p extra-commands))))) + (cond ((eq user-selection 'close) + (call-interactively 'delete-window)) + ((eq user-selection 'maximize) + (delete-other-windows window)) + ((eq user-selection nil)) + (t + (funcall user-selection))))))))) + +(defun ide-skel-tabbar-mwheel-scroll-forward (event) + (interactive "@e") + (tabbar-press-scroll-left)) + +(defun ide-skel-tabbar-mwheel-scroll-backward (event) + (interactive "@e") + (tabbar-press-scroll-right)) + +(defun ide-skel-tabbar-mwheel-scroll (event) + "Select the next or previous group of tabs according to EVENT." + (interactive "@e") + (if (tabbar--mwheel-up-p event) + (ide-skel-tabbar-mwheel-scroll-forward event) + (ide-skel-tabbar-mwheel-scroll-backward event))) + +(defun ide-skel-tabbar-mwhell-mode-hook () + (setq tabbar-mwheel-mode-map + (let ((km (make-sparse-keymap))) + (if (get 'mouse-wheel 'event-symbol-elements) + ;; Use one generic mouse wheel event + (define-key km [A-mouse-wheel] + 'ide-skel-tabbar-mwheel-scroll) + ;; Use separate up/down mouse wheel events + (let ((up (tabbar--mwheel-key tabbar--mwheel-up-event)) + (down (tabbar--mwheel-key tabbar--mwheel-down-event))) + (define-key km `[header-line ,down] + 'ide-skel-tabbar-mwheel-scroll-backward) + (define-key km `[header-line ,up] + 'ide-skel-tabbar-mwheel-scroll-forward) + )) + km)) + (setcdr (assoc 'tabbar-mwheel-mode minor-mode-map-alist) tabbar-mwheel-mode-map)) + +(defun ide-skel-tabbar-mode-hook () + (setq tabbar-prefix-map + (let ((km (make-sparse-keymap))) + (define-key km [(control home)] 'tabbar-press-home) + (define-key km [(control left)] 'tabbar-backward) + (define-key km [(control right)] 'tabbar-forward) + (define-key km [(control prior)] 'tabbar-press-scroll-left) + (define-key km [(control next)] 'tabbar-press-scroll-right) + km)) + (setq tabbar-mode-map + (let ((km (make-sparse-keymap))) + (define-key km tabbar-prefix-key tabbar-prefix-map) + km)) + (setcdr (assoc 'tabbar-mode minor-mode-map-alist) tabbar-mode-map)) + +(defun ide-skel-tabbar-init-hook () + (setq tabbar-cycle-scope 'tabs + tabbar-auto-scroll-flag nil) + (setq + tabbar-tab-label-function 'ide-skel-tabbar-tab-label + tabbar-help-on-tab-function 'ide-skel-tabbar-help-on-tab + tabbar-buffer-groups-function 'ide-skel-tabbar-buffer-groups + tabbar-buffer-list-function 'ide-skel-tabbar-buffer-list + tabbar-current-tabset-function 'ide-skel-tabbar-buffer-tabs + tabbar-select-tab-function 'ide-skel-tabbar-select-tab + tabbar-inhibit-functions (append '(ide-skel-tabbar-inhibit-function) + (delq 'tabbar-default-inhibit-function tabbar-inhibit-functions)) + tabbar-home-function 'ide-skel-tabbar-home-function + tabbar-home-help-function (lambda () "Window menu")) + (add-hook 'kill-buffer-hook 'ide-skel-tabbar-buffer-kill-buffer-hook)) + +(defun ide-skel-tabbar-quit-hook () + (setq + tabbar-current-tabset-function nil + tabbar-tab-label-function nil + tabbar-select-tab-function nil + tabbar-help-on-tab-function nil + tabbar-home-function nil + tabbar-home-help-function nil + tabbar-buffer-groups-function nil + tabbar-buffer-list-function nil) + (remove-hook 'kill-buffer-hook 'ide-skel-tabbar-buffer-kill-buffer-hook)) + +(defun ide-skel-tabbar-load-hook () + (add-hook 'tabbar-mode-hook 'ide-skel-tabbar-mode-hook) + (add-hook 'tabbar-mwheel-mode-hook 'ide-skel-tabbar-mwhell-mode-hook) + (add-hook 'tabbar-init-hook 'ide-skel-tabbar-init-hook t) + (add-hook 'tabbar-quit-hook 'ide-skel-tabbar-quit-hook t) + (custom-set-faces + '(tabbar-default ((t (:inherit variable-pitch :background "gray82" :foreground "gray50" :height 0.8)))) + '(tabbar-selected ((t (:inherit tabbar-default :background "white" :foreground "blue" :box (:line-width 1 :color "black"))))) + '(tabbar-separator ((t (:inherit tabbar-default :height 0.2)))) + '(tabbar-highlight ((t ()))) + '(tabbar-button-highlight ((t (:inherit tabbar-button)))) + '(tabbar-unselected ((t (:inherit tabbar-default :background "gray72" :foreground "black" :box (:line-width 1 :color "black")))))) + (ide-skel-tabbar-faces-adapt)) + +(defun ide-skel-tabbar-faces-adapt () + (ide-skel-shine-face-background 'tabbar-default +18) + (set-face-attribute 'tabbar-selected nil :background (face-background 'default)) + (set-face-attribute 'tabbar-selected nil :foreground (face-foreground 'font-lock-function-name-face)) + (set-face-attribute 'tabbar-selected nil :box (list :line-width 1 :color (face-foreground 'default))) + (ide-skel-shine-face-background 'tabbar-unselected +30) + (set-face-attribute 'tabbar-unselected nil :foreground (face-foreground 'default)) + (set-face-attribute 'tabbar-unselected nil :box (list :line-width 1 :color (face-foreground 'default))) + (ide-skel-shine-face-background 'tabbar-button +18) + (ide-skel-shine-face-foreground 'tabbar-button +20)) + +(defun ide-skel-paradox-settings () + ;; hide scroll buttons + (setq tabbar-scroll-left-button (cons (cons "" nil) (cons "" nil)) + tabbar-scroll-right-button (cons (cons "" nil) (cons "" nil)))) + +(ide-skel-paradox-settings) + + +;;; Views + +(defun ide-skel-window-list () + (delq nil + (mapcar (lambda (win) + (unless (memq win ide-skel-ommited-windows) + win)) + (copy-list (window-list nil 1))))) + +(defun ide-skel-next-window (&optional window minibuf all-frames) + (let ((nw (next-window window minibuf all-frames))) + (if (memq nw ide-skel-ommited-windows) + (ide-skel-next-window nw minibuf all-frames) + nw))) + +(defun ide-skel-previous-window (window minibuf all-frames) + (let ((pw (previous-window window minibuf all-frames))) + (if (memq pw ide-skel-ommited-windows) + window + pw))) + +(defun ide-skel-win--absorb-win-node (dest-win-node src-win-node) + (dotimes (index (length src-win-node)) + (setf (elt dest-win-node index) + (elt src-win-node index)))) + +(defun ide-skel-win--create-win-node (object) + (cond ((win-node-p object) (copy-win-node object)) + ((windowp object) + (make-win-node :corner-pos (ide-skel-win-corner object) + :buf-corner-pos (window-start object) + :buffer (window-buffer object) + :horiz-scroll (window-hscroll object) + :point (window-point object) + :mark nil + :edges (window-edges object) + :fixed-size (cdr (assoc (ide-skel-win-corner object) ide-skel--fixed-size-windows)) + :divisions nil)) + (t (error "Argument is not win-not nor window: %S" object)))) + +(defun ide-skel-win--get-corner-pos (object) + (cond ((windowp object) (ide-skel-win-corner object)) + ((win-node-p object) (win-node-corner-pos object)) + ((consp object) object) + (t (error "Invalid arg: %S" object)))) + +(defun ide-skel-win--corner-pos-equal (win-node1 win-node2) + (let ((corner-pos1 (ide-skel-win--get-corner-pos win-node1)) + (corner-pos2 (ide-skel-win--get-corner-pos win-node2))) + (equal corner-pos1 corner-pos2))) + +(defun ide-skel-win--add-division (win-node division &optional at-end-p) + (setf (win-node-divisions win-node) + (if at-end-p + (reverse (cons division (reverse (win-node-divisions win-node)))) + (cons division (win-node-divisions win-node))))) + +(defun ide-skel-win--remove-division (win-node &optional from-end-p) + (let (result) + (if from-end-p + (let ((divs (reverse (win-node-divisions win-node)))) + (setq result (car divs)) + (setf (win-node-divisions win-node) + (reverse (cdr divs)))) + (setq result (car (win-node-divisions win-node))) + (setf (win-node-divisions win-node) (cdr (win-node-divisions win-node)))) + result)) + +(defun ide-skel-win--find-node (root predicate) + "Return node for which predicate returns non-nil." + (when root + (if (funcall predicate root) + root + (some (lambda (division) + (ide-skel-win--find-node (division-win-node division) predicate)) + (win-node-divisions root))))) + +(defun ide-skel-win--find-node-by-corner-pos (root corner-pos) + "Return struct for window with specified corner coordinates." + (setq corner-pos + (cond ((windowp corner-pos) (ide-skel-win-corner corner-pos)) + ((consp corner-pos) corner-pos) + (t (error "arg corner-pos %S is not a pair/window" corner-pos)))) + (ide-skel-win--find-node root + (lambda (win-node) + (equal corner-pos (win-node-corner-pos win-node))))) + +(defun ide-skel-win--get-window-list () + (let* ((start-win (selected-window)) + (cur-win (ide-skel-next-window start-win 1 1)) + (win-list (list start-win))) + (while (not (eq cur-win start-win)) + (setq win-list (cons cur-win win-list)) + (setq cur-win (ide-skel-next-window cur-win 1 1))) + (reverse win-list))) + +(defun ide-skel-win--analysis (&optional window-proc) + ;; (message "ide-skel-win--analysis BEGIN %S" (get-internal-run-time)) + (let ((window-size-fixed nil)) + (setq ide-skel--fixed-size-windows nil) + (dolist (window (copy-list (window-list nil 1))) + (with-selected-window window + (cond ((eq window-size-fixed 'width) + (push (cons (ide-skel-win-corner window) (cons (window-width window) nil)) ide-skel--fixed-size-windows)) + ((eq window-size-fixed 'height) + (push (cons (ide-skel-win-corner window) (cons nil (window-height window))) ide-skel--fixed-size-windows)) + ((not window-size-fixed) + nil) + (t + (push (cons (ide-skel-win-corner window) (cons (window-width window) (window-height window))) ide-skel--fixed-size-windows))))) + (dolist (window (ide-skel-window-list)) + (when (ide-skel-side-view-window-p window) (set-window-dedicated-p window nil))) + (setq ide-skel-win--minibuffer-selected-p (eq (selected-window) (minibuffer-window))) + (when ide-skel-win--minibuffer-selected-p + (select-window (ide-skel-get-editor-window))) + (when (memq (selected-window) ide-skel-ommited-windows) + (select-window (ide-skel-next-window (selected-window) 1 1))) + (let* (leaf-win + (counter 0) + (cursor-alist (mapcar (lambda (win) (prog1 (cons win counter) (incf counter))) (ide-skel-win--get-window-list))) + win-node-set) + (select-window (ide-skel-win-get-upper-left-window)) + (while (setq leaf-win (get-window-with-predicate + (lambda (win) + (if ide-skel-win--win2-switch (ide-skel-win--is-leaf2 win) (ide-skel-win--is-leaf win))) 1 1)) + (let* ((parent-win (ide-skel-previous-window leaf-win 1 1)) + (parent-node (car (member* (ide-skel-win-corner parent-win) win-node-set :test 'ide-skel-win--corner-pos-equal))) + (leaf-node (car (member* (ide-skel-win-corner leaf-win) win-node-set :test 'ide-skel-win--corner-pos-equal)))) + (unless leaf-node + (setq leaf-node (ide-skel-win--create-win-node leaf-win)) + (setf (win-node-cursor-priority leaf-node) (cdr (assq leaf-win cursor-alist))) + (setq win-node-set (adjoin leaf-node win-node-set :test 'ide-skel-win--corner-pos-equal))) + (unless parent-node + (setq parent-node (ide-skel-win--create-win-node parent-win)) + (setf (win-node-cursor-priority parent-node) (cdr (assq parent-win cursor-alist))) + (setq win-node-set (adjoin parent-node win-node-set :test 'ide-skel-win--corner-pos-equal))) + + (let* ((is-horizontal (ide-skel-win--is-adjacent parent-win 'right leaf-win)) + (size (if is-horizontal (window-width parent-win) (window-height parent-win))) + percent) + (setf (win-node-edges leaf-node) (window-edges leaf-win)) + (when window-proc (funcall window-proc parent-win)) + (when window-proc (funcall window-proc leaf-win)) + (delete-window leaf-win) + (when window-proc (funcall window-proc parent-win)) + (setq percent + (/ (float size) (if is-horizontal (window-width parent-win) (window-height parent-win)))) + (ide-skel-win--add-division parent-node + (make-division :win-node leaf-node + :horizontal-p is-horizontal + :percent percent))))) + ;; if there was only one window + (unless win-node-set + (when window-proc (funcall window-proc (selected-window))) + (let ((node (ide-skel-win--create-win-node (selected-window)))) + (setq win-node-set (adjoin node win-node-set + :test 'ide-skel-win--corner-pos-equal)))) + ;; return root node + (let ((root-node (car (member* (ide-skel-win-corner (selected-window)) + win-node-set + :test 'ide-skel-win--corner-pos-equal)))) + (setf (win-node-edges root-node) (window-edges (selected-window))) + ;; (message "ide-skel-win--analysis END %S" (get-internal-run-time)) + root-node)))) + +(defun ide-skel-win-get-upper-left-window () + "Return window in left upper corner" + (let (best-window) + (dolist (win (ide-skel-window-list)) + (if (null best-window) + (setq best-window win) + (let* ((best-window-coords (window-edges best-window)) + (best-window-weight (+ (car best-window-coords) (cadr best-window-coords))) + (win-coords (window-edges win)) + (win-weight (+ (car win-coords) (cadr win-coords)))) + (when (< win-weight best-window-weight) + (setq best-window win))))) + best-window)) + +(defun ide--is-right-window (window) + (let ((bounds (window-edges window)) + (result t)) + (dolist (win (ide-skel-window-list)) + (let ((left-edge-pos (car (window-edges win)))) + (when (>= left-edge-pos (nth 2 bounds)) + (setq result nil)))) + result)) + +(defun ide-skel-get-win-width-delta (window) + (if window-system + (let ((bounds (window-edges window))) + (+ (- (- (nth 2 bounds) (nth 0 bounds)) (window-width window)) + (if (and (not scroll-bar-mode) + (ide--is-right-window window)) + 1 + 0))) + 1)) + +(defun ide-skel-win--split (window horizontal-p percentage) + "Split window and return children." + (let* ((delta (ide-skel-get-win-width-delta window)) + (weight percentage) + (new-size (cond + ((integerp weight) (if (< weight 0) + (if horizontal-p + (+ (window-width window) weight) + (+ (window-height window) weight)) + (if horizontal-p (+ delta weight) weight))) + (t ; float + (when (< weight 0.0) + (setq weight (+ 1.0 weight))) + (if horizontal-p + (round (+ delta (* (window-width window) weight))) + (round (* (window-height window) weight))))))) + (split-window window new-size horizontal-p))) + +(defun ide-skel-win--process-win-node (win win-node &optional window-proc) + (let ((win2 win)) + (set-window-buffer win (win-node-buffer win-node)) + ; (set-window-start win (win-node-buf-corner-pos win-node)) + (set-window-hscroll win (win-node-horiz-scroll win-node)) + (set-window-point win (win-node-point win-node)) + (when window-proc (setq win (funcall window-proc win))) + (dolist (division (win-node-divisions win-node)) + (when (not (null (division-win-node division))) + (let ((child-window (ide-skel-win--split win (division-horizontal-p division) (division-percent division)))) + (when window-proc (setq win (funcall window-proc win))) + (ide-skel-win--process-win-node child-window (division-win-node division) window-proc)))) + (with-selected-window win2 + (let ((fixed-size (win-node-fixed-size win-node)) + (window-size-fixed nil)) + (when fixed-size + (when (car fixed-size) + (enlarge-window (- (car fixed-size) (window-width win2)) t)) + (when (cdr fixed-size) + (enlarge-window (- (cdr fixed-size) (window-height win2)) nil))))) + (when (win-node-cursor-priority win-node) + (unless sel-window + (setq sel-window win + sel-priority (win-node-cursor-priority win-node))) + (when (< (win-node-cursor-priority win-node) sel-priority) + (setq sel-window win + sel-priority (win-node-cursor-priority win-node)))))) + +(defun ide-skel-win--synthesis (window win-node &optional window-proc) + (let ((window-size-fixed nil) + sel-window + sel-priority) + (ide-skel-win--process-win-node window win-node window-proc) + (when sel-window + (select-window sel-window)) + (when ide-skel-win--minibuffer-selected-p + (select-window (minibuffer-window))) + (setq ide-skel-win--minibuffer-selected-p nil) + (dolist (window (ide-skel-window-list)) + (when (ide-skel-side-view-window-p window) (set-window-dedicated-p window t))))) + +(defun ide-skel-win--remove-child (win-node child-win-node) + (if (eq win-node child-win-node) + (let* ((division (ide-skel-win--remove-division win-node t)) + (divisions (win-node-divisions win-node))) + (when division + (ide-skel-win--absorb-win-node win-node (division-win-node division))) + (setf (win-node-divisions win-node) + (append divisions (win-node-divisions win-node)))) + (dolist (division (win-node-divisions win-node)) + (if (and (eq (division-win-node division) child-win-node) (null (win-node-divisions (division-win-node division)))) + (setf (division-win-node division) nil) + (ide-skel-win--remove-child (division-win-node division) child-win-node))))) + +(defun ide-skel-win-remove-window (window) + "Remove window with coordinates WINDOW." + (let* ((window-corner-pos (ide-skel-win-corner window)) + (root-win-node (ide-skel-win--analysis)) + (child-win-node (ide-skel-win--find-node-by-corner-pos root-win-node window-corner-pos))) + (ide-skel-win--remove-child root-win-node child-win-node) + (ide-skel-win--synthesis (selected-window) root-win-node))) + +(defun ide-skel-win-add-window (buffer parent-window-edges edge-symbol size) + "Split PARENT-WINDOW-EDGES window along specified edge. In new window with width/height SIZE +show buffer BUFFER. SIZE can be integer (character count) or float 0.0 - 1.0." + (when (windowp parent-window-edges) + (setq parent-window-edges (window-edges parent-window-edges))) + (let ((horizontal-p (or (eq edge-symbol 'left) (eq edge-symbol 'right))) + (replace-parent-p (or (eq edge-symbol 'top) (eq edge-symbol 'left))) + (percentage + (if (or (eq edge-symbol 'bottom) (eq edge-symbol 'right)) + (- size) + size))) + (ide-skel-win--add-window buffer parent-window-edges horizontal-p percentage replace-parent-p))) + +(defun ide-skel-win--add-window (buffer parent-window-edges horizontal-p percentage replace-parent-p) + (let* ((root-win-node (ide-skel-win--analysis)) + (new-win-node (make-win-node :buffer buffer))) + (ide-skel-win--synthesis (selected-window) root-win-node + (lambda (window) + (if (equal (window-edges window) parent-window-edges) + (let ((child-window (ide-skel-win--split window horizontal-p percentage))) + (set-window-buffer (if replace-parent-p window child-window) buffer) + (if replace-parent-p child-window window)) + window))))) + +(defun ide-skel-win--get-bounds (object) + (cond ((windowp object) (window-edges object)) + ((and (listp object) (= (length object) 4)) object) + (t (error "Invalid object param: %S" object)))) + +(defun ide-skel-win--win-area (window) + (let ((win-bounds (ide-skel-win--get-bounds window))) + (* (- (nth 2 win-bounds) (nth 0 win-bounds)) + (- (nth 3 win-bounds) (nth 1 win-bounds))))) + +(defun ide-skel-win--is-adjacent(window1 edge-symbol window2) + "Non-nil if WINDOW1 sticks to WINDOW2 along specified edge." + (let ((bounds1 (ide-skel-win--get-bounds window1)) + (bounds2 (ide-skel-win--get-bounds window2)) + result) + (if (or (equal edge-symbol 'top) (equal edge-symbol 'bottom)) + (setq result (and + (equal (nth 0 bounds1) (nth 0 bounds2)) ; bounds.LEFT = bounds2.LEFT + (equal (nth 2 bounds1) (nth 2 bounds2)))) ; bounds.RIGHT = bounds2.RIGHT + (setq result (and + (equal (nth 1 bounds1) (nth 1 bounds2)) ; bounds.TOP = bounds2.TOP + (equal (nth 3 bounds1) (nth 3 bounds2))))) ; bounds.BOTTOM = bounds2.BOTTOM + (when result + (setq result + (cond ((equal edge-symbol 'top) (equal (nth 1 bounds1) (nth 3 bounds2))) ; bounds.TOP = bounds2.BOTTOM + ((equal edge-symbol 'bottom) (equal (nth 3 bounds1) (nth 1 bounds2))) ; bounds.BOTTOM = bounds2.TOP + ((equal edge-symbol 'left) (equal (nth 0 bounds1) (nth 2 bounds2))) ; bounds.LEFT = bounds2.RIGHT + (t (equal (nth 2 bounds1) (nth 0 bounds2)))))) + result)) + +(defun ide-skel-win--is-leaf (&optional window) + "Non-nil if WINDOW is a leaf." + (unless window + (setq window (selected-window))) + ;; no window can stick from right or bottom + (when (and (not (get-window-with-predicate + (lambda (win) (ide-skel-win--is-adjacent window 'right win)) 1 1)) + (not (get-window-with-predicate + (lambda (win) (ide-skel-win--is-adjacent window 'bottom win)) 1 1))) + (let ((parent (ide-skel-previous-window window 1 1))) + ;; parent must exist and come from left or up + (when (and parent + (or (ide-skel-win--is-adjacent window 'top parent) + (ide-skel-win--is-adjacent window 'left parent))) + window)))) + +(defun ide-skel-win--is-leaf2 (&optional win2) + "Non-nil if WIN2 is leaf." + (unless win2 + (setq win2 (selected-window))) + ;; no window can stick from right or bottom + (when (and (not (get-window-with-predicate + (lambda (win) (ide-skel-win--is-adjacent win2 'right win)))) + (not (get-window-with-predicate + (lambda (win) (ide-skel-win--is-adjacent win2 'bottom win))))) + (let ((parent (ide-skel-previous-window win2 1 1))) + ;; parent must exist and come from left or up + (when (and parent + (or (ide-skel-win--is-adjacent win2 'top parent) + (ide-skel-win--is-adjacent win2 'left parent))) + win2)))) + +(defun ide-skel-win-corner (window) + (let ((coords (window-edges window))) + (cons (car coords) (cadr coords)))) + +(defun ide-skel-window-size-changed (frame) + (let* ((editor-window (ide-skel-get-editor-window)) + (left-view-window (car ide-skel--current-side-windows)) + (right-view-window (cdr ide-skel--current-side-windows)) + (bottom-view-window (ide-skel-get-bottom-view-window))) + (ide-skel-recalculate-view-cache) + (when bottom-view-window + (ide-skel-remember-bottom-view-window)) + (when left-view-window + (setq ide-skel-left-view-window-width (window-width left-view-window))) + (when right-view-window + (setq ide-skel-right-view-window-width (window-width right-view-window))))) + +(add-hook 'window-size-change-functions 'ide-skel-window-size-changed) + +(setq special-display-regexps ide-skel-bottom-view-buffer-names-regexps) + +(defun ide-skel-recalculate-view-cache () + (setq ide-skel-selected-frame (selected-frame) + ide-skel-current-editor-window (ide-skel-get-editor-window)) + (setq ide-skel-current-editor-buffer (window-buffer ide-skel-current-editor-window) + ide-skel-current-left-view-window (car ide-skel--current-side-windows) + ide-skel-current-right-view-window (cdr ide-skel--current-side-windows))) + +(defun ide-skel-get-last-selected-window () + (and ide-skel-last-selected-window-or-buffer + (or (and (window-live-p (car ide-skel-last-selected-window-or-buffer)) + (car ide-skel-last-selected-window-or-buffer)) + (and (buffer-live-p (cdr ide-skel-last-selected-window-or-buffer)) + (get-buffer-window (cdr ide-skel-last-selected-window-or-buffer)))))) + +(require 'mwheel) + +(defvar ide-skel-mouse-wheel-events (list mouse-wheel-up-event mouse-wheel-down-event)) + +(run-with-idle-timer 0 t (lambda () +;; (when ide-skel-current-left-view-window +;; (with-selected-window ide-skel-current-left-view-window +;; (beginning-of-line))) +;; (when ide-skel-current-right-view-window +;; (with-selected-window ide-skel-current-right-view-window +;; (beginning-of-line))) + (unless (or (active-minibuffer-window) + (memq 'down (event-modifiers last-input-event)) + (memq (event-basic-type last-input-event) ide-skel-mouse-wheel-events) + (mouse-movement-p last-input-event)) + ;; selected frame changed? + (unless (eq (selected-frame) ide-skel-selected-frame) + (ide-skel-recalculate-view-cache)) + ;; side view windows cannot have cursor + (while (memq (selected-window) (list ide-skel-current-left-view-window + ide-skel-current-right-view-window)) + (let ((win (ide-skel-get-last-selected-window))) + (if (and win (not (eq (selected-window) win))) + (select-window win) + (other-window 1)))) + (setq ide-skel-last-selected-window-or-buffer + (cons (selected-window) (window-buffer (selected-window)))) + ;; current buffer changed? + (let ((editor-buffer (window-buffer ide-skel-current-editor-window))) + (when (not (eq ide-skel-last-buffer-change-event editor-buffer)) + (ide-skel-send-event nil 'editor-buffer-changed ide-skel-last-buffer-change-event editor-buffer)))))) + +(setq special-display-function + (lambda (buffer &optional data) + (let ((bottom-view-window (ide-skel-get-bottom-view-window))) + (if (and bottom-view-window + (eq bottom-view-window (selected-window)) + (member (buffer-name buffer) ide-skel-unexpected-bottom-view-window-buffer-names)) + (progn + (show-buffer (ide-skel-get-editor-window) buffer) + (ide-skel-get-editor-window)) + (unless (ide-skel-get-bottom-view-window) + (ide-skel-show-bottom-view-window)) + (set-window-buffer (ide-skel-get-bottom-view-window) buffer) + ;; (select-window (ide-skel-get-bottom-view-window)) + (ide-skel-get-bottom-view-window))))) + +;;; Bottom view + +(defun ide-skel-hidden-buffer-name-p (buffer-name) + (equal (elt buffer-name 0) 32)) + +(defun ide-skel-bottom-view-buffer-p (buffer) + "Non-nil if buffer should be shown in bottom view." + (let ((name (buffer-name buffer))) + (or (with-current-buffer buffer + (and ide-skel-tabset-name + (string= ide-skel-tabset-name ide-skel-bottom-view-window-tabset-name))) + (and (not (ide-skel-hidden-buffer-name-p name)) + (some (lambda (regexp) (string-match regexp name)) ide-skel-bottom-view-buffer-names-regexps) + (not (some (lambda (regexp) (string-match regexp name)) ide-skel-bottom-view-buffer-names-disallowed-regexps)))))) + +(defun ide-skel-remember-bottom-view-window () + (let ((bottom-view-window (ide-skel-get-bottom-view-window))) + (when bottom-view-window + (setq ide-skel--last-bottom-view-buffer-name (buffer-name (window-buffer bottom-view-window)) + ide-skel-bottom-view-window-size (max 5 (window-height bottom-view-window)))))) + +(defun ide-skel--find-buffer-for-bottom-view-window () + "Returns first buffer to display in bottom view window (always returns a buffer)." + (let ((best-buffers (list (car (buffer-list (selected-frame)))))) + (some (lambda (buffer) + (when (ide-skel-bottom-view-buffer-p buffer) + (if (member (buffer-name buffer) ide-skel-unexpected-bottom-view-window-buffer-names) + (setq best-buffers (append best-buffers (list buffer))) + (setq best-buffers (cons buffer best-buffers))) + nil)) + (buffer-list (selected-frame))) + (if (and (not ide-skel-was-scratch) + (get-buffer "*scratch*")) + (progn + (setq ide-skel-was-scratch t) + (get-buffer "*scratch*")) + (car best-buffers)))) + +(defun ide-skel--is-full-width-window (window &rest except-windows) + (let ((bounds (window-edges window)) + (result t)) + (dolist (win (ide-skel-window-list)) + (unless (memq win except-windows) + (let ((left-edge-pos (car (window-edges win)))) + (when (or (< left-edge-pos (car bounds)) + (>= left-edge-pos (nth 2 bounds))) + (setq result nil))))) + result)) + +(defun ide-skel-get-bottom-view-window () + (let* ((editor-window (ide-skel-get-editor-window)) + best-window) + ;; get lowest window + (dolist (win (copy-list (window-list nil 1))) + (when (with-current-buffer (window-buffer win) + (and (or (not ide-skel-tabset-name) + (equal ide-skel-tabset-name ide-skel-bottom-view-window-tabset-name)) + (not (eq win editor-window)))) + (if (null best-window) + (setq best-window win) + (when (> (cadr (window-edges win)) (cadr (window-edges best-window))) + (setq best-window win))))) + (when (and best-window + (not (ide-skel--is-full-width-window best-window (ide-skel-get-left-view-window) (ide-skel-get-right-view-window)))) + (setq best-window nil)) + best-window)) + +(defun ide-skel-show-bottom-view-window (&optional buffer) + (interactive) + (unless ide-skel-bottom-view-window-oper-in-progress + (let ((saved-window (cons (selected-window) (window-buffer (selected-window))))) + (unwind-protect + (unless (ide-skel-get-bottom-view-window) ;; if not open yet + (setq ide-skel-bottom-view-window-oper-in-progress t) + (unless buffer + (setq buffer + (or (and ide-skel--last-bottom-view-buffer-name (get-buffer ide-skel--last-bottom-view-buffer-name)) + (ide-skel--find-buffer-for-bottom-view-window)))) + (let* ((left-view-window (ide-skel-get-left-view-window)) + (left-view-window-bounds (and left-view-window + (window-edges left-view-window))) + (right-view-window (ide-skel-get-right-view-window)) + (right-view-window-bounds (and right-view-window + (window-edges right-view-window))) + (root-win-node (ide-skel-win--analysis)) + (window-bounds (window-edges (selected-window)))) ; bounds of maximized window (after analysis) + (when (and left-view-window-bounds (not ide-skel-bottom-view-on-left-view)) + (setf (nth 0 window-bounds) (nth 2 left-view-window-bounds))) + (when (and right-view-window-bounds (not ide-skel-bottom-view-on-right-view)) + (setf (nth 2 window-bounds) (nth 0 right-view-window-bounds))) + (ide-skel-win--synthesis (selected-window) root-win-node) + (let ((ide-skel-win--win2-switch (and (not (null left-view-window)) + ide-skel-bottom-view-on-right-view)) + (old ide-skel-ommited-windows)) + (when (and (not ide-skel-bottom-view-on-left-view) + (not ide-skel-bottom-view-on-right-view) + (ide-skel-get-left-view-window)) + (push (ide-skel-get-left-view-window) ide-skel-ommited-windows)) + (ide-skel-win-add-window buffer window-bounds 'bottom ide-skel-bottom-view-window-size) + (setq ide-skel-ommited-windows old)))) + (if (window-live-p (car saved-window)) + (select-window (car saved-window)) + (when (get-buffer-window (cdr saved-window)) + (select-window (get-buffer-window (cdr saved-window))))) + (setq ide-skel-bottom-view-window-oper-in-progress nil))))) + +(defun ide-skel-hide-bottom-view-window () + (interactive) + (unless ide-skel-bottom-view-window-oper-in-progress + (setq ide-skel-bottom-view-window-oper-in-progress t) + (let ((bottom-view-window (ide-skel-get-bottom-view-window))) + (when bottom-view-window + (let ((ide-skel-win--win2-switch nil) + (select-editor (eq bottom-view-window (selected-window)))) + (ide-skel-remember-bottom-view-window) + (ide-skel-win-remove-window bottom-view-window) + (when select-editor (select-window (ide-skel-get-editor-window)))))) + (setq ide-skel-bottom-view-window-oper-in-progress nil))) + +(defun ide-skel-toggle-bottom-view-window () + "Toggle bottom view window." + (interactive) + (if (ide-skel-get-bottom-view-window) + (ide-skel-hide-bottom-view-window) + (ide-skel-show-bottom-view-window))) + +;;; Editor + +(defun ide-skel-get-editor-window () + (let (best-window) + (setq ide-skel--current-side-windows (cons nil nil)) + (dolist (win (copy-list (window-list nil 1))) + (when (with-current-buffer (window-buffer win) + (when (equal ide-skel-tabset-name ide-skel-left-view-window-tabset-name) + (setcar ide-skel--current-side-windows win)) + (when (equal ide-skel-tabset-name ide-skel-right-view-window-tabset-name) + (setcdr ide-skel--current-side-windows win)) + (or (not ide-skel-tabset-name) + (equal ide-skel-tabset-name ide-skel-editor-window-tabset-name))) + (if (null best-window) + (setq best-window win) + (let* ((best-window-coords (window-edges best-window)) + (win-coords (window-edges win))) + (when (or (< (cadr win-coords) (cadr best-window-coords)) + (and (= (cadr win-coords) (cadr best-window-coords)) + (< (car win-coords) (car best-window-coords)))) + (setq best-window win)))))) + best-window)) + +;;; Left view & Right view + +(defun ide-skel-toggle-side-view-window (name &optional run-hooks) + (if (funcall (intern (format "ide-skel-get-%s-view-window" name))) + (funcall (intern (format "ide-skel-hide-%s-view-window" name)) run-hooks) + (funcall (intern (format "ide-skel-show-%s-view-window" name)) run-hooks))) + +(defun ide-skel-toggle-left-view-window () + (interactive) + (ide-skel-toggle-side-view-window 'left (interactive-p))) + +(defun ide-skel-toggle-right-view-window () + (interactive) + (ide-skel-toggle-side-view-window 'right (interactive-p))) + + +(add-hook 'kill-buffer-hook (lambda () + (when (eq ide-skel-current-editor-buffer (current-buffer)) + (let* ((context (gethash ide-skel-current-editor-buffer ide-skel-context-properties)) + (imenu-buffer (cdr (assq :imenu-buffer context))) + (imenu-window (when imenu-buffer (get-buffer-window imenu-buffer)))) + (when imenu-window + (set-window-dedicated-p imenu-window nil) + (set-window-buffer imenu-window ide-skel-default-right-view-buffer) + (set-window-dedicated-p imenu-window t)) + (remhash (current-buffer) ide-skel-context-properties) + (when imenu-buffer + (kill-buffer imenu-buffer)))))) + +(defun ide-skel-send-event (side-symbol event-type &rest params) + (ide-skel-recalculate-view-cache) + (cond ((eq event-type 'hide) + (run-hook-with-args-until-success 'ide-skel-side-view-window-functions side-symbol 'hide) + (ide-skel-disable-nonactual-side-view-tabs side-symbol 'disable-all)) + ((eq event-type 'show) + (run-hook-with-args-until-success 'ide-skel-side-view-window-functions side-symbol 'show) + (ide-skel-side-window-switch-to-buffer (symbol-value (intern (format "ide-skel-current-%s-view-window" side-symbol))) nil)) + ((eq event-type 'editor-buffer-changed) + (run-hooks 'ide-skel-editor-buffer-changed-hook) + (when ide-skel-current-left-view-window + (ide-skel-disable-nonactual-side-view-tabs 'left) + (run-hook-with-args-until-success 'ide-skel-side-view-window-functions + 'left 'editor-buffer-changed + ide-skel-last-buffer-change-event ide-skel-current-editor-buffer) + (ide-skel-side-window-switch-to-buffer ide-skel-current-left-view-window nil)) + (when ide-skel-current-right-view-window + (ide-skel-disable-nonactual-side-view-tabs 'right) + (run-hook-with-args-until-success 'ide-skel-side-view-window-functions + 'right 'editor-buffer-changed + (car params) (cadr params)) + (ide-skel-side-window-switch-to-buffer ide-skel-current-right-view-window nil)) + (setq ide-skel-last-buffer-change-event ide-skel-current-editor-buffer)) + ((eq event-type 'tab-change) + (run-hook-with-args-until-success 'ide-skel-side-view-window-functions side-symbol 'tab-change (car params) (cadr params))))) + +(defun ide-skel-hide-side-view-window (name &optional run-hooks) + (let* ((view-window (funcall (intern (format "ide-skel-get-%s-view-window" name)))) + (select-editor (eq view-window (selected-window)))) + (when view-window + (when (active-minibuffer-window) + (error "Cannot remove side window while minibuffer is active")) + (let* ((bottom-view-window (ide-skel-get-bottom-view-window)) + (selected-bottom-view-window (and bottom-view-window (eq bottom-view-window (selected-window)))) + (buffer (window-buffer view-window)) + (second-side-window (funcall (intern (format "ide-skel-get-%s-view-window" (if (eq name 'left) 'right 'left)))))) + (set (intern (format "ide-skel-last-%s-view-buffer" name)) buffer) + (when run-hooks + (ide-skel-send-event name 'hide)) + (when bottom-view-window + (ide-skel-hide-bottom-view-window)) + (when second-side-window + (push second-side-window ide-skel-ommited-windows)) + (let ((ide-skel-win--win2-switch (eq name 'left))) + (set (intern (format "ide-skel-%s-view-window-width" name)) (window-width view-window)) + (ide-skel-win-remove-window view-window)) + (setq ide-skel-ommited-windows nil) + (when bottom-view-window + (ide-skel-show-bottom-view-window) + (when selected-bottom-view-window + (select-window (ide-skel-get-bottom-view-window)))) + (ide-skel-recalculate-view-cache) + (when select-editor (select-window (ide-skel-get-editor-window))))))) + +(defun ide-skel-hide-left-view-window (&optional run-hooks) + (interactive) + (let ((right-view-window (ide-skel-get-right-view-window))) + (when right-view-window + (ide-skel-hide-right-view-window)) + (ide-skel-hide-side-view-window 'left (or run-hooks (interactive-p))) + (when right-view-window + (ide-skel-show-right-view-window)))) + +(defun ide-skel-hide-right-view-window (&optional run-hooks) + (interactive) + (ide-skel-hide-side-view-window 'right (or (interactive-p) run-hooks))) + +(defun ide-skel-get-side-view-buffer-create (name side-sym tab-label help-string keep-condition-function) + (let* ((was-buffer (get-buffer name)) + (km (make-sparse-keymap)) + (buffer (get-buffer-create name))) + (unless was-buffer + (with-current-buffer buffer + (kill-all-local-variables) + (remove-overlays) + (define-key km [drag-mouse-1] 'ignore) + (use-local-map km) + (make-local-variable 'mouse-wheel-scroll-amount) + (make-local-variable 'auto-hscroll-mode) + (make-local-variable 'hscroll-step) + (make-local-variable 'hscroll-margin) + (setq ide-skel-tabset-name (if (eq side-sym 'left) ide-skel-left-view-window-tabset-name ide-skel-right-view-window-tabset-name) + ide-skel-tabbar-tab-label tab-label + ide-skel-tabbar-tab-help-string help-string + ide-skel-keep-condition-function keep-condition-function + auto-hscroll-mode nil + hscroll-step 0.0 + hscroll-margin 0 +;; left-fringe-width 0 +;; right-fringe-width 0 + buffer-read-only t + mode-line-format " " + mouse-wheel-scroll-amount '(1) + window-size-fixed 'width) + ;; (make-variable-buffer-local 'fringe-indicator-alist) + (setq fringe-indicator-alist (copy-alist default-fringe-indicator-alist)) +;; (when (>= emacs-major-version 22) +;; (set 'indicate-buffer-boundaries '((up . left) (down . left)))) + (setcdr (assq 'truncation fringe-indicator-alist) nil) + (set (make-local-variable 'scroll-conservatively) 1500) ; much greater than 0 + (when (and window-system + (not ide-skel-side-view-display-cursor)) + (setq cursor-type nil)))) + buffer)) + +(defvar ide-skel-default-left-view-buffer + (let ((buffer (ide-skel-get-side-view-buffer-create " Default Left View Buffer" 'left nil nil (lambda (buf) t)))) + (with-current-buffer buffer + (setq header-line-format " ")) + buffer)) +(defvar ide-skel-last-left-view-buffer ide-skel-default-left-view-buffer) +(defvar ide-skel-default-right-view-buffer + (let ((buffer (ide-skel-get-side-view-buffer-create " Default Right View Buffer" 'right nil nil (lambda (buf) t)))) + (with-current-buffer buffer + (setq header-line-format " ")) + buffer)) +(defvar ide-skel-last-right-view-buffer ide-skel-default-right-view-buffer) + +(defun ide-skel-show-side-view-window (name &optional run-hooks) + (unless (funcall (intern (format "ide-skel-get-%s-view-window" name))) + (let* ((current-buffer (window-buffer (selected-window))) + (bottom-view-window (ide-skel-get-bottom-view-window)) + root-win-node + (bottom-view-window-bounds (and (or (symbol-value (intern (format "ide-skel-bottom-view-on-%s-view" name))) + (and ide-skel-bottom-view-on-left-view + (not ide-skel-bottom-view-on-right-view))) + bottom-view-window + (window-edges bottom-view-window))) + best-window-bounds) + (when bottom-view-window-bounds + (ide-skel-hide-bottom-view-window)) + (let ((second-side-window (funcall (intern (format "ide-skel-get-%s-view-window" (if (eq name 'left) 'right 'left)))))) + (when second-side-window + (push second-side-window ide-skel-ommited-windows)) + (setq root-win-node (ide-skel-win--analysis)) + (setq best-window-bounds (window-edges (selected-window))) ; bounds of maximized window (after analysis) + (ide-skel-win--synthesis (selected-window) root-win-node) + (ide-skel-win-add-window + (symbol-value (intern (format (if run-hooks "ide-skel-default-%s-view-buffer" "ide-skel-last-%s-view-buffer") name))) + best-window-bounds name + (symbol-value (intern (format "ide-skel-%s-view-window-width" name)))) + (setq ide-skel-ommited-windows nil) + (when bottom-view-window-bounds + (ide-skel-show-bottom-view-window)) + (set-window-dedicated-p (funcall (intern (format "ide-skel-get-%s-view-window" name))) t) + (when run-hooks + (dolist (tab (tabbar-tabs (tabbar-get-tabset (symbol-value (intern (format "ide-skel-%s-view-window-tabset-name" name)))))) + (tabbar-delete-tab tab)) + (ide-skel-send-event name 'show)) + (some (lambda (win) (when (eq (window-buffer win) current-buffer) (select-window win) t)) (copy-list (window-list nil 1))))))) + +;; Disables from view all buffers for which keep condition function +;; returns nil. If a current buffer is there, select another enabled, +;; which implies tab-change event, then select any enabled buffer. +(defun ide-skel-disable-nonactual-side-view-tabs (name &optional disable-all) + (let* ((tabset (tabbar-get-tabset (symbol-value (intern (format "ide-skel-%s-view-window-tabset-name" name))))) + (tabs (tabbar-tabs tabset)) + (editor-buffer (window-buffer (ide-skel-get-editor-window))) + selected-deleted + (selected-tab (tabbar-selected-tab tabset))) + (when tabs + (dolist (tab tabs) + (let ((buffer (tabbar-tab-value tab))) + (with-current-buffer buffer + (when (or disable-all + (not ide-skel-keep-condition-function) + (not (funcall ide-skel-keep-condition-function editor-buffer))) + (setq ide-skel-tabbar-enabled nil) + (when (eq tab selected-tab) + (setq selected-deleted t)) + (tabbar-delete-tab tab))))) + (let ((selected-buffer (when (and (not selected-deleted) + (tabbar-tabs tabset) (tabbar-selected-value tabset))))) + (when (and (not disable-all) + (or selected-deleted + (not (eq (tabbar-selected-tab tabset) selected-tab)))) + (unless selected-buffer + (setq selected-buffer (symbol-value (intern (format "ide-skel-default-%s-view-buffer" name))))) + (ide-skel-side-window-switch-to-buffer + (symbol-value (intern (format "ide-skel-current-%s-view-window" name))) + selected-buffer)))))) + +(defun ide-skel-show-left-view-window (&optional run-hooks) + (interactive) + (let ((right-view-window (ide-skel-get-right-view-window))) + (when right-view-window + (ide-skel-hide-right-view-window)) + (ide-skel-show-side-view-window 'left (or run-hooks (interactive-p))) + (when right-view-window + (ide-skel-show-right-view-window)))) + +(defun ide-skel-show-right-view-window (&optional run-hooks) + (interactive) + (ide-skel-show-side-view-window 'right (or run-hooks (interactive-p)))) + +(defun ide-skel-get-side-view-window (name) + (let ((tabset-name (symbol-value (intern (format "ide-skel-%s-view-window-tabset-name" name))))) + (some (lambda (win) + (when (with-current-buffer (window-buffer win) + (equal ide-skel-tabset-name tabset-name)) + win)) + (copy-list (window-list nil 1))))) + +(defun ide-skel-get-left-view-window () + (ide-skel-get-side-view-window 'left)) + +(defun ide-skel-get-right-view-window () + (ide-skel-get-side-view-window 'right)) + +(defun ide-skel-get-side-view-windows () + (let (result + (left-view-win (ide-skel-get-left-view-window)) + (right-view-win (ide-skel-get-right-view-window))) + (when left-view-win (push left-view-win result)) + (when right-view-win (push right-view-win result)) + result)) + +(defun ide-skel-side-view-window-p (window) + (ide-skel-side-view-buffer-p (window-buffer window))) + +(defun ide-skel-side-view-buffer-p (buffer) + (with-current-buffer buffer + (or (equal ide-skel-tabset-name ide-skel-left-view-window-tabset-name) + (equal ide-skel-tabset-name ide-skel-right-view-window-tabset-name)))) + +(defadvice delete-window (around delete-window-around-advice (&optional window)) + (let* ((target-window (if window window (selected-window))) + (editor-window (and (interactive-p) (ide-skel-get-editor-window))) ; for ide-skel--current-side-windows (side-effects) + (hide-view-windows (and (interactive-p) + (not (eq (car ide-skel--current-side-windows) target-window)) + (not (eq (cdr ide-skel--current-side-windows) target-window)))) + (hide-left-view-window (and hide-view-windows (car ide-skel--current-side-windows))) + (hide-right-view-window (and hide-view-windows (cdr ide-skel--current-side-windows))) + result) + (when (interactive-p) + (if (eq (car ide-skel--current-side-windows) target-window) + (ide-skel-send-event 'left 'hide) + (when (eq (cdr ide-skel--current-side-windows) target-window) + (ide-skel-send-event 'right 'hide)))) + (let* ((edges (window-inside-edges window)) + (buf (window-buffer window)) + win + (center-position (cons (/ (+ (car edges) (caddr edges)) 2) + (/ (+ (cadr edges) (cadddr edges)) 2)))) + (when hide-left-view-window (ide-skel-hide-left-view-window)) + (when hide-right-view-window (ide-skel-hide-right-view-window)) + (setq win (window-at (car center-position) (cdr center-position))) + (when (eq (window-buffer win) buf) + (setq window (window-at (car center-position) (cdr center-position))))) + (unwind-protect + (setq result (progn ad-do-it)) + (when hide-left-view-window (ide-skel-show-left-view-window)) + (when hide-right-view-window (ide-skel-show-right-view-window))) + result)) +(ad-activate 'delete-window) + +(defadvice delete-other-windows (around delete-other-windows-around-advice (&optional window)) + (ide-skel-assert-not-in-side-view-window) + (let* ((editor-window (ide-skel-get-editor-window)) + (dont-revert-after (and (interactive-p) (listp current-prefix-arg) (car current-prefix-arg))) ; C-u + (hide-left-view-window (and (interactive-p) (car ide-skel--current-side-windows))) + (hide-right-view-window (and (interactive-p) (cdr ide-skel--current-side-windows))) + result) + (when hide-left-view-window (ide-skel-hide-left-view-window dont-revert-after)) + (when hide-right-view-window (ide-skel-hide-right-view-window dont-revert-after)) + (unwind-protect + (setq result (progn ad-do-it)) + (when (not dont-revert-after) + (when hide-left-view-window + (ide-skel-show-left-view-window)) + (when hide-right-view-window + (ide-skel-show-right-view-window)))) + result)) +(ad-activate 'delete-other-windows) + +(defun ide-skel-assert-not-in-side-view-window () + (when (and (interactive-p) (ide-skel-side-view-window-p (selected-window))) + (error "Cannot do it"))) + +(defadvice kill-buffer (before kill-buffer-before-advice (buffer)) + (ide-skel-assert-not-in-side-view-window)) +(ad-activate 'kill-buffer) + +(defadvice split-window-vertically (before split-window-vertically-before-advice (&optional size)) + (ide-skel-assert-not-in-side-view-window)) +(ad-activate 'split-window-vertically) + +(defadvice split-window-horizontally (before split-window-horizontally-before-advice (&optional size)) + (ide-skel-assert-not-in-side-view-window)) +(ad-activate 'split-window-horizontally) + +(defadvice mouse-drag-vertical-line (around mouse-drag-vertical-line-around-advice (start-event)) + (let* ((editor-window (ide-skel-get-editor-window)) + (left-view-window (car ide-skel--current-side-windows)) + (right-view-window (cdr ide-skel--current-side-windows))) + (when left-view-window (with-selected-window left-view-window (setq window-size-fixed nil))) + (when right-view-window (with-selected-window right-view-window (setq window-size-fixed nil))) + (unwind-protect + (progn ad-do-it) + (when left-view-window (with-selected-window left-view-window (setq window-size-fixed 'width))) + (when right-view-window (with-selected-window right-view-window (setq window-size-fixed 'width)))))) +(ad-activate 'mouse-drag-vertical-line) + +(defadvice other-window (after other-window-after-advice (arg &optional all-frames)) + (if (memq (selected-window) (list ide-skel-current-left-view-window ide-skel-current-right-view-window)) + (other-window arg all-frames) + ad-return-value)) +(ad-activate 'other-window) + +;; Buffer list buffer (left side view) + +(define-derived-mode fundmental-mode + fundamental-mode "Fundmental") + +(setq default-major-mode 'fundmental-mode) + +(defun ide-skel-recentf-closed-files-list () + "Lista ostatnio otwieranych, ale aktualnie zamknietych plikow" + (let* ((open-file-paths (delq nil (mapcar (lambda (buffer) (buffer-file-name buffer)) (buffer-list))))) + (if (featurep 'recentf) + (sort (reverse (set-difference recentf-list open-file-paths :test 'string=)) + (lambda (path1 path2) + (string< (file-name-nondirectory path1) (file-name-nondirectory path2)))) + nil))) + +(defun ide-skel-select-buffer (buffer-or-path &optional line-no) + (let* ((window (ide-skel-get-last-selected-window)) + (buffer (or (and (bufferp buffer-or-path) buffer-or-path) + (find-file-noselect buffer-or-path))) + (is-bottom-view-buffer (ide-skel-bottom-view-buffer-p buffer))) + (when (not (buffer-live-p buffer)) + (error "Buffer %s is dead" buffer)) + (unless (get-buffer-window buffer) + ;; (message "%S %S" window (ide-skel-get-bottom-view-window)) + (if (and window + (not (eq window (ide-skel-get-bottom-view-window))) + (not is-bottom-view-buffer)) + (set-window-buffer window buffer) + (let ((editor-window (ide-skel-get-editor-window))) + (select-window editor-window) + (if is-bottom-view-buffer + (switch-to-buffer-other-window buffer) + (set-window-buffer editor-window buffer))))) + (setq ide-skel-last-selected-window-or-buffer (cons (get-buffer-window buffer) buffer)) + (select-window (car ide-skel-last-selected-window-or-buffer)) + (when line-no + (with-current-buffer buffer + (goto-line line-no))))) + +(defun ide-skel-select-buffer-handler (event) + (interactive "@e") + ;; (message "EVENT: %S" event) + (with-selected-window (posn-window (event-start event)) + (let* ((object (get-text-property (posn-point (event-start event)) 'object-to-display))) + (beginning-of-line) + (ide-skel-select-buffer object)))) + +(defun ide-skel-buffers-view-insert-buffer-list (label buffer-list) + (setq label (propertize label 'face 'bold)) + (insert (format "%s\n" label)) + (dolist (object buffer-list) + (let* ((label (format " % -100s" (if (bufferp object) (buffer-name object) (file-name-nondirectory object)))) + (km (make-sparse-keymap))) + (define-key km [mouse-1] 'ide-skel-select-buffer-handler) + (setq label (propertize label + 'mouse-face 'ide-skel-highlight-face + 'local-map km + 'face 'variable-pitch + 'pointer 'hand + 'object-to-display object + 'help-echo (if (bufferp object) (buffer-file-name object) object))) + (insert label) + (insert "\n")))) + +(defun ide-skel-buffers-view-fill () + (when ide-skel-current-left-view-window + (with-current-buffer ide-skel-buffer-list-buffer + (let ((point (point)) + (window-start (when (eq (window-buffer ide-skel-current-left-view-window) ide-skel-buffer-list-buffer) + (save-excursion + (goto-char (window-start ide-skel-current-left-view-window)) + (cons (line-number-at-pos) (current-column)))))) + ;; (message "%S" window-start) + (let (asterisk-buffers + (inhibit-read-only t) + normal-buffers) + (erase-buffer) + (dolist (buffer (sort (buffer-list) (lambda (buf1 buf2) (string< (buffer-name buf1) (buffer-name buf2))))) + (let* ((name (buffer-name buffer)) + (first-char (aref (buffer-name buffer) 0))) + (unless (char-equal ?\ first-char) + (if (char-equal ?* first-char) + (push buffer asterisk-buffers) + (push buffer normal-buffers))))) + (ide-skel-buffers-view-insert-buffer-list "Normal Buffers:" normal-buffers) + (ide-skel-buffers-view-insert-buffer-list "Scratch Buffers:" asterisk-buffers) + (ide-skel-buffers-view-insert-buffer-list "Recent Files:" (ide-skel-recentf-closed-files-list))) + (if window-start + (let ((pos (save-excursion + (goto-line (car window-start)) + (beginning-of-line) + (forward-char (cdr window-start)) + (point)))) + (set-window-start ide-skel-current-left-view-window pos)) + (goto-char point) + (beginning-of-line)))))) + +(defun ide-skel-some-view-window-buffer (side-symbol predicate) + (some (lambda (buffer) + (and (buffer-live-p buffer) + (with-current-buffer buffer + (and (equal ide-skel-tabset-name (symbol-value (intern (format "ide-skel-%s-view-window-tabset-name" side-symbol)))) + ide-skel-tabbar-enabled + (funcall predicate buffer) + buffer)))) + (buffer-list))) + +(defun ide-skel-side-window-switch-to-buffer (side-window buffer) + "If BUFFER is nil, then select any non-default buffer. The +TAB-CHANGE event is send only if selected buffer changed." + (unwind-protect + (let* ((side-symbol (cond ((eq side-window ide-skel-current-left-view-window) 'left) + ((eq side-window ide-skel-current-right-view-window) 'right) + (t nil))) + (context (gethash ide-skel-current-editor-buffer ide-skel-context-properties)) + (context-default-tab-label-symbol (intern (format "default-%s-tab-label" side-symbol)))) + (when side-symbol + (unless buffer + (let* ((default-empty-buffer (symbol-value (intern (format "ide-skel-default-%s-view-buffer" side-symbol)))) + (context-default-tab-label (cdr (assq context-default-tab-label-symbol context))) + (last-view-window-tab-label (symbol-value (intern (format "ide-skel-last-%s-view-window-tab-label" side-symbol))))) + ;; first non-nil: + ;; - selected before in this context + ;; - selected in previous context + ;; - current if other than default-empty + ;; - first non default-empty + ;; - default-empty + (setq buffer + (or (and context-default-tab-label + (ide-skel-some-view-window-buffer side-symbol (lambda (buffer) + (equal ide-skel-tabbar-tab-label context-default-tab-label)))) + (and last-view-window-tab-label + (ide-skel-some-view-window-buffer side-symbol (lambda (buffer) + (equal ide-skel-tabbar-tab-label last-view-window-tab-label)))) + (and (not (eq (window-buffer side-window) default-empty-buffer)) + (window-buffer side-window)) + (ide-skel-some-view-window-buffer side-symbol (lambda (buffer) ide-skel-tabbar-tab-label)) + default-empty-buffer)))) + (unless (eq (window-buffer side-window) buffer) + (set (intern (format "ide-skel-last-%s-view-window-tab-label" side-symbol)) (with-current-buffer buffer ide-skel-tabbar-tab-label)) + (setq context (assq-delete-all context-default-tab-label-symbol context)) + (puthash ide-skel-current-editor-buffer + (cons (cons context-default-tab-label-symbol (with-current-buffer buffer ide-skel-tabbar-tab-label)) context) + ide-skel-context-properties) + (ide-skel-send-event side-symbol 'tab-change (window-buffer side-window) buffer))) + (set-window-dedicated-p side-window nil) + (set-window-buffer side-window buffer)) + (set-window-dedicated-p side-window t))) + +;; args: 'left/right 'show/editor-buffer-changed/hide/tab-change &rest buffer... +(defun ide-skel-default-side-view-window-function (side event &rest list) + ;; (message "SIDE: %S, event: %S, rest: %S %S" side event list ide-skel-current-left-view-window) + (when (and (eq side 'left) ide-skel-current-left-view-window) + (cond ((eq event 'show) + (unless ide-skel-buffer-list-buffer + (setq ide-skel-buffer-list-buffer (ide-skel-get-side-view-buffer-create + " Ide-Skel Buffer List Buffer" 'left "Bufs" "List of opened and recent files" + (lambda (buf) t))) + (with-current-buffer ide-skel-buffer-list-buffer + (setq ide-skel-tabbar-enabled t))) + (ide-skel-buffers-view-fill) + (ide-skel-side-window-switch-to-buffer ide-skel-current-left-view-window ide-skel-buffer-list-buffer)))) + nil) + + ;; (message "SIDE: %S, event: %S, rest: %S" side event list) + +(add-hook 'change-major-mode-hook (lambda () (setq ide-skel-buffer-list-tick t))) +(add-hook 'kill-buffer-hook (lambda () (setq ide-skel-buffer-list-tick t))) +(run-with-idle-timer 0.1 t (lambda () + (when ide-skel-buffer-list-tick + (setq ide-skel-buffer-list-tick nil) + (ide-skel-buffers-view-fill)))) + +(add-hook 'ide-skel-side-view-window-functions 'ide-skel-default-side-view-window-function) + +(define-key-after global-map [tool-bar ide-skel-toggle-left-view-window] + (list 'menu-item "Left View Window" 'ide-skel-toggle-left-view-window :image ide-skel-left-view-window-image)) +(define-key-after global-map [tool-bar ide-skel-toggle-bottom-view-window] + (list 'menu-item "Bottom View Window" 'ide-skel-toggle-bottom-view-window :image ide-skel-bottom-view-window-image)) +(define-key-after global-map [tool-bar ide-skel-toggle-right-view-window] + (list 'menu-item "Right View Window" 'ide-skel-toggle-right-view-window :image ide-skel-right-view-window-image)) + +(eval-after-load "tabbar" '(ide-skel-tabbar-load-hook)) + +;;; Tree Widget + +(defadvice tree-widget-lookup-image (around tree-widget-lookup-image-around-advice (name)) + (if (equal (tree-widget-theme-name) "small-folder") + (setq ad-return-value (apply 'create-image (symbol-value (intern (format "ide-skel-tree-widget-%s-xpm" name))) 'xpm t (tree-widget-image-properties name))) + ad-do-it)) +(ad-activate 'tree-widget-lookup-image) + + + +;;; Imenu + +(require 'imenu) + +(defun ide-skel-imenu-refresh () + (interactive) + (ide-skel-imenu-side-view-draw-tree (window-buffer ide-skel-current-right-view-window) t)) + +(defun ide-skel-imenu-sort-change () + (interactive) + (with-current-buffer (window-buffer ide-skel-current-right-view-window) + (setq ide-skel-imenu-sorted (not ide-skel-imenu-sorted))) + (ide-skel-imenu-side-view-draw-tree (window-buffer ide-skel-current-right-view-window) t)) + +(defun ide-skel-imenu-get-buffer-create (editor-buffer &optional dont-create) + (let* ((context (gethash editor-buffer ide-skel-context-properties)) + (buffer (cdr (assq :imenu-buffer context)))) + (when (and (not buffer) (not dont-create)) + (setq buffer (ide-skel-get-side-view-buffer-create (concat " " (buffer-name editor-buffer) " Ide Skel Imenu") + 'right "Imenu" nil + (lambda (editor-buffer) + (eq ide-skel-imenu-editor-buffer ide-skel-current-editor-buffer)))) + (with-current-buffer buffer + (setq ide-skel-tabbar-menu-function + (lambda () + (let ((is-outline-mode (with-current-buffer (window-buffer ide-skel-current-right-view-window) + (with-current-buffer ide-skel-imenu-editor-buffer + (or (eq major-mode 'outline-mode) + (and (boundp 'outline-minor-mode) + (symbol-value 'outline-minor-mode))))))) + (append + (list + (list 'ide-skel-imenu-refresh "Refresh" t) + (unless is-outline-mode + (list 'ide-skel-imenu-sort-change (if (with-current-buffer (window-buffer ide-skel-current-right-view-window) + ide-skel-imenu-sorted) + "Natural order" + "Sorted order") t)))))) + ide-skel-imenu-editor-buffer editor-buffer + ide-skel-imenu-open-paths (make-hash-table :test 'equal)) + (add-hook 'tree-widget-after-toggle-functions (lambda (widget) + (let ((path (widget-get widget :path))) + (when path + (if (widget-get widget :open) + (puthash path t ide-skel-imenu-open-paths) + (remhash path ide-skel-imenu-open-paths))))) + nil t)) + (puthash editor-buffer (cons (cons :imenu-buffer buffer) context) ide-skel-context-properties)) + buffer)) + +(defun ide-skel-tree-node-notify (widget &rest rest) + (let ((index-name (widget-get widget :index-name)) + (index-position (widget-get widget :index-position)) + (function (widget-get widget :function)) + (arguments (widget-get widget :arguments))) + (select-window (ide-skel-get-editor-window)) + (if function + (apply function index-name index-position arguments) + (goto-char index-position)))) + +;; building hash +(defun ide-skel-imenu-analyze (hash prefix element) + (when element + (if (and (consp (cdr element)) + (listp (cadr element))) + (dolist (elem (cdr element)) + (ide-skel-imenu-analyze hash (concat prefix "/" (car element)) elem)) + (puthash (concat prefix "/" (car element)) (list (cons :element element)) hash)))) + +;; logical linking, internal nodes creation +(defun ide-skel-imenu-analyze2 (hash prefix element) + (when element + (if (and (consp (cdr element)) + (listp (cadr element))) + (dolist (elem (cdr element)) + (ide-skel-imenu-analyze2 hash (concat prefix "/" (car element)) elem)) + (let* ((index-name (car element)) + (path (concat prefix "/" index-name)) + (node (gethash path hash)) + (reverse-separators (let ((index 0) + result) + (while (string-match "[*#:.]+" index-name index) + (push (cons (match-beginning 0) (match-end 0)) result) + (setq index (match-end 0))) + result)) + found) + (some (lambda (separator-pair) + (let* ((begin (car separator-pair)) + (end (cdr separator-pair)) + (before-name (substring index-name 0 begin)) + (after-name (substring index-name end)) + (parent-path (concat prefix "/" before-name)) + (parent-node (gethash parent-path hash))) + (when parent-node + (push (cons :parent parent-path) node) + (unless (assq :name node) + (push (cons :name after-name) node)) + (puthash path node hash) + (unless (assq :widget parent-node) + (let* ((parent-element (cdr (assq :element parent-node))) + (parent-index-name (car parent-element)) + (parent-index-position (if (consp (cdr parent-element)) (cadr parent-element) (cdr parent-element))) + (parent-function (when (consp (cdr parent-element)) (caddr parent-element))) + (open-status (gethash parent-path ide-skel-imenu-open-paths)) + (parent-arguments (when (consp (cdr parent-element)) (cdddr parent-element)))) + (push (cons :widget + ;; internal node + (list 'ide-skel-imenu-internal-node-widget + :open open-status + :indent 0 + :path parent-path + :notify 'ide-skel-tree-node-notify + :index-name parent-index-name + :index-position parent-index-position + :function parent-function + :arguments parent-arguments + :node (list 'push-button + :format "%[%t%]\n" + :button-face 'variable-pitch + :tag (or (cdr (assq :name parent-node)) + before-name) + ;; :tag (cadr (assq :element parent-node)) + ))) + parent-node) + (puthash parent-path parent-node hash))) + t))) + reverse-separators))))) + +;; widget linking, leafs creation +(defun ide-skel-imenu-analyze3 (hash prefix element) + (when element + (if (and (consp (cdr element)) + (listp (cadr element))) + (dolist (elem (cdr element)) + (ide-skel-imenu-analyze3 hash (concat prefix "/" (car element)) elem)) + (let* ((index-name (car element)) + (index-position (if (consp (cdr element)) (cadr element) (cdr element))) + (function (when (consp (cdr element)) (caddr element))) + (arguments (when (consp (cdr element)) (cdddr element))) + (path (concat prefix "/" index-name)) + (node (gethash path hash)) + (widget (cdr (assq :widget node))) + (parent-path (cdr (assq :parent node))) + (parent-node (when parent-path (gethash parent-path hash))) + (parent-widget (when parent-node (cdr (assq :widget parent-node))))) + ;; create leaf if not exists + (unless widget + ;; leaf node + (push (cons :widget (list 'ide-skel-imenu-leaf-widget + :notify 'ide-skel-tree-node-notify + :index-name index-name + :index-position index-position + :function function + :arguments arguments + :tag (or (cdr (assq :name node)) + index-name))) + node) + (puthash path node hash) + (setq widget (cdr (assq :widget node)))) + ;; add to parent + (when parent-widget + (setcdr (last parent-widget) (cons widget nil))))))) + +(defun ide-skel-imenu-create-tree (hash prefix element) + (when element + (if (and (consp (cdr element)) + (listp (cadr element))) + (let* ((menu-title (car element)) + (sub-alist (cdr element)) + (path (concat prefix "/" menu-title)) + (open-status (gethash path ide-skel-imenu-open-paths))) + (append + (list 'ide-skel-imenu-internal-node-widget + :open open-status + :indent 0 + :path path + :node (list 'push-button + :format "%[%t%]\n" + :button-face 'variable-pitch + :tag menu-title)) + (delq nil (mapcar (lambda (elem) + (ide-skel-imenu-create-tree hash path elem)) + sub-alist)))) + (let* ((index-name (car element)) + (index-position (if (consp (cdr element)) (cadr element) (cdr element))) + (function (when (consp (cdr element)) (caddr element))) + (arguments (when (consp (cdr element)) (cdddr element))) + (path (concat prefix "/" index-name)) + (node (gethash path hash)) + (parent-path (cdr (assq :parent node))) + (widget (cdr (assq :widget node)))) + (unless parent-path + widget))))) + +(defun ide-skel-imenu-compare (e1 e2) + (let ((ce1 (and (consp (cdr e1)) (listp (cadr e1)))) + (ce2 (and (consp (cdr e2)) (listp (cadr e2))))) + (when ce1 + (setcdr e1 (sort (cdr e1) 'ide-skel-imenu-compare))) + (when ce2 + (setcdr e2 (sort (cdr e2) 'ide-skel-imenu-compare))) + (if (or (and ce1 ce2) + (and (not ce1) (not ce2))) + (string< (car e1) (car e2)) + (and ce1 (not ce2))))) + +(defun ide-skel-outline-tree-create (index-alist) + (let (stack + node-list + (current-depth 0)) + (dolist (element index-alist) + (let ((index-name (car element)) + (index-position (if (consp (cdr element)) (cadr element) (cdr element))) + (function (when (consp (cdr element)) (caddr element))) + (arguments (when (consp (cdr element)) (cdddr element)))) + ;; (message "index-name: %S" index-name) + (string-match "^\\([*]+\\)[ ]*\\(.*\\)$" index-name) + (let* ((depth (length (match-string 1 index-name))) + (name (match-string 2 index-name)) + parent-node + node) + (while (and stack + (>= (caar stack) depth)) + (setq stack (cdr stack))) + (when stack + (setq parent-node (cdar stack)) + (when (eq (car parent-node) 'ide-skel-imenu-leaf-widget) + (let ((path (plist-get (cdr parent-node) :path))) + (setcar parent-node 'ide-skel-imenu-internal-node-widget) + (setcdr parent-node (list :open (gethash path ide-skel-imenu-open-paths) + :indent 0 + :notify 'ide-skel-tree-node-notify + :index-name (plist-get (cdr parent-node) :index-name) + :index-position (plist-get (cdr parent-node) :index-position) + :function (plist-get (cdr parent-node) :function) + :arguments (plist-get (cdr parent-node) :arguments) + :path path + :node (list 'push-button + :format "%[%t%]\n" + :button-face 'variable-pitch + :tag (plist-get (cdr parent-node) :tag))))))) + (setq node (list 'ide-skel-imenu-leaf-widget + :notify 'ide-skel-tree-node-notify + :index-name index-name + :index-position index-position + :function function + :path (concat (plist-get (cdr parent-node) :path) "/" index-name) + :arguments arguments + :tag name)) + (push (cons depth node) stack) + (if parent-node + (setcdr (last parent-node) (cons node nil)) + (push node node-list))))) + (append + (list 'ide-skel-imenu-internal-node-widget + :open t + :indent 0 + :path "" + :tag "") + (reverse node-list)))) + +(defun ide-skel-imenu-side-view-draw-tree (imenu-buffer &optional refresh) + (with-current-buffer imenu-buffer + (let ((index-alist (with-current-buffer ide-skel-imenu-editor-buffer + (when refresh + (imenu--cleanup) + (setq imenu--index-alist nil)) + (cons "" (progn + (unless imenu--index-alist + (font-lock-default-fontify-buffer) + (condition-case err + (imenu--make-index-alist t) + (error nil))) + imenu--index-alist)))) + (is-outline-mode (with-current-buffer ide-skel-imenu-editor-buffer + (or (eq major-mode 'outline-mode) + (and (boundp 'outline-minor-mode) + (symbol-value 'outline-minor-mode))))) + (inhibit-read-only t) + (hash (make-hash-table :test 'equal)) + (start-line (save-excursion + (goto-char (window-start ide-skel-current-right-view-window)) + (line-number-at-pos)))) + (unless is-outline-mode + (when ide-skel-imenu-sorted + (setq index-alist (cons "" (sort (copy-tree (cdr index-alist)) 'ide-skel-imenu-compare)))) + (ide-skel-imenu-analyze hash "/" index-alist) + (ide-skel-imenu-analyze2 hash "/" index-alist) + (ide-skel-imenu-analyze3 hash "/" index-alist)) + (let ((tree (if is-outline-mode + (ide-skel-outline-tree-create (cdr index-alist)) + (ide-skel-imenu-create-tree hash "/" index-alist)))) + (plist-put (cdr tree) :open t) + (plist-put (cdr tree) :indent 0) + (erase-buffer) + (tree-widget-set-theme "small-folder") + (widget-create tree) + (set-keymap-parent (current-local-map) tree-widget-button-keymap) + (widget-setup) + (goto-line start-line) + (beginning-of-line) + (set-window-start ide-skel-current-right-view-window (point)))))) + +(defun ide-skel-imenu-side-view-window-function (side event &rest list) + ;; (message "%S %S %S" side event list) + (when (and (eq side 'right) + ide-skel-current-right-view-window) + (let ((imenu-buffer (ide-skel-imenu-get-buffer-create ide-skel-current-editor-buffer t))) + (when (memq event '(show editor-buffer-changed)) + (when (ide-skel-has-imenu ide-skel-current-editor-buffer) + (unless imenu-buffer + (setq imenu-buffer (ide-skel-imenu-get-buffer-create ide-skel-current-editor-buffer))) + (with-current-buffer imenu-buffer + (setq ide-skel-tabbar-enabled t)))) + (when (and imenu-buffer + (eq event 'tab-change) + (eq (cadr list) imenu-buffer)) + (with-current-buffer imenu-buffer + (when (= (buffer-size) 0) + (ide-skel-imenu-side-view-draw-tree imenu-buffer)))))) + nil) + +(add-hook 'ide-skel-side-view-window-functions 'ide-skel-imenu-side-view-window-function) + +;;; Info + +(require 'info) + +(defun ide-skel-info-get-buffer-create () + (let ((buffer (ide-skel-get-side-view-buffer-create " Ide Skel Info" + 'left "Info" "Info browser" + (lambda (editor-buffer) t)))) + (with-current-buffer buffer + (setq ide-skel-tabbar-menu-function + (lambda () + (append + (list + (list 'ide-skel-info-refresh "Refresh" t)))) + ide-skel-info-open-paths (make-hash-table :test 'equal) + ide-skel-info-root-node (cons "Top" "(dir)top")) + (add-hook 'tree-widget-after-toggle-functions (lambda (widget) + (let ((path (widget-get widget :path))) + (when path + (if (widget-get widget :open) + (puthash path t ide-skel-info-open-paths) + (remhash path ide-skel-info-open-paths))))) + nil t)) + buffer)) + +(defun ide-skel-info-file-open (widget &rest rest) + (let ((path (widget-get widget :path))) + (if (not (string-match "^(\\([^)]+\\))\\([^.]+\\)$" path)) + (error "Invalid node %s" path) + (let ((filename (match-string 1 path)) + (nodename (match-string 2 path)) + (buffer (get-buffer "*info*")) + buffer-win) + (unless buffer + (with-selected-window (ide-skel-get-last-selected-window) + (info) + (setq buffer (window-buffer (selected-window))) + (setq buffer-win (selected-window)))) + (unless buffer-win + (setq buffer-win (get-buffer-window buffer)) + (unless buffer-win + (with-selected-window (ide-skel-get-last-selected-window) + (switch-to-buffer buffer) + (setq buffer-win (selected-window))))) + (select-window buffer-win) + (Info-find-node filename nodename))))) + +(defun ide-skel-info-tree-expand-dir (tree) + (let ((path (widget-get tree :path))) + (condition-case err + (mapcar 'ide-skel-info-tree-widget (Info-speedbar-fetch-file-nodes path)) + (error + (message "%s" (error-message-string err)) + nil)))) + +(defun ide-skel-info-tree-widget (e) + (let ((name (car e)) + (path (cdr e))) + (if (condition-case err + (Info-speedbar-fetch-file-nodes path) + (error nil)) + (list 'ide-skel-info-tree-dir-widget + :path path + :help-echo name + :open (gethash path ide-skel-info-open-paths) + :node (list 'push-button + :tag name + :format "%[%t%]\n" + :notify 'ide-skel-info-file-open + :path path + :button-face 'variable-pitch + :help-echo name + :keymap tree-widget-button-keymap + )) + (list 'ide-skel-info-tree-file-widget + :path path + :help-echo name + :keymap tree-widget-button-keymap + :tag name)))) + +(defun ide-skel-info-refresh (&optional show-top) + (interactive) + (with-current-buffer ide-skel-info-buffer + (let ((inhibit-read-only t) + (start-line (save-excursion + (goto-char (window-start ide-skel-current-left-view-window)) + (line-number-at-pos)))) + (erase-buffer) + (tree-widget-set-theme "small-folder") + (let ((tree (ide-skel-info-tree-widget ide-skel-info-root-node))) + (plist-put (cdr tree) :open t) + (widget-create tree)) + (set-keymap-parent (current-local-map) tree-widget-button-keymap) + (widget-setup) + (if show-top + (goto-char (point-min)) + (goto-line start-line)) + (beginning-of-line) + (set-window-start ide-skel-current-right-view-window (point))))) + +(defun ide-skel-info (root-node) + (with-current-buffer ide-skel-info-buffer + (clrhash ide-skel-info-open-paths) + (setq ide-skel-info-root-node root-node) + (ide-skel-info-refresh t))) + +(defun ide-skel-info-side-view-window-function (side event &rest list) + (when (and (eq side 'left) ide-skel-current-left-view-window) + (cond ((eq event 'show) + (unless ide-skel-info-buffer + (setq ide-skel-info-buffer (ide-skel-info-get-buffer-create))) + (with-current-buffer ide-skel-info-buffer + (setq ide-skel-tabbar-enabled t))) + ((and (eq event 'tab-change) + (eq (cadr list) ide-skel-info-buffer) + (= (buffer-size ide-skel-info-buffer) 0)) + (ide-skel-info-refresh)))) + nil) + +(add-hook 'ide-skel-side-view-window-functions 'ide-skel-info-side-view-window-function) + +;;; Dir tree + +(defun ide-skel-dir-node-notify (widget &rest rest) + (let ((path (widget-get widget :path))) + (ide-skel-dir path))) + +(defun ide-skel-file-open (widget &rest rest) + (let ((path (widget-get widget :path))) + (ide-skel-select-buffer path))) + +(defun ide-skel-dir-tree-widget (e) + "Return a widget to display file or directory E." + (if (file-directory-p e) + `(ide-skel-dir-tree-dir-widget + :path ,e + :help-echo ,e + :open ,(gethash e ide-skel-dir-open-paths) + :node (push-button + :tag ,(file-name-as-directory + (file-name-nondirectory e)) + :format "%[%t%]\n" + :notify ide-skel-dir-node-notify + :path ,e + :button-face (variable-pitch bold) + :help-echo ,e + :keymap ,tree-widget-button-keymap ; Emacs + )) + `(ide-skel-dir-tree-file-widget + :path ,e + :help-echo ,e + :tag ,(file-name-nondirectory e)))) + +(defun ide-skel-dir-get-buffer-create () + (let ((buffer (ide-skel-get-side-view-buffer-create " Ide Skel Dirs" + 'left "Dirs" "Filesystem browser" + (lambda (editor-buffer) t)))) + (with-current-buffer buffer + (setq ide-skel-tabbar-menu-function + (lambda () + (append + (list + (list 'ide-skel-dir-refresh "Refresh" t) + (when (and (buffer-file-name ide-skel-current-editor-buffer) + (fboundp 'ide-skel-proj-get-project-create) + (funcall 'ide-skel-project-p (car (funcall 'ide-skel-proj-get-project-create (buffer-file-name ide-skel-current-editor-buffer))))) + (list 'ide-skel-dir-project "Show project tree" t)) + (list 'ide-skel-dir-home "Home" t) + (list 'ide-skel-dir-filesystem-root "/" t) + ))) + ide-skel-dir-open-paths (make-hash-table :test 'equal) + ide-skel-dir-root-dir (file-truename (substitute-in-file-name "~"))) + (add-hook 'tree-widget-after-toggle-functions (lambda (widget) + (let ((path (widget-get widget :path))) + (when path + (if (widget-get widget :open) + (puthash path t ide-skel-dir-open-paths) + (remhash path ide-skel-dir-open-paths))))) + nil t)) + buffer)) + +(defun ide-skel-dir-tree-list (dir) + "Return the content of the directory DIR. +Return the list of components found, with sub-directories at the +beginning of the list." + (let (files dirs) + (dolist (entry (directory-files dir 'full)) + (unless (string-equal (substring entry -1) ".") + (if (file-directory-p entry) + (push entry dirs) + (push entry files)))) + (nreverse (nconc files dirs)))) + +(defun ide-skel-dir-tree-expand-dir (tree) + "Expand the tree widget TREE. +Return a list of child widgets." + (let ((dir (directory-file-name (widget-get tree :path)))) + (if (file-accessible-directory-p dir) + (progn + (message "Reading directory %s..." dir) + (condition-case err + (prog1 + (mapcar 'ide-skel-dir-tree-widget (ide-skel-dir-tree-list dir)) + (message "Reading directory %s...done" dir)) + (error + (message "%s" (error-message-string err)) + nil))) + (error "This directory is inaccessible")))) + +(defun ide-skel-select-dir-handler (event) + (interactive "@e") + (with-selected-window (posn-window (event-start event)) + (let* ((path (get-text-property (posn-point (event-start event)) 'path))) + (ide-skel-dir path)))) + +(defun ide-skel-dir-refresh (&optional show-top) + (interactive) + (with-current-buffer ide-skel-dir-buffer + (let ((inhibit-read-only t) + (start-line (save-excursion + (goto-char (window-start ide-skel-current-left-view-window)) + (line-number-at-pos)))) + (erase-buffer) + (let ((path-dirs (split-string (directory-file-name ide-skel-dir-root-dir) "[/\\]")) + (km (make-sparse-keymap)) + path) + (setq path-dirs (reverse (cdr (reverse path-dirs)))) + (define-key km [mouse-1] 'ide-skel-select-dir-handler) + (while path-dirs + (let ((dir (car path-dirs))) + (when (and (> (current-column) 0) + (>= (+ (current-column) (length dir) 1) (window-width ide-skel-current-left-view-window))) + (insert "\n")) + (setq path (directory-file-name (concat path (format "/%s" dir)))) + (unless (equal (char-before) ?/) + (insert "/")) + (insert (propertize dir + 'face 'bold + 'local-map km + 'mouse-face 'highlight + 'path path))) + (setq path-dirs (cdr path-dirs)))) + (insert "\n\n") + (tree-widget-set-theme "small-folder") + (let ((default-directory ide-skel-dir-root-dir) + (tree (ide-skel-dir-tree-widget (directory-file-name ide-skel-dir-root-dir)))) + (plist-put (cdr tree) :open t) + (widget-create tree)) + (set-keymap-parent (current-local-map) tree-widget-button-keymap) + (widget-setup) + (if show-top + (goto-char (point-min)) + (goto-line start-line)) + (beginning-of-line) + (set-window-start ide-skel-current-right-view-window (point)) + ))) + +(defun ide-skel-dir (root-dir) + (with-current-buffer ide-skel-dir-buffer + (clrhash ide-skel-dir-open-paths) + (setq ide-skel-dir-root-dir (file-truename (substitute-in-file-name root-dir))) + (ide-skel-dir-refresh t))) + +(defun ide-skel-dir-project () + (interactive) + (let ((root-dir (funcall 'ide-skel-project-root-path + (car (funcall 'ide-skel-proj-get-project-create (buffer-file-name ide-skel-current-editor-buffer)))))) + (message "Root dir: %S" root-dir) + (ide-skel-dir root-dir))) + +(defun ide-skel-dir-home () + (interactive) + (ide-skel-dir "~")) + +(defun ide-skel-dir-filesystem-root () + (interactive) + (ide-skel-dir "/")) + +(defun ide-skel-dirs-side-view-window-function (side event &rest list) + (when (and (eq side 'left) ide-skel-current-left-view-window) + (cond ((eq event 'show) + (unless ide-skel-dir-buffer + (setq ide-skel-dir-buffer (ide-skel-dir-get-buffer-create))) + (with-current-buffer ide-skel-dir-buffer + (setq ide-skel-tabbar-enabled t))) + ((and (eq event 'tab-change) + (eq (cadr list) ide-skel-dir-buffer) + (= (buffer-size ide-skel-dir-buffer) 0)) + (ide-skel-dir-refresh)))) + nil) + +(add-hook 'ide-skel-side-view-window-functions 'ide-skel-dirs-side-view-window-function) + +(easy-menu-add-item nil nil ide-skel-project-menu t) + +(defun ide-skel-proj-insert-with-face (string face) + (let ((point (point))) + (insert string) + (let ((overlay (make-overlay point (point)))) + (overlay-put overlay 'face face)))) + +(defun ide-skel-mode-name-stringify (mode-name) + (let ((name (format "%s" mode-name))) + (replace-regexp-in-string "-" " " + (capitalize + (if (string-match "^\\(.*\\)-mode" name) + (match-string 1 name) + name))))) + +(defun ide-skel-proj-get-all-dirs (root-dir) + (condition-case err + (split-string (shell-command-to-string (format "find %s -type d | grep -v '/CVS\\|/\\.svn'" root-dir)) + "\n" t) + (error nil))) + +(defun ide-skel-shell () + (interactive) + (when (fboundp 'ide-skel-show-bottom-view-window) + (funcall 'ide-skel-show-bottom-view-window) + (select-window (or (funcall 'ide-skel-get-bottom-view-window) + (selected-window))) + (ansi-term (or (getenv "ESHELL") (getenv "SHELL"))))) + +(defun ide-skel-project-menu (menu) + (let* ((curbuf-file (buffer-file-name (current-buffer))) + (curbuf-mode-name (when (and (buffer-file-name (current-buffer)) + (ide-skel-mode-file-regexp-list (list major-mode))) + (ide-skel-mode-name-stringify major-mode)))) + (condition-case err + (append + (when curbuf-mode-name + (list (vector (format "Search for %s file..." curbuf-mode-name) 'ide-skel-proj-find-files-by-regexp curbuf-mode-name))) + (list (vector "Search for file..." 'ide-skel-proj-find-text-files-by-regexp curbuf-mode-name)) + (when curbuf-mode-name + (list (vector (format "Grep %s files..." curbuf-mode-name) 'ide-skel-proj-grep-files-by-regexp curbuf-mode-name))) + (list (vector "Grep files..." 'ide-skel-proj-grep-text-files-by-regexp curbuf-file)) + (list (vector "Shell" 'ide-skel-shell t))) + (error (message (error-message-string err)))))) + +;; (ide-skel-project . relative-path) jesli path nalezy do projektu, +;; (qdir . filename) wpp + +(defun ide-skel-proj-get-project-create (path) + (let ((path (file-truename (substitute-in-file-name path))) + dir) + (if (file-directory-p path) + (progn + (setq path (file-name-as-directory path)) + (setq dir path)) + (setq dir (file-name-as-directory (file-name-directory path)))) + ;; path - true, qualified file name (no environment variables, ~, links) + (let ((project (some (lambda (project) + (let ((root-dir (ide-skel-project-root-path project))) + (when (string-match (concat "^" (regexp-quote root-dir)) path) + project))) + ide-skel-projects))) + (when project + (setq dir (ide-skel-project-root-path project))) + ;; there is no such project + (unless project + (let ((last-project-dir dir) + (dir-list (split-string dir "/")) + is-project) + ;; there is no root dir + (while (directory-files dir t (concat "^" ide-skel-cvs-dir-regexp) t) + (setq is-project t + last-project-dir (file-name-as-directory dir) + dir (file-name-as-directory (file-name-directory (directory-file-name dir))))) + (when is-project + (let ((list (nthcdr (1- (length (split-string last-project-dir "/"))) dir-list))) + (cond ((equal (car list) "trunk") + (setq last-project-dir (concat last-project-dir "trunk/"))) + ((member (car list) '("branches" "tags")) + (setq last-project-dir (concat last-project-dir (car list) "/" (when (cdr list) (concat (cadr list) "/"))))) + (t))) + (setq project (make-ide-skel-project :root-path last-project-dir + :include-file-path (ide-skel-proj-get-all-dirs last-project-dir)) + dir last-project-dir) + (push project ide-skel-projects)))) + (list (or project dir) (file-relative-name path dir) path)))) + +(defun ide-skel-proj-get-root (proj-or-dir) + (when proj-or-dir + (directory-file-name (file-truename (substitute-in-file-name + (if (ide-skel-project-p proj-or-dir) + (ide-skel-project-root-path proj-or-dir) + proj-or-dir)))))) + +(defun ide-skel-proj-find-files (dir file-predicate &optional dir-predicate) + "Return list of all qualified file paths in tree dir with root +DIR, for which FILE-PREDICATE returns non-nil. We will go into +directory only if DIR-PREDICATE returns non-nil or DIR-PREDICATE *is* nil." + (setq dir (file-name-as-directory (file-truename (substitute-in-file-name dir)))) + (let (result-list) + (mapcar (lambda (path) + (if (file-directory-p path) + (when (and (file-accessible-directory-p path) + (or (null dir-predicate) + (funcall dir-predicate path))) + (setq result-list (append result-list (ide-skel-proj-find-files path file-predicate dir-predicate)))) + (when (or (null file-predicate) + (funcall file-predicate path)) + (push path result-list)))) + (delete (concat (file-name-as-directory dir) ".") + (delete (concat (file-name-as-directory dir) "..") + (directory-files dir t nil t)))) + result-list)) + +(defun ide-skel-root-dir-for-path (path) + (let (root-dir) + (setq root-dir (car (ide-skel-proj-get-project-create path))) + (unless (stringp root-dir) + (setq root-dir (ide-skel-project-root-path root-dir))) + root-dir)) + +(defun ide-skel-has-imenu (&optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (or (and imenu-prev-index-position-function + imenu-extract-index-name-function) + imenu-generic-expression + (not (eq imenu-create-index-function + 'imenu-default-create-index-function))))) + +(defun ide-skel-mode-file-regexp-list (mode-symbol-list) + (delq nil (mapcar (lambda (element) + (let ((fun-name (if (listp (cdr element)) (cadr element) (cdr element)))) + (when (memq fun-name mode-symbol-list) (cons (car element) fun-name)))) + auto-mode-alist))) + +(defun ide-skel-find-project-files (root-dir mode-symbol-list predicate) + (let ((obj-file-regexp-list (delq nil (mapcar (lambda (element) + (let ((len (length element))) + (unless (and (> len 0) + (equal (elt element (1- len)) ?/)) + (concat (regexp-quote element) "$")))) + (append ide-skel-proj-ignored-extensions completion-ignored-extensions)))) + (mode-file-regexp-list (ide-skel-mode-file-regexp-list mode-symbol-list))) ; (file-path-regexp . major-mode-function-symbol) + (when (and mode-symbol-list + (not mode-file-regexp-list)) + (error (format "No rules for %s major modes in auto-mode-alist." (mapconcat 'identity mode-symbol-list ", ")))) + (ide-skel-proj-find-files root-dir + (lambda (file-name) + (and (not (string-match "#" file-name)) + (not (string-match "semantic.cache" file-name)) + (or (and (not mode-symbol-list) + (not (some (lambda (regexp) + (string-match regexp file-name)) + obj-file-regexp-list))) + (and mode-symbol-list + (some (lambda (element) + (let ((freg (if (string-match "[$]" (car element)) + (car element) + (concat (car element) "$")))) + (when (string-match freg file-name) + (cdr element)))) + mode-file-regexp-list))) + (or (not predicate) + (funcall predicate file-name)))) + (lambda (dir-path) + (not (string-match (concat "/" ide-skel-cvs-dir-regexp) dir-path)))))) + +(defun ide-skel-proj-find-text-files-by-regexp () + (interactive) + (unwind-protect + (progn + (setq ide-skel-all-text-files-flag t) + (call-interactively 'ide-skel-proj-find-files-by-regexp)) + (setq ide-skel-all-text-files-flag nil))) + +(defun ide-skel-proj-grep-text-files-by-regexp () + (interactive) + (unwind-protect + (progn + (setq ide-skel-all-text-files-flag t) + (call-interactively 'ide-skel-proj-grep-files-by-regexp)) + (setq ide-skel-all-text-files-flag nil))) + +(defun ide-skel-proj-grep-files-by-regexp (root-dir mode-symbol-list regexp) + (interactive (let* ((path (buffer-file-name (current-buffer))) + (all-text-files (or ide-skel-all-text-files-flag + (consp current-prefix-arg))) + (whatever (progn + (when (and (not all-text-files) + (not (ide-skel-mode-file-regexp-list (list major-mode)))) + (error (format "No rules for %s major mode in auto-mode-alist" (symbol-name major-mode)))) + (unless path + (error "Current buffer (%s) is not visiting any project file" (buffer-name (current-buffer)))))) + (root-dir (when path (ide-skel-root-dir-for-path path))) + (thing (let ((res (thing-at-point 'symbol))) + (set-text-properties 0 (length res) nil res) + res)) + (chunk (let ((result (read-string (concat (if root-dir (format "Root dir is %s. " root-dir) "") + (format "Search in %s files. Regexp%s: " + (if all-text-files + "all text" + (ide-skel-mode-name-stringify major-mode)) + (if thing (format " (default %s)" thing) ""))) + nil ide-skel-proj-grep-project-files-history thing))) + (if (and result (> (length result) 0)) + result + (error "Regexp cannot be null"))))) + (list root-dir (unless all-text-files (list major-mode)) chunk))) + (let* ((paths (ide-skel-find-project-files root-dir mode-symbol-list (lambda (path) t))) + (temp-file-path (concat (file-name-as-directory temporary-file-directory) (make-temp-name "ide-")))) + (unless paths + (error "No files to grep")) + ;; create temporary file with file paths to search + (with-temp-file temp-file-path + (dolist (path paths) + ;; save buffer if is open + (let ((buffer (get-file-buffer path))) + (when (and buffer + (buffer-live-p buffer)) + (with-current-buffer buffer + (save-buffer)))) + (setq path (concat "./" (file-relative-name path (file-name-as-directory root-dir)))) + (insert (concat "'" path "'\n")))) + (let* ((default-directory root-dir) + (grep-command (format "cat %s | xargs grep -n %s" temp-file-path regexp))) + (setq ide-skel-proj-grep-header (list root-dir + (if mode-symbol-list + (mapconcat (lambda (sym) (ide-skel-mode-name-stringify sym)) mode-symbol-list ", ") + "all text") + regexp)) + (grep grep-command)) + ;; delete file after some time, because grep is executed as external process + (run-with-idle-timer 5 nil (lambda (file-path) + (condition-case nil + nil ; (delete-file file-path) + (error nil))) + temp-file-path))) + +(defun ide-skel-proj-find-files-by-regexp (root-dir mode-symbol-list name-regexp &optional case-sensitive) + "Search directory tree with root in ROOT-DIR and returns +qualified paths to files which after open in Emacs would have one +of modes in MODE-SYMBOL-LIST (if list is empty, we will take all +text files) and their name (without dir) matches NAME-REGEXP." + (interactive (let* ((path (buffer-file-name (current-buffer))) + (all-text-files (or ide-skel-all-text-files-flag + (consp current-prefix-arg))) + (whatever (progn + (when (and (not all-text-files) + (not (ide-skel-mode-file-regexp-list (list major-mode)))) + (error (format "No rules for %s major mode in auto-mode-alist" (symbol-name major-mode)))) + (unless path + (error "Current buffer (%s) is not visiting any project file" (buffer-name (current-buffer)))))) + (root-dir (when path (ide-skel-root-dir-for-path path))) + (chunk (read-string (concat (if root-dir (format "Root dir is %s. " root-dir) "") + (if all-text-files + "F" + (concat (ide-skel-mode-name-stringify major-mode) " f")) + (format "ile name regexp: " )) + nil ide-skel-proj-find-project-files-history nil))) + (list root-dir (unless all-text-files (list major-mode)) chunk))) + (let* ((paths (ide-skel-find-project-files root-dir mode-symbol-list + (lambda (path) + (let ((case-fold-search (not case-sensitive))) + (or (not name-regexp) + (string-match name-regexp (file-name-nondirectory path))))))) + (buffer (get-buffer-create ide-skel-proj-find-results-buffer-name)) + (saved-window (cons (selected-window) (window-buffer (selected-window))))) + (if (= (length paths) 1) + (find-file (car paths)) + (save-selected-window + (save-excursion + (set-buffer buffer) + (setq buffer-read-only nil + default-directory root-dir) + (erase-buffer) + + (insert "Root dir: ") + (ide-skel-proj-insert-with-face root-dir 'font-lock-keyword-face) + (insert "; Range: ") + (ide-skel-proj-insert-with-face + (if mode-symbol-list + (mapconcat (lambda (sym) (ide-skel-mode-name-stringify sym)) mode-symbol-list ", ") + "all text") + 'font-lock-keyword-face) + (insert " files; Regexp: ") + (ide-skel-proj-insert-with-face name-regexp 'font-lock-keyword-face) + (insert "; Case sensitive: ") + (ide-skel-proj-insert-with-face (if case-sensitive "Yes" "No") 'font-lock-keyword-face) + (insert "\n\n") + (compilation-minor-mode 1) + (let ((invisible-suffix ":1:1 s")) + (put-text-property 0 (length invisible-suffix) 'invisible t invisible-suffix) + (dolist (path paths) + (let ((relative-path (file-relative-name path root-dir))) + (put-text-property 0 (length relative-path) 'mouse-face 'highlight relative-path) + (insert relative-path) + (insert invisible-suffix) + (insert "\n")))) + (insert (format "\n%d files found." (length paths))) + (goto-char (point-min)) + (setq buffer-read-only t) + (when (and paths (fboundp 'compile-reinitialize-errors) (funcall (symbol-function 'compile-reinitialize-errors) t))) + (switch-to-buffer-other-window buffer) + (goto-line 1) + (goto-line 3))) + (if (window-live-p (car saved-window)) + (select-window (car saved-window)) + (when (get-buffer-window (cdr saved-window)) + (select-window (get-buffer-window (cdr saved-window)))))))) + +(unless ide-skel-proj-grep-mode-map + (setq ide-skel-proj-grep-mode-map (make-sparse-keymap)) + (define-key ide-skel-proj-grep-mode-map "r" 'ide-skel-proj-grep-replace)) + +(defun ide-skel-proj-grep-replace () + (interactive) + (let ((replace-to (read-string "Replace to: " nil 'ide-skel-proj-grep-replace-history)) + (current-pos 1) + begin end + buffers-to-revert + replace-info) + (save-excursion + (while current-pos + (setq current-pos (next-single-property-change current-pos 'font-lock-face (current-buffer))) + (when (and current-pos + (eq (get-text-property current-pos 'font-lock-face) 'match)) + (setq begin current-pos) + (setq current-pos (next-single-property-change current-pos 'font-lock-face (current-buffer))) + (setq end current-pos) + (save-excursion + (goto-char begin) + (beginning-of-line) + (let ((begline (point))) + (re-search-forward "^\\(.*\\):\\([0-9]+\\):" nil t) + (let ((len (length (match-string 0))) + (file-path (expand-file-name (substring-no-properties (match-string 1)) default-directory))) + (when (get-file-buffer file-path) + (push (get-file-buffer file-path) buffers-to-revert)) + (push (list file-path + (string-to-number (match-string 2)) + (- begin begline len) + (- end begline len)) + replace-info))))))) + (dolist (replacement replace-info) + (let ((file-path (nth 0 replacement)) + (line-no (nth 1 replacement)) + (from-column-no (nth 2 replacement)) + (to-column-no (nth 3 replacement))) + (condition-case err + (with-temp-file file-path + (insert-file-contents file-path) + (goto-line line-no) + (forward-char from-column-no) + (delete-region (point) (+ (point) (- to-column-no from-column-no))) + (insert replace-to)) + (error (message "%s" (error-message-string err)))))) + (dolist (buffer buffers-to-revert) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (revert-buffer t t t)))) ; ignore-auto, nonconfirm, preserve-modes + (message "Done."))) + +(define-minor-mode ide-skel-proj-grep-mode + "" + nil ; init value + nil ; mode indicator + ide-skel-proj-grep-mode-map ; keymap + ;; body + (unless (assq 'ide-skel-proj-grep-mode minor-mode-map-alist) + (push (cons 'ide-skel-proj-grep-mode ide-skel-proj-grep-mode-map) minor-mode-map-alist))) + +(add-hook 'grep-setup-hook (lambda () + (when ide-skel-proj-grep-header + (ide-skel-proj-grep-mode 1) + (unwind-protect + (progn + (setq buffer-read-only nil) + (erase-buffer) + (remove-overlays) + (insert "Root dir: ") + (ide-skel-proj-insert-with-face (car ide-skel-proj-grep-header) 'font-lock-keyword-face) + (insert "; Range: ") + (ide-skel-proj-insert-with-face (cadr ide-skel-proj-grep-header) 'font-lock-keyword-face) + (insert " files; Regexp: ") + (ide-skel-proj-insert-with-face (caddr ide-skel-proj-grep-header) 'font-lock-keyword-face) + (insert "\n") + (insert "mouse-1 toggle match; r replace matches") + (insert "\n\n")) + (setq buffer-read-only t + ide-skel-proj-grep-header nil) + (setq ide-skel-proj-old-compilation-exit-message-function (symbol-value 'compilation-exit-message-function)) + (set 'compilation-exit-message-function + (lambda (status code msg) + (let ((result (if ide-skel-proj-old-compilation-exit-message-function + (funcall ide-skel-proj-old-compilation-exit-message-function + status code msg) + (cons msg code)))) + (save-excursion + (goto-char (point-min)) + (let (begin + end + (km (make-sparse-keymap)) + (inhibit-read-only t)) + (define-key km [down-mouse-1] 'ignore) + (define-key km [mouse-1] 'ide-skel-proj-grep-click) + (while (setq begin (next-single-property-change (point) 'font-lock-face (current-buffer) nil)) + (setq end (next-single-property-change begin 'font-lock-face (current-buffer) nil)) + (put-text-property begin end 'pointer 'hand) + (put-text-property begin end 'local-map km) + (goto-char end)))) + result))))))) + +(defun ide-skel-proj-grep-click (event) + (interactive "@e") + (with-selected-window (posn-window (event-start event)) + (let* ((posn-point (posn-point (event-start event))) + (begin (or (and (not (get-text-property (1- posn-point) 'font-lock-face)) + posn-point) + (previous-single-property-change posn-point 'font-lock-face (current-buffer) nil))) + (end (next-single-property-change posn-point 'font-lock-face (current-buffer) nil)) + (font-lock-face (get-text-property posn-point 'font-lock-face)) + (inhibit-read-only t)) + (put-text-property begin end 'font-lock-face (if (eq font-lock-face 'match) 'widget-field 'match))))) + +(defun ide-skel-proj-change-buffer-hook-function () + (let ((path (buffer-file-name))) + (when path + (condition-case err + (let ((project-list (ide-skel-proj-get-project-create path))) + (when (ide-skel-project-p (car project-list)) + (setq PC-include-file-path (ide-skel-project-include-file-path (car project-list))))) + (error nil))))) + +(add-hook 'ide-skel-editor-buffer-changed-hook 'ide-skel-proj-change-buffer-hook-function) + +(tabbar-mode 1) + +(provide 'ide-skel) + diff --git a/.emacs.d/elisp/lcars-theme.el b/.emacs.d/elisp/lcars-theme.el new file mode 100644 index 0000000..8c89fad --- /dev/null +++ b/.emacs.d/elisp/lcars-theme.el @@ -0,0 +1,411 @@ +;;; lcars-theme.el --- A color theme + +;; Copyright (C) 2011 Julien Danjou + +;; Authors: Julien Danjou <julien@danjou.info> + +;; This file is NOT part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Code: + +(deftheme lcars + "LCARS theme.") + + +;; We want the face to be created even if they do not exist. +(put 'lcars 'theme-immediate t) + +;; These colors are stolen from Tango. +(setq lcars-colors + '((((class color) (min-colors 65535)) + (lcars-1 . "#FF9900") + (lcars-2 . "#CC99CC") + (lcars-3 . "#9999CC") + (lcars-4 . "#CC6666") + (lcars-5 . "#FFCC99") + (lcars-6 . "#9999FF") + (lcars-7 . "#FF9966") + (lcars-8 . "#CC6699") + (lcars-background . "#000000") + (lcars-border . "#666666") + (lcars-selected . "#FFFFFF") + (lcars-red . "#FF0000") + (aluminium-1 . "#eeeeec") + (aluminium-2 . "#d3d7cf") + (aluminium-3 . "#babdb6") + (aluminium-4 . "#888a85") + (aluminium-5 . "#555753") + (aluminium-6 . "#2e3436") + (butter-1 . "#fce94f") + (butter-2 . "#edd400") + (butter-3 . "#c4a000") + (orange-1 . "#fcaf3e") + (orange-2 . "#f57900") + (orange-3 . "#ce5c00") + (chocolate-1 . "#e9b96e") + (chocolate-2 . "#c17d11") + (chocolate-3 . "#9f5902") + (chameleon-1 . "#8ae234") + (chameleon-2 . "#73d216") + (chameleon-3 . "#4e9a06") + (sky-blue-1 . "#729fcf") + (sky-blue-2 . "#3465a4") + (sky-blue-3 . "#204a87") + (plum-1 . "#ad7fa8") + (plum-2 . "#75507b") + (plum-3 . "#5c3566") + (scarlet-red-1 . "#ef2929") + (scarlet-red-2 . "#cc0000") + (scarlet-red-3 . "#a40000") + (background . "#252A2B") + (black . "#0c191C") + (gradient-1 . "#729fcf") ;; sky-blue-1 + (gradient-2 . "#8ae234") ;; chameleon-1 + (gradient-3 . "#fce94f") ;; butter-1 + (gradient-4 . "#ad7fa8") ;; plum-1 + (gradient-5 . "#e9b96e") ;; chocolate-1 + (gradient-6 . "#fcaf3e") ;; orange-1 + (gradient-7 . "#3465a4") ;; sky-blue-2 + (gradient-8 . "#73d216") ;; chameleon-2 + (gradient-9 . "#f57900") ;; orange-2 + (gradient-10 . "#75507b") ;; plum-2 + (gradient-11 . "#c17d11") ;; chocolate-2 + ) + (t + (aluminium-1 . "color-255") + (aluminium-2 . "color-253") + (aluminium-3 . "color-251") + (aluminium-4 . "color-245") + (aluminium-5 . "color-240") + (aluminium-6 . "color-235") + (butter-1 . "color-221") + (butter-2 . "color-220") + (butter-3 . "color-178") + (orange-1 . "color-214") + (orange-2 . "color-208") + (orange-3 . "color-130") + (chocolate-1 . "color-180") + (chocolate-2 . "color-172") + (chocolate-3 . "color-94") + (chameleon-1 . "color-82") + (chameleon-2 . "color-76") + (chameleon-3 . "color-34") + (sky-blue-1 . "color-117") + (sky-blue-2 . "color-63") + (sky-blue-3 . "color-24") + (plum-1 . "color-176") + (plum-2 . "color-96") + (plum-3 . "color-54") + (scarlet-red-1 . "color-196") + (scarlet-red-2 . "color-160") + (scarlet-red-3 . "color-124") + (background . "color-234") + (black . "color-16") + (gradient-1 . "color-117") ;; sky-blue-1 + (gradient-2 . "color-82") ;; chameleon-1 + (gradient-3 . "color-221") ;; butter-1 + (gradient-4 . "color-176") ;; plum-1 + (gradient-5 . "color-180") ;; chocolate-1 + (gradient-6 . "color-214") ;; orange-1 + (gradient-7 . "color-63") ;; sky-blue-2 + (gradient-8 . "color-76") ;; chameleon-2 + (gradient-9 . "color-208") ;; orange-2 + (gradient-10 . "color-96") ;; plum-2 + (gradient-11 . "color-172") ;; chocolate-2 + ))) +; "The color values for each color name for a given +; condition. The format is: ((condition) (key . value) (key +; . value) ...)") + +(defun lcars-get-colors (name) + (cdr + (assoc + name + (car lcars-colors)))) + +(setq ansi-term-color-vector + `[unspecified ,(lcars-get-colors 'black) + ,(lcars-get-colors 'scarlet-red-1) + ,(lcars-get-colors 'chameleon-1) + ,(lcars-get-colors 'butter-1) + ,(lcars-get-colors 'sky-blue-1) + ,(lcars-get-colors 'plum-1) + "cyan3" + ,(lcars-get-colors 'aluminium-1)]) + +(defun lcars-simple-face-to-multiple (face) + (let ((spec (car face)) + (lst (cadr face))) + (list spec (mapcar + '(lambda (entry) + (let ((color-condition (car entry))) + (list color-condition + (lcars-color-list-expand (cdr entry) lst)))) + lcars-colors)))) + +(defun lcars-color-list-expand (color-alist lst) + (let ((result '())) + (while (car lst) + (let ((key (car lst)) + (val (cadr lst))) + (if (memq key '(:foreground :background :color)) + (setq val (or (cdr (assq val color-alist)) val))) + (if (listp val) + (setq val (lcars-color-list-expand entry val))) + (setq result (append result `(,key ,val)))) + (setq lst (cddr lst))) + result)) + +(defun lcars-theme-set-faces (theme &rest args) + (apply 'custom-theme-set-faces + (append (list theme) + (mapcar 'lcars-simple-face-to-multiple args)))) + +(lcars-theme-set-faces + 'lcars + '(default (:background lcars-background :foreground lcars-1)) + '(shadow (:foreground lcars-border)) + '(secondary-selection (:background lcars-red)) + '(cursor (:background lcars-1)) + '(hl-line (:foreground lcars-selected)) + '(highlight (:foreground lcars-selected)) + '(fringe (:background lcars-background)) + '(mode-line (:foreground lcars-1 :background lcars-background + :box (:line-width 1 :color lcars-border))) + '(mode-line-inactive (:foreground lcars-1 :background lcars-background + :box nil)) + '(mode-line-buffer-id (:bold t :foreground lcars-2)) + '(header-line (:foreground lcars-1 :background lcars-background + :box (:line-width 1 :color lcars-border))) + '(region (:background lcars-border)) + '(link (:foreground lcars-2)) + '(link-visited (:inherit 'link :foreground lcars-4)) + '(match (:bold t :foreground lcars-selected)) + '(tooltip (:inherit 'variable-pitch :foreground aluminium-1 :background black)) + '(bold (:bold t)) + '(italic (:italic t)) + + '(font-lock-builtin-face (:foreground lcars-6)) + '(font-lock-keyword-face (:inherit 'font-lock-builtin-face :bold t)) + '(font-lock-comment-face (:inherit 'shadow :italic t)) + '(font-lock-comment-delimiter-face (:inherit 'font-lock-comment-face)) + '(font-lock-constant-face (:foreground lcars-4)) + '(font-lock-type-face (:inherit 'font-lock-constant-face :bold t)) + '(font-lock-doc-face (:inherit 'shadow)) + '(font-lock-string-face (:foreground lcars-3)) + '(font-lock-variable-name-face (:foreground lcars-8)) + '(font-lock-warning-face (:bold t :foreground lcars-red)) + '(font-lock-function-name-face (:foreground lcars-2 :bold t)) + + '(comint-highlight-prompt ()) + + '(isearch (:background orange-3 :foreground background)) + '(isearch-fail (:background scarlet-red-2)) + '(lazy-highlight (:background chocolate-1 :foreground background)) + + '(show-paren-match-face (:background chameleon-3)) + '(show-paren-mismatch-face (:background plum-3)) + + '(minibuffer-prompt (:foreground sky-blue-1 :bold t)) + + ;; '(widget-mouse-face ((t (:bold t :foreground aluminium-1 :background scarlet-red-2)))) + ;; '(widget-field ((t (:foreground orange-1 :background "gray30")))) + ;; '(widget-single-line-field ((t (:foreground orange-1 :background "gray30")))) + + '(custom-group-tag (:bold t :foreground orange-2 :height 1.3)) + '(custom-variable-tag (:bold t :foreground butter-2 :height 1.1)) + '(custom-face-tag (:bold t :foreground butter-2 :height 1.1)) + '(custom-state (:foreground sky-blue-1)) + ;; '(custom-button ((t :background "gray50" :foreground black + ;; :box (:line-width 1 :style released-button)))) + ;; '(custom-variable-button ((t (:inherit 'custom-button)))) + ;; '(custom-button-mouse ((t (:inherit 'custom-button :background "gray60")))) + ;; '(custom-button-unraised ((t (:background "gray50" :foreground "black")))) + ;; '(custom-button-mouse-unraised ((t (:inherit 'custom-button-unraised :background "gray60")))) + ;; '(custom-button-pressed ((t (:inherit 'custom-button :box (:style pressed-button))))) + ;; '(custom-button-mouse-pressed-unraised ((t (:inherit 'custom-button-unraised :background "gray60")))) + '(custom-documentation (:inherit 'font-lock-comment-face)) + + '(gnus-cite-1 (:foreground gradient-1)) + '(gnus-cite-2 (:foreground gradient-2)) + '(gnus-cite-3 (:foreground gradient-3)) + '(gnus-cite-4 (:foreground gradient-4)) + '(gnus-cite-5 (:foreground gradient-5)) + '(gnus-cite-6 (:foreground gradient-6)) + '(gnus-cite-7 (:foreground gradient-7)) + '(gnus-cite-8 (:foreground gradient-8)) + '(gnus-cite-9 (:foreground gradient-9)) + '(gnus-cite-10 (:foreground gradient-10)) + '(gnus-cite-11 (:foreground gradient-11)) + '(gnus-header-name (:bold t :foreground sky-blue-1)) + '(gnus-header-from (:bold t)) + '(gnus-header-to (:bold t :foreground aluminium-2)) + '(gnus-header-subject ()) + '(gnus-header-content (:italic t :foreground aluminium-2)) + '(gnus-header-newsgroups (:inherit 'gnus-header-to)) + '(gnus-signature (:italic t :foreground aluminium-3)) + '(gnus-summary-cancelled (:background black :foreground butter-1)) + '(gnus-summary-normal-ancient (:foreground chameleon-3)) + '(gnus-summary-normal-read (:foreground chameleon-1)) + '(gnus-summary-normal-ticked (:foreground scarlet-red-1)) + '(gnus-summary-normal-unread (:foreground aluminium-1)) + '(gnus-summary-high-ancient (:inherit 'gnus-summary-normal-ancient)) + '(gnus-summary-high-read (:inherit 'gnus-summary-normal-read)) + '(gnus-summary-high-ticked (:inherit 'gnus-summary-normal-ticked)) + '(gnus-summary-high-unread (:inherit 'gnus-summary-normal-unread)) + '(gnus-summary-low-ancient (:inherit 'gnus-summary-normal-ancient :italic t)) + '(gnus-summary-low-read (:inherit 'gnus-summary-normal-read :italic t)) + '(gnus-summary-low-ticked (:inherit 'gnus-summary-normal-ticked :italic t)) + '(gnus-summary-low-unread (:inherit 'gnus-summary-normal-unread :italic t)) + '(gnus-summary-selected (:background sky-blue-3 :foreground aluminium-1)) + '(gnus-button (:bold t :foreground aluminium-2)) + '(spam (:background black :foreground orange-2)) + + '(message-header-newsgroups (:inherit gnus-header-newsgroups)) + '(message-header-name (:inherit 'gnus-header-name)) + '(message-header-to (:inherit gnus-header-to)) + '(message-header-other (:inherit gnus-header-content)) + '(message-header-subject (:inherit 'gnus-header-subject)) + '(message-header-cc (:foreground aluminium-2)) + '(message-header-xheader (:foreground aluminium-4)) + '(message-separator (:foreground sky-blue-3)) + '(message-mml (:foreground chameleon-1)) + + ;; org-mode + '(org-level-1 (:bold t :foreground lcars-1 :height 1.3)) + '(org-level-2 (:bold t :foreground lcars-2 :height 1.2)) + '(org-level-3 (:bold t :foreground lcars-3 :height 1.1)) + '(org-level-4 (:bold t :foreground lcars-4)) + '(org-level-5 (:bold t :foreground lcars-5)) + '(org-level-6 (:bold t :foreground lcars-6)) + '(org-level-7 (:bold t :foreground lcars-7)) + '(org-level-8 (:bold t :foreground lcars-8)) + + '(org-mode-line-clock ()) + '(org-mode-line-clock-overrun (:foreground scarlet-red-1)) + '(org-document-title (:bold t :foreground sky-blue-1 :height 1.4)) + '(org-document-info (:foreground sky-blue-1 :italic t)) + '(org-todo (:bold t :foreground scarlet-red-2)) + '(org-done (:bold t :foreground chameleon-3)) + '(org-hide (:foreground background)) + '(org-scheduled (:foreground chameleon-2)) + '(org-scheduled-previously (:foreground orange-2)) + '(org-scheduled-today (:foreground chameleon-1)) + '(org-date (:foreground chocolate-1)) + '(org-special-keyword (:foreground scarlet-red-1 :bold t)) + '(org-agenda-done ()) + '(org-time-grid (:inherit 'shadow)) + '(org-agenda-date (:foreground butter-1 :height 1.2)) + '(org-agenda-date-today (:inherit 'org-agenda-date :foreground butter-2 :weight bold :height 1.3)) + '(org-agenda-date-tc (:inherit 'org-agenda-date :foreground butter-3)) + '(org-agenda-date-weekend (:inherit 'org-agenda-date :foreground scarlet-red-1 :weight bold)) + + '(org-habit-clear-future-face (:background sky-blue-3)) + '(org-habit-clear-face (:background sky-blue-2)) + '(org-habit-ready-future-face (:background chameleon-3)) + '(org-habit-ready-face (:background chameleon-2 :foreground black)) + '(org-habit-alert-ready-future-face (:background orange-3)) + '(org-habit-overdue-face (:background scarlet-red-3)) + '(org-habit-overdue-future-face (:background scarlet-red-3)) + + ;; egocentric-mode + '(egocentric-face (:foreground scarlet-red-1 :weight bold)) + + ;; erc + '(erc-direct-msg-face (:inherit 'egocentric-face)) + '(erc-header-line (:inherit 'header-line)) + '(erc-input-face (:inherit 'shadow)) + '(erc-my-nick-face (:inherit 'egocentric-face)) + '(erc-notice-face (:foreground sky-blue-1)) + '(erc-prompt-face (:background black :foreground aluminium-1 :weight bold)) + '(erc-timestamp-face (:foreground aluminium-2 :weight bold)) + '(erc-pal-face (:foreground chameleon-1 :weight bold)) + '(erc-keyword-face (:foreground orange-1)) + '(erc-fool-face (:inherit 'shadow)) + '(erc-current-nick-face (:inherit 'egocentric-face)) + + '(which-func (:foreground sky-blue-1)) + + '(dired-directory (:foreground sky-blue-1)) + '(dired-symlink (:bold t :foreground "cyan")) + '(dired-marked (:bold t :foreground butter-1)) + + '(mm-uu-extract (:background aluminium-6)) + + ;; diff-mode + '(diff-added (:foreground chameleon-2)) + '(diff-changed (:foreground orange-1)) + '(diff-removed (:foreground scarlet-red-1)) + '(diff-hunk-header (:bold t)) + '(diff-function (:foreground orange-1)) + '(diff-header (:background aluminium-6)) + '(diff-file-header (:foreground aluminium-1)) + + ;; magit + '(magit-diff-add (:inherit diff-added)) + '(magit-diff-del (:inherit diff-removed)) + '(magit-diff-none (:inherit diff-context)) + '(magit-diff-hunk-header (:inherit (magit-header diff-hunk-header))) + '(magit-diff-file-header (:inherit (magit-header diff-file-header))) + '(magit-log-sha1 (:foreground scarlet-red-1)) + '(magit-log-graph (:foreground aluminium-2)) + '(magit-item-highlight (:background aluminium-6)) + '(magit-item-mark (:foreground orange-1)) + '(magit-log-tag-label (:background chameleon-3 :box t :foreground aluminium-6)) + '(magit-log-head-label-bisect-good (:background chameleon-2 :box t)) + '(magit-log-head-label-bisect-bad (:background scarlet-red-3 :box t)) + '(magit-log-head-label-remote (:foreground aluminium-6 :background butter-2 :box (:color butter-3))) + '(magit-log-head-label-tags (:inherit (magit-log-tag-label))) + '(magit-log-head-label-local (:foreground aluminium-1 :background sky-blue-2 + :box (:color sky-blue-3))) + + + ;; git-commit-mode + '(git-commit-summary-face (:bold t)) + '(git-commit-branch-face (:foreground orange-2 :bold t)) + '(git-commit-nonempty-second-line-face ((:foreground scarlet-red-2))) + '(git-commit-comment-face (:inherit font-lock-comment-face)) + '(git-commit-known-pseudo-header-face (:inherit gnus-header-name-face)) + '(git-commit-pseudo-header-face (:inherit gnus-header-content)) + + ;; makefile-mode + '(makefile-space (:background plum-3)) + + ;; rainbow-delimiters + '(rainbow-delimiters-depth-1-face (:foreground lcars-8)) + '(rainbow-delimiters-depth-2-face (:foreground lcars-7)) + '(rainbow-delimiters-depth-3-face (:foreground lcars-6)) + '(rainbow-delimiters-depth-4-face (:foreground lcars-5)) + '(rainbow-delimiters-depth-5-face (:foreground lcars-4)) + '(rainbow-delimiters-depth-6-face (:foreground lcars-3)) + '(rainbow-delimiters-depth-7-face (:foreground lcars-2)) + '(rainbow-delimiters-depth-8-face (:foreground lcars-1)) + + ;; rst-mode + '(rst-level-1-face (:foreground gradient-1 :height 1.3)) + '(rst-level-2-face (:foreground gradient-2 :height 1.2)) + '(rst-level-3-face (:foreground gradient-3 :height 1.1)) + '(rst-level-4-face (:foreground gradient-4)) + '(rst-level-5-face (:foreground gradient-5)) + '(rst-level-6-face (:foreground gradient-6))) + +(provide-theme 'lcars) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; lcars-theme.el ends here diff --git a/.emacs.d/elisp/lua-mode b/.emacs.d/elisp/lua-mode new file mode 160000 +Subproject 3367502fc1bddb78f33a7ccc833a92e7285d9bb diff --git a/.emacs.d/elisp/markdown-mode b/.emacs.d/elisp/markdown-mode new file mode 160000 +Subproject 2909154d8a1e42d9aee16530312e7764ad74da9 diff --git a/.emacs.d/elisp/muttrc-mode.el b/.emacs.d/elisp/muttrc-mode.el new file mode 100644 index 0000000..b3bdd2c --- /dev/null +++ b/.emacs.d/elisp/muttrc-mode.el @@ -0,0 +1,1638 @@ +;;; muttrc-mode.el --- Major mode to edit muttrc under Emacs + +;;; Copyright (C) 2000, 2001, 2002 Laurent Pelecq +;;; Copyright (C) 2009 Kumar Appaiah +;;; +;;; Authors: Laurent Pelecq <laurent.pelecq@soleil.org> +;;; Kumar Appaiah <a.kumar@alumni.iitm.ac.in> + +;;; 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. + +;;; Supported Emacs: +;;; ================ +;;; This mode has only been tested on Emacs 21.2. If you +;;; encounter problems with older versions or with Xemacs, let me +;;; know. + +;;; Installation: +;;; ============= +;;; Add this lines to your .emacs: +;;; (autoload 'muttrc-mode "muttrc-mode.el" +;;; "Major mode to edit muttrc files" t) +;;; (setq auto-mode-alist +;;; (append '(("muttrc\\'" . muttrc-mode)) +;;; auto-mode-alist)) +;;; Be sure this file is in a directory that appears in the load-path. +;;; +;;; You mail want to use this mode for other files like the mail +;;; aliases file. In that case just add the following lines at the end +;;; of these files: +;;; ### Local Variables: *** +;;; ### mode: muttrc *** +;;; ### End: *** + +;;; Customization: +;;; ============== +;;; Execute: M-x configure-group RET muttrc RET +;;; +;;; By default, help on command/variable is displayed automatically +;;; while executing a command to modify them. Disable this feature if +;;; you have problems with. + +;;; Description: +;;; ============ +;;; This mode first goal is to provide syntax highlighting with +;;; font-lock. The basic fontification appears on strings, comments, +;;; command names and variables. Additional fontification for commands +;;; arguments can be enabled through the customization buffer. +;;; +;;; Main commands are: +;;; C-x c -- muttrc-insert-command +;;; C-x s -- muttrc-set-variable +;;; C-x S -- muttrc-unset-variable +;;; +;;; Type C-h m for all key bindings. + +;;; BUGS: +;;; ===== +;;; - Multiline commands are not properly handled and can lead to +;;; unexpected result. + + + +;;; Code: + +;;; ------------------------------------------------------------ +;;; Requirement +;;; ------------------------------------------------------------ + +(require 'man) + +(defconst muttrc-mode-version "$Revision: 1.2 $") + +;;; ------------------------------------------------------------ +;;; Configurable stuff +;;; ------------------------------------------------------------ + +(defgroup muttrc nil + "Muttrc editing commands for Emacs." + :group 'files + :prefix "muttrc-") + +(defcustom muttrc-manual-path "/usr/share/doc/mutt/manual.txt.gz" + "Path to the Mutt manual." + :type 'string + :group 'muttrc) + +(defcustom muttrc-display-help t + "Display help for each command/variable modification if set." + :type 'boolean + :group 'muttrc) + +(defcustom muttrc-folder-abbrev ?+ + "Character used to refer to the folder directory." + :type '(choice (const :tag "+" ?+) + (const :tag "=" ?=)) + :group 'muttrc) + +(defcustom muttrc-argument-faces-alist + '((alias . bold) + (address . default) + (face . default) + (color . default) + (command . default) + (path . default) + (function . default) + (header . default) + (hook . default) + (key . default) + (map . default) + (mimetype . default) + (object . default) + (regexp . default) + (sequence . default) + (string . default) + (hook-type . default)) + "List of faces for the Muttrc command arguments. Standard faces are +symbols like 'bold, 'underline, ... Muttrc files must be revisited in +order for the modifications to take effect." + :type '(repeat (cons symbol symbol)) + :group 'muttrc) + +;;; ------------------------------------------------------------ +;;; For backward compatibility +;;; ------------------------------------------------------------ + +(or (functionp 'match-string-no-properties) + (defalias 'match-string-no-properties 'match-string)) + +;;; ------------------------------------------------------------ +;;; Mutt variables and commands +;;; ------------------------------------------------------------ + +(defconst muttrc-arg-handler-alist + '((alias muttrc-get-word "Alias") + (boolean muttrc-get-boolean "Enable") + (number muttrc-get-number "Number") + (address muttrc-get-string "Address") + (face muttrc-get-from-list "Face" muttrc-face-alist t) + (color muttrc-get-from-list "Color" muttrc-color-alist) + (command muttrc-get-command "Command") + (statement muttrc-get-statement "Command") + (assignment muttrc-get-assignment "Variable" t) + (variable muttrc-get-assignment "Variable" nil) + (path muttrc-get-path "Path") + (function muttrc-get-from-list "Function" muttrc-mutt-function-alist) + (header muttrc-get-from-list "Header name" muttrc-header-alist) + (hook-type muttrc-get-from-list "Hook" muttrc-hook-alist t) + (key muttrc-get-string "Key") + (map muttrc-get-from-list "Map" muttrc-map-alist t) + (mimetype muttrc-get-from-list "MIME type" muttrc-mimetype-alist) + (object muttrc-get-from-list "Object" muttrc-object-alist) + (regexp muttrc-get-string "Regular expression") + (sequence muttrc-get-string "Sequence") + (string muttrc-get-string "String") + (alias-sort-order muttrc-get-from-list "Sort order" + muttrc-alias-sort-order-alist) + (aux-sort-order muttrc-get-from-list "Sort order" + muttrc-aux-sort-order-alist) + (browser-sort-order muttrc-get-from-list "Sort order" + muttrc-browser-sort-order-alist) + (pgp-sort-order muttrc-get-from-list "Sort order" + muttrc-pgp-sort-order-alist) + (quadoption muttrc-get-from-list "Option" muttrc-quadoption-alist) + (sort-order muttrc-get-from-list "Sort order" + muttrc-sort-order-alist)) + "List of handler for each type of argument. The format is: +\(ARG-TYPE FACE HANDLER PROMPT HANDLER-ARGS\). +The PROMPT can be overwritten by in command description.") + +(defconst muttrc-face-alist + '(("none" . 1) ("bold" . 2) ("underline" . 3) + ("reverse" . 4) ("standout". 5))) + +(defconst muttrc-color-alist + '(("default" . 0) + ("black" . 1) ("blue" . 2) ("cyan" . 3) ("green" . 4) + ("magenta" . 5) ("red" . 6) ("white" . 7) ("yellow" . 8) + ("brightdefault" . 9) + ("brightblack" . 10) ("brightblue" . 11) ("brightcyan" . 12) + ("brightgreen" . 13) ("brightmagenta" . 14) ("brightred" . 15) + ("brightwhite" . 16) ("brightyellow" . 17))) + +(defconst muttrc-object-alist + '(("attachment" . 0) + ("body" . 1) + ("bold" . 2) + ("error" . 3) + ("hdrdefault" . 4) + ("header" . 5) + ("index" . 6) + ("indicator" . 7) + ("markers" . 8) + ("message" . 9) + ("normal" . 10) + ("quoted" . 11) + ("search" . 12) + ("signature" . 13) + ("status" . 14) + ("tilde" . 15) + ("tree" . 16) + ("underline" . 17)) + "Mutt object on which color apply.") + +(defconst muttrc-header-alist + '(("content-transfer-encoding" . 0) + ("content-type" . 1) + ("date" . 2) + ("from" . 3) + ("message-id" . 4) + ("mime-version" . 5) + ("organization" . 6) + ("received" . 7) + ("reply-to" . 8) + ("resent-from" . 9) + ("subject" . 10) + ("to" . 11) + ("x-accept-language" . 12) + ("x-mailer" . 13) + ("x-mimetrack" . 14) + ("x-sender" . 15))) + +(defconst muttrc-hook-alist + '(("folder-hook" . 0) ("send-hook" . 1) ("save-hook" . 2) + ("mbox-hook" . 3) ("fcc-hook" . 4) ("fcc-save-hook" . 5) + ("message-hook" . 5) ("charset-hook" . 6) ("iconv-hook" . 7) + ("account-hook" . 8) ("append-hook" . 9) ("close-hook" . 10) + ("crypt-hook" . 11) ("send2-hook" . 12) ("reply-hook" . 13) + ("open-hook" . 14))) + +(defconst muttrc-map-alist + '(("alias" . 0) ("attach" . 1) ("browser" . 2) ("compose" . 3) + ("editor" . 4) ("generic" . 5) ("index" . 6) ("pager" . 7) + ("pgp" . 8) ("postpone" . 9) ("query" . 10))) + +(defconst muttrc-mimetype-alist + '(("application/andrew-inset" "ez") + ("application/excel" "xls") + ("application/fractals" "fif") + ("application/java-archive" "jar") + ("application/mac-binhex40" "hqx") + ("application/msword" "doc" "dot") + ("application/octet-stream" "exe" "bin") + ("application/oda" "oda") + ("application/pdf" "pdf") + ("application/pdf") + ("application/pgp" "pgp") + ("application/postscript" "ai" "eps" "ps" "PS") + ("application/pre-encrypted" "enc") + ("application/rtf" "rtf") + ("application/vnd.lotus-wordpro" "lwp" "sam") + ("application/vnd.ms-access" "mdb" "mda" "mde") + ("application/vnd.ms-excel" "xls") + ("application/vnd.ms-powerpoint" "ppt" "pot" "ppa" "pps" "pwz") + ("application/vnd.ms-schedule" "scd" "sch" "sc2") + ("application/wordperfect5.1" "wpd" "wp6") + ("application/x-arj-compressed" "arj") + ("application/x-bcpio" "bcpio") + ("application/x-chess-pgn" "pgn") + ("application/x-cpio" "cpio") + ("application/x-csh" "csh") + ("application/x-debian-package" "deb") + ("application/x-dvi" "dvi") + ("application/x-fortezza-ckl" "ckl") + ("application/x-gtar" "gtar") + ("application/x-gunzip" "gz") + ("application/x-hdf" "hdf") + ("application/x-javascript" "js" "mocha") + ("application/x-javascript-config" "jsc") + ("application/x-latex" "latex") + ("application/x-mif" "mif") + ("application/x-msdos-program" "com" "exe" "bat") + ("application/x-netcdf" "cdf" "nc") + ("application/x-ns-proxy-autoconfig" "pac") + ("application/x-ns-proxy-autoconfig") + ("application/x-perl" "pl" "pm") + ("application/x-pkcs7-crl" "crl") + ("application/x-pkcs7-mime" "p7m" "p7c") + ("application/x-pkcs7-signature" "p7s") + ("application/x-rar-compressed" "rar") + ("application/x-sh" "sh") + ("application/x-shar" "shar") + ("application/x-stuffit" "sit") + ("application/x-sv4cpio" "sv4cpio") + ("application/x-sv4crc" "sv4crc") + ("application/x-tar" "tar") + ("application/x-tar-gz" "tgz" "tar.gz") + ("application/x-tcl" "tcl") + ("application/x-tex" "tex") + ("application/x-texinfo" "texi" "texinfo") + ("application/x-troff" "t" "tr" "roff") + ("application/x-troff-man" "man") + ("application/x-troff-me" "me") + ("application/x-troff-ms" "ms") + ("application/x-ustar" "ustar") + ("application/x-wais-source" "src") + ("application/x-zip-compressed" "zip") + ("audio/basic" "au" "snd") + ("audio/basic" "snd") + ("audio/midi" "mid" "midi") + ("audio/ulaw" "au") + ("audio/x-aiff" "aif" "aifc" "aiff") + ("audio/x-aiff" "aif" "aiff" "aifc") + ("audio/x-wav" "wav") + ("image/gif" "gif") + ("image/ief" "ief") + ("image/jpeg" "jpe" "jpeg" "jpg") + ("image/png" "png") + ("image/tiff" "tif" "tiff") + ("image/tiff") + ("image/x-MS-bmp" "bmp") + ("image/x-cmu-raster" "ras") + ("image/x-photo-cd" "pcd") + ("image/x-portable-anymap" "pnm") + ("image/x-portable-bitmap" "pbm") + ("image/x-portable-graymap" "pgm") + ("image/x-portable-pixmap" "ppm") + ("image/x-rgb" "rgb") + ("image/x-xbitmap" "xbm") + ("image/x-xpixmap" "xpm") + ("image/x-xwindowdump" "xwd") + ("text/html" "html" "htm" "shtml") + ("text/plain" "txt" "text") + ("text/richtext" "rtx") + ("text/tab-separated-values" "tsv") + ("text/x-setext" "etx") + ("text/x-vcard" "vcf") + ("text/x-vcard") + ("video/dl" "dl") + ("video/fli" "fli") + ("video/gl" "gl") + ("video/mpeg" "mpeg" "mpg" "mpe" "mpv" "vbs" "mpegv") + ("video/quicktime" "qt" "mov" "moov") + ("video/x-msvideo" "avi") + ("video/x-sgi-movie" "movie") + ("x-world/x-vrml" "vrm" "vrml" "wrl"))) + +(defconst muttrc-command-alist + '( + ("folder-hook" ((string) (statement)) nil nil) + ("alias" ((alias) (address)) t nil) + ("unalias" ((alias) (address)) t nil) + ("alternative_order" ((mimetype)) t nil) + ("auto_view" ((mimetype)) t nil) + ("bind" ((map) (key) (function)) nil t) + ("color" ((object) + (color "Foreground") + (color "Background") + (regexp)) nil t) + ("charset-hook" ((string "Alias") + (string "Charset")) nil nil) + ("fcc-hook" ((regexp) (path)) nil nil) + ("fcc-save-hook" ((regexp) (path)) nil nil) + ("folder-hook" ((regexp) (statement)) nil nil) + ("ignore" ((header)) t nil) + ("iconv-hook" ((string "Charset") + (string "Local charset")) nil nil) + ("unignore" ((header)) t nil) + ("hdr_order" ((header)) t nil) + ("unhdr_order" ((header)) t nil) + ("lists" ((address)) t nil) + ("unlists" ((address)) t nil) + ("macro" ((map) (key) (sequence) + (string "Description")) nil t) + ("mailboxes" ((path)) t nil) + ("mono" ((object) (face) (regexp)) nil t) + ("mbox-hook" ((regexp) (path)) nil nil) + ("message-hook" ((regexp) (statement)) nil nil) + ("my_hdr" ((string "Header")) nil nil) + ("unmy_hdr" ((header)) t nil) + ("push" ((string)) nil nil) + ("pgp-hook" ((regexp) + (string "Keyid")) nil nil) + ("save-hook" ((regexp) (path)) nil nil) + ("score" ((regexp) + (number "Value")) nil nil) + ("unscore" ((regexp)) t nil) + ("send-hook" ((regexp) (statement)) nil nil) + ("source" ((path)) nil nil) + ("subscribe" ((address)) t nil) + ("unsubscribe" ((address)) t nil) + ("unhook" ((hook-type)) nil nil) + ("alternates" ((regexp)) nil nil) + ("unalternates" ((regexp)) nil nil)) + "List of muttrc commands with their arguments. Format is: +COMMAND '\(ARG1 ARG2 ...\) REPEAT OPTIONAL +REPEAT and OPTIONAL apply to the last argument. +ARGn is the list of arguments for muttrc-call-arg-handler. Each args +is a list \(ARGTYPE \[ARGNAME\]\).") + +(defconst muttrc-statement-alist + (append + '(("set" ((assignment)) t nil) + ("unset" ((variable)) t nil)) + muttrc-command-alist) + "Additional muttrc commands with their arguments that are handled +differently. See muttrc-command-alist") + + +(defconst muttrc-variables-alist + '(("abort_nosubject" quadoption "ask-yes") + ("abort_unmodified" quadoption "yes") + ("alias_file" path "~/.muttrc") + ("alias_format" string "%4n %2f %t %-10a %r") + ("allow_8bit" boolean t) + ("allow_ansi" boolean nil) + ("arrow_cursor" boolean nil) + ("ascii_chars" boolean nil) + ("askbcc" boolean nil) + ("askcc" boolean nil) + ("assumed_charset" string "us-ascii") + ("attach_format" string "%u%D%I %t%4n %T%.40d%> [%.7m/%.10M, %.6e%?C?, %C?, %s] ") + ("attach_sep" string "\\n") + ("attach_split" boolean t) + ("attribution" string "On %d, %n wrote:") + ("autoedit" boolean nil) + ("auto_tag" boolean nil) + ("beep" boolean t) + ("beep_new" boolean nil) + ("bounce" quadoption "ask-yes") + ("bounce_delivered" boolean t) + ("braille_friendly" boolean nil) + ("charset" string "") + ("check_new" boolean t) + ("collapse_unread" boolean t) + ("uncollapse_jump" boolean nil) + ("compose_format" string "-- Mutt: Compose [Approx. msg size: %l Atts: %a]%>-") + ("config_charset" string "") + ("confirmappend" boolean t) + ("confirmcreate" boolean t) + ("connect_timeout" number 30) + ("content_type" string "text/plain") + ("copy" quadoption "yes") + ("crypt_use_gpgme" boolean nil) + ("crypt_autopgp" boolean t) + ("crypt_autosmime" boolean t) + ("date_format" string "!%a, %b %d, %Y at %I:%M:%S%p %Z") + ("default_hook" string "~f %s !~P | (~P ~C %s)") + ("delete" quadoption "ask-yes") + ("delete_untag" boolean t) + ("digest_collapse" boolean t) + ("display_filter" path "") + ("dotlock_program" path "/usr/bin/mutt_dotlock") + ("dsn_notify" string "") + ("dsn_return" string "") + ("duplicate_threads" boolean t) + ("edit_headers" boolean nil) + ("editor" path "") + ("encode_from" boolean nil) + ("envelope_from_address" e-mail "") + ("escape" string "~") + ("fast_reply" boolean nil) + ("fcc_attach" boolean t) + ("fcc_clear" boolean nil) + ("file_charset" string "") + ("folder" path "~/Mail") + ("folder_format" string "%2C %t %N %F %2l %-8.8u %-8.8g %8s %d %f") + ("followup_to" boolean t) + ("force_name" boolean nil) + ("forward_decode" boolean t) + ("forward_edit" quadoption "yes") + ("forward_format" string "[%a: %s]") + ("forward_quote" boolean nil) + ("from" e-mail "") + ("gecos_mask" regular "^[^,]*") + ("hdrs" boolean t) + ("header" boolean nil) + ("help" boolean t) + ("hidden_host" boolean nil) + ("hide_limited" boolean nil) + ("hide_missing" boolean t) + ("hide_thread_subject" boolean t) + ("hide_top_limited" boolean nil) + ("hide_top_missing" boolean t) + ("history" number 10) + ("honor_followup_to" quadoption "yes") + ("hostname" string "") + ("ignore_list_reply_to" boolean nil) + ("imap_authenticators" string "") + ("imap_check_subscribed" boolean nil) + ("imap_delim_chars" string "/.") + ("imap_headers" string "") + ("imap_home_namespace" string "") + ("imap_idle" boolean nil) + ("imap_keepalive" number 900) + ("imap_list_subscribed" boolean nil) + ("imap_login" string "") + ("imap_pass" string "") + ("imap_passive" boolean t) + ("imap_peek" boolean t) + ("imap_servernoise" boolean t) + ("imap_user" string "") + ("implicit_autoview" boolean nil) + ("include" quadoption "ask-yes") + ("include_onlyfirst" boolean nil) + ("indent_string" string "> ") + ("index_format" string "%4C %Z %{%b %d} %-15.15L (%?l?%4l&%4c?) %s") + ("hdr_format" string "%4C %Z %{%b %d} %-15.15L (%?l?%4l&%4c?) %s") + ("ispell" path "ispell") + ("keep_flagged" boolean nil) + ("locale" string "C") + ("mail_check" number 5) + ("mailcap_path" string "") + ("mailcap_sanitize" boolean t) + ("maildir_mtime" boolean nil) + ("header_cache" path "") + ("maildir_header_cache_verify" boolean t) + ("header_cache_pagesize" string "16384") + ("maildir_trash" boolean nil) + ("mark_old" boolean t) + ("markers" boolean t) + ("mask" regular "!^\.[^.]") + ("mbox" path "~/mbox") + ("mbox_type" folder mbox) + ("metoo" boolean nil) + ("menu_context" number 0) + ("menu_move_off" boolean t) + ("menu_scroll" boolean nil) + ("meta_key" boolean nil) + ("mh_purge" boolean nil) + ("mh_seq_flagged" string "flagged") + ("mh_seq_replied" string "replied") + ("mh_seq_unseen" string "unseen") + ("mime_forward" quadoption "no") + ("mime_forward_decode" boolean nil) + ("mime_forward_rest" quadoption "yes") + ("pgp_mime_signature_filename" string "signature.asc") + ("pgp_mime_signature_description" string "Digital signature") + ("mix_entry_format" string "%4n %c %-16s %a") + ("mixmaster" path "mixmaster") + ("move" quadoption "ask-no") + ("message_cachedir" path "") + ("message_format" string "%s") + ("narrow_tree" boolean nil) + ("net_inc" number 10) + ("pager" path "builtin") + ("pager_context" number 0) + ("pager_format" string "-%Z- %C/%m: %-20.20n %s") + ("pager_index_lines" number 0) + ("pager_stop" boolean nil) + ("crypt_autosign" boolean nil) + ("crypt_autoencrypt" boolean nil) + ("pgp_ignore_subkeys" boolean t) + ("crypt_replyencrypt" boolean t) + ("crypt_replysign" boolean nil) + ("crypt_replysignencrypted" boolean nil) + ("crypt_timestamp" boolean t) + ("pgp_use_gpg_agent" boolean nil) + ("crypt_verify_sig" quadoption "yes") + ("pgp_verify_sig" quadoption "yes") + ("smime_is_default" boolean nil) + ("smime_ask_cert_label" boolean t) + ("smime_decrypt_use_default_key" boolean t) + ("pgp_entry_format" string "%4n %t%f %4l/0x%k %-4a %2c %u") + ("pgp_good_sign" regular "") + ("pgp_check_exit" boolean t) + ("pgp_long_ids" boolean nil) + ("pgp_retainable_sigs" boolean nil) + ("pgp_autoinline" boolean nil) + ("pgp_replyinline" boolean nil) + ("pgp_show_unusable" boolean t) + ("pgp_sign_as" string "") + ("pgp_strict_enc" boolean t) + ("pgp_timeout" number 300) + ("pgp_sort_keys" sort address) + ("pgp_mime_auto" quadoption "ask-yes") + ("pgp_auto_decode" boolean nil) + ("pgp_decode_command" string "") + ("pgp_getkeys_command" string "") + ("pgp_verify_command" string "") + ("pgp_decrypt_command" string "") + ("pgp_clearsign_command" string "") + ("pgp_sign_command" string "") + ("pgp_encrypt_sign_command" string "") + ("pgp_encrypt_only_command" string "") + ("pgp_import_command" string "") + ("pgp_export_command" string "") + ("pgp_verify_key_command" string "") + ("pgp_list_secring_command" string "") + ("pgp_list_pubring_command" string "") + ("forward_decrypt" boolean t) + ("smime_timeout" number 300) + ("smime_encrypt_with" string "") + ("smime_keys" path "") + ("smime_ca_location" path "") + ("smime_certificates" path "") + ("smime_decrypt_command" string "") + ("smime_verify_command" string "") + ("smime_verify_opaque_command" string "") + ("smime_sign_command" string "") + ("smime_sign_opaque_command" string "") + ("smime_encrypt_command" string "") + ("smime_pk7out_command" string "") + ("smime_get_cert_command" string "") + ("smime_get_signer_cert_command" string "") + ("smime_import_cert_command" string "") + ("smime_get_cert_email_command" string "") + ("smime_default_key" string "") + ("ssl_force_tls" boolean nil) + ("ssl_starttls" quadoption "yes") + ("certificate_file" path "~/.mutt_certificates") + ("ssl_use_sslv3" boolean t) + ("ssl_use_tlsv1" boolean t) + ("ssl_min_dh_prime_bits" number 0) + ("ssl_ca_certificates_file" path "") + ("pipe_split" boolean nil) + ("pipe_decode" boolean nil) + ("pipe_sep" string "\\n") + ("pop_authenticators" string "") + ("pop_auth_try_all" boolean t) + ("pop_checkinterval" number 60) + ("pop_delete" quadoption "ask-no") + ("pop_host" string "") + ("pop_last" boolean nil) + ("pop_reconnect" quadoption "ask-yes") + ("pop_user" string "") + ("pop_pass" string "") + ("post_indent_string" string "") + ("postpone" quadoption "ask-yes") + ("postponed" path "~/postponed") + ("preconnect" string "") + ("print" quadoption "ask-no") + ("print_command" path "lpr") + ("print_decode" boolean t) + ("print_split" boolean nil) + ("prompt_after" boolean t) + ("query_command" path "") + ("quit" quadoption "yes") + ("quote_regexp" regular "^([ \t]*[|>:}#])+") + ("read_inc" number 10) + ("read_only" boolean nil) + ("realname" string "") + ("recall" quadoption "ask-yes") + ("record" path "~/sent") + ("reply_regexp" regular "^(re([\[0-9\]+])*|aw):[ \t]*") + ("reply_self" boolean nil) + ("reply_to" quadoption "ask-yes") + ("resolve" boolean t) + ("reverse_alias" boolean nil) + ("reverse_name" boolean nil) + ("reverse_realname" boolean t) + ("rfc2047_parameters" boolean nil) + ("save_address" boolean nil) + ("save_empty" boolean t) + ("save_name" boolean nil) + ("score" boolean t) + ("score_threshold_delete" number -1) + ("score_threshold_flag" number 9999) + ("score_threshold_read" number -1) + ("send_charset" string "us-ascii:iso-8859-1:utf-8") + ("sendmail" path "/usr/sbin/sendmail -oem -oi") + ("sendmail_wait" number 0) + ("shell" path "") + ("sig_dashes" boolean t) + ("sig_on_top" boolean nil) + ("signature" path "~/.signature") + ("simple_search" string "~f %s | ~s %s") + ("smart_wrap" boolean t) + ("smileys" regular "(>From )|(:[-^]?[][)(><}{|/DP])") + ("sleep_time" number 1) + ("sort" sort date) + ("sort_alias" sort alias) + ("sort_aux" sort date) + ("sort_browser" sort alpha) + ("sort_re" boolean t) + ("spam_separator" string ",") + ("spoolfile" path "") + ("status_chars" string "-*%A") + ("status_format" string "-%r-Mutt: %f [Msgs:%?M?%M/?%m%?n? New:%n?%?o? Old:%o?%?d? Del:%d?%?F? Flag:%F?%?t? Tag:%t?%?p? Post:%p?%?b? Inc:%b?%?l? %l?]---(%s/%S)-%>-(%P)---") + ("status_on_top" boolean nil) + ("strict_mime" boolean t) + ("strict_threads" boolean nil) + ("suspend" boolean t) + ("text_flowed" boolean nil) + ("thread_received" boolean nil) + ("thorough_search" boolean nil) + ("tilde" boolean nil) + ("timeout" number 600) + ("tmpdir" path "") + ("to_chars" string " +TCFL") + ("tunnel" string "") + ("use_8bitmime" boolean nil) + ("use_domain" boolean t) + ("use_envelope_from" boolean nil) + ("use_from" boolean t) + ("use_idn" boolean t) + ("use_ipv6" boolean t) + ("user_agent" boolean t) + ("visual" path "") + ("wait_key" boolean t) + ("weed" boolean t) + ("wrap_search" boolean t) + ("wrapmargin" number 0) + ("write_inc" number 10) + ("write_bcc" boolean t) + ("xterm_icon" string "M%?n?AIL&ail?") + ("xterm_set_titles" boolean nil) + ("xterm_title" string "Mutt with %?m?%m messages&no messages?%?n? [%n NEW]?")) + "List of muttrc variables. Format is: +VARIABLE TYPE DEFAULT" + ) + +(defconst muttrc-mutt-function-alist + '(("attach-file" . 0) + ("attach-key" . 1) + ("attach-message" . 2) + ("backspace" . 3) + ("backward-char" . 4) + ("bol" . 5) + ("bottom-page" . 6) + ("bounce-message" . 7) + ("buffy-cycle" . 8) + ("change-dir" . 9) + ("change-folder" . 10) + ("change-folder-readonly" . 11) + ("check-new" . 12) + ("clear-flag" . 13) + ("complete" . 14) + ("complete-query" . 15) + ("copy-file" . 16) + ("copy-message" . 17) + ("create-alias" . 18) + ("current-bottom" . 19) + ("current-middle" . 20) + ("current-top" . 21) + ("decode-copy" . 22) + ("decode-save" . 23) + ("delete-char" . 24) + ("delete-entry" . 25) + ("delete-message" . 26) + ("delete-pattern" . 27) + ("delete-subthread" . 28) + ("delete-thread" . 29) + ("detach-file" . 30) + ("display-address" . 31) + ("display-message" . 32) + ("display-toggle-weed" . 33) + ("edit" . 34) + ("edit-bcc" . 35) + ("edit-cc" . 36) + ("edit-description" . 37) + ("edit-encoding" . 38) + ("edit-fcc" . 39) + ("edit-file" . 40) + ("edit-from" . 41) + ("edit-headers" . 42) + ("edit-message" . 43) + ("edit-mime" . 44) + ("edit-reply-to" . 45) + ("edit-subject" . 46) + ("edit-to" . 47) + ("edit-type" . 48) + ("enter-command" . 49) + ("enter-mask" . 50) + ("eol" . 51) + ("exit" . 52) + ("extract-keys" . 53) + ("fetch-mail" . 54) + ("filter-entry" . 55) + ("first-entry" . 56) + ("flag-message" . 57) + ("forget-passphrase" . 58) + ("forward-char" . 59) + ("forward-message" . 60) + ("group-reply" . 61) + ("half-down" . 62) + ("half-up" . 63) + ("help" . 64) + ("history-down" . 65) + ("history-up" . 66) + ("ispell" . 67) + ("jump" . 68) + ("kill-eol" . 69) + ("kill-line" . 70) + ("kill-word" . 71) + ("last-entry" . 72) + ("limit" . 73) + ("list-reply" . 74) + ("mail" . 75) + ("mail-key" . 76) + ("mark-as-new" . 77) + ("middle-page" . 78) + ("new-mime" . 79) + ("next-entry" . 80) + ("next-line" . 81) + ("next-new" . 82) + ("next-page" . 83) + ("next-subthread" . 84) + ("next-thread" . 85) + ("next-undeleted" . 86) + ("next-unread" . 87) + ("parent-message" . 88) + ("pgp-menu" . 89) + ("pipe-entry" . 90) + ("pipe-message" . 91) + ("postpone-message" . 92) + ("previous-entry" . 93) + ("previous-line" . 94) + ("previous-new" . 95) + ("previous-page" . 96) + ("previous-subthread" . 97) + ("previous-thread" . 98) + ("previous-undeleted" . 99) + ("previous-unread" . 100) + ("print-entry" . 101) + ("print-message" . 102) + ("query" . 103) + ("query-append" . 104) + ("quit" . 105) + ("quote-char" . 106) + ("read-subthread" . 107) + ("read-thread" . 108) + ("recall-message" . 109) + ("redraw-screen" . 110) + ("refresh" . 111) + ("rename-file" . 112) + ("reply" . 113) + ("save-entry" . 114) + ("save-message" . 115) + ("search" . 116) + ("search-next" . 117) + ("search-opposite" . 118) + ("search-reverse" . 119) + ("search-toggle" . 120) + ("select-entry" . 121) + ("select-new" . 122) + ("send-message" . 123) + ("set-flag" . 124) + ("shell-escape" . 125) + ("show-limit" . 126) + ("show-version" . 127) + ("skip-quoted" . 128) + ("sort" . 129) + ("sort-mailbox" . 130) + ("sort-reverse" . 131) + ("subscribe" . 132) + ("sync-mailbox" . 133) + ("tag-entry" . 134) + ("tag-message" . 135) + ("tag-pattern" . 136) + ("tag-prefix" . 137) + ("tag-thread" . 138) + ("toggle-mailboxes" . 139) + ("toggle-new" . 140) + ("toggle-quoted" . 141) + ("toggle-subscribed" . 142) + ("toggle-unlink" . 143) + ("toggle-write" . 144) + ("top" . 145) + ("top-page" . 146) + ("undelete-entry" . 147) + ("undelete-message" . 148) + ("undelete-pattern" . 149) + ("undelete-subthread" . 150) + ("undelete-thread" . 151) + ("unsubscribe" . 152) + ("untag-pattern" . 153) + ("verify-key" . 154) + ("view-attach" . 155) + ("view-attachments" . 156) + ("view-file" . 157) + ("view-mailcap" . 158) + ("view-name" . 159) + ("view-text" . 160) + ("write-fcc" . 161)) + "List of Mutt command (not muttrc!)") + +(defconst muttrc-alias-sort-order-alist + '(("address" . 0) ("alias" . 1) ("unsorted" . 2))) + +(defconst muttrc-aux-sort-order-alist + '(("date-sent" . 0) ("reverse-date-sent" . 1) ("last-date-sent" . 2) + ("date-received" . 3) ("reverse-date-received" . 4) + ("last-date-received" . 5) + ("from" . 6) ("reverse-from" . 7) ("last-from" . 8) + ("mailbox-order" . 9) ("reverse-mailbox-order" . 10) + ("last-mailbox-order" . 11) + ("score" . 12) ("reverse-score" . 13) ("last-score" . 14) + ("size" . 15) ("reverse-size" . 16) ("last-size" . 17) + ("subject" . 18) ("reverse-subject" . 19) ("last-subject" . 20) + ("threads" . 21) ("reverse-threads" . 22) ("last-threads" . 23) + ("to" . 24) ("reverse-to" . 25) ("last-to" . 26))) + +(defconst muttrc-browser-sort-order-alist + '(("alpha" . 0) ("date" . 1) ("size" . 2) ("unsorted" . 3))) + +(defconst muttrc-pgp-sort-order-alist + '(("address" . 0) ("date" . 1) ("keyid" . 2) + ("reverse-address" . 3) ("reverse-date" . 4) + ("reverse-keyid" . 5) ("reverse-trust" . 6) + ("trust" . 7))) + +(defconst muttrc-quadoption-alist + '(("yes" .0) ("no" .1) ("ask-yes" .2) ("ask-no" .3))) + +(defconst muttrc-sort-order-alist + '(("date-sent" . 0) ("reverse-date-sent" . 1) + ("date-received" . 2) ("reverse-date-received" . 3) + ("from" . 4) ("reverse-from" . 5) + ("mailbox-order" . 6) ("reverse-mailbox-order" . 7) + ("score" . 8) ("reverse-score" . 9) + ("size" . 10) ("reverse-size" . 11) + ("subject" . 12) ("reverse-subject" . 13) + ("threads" . 14) ("reverse-threads" . 15) + ("to" . 16) ("reverse-to" . 17))) + +;;; ------------------------------------------------------------ +;;; Font-lock definitions +;;; ------------------------------------------------------------ + +(defun muttrc-string-regexp (quote-char) + (let ((c (char-to-string quote-char))) + (format "%s\\([^\n%s]\\|[\\].\\)*%s" c c c))) + +(defvar muttrc-generic-arg-regexp + (concat "\\(" + (muttrc-string-regexp ?\") + "\\|" + "'\\([^']*\\)'" + "\\|" + (muttrc-string-regexp ?\`) + "\\|" + "\\([^\n\t \"'`#;\\]\\|[\\].\\)+" + "\\)")) + +(defvar muttrc-generic-arg-sequence-regexp + (concat "\\(\\s-*" muttrc-generic-arg-regexp "+\\)*")) + +(defvar muttrc-non-command-keyword-regexp + "\\(^\\|;\\)\\s-*\\<\\(set\\|unset\\|toggle\\|reset\\)\\>") + +(defvar muttrc-variable-regexp + (concat "\\<\\(\\(no\\|inv\\)?\\(" + (mapconcat 'car muttrc-variables-alist "\\|") + "\\)\\)\\>")) + +(defvar muttrc-assignement-regexp + (concat muttrc-variable-regexp + "\\s-*\\(=\\s-*" muttrc-generic-arg-regexp "\\)?")) + +(defun muttrc-search-command-forward (command &optional limit) + (let ((cmd-desc (assoc command muttrc-command-alist))) + (if cmd-desc + (let ((cmd-match-data '()) + (cmd-args (cadr cmd-desc)) + (origin (point)) + beg-0 end-0) + (catch 'done + (while (and (not cmd-match-data) + (re-search-forward + (concat "\\(;\\|^\\)\\s-*\\(" command "\\)") + limit t)) + (let ((beg (nth 4 (match-data))) + (end (nth 5 (match-data)))) + (setq beg-0 beg) + (setq cmd-match-data (list beg end))) + (let ((args cmd-args)) + (while args + (let ((arg-type (caar args)) + (arg-re (if (null (cdr args)) + muttrc-generic-arg-sequence-regexp + muttrc-generic-arg-regexp))) + (skip-syntax-forward "-") + (if (looking-at arg-re) + (let ((beg (nth 0 (match-data))) + (end (nth 1 (match-data)))) + (goto-char end) + (setq cmd-match-data (append cmd-match-data + (list beg end))) + (setq end-0 end) + (setq args (cdr args))) + (progn + (setq args nil) + (setq cmd-match-data nil))))) + (when cmd-match-data + (set-match-data (cons beg-0 + (cons end-0 + cmd-match-data))) + (throw 'done t)))) + (goto-char origin) + nil))))) + + +(defun muttrc-font-lock-keywords () + (let ((command-alist muttrc-command-alist) + keywords) + (while command-alist + (let* ((cmd (caar command-alist)) + (args (cadr (car command-alist))) + (regexp (eval ; Simulate a closure + (list + 'lambda '(&optional limit) + (list 'muttrc-search-command-forward cmd 'limit)))) + (hilighters '((1 font-lock-keyword-face))) + (n 2)) + (while args + (let ((arg-type (caar args)) + (last-arg-p (null (cdr args)))) + (setq hilighters + (append hilighters + (let ((face + (or (cdr-safe + (assoc arg-type + muttrc-argument-faces-alist)) + 'default))) + (list (append (list n (list 'quote face)) + (if last-arg-p '(nil t)))))))) + (setq n (1+ n)) + (setq args (cdr args))) + (setq keywords (append keywords (list (cons regexp hilighters)))) + (setq command-alist (cdr command-alist)))) + (append keywords + (list + (list muttrc-non-command-keyword-regexp 2 + font-lock-keyword-face) + (list muttrc-assignement-regexp 1 + font-lock-variable-name-face))) + )) + +;;; ------------------------------------------------------------ +;;; Mode specific customization +;;; ------------------------------------------------------------ + +(defconst muttrc-mode-map nil + "The keymap that is used in Muttrc mode.") +(if (null muttrc-mode-map) + (setq muttrc-mode-map + (let ((map (make-sparse-keymap)) + (help-map (make-sparse-keymap)) + (ctrl-c-map (make-sparse-keymap))) + (define-key map "\C-c" ctrl-c-map) + (define-key ctrl-c-map "c" 'muttrc-insert-command) + (define-key ctrl-c-map "C" 'comment-region) + (define-key ctrl-c-map "s" 'muttrc-set-variable) + (define-key ctrl-c-map "S" 'muttrc-unset-variable) + (define-key ctrl-c-map "f" 'muttrc-find-variable-in-buffer) + (define-key ctrl-c-map "h" help-map) + (define-key help-map "m" 'muttrc-find-manual-file) + (define-key help-map "v" 'muttrc-find-variable-help) + (define-key help-map "c" 'muttrc-find-command-help) + map))) + +(defvar muttrc-mode-syntax-table nil) +(when (null muttrc-mode-syntax-table) + (setq muttrc-mode-syntax-table (make-syntax-table)) + (modify-syntax-entry ?# "< " muttrc-mode-syntax-table) + (modify-syntax-entry ?\n "> " muttrc-mode-syntax-table) + (modify-syntax-entry ?\' "$ " muttrc-mode-syntax-table) + (modify-syntax-entry ?\' "$ " muttrc-mode-syntax-table) + (modify-syntax-entry ?_ "w " muttrc-mode-syntax-table) + (modify-syntax-entry ?- "w " muttrc-mode-syntax-table) + ) + +;;; ------------------------------------------------------------ +;;; The mode function itself. +;;; ------------------------------------------------------------ + +;;;###autoload +(defun muttrc-mode () + "Major mode for editing Muttrc files. +This function ends by invoking the function(s) `muttrc-mode-hook'. + +\\{muttrc-mode-map} +" + + (interactive) + (kill-all-local-variables) + + ;; Font lock. + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults + '('muttrc-font-lock-keywords + nil nil nil nil + (font-lock-syntactic-keywords . (("'[^'\n]*'" 0 "\""))))) + + ;; Comment stuff. + (make-local-variable 'comment-start) + (setq comment-start "#") + (make-local-variable 'comment-end) + (setq comment-end "") + (make-local-variable 'comment-start-skip) + (setq comment-start-skip "#+[ \t]*") + + ;; become the current major mode + (setq major-mode 'muttrc-mode) + (setq mode-name "Muttrc") + + ;; Activate keymap and syntax table. + (use-local-map muttrc-mode-map) + (set-syntax-table muttrc-mode-syntax-table) + + (run-hooks 'muttrc-mode-hook)) + + + +;;; ------------------------------------------------------------ +;;; Other functions +;;; ------------------------------------------------------------ + +(defun muttrc-perform-nonreg-test () + (interactive) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^# Begin\\s-+\\(.*\\)$" nil t) + (let ((test-name (match-string-no-properties 1)) + (expr "")) + (catch 'loop + (while t + (or (= (forward-line 1) 0) + (throw 'loop t)) + (if (looking-at (format "^# End\\s-+%s\\s-*" + (regexp-quote test-name))) + (throw 'loop t)) + (if (looking-at "^# End\\s-+\\(.*\\)$") + (error "Found end of %s before %s" + (match-string-no-properties 1) test-name)) + (if (looking-at "^[^#]") + (error "End of %s not found" test-name)) + (if (looking-at "^#\\s-*\\(.*\\)$") + (setq expr (concat expr (match-string-no-properties 1)))))) + (if (eval (read expr)) + (message "Passed: %s" test-name) + (error "Failed: %s" test-name)))))) + +(defun muttrc-quote-string (s) + "Add a backslash on quotes and surround by quotes if needed." + (save-match-data + (cond ((or (not s) (equal s "")) "''") + ((string-match "^[^']*\\s-[^']*$" s) (format "'%s'" s)) + ((string-match "\\s-" s) + (concat "\"" + (mapconcat (lambda (c) + (if (eq c ?\") "\\\"" + (char-to-string c))) + s "") + "\"")) + (t s)))) + +(defun muttrc-prompt-string (prompt-base &optional default) + (if default + (format "%s [%s]: " prompt-base default) + (format "%s: " prompt-base))) + +(defun muttrc-token-around-point (alist &optional strip-fun) + (let ((word (and (functionp 'thing-at-point) + (funcall (or strip-fun 'identity) + (funcall 'thing-at-point 'word))))) + (if (and word (assoc word alist)) + word))) + +(defun muttrc-assignement (varname modifier &optional value) + (concat (format "%s%s" (or modifier "") varname) + (if (stringp value) + (format "=%s" + (muttrc-quote-string value)) + ""))) + +(defun muttrc-split-next-set-line () + "Returns the current line splitted into tokens. The result is a list +of tokens like: +\((CMD START END) ((VAR1 MODIFIER1 ASSIGNMENT1 START END) ... REST)). +Last element REST is one string that is the rest of the line." + (if (re-search-forward + "^\\s-*\\(set\\|unset\\|toggle\\|reset\\)\\s-+" nil t) + (let ((line (list (list (match-string-no-properties 1) + (match-beginning 1) + (match-end 1)))) + (limit (save-excursion + (end-of-line) + (point)))) + (catch 'done + (while (< (point) limit) + (or (looking-at + (format "\\<\\(inv\\|no\\)?\\([a-z][a-z_]*\\)\\>")) + (throw 'done t)) + (let ((modifier (match-string-no-properties 1)) + (varname (match-string-no-properties 2)) + (assignment nil)) + (goto-char (match-end 0)) + (skip-syntax-forward "-" limit) + (if (or (looking-at ; Set without quote + "=\\s-*\\([^'\" \t\n#]+\\)") + (looking-at ; Set with double quote (") + "=\\s-*\"\\(\\([^\"\\]\\|\\\\.\\)*\\)\"") + (looking-at ; Set with single quote (') + "=\\s-*'\\([^']*\\)'")) + (let ((type (let ((desc (assoc varname + muttrc-variables-alist))) + (if desc (cadr desc))))) + (if type + (and (eq type 'boolean) + (message "%s: can't assign a boolean" varname)) + (message "%s: unknown Muttrc variable" + varname)) + (setq assignment (match-string-no-properties 1)) + (goto-char (match-end 0)))) + (nconc line (list (list varname modifier + assignment + (match-beginning 0) + (match-end 0)))) + (skip-syntax-forward "-" limit)))) + (skip-syntax-backward "-") + (if (looking-at ".+$") + (nconc line (list (list (match-string-no-properties 0))))) + (end-of-line) + line))) + +(defun muttrc-splice-assignment (line varname) + "Returns a list where assignements for VARNAME are separated from +assignment for other variables." + (let ((l (cdr line)) + (in '()) + (out '())) + (while (and l (consp (car l))) + (let ((arg (car l))) + (if (string= (car arg) varname) + (setq in (append in (list arg))) + (setq out (append out (list arg))))) + (setq l (cdr l))) + (list in out))) + +(defun muttrc-new-value (cmd varname type modifier value default) + (if (eq type 'boolean) + (cond ((string= cmd "set") + (cond ((null modifier) t) + ((string= modifier "no") nil) + ((string= modifier "inv") (not value)))) + ((string= cmd "unset") + (cond ((null modifier) nil) + ((string= modifier "no") t) + ((string= modifier "inv") value))) + ((string= cmd "toggle") (not value)) + ((string= cmd "reset") + (cond ((null modifier) default) + ((string= modifier "no") (not default)) + ((string= modifier "inv") (not default))))) + (cond ((string= cmd "set") value) + ((string= cmd "unset") default) + ((string= cmd "toggle") + (error "%s: can't toggle non boolean" varname)) + ((string= cmd "reset") default)))) + +(defun muttrc-get-value-and-point (varname) + "Fetch the value of VARIABLE from the current buffer. It returns a +cons (VALUE . POINT) where POINT is the beginning of the line defining +VARNAME." + (save-excursion + (let ((var-descriptor (assoc varname muttrc-variables-alist))) + (or var-descriptor + (error "%s: unknown variable." varname)) + (goto-char (point-min)) + (let ((type (nth 0 (cdr var-descriptor))) + (default (nth 1 (cdr var-descriptor))) + (pos nil)) + (let ((value default)) + ;; We search all the definitions in the buffer because some + ;; users may use toggle or set inv... + (catch 'done + (while t + (let ((line (muttrc-split-next-set-line))) + (or line (throw 'done t)) + (let ((cmd (caar line)) + (assignments + (car (muttrc-splice-assignment line varname)))) + (if assignments + (setq pos (save-excursion + (beginning-of-line) + (point)))) + (while assignments + (let ((modifier (nth 1 (car assignments))) + (new-value (nth 2 (car assignments)))) + (setq value + (muttrc-new-value cmd varname type modifier + (or new-value value) + default))) + (setq assignments (cdr assignments))))))) + (cons value pos)))))) + +(defun muttrc-get-value (varname) + "Fetch the value of VARIABLE from the current buffer." + (let ((value (muttrc-get-value-and-point varname))) + (and value (car value)))) + +;;; ------------------------------------------------------------ +;;; Viewing manual +;;; ------------------------------------------------------------ + +(defvar muttrc-manual-buffer-name "*Mutt Manual*") + +(defun muttrc-find-manual-file-no-select () + "Convert overstriking and underlining to the correct fonts in a +file. The buffer does not visit the file." + (interactive) + (or (file-readable-p muttrc-manual-path) + (error "%s: file not found" muttrc-manual-path)) + (let ((buf (get-buffer-create muttrc-manual-buffer-name))) + (save-excursion + (set-buffer buf) + (if (not buffer-read-only) + (let ((insert-contents-fun + (condition-case nil + (and (require 'jka-compr) + 'jka-compr-insert-file-contents) + (error 'insert-file-contents)))) + (funcall insert-contents-fun muttrc-manual-path nil nil nil t) + (buffer-disable-undo buf) + (Man-fontify-manpage) + (set-buffer-modified-p nil) + (toggle-read-only) + (goto-char (point-min)))) + buf))) + +(defun muttrc-find-manual-file () + "Convert overstriking and underlining to the correct fonts in a +file. The buffer does not visit the file." + (interactive) + (switch-to-buffer-other-window + (muttrc-find-manual-file-no-select) t)) + +(defun muttrc-search-command-help-forward (command) + (when (re-search-forward + (format "^[ \t]*Usage:\\s-*\\(\\[un\\]\\)?%s" command) + nil t) + (goto-char (match-beginning 0)) + (forward-line -2) + (point))) + +(defun muttrc-search-variable-help-forward (command) + (when (and (re-search-forward + (format "^[ \t]*%s\\.?\\s-*%s\\s-*$" + "\\([1-9][0-9.]*\\)" + (regexp-quote variable)) + nil t) + (re-search-forward + (format "^[ \t]*%s\\.?\\s-*%s\\s-*$" + "\\([1-9][0-9.]*\\)" + (regexp-quote variable)) + nil t) + (re-search-forward + (format "^[ \t]*%s\\.?\\s-*%s\\s-*$" + (regexp-quote (match-string-no-properties 1)) + (regexp-quote variable)) + nil t)) + (goto-char (match-beginning 0)) + (point))) + +(defun muttrc-find-help (search-fun topic) + "Find an help topic in the manual and display it. Returns the manual +buffer." + (let ((buf (muttrc-find-manual-file-no-select))) + (let ((win (get-buffer-window buf)) + help-start) + (save-excursion + (set-buffer buf) + (goto-char (point-min)) + (or (funcall search-fun topic) + (error "%s: entry not found in Mutt manual." command)) + (setq help-start (point)) + (unless (get-buffer-window buf) + (switch-to-buffer-other-window buf t)) + (set-window-start win help-start))) + buf)) + +(defun muttrc-find-command-help (&optional command) + (interactive + (let ((word (muttrc-token-around-point muttrc-command-alist))) + (list (muttrc-get-from-list "Command" word 'muttrc-command-alist t)))) + (muttrc-find-help 'muttrc-search-command-help-forward + (if (string-match "^un\\(.*\\)$" command) + (match-string-no-properties 1 command) + command))) + +(defun muttrc-find-variable-help (&optional variable) + (interactive + (list + (let ((word (muttrc-token-around-point + muttrc-variables-alist + (function + (lambda (word) + (if (and word + (string-match "^\\(no\\|inv\\)\\(.*\\)$" word)) + (match-string-no-properties 2 word) + word)))))) + (muttrc-get-from-list "Variable" word 'muttrc-variables-alist)))) + (muttrc-find-help 'muttrc-search-variable-help-forward variable)) + +(defun muttrc-bury-manual-buffer () + (let ((buf (get-buffer muttrc-manual-buffer-name))) + (if buf (bury-buffer buf)))) + +;;; ------------------------------------------------------------ +;;; Argument handlers +;;; ------------------------------------------------------------ + +(defun muttrc-call-arg-handler (key default &optional prompt) + "Call the function that properly prompts for an argument type." + (let ((handler-args (assoc key muttrc-arg-handler-alist))) + (or handler-args + (error "%s: unknown argument type." (symbol-name key))) + (let ((cmd (nth 0 (cdr handler-args))) + (default-prompt (nth 1 (cdr handler-args))) + (args (cdr (cddr handler-args)))) + (apply cmd (or prompt default-prompt) default args)))) + +(defun muttrc-get-boolean (prompt &optional default) + "Prompt for a boolean." + (y-or-n-p (format "%s? " prompt))) + +(defun muttrc-get-number (prompt default) + "Prompt for a string and return DEFAULT if the string is empty" + (or (read-from-minibuffer (muttrc-prompt-string prompt default)) + default)) + +(defun muttrc-get-string (prompt default) + "Prompt for a string and return DEFAULT if the string is empty" + (let ((s (read-from-minibuffer (muttrc-prompt-string prompt default)))) + (if (> (length s) 0) s default))) + +(defun muttrc-get-word (prompt default) + "Prompt for a word and return DEFAULT if it is empty" + (let ((s (read-from-minibuffer (muttrc-prompt-string prompt default)))) + (or (string-match "^\\w*$" s) + (error "%s: invalid entry, expecting a word" s)) + (if (> (length s) 0) s default))) + +(defun muttrc-get-from-list (prompt default list &optional require-match) + "Prompt for a string from list and return DEFAULT if the string is empty" + (let ((s (completing-read (muttrc-prompt-string prompt default) + (symbol-value list) + nil require-match))) + (if (> (length s) 0) s default))) + +(defun muttrc-get-path (prompt default) + "Prompt for a path and return DEFAULT if the string is empty. The +muttrc folder prefix is replaced by MUTTRC-FOLDER-ABBREV." + (let* ((folder (muttrc-get-value "folder")) + (path (read-file-name (muttrc-prompt-string prompt default) + folder folder))) + (let ((compacted-path + (if (string-match (format "^%s/?\\(.*\\)$" (regexp-quote folder)) + path) + (format "%s%s" + (char-to-string muttrc-folder-abbrev) + (match-string-no-properties 1 path)) + path))) + (if (not (string= compacted-path + (char-to-string muttrc-folder-abbrev))) + compacted-path + default)))) + +(defun muttrc-get-assignment (&optional prompt default + with-value-p) + (let ((varname (completing-read (muttrc-prompt-string prompt default) + muttrc-variables-alist))) + (if (assoc varname muttrc-variables-alist) + (let* ((type (cadr (assoc varname muttrc-variables-alist))) + (default (car-safe (muttrc-get-value-and-point varname))) + (value (if with-value-p + (muttrc-call-arg-handler type default "Value")))) + (if with-value-p + (muttrc-assignement varname + (and (eq type 'boolean) + (not value) + "no") + value) + varname)) + default))) + +;;; ------------------------------------------------------------ +;;; Commands insertion +;;; ------------------------------------------------------------ + +(defun muttrc-get-command (&optional prompt default) + "Prompts the usr for a command to enter and asks for all the arguments." + (let* ((cmd (muttrc-get-from-list "Command" nil 'muttrc-command-alist t)) + (cmd-descriptor (cdr (assoc cmd muttrc-command-alist))) + (arg-list-type (nth 0 cmd-descriptor)) + (repeat-p (nth 1 cmd-descriptor)) + (optional-p (nth 2 cmd-descriptor)) + (arg-list-value (list cmd))) + (save-window-excursion + (if (and muttrc-display-help) + (save-excursion + (muttrc-find-command-help cmd))) + (while arg-list-type + (let* ((arg-type (caar arg-list-type)) + (arg (apply 'muttrc-call-arg-handler + (append (list arg-type nil) + (cdar arg-list-type))))) + (if arg + (progn + (nconc arg-list-value + (list (if (eq arg-type 'assignment) + arg ; assignment are quoted by handler + (muttrc-quote-string arg)))) + (if (and repeat-p + (null (cdr arg-list-type))) + (setq optional-p t) + (setq arg-list-type (cdr arg-list-type)))) + (if (and (null (cdr arg-list-type)) + optional-p) + (setq arg-list-type nil) + (error "Argument required")))))) + (muttrc-bury-manual-buffer) + (mapconcat 'identity arg-list-value " "))) + +(defun muttrc-get-statement (&optional prompt default) + (let ((muttrc-command-alist muttrc-statement-alist)) + (muttrc-get-command prompt default))) + +(defun muttrc-insert-command () + "Insert a muttrc command on the current line." + (interactive) + (let ((cmd-line (muttrc-get-command))) + (beginning-of-line) + (or (eolp) (forward-line 1)) + (insert cmd-line) + (newline))) + +;;; ------------------------------------------------------------ +;;; Setting variables +;;; ------------------------------------------------------------ + +(defun muttrc-update-current-line (varname type &optional value) + "Rewrites the current line by setting VARNAME to VALUE. If the +statement is not \"set\", the variable is removed. In set statement, +it is removed if the value is NIL and the variable is not a boolean. +The function returns t is the variable is really assigned in the line." + (let* ((line (muttrc-split-next-set-line)) + (cmd (caar line)) + (kill-whole-line t) + (args "") + (set-p nil)) + (beginning-of-line) + (kill-line) + (let ((l (cdr line))) + (while l + (let ((elt (car l))) + (if (consp elt) + (let ((this-var (nth 0 elt)) + (this-modifier (nth 1 elt)) + (this-value (nth 2 elt))) + (let ((assignement + (if (string= this-var varname) + (when (string= cmd "set") + (setq set-p t) + (cond ((eq type 'boolean) + (muttrc-assignement varname + (if (not value) "no") + value)) + (value + (muttrc-assignement varname nil value)) + (t (setq set-p nil)))) + (muttrc-assignement this-var + this-modifier + this-value)))) + (if assignement + (setq args (concat args " " assignement))))) + (setq args (concat args elt)))) + (setq l (cdr l)))) + (when (not (string= args "")) + (insert cmd) + (insert args) + (newline)) + (backward-char 1) + set-p)) + +(defun muttrc-update-variable (varname type value pos) + (catch 'done + (when pos + (goto-char pos) + (if (muttrc-update-current-line varname type value) + (throw 'done t))) + (end-of-line) + (let ((cr-after-p (bolp)) + (cmd (if (or value (eq type 'boolean)) "set" "unset")) + (modifier (if (and (not value) (eq type 'boolean)) "no"))) + (or cr-after-p (newline)) + (insert cmd " " + (muttrc-assignement varname modifier value)) + (if cr-after-p (newline)))) + t) + +(defun muttrc-set-variable (&optional varname type value pos) + (interactive + (let* ((varname (muttrc-get-from-list "Variable" nil + 'muttrc-variables-alist t)) + (type (cadr (assoc varname muttrc-variables-alist))) + (default (muttrc-get-value-and-point varname))) + (list varname type + (save-window-excursion + (if muttrc-display-help + (save-excursion + (muttrc-find-variable-help varname))) + (muttrc-call-arg-handler type (car default))) + (cdr default)))) + (muttrc-bury-manual-buffer) + (muttrc-update-variable varname type value pos)) + +(defun muttrc-unset-variable (&optional varname type pos) + (interactive + (let* ((varname (muttrc-get-from-list "Variable" nil + 'muttrc-variables-alist t)) + (type (cadr (assoc varname muttrc-variables-alist))) + (default (muttrc-get-value-and-point varname))) + (list varname type (cdr default)))) + (muttrc-update-variable varname type nil pos)) + +(defun muttrc-find-variable-in-buffer (&optional varname) + (interactive + (list (muttrc-get-from-list "Variable" nil + 'muttrc-variables-alist t))) + (let* ((var-info (muttrc-get-value-and-point varname)) + (value (car var-info)) + (pos (cdr-safe var-info))) + (if pos + (goto-char pos) + (progn + (message "%s: variable not set (default: %s)" varname value))))) + +;;; ------------------------------------------------------------ +;;; Almost the end +;;; ------------------------------------------------------------ + +(provide 'muttrc-mode) + +;;; muttrc-mode.el ends here diff --git a/.emacs.d/elisp/php-mode-improved.el b/.emacs.d/elisp/php-mode-improved.el new file mode 100644 index 0000000..dcf4fb9 --- /dev/null +++ b/.emacs.d/elisp/php-mode-improved.el @@ -0,0 +1,1283 @@ +;;; php-mode.el --- major mode for editing PHP code + +;; This is a version of the php-mode from http://php-mode.sourceforge.net that +;; fixes a few bugs which make using php-mode much more palatable, namely: +;; +;; 1. New customisation options for some of the syntax highlighting +;; features. I personally use the 'Gauchy' level of syntax +;; highlighting -- I want variables and function calls fontified -- +;; but there were several very annoying "features" in this level of +;; syntax highlighting, particularly the ones that warn you about +;; perfectly valid code. I've added: +;; +;; * `php-mode-dollar-property-warning', which, if non-nil, warns on +;; $foo->$bar. (Default is nil.) +;; * `php-mode-dot-property-warning', which, if non-nil, warns on +;; $foo.bar. (Default is nil.) +;; * `php-mode-warn-on-unmatches', which, if non-nil, warns on +;; "everything else". (Default is nil.) +;; * `php-mode-warn-if-mumamo-off', which, if nil, suppresses the +;; once-per-file warning about indenting with mumamo-mode turned +;; off. (Default is t) +;; +;; 2. Bugfix in `php-show-arglist': this function no longer jumps to the +;; function definition if that definition is in the current buffer. +;; +;; 3. Bugfix: 'class' keywords at the beginning of a line are now +;; correctly fontified. +;; +;; This has been submitted to the php-mode maintainer, but I've not yet had a +;; response. +;; +;; This was branched from the php-mode in nxhtml-mode, so if you have problems, +;; download the latest nxhtml-mode, and replace related/php-mode.el in the +;; nxhtml distribution with this file. +;; +;; -- David House, dmhouse@gmail.com + +;; Copyright (C) 1999, 2000, 2001, 2003, 2004 Turadg Aleahmad +;; 2008 Aaron S. Hawley + +;; Maintainer: Aaron S. Hawley <ashawley at users.sourceforge.net> +;; Author: Turadg Aleahmad, 1999-2004 +;; Keywords: php languages oop +;; Created: 1999-05-17 +;; Modified: 2008-01-25T22:25:26+0100 Fri +;; X-URL: http://php-mode.sourceforge.net/ + +(defconst php-mode-version-number "1.4.1a-nxhtml" + "PHP Mode version number.") + +;;; License + +;; This file is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License +;; as published by the Free Software Foundation; either version 3 +;; of the License, or (at your option) any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this file; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301, USA. + +;;; Usage + +;; Put this file in your Emacs lisp path (eg. site-lisp) and add to +;; your .emacs file: +;; +;; (require 'php-mode) + +;; To use abbrev-mode, add lines like this: +;; (add-hook 'php-mode-hook +;; '(lambda () (define-abbrev php-mode-abbrev-table "ex" "extends"))) + +;; To make php-mode compatible with html-mode, see http://php-mode.sf.net + +;; Many options available under Help:Customize +;; Options specific to php-mode are in +;; Programming/Languages/Php +;; Since it inherits much functionality from c-mode, look there too +;; Programming/Languages/C + +;;; Commentary: + +;; PHP mode is a major mode for editing PHP 3 and 4 source code. It's +;; an extension of C mode; thus it inherits all C mode's navigation +;; functionality. But it colors according to the PHP grammar and indents +;; according to the PEAR coding guidelines. It also includes a couple +;; handy IDE-type features such as documentation search and a source +;; and class browser. + + +;;; Contributors: (in chronological order) + +;; Juanjo, Torsten Martinsen, Vinai Kopp, Sean Champ, Doug Marcey, +;; Kevin Blake, Rex McMaster, Mathias Meyer, Boris Folgmann, Roland +;; Rosenfeld, Fred Yankowski, Craig Andrews, John Keller, Ryan +;; Sammartino, ppercot, Valentin Funk, Stig Bakken, Gregory Stark, +;; Chris Morris, Nils Rennebarth, Gerrit Riessen, Eric Mc Sween, +;; Ville Skytta, Giacomo Tesio, Lennart Borgman, Stefan Monnier, +;; Aaron S. Hawley, Ian Eure, Bill Lovett, David House + +;;; Changelog: + +;; 1.4.1a-nxhtml +;; Made underscore be part of identifiers. +;; +;; 1.4.1-nxhtml +;; Added php-mode-to-use. + +;; 1.4.1 +;; Modified `php-check-html-for-indentation' to check for multiple +;; mode support libraries. (Lennart Borgman) +;; +;; 1.4 +;; Updated GNU GPL to version 3. Ported to Emacs 22 (CC mode +;; 5.31). M-x php-mode-version shows version. Provide end-of-defun +;; beginning-of-defun functionality. Support add-log library. +;; Fix __CLASS__ constant (Ian Eure). Allow imenu to see visibility +;; declarations -- "private", "public", "protected". (Bill Lovett) +;; +;; 1.3 +;; Changed the definition of # using a tip from Stefan +;; Monnier to correct highlighting and indentation. (Lennart Borgman) +;; Changed the highlighting of the HTML part. (Lennart Borgman) +;; +;; 1.2 +;; Implemented php-show-arglist, C-. (Engelke Eschner) +;; Implemented php-complete-function, M-tab (Engelke Eschner) +;; Re-enabled # comment detection in GNU Emacs (Urban Müller) +;; Fixed some keybindings and default settings (Engelke Eschner) +;; +;; 1.1 +;; Added PHP5 support (Giacomo Tesio) +;; known problem: doesn't highlight after first 'implements' +;; Better XEmacs compatibility (imenu, regexp, and comments!) (Ville Skytta) +;; Improvement to php-conditional-key regexp (Eric Mc Sween) + +;; 1.05 +;; Incorporated speedbar defs by Gerrit Riessen +;; Add "foreach" to conditional introducing keywords (Nils Rennebarth) +;; Cleared the Changelog +;; Moved contribution credits into comments above + + +;;; Code: + +(require 'speedbar) +(require 'font-lock) +(require 'cc-mode) +(require 'custom) +(require 'etags) +(eval-when-compile + (require 'regexp-opt)) + +;; Local variables +(defgroup php nil + "Major mode `php-mode' for editing PHP code." + :prefix "php-" + :group 'languages) + +(defcustom php-default-face 'default + "Default face in `php-mode' buffers." + :type 'face + :group 'php) + +(defcustom php-speedbar-config t + "When set to true automatically configures Speedbar to observe PHP files.\ +Ignores php-file patterns option; fixed to expression \"\\.\\(inc\\|php[s34]?\\)\"" + :type 'boolean + :set (lambda (sym val) + (set-default sym val) + (if (and val (boundp 'speedbar)) + (speedbar-add-supported-extension + "\\.\\(inc\\|php[s34]?\\|phtml\\)"))) + :group 'php) + +(defcustom php-mode-speedbar-open nil + "Normally `php-mode' starts with the speedbar closed.\ +Turning this on will open it whenever `php-mode' is loaded." + :type 'boolean + :set (lambda (sym val) + (set-default sym val) + (when val + (speedbar 1))) + :group 'php) + +(defcustom php-manual-url "http://www.php.net/manual/en/" + "URL at which to find PHP manual.\ +You can replace \"en\" with your ISO language code." + :type 'string + :group 'php) + +(defcustom php-search-url "http://www.php.net/" + "URL at which to search for documentation on a word" + :type 'string + :group 'php) + +(defcustom php-completion-file "" + "Path to the file which contains the function names known to PHP" + :type 'string + :group 'php) + +(defcustom php-manual-path "" + "Path to the directory which contains the PHP manual" + :type 'string + :group 'php) + +;;;###autoload +(defcustom php-mode-to-use + (progn + (require 'mumamo nil t) + (if (fboundp 'nxhtml-mumamo-turn-on) + 'nxhtml-mumamo-turn-on + (if (fboundp 'html-mumamo-turn-on) + 'html-mumamo-turn-on + 'php-mode))) + "Major mode turn on function to use for php files." + :type 'function + :group 'php) + +;;;###autoload +(defcustom php-file-patterns '("\\.php[s34]?\\'" "\\.phtml\\'" "\\.inc\\'") + "List of file patterns for which to automatically invoke `php-mode'." + :type '(repeat (regexp :tag "Pattern")) + :set-after '(php-mode-to-use) + :set (lambda (sym val) + (set-default sym val) + (let ((php-file-patterns-temp val)) + (while php-file-patterns-temp + (add-to-list 'auto-mode-alist + (cons (car php-file-patterns-temp) php-mode-to-use)) + (setq php-file-patterns-temp (cdr php-file-patterns-temp))))) + :group 'php) + +(defcustom php-mode-hook nil + "List of functions to be executed on entry to `php-mode'." + :type 'hook + :group 'php) + +(defcustom php-mode-pear-hook nil + "Hook called when a PHP PEAR file is opened with `php-mode'." + :type 'hook + :group 'php) + +(defcustom php-mode-force-pear nil + "Normally PEAR coding rules are enforced only when the filename contains \"PEAR\"\ +Turning this on will force PEAR rules on all PHP files." + :type 'boolean + :group 'php) + +(defcustom php-mode-dollar-property-warning nil + "If non-`nil', warn about expressions like $foo->$bar where you +might have meant $foo->bar. Defaults to `nil' since this is valid +code." + :type 'boolean + :group 'php) + +(defcustom php-mode-dot-property-warning nil + "If non-`nil', wan about expressions like $foo.bar, which could +be a valid concatenation (if bar were a constant, or interpreted +as an unquoted string), but it's more likely you meant $foo->bar." + :type 'boolean + :group 'php) + +(defcustom php-mode-warn-on-unmatched nil + "If non-`nil', use `font-lock-warning-face' on any expression +that isn't matched by the other font lock regular expressions." + :type 'boolean + :group 'php) + +(defcustom php-warn-if-mumamo-off t + "Warn once per buffer if you try to indent a buffer without +mumamo-mode turned on. Detects if there are any HTML tags in the +buffer before warning, but this is not very smart; e.g. if you +have any tags inside a PHP string, it will be fooled." + :type '(choice (const :tag "Warn" t) (const "Don't warn" nil)) + :group 'php) + + +(eval-when-compile + (defconst php-mode-modified + (save-excursion + (and + (re-search-backward "^;; Modified: \\(.*\\)" nil 'noerror) + (match-string-no-properties 1))) + "PHP Mode version number.")) + +(defun php-mode-version () + "Display string describing the version of PHP mode" + (interactive) + (message "PHP mode %s of %s" + php-mode-version-number php-mode-modified)) + +(defconst php-beginning-of-defun-regexp + "^\\s *function\\s +&?\\(\\(\\sw\\|\\s_\\)+\\)\\s *(" + "Regular expression for a PHP function.") + +(defun php-beginning-of-defun (&optional arg) + "Move to the beginning of the ARGth PHP function from point. +Implements PHP version of `beginning-of-defun-function'." + (interactive "p") + (let ((arg (or arg 1))) + (while (> arg 0) + (re-search-backward php-beginning-of-defun-regexp + nil 'noerror) + (setq arg (1- arg))) + (while (< arg 0) + (end-of-line 1) + (let ((opoint (point))) + (beginning-of-defun 1) + (forward-list 2) + (forward-line 1) + (if (eq opoint (point)) + (re-search-forward php-beginning-of-defun-regexp + nil 'noerror)) + (setq arg (1+ arg)))))) + +(defun php-end-of-defun (&optional arg) + "Move the end of the ARGth PHP function from point. +Implements PHP befsion of `end-of-defun-function' + +See `php-beginning-of-defun'." + (interactive "p") + (php-beginning-of-defun (- (or arg 1)))) + + +(defvar php-completion-table nil + "Obarray of tag names defined in current tags table and functions know to PHP.") + +(defvar php-warned-bad-indent nil) +;;(make-variable-buffer-local 'php-warned-bad-indent) + +;; Do it but tell it is not good if html tags in buffer. +(defun php-check-html-for-indentation () + (let ((html-tag-re "</?\\sw+.*?>") + (here (point))) + (if (not (or (re-search-forward html-tag-re (+ (point) 1000) t) + (re-search-backward html-tag-re (- (point) 1000) t))) + t + (goto-char here) + (setq php-warned-bad-indent t) + ;;(setq php-warned-bad-indent nil) + (let* ((known-multi-libs '(("mumamo" mumamo (lambda () (nxhtml-mumamo))) + ("mmm-mode" mmm-mode (lambda () (mmm-mode 1))) + ("multi-mode" multi-mode (lambda () (multi-mode 1))))) + (known-names (mapcar (lambda (lib) (car lib)) known-multi-libs)) + (available-multi-libs (delq nil + (mapcar + (lambda (lib) + (when (locate-library (car lib)) lib)) + known-multi-libs))) + (available-names (mapcar (lambda (lib) (car lib)) available-multi-libs)) + (base-msg + (concat + "Indentation fails badly with mixed HTML/PHP in plaín\n" + "`php-mode'. To get indentation to work you must use an Emacs\n" + "library that supports 'multiple major modes' in a buffer. Parts\n" + "of the buffer will then be in `php-mode' and parts in for example\n" + "`html-mode'. Known such libraries are:\n\t" + (mapconcat 'identity known-names ", ") + "\n" + (if available-multi-libs + (concat + "You have these available in your `load-path':\n\t" + (mapconcat 'identity available-names ", ") + "\n\n" + "Do you want to turn any of those on? ") + "You do not have any of those in your `load-path'."))) + (is-using-multi + (catch 'is-using + (dolist (lib available-multi-libs) + (when (and (boundp (cadr lib)) + (symbol-value (cadr lib))) + (throw 'is-using t)))))) + (unless is-using-multi + (if available-multi-libs + (if (not (y-or-n-p base-msg)) + (message "Did not do indentation, but you can try again now if you want") + (let* ((name + (if (= 1 (length available-multi-libs)) + (car available-names) + ;; Minibuffer window is more than one line, fix that first: + (message "") + (completing-read "Choose multiple major mode support library: " + available-names nil t + (car available-names) + '(available-names . 1) + ))) + (mode (when name + (caddr (assoc name available-multi-libs))))) + (when mode + ;; Minibuffer window is more than one line, fix that first: + (message "") + (load name) + (funcall mode)))) + (lwarn 'php-indent :warning base-msg))) + nil)))) + +(defun php-cautious-indent-region (start end &optional quiet) + (if (or (not php-warn-if-mumamo-off) + php-warned-bad-indent + (php-check-html-for-indentation)) + (funcall 'c-indent-region start end quiet))) + +(defun php-cautious-indent-line () + (if (or (not php-warn-if-mumamo-off) + php-warned-bad-indent + (php-check-html-for-indentation)) + (funcall 'c-indent-line))) + +;;;###autoload +(define-derived-mode php-mode c-mode "PHP" + "Major mode for editing PHP code.\n\n\\{php-mode-map}" +;; (c-add-language 'php-mode 'c-mode) + +;; (c-lang-defconst c-block-stmt-1-kwds +;; php php-block-stmt-1-kwds) + (set (make-local-variable 'c-block-stmt-1-key) php-block-stmt-1-key) + +;; (c-lang-defconst c-block-stmt-2-kwds +;; php php-block-stmt-2-kwds) + (set (make-local-variable 'c-block-stmt-2-key) php-block-stmt-2-key) + ;; Specify that cc-mode recognize Javadoc comment style + (set (make-local-variable 'c-doc-comment-style) + '((php-mode . javadoc))) + +;; (c-lang-defconst c-class-decl-kwds +;; php php-class-decl-kwds) + (set (make-local-variable 'c-class-key) php-class-key) + + ;; this line makes $ into punctuation instead of a word constituent + ;; it used to be active, but it killed indenting of case lines that + ;; begin with '$' (many do). If anyone has a solution to this + ;; problem, please let me know. Of course, you're welcome to + ;; uncomment this line in your installation. +; (modify-syntax-entry ?$ "." php-mode-syntax-table) + + ;; The above causes XEmacs to handle shell-style comments correctly, + ;; but fails to work in GNU Emacs which fails to interpret \n as the + ;; end of the comment. + (if (featurep 'xemacs) (progn + (modify-syntax-entry ?# "< b" php-mode-syntax-table) + (modify-syntax-entry ?\n "> b" php-mode-syntax-table))) + + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults + '((php-font-lock-keywords-1 + php-font-lock-keywords-2 + ;; Comment-out the next line if the font-coloring is too + ;; extreme/ugly for you. + php-font-lock-keywords-3) + nil ; KEYWORDS-ONLY + nil ; CASE-FOLD + nil ; SYNTAX-ALIST + nil)) ; SYNTAX-BEGIN + (modify-syntax-entry ?# "< b" php-mode-syntax-table) + (modify-syntax-entry ?_ "w" php-mode-syntax-table) + + ;; Electric behaviour must be turned off, they do not work since + ;; they can not find the correct syntax in embedded PHP. + ;; + ;; Seems to work with narrowing so let it be on if the user prefers it. + ;;(setq c-electric-flag nil) + + (setq font-lock-maximum-decoration t + case-fold-search t ; PHP vars are case-sensitive + imenu-generic-expression php-imenu-generic-expression) + + ;; Do not force newline at end of file. Such newlines can cause + ;; trouble if the PHP file is included in another file before calls + ;; to header() or cookie(). + (set (make-local-variable 'require-final-newline) nil) + (set (make-local-variable 'next-line-add-newlines) nil) + + ;; PEAR coding standards + (add-hook 'php-mode-pear-hook + (lambda () + (set (make-local-variable 'tab-width) 4) + (set (make-local-variable 'c-basic-offset) 4) + (set (make-local-variable 'indent-tabs-mode) nil) + (c-set-offset 'block-open' - ) + (c-set-offset 'block-close' 0 )) nil t) + + (if (or php-mode-force-pear + (and (stringp buffer-file-name) + (string-match "PEAR\\|pear" + (buffer-file-name)) + (string-match "\\.php$" (buffer-file-name)))) + (run-hooks 'php-mode-pear-hook)) + + (setq indent-line-function 'php-cautious-indent-line) + (setq indent-region-function 'php-cautious-indent-region) + (setq c-special-indent-hook nil) + + (set (make-local-variable 'syntax-begin-function) + 'c-beginning-of-syntax) + (set (make-local-variable 'beginning-of-defun-function) + 'php-beginning-of-defun) + (set (make-local-variable 'end-of-defun-function) + 'php-end-of-defun) + (set (make-local-variable 'open-paren-in-column-0-is-defun-start) + nil) + (set (make-local-variable 'defun-prompt-regexp) + "^\\s *function\\s +&?\\(\\(\\sw\\|\\s_\\)+\\)\\s *") + (set (make-local-variable 'add-log-current-defun-header-regexp) + php-beginning-of-defun-regexp) + + (run-hooks 'php-mode-hook)) + +;; Make a menu keymap (with a prompt string) +;; and make it the menu bar item's definition. +(define-key php-mode-map [menu-bar] (make-sparse-keymap)) +(define-key php-mode-map [menu-bar php] + (cons "PHP" (make-sparse-keymap "PHP"))) + +;; Define specific subcommands in this menu. +(define-key php-mode-map [menu-bar php complete-function] + '("Complete function name" . php-complete-function)) +(define-key php-mode-map + [menu-bar php browse-manual] + '("Browse manual" . php-browse-manual)) +(define-key php-mode-map + [menu-bar php search-documentation] + '("Search documentation" . php-search-documentation)) + +;; Define function name completion function +(defun php-complete-function () + "Perform function completion on the text around point. +Completes to the set of names listed in the current tags table +and the standard php functions. +The string to complete is chosen in the same way as the default +for \\[find-tag] (which see)." + (interactive) + (let ((pattern (php-get-pattern)) + beg + completion + (php-functions (php-completion-table))) + (if (not pattern) (message "Nothing to complete") + (search-backward pattern) + (setq beg (point)) + (forward-char (length pattern)) + (setq completion (try-completion pattern php-functions nil)) + (cond ((eq completion t)) + ((null completion) + (message "Can't find completion for \"%s\"" pattern) + (ding)) + ((not (string= pattern completion)) + (delete-region beg (point)) + (insert completion)) + (t + (message "Making completion list...") + (with-output-to-temp-buffer "*Completions*" + (display-completion-list + (all-completions pattern php-functions))) + (message "Making completion list...%s" "done")))))) + +;; Build php-completion-table on demand. The table includes the +;; PHP functions and the tags from the current tags-file-name +(defun php-completion-table () + (or (and tags-file-name + (save-excursion (tags-verify-table tags-file-name)) + php-completion-table) + (let ((tags-table + (if (and tags-file-name + (functionp 'etags-tags-completion-table)) + (with-current-buffer (get-file-buffer tags-file-name) + (etags-tags-completion-table)) + nil)) + (php-table + (cond ((and (not (string= "" php-completion-file)) + (file-readable-p php-completion-file)) + (php-build-table-from-file php-completion-file)) + (php-manual-path + (php-build-table-from-path php-manual-path)) + (t nil)))) + (unless (or php-table tags-table) + (error + (concat "No TAGS file active nor are " + "`php-completion-file' or `php-manual-path' set"))) + (when tags-table + ;; Combine the tables. + (mapatoms (lambda (sym) (intern (symbol-name sym) php-table)) + tags-table)) + (setq php-completion-table php-table)))) + +(defun php-build-table-from-file (filename) + (let ((table (make-vector 1022 0)) + (buf (find-file-noselect filename))) + (save-excursion + (set-buffer buf) + (goto-char (point-min)) + (while (re-search-forward + "^\\([-a-zA-Z0-9_.]+\\)\n" + nil t) + (intern (buffer-substring (match-beginning 1) (match-end 1)) + table))) + (kill-buffer buf) + table)) + +(defun php-build-table-from-path (path) + (let ((table (make-vector 1022 0)) + (files (directory-files + path + nil + "^function\\..+\\.html$"))) + (mapc (lambda (file) + (string-match "\\.\\([-a-zA-Z_0-9]+\\)\\.html$" file) + (intern + (replace-regexp-in-string + "-" "_" (substring file (match-beginning 1) (match-end 1)) t) + table)) + files) + table)) + +;; Find the pattern we want to complete +;; find-tag-default from GNU Emacs etags.el +(defun php-get-pattern () + (save-excursion + (while (looking-at "\\sw\\|\\s_") + (forward-char 1)) + (if (or (re-search-backward "\\sw\\|\\s_" + (save-excursion (beginning-of-line) (point)) + t) + (re-search-forward "\\(\\sw\\|\\s_\\)+" + (save-excursion (end-of-line) (point)) + t)) + (progn (goto-char (match-end 0)) + (buffer-substring-no-properties + (point) + (progn (forward-sexp -1) + (while (looking-at "\\s'") + (forward-char 1)) + (point)))) + nil))) + + +(defun php-show-arglist () + (interactive) + (let* ((tagname (php-get-pattern)) arglist) + (save-excursion + (set-buffer (find-tag-noselect tagname nil nil)) + (goto-char (point-min)) + (when (re-search-forward + (format "function[ \t]+%s[ \t]*(\\([^{]*\\))" tagname) + nil t) + (setq arglist (buffer-substring-no-properties + (match-beginning 1) (match-end 1))))) + (if arglist + (message "Arglist for %s: %s" tagname arglist) + (message "Unknown function: %s" tagname)))) + +;; Define function documentation function +(defun php-search-documentation () + "Search PHP documentation for the word at the point." + (interactive) + (browse-url (concat php-search-url (current-word t)))) + +;; Define function for browsing manual +(defun php-browse-manual () + "Bring up manual for PHP." + (interactive) + (browse-url php-manual-url)) + +;; Define shortcut +(define-key php-mode-map + "\C-c\C-f" + 'php-search-documentation) + +;; Define shortcut +(define-key php-mode-map + [(meta tab)] + 'php-complete-function) + +;; Define shortcut +(define-key php-mode-map + "\C-c\C-m" + 'php-browse-manual) + +;; Define shortcut +(define-key php-mode-map + '[(control .)] + 'php-show-arglist) + +(defconst php-constants + (eval-when-compile + (regexp-opt + '(;; core constants + "__LINE__" "__FILE__" + "__FUNCTION__" "__CLASS__" "__METHOD__" + "PHP_OS" "PHP_VERSION" + "TRUE" "FALSE" "NULL" + "E_ERROR" "E_NOTICE" "E_PARSE" "E_WARNING" "E_ALL" "E_STRICT" + "E_USER_ERROR" "E_USER_WARNING" "E_USER_NOTICE" + "DEFAULT_INCLUDE_PATH" "PEAR_INSTALL_DIR" "PEAR_EXTENSION_DIR" + "PHP_BINDIR" "PHP_LIBDIR" "PHP_DATADIR" "PHP_SYSCONFDIR" + "PHP_LOCALSTATEDIR" "PHP_CONFIG_FILE_PATH" + "PHP_EOL" + + ;; from ext/standard: + "EXTR_OVERWRITE" "EXTR_SKIP" "EXTR_PREFIX_SAME" + "EXTR_PREFIX_ALL" "EXTR_PREFIX_INVALID" "SORT_ASC" "SORT_DESC" + "SORT_REGULAR" "SORT_NUMERIC" "SORT_STRING" "ASSERT_ACTIVE" + "ASSERT_CALLBACK" "ASSERT_BAIL" "ASSERT_WARNING" + "ASSERT_QUIET_EVAL" "CONNECTION_ABORTED" "CONNECTION_NORMAL" + "CONNECTION_TIMEOUT" "M_E" "M_LOG2E" "M_LOG10E" "M_LN2" + "M_LN10" "M_PI" "M_PI_2" "M_PI_4" "M_1_PI" "M_2_PI" + "M_2_SQRTPI" "M_SQRT2" "M_SQRT1_2" "CRYPT_SALT_LENGTH" + "CRYPT_STD_DES" "CRYPT_EXT_DES" "CRYPT_MD5" "CRYPT_BLOWFISH" + "DIRECTORY_SEPARATOR" "SEEK_SET" "SEEK_CUR" "SEEK_END" + "LOCK_SH" "LOCK_EX" "LOCK_UN" "LOCK_NB" "HTML_SPECIALCHARS" + "HTML_ENTITIES" "ENT_COMPAT" "ENT_QUOTES" "ENT_NOQUOTES" + "INFO_GENERAL" "INFO_CREDITS" "INFO_CONFIGURATION" + "INFO_ENVIRONMENT" "INFO_VARIABLES" "INFO_LICENSE" "INFO_ALL" + "CREDITS_GROUP" "CREDITS_GENERAL" "CREDITS_SAPI" + "CREDITS_MODULES" "CREDITS_DOCS" "CREDITS_FULLPAGE" + "CREDITS_QA" "CREDITS_ALL" "PHP_OUTPUT_HANDLER_START" + "PHP_OUTPUT_HANDLER_CONT" "PHP_OUTPUT_HANDLER_END" + "STR_PAD_LEFT" "STR_PAD_RIGHT" "STR_PAD_BOTH" + "PATHINFO_DIRNAME" "PATHINFO_BASENAME" "PATHINFO_EXTENSION" + "CHAR_MAX" "LC_CTYPE" "LC_NUMERIC" "LC_TIME" "LC_COLLATE" + "LC_MONETARY" "LC_ALL" "LC_MESSAGES" "LOG_EMERG" "LOG_ALERT" + "LOG_CRIT" "LOG_ERR" "LOG_WARNING" "LOG_NOTICE" "LOG_INFO" + "LOG_DEBUG" "LOG_KERN" "LOG_USER" "LOG_MAIL" "LOG_DAEMON" + "LOG_AUTH" "LOG_SYSLOG" "LOG_LPR" "LOG_NEWS" "LOG_UUCP" + "LOG_CRON" "LOG_AUTHPRIV" "LOG_LOCAL0" "LOG_LOCAL1" + "LOG_LOCAL2" "LOG_LOCAL3" "LOG_LOCAL4" "LOG_LOCAL5" + "LOG_LOCAL6" "LOG_LOCAL7" "LOG_PID" "LOG_CONS" "LOG_ODELAY" + "LOG_NDELAY" "LOG_NOWAIT" "LOG_PERROR" + + ;; filters + "FILTER_VALIDATE_BOOLEAN" "FILTER_VALIDATE_EMAIL" + "FILTER_VALIDATE_FLOAT" "FILTER_VALIDATE_INT" + "FILTER_VALIDATE_IP" "FILTER_VALIDATE_REGEXP" + "FILTER_VALIDATE_URL" "FILTER_NULL_ON_FAILURE" + "FILTER_FLAG_ALLOW_THOUSAND" "FILTER_FLAG_ALLOW_OCTAL" + "FILTER_FLAG_ALLOW_HEX" "FILTER_FLAG_IPV4" "FILTER_FLAG_IPV6" + "FILTER_FLAG_NO_PRIV_RANGE" "FILTER_FLAG_NO_RES_RANGE" + "FILTER_FLAG_PATH_REQUIRED" "FILTER_FLAG_QUERY_REQUIRED" + "FILTER_SANITIZE_EMAIL" "FILTER_SANITIZE_ENCODED" + "FILTER_SANITIZE_MAGIC_QUOTES" "FILTER_SANITIZE_NUMBER_FLOAT" + "FILTER_SANITIZE_NUMBER_INT" "FILTER_SANITIZE_SPECIAL_CHARS" + "FILTER_SANITIZE_STRING" "FILTER_SANITIZE_STRIPPED" + "FILTER_SANITIZE_URL" "FILTER_UNSAFE_RAW" + "FILTER_FLAG_STRIP_LOW" "FILTER_FLAG_STRIP_HIGH" + "FILTER_FLAG_ENCODE_LOW" "FILTER_FLAG_ENCODE_HIGH" + "FILTER_FLAG_ALLOW_FRACTION" "FILTER_FLAG_ALLOW_SCIENTIFIC" + "FILTER_FLAG_NO_ENCODE_QUOTES" "FILTER_FLAG_ENCODE_AMP" + "FILTER_CALLBACK" "FILTER_REQUIRE_ARRAY" + + ;; Disabled by default because they slow buffer loading + ;; If you have use for them, uncomment the strings + ;; that you want colored. + ;; To compile, you may have to increase 'max-specpdl-size' + + ;; from other bundled extensions: +; "CAL_EASTER_TO_xxx" "VT_NULL" "VT_EMPTY" "VT_UI1" "VT_I2" +; "VT_I4" "VT_R4" "VT_R8" "VT_BOOL" "VT_ERROR" "VT_CY" "VT_DATE" +; "VT_BSTR" "VT_DECIMAL" "VT_UNKNOWN" "VT_DISPATCH" "VT_VARIANT" +; "VT_I1" "VT_UI2" "VT_UI4" "VT_INT" "VT_UINT" "VT_ARRAY" +; "VT_BYREF" "CP_ACP" "CP_MACCP" "CP_OEMCP" "CP_SYMBOL" +; "CP_THREAD_ACP" "CP_UTF7" "CP_UTF8" "CPDF_PM_NONE" +; "CPDF_PM_OUTLINES" "CPDF_PM_THUMBS" "CPDF_PM_FULLSCREEN" +; "CPDF_PL_SINGLE" "CPDF_PL_1COLUMN" "CPDF_PL_2LCOLUMN" +; "CPDF_PL_2RCOLUMN" "CURLOPT_PORT" "CURLOPT_FILE" +; "CURLOPT_INFILE" "CURLOPT_INFILESIZE" "CURLOPT_URL" +; "CURLOPT_PROXY" "CURLOPT_VERBOSE" "CURLOPT_HEADER" +; "CURLOPT_HTTPHEADER" "CURLOPT_NOPROGRESS" "CURLOPT_NOBODY" +; "CURLOPT_FAILONERROR" "CURLOPT_UPLOAD" "CURLOPT_POST" +; "CURLOPT_FTPLISTONLY" "CURLOPT_FTPAPPEND" "CURLOPT_NETRC" +; "CURLOPT_FOLLOWLOCATION" "CURLOPT_FTPASCII" "CURLOPT_PUT" +; "CURLOPT_MUTE" "CURLOPT_USERPWD" "CURLOPT_PROXYUSERPWD" +; "CURLOPT_RANGE" "CURLOPT_TIMEOUT" "CURLOPT_POSTFIELDS" +; "CURLOPT_REFERER" "CURLOPT_USERAGENT" "CURLOPT_FTPPORT" +; "CURLOPT_LOW_SPEED_LIMIT" "CURLOPT_LOW_SPEED_TIME" +; "CURLOPT_RESUME_FROM" "CURLOPT_COOKIE" "CURLOPT_SSLCERT" +; "CURLOPT_SSLCERTPASSWD" "CURLOPT_WRITEHEADER" +; "CURLOPT_COOKIEFILE" "CURLOPT_SSLVERSION" +; "CURLOPT_TIMECONDITION" "CURLOPT_TIMEVALUE" +; "CURLOPT_CUSTOMREQUEST" "CURLOPT_STDERR" "CURLOPT_TRANSFERTEXT" +; "CURLOPT_RETURNTRANSFER" "CURLOPT_QUOTE" "CURLOPT_POSTQUOTE" +; "CURLOPT_INTERFACE" "CURLOPT_KRB4LEVEL" +; "CURLOPT_HTTPPROXYTUNNEL" "CURLOPT_FILETIME" +; "CURLOPT_WRITEFUNCTION" "CURLOPT_READFUNCTION" +; "CURLOPT_PASSWDFUNCTION" "CURLOPT_HEADERFUNCTION" +; "CURLOPT_MAXREDIRS" "CURLOPT_MAXCONNECTS" "CURLOPT_CLOSEPOLICY" +; "CURLOPT_FRESH_CONNECT" "CURLOPT_FORBID_REUSE" +; "CURLOPT_RANDOM_FILE" "CURLOPT_EGDSOCKET" +; "CURLOPT_CONNECTTIMEOUT" "CURLOPT_SSL_VERIFYPEER" +; "CURLOPT_CAINFO" "CURLOPT_BINARYTRANSER" +; "CURLCLOSEPOLICY_LEAST_RECENTLY_USED" "CURLCLOSEPOLICY_OLDEST" +; "CURLINFO_EFFECTIVE_URL" "CURLINFO_HTTP_CODE" +; "CURLINFO_HEADER_SIZE" "CURLINFO_REQUEST_SIZE" +; "CURLINFO_TOTAL_TIME" "CURLINFO_NAMELOOKUP_TIME" +; "CURLINFO_CONNECT_TIME" "CURLINFO_PRETRANSFER_TIME" +; "CURLINFO_SIZE_UPLOAD" "CURLINFO_SIZE_DOWNLOAD" +; "CURLINFO_SPEED_DOWNLOAD" "CURLINFO_SPEED_UPLOAD" +; "CURLINFO_FILETIME" "CURLE_OK" "CURLE_UNSUPPORTED_PROTOCOL" +; "CURLE_FAILED_INIT" "CURLE_URL_MALFORMAT" +; "CURLE_URL_MALFORMAT_USER" "CURLE_COULDNT_RESOLVE_PROXY" +; "CURLE_COULDNT_RESOLVE_HOST" "CURLE_COULDNT_CONNECT" +; "CURLE_FTP_WEIRD_SERVER_REPLY" "CURLE_FTP_ACCESS_DENIED" +; "CURLE_FTP_USER_PASSWORD_INCORRECT" +; "CURLE_FTP_WEIRD_PASS_REPLY" "CURLE_FTP_WEIRD_USER_REPLY" +; "CURLE_FTP_WEIRD_PASV_REPLY" "CURLE_FTP_WEIRD_227_FORMAT" +; "CURLE_FTP_CANT_GET_HOST" "CURLE_FTP_CANT_RECONNECT" +; "CURLE_FTP_COULDNT_SET_BINARY" "CURLE_PARTIAL_FILE" +; "CURLE_FTP_COULDNT_RETR_FILE" "CURLE_FTP_WRITE_ERROR" +; "CURLE_FTP_QUOTE_ERROR" "CURLE_HTTP_NOT_FOUND" +; "CURLE_WRITE_ERROR" "CURLE_MALFORMAT_USER" +; "CURLE_FTP_COULDNT_STOR_FILE" "CURLE_READ_ERROR" +; "CURLE_OUT_OF_MEMORY" "CURLE_OPERATION_TIMEOUTED" +; "CURLE_FTP_COULDNT_SET_ASCII" "CURLE_FTP_PORT_FAILED" +; "CURLE_FTP_COULDNT_USE_REST" "CURLE_FTP_COULDNT_GET_SIZE" +; "CURLE_HTTP_RANGE_ERROR" "CURLE_HTTP_POST_ERROR" +; "CURLE_SSL_CONNECT_ERROR" "CURLE_FTP_BAD_DOWNLOAD_RESUME" +; "CURLE_FILE_COULDNT_READ_FILE" "CURLE_LDAP_CANNOT_BIND" +; "CURLE_LDAP_SEARCH_FAILED" "CURLE_LIBRARY_NOT_FOUND" +; "CURLE_FUNCTION_NOT_FOUND" "CURLE_ABORTED_BY_CALLBACK" +; "CURLE_BAD_FUNCTION_ARGUMENT" "CURLE_BAD_CALLING_ORDER" +; "CURLE_HTTP_PORT_FAILED" "CURLE_BAD_PASSWORD_ENTERED" +; "CURLE_TOO_MANY_REDIRECTS" "CURLE_UNKOWN_TELNET_OPTION" +; "CURLE_TELNET_OPTION_SYNTAX" "CURLE_ALREADY_COMPLETE" +; "DBX_MYSQL" "DBX_ODBC" "DBX_PGSQL" "DBX_MSSQL" "DBX_PERSISTENT" +; "DBX_RESULT_INFO" "DBX_RESULT_INDEX" "DBX_RESULT_ASSOC" +; "DBX_CMP_TEXT" "DBX_CMP_NUMBER" "XML_ELEMENT_NODE" +; "XML_ATTRIBUTE_NODE" "XML_TEXT_NODE" "XML_CDATA_SECTION_NODE" +; "XML_ENTITY_REF_NODE" "XML_ENTITY_NODE" "XML_PI_NODE" +; "XML_COMMENT_NODE" "XML_DOCUMENT_NODE" "XML_DOCUMENT_TYPE_NODE" +; "XML_DOCUMENT_FRAG_NODE" "XML_NOTATION_NODE" +; "XML_HTML_DOCUMENT_NODE" "XML_DTD_NODE" "XML_ELEMENT_DECL_NODE" +; "XML_ATTRIBUTE_DECL_NODE" "XML_ENTITY_DECL_NODE" +; "XML_NAMESPACE_DECL_NODE" "XML_GLOBAL_NAMESPACE" +; "XML_LOCAL_NAMESPACE" "XML_ATTRIBUTE_CDATA" "XML_ATTRIBUTE_ID" +; "XML_ATTRIBUTE_IDREF" "XML_ATTRIBUTE_IDREFS" +; "XML_ATTRIBUTE_ENTITY" "XML_ATTRIBUTE_NMTOKEN" +; "XML_ATTRIBUTE_NMTOKENS" "XML_ATTRIBUTE_ENUMERATION" +; "XML_ATTRIBUTE_NOTATION" "XPATH_UNDEFINED" "XPATH_NODESET" +; "XPATH_BOOLEAN" "XPATH_NUMBER" "XPATH_STRING" "XPATH_POINT" +; "XPATH_RANGE" "XPATH_LOCATIONSET" "XPATH_USERS" "FBSQL_ASSOC" +; "FBSQL_NUM" "FBSQL_BOTH" "FDFValue" "FDFStatus" "FDFFile" +; "FDFID" "FDFFf" "FDFSetFf" "FDFClearFf" "FDFFlags" "FDFSetF" +; "FDFClrF" "FDFAP" "FDFAS" "FDFAction" "FDFAA" "FDFAPRef" +; "FDFIF" "FDFEnter" "FDFExit" "FDFDown" "FDFUp" "FDFFormat" +; "FDFValidate" "FDFKeystroke" "FDFCalculate" +; "FRIBIDI_CHARSET_UTF8" "FRIBIDI_CHARSET_8859_6" +; "FRIBIDI_CHARSET_8859_8" "FRIBIDI_CHARSET_CP1255" +; "FRIBIDI_CHARSET_CP1256" "FRIBIDI_CHARSET_ISIRI_3342" +; "FTP_ASCII" "FTP_BINARY" "FTP_IMAGE" "FTP_TEXT" "IMG_GIF" +; "IMG_JPG" "IMG_JPEG" "IMG_PNG" "IMG_WBMP" "IMG_COLOR_TILED" +; "IMG_COLOR_STYLED" "IMG_COLOR_BRUSHED" +; "IMG_COLOR_STYLEDBRUSHED" "IMG_COLOR_TRANSPARENT" +; "IMG_ARC_ROUNDED" "IMG_ARC_PIE" "IMG_ARC_CHORD" +; "IMG_ARC_NOFILL" "IMG_ARC_EDGED" "GMP_ROUND_ZERO" +; "GMP_ROUND_PLUSINF" "GMP_ROUND_MINUSINF" "HW_ATTR_LANG" +; "HW_ATTR_NR" "HW_ATTR_NONE" "IIS_READ" "IIS_WRITE" +; "IIS_EXECUTE" "IIS_SCRIPT" "IIS_ANONYMOUS" "IIS_BASIC" +; "IIS_NTLM" "NIL" "OP_DEBUG" "OP_READONLY" "OP_ANONYMOUS" +; "OP_SHORTCACHE" "OP_SILENT" "OP_PROTOTYPE" "OP_HALFOPEN" +; "OP_EXPUNGE" "OP_SECURE" "CL_EXPUNGE" "FT_UID" "FT_PEEK" +; "FT_NOT" "FT_INTERNAL" "FT_PREFETCHTEXT" "ST_UID" "ST_SILENT" +; "ST_SET" "CP_UID" "CP_MOVE" "SE_UID" "SE_FREE" "SE_NOPREFETCH" +; "SO_FREE" "SO_NOSERVER" "SA_MESSAGES" "SA_RECENT" "SA_UNSEEN" +; "SA_UIDNEXT" "SA_UIDVALIDITY" "SA_ALL" "LATT_NOINFERIORS" +; "LATT_NOSELECT" "LATT_MARKED" "LATT_UNMARKED" "SORTDATE" +; "SORTARRIVAL" "SORTFROM" "SORTSUBJECT" "SORTTO" "SORTCC" +; "SORTSIZE" "TYPETEXT" "TYPEMULTIPART" "TYPEMESSAGE" +; "TYPEAPPLICATION" "TYPEAUDIO" "TYPEIMAGE" "TYPEVIDEO" +; "TYPEOTHER" "ENC7BIT" "ENC8BIT" "ENCBINARY" "ENCBASE64" +; "ENCQUOTEDPRINTABLE" "ENCOTHER" "INGRES_ASSOC" "INGRES_NUM" +; "INGRES_BOTH" "IBASE_DEFAULT" "IBASE_TEXT" "IBASE_UNIXTIME" +; "IBASE_READ" "IBASE_COMMITTED" "IBASE_CONSISTENCY" +; "IBASE_NOWAIT" "IBASE_TIMESTAMP" "IBASE_DATE" "IBASE_TIME" +; "LDAP_DEREF_NEVER" "LDAP_DEREF_SEARCHING" "LDAP_DEREF_FINDING" +; "LDAP_DEREF_ALWAYS" "LDAP_OPT_DEREF" "LDAP_OPT_SIZELIMIT" +; "LDAP_OPT_TIMELIMIT" "LDAP_OPT_PROTOCOL_VERSION" +; "LDAP_OPT_ERROR_NUMBER" "LDAP_OPT_REFERRALS" "LDAP_OPT_RESTART" +; "LDAP_OPT_HOST_NAME" "LDAP_OPT_ERROR_STRING" +; "LDAP_OPT_MATCHED_DN" "LDAP_OPT_SERVER_CONTROLS" +; "LDAP_OPT_CLIENT_CONTROLS" "GSLC_SSL_NO_AUTH" +; "GSLC_SSL_ONEWAY_AUTH" "GSLC_SSL_TWOWAY_AUTH" "MCAL_SUNDAY" +; "MCAL_MONDAY" "MCAL_TUESDAY" "MCAL_WEDNESDAY" "MCAL_THURSDAY" +; "MCAL_FRIDAY" "MCAL_SATURDAY" "MCAL_JANUARY" "MCAL_FEBRUARY" +; "MCAL_MARCH" "MCAL_APRIL" "MCAL_MAY" "MCAL_JUNE" "MCAL_JULY" +; "MCAL_AUGUST" "MCAL_SEPTEMBER" "MCAL_OCTOBER" "MCAL_NOVEMBER" +; "MCAL_RECUR_NONE" "MCAL_RECUR_DAILY" "MCAL_RECUR_WEEKLY" +; "MCAL_RECUR_MONTHLY_MDAY" "MCAL_RECUR_MONTHLY_WDAY" +; "MCAL_RECUR_YEARLY" "MCAL_M_SUNDAY" "MCAL_M_MONDAY" +; "MCAL_M_TUESDAY" "MCAL_M_WEDNESDAY" "MCAL_M_THURSDAY" +; "MCAL_M_FRIDAY" "MCAL_M_SATURDAY" "MCAL_M_WEEKDAYS" +; "MCAL_M_WEEKEND" "MCAL_M_ALLDAYS" "MCRYPT_" "MCRYPT_" +; "MCRYPT_ENCRYPT" "MCRYPT_DECRYPT" "MCRYPT_DEV_RANDOM" +; "MCRYPT_DEV_URANDOM" "MCRYPT_RAND" "SWFBUTTON_HIT" +; "SWFBUTTON_DOWN" "SWFBUTTON_OVER" "SWFBUTTON_UP" +; "SWFBUTTON_MOUSEUPOUTSIDE" "SWFBUTTON_DRAGOVER" +; "SWFBUTTON_DRAGOUT" "SWFBUTTON_MOUSEUP" "SWFBUTTON_MOUSEDOWN" +; "SWFBUTTON_MOUSEOUT" "SWFBUTTON_MOUSEOVER" +; "SWFFILL_RADIAL_GRADIENT" "SWFFILL_LINEAR_GRADIENT" +; "SWFFILL_TILED_BITMAP" "SWFFILL_CLIPPED_BITMAP" +; "SWFTEXTFIELD_HASLENGTH" "SWFTEXTFIELD_NOEDIT" +; "SWFTEXTFIELD_PASSWORD" "SWFTEXTFIELD_MULTILINE" +; "SWFTEXTFIELD_WORDWRAP" "SWFTEXTFIELD_DRAWBOX" +; "SWFTEXTFIELD_NOSELECT" "SWFTEXTFIELD_HTML" +; "SWFTEXTFIELD_ALIGN_LEFT" "SWFTEXTFIELD_ALIGN_RIGHT" +; "SWFTEXTFIELD_ALIGN_CENTER" "SWFTEXTFIELD_ALIGN_JUSTIFY" +; "UDM_FIELD_URLID" "UDM_FIELD_URL" "UDM_FIELD_CONTENT" +; "UDM_FIELD_TITLE" "UDM_FIELD_KEYWORDS" "UDM_FIELD_DESC" +; "UDM_FIELD_DESCRIPTION" "UDM_FIELD_TEXT" "UDM_FIELD_SIZE" +; "UDM_FIELD_RATING" "UDM_FIELD_SCORE" "UDM_FIELD_MODIFIED" +; "UDM_FIELD_ORDER" "UDM_FIELD_CRC" "UDM_FIELD_CATEGORY" +; "UDM_PARAM_PAGE_SIZE" "UDM_PARAM_PAGE_NUM" +; "UDM_PARAM_SEARCH_MODE" "UDM_PARAM_CACHE_MODE" +; "UDM_PARAM_TRACK_MODE" "UDM_PARAM_PHRASE_MODE" +; "UDM_PARAM_CHARSET" "UDM_PARAM_STOPTABLE" +; "UDM_PARAM_STOP_TABLE" "UDM_PARAM_STOPFILE" +; "UDM_PARAM_STOP_FILE" "UDM_PARAM_WEIGHT_FACTOR" +; "UDM_PARAM_WORD_MATCH" "UDM_PARAM_MAX_WORD_LEN" +; "UDM_PARAM_MAX_WORDLEN" "UDM_PARAM_MIN_WORD_LEN" +; "UDM_PARAM_MIN_WORDLEN" "UDM_PARAM_ISPELL_PREFIXES" +; "UDM_PARAM_ISPELL_PREFIX" "UDM_PARAM_PREFIXES" +; "UDM_PARAM_PREFIX" "UDM_PARAM_CROSS_WORDS" +; "UDM_PARAM_CROSSWORDS" "UDM_LIMIT_CAT" "UDM_LIMIT_URL" +; "UDM_LIMIT_TAG" "UDM_LIMIT_LANG" "UDM_LIMIT_DATE" +; "UDM_PARAM_FOUND" "UDM_PARAM_NUM_ROWS" "UDM_PARAM_WORDINFO" +; "UDM_PARAM_WORD_INFO" "UDM_PARAM_SEARCHTIME" +; "UDM_PARAM_SEARCH_TIME" "UDM_PARAM_FIRST_DOC" +; "UDM_PARAM_LAST_DOC" "UDM_MODE_ALL" "UDM_MODE_ANY" +; "UDM_MODE_BOOL" "UDM_MODE_PHRASE" "UDM_CACHE_ENABLED" +; "UDM_CACHE_DISABLED" "UDM_TRACK_ENABLED" "UDM_TRACK_DISABLED" +; "UDM_PHRASE_ENABLED" "UDM_PHRASE_DISABLED" +; "UDM_CROSS_WORDS_ENABLED" "UDM_CROSSWORDS_ENABLED" +; "UDM_CROSS_WORDS_DISABLED" "UDM_CROSSWORDS_DISABLED" +; "UDM_PREFIXES_ENABLED" "UDM_PREFIX_ENABLED" +; "UDM_ISPELL_PREFIXES_ENABLED" "UDM_ISPELL_PREFIX_ENABLED" +; "UDM_PREFIXES_DISABLED" "UDM_PREFIX_DISABLED" +; "UDM_ISPELL_PREFIXES_DISABLED" "UDM_ISPELL_PREFIX_DISABLED" +; "UDM_ISPELL_TYPE_AFFIX" "UDM_ISPELL_TYPE_SPELL" +; "UDM_ISPELL_TYPE_DB" "UDM_ISPELL_TYPE_SERVER" "UDM_MATCH_WORD" +; "UDM_MATCH_BEGIN" "UDM_MATCH_SUBSTR" "UDM_MATCH_END" +; "MSQL_ASSOC" "MSQL_NUM" "MSQL_BOTH" "MYSQL_ASSOC" "MYSQL_NUM" +; "MYSQL_BOTH" "MYSQL_USE_RESULT" "MYSQL_STORE_RESULT" +; "OCI_DEFAULT" "OCI_DESCRIBE_ONLY" "OCI_COMMIT_ON_SUCCESS" +; "OCI_EXACT_FETCH" "SQLT_BFILEE" "SQLT_CFILEE" "SQLT_CLOB" +; "SQLT_BLOB" "SQLT_RDD" "OCI_B_SQLT_NTY" "OCI_SYSDATE" +; "OCI_B_BFILE" "OCI_B_CFILEE" "OCI_B_CLOB" "OCI_B_BLOB" +; "OCI_B_ROWID" "OCI_B_CURSOR" "OCI_B_BIN" "OCI_ASSOC" "OCI_NUM" +; "OCI_BOTH" "OCI_RETURN_NULLS" "OCI_RETURN_LOBS" +; "OCI_DTYPE_FILE" "OCI_DTYPE_LOB" "OCI_DTYPE_ROWID" "OCI_D_FILE" +; "OCI_D_LOB" "OCI_D_ROWID" "ODBC_TYPE" "ODBC_BINMODE_PASSTHRU" +; "ODBC_BINMODE_RETURN" "ODBC_BINMODE_CONVERT" "SQL_ODBC_CURSORS" +; "SQL_CUR_USE_DRIVER" "SQL_CUR_USE_IF_NEEDED" "SQL_CUR_USE_ODBC" +; "SQL_CONCURRENCY" "SQL_CONCUR_READ_ONLY" "SQL_CONCUR_LOCK" +; "SQL_CONCUR_ROWVER" "SQL_CONCUR_VALUES" "SQL_CURSOR_TYPE" +; "SQL_CURSOR_FORWARD_ONLY" "SQL_CURSOR_KEYSET_DRIVEN" +; "SQL_CURSOR_DYNAMIC" "SQL_CURSOR_STATIC" "SQL_KEYSET_SIZE" +; "SQL_CHAR" "SQL_VARCHAR" "SQL_LONGVARCHAR" "SQL_DECIMAL" +; "SQL_NUMERIC" "SQL_BIT" "SQL_TINYINT" "SQL_SMALLINT" +; "SQL_INTEGER" "SQL_BIGINT" "SQL_REAL" "SQL_FLOAT" "SQL_DOUBLE" +; "SQL_BINARY" "SQL_VARBINARY" "SQL_LONGVARBINARY" "SQL_DATE" +; "SQL_TIME" "SQL_TIMESTAMP" "SQL_TYPE_DATE" "SQL_TYPE_TIME" +; "SQL_TYPE_TIMESTAMP" "SQL_BEST_ROWID" "SQL_ROWVER" +; "SQL_SCOPE_CURROW" "SQL_SCOPE_TRANSACTION" "SQL_SCOPE_SESSION" +; "SQL_NO_NULLS" "SQL_NULLABLE" "SQL_INDEX_UNIQUE" +; "SQL_INDEX_ALL" "SQL_ENSURE" "SQL_QUICK" +; "X509_PURPOSE_SSL_CLIENT" "X509_PURPOSE_SSL_SERVER" +; "X509_PURPOSE_NS_SSL_SERVER" "X509_PURPOSE_SMIME_SIGN" +; "X509_PURPOSE_SMIME_ENCRYPT" "X509_PURPOSE_CRL_SIGN" +; "X509_PURPOSE_ANY" "PKCS7_DETACHED" "PKCS7_TEXT" +; "PKCS7_NOINTERN" "PKCS7_NOVERIFY" "PKCS7_NOCHAIN" +; "PKCS7_NOCERTS" "PKCS7_NOATTR" "PKCS7_BINARY" "PKCS7_NOSIGS" +; "OPENSSL_PKCS1_PADDING" "OPENSSL_SSLV23_PADDING" +; "OPENSSL_NO_PADDING" "OPENSSL_PKCS1_OAEP_PADDING" +; "ORA_BIND_INOUT" "ORA_BIND_IN" "ORA_BIND_OUT" +; "ORA_FETCHINTO_ASSOC" "ORA_FETCHINTO_NULLS" +; "PREG_PATTERN_ORDER" "PREG_SET_ORDER" "PREG_SPLIT_NO_EMPTY" +; "PREG_SPLIT_DELIM_CAPTURE" +; "PGSQL_ASSOC" "PGSQL_NUM" "PGSQL_BOTH" +; "PRINTER_COPIES" "PRINTER_MODE" "PRINTER_TITLE" +; "PRINTER_DEVICENAME" "PRINTER_DRIVERVERSION" +; "PRINTER_RESOLUTION_Y" "PRINTER_RESOLUTION_X" "PRINTER_SCALE" +; "PRINTER_BACKGROUND_COLOR" "PRINTER_PAPER_LENGTH" +; "PRINTER_PAPER_WIDTH" "PRINTER_PAPER_FORMAT" +; "PRINTER_FORMAT_CUSTOM" "PRINTER_FORMAT_LETTER" +; "PRINTER_FORMAT_LEGAL" "PRINTER_FORMAT_A3" "PRINTER_FORMAT_A4" +; "PRINTER_FORMAT_A5" "PRINTER_FORMAT_B4" "PRINTER_FORMAT_B5" +; "PRINTER_FORMAT_FOLIO" "PRINTER_ORIENTATION" +; "PRINTER_ORIENTATION_PORTRAIT" "PRINTER_ORIENTATION_LANDSCAPE" +; "PRINTER_TEXT_COLOR" "PRINTER_TEXT_ALIGN" "PRINTER_TA_BASELINE" +; "PRINTER_TA_BOTTOM" "PRINTER_TA_TOP" "PRINTER_TA_CENTER" +; "PRINTER_TA_LEFT" "PRINTER_TA_RIGHT" "PRINTER_PEN_SOLID" +; "PRINTER_PEN_DASH" "PRINTER_PEN_DOT" "PRINTER_PEN_DASHDOT" +; "PRINTER_PEN_DASHDOTDOT" "PRINTER_PEN_INVISIBLE" +; "PRINTER_BRUSH_SOLID" "PRINTER_BRUSH_CUSTOM" +; "PRINTER_BRUSH_DIAGONAL" "PRINTER_BRUSH_CROSS" +; "PRINTER_BRUSH_DIAGCROSS" "PRINTER_BRUSH_FDIAGONAL" +; "PRINTER_BRUSH_HORIZONTAL" "PRINTER_BRUSH_VERTICAL" +; "PRINTER_FW_THIN" "PRINTER_FW_ULTRALIGHT" "PRINTER_FW_LIGHT" +; "PRINTER_FW_NORMAL" "PRINTER_FW_MEDIUM" "PRINTER_FW_BOLD" +; "PRINTER_FW_ULTRABOLD" "PRINTER_FW_HEAVY" "PRINTER_ENUM_LOCAL" +; "PRINTER_ENUM_NAME" "PRINTER_ENUM_SHARED" +; "PRINTER_ENUM_DEFAULT" "PRINTER_ENUM_CONNECTIONS" +; "PRINTER_ENUM_NETWORK" "PRINTER_ENUM_REMOTE" "PSPELL_FAST" +; "PSPELL_NORMAL" "PSPELL_BAD_SPELLERS" "PSPELL_RUN_TOGETHER" +; "SID" "SID" "AF_UNIX" "AF_INET" "SOCK_STREAM" "SOCK_DGRAM" +; "SOCK_RAW" "SOCK_SEQPACKET" "SOCK_RDM" "MSG_OOB" "MSG_WAITALL" +; "MSG_PEEK" "MSG_DONTROUTE" "SO_DEBUG" "SO_REUSEADDR" +; "SO_KEEPALIVE" "SO_DONTROUTE" "SO_LINGER" "SO_BROADCAST" +; "SO_OOBINLINE" "SO_SNDBUF" "SO_RCVBUF" "SO_SNDLOWAT" +; "SO_RCVLOWAT" "SO_SNDTIMEO" "SO_RCVTIMEO" "SO_TYPE" "SO_ERROR" +; "SOL_SOCKET" "PHP_NORMAL_READ" "PHP_BINARY_READ" +; "PHP_SYSTEM_READ" "SOL_TCP" "SOL_UDP" "MOD_COLOR" "MOD_MATRIX" +; "TYPE_PUSHBUTTON" "TYPE_MENUBUTTON" "BSHitTest" "BSDown" +; "BSOver" "BSUp" "OverDowntoIdle" "IdletoOverDown" +; "OutDowntoIdle" "OutDowntoOverDown" "OverDowntoOutDown" +; "OverUptoOverDown" "OverUptoIdle" "IdletoOverUp" "ButtonEnter" +; "ButtonExit" "MenuEnter" "MenuExit" "XML_ERROR_NONE" +; "XML_ERROR_NO_MEMORY" "XML_ERROR_SYNTAX" +; "XML_ERROR_NO_ELEMENTS" "XML_ERROR_INVALID_TOKEN" +; "XML_ERROR_UNCLOSED_TOKEN" "XML_ERROR_PARTIAL_CHAR" +; "XML_ERROR_TAG_MISMATCH" "XML_ERROR_DUPLICATE_ATTRIBUTE" +; "XML_ERROR_JUNK_AFTER_DOC_ELEMENT" "XML_ERROR_PARAM_ENTITY_REF" +; "XML_ERROR_UNDEFINED_ENTITY" "XML_ERROR_RECURSIVE_ENTITY_REF" +; "XML_ERROR_ASYNC_ENTITY" "XML_ERROR_BAD_CHAR_REF" +; "XML_ERROR_BINARY_ENTITY_REF" +; "XML_ERROR_ATTRIBUTE_EXTERNAL_ENTITY_REF" +; "XML_ERROR_MISPLACED_XML_PI" "XML_ERROR_UNKNOWN_ENCODING" +; "XML_ERROR_INCORRECT_ENCODING" +; "XML_ERROR_UNCLOSED_CDATA_SECTION" +; "XML_ERROR_EXTERNAL_ENTITY_HANDLING" "XML_OPTION_CASE_FOLDING" +; "XML_OPTION_TARGET_ENCODING" "XML_OPTION_SKIP_TAGSTART" +; "XML_OPTION_SKIP_WHITE" "YPERR_BADARGS" "YPERR_BADDB" +; "YPERR_BUSY" "YPERR_DOMAIN" "YPERR_KEY" "YPERR_MAP" +; "YPERR_NODOM" "YPERR_NOMORE" "YPERR_PMAP" "YPERR_RESRC" +; "YPERR_RPC" "YPERR_YPBIND" "YPERR_YPERR" "YPERR_YPSERV" +; "YPERR_VERS" "FORCE_GZIP" "FORCE_DEFLATE" + + ;; PEAR constants +; "PEAR_ERROR_RETURN" "PEAR_ERROR_PRINT" "PEAR_ERROR_TRIGGER" +; "PEAR_ERROR_DIE" "PEAR_ERROR_CALLBACK" "OS_WINDOWS" "OS_UNIX" +; "PEAR_OS" "DB_OK" "DB_ERROR" "DB_ERROR_SYNTAX" +; "DB_ERROR_CONSTRAINT" "DB_ERROR_NOT_FOUND" +; "DB_ERROR_ALREADY_EXISTS" "DB_ERROR_UNSUPPORTED" +; "DB_ERROR_MISMATCH" "DB_ERROR_INVALID" "DB_ERROR_NOT_CAPABLE" +; "DB_ERROR_TRUNCATED" "DB_ERROR_INVALID_NUMBER" +; "DB_ERROR_INVALID_DATE" "DB_ERROR_DIVZERO" +; "DB_ERROR_NODBSELECTED" "DB_ERROR_CANNOT_CREATE" +; "DB_ERROR_CANNOT_DELETE" "DB_ERROR_CANNOT_DROP" +; "DB_ERROR_NOSUCHTABLE" "DB_ERROR_NOSUCHFIELD" +; "DB_ERROR_NEED_MORE_DATA" "DB_ERROR_NOT_LOCKED" +; "DB_ERROR_VALUE_COUNT_ON_ROW" "DB_ERROR_INVALID_DSN" +; "DB_ERROR_CONNECT_FAILED" "DB_WARNING" "DB_WARNING_READ_ONLY" +; "DB_PARAM_SCALAR" "DB_PARAM_OPAQUE" "DB_BINMODE_PASSTHRU" +; "DB_BINMODE_RETURN" "DB_BINMODE_CONVERT" "DB_FETCHMODE_DEFAULT" +; "DB_FETCHMODE_ORDERED" "DB_FETCHMODE_ASSOC" +; "DB_FETCHMODE_FLIPPED" "DB_GETMODE_ORDERED" "DB_GETMODE_ASSOC" +; "DB_GETMODE_FLIPPED" "DB_TABLEINFO_ORDER" +; "DB_TABLEINFO_ORDERTABLE" "DB_TABLEINFO_FULL" + + ))) + "PHP constants.") + +(defconst php-keywords + (eval-when-compile + (regexp-opt + ;; "class", "new" and "extends" get special treatment + ;; "case" and "default" get special treatment elsewhere + '("and" "as" "break" "continue" "declare" "do" "echo" "else" "elseif" + "endfor" "endforeach" "endif" "endswitch" "endwhile" "exit" + "extends" "for" "foreach" "global" "if" "include" "include_once" + "next" "or" "require" "require_once" "return" "static" "switch" + "then" "var" "while" "xor" "private" "throw" "catch" "try" + "instanceof" "catch all" "finally"))) + "PHP keywords.") + +(defconst php-identifier + (eval-when-compile + '"[a-zA-Z\_\x7f-\xff][a-zA-Z0-9\_\x7f-\xff]*") + "Characters in a PHP identifier.") + +(defconst php-types + (eval-when-compile + (regexp-opt '("array" "bool" "boolean" "char" "const" "double" "float" + "int" "integer" "long" "mixed" "object" "real" + "string"))) + "PHP types.") + +(defconst php-superglobals + (eval-when-compile + (regexp-opt '("_GET" "_POST" "_COOKIE" "_SESSION" "_ENV" "GLOBALS" + "_SERVER" "_FILES" "_REQUEST"))) + "PHP superglobal variables.") + +;; Set up font locking +(defconst php-font-lock-keywords-1 + (list + ;; Fontify constants + (cons + (concat "\\<\\(" php-constants "\\)\\>") + 'font-lock-constant-face) + + ;; Fontify keywords + (cons + (concat "\\<\\(" php-keywords "\\)\\>") + 'font-lock-keyword-face) + + ;; Fontify keywords and targets, and case default tags. + (list "\\<\\(break\\|case\\|continue\\)\\>[ \t]*\\(-?\\(?:\\sw\\|\\s_\\)+\\)?" + '(1 font-lock-keyword-face) '(2 font-lock-constant-face t t)) + ;; This must come after the one for keywords and targets. + '(":" ("^[ \t]*\\(\\(?:\\sw\\|\\s_\\)+\\)[ \t]*:[ \t]*$" + (beginning-of-line) (end-of-line) + (1 font-lock-constant-face))) + + ;; treat 'print' as keyword only when not used like a function name + '("\\<print\\s-*(" . php-default-face) + '("\\<print\\>" . font-lock-keyword-face) + + ;; Fontify PHP tag + '("<\\?\\(php\\)?" . font-lock-constant-face) + '("\\?>" . font-lock-constant-face) + + ;; Fontify ASP-style tag + '("<\\%\\(=\\)?" . font-lock-constant-face) + '("\\%>" . font-lock-constant-face) + + ) + "Subdued level highlighting for PHP mode.") + +(defconst php-font-lock-keywords-2 + (append + php-font-lock-keywords-1 + (list + + ;; class declaration + '("[^_]*\\<\\(class\\|interface\\)[ \t]*\\(\\(?:\\sw\\|\\s_\\)+\\)?" + (1 font-lock-keyword-face) (2 font-lock-type-face nil t)) + ;; handle several words specially, to include following word, + ;; thereby excluding it from unknown-symbol checks later + ;; FIX to handle implementing multiple + ;; currently breaks on "class Foo implements Bar, Baz" + '("\\<\\(new\\|extends\\|implements\\)\\s-+\\$?\\(\\(?:\\sw\\|\\s_\\)+\\)" + (1 font-lock-keyword-face) (2 font-lock-type-face)) + + ;; function declaration + '("\\<\\(function\\)\\s-+&?\\(\\(?:\\sw\\|\\s_\\)+\\)\\s-*(" + (1 font-lock-keyword-face) + (2 font-lock-function-name-face nil t)) + + ;; class hierarchy + '("\\(self\\|parent\\)\\W" (1 font-lock-constant-face nil nil)) + + ;; method and variable features + '("\\<\\(private\\|protected\\|public\\)\\s-+\\$?\\(?:\\sw\\|\\s_\\)+" + (1 font-lock-keyword-face)) + + ;; method features + '("^[ \t]*\\(abstract\\|static\\|final\\)\\s-+\\$?\\(?:\\sw\\|\\s_\\)+" + (1 font-lock-keyword-face)) + + ;; variable features + '("^[ \t]*\\(static\\|const\\)\\s-+\\$?\\(?:\\sw\\|\\s_\\)+" + (1 font-lock-keyword-face)) + )) + "Medium level highlighting for PHP mode.") + +(defconst php-font-lock-keywords-3 + (append + php-font-lock-keywords-2 + `( + ;; <word> or </word> for HTML + ;;'("</?\\sw+[^> ]*>" . font-lock-constant-face) + ;;'("</?\\sw+[^>]*" . font-lock-constant-face) + ;;'("<!DOCTYPE" . font-lock-constant-face) + ("</?[a-z!:]+" . font-lock-constant-face) + + ;; HTML > + ("<[^>]*\\(>\\)" (1 font-lock-constant-face)) + + ;; HTML tags + ("\\(<[a-z]+\\)[[:space:]]+\\([a-z:]+=\\)[^>]*?" (1 font-lock-constant-face) (2 font-lock-constant-face) ) + ("\"[[:space:]]+\\([a-z:]+=\\)" (1 font-lock-constant-face)) + + ;; HTML entities + ;;'("&\\w+;" . font-lock-variable-name-face) + + ;; warn about '$' immediately after -> + ,@(if php-mode-dollar-property-warning + '("\\$\\(?:\\sw\\|\\s_\\)+->\\s-*\\(\\$\\)\\(\\(?:\\sw\\|\\s_\\)+\\)" + (1 font-lock-warning-face) (2 php-default-face))) + + ;; warn about $word.word -- it could be a valid concatenation, + ;; but without any spaces we'll assume $word->word was meant. + ,@(if php-mode-dot-property-warning + '("\\$\\(?:\\sw\\|\\s_\\)+\\(\\.\\)\\sw" 1 font-lock-warning-face)) + + ;; Warn about ==> instead of => + ("==+>" . font-lock-warning-face) + + ;; exclude casts from bare-word treatment (may contain spaces) + (,(concat "(\\s-*\\(" php-types "\\)\\s-*)") 1 font-lock-type-face) + + ;; PHP5: function declarations may contain classes as parameters type + (,(concat + "[(,]\\s-*\\(\\(?:\\sw\\|\\s_\\)+\\)\\s-+&?\\$\\(?:\\sw\\|\\s_\\)+\\>") + 1 font-lock-type-face) + + ;; Fontify variables and function calls + ("\\$\\(this\\|that\\)\\W" (1 font-lock-constant-face nil nil)) + (,(concat "\\$\\(" php-superglobals "\\)\\W") + (1 font-lock-constant-face nil nil)) ; $_GET & co + ("\\$\\(\\(?:\\sw\\|\\s_\\)+\\)" (1 font-lock-variable-name-face)) ; $variable + ("->\\(\\(?:\\sw\\|\\s_\\)+\\)" (1 font-lock-variable-name-face t t)) ; ->variable + ("->\\(\\(?:\\sw\\|\\s_\\)+\\)\\s-*(" . (1 php-default-face t t)) ; ->function_call + ("\\(\\(?:\\sw\\|\\s_\\)+\\)::\\(?:\\sw\\|\\s_\\)+\\s-*(?" . (1 font-lock-type-face)) ; class::member + ("::\\(\\(?:\\sw\\|\\s_\\)+\\>[^(]\\)" . (1 php-default-face)) ; class::constant + ("\\<\\(?:\\sw\\|\\s_\\)+\\s-*[[(]" . php-default-face) ; word( or word[ + ("\\<[0-9]+" . php-default-face) ; number (also matches word) + + ;; Warn on any words not already fontified + ,@(if php-mode-warn-on-unmatched + '("\\<\\(?:\\sw\\|\\s_\\)+\\>" . font-lock-warning-face)) + + ) + ) + "Gauchy level highlighting for PHP mode.") + +;; Define the imenu-generic-expression for PHP mode. +;; To use, execute M-x imenu, then click on Functions or Classes, +;; then select given function/class name to go to its definition. +;; [Contributed by Gerrit Riessen] +(defvar php-imenu-generic-expression + '( + ("All Functions" + "^\\s-*function\\s-+\\([[:alnum:]_]+\\)\\s-*(" 1) + ("Classes" + "^\\s-*class\\s-+\\([[:alnum:]_]+\\)\\s-*" 1) + ("Public Methods" + "^\\s-*public function\\s-+\\([[:alnum:]_]+\\)\\s-*(" 1) + ("Protected Methods" + "^\\s-*protected function\\s-+\\([[:alnum:]_]+\\)\\s-*(" 1) + ("Private Methods" + "^\\s-*private function\\s-+\\([[:alnum:]_]+\\)\\s-*(" 1) + ) + "Imenu generic expression for PHP Mode. See `imenu-generic-expression'." + ) + +(defconst php-block-stmt-1-kwds '("do" "else" "finally" "try")) +(defconst php-block-stmt-2-kwds + '("for" "if" "while" "switch" "foreach" "elseif" "catch all")) + +(defconst php-block-stmt-1-key + (regexp-opt php-block-stmt-1-kwds)) +(defconst php-block-stmt-2-key + (regexp-opt php-block-stmt-2-kwds)) + +(defconst php-class-decl-kwds '("class" "interface")) + +(defconst php-class-key + (concat + "\\(" (regexp-opt php-class-decl-kwds) "\\)\\s +" + c-symbol-key ;; Class name. + "\\(\\s *extends\\s *" c-symbol-key "\\)?" ;; Name of superclass. + "\\(\\s *implements *[^{]+{\\)?")) ;; List of any adopted protocols. + +;; Create "php-default-face" symbol for GNU Emacs so that both XEmacs +;; and GNU emacs can refer to the default face. +(unless (boundp 'php-default-face) + (defvar php-default-face 'php-default-face)) + +;; Create faces for XEmacs +(when (featurep 'xemacs) + (unless (boundp 'font-lock-keyword-face) + (copy-face 'bold 'font-lock-keyword-face)) + (unless (boundp 'font-lock-constant-face) + (copy-face 'font-lock-keyword-face 'font-lock-constant-face))) + +(provide 'php-mode) + +;;; php-mode.el ends here diff --git a/.emacs.d/elisp/pi-php-mode b/.emacs.d/elisp/pi-php-mode new file mode 160000 +Subproject 32c5b60b1748f8df4f6d1472e05679a443a1dea diff --git a/.emacs.d/elisp/rainbow b/.emacs.d/elisp/rainbow new file mode 160000 +Subproject 0fd92f979a6f987e1080faa65681b8e54735a90 diff --git a/.emacs.d/elisp/rainbow-delimiters b/.emacs.d/elisp/rainbow-delimiters new file mode 160000 +Subproject 4c948535838e752587566c80836f92f67078263 diff --git a/.emacs.d/elisp/sqlplus.el b/.emacs.d/elisp/sqlplus.el new file mode 100644 index 0000000..4d5e7d7 --- /dev/null +++ b/.emacs.d/elisp/sqlplus.el @@ -0,0 +1,5151 @@ +;;; sqlplus.el --- User friendly interface to SQL*Plus and support for PL/SQL compilation + +;; Copyright (C) 2007, 2008 Peter Karpiuk, Scott Tiger S.A. + +;; Author: Peter Karpiuk <piotr.karpiuk (at) gmail (dot) com> +;; Maintainer: Peter Karpiuk <piotr.karpiuk (at) gmail (dot) com> +;; Created: 25 Nov 2007 +;; Version 0.9.0 +;; Keywords: sql sqlplus oracle plsql + +;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;; Facilitates interaction with Oracle via SQL*Plus (GNU Emacs only). +;; Moreover, this package complements plsql.el (Kahlil Hodgson) +;; upon convenient compilation of PL/SQL source files. +;; +;; This package was inspired by sqlplus-mode.el (Rob Riepel, Peter +;; D. Pezaris, Martin Schwenke), but offers more features: +;; - tables are parsed, formatted and rendered with colors, like in +;; many GUI programs; you can see raw SQL*Plus output also, +;; if you wish +;; - table will be cutted if you try to fetch too many rows +;; (SELECT * FROM MY_MILLION_ROWS_TABLE); current SQL*Plus command +;; will be automatically interrupted under the hood in such cases +;; - you can use many SQL*Plus processes simultaneously, +;; - font locking (especially if you use Emacs>=22), with database +;; object names highlighting, +;; - history (log) of executed commands - see` sqlplus-history-dir` +;; variable, +;; - commands for fetching any database object definition +;; (package, table/index/sequence script) +;; - query result can be shown in HTML, +;; - input buffer for each connection can be saved into file on +;; disconnect and automatically restored on next connect (see +;; 'sqlplus-session-cache-dir' variable); if you place some +;; SQL*Plus commands between '/* init */' and '/* end */' +;; comments in saved input buffer, they will be automatically +;; executed on every connect +;; - if you use plsql.el for editing PL/SQL files, you can compile +;; such sources everytime with C-cC-c; error messages will be +;; parsed and displayed for easy source navigation +;; - M-. or C-mouse-1 on database object name will go to definition +;; in filesystem (use arrow button on toolbar to go back) +;; +;; The following commands should be added to a global initialization +;; file or to any user's .emacs file to conveniently use +;; sqlplus-mode: +;; +;; (require 'sqlplus) +;; (add-to-list 'auto-mode-alist '("\\.sqp\\'" . sqlplus-mode)) +;; +;; If you want PL/SQL support also, try something like this: +;; +;; (require 'plsql) +;; (setq auto-mode-alist +;; (append '(("\\.pls\\'" . plsql-mode) ("\\.pkg\\'" . plsql-mode) +;; ("\\.pks\\'" . plsql-mode) ("\\.pkb\\'" . plsql-mode) +;; ("\\.sql\\'" . plsql-mode) ("\\.PLS\\'" . plsql-mode) +;; ("\\.PKG\\'" . plsql-mode) ("\\.PKS\\'" . plsql-mode) +;; ("\\.PKB\\'" . plsql-mode) ("\\.SQL\\'" . plsql-mode) +;; ("\\.prc\\'" . plsql-mode) ("\\.fnc\\'" . plsql-mode) +;; ("\\.trg\\'" . plsql-mode) ("\\.vw\\'" . plsql-mode) +;; ("\\.PRC\\'" . plsql-mode) ("\\.FNC\\'" . plsql-mode) +;; ("\\.TRG\\'" . plsql-mode) ("\\.VW\\'" . plsql-mode)) +;; auto-mode-alist )) +;; +;; M-x sqlplus will start new SQL*Plus session. +;; +;; C-RET execute command under point +;; S-C-RET execute command under point and show result table in HTML +;; buffer +;; M-RET explain execution plan for command under point +;; M-. or C-mouse-1: find database object definition (table, view +;; index, synonym, trigger, procedure, function, package) +;; in filesystem +;; C-cC-s show database object definition (retrieved from database) +;; +;; Use describe-mode while in sqlplus-mode for further instructions. +;; +;; Many useful commands are defined in orcl-mode minor mode, which is +;; common for input and otput SQL*Plus buffers, as well as PL/SQL +;; buffers. +;; +;; For twiddling, see 'sqlplus' customization group. +;; +;; If you find this package useful, send me a postcard to address: +;; +;; Peter Karpiuk +;; Scott Tiger S.A. +;; ul. Gawinskiego 8 +;; 01-645 Warsaw +;; Poland + +;;; Known bugs: + +;; 1. Result of SQL select command can be messed up if some columns +;; has newline characters. To avoid this, execute SQL*Plus command +;; column <colname> truncated +;; before such select + +;;; Code: + +(require 'recentf) +(require 'font-lock) +(require 'cl) +(require 'sql) +(require 'tabify) +(require 'skeleton) + +(defconst sqlplus-revision "$Revision: 1.7 $") + +;;; Variables - + +(defgroup sqlplus nil + "SQL*Plus" + :group 'tools + :version 21) + +(defcustom plsql-auto-parse-errors-flag t + "Non nil means parse PL/SQL compilation results and show them in the compilation buffer." + :group 'sqlplus + :type '(boolean)) + +(defcustom sqlplus-init-sequence-start-regexp "/\\* init \\*/" + "SQL*Plus start of session init command sequence." + :group 'sqlplus + :type '(regexp)) + +(defcustom sqlplus-init-sequence-end-regexp "/\\* end \\*/" + "SQL*Plus end of session init command sequence." + :group 'sqlplus + :type '(regexp)) + +(defcustom sqlplus-explain-plan-warning-regexps '("TABLE ACCESS FULL" "INDEX FULL SCAN") + "SQL*Plus explain plan warning regexps" + :group 'sqlplus + :type '(repeat regexp)) + +(defcustom sqlplus-syntax-faces + '((schema font-lock-type-face nil) + (table font-lock-type-face ("dual")) + (synonym font-lock-type-face nil) + (view font-lock-type-face nil) + (column font-lock-constant-face nil) + (sequence font-lock-type-face nil) + (package font-lock-type-face nil) + (trigger font-lock-type-face nil) + (index font-lock-type-face) nil) + "Font lock configuration for database object names in current schema. +This is alist, and each element looks like (SYMBOL FACE LIST) +where SYMBOL is one of: schema, table, synonym, view, column, +sequence, package, trigger, index. Database objects means only +objects from current schema, so if you want syntax highlighting +for other objects (eg. 'dual' table name), you can explicitly +enumerate them in LIST as strings." + :group 'sqlplus + :tag "Oracle SQL Syntax Faces" + :type '(repeat (list symbol face (repeat string)))) + +(defcustom sqlplus-output-buffer-max-size (* 50 1000 1000) + "Maximum size of SQL*Plus output buffer. +After exceeding oldest results are deleted." + :group 'sqlplus + :tag "SQL*Plus Output Buffer Max Size" + :type '(integer)) + +(defcustom sqlplus-select-result-max-col-width nil + "Maximum width of column in displayed database table, or nil if there is no limit. +If any cell value is longer, it will be cutted and terminated with ellipsis ('...')." + :group 'sqlplus + :tag "SQL*Plus Select Result Max Column Width" + :type '(choice integer (const nil))) + +(defcustom sqlplus-format-output-tables-flag t + "Non-nil means format result if it looks like database table." + :group 'sqlplus + :tag "SQL*Plus Format Output Table" + :type '(boolean)) + +(defcustom sqlplus-kill-processes-without-query-on-exit-flag t + "Non-nil means silently kill all SQL*Plus processes on Emacs exit." + :group 'sqlplus + :tag "SQL*Plus Kill Processes Without Query On Exit" + :type '(boolean)) + +(defcustom sqlplus-multi-output-tables-default-flag t + "Non-nil means render database table as set of adjacent tables so that they occupy all width of output window. +For screen space saving and user comfort." + :group 'sqlplus + :tag "SQL*Plus Multiple Tables In Output by Default" + :type '(boolean)) + +(defcustom sqlplus-source-buffer-readonly-by-default-flag t + "Non-nil means show database sources in read-only buffer." + :group 'sqlplus + :tag "SQL*Plus Source Buffer Read Only By Default" + :type '(boolean)) + +(defcustom sqlplus-command "sqlplus" + "SQL*Plus interpreter program." + :group 'sqlplus + :tag "SQL*Plus Command" + :type '(string)) + +(defcustom sqlplus-history-dir nil + "Directory of SQL*Plus command history (log) files, or nil (dont generate log files). +History file name has format '<connect-string>-history.txt'." + :group 'sqlplus + :tag "SQL*Plus History Dir" + :type '(choice directory (const nil))) + +(defvar sqlplus-session-file-extension "sqp") + +(defcustom sqlplus-session-cache-dir nil + "Directory of SQL*Plus input buffer files, or nil (dont save user session). +Session file name has format '<connect-string>.sqp'" + :group 'sqlplus + :tag "SQL*Plus History Dir" + :type '(choice directory (const nil))) + +(defcustom sqlplus-save-passwords nil + "Non-nil means save passwords between Emacs sessions. (Not implemented yet)." + :group 'sqlplus + :tag "SQL*Plus Save Passwords" + :type '(boolean)) + +(defcustom sqlplus-pagesize 200 + "Approximate number of records in query results. +If result has more rows, it will be cutted and terminated with '. . .' line." + :group 'sqlplus + :tag "SQL*Plus Max Rows Count" + :type '(integer)) + +(defvar sqlplus-default-wrap "on") + +(defcustom sqlplus-initial-strings + (list "set sqlnumber off" + "set tab off" + "set linesize 4000" + "set echo off" + "set newpage 1" + "set space 1" + "set feedback 6" + "set heading on" + "set trimspool off" + (format "set wrap %s" sqlplus-default-wrap) + "set timing on" + "set feedback on") + "Initial commands to send to interpreter. +Customizing this variable is dangerous." + :group 'sqlplus + :tag "SQL*Plus Initial Strings" + :type '(repeat string)) + +(defcustom sqlplus-table-col-separator " | " + "Database table column separator (text-only terminals)." + :group 'sqlplus + :tag "SQL*Plus Table Col Separator" + :type '(string)) + +(defcustom sqlplus-table-col-head-separator "-+-" + "Database table header-column separator (text-only terminals)." + :group 'sqlplus + :tag "SQL*Plus Table Col Separator" + :type '(string)) + +(defcustom sqlplus-html-output-file-name "$HOME/sqlplus_report.html" + "Output file for HTML result." + :group 'sqlplus + :tag "SQL*Plus HTML Output File Name" + :type '(file)) + +(defcustom sqlplus-html-output-encoding "iso-8859-1" + "Encoding for SQL*Plus HTML output." + :group 'sqlplus + :tag "SQL*Plus HTML Output Encoding" + :type '(string)) + +(defcustom sqlplus-html-output-sql t + "Non-nil means put SQL*Plus command in head of HTML result." + :group 'sqlplus + :tag "SQL*Plus HTML Output Encoding" + :type '(choice (const :tag "Elegant" 'elegant) + (const :tag "Simple" t) + (const :tag "No" nil))) + +(defcustom sqlplus-html-output-header (concat (current-time-string) "<br><br>") + "HTML header sexp (result must be string)." + :group 'sqlplus + :tag "SQL*Plus HTML Output Header" + :type '(sexp)) + +(defcustom sqlplus-command-highlighting-percentage 7 + "SQL*Plus command highlighting percentage (0-100), only if sqlplus-command-highlighting-style is set." + :group 'sqlplus + :tag "SQL*Plus command highlighting percentage" + :type '(integer)) + +(defcustom sqlplus-command-highlighting-style nil + "How to highlight current command in sqlplus buffer." + :group 'sqlplus + :tag "SQL*Plud command highlighting style" + :type '(choice (const :tag "Fringe" fringe) + (const :tag "Background" background) + (const :tag "Fringe and background" fringe-and-background) + (const :tag "None" nil))) + +(defvar sqlplus-elegant-style window-system) + +(defvar sqlplus-cs nil) + +(defun sqlplus-shine-color (color percent) + (when (equal color "unspecified-bg") + (setq color (if (< percent 0) "white" "black"))) + (apply 'format "#%02x%02x%02x" + (mapcar (lambda (value) + (min 65535 (max 0 (* (+ (/ value 650) percent) 650)))) + (color-values color)))) + +(defvar sqlplus-table-head-face 'sqlplus-table-head-face) +(defface sqlplus-table-head-face + (list + (list '((class mono)) + '(:inherit default :weight bold :inverse-video t)) + (list '((background light)) + (append (list :inherit 'default :background (sqlplus-shine-color (face-background 'default) -70) :foreground (face-background 'default)) + (when (and sqlplus-elegant-style (>= emacs-major-version 22)) '(:box (:style released-button))))) + (list '((background dark)) + (append (list :inherit 'default :background (sqlplus-shine-color (face-background 'default) +70) :foreground (face-background 'default)) + (when (and sqlplus-elegant-style (>= emacs-major-version 22)) '(:box (:style released-button))))) + '(t (:inherit default))) + "Face for table header" + :group 'sqlplus) + +(defvar sqlplus-table-even-rows-face 'sqlplus-table-even-rows-face) +(defface sqlplus-table-even-rows-face + (list + (list '((class mono)) '()) + (list '((type tty)) '()) + (list '((background light)) + (append (list :inherit 'default :background (sqlplus-shine-color (face-background 'default) -20) :overline (face-background 'default)))) + (list '((background dark)) + (append (list :inherit 'default :background (sqlplus-shine-color (face-background 'default) +20) :overline (face-background 'default)))) + '(t ())) + "Face for table even rows" + :group 'sqlplus) + +(defvar sqlplus-table-odd-rows-face 'sqlplus-table-odd-rows-face) +(defface sqlplus-table-odd-rows-face + (list + (list '((class mono)) '(:inherit default)) + (list '((background light)) + (append (list :inherit 'default :background (sqlplus-shine-color (face-background 'default) -30) :overline (face-background 'default)))) + (list '((background dark)) + (append (list :inherit 'default :background (sqlplus-shine-color (face-background 'default) +30) :overline (face-background 'default)))) + '(t (:inherit default))) + "Face for table even rows" + :group 'sqlplus) + +(defvar sqlplus-command-highlight-face 'sqlplus-command-highlight-face) +(defface sqlplus-command-highlight-face + (list + '(((class mono)) ()) + '(((type tty)) ()) + (list '((background light)) + (append (list :background (sqlplus-shine-color (face-background 'default) (- sqlplus-command-highlighting-percentage))))) + (list '((background dark)) + (append (list :background (sqlplus-shine-color (face-background 'default) sqlplus-command-highlighting-percentage)))) + '(t ())) + "Face for highlighting command under point" + :group 'sqlplus) + +(defvar sqlplus-plsql-compilation-results-buffer-name "*PL/SQL Compilation*") + +(defvar sqlplus-fan "|" + "Local in input buffers") +(make-variable-buffer-local 'sqlplus-fan) + +(defvar orcl-mode-map nil + "Keymap used in Orcl mode.") + +(define-minor-mode orcl-mode + "Mode for executing SQL*Plus commands and scrolling results. + +Mode Specific Bindings: + +\\{orcl-mode-map}" + nil ; init value + (" " (:eval sqlplus-fan) " " (:eval (connect-string-to-string))) ; mode indicator + orcl-mode-map ; keymap + ;; body + (setq sqlplus-fan "|") + (unless (assq 'orcl-mode minor-mode-map-alist) + (push (cons 'orcl-mode orcl-mode-map) minor-mode-map-alist))) + +(defvar sqlplus-user-variables (makehash 'equal)) + +(defvar sqlplus-user-variables-history nil) + +(defvar sqlplus-get-source-history nil) + +(defvar sqlplus-process-p nil + "Non-nil (connect string) if current buffer is SQL*Plus process buffer. +Local in process buffer.") +(make-variable-buffer-local 'sqlplus-process-p) + +(defvar sqlplus-command-seq 0 + "Sequence for command id within SQL*Plus connection. +Local in process buffer.") +(make-variable-buffer-local 'sqlplus-command-seq) + +;;; :id - unique command identifier (from sequence, for session) +;;; :sql - content of command +;;; :dont-parse-result - process data online as it comes from sqlplus, with sqlplus-result-online or with :result-function function +;;; :result-function - function for processing sqlplus data; must have signature (context connect-string begin end interrupted); +;;; if nil then it is sqlplus-result-online for :dont-parse-result set to non-nil and sqlplus-process-command-output for :dont-parse-result set to nil +;;; :current-command-input-buffer-name - buffer name from which command was initialized +(defvar sqlplus-command-contexts nil + "Command options list, for current and enqueued commands, in chronological order. +Local in process buffer.") +(make-variable-buffer-local 'sqlplus-command-contexts) + +(defvar sqlplus-connect-string nil + "Local variable with connect-string for current buffer (input buffers, output buffer).") +(make-variable-buffer-local 'sqlplus-connect-string) + +(defvar sqlplus-connect-strings-alist nil + "Connect strings in format (CS . PASSWD), where PASSWD can be nil.") + +(defvar sqlplus-connect-string-history nil) + +(defvar sqlplus-prompt-prefix "SQL[") +(defvar sqlplus-prompt-suffix "]# ") + +(defvar sqlplus-page-separator "@!%#!") + +(defvar sqlplus-repfooter "##%@!") + +(defvar sqlplus-mode-map nil + "Keymap used in SQL*Plus mode.") + +(defvar sqlplus-output-separator "@--" + "String printed between sets of SQL*Plus command output.") + +;;; Markers - + +(defvar sqlplus-buffer-mark (make-marker) + "Marks the current SQL command in the SQL*Plus output buffer. +Local in output buffer.") +(make-variable-buffer-local 'sqlplus-buffer-mark) + +(defvar sqlplus-region-beginning-pos nil + "Marks the beginning of the region to sent to the SQL*Plus process. +Local in input buffer with sqlplus-mode.") +(make-variable-buffer-local 'sqlplus-region-beginning-pos) + +(defvar sqlplus-region-end-pos nil + "Marks the end of the region to sent to the SQL*Plus process. +Local in input buffer with sqlplus-mode.") +(make-variable-buffer-local 'sqlplus-region-end-pos) + +(defvar sqlplus-connections-menu + '("SQL*Plus" + :filter sqlplus-connections-menu) + "Menu for database connections") + +(defconst sqlplus-kill-xpm "\ +/* XPM */ +static char * reload_page_xpm[] = { +\"24 24 100 2\", +\" c None\", +\". c #000000\", +\"+ c #2A5695\", +\"@ c #30609E\", +\"# c #3363A2\", +\"$ c #3969A6\", +\"% c #3D6BA6\", +\"& c #3C68A3\", +\"* c #35619C\", +\"= c #244F8D\", +\"- c #3364A3\", +\"; c #3162A1\", +\"> c #3867A4\", +\", c #3F6DA8\", +\"' c #4672AC\", +\") c #4B76AE\", +\"! c #4E78AF\", +\"~ c #537CB1\", +\"{ c #547DB0\", +\"] c #446BA1\", +\"^ c #2E5D9C\", +\"/ c #234F8C\", +\"( c #214C89\", +\"_ c #244E8C\", +\": c #3A649D\", +\"< c #517BB0\", +\"[ c #517BB1\", +\"} c #4874AD\", +\"| c #6086B7\", +\"1 c #5F84B4\", +\"2 c #4B71A6\", +\"3 c #7B9BC4\", +\"4 c #224C89\", +\"5 c #3865A2\", +\"6 c #406FAB\", +\"7 c #436BA3\", +\"8 c #648ABA\", +\"9 c #4D78AF\", +\"0 c #4B77AE\", +\"a c #6E91BE\", +\"b c #809EC6\", +\"c c #204A87\", +\"d c #4974AF\", +\"e c #2B5590\", +\"f c #6487B5\", +\"g c #678CBB\", +\"h c #3465A4\", +\"i c #84A1C8\", +\"j c #6D8FBA\", +\"k c #4F7AB0\", +\"l c #8BA7CB\", +\"m c #7E9DC5\", +\"n c #83A1C7\", +\"o c #91ACCE\", +\"p c #89A4C9\", +\"q c #8FA9CB\", +\"r c #85A2C7\", +\"s c #90ABCC\", +\"t c #3E6CA8\", +\"u c #87A3C8\", +\"v c #4B6DA1\", +\"w c #91ABCD\", +\"x c #3768A5\", +\"y c #8AA5C9\", +\"z c #2D5690\", +\"A c #204A86\", +\"B c #93ADCE\", +\"C c #7294BF\", +\"D c #6288B9\", +\"E c #86A3C8\", +\"F c #466EA3\", +\"G c #3864A1\", +\"H c #285390\", +\"I c #234E8C\", +\"J c #95AECF\", +\"K c #7493BC\", +\"L c #86A2C7\", +\"M c #7999C3\", +\"N c #5B82B5\", +\"O c #6C8EBB\", +\"P c #4B71A5\", +\"Q c #26508B\", +\"R c #2B5792\", +\"S c #305E9B\", +\"T c #31619F\", +\"U c #7895BD\", +\"V c #819DC3\", +\"W c #688DBB\", +\"X c #6288B8\", +\"Y c #5880B4\", +\"Z c #577FB3\", +\"` c #547DB2\", +\" . c #416FAA\", +\".. c #3564A2\", +\"+. c #577AAB\", +\"@. c #6286B6\", +\"#. c #668BBA\", +\"$. c #507AB0\", +\"%. c #426EA8\", +\"&. c #2F5B97\", +\" \", +\" \", +\" \", +\" . . . . . . . . \", +\" . . + @ # $ % & * . . . . \", +\" . = - ; @ > , ' ) ! ~ { . . . ] . \", +\" . ^ / ( _ . . . : < [ } | 1 2 3 . \", +\" . _ 4 5 6 . . . 7 8 9 0 a b . \", +\" . c d . . . e f g h i . \", +\" . . . . . j k h l . \", +\" . . f m n l o . \", +\" . . . . . . . . \", +\" . . . . . . . . \", +\" . p q q q r . . \", +\" . s , t u v . . . . \", +\" . w x | y z . . . . A . \", +\" . B C 9 D E F . . . G H I . \", +\" . J K L M N C O P . . . Q R S T . \", +\" . U . . . V W X | Y Z ` ) .... \", +\" . . . . +.@.#.N $.%.&.. . \", +\" . . . . . . . . \", +\" \", +\" \", +\" \"}; +" + "XPM format image used as Kill icon") + +(defconst sqlplus-cancel-xpm "\ +/* XPM */ +static char * process_stop_xpm[] = { +\"24 24 197 2\", +\" c None\", +\". c #000000\", +\"+ c #C92B1E\", +\"@ c #DA432F\", +\"# c #E95941\", +\"$ c #F26B50\", +\"% c #ED6047\", +\"& c #DF4A35\", +\"* c #CE3324\", +\"= c #BF1D13\", +\"- c #EA5942\", +\"; c #EF563A\", +\"> c #F14D2C\", +\", c #F1431F\", +\"' c #F23A12\", +\") c #F2421C\", +\"! c #F24D2A\", +\"~ c #F15737\", +\"{ c #F0644A\", +\"] c #CF3121\", +\"^ c #D83828\", +\"/ c #ED5840\", +\"( c #EC3B1C\", +\"_ c #EE310B\", +\": c #F1350C\", +\"< c #F4380D\", +\"[ c #F53A0D\", +\"} c #F53B0D\", +\"| c #F4390D\", +\"1 c #F2360C\", +\"2 c #EF3A15\", +\"3 c #F05A3D\", +\"4 c #E44D37\", +\"5 c #CD2B1E\", +\"6 c #EA4D35\", +\"7 c #E92D0C\", +\"8 c #ED2F0B\", +\"9 c #F0330C\", +\"0 c #F3380D\", +\"a c #F63C0E\", +\"b c #F93F0F\", +\"c c #F9400F\", +\"d c #F73D0E\", +\"e c #F1340C\", +\"f c #EE300B\", +\"g c #EC482C\", +\"h c #E04532\", +\"i c #E84E3A\", +\"j c #E62A0E\", +\"k c #EA2B0A\", +\"l c #F83F0E\", +\"m c #FC4310\", +\"n c #FC4410\", +\"o c #F63B0E\", +\"p c #EB2C0A\", +\"q c #EB5139\", +\"r c #C8251A\", +\"s c #DD3D2E\", +\"t c #E5341D\", +\"u c #E62508\", +\"v c #F9BEB2\", +\"w c #FBCFC5\", +\"x c #F54C23\", +\"y c #F95125\", +\"z c #FDD4CB\", +\"A c #FABFB2\", +\"B c #E83013\", +\"C c #E84F3B\", +\"D c #E54737\", +\"E c #E22007\", +\"F c #E92A09\", +\"G c #FBD2CA\", +\"H c #FFFFFF\", +\"I c #FDDFD9\", +\"J c #F64E24\", +\"K c #FDE0D9\", +\"L c #E72609\", +\"M c #E7452F\", +\"N c #E33D2D\", +\"O c #E11E07\", +\"P c #E52308\", +\"Q c #E82809\", +\"R c #EC3F21\", +\"S c #FCDED8\", +\"T c #F55C37\", +\"U c #FCDFD8\", +\"V c #F04521\", +\"W c #EC2E0A\", +\"X c #E92909\", +\"Y c #E62408\", +\"Z c #E53823\", +\"` c #CE2B1F\", +\" . c #C62018\", +\".. c #E03120\", +\"+. c #E01C06\", +\"@. c #E32107\", +\"#. c #ED4121\", +\"$. c #FEF9F8\", +\"%. c #E72709\", +\"&. c #E42208\", +\"*. c #E32D17\", +\"=. c #D83729\", +\"-. c #CB231B\", +\";. c #DE2A1B\", +\">. c #DE1A06\", +\",. c #EE5135\", +\"'. c #EF5335\", +\"). c #EC2D0A\", +\"!. c #E82709\", +\"~. c #E21F07\", +\"{. c #E02511\", +\"]. c #DC392C\", +\"^. c #BE1612\", +\"/. c #DD2E21\", +\"(. c #DC1705\", +\"_. c #DF1B06\", +\":. c #E42308\", +\"<. c #E93A20\", +\"[. c #FBDDD8\", +\"}. c #EB3D20\", +\"|. c #DF2A18\", +\"1. c #D02A1F\", +\"2. c #DC3328\", +\"3. c #DA1404\", +\"4. c #DD1805\", +\"5. c #E3331E\", +\"6. c #FADCD8\", +\"7. c #FBDCD8\", +\"8. c #EB4C34\", +\"9. c #E6361F\", +\"0. c #DD1905\", +\"a. c #DF2F21\", +\"b. c #C21A14\", +\"c. c #DA3128\", +\"d. c #D81408\", +\"e. c #F7C9C4\", +\"f. c #FADBD8\", +\"g. c #E5341E\", +\"h. c #E5351E\", +\"i. c #F8CEC9\", +\"j. c #DB1505\", +\"k. c #DD3429\", +\"l. c #C31613\", +\"m. c #D9281F\", +\"n. c #D71003\", +\"o. c #D91304\", +\"p. c #F3B5B0\", +\"q. c #F7CDC9\", +\"r. c #E12F1D\", +\"s. c #DF1C06\", +\"t. c #E2301D\", +\"u. c #F4B6B0\", +\"v. c #DC1605\", +\"w. c #DB2317\", +\"x. c #D2271F\", +\"y. c #D1231D\", +\"z. c #D61A10\", +\"A. c #D60F03\", +\"B. c #D81104\", +\"C. c #DB1605\", +\"D. c #D81204\", +\"E. c #D81509\", +\"F. c #DA2F26\", +\"G. c #D52620\", +\"H. c #D51A12\", +\"I. c #D50D03\", +\"J. c #D60E03\", +\"K. c #D6170D\", +\"L. c #D92B23\", +\"M. c #BD100D\", +\"N. c #AB0404\", +\"O. c #CE1D19\", +\"P. c #D6231C\", +\"Q. c #D41008\", +\"R. c #D40B02\", +\"S. c #D40C02\", +\"T. c #D50C03\", +\"U. c #D40E05\", +\"V. c #D62018\", +\"W. c #D4251F\", +\"X. c #B30A09\", +\"Y. c #A20000\", +\"Z. c #BC0F0E\", +\"`. c #D2211E\", +\" + c #D52520\", +\".+ c #D5201A\", +\"++ c #D41A14\", +\"@+ c #D51F19\", +\"#+ c #D62620\", +\"$+ c #D52420\", +\"%+ c #C51614\", +\"&+ c #A30101\", +\"*+ c #A30303\", +\"=+ c #AE0909\", +\"-+ c #BD0E0E\", +\";+ c #B30B0B\", +\">+ c #A30404\", +\" \", +\" . . . . . . . \", +\" . . + @ # $ % & * . . \", +\" . = - ; > , ' ) ! ~ { ] . \", +\" . ^ / ( _ : < [ } | 1 2 3 4 . \", +\" . 5 6 7 8 9 0 a b c d | e f g h . \", +\" . i j k f : [ l m n c o 1 _ p q r . \", +\" . s t u k v w x l m n y z A _ p B C . \", +\" . D E u F G H I J b y K H w f k L M . \", +\" . N O P Q R S H I T K H U V W X Y Z ` . \", +\" . ...+.@.u F #.S H $.H U V 8 k %.&.*.=.. \", +\" . -.;.>.O &.L F ,.$.H $.'.).k !.P ~.{.].. \", +\" . ^./.(._.~.:.<.[.H $.H [.}.L P E +.|.1.. \", +\" . 2.3.4._.5.6.H 7.8.7.H 6.9.~.+.0.a.b.. \", +\" . c.d.3.(.e.H f.g.@.h.6.H i._.4.j.k.. \", +\" . l.m.n.o.p.q.r._.s.s.t.e.u.v.3.w.x.. \", +\" . y.z.A.B.o.j.C.(.(.v.j.3.D.E.F.. \", +\" . G.H.I.J.n.B.B.B.B.n.A.K.L.M.. \", +\" . N.O.P.Q.R.S.T.T.S.U.V.W.X.. \", +\" . Y.Z.`. +.+++@+#+$+%+&+. \", +\" . . . *+=+-+;+>+Y.. . \", +\" . . . . . . \", +\" \", +\" \"}; +" + "XPM format image used as Cancel icon") + +(defconst sqlplus-rollback-xpm "\ +/* XPM */ +static char * rollback_xpm[] = { +\"24 24 228 2\", +\" c None\", +\". c #000000\", +\"+ c #F8F080\", +\"@ c #FEF57B\", +\"# c #FFF571\", +\"$ c #FFF164\", +\"% c #FFED58\", +\"& c #FFE748\", +\"* c #FEDE39\", +\"= c #F8F897\", +\"- c #FFFE96\", +\"; c #FFFA8A\", +\"> c #FFF67C\", +\", c #FFF16E\", +\"' c #FFEC62\", +\") c #FFE956\", +\"! c #FFE448\", +\"~ c #FFE03C\", +\"{ c #FFDD30\", +\"] c #FED821\", +\"^ c #F1CB15\", +\"/ c #FFFC92\", +\"( c #FFFC91\", +\"_ c #FFFC90\", +\": c #FFFB8D\", +\"< c #FFF67D\", +\"[ c #FFEB5E\", +\"} c #FFEA5B\", +\"| c #FFE958\", +\"1 c #FFE855\", +\"2 c #FFE752\", +\"3 c #FDD41C\", +\"4 c #FDD319\", +\"5 c #FDD416\", +\"6 c #FFFF9D\", +\"7 c #FFFF99\", +\"8 c #FFFD94\", +\"9 c #FFFA89\", +\"0 c #FFDC2F\", +\"a c #FED315\", +\"b c #FFD808\", +\"c c #FFFC9F\", +\"d c #FFFE99\", +\"e c #FFDF3B\", +\"f c #F7C909\", +\"g c #F8EA86\", +\"h c #FEFCB7\", +\"i c #FFFDA6\", +\"j c #FFFA91\", +\"k c #FFF681\", +\"l c #FFF171\", +\"m c #FFED64\", +\"n c #FFE44A\", +\"o c #FFE03D\", +\"p c #FEDB2F\", +\"q c #F9D21E\", +\"r c #E9BC0F\", +\"s c #CE9C02\", +\"t c #F3E36A\", +\"u c #FCF899\", +\"v c #FFFCA3\", +\"w c #FEF694\", +\"x c #FFF284\", +\"y c #FFEE71\", +\"z c #FFEA62\", +\"A c #FDDC40\", +\"B c #F8D22F\", +\"C c #F1C61B\", +\"D c #DDAD0A\", +\"E c #CC9A02\", +\"F c #C89500\", +\"G c #F4EA77\", +\"H c #F7EF7F\", +\"I c #FFF16A\", +\"J c #FFEF68\", +\"K c #FFEE66\", +\"L c #FED622\", +\"M c #FED51E\", +\"N c #FED419\", +\"O c #E9B90E\", +\"P c #E7B509\", +\"Q c #D4A202\", +\"R c #CA9700\", +\"S c #F6E67C\", +\"T c #F3E67F\", +\"U c #FCEE7A\", +\"V c #FDEB66\", +\"W c #FEE44E\", +\"X c #FED313\", +\"Y c #FDCA03\", +\"Z c #F2BE01\", +\"` c #D4A60D\", +\" . c #D4A206\", +\".. c #D19C00\", +\"+. c #CF9800\", +\"@. c #E3AF02\", +\"#. c #F9EB81\", +\"$. c #FBF096\", +\"%. c #F9E67C\", +\"&. c #F8DC5F\", +\"*. c #F8D548\", +\"=. c #F9D02D\", +\"-. c #F9C915\", +\";. c #F7C104\", +\">. c #EEB606\", +\",. c #E9B704\", +\"'. c #DEAE08\", +\"). c #414D7B\", +\"!. c #3C5CA2\", +\"~. c #3A65B3\", +\"{. c #3668BB\", +\"]. c #325EAF\", +\"^. c #F3E46E\", +\"/. c #FCFA9B\", +\"(. c #FFF89C\", +\"_. c #FDEC81\", +\":. c #FCE668\", +\"<. c #FDDF4E\", +\"[. c #FCDA3C\", +\"}. c #FCD52E\", +\"|. c #FAD026\", +\"1. c #4662A2\", +\"2. c #465A8D\", +\"3. c #3F6CBA\", +\"4. c #3A68B7\", +\"5. c #2E529E\", +\"6. c #2655AC\", +\"7. c #F0DC69\", +\"8. c #FBF78C\", +\"9. c #FFF880\", +\"0. c #FFF06B\", +\"a. c #FFE03E\", +\"b. c #FFD828\", +\"c. c #FED015\", +\"d. c #F5C40A\", +\"e. c #4B70B4\", +\"f. c #4870B7\", +\"g. c #3C5CA1\", +\"h. c #4070BF\", +\"i. c #3759A0\", +\"j. c #1D469C\", +\"k. c #214493\", +\"l. c #F2DD6C\", +\"m. c #F8EB7E\", +\"n. c #FBEE7A\", +\"o. c #FBE461\", +\"p. c #FADB48\", +\"q. c #FBD631\", +\"r. c #FED10F\", +\"s. c #FECD07\", +\"t. c #F1BD00\", +\"u. c #456AAE\", +\"v. c #4C7ECA\", +\"w. c #487AC8\", +\"x. c #35528F\", +\"y. c #1B4294\", +\"z. c #1B4193\", +\"A. c #F9EA83\", +\"B. c #FCF08E\", +\"C. c #F6E16E\", +\"D. c #F4D559\", +\"E. c #F5CF45\", +\"F. c #F6CB2E\", +\"G. c #F8C611\", +\"H. c #F6C005\", +\"I. c #E8B300\", +\"J. c #4268AE\", +\"K. c #4375C4\", +\"L. c #3F71C1\", +\"M. c #33569B\", +\"N. c #173F94\", +\"O. c #183A8B\", +\"P. c #F3E36E\", +\"Q. c #FCF7A1\", +\"R. c #FEF9A1\", +\"S. c #FEEE7D\", +\"T. c #FCE360\", +\"U. c #FAD946\", +\"V. c #F9D132\", +\"W. c #F8CD26\", +\"X. c #F7CA20\", +\"Y. c #3B589A\", +\"Z. c #395FA9\", +\"`. c #3359A5\", +\" + c #3056A3\", +\".+ c #2B468D\", +\"++ c #0A3897\", +\"@+ c #E6D465\", +\"#+ c #FDFA90\", +\"$+ c #FFF885\", +\"%+ c #FFF074\", +\"&+ c #FFEA60\", +\"*+ c #FFE246\", +\"=+ c #FFDC31\", +\"-+ c #FED51F\", +\";+ c #F7CB14\", +\">+ c #173788\", +\",+ c #063494\", +\"'+ c #E8DE7B\", +\")+ c #FFFA86\", +\"!+ c #FFF26A\", +\"~+ c #FFE84F\", +\"{+ c #FFD415\", +\"]+ c #FDCC04\", +\"^+ c #F3C001\", +\"/+ c #EBB600\", +\"(+ c #E3AF01\", +\"_+ c #D7A100\", +\":+ c #2D3E7F\", +\"<+ c #033396\", +\"[+ c #CFB954\", +\"}+ c #DBC347\", +\"|+ c #DEBF2C\", +\"1+ c #DFB718\", +\"2+ c #DFB206\", +\"3+ c #D6A505\", +\"4+ c #C6970A\", +\"5+ c #B48413\", +\"6+ c #374682\", +\"7+ c #023398\", +\"8+ c #0E3287\", +\"9+ c #253775\", +\"0+ c #05318F\", +\"a+ c #10358B\", +\"b+ c #183888\", +\"c+ c #053495\", +\"d+ c #0E348D\", +\"e+ c #183585\", +\" . . . . . . . \", +\" . . + @ # $ % & * . . . \", +\" . = - ; > , ' ) ! ~ { ] ^ . \", +\". / ( _ : ; < [ } | 1 2 3 4 5 . \", +\". 6 7 8 9 > , ' ) ! ~ 0 ] a b . \", +\". c d 8 9 > , ' ) ! e 0 ] a f . \", +\". g h i j k l m | n o p q r s . \", +\". t u v w x y z 2 A B C D E F . \", +\". G H I J K L M N O P Q R F F . \", +\". S T U V W p X Y Z ` ...+.@.. . . . . \", +\". #.$.%.&.*.=.-.;.>.. . ,.'.. ).!.~.{.].. \", +\". ^./.(._.:.<.[.}.|.. 1.. . 2.3.4.. . 5.6.. \", +\". 7.8.9.0.) a.b.c.d.. e.f.g.h.i.. . j.k.. \", +\". l.m.n.o.p.q.r.s.t.. u.v.w.x.. . y.z.. \", +\". A.B.C.D.E.F.G.H.I.. J.K.L.M.. . N.O.. \", +\". P.Q.R.S.T.U.V.W.X.. Y.Z.`. +.+. . ++. \", +\". @+#+$+%+&+*+=+-+;+. . . . . . . . >+,+. \", +\" . '+)+!+~+{ {+]+^+/+(+_+. . :+<+. \", +\" . . [+}+|+1+2+3+4+5+. . 6+7+8+. \", +\" . . . . . . . . . 9+0+a+. \", +\" . b+c+d+. \", +\" . e+. . \", +\" . \", +\" \"}; +" + "XPM format image used as Rollback icon") + +(defconst sqlplus-commit-xpm "\ +/* XPM */ +static char * commit_xpm[] = { +\"24 24 276 2\", +\" c None\", +\". c #000000\", +\"+ c #FDF57D\", +\"@ c #FFF676\", +\"# c #FFF36C\", +\"$ c #FFF05D\", +\"% c #FFEB51\", +\"& c #FFE445\", +\"* c #FDDC35\", +\"= c #EFEA85\", +\"- c #FBF68D\", +\"; c #FCF482\", +\"> c #FCF178\", +\", c #FCEE6E\", +\"' c #FCEB66\", +\") c #FCE85B\", +\"! c #FCE551\", +\"~ c #FDE147\", +\"{ c #FDDF3D\", +\"] c #FEDD2D\", +\"^ c #FCD621\", +\"/ c #E5BF16\", +\"( c #D8D479\", +\"_ c #FCF587\", +\": c #FAEF78\", +\"< c #FAEA6B\", +\"[ c #FAEA6A\", +\"} c #FAE968\", +\"| c #FAE967\", +\"1 c #FAE865\", +\"2 c #FAE864\", +\"3 c #FDDD3C\", +\"4 c #FED621\", +\"5 c #FFD51D\", +\"6 c #FFD51B\", +\"7 c #FFD519\", +\"8 c #D8B82B\", +\"9 c #FCF790\", +\"0 c #FBF587\", +\"a c #F8EF7D\", +\"b c #F8EC75\", +\"c c #F7E86B\", +\"d c #F8E868\", +\"e c #F9E663\", +\"f c #F9E45A\", +\"g c #F9E253\", +\"h c #F9E04C\", +\"i c #FBDD40\", +\"j c #FBDB38\", +\"k c #FAD933\", +\"l c #FAD529\", +\"m c #FDD810\", +\"n c #FFFD9E\", +\"o c #FFFF9A\", +\"p c #FFFE96\", +\"q c #FFFB8C\", +\"r c #FFF781\", +\"s c #FFF375\", +\"t c #FFEF69\", +\"u c #FFEA5B\", +\"v c #FFE750\", +\"w c #FFE345\", +\"x c #FFDF38\", +\"y c #FFDB2B\", +\"z c #FFD81F\", +\"A c #FFD313\", +\"B c #FBD007\", +\"C c #FBF090\", +\"D c #FFFDAE\", +\"E c #FFFEA2\", +\"F c #FFFA8C\", +\"G c #FFF780\", +\"H c #F6CA11\", +\"I c #E1AF03\", +\"J c #F4E36D\", +\"K c #FCF7A4\", +\"L c #FFFEBB\", +\"M c #FEFAA6\", +\"N c #FFF990\", +\"O c #FFF57E\", +\"P c #FFEE6F\", +\"Q c #FFEB61\", +\"R c #FFE856\", +\"S c #FFE34A\", +\"T c #FBDD44\", +\"U c #F7D535\", +\"V c #EBBF13\", +\"W c #D5A406\", +\"X c #C99500\", +\"Y c #F0DC5F\", +\"Z c #F3E772\", +\"` c #F7EC76\", +\" . c #F6E56D\", +\".. c #F6E369\", +\"+. c #F6E264\", +\"@. c #F5DF5C\", +\"#. c #F3DB53\", +\"$. c #F3D849\", +\"%. c #EFD245\", +\"&. c #ECCE3F\", +\"*. c #E3B91F\", +\"=. c #D3A40B\", +\"-. c #C99600\", +\";. c #C69200\", +\">. c #EED95E\", +\",. c #EDDA60\", +\"'. c #F1DF64\", +\"). c #F2DF5E\", +\"!. c #F2DD57\", +\"~. c #F2D94E\", +\"{. c #F2D644\", +\"]. c #EFD038\", +\"^. c #ECCB34\", +\"/. c #E6C430\", +\"(. c #DFB71F\", +\"_. c #D9AD17\", +\":. c #CC9907\", +\"<. c #C69000\", +\"[. c #D39E00\", +\"}. c #BB1503\", +\"|. c #F9EA7D\", +\"1. c #F6E57A\", +\"2. c #F5E370\", +\"3. c #F5DE62\", +\"4. c #F9DF52\", +\"5. c #FBDB3E\", +\"6. c #FCD526\", +\"7. c #FCCE0F\", +\"8. c #F7C50A\", +\"9. c #EEBA08\", +\"0. c #E2AB03\", +\"a. c #D7A000\", +\"b. c #D59D00\", +\"c. c #DFA901\", +\"d. c #E7B402\", +\"e. c #C91800\", +\"f. c #F6E676\", +\"g. c #FCF4A1\", +\"h. c #FDF096\", +\"i. c #FAE167\", +\"j. c #F7D64F\", +\"k. c #F7CF38\", +\"l. c #F7CB26\", +\"m. c #F6BF0C\", +\"n. c #F1B905\", +\"o. c #ECB309\", +\"p. c #EBB60A\", +\"q. c #F0BF0B\", +\"r. c #F3C206\", +\"s. c #E5B201\", +\"t. c #CF9C01\", +\"u. c #C21602\", +\"v. c #C21703\", +\"w. c #F2E067\", +\"x. c #FBF78F\", +\"y. c #FEF28A\", +\"z. c #FEED74\", +\"A. c #FFE85F\", +\"B. c #FFE24D\", +\"C. c #FFDE3A\", +\"D. c #FED92F\", +\"E. c #FCD325\", +\"F. c #F8CD1A\", +\"G. c #EDBD0A\", +\"H. c #D9A701\", +\"I. c #C79200\", +\"J. c #D11D00\", +\"K. c #EFDA64\", +\"L. c #F7EF7F\", +\"M. c #FCF47F\", +\"N. c #FDEE6C\", +\"O. c #FDE85B\", +\"P. c #FDE249\", +\"Q. c #FDDC36\", +\"R. c #FCD423\", +\"S. c #F9CC14\", +\"T. c #F0C10E\", +\"U. c #E6B507\", +\"V. c #DCA900\", +\"W. c #D29F00\", +\"X. c #C69400\", +\"Y. c #C99200\", +\"Z. c #CC1B02\", +\"`. c #C61A04\", +\" + c #E1CF5F\", +\".+ c #EAD862\", +\"++ c #ECDB63\", +\"@+ c #EFDC5E\", +\"#+ c #EFD955\", +\"$+ c #EFD74D\", +\"%+ c #EFD444\", +\"&+ c #F0D23E\", +\"*+ c #EECE37\", +\"=+ c #E8C731\", +\"-+ c #E0B922\", +\";+ c #D09E03\", +\">+ c #CB9700\", +\",+ c #C39100\", +\"'+ c #C99400\", +\")+ c #E12400\", +\"!+ c #F2E47C\", +\"~+ c #F8ED8C\", +\"{+ c #F4E171\", +\"]+ c #F0D65B\", +\"^+ c #F0D24F\", +\"/+ c #F1CF43\", +\"(+ c #F2CD34\", +\"_+ c #F2C824\", +\":+ c #EEC527\", +\"<+ c #E7BD23\", +\"[+ c #DFAC12\", +\"}+ c #DAA203\", +\"|+ c #E5B202\", +\"1+ c #EDBA01\", +\"2+ c #D69F00\", +\"3+ c #D21E01\", +\"4+ c #D01C00\", +\"5+ c #F2E16A\", +\"6+ c #FBF59D\", +\"7+ c #FEFBAA\", +\"8+ c #FEF084\", +\"9+ c #FCE567\", +\"0+ c #FBDD50\", +\"a+ c #F8D23B\", +\"b+ c #F8CD28\", +\"c+ c #EEB51C\", +\"d+ c #DA8A13\", +\"e+ c #E29A16\", +\"f+ c #EDB111\", +\"g+ c #E5AE08\", +\"h+ c #D19C01\", +\"i+ c #C79400\", +\"j+ c #BF1603\", +\"k+ c #DD2300\", +\"l+ c #E6D261\", +\"m+ c #FCF88C\", +\"n+ c #FFF27A\", +\"o+ c #FFEC6A\", +\"p+ c #FFE655\", +\"q+ c #FFE041\", +\"r+ c #FFDA2B\", +\"s+ c #E49D14\", +\"t+ c #BA4F02\", +\"u+ c #BB6A00\", +\"v+ c #B37102\", +\"w+ c #DD2200\", +\"x+ c #CA1B02\", +\"y+ c #E6DB78\", +\"z+ c #FEFB8B\", +\"A+ c #FFF470\", +\"B+ c #FFEA56\", +\"C+ c #FFE13E\", +\"D+ c #FFDA24\", +\"E+ c #FECF0A\", +\"F+ c #F5BE01\", +\"G+ c #D37800\", +\"H+ c #D72000\", +\"I+ c #C61802\", +\"J+ c #EBD55C\", +\"K+ c #FCE353\", +\"L+ c #FFE33E\", +\"M+ c #FFDB26\", +\"N+ c #FFD20B\", +\"O+ c #FCCB01\", +\"P+ c #F0B900\", +\"Q+ c #D47D00\", +\"R+ c #E42500\", +\"S+ c #EB2900\", +\"T+ c #DF2301\", +\"U+ c #E82700\", +\"V+ c #D31F04\", +\"W+ c #C71F01\", +\"X+ c #EA2800\", +\"Y+ c #E92800\", +\"Z+ c #DD2301\", +\"`+ c #E22501\", +\" . . . . . . . \", +\" . . . + @ # $ % & * . . . \", +\" . = - ; > , ' ) ! ~ { ] ^ / . \", +\". ( _ : < [ } | 1 2 3 4 5 6 7 8 . \", +\". 9 0 a b c d e f g h i j k l m . \", +\". n o p q r s t u v w x y z A B . \", +\". C D E F G s t u v w x y z H I . \", +\". J K L M N O P Q R S T U V W X . \", +\". Y Z ` ...+.@.#.$.%.&.*.=.-.;.. . . \", +\". >.,.'.).!.~.{.].^./.(._.:.<.[.. . }.. \", +\". |.1.2.3.4.5.6.7.8.9.0.a.b.c.d.. . e.. \", +\". f.g.h.i.j.k.l.m.n.o.p.q.r.s.t.. . u.v.. \", +\". w.x.n y.z.A.B.C.D.E.F.G.H.-.I.. . J.. \", +\". K.L.M.N.O.P.Q.R.S.T.U.V.W.X.Y.. . Z.`.. \", +\". +.+++@+#+$+%+&+*+=+-+;+>+,+'+. . )+. \", +\". !+~+{+]+^+/+(+_+:+<+[+}+|+1+2+. . 3+4+. \", +\". 5+6+7+8+9+0+a+b+c+d+e+f+g+h+i+. j+k+. \", +\". l+m+q n+o+p+q+r+s+. . . t+u+v+. w+x+. \", +\" . y+z+A+B+C+D+E+F+G+. H+. . . I+)+. \", +\" . . J+K+L+M+N+O+P+Q+. R+S+T+U+V+. \", +\" . . . . . . . . . . W+X+Y+. \", +\" . Z+`+. \", +\" . . \", +\" . \"}; +" + "XPM format image used as Commit icon") + +(defconst plsql-prev-mark-xpm "\ +/* XPM */ +static char * go_previous_xpm[] = { +\"24 24 59 1\", +\" c None\", +\". c #000000\", +\"+ c #355D96\", +\"@ c #3C639B\", +\"# c #6E92BF\", +\"$ c #41679D\", +\"% c #6990BE\", +\"& c #6D94C2\", +\"* c #456DA2\", +\"= c #628BBC\", +\"- c #4D7BB4\", +\"; c #6991C0\", +\"> c #4971A6\", +\", c #5D87BA\", +\"' c #4B7BB3\", +\") c #4979B3\", +\"! c #5884B9\", +\"~ c #638CBC\", +\"{ c #638BBC\", +\"] c #6089BA\", +\"^ c #4B73A9\", +\"/ c #5883B8\", +\"( c #4A7AB3\", +\"_ c #618ABB\", +\": c #4C74AB\", +\"< c #547FB5\", +\"[ c #4972A9\", +\"} c #4D79B1\", +\"| c #4171AD\", +\"1 c #4071AD\", +\"2 c #4070AD\", +\"3 c #4171AC\", +\"4 c #4071AC\", +\"5 c #4070AC\", +\"6 c #3F70AC\", +\"7 c #3F70AB\", +\"8 c #406FAC\", +\"9 c #5781B5\", +\"0 c #4A74AC\", +\"a c #3E6CA8\", +\"b c #3465A4\", +\"c c #4E78AF\", +\"d c #446FA8\", +\"e c #4A75AD\", +\"f c #3F6CA6\", +\"g c #3C6BA7\", +\"h c #3B6BA7\", +\"i c #4471AB\", +\"j c #4572AB\", +\"k c #4672AC\", +\"l c #4571AB\", +\"m c #3A68A3\", +\"n c #3B6AA7\", +\"o c #406EA9\", +\"p c #3564A0\", +\"q c #3868A6\", +\"r c #305E9D\", +\"s c #3767A5\", +\"t c #2E5D9B\", +\" \", +\" \", +\" \", +\" .. \", +\" .+. \", +\" .@#. \", +\" .$%&. \", +\" .*=-;......... \", +\" .>,')!~{{{{{~]. \", +\" .^/()))(((((('_. \", +\" .:<)))))))))))),. \", +\" .[}|1123455567589. \", +\" .0abbbbbbbbbbbbc. \", +\" .dabbbbbbbbbbbe. \", +\" .fgbbhijjjjjkl. \", +\" .mnbo......... \", +\" .pqh. \", +\" .rs. \", +\" .t. \", +\" .. \", +\" . \", +\" \", +\" \", +\" \"}; +" + "XPM format image used as Previous Mark icon") + +(defconst plsql-next-mark-xpm "\ +/* XPM */ +static char * go_next_xpm[] = { +\"24 24 63 1\", +\" c None\", +\". c #000000\", +\"+ c #365F97\", +\"@ c #6B8FBE\", +\"# c #41689E\", +\"$ c #6990BF\", +\"% c #466EA4\", +\"& c #678EBD\", +\"* c #4E7DB5\", +\"= c #638CBC\", +\"- c #4B72A7\", +\"; c #5B83B5\", +\"> c #628BBB\", +\", c #5A86BA\", +\"' c #4979B3\", +\") c #4B7AB3\", +\"! c #5E87B9\", +\"~ c #4E76AA\", +\"{ c #5B84B8\", +\"] c #4E7CB5\", +\"^ c #4A7AB3\", +\"/ c #5883B7\", +\"( c #5178AD\", +\"_ c #5982B6\", +\": c #4C7BB4\", +\"< c #537FB5\", +\"[ c #5079AE\", +\"} c #507BB0\", +\"| c #4272AD\", +\"1 c #4070AC\", +\"2 c #3F70AB\", +\"3 c #3F70AC\", +\"4 c #4071AC\", +\"5 c #4171AC\", +\"6 c #4070AD\", +\"7 c #4071AD\", +\"8 c #4171AD\", +\"9 c #4D79B1\", +\"0 c #4E76AD\", +\"a c #4872AA\", +\"b c #3767A5\", +\"c c #3465A4\", +\"d c #3D6CA8\", +\"e c #4C76AD\", +\"f c #2B548E\", +\"g c #446FA8\", +\"h c #3C6BA7\", +\"i c #4772AA\", +\"j c #29528E\", +\"k c #3F6CA6\", +\"l c #4471AB\", +\"m c #4371AB\", +\"n c #3B6BA7\", +\"o c #416EA8\", +\"p c #3F6CA7\", +\"q c #3A69A6\", +\"r c #3C6AA5\", +\"s c #3B6AA5\", +\"t c #3868A6\", +\"u c #3765A2\", +\"v c #3666A3\", +\"w c #32619F\", +\"x c #2F5D9B\", +\" \", +\" \", +\" \", +\" .. \", +\" .+. \", +\" .@#. \", +\" .$$%. \", +\" .........&*=-. \", +\" .;>>>>>>=,')!~. \", +\" .{]^^^^^^''''/(. \", +\" ._:'''''''''''<[. \", +\" .}|12311145677890. \", +\" .abcccccccccccde. \", +\" .gbcccccccccchi. \", +\" .klmlllllhccno. \", +\" .........pcqr. \", +\" .stu. \", +\" .vw. \", +\" .x. \", +\" .. \", +\" . \", +\" \", +\" \", +\" \"}; +" + "XPM format image used as Next Mark icon") + +(defconst sqlplus-kill-image + (create-image sqlplus-kill-xpm 'xpm t)) + +(defconst sqlplus-cancel-image + (create-image sqlplus-cancel-xpm 'xpm t)) + +(defconst sqlplus-commit-image + (create-image sqlplus-commit-xpm 'xpm t)) + +(defconst sqlplus-rollback-image + (create-image sqlplus-rollback-xpm 'xpm t)) + +(defconst plsql-prev-mark-image + (create-image plsql-prev-mark-xpm 'xpm t)) + +(defconst plsql-next-mark-image + (create-image plsql-next-mark-xpm 'xpm t)) + +(defvar sqlplus-mode-syntax-table nil + "Syntax table used while in sqlplus-mode.") + +(defvar sqlplus-suppress-show-output-buffer nil) + +;; Local in input buffers +(defvar sqlplus-font-lock-keywords-1 nil) +(make-variable-buffer-local 'sqlplus-font-lock-keywords-1) +(defvar sqlplus-font-lock-keywords-2 nil) +(make-variable-buffer-local 'sqlplus-font-lock-keywords-2) +(defvar sqlplus-font-lock-keywords-3 nil) +(make-variable-buffer-local 'sqlplus-font-lock-keywords-3) + +(defvar sqlplus-font-lock-defaults '((sqlplus-font-lock-keywords-1 sqlplus-font-lock-keywords-2 sqlplus-font-lock-keywords-3) nil t nil nil)) + +(defvar sqlplus-oracle-extra-builtin-functions-re + (concat "\\b" + (regexp-opt '("acos" "asciistr" "asin" "atan" "atan2" "bfilename" "bin_to_num" "bitand" "cardinality" "cast" "coalesce" "collect" + "compose" "corr" "corr_s" "corr_k" "covar_pop" "covar_samp" "cume_dist" "current_date" "current_timestamp" "cv" + "dbtimezone" "decompose" "dense_rank" "depth" "deref" "empty_blob, empty_clob" "existsnode" "extract" + "extractvalue" "first" "first_value" "from_tz" "group_id" "grouping" "grouping_id" "iteration_number" + "lag" "last" "last_value" "lead" "lnnvl" "localtimestamp" "make_ref" "median" "nanvl" "nchr" "nls_charset_decl_len" + "nls_charset_id" "nls_charset_name" "ntile" "nullif" "numtodsinterval" "numtoyminterval" "nvl2" "ora_hash" "path" + "percent_rank" "percentile_cont" "percentile_disc" "powermultiset" "powermultiset_by_cardinality" "presentnnv" + "presentv" "previous" "rank" "ratio_to_report" "rawtonhex" "ref" "reftohex" "regexp_instr" "regexp_replace" + "regexp_substr" "regr_slope" "regr_intercept" "regr_count" "regr_r2" "regr_avgx" "regr_avgy" "regr_sxx" "regr_syy" + "regr_sxy" "remainder" "row_number" "rowidtonchar" "scn_to_timestamp" "sessiontimezone" "stats_binomial_test" + "stats_crosstab" "stats_f_test" "stats_ks_test" "stats_mode" "stats_mw_test" "stats_one_way_anova" "stats_t_test_one" + "stats_t_test_paired" "stats_t_test_indep" "stats_t_test_indepu" "stats_wsr_test" "stddev_pop" "stddev_samp" + "sys_connect_by_path" "sys_context" "sys_dburigen" "sys_extract_utc" "sys_guid" "sys_typeid" "sys_xmlagg" "sys_xmlgen" + "systimestamp" "timestamp_to_scn" "to_binary_double" "to_binary_float" "to_clob" "to_dsinterval" "to_lob" "to_nchar" + "to_nclob" "to_timestamp" "to_timestamp_tz" "to_yminterval" "treat" "tz_offset" "unistr" "updatexml" "value" "var_pop" + "var_samp" "width_bucket" "xmlagg" "xmlcolattval" "xmlconcat" "xmlelement" "xmlforest" "xmlsequence" "xmltransform") t) + "\\b")) +(defvar sqlplus-oracle-extra-warning-words-re + (concat "\\b" + (regexp-opt '("access_into_null" "case_not_found" "collection_is_null" "rowtype_mismatch" + "self_is_null" "subscript_beyond_count" "subscript_outside_limit" "sys_invalid_rowid") t) + "\\b")) +(defvar sqlplus-oracle-extra-keywords-re + (concat "\\b\\(" + "\\(at\\s-+local\\|at\\s-+time\\s-+zone\\|to\\s-+second\\|to\\s-+month\\|is\\s-+present\\|a\\s-+set\\)\\|" + (regexp-opt '("case" "nan" "infinite" "equals_path" "empty" "likec" "like2" "like4" "member" + "regexp_like" "submultiset" "under_path" "mlslabel") t) + "\\)\\b")) +(defvar sqlplus-oracle-extra-pseudocolumns-re + (concat "\\b" + (regexp-opt '("connect_by_iscycle" "connect_by_isleaf" "versions_starttime" "versions_startscn" + "versions_endtime" "versions_endscn" "versions_xid" "versions_operation" "object_id" "object_value" "ora_rowscn" + "xmldata") t) + "\\b")) +(defvar sqlplus-oracle-plsql-extra-reserved-words-re + (concat "\\b" + (regexp-opt '("array" "at" "authid" "bulk" "char_base" "day" "do" "extends" "forall" "heap" "hour" + "interface" "isolation" "java" "limited" "minute" "mlslabel" "month" "natural" "naturaln" "nocopy" "number_base" + "ocirowid" "opaque" "operator" "organization" "pls_integer" "positive" "positiven" "range" "record" "release" "reverse" + "rowtype" "second" "separate" "space" "sql" "timezone_region" "timezone_abbr" "timezone_minute" "timezone_hour" "year" + "zone") t) + "\\b")) +(defvar sqlplus-oracle-extra-types-re + (concat "\\b" + (regexp-opt '("nvarchar2" "binary_float" "binary_double" "timestamp" "interval" "interval_day" "urowid" "nchar" "clob" "nclob" "bfile") t) + "\\b")) + +(defvar sqlplus-commands-regexp-1 nil) +(defvar sqlplus-commands-regexp-23 nil) +(defvar sqlplus-system-variables-regexp-1 nil) +(defvar sqlplus-system-variables-regexp-23 nil) +(defvar sqlplus-v22-commands-font-lock-keywords-1 nil) +(defvar sqlplus-v22-commands-font-lock-keywords-23 nil) +(defvar font-lock-sqlplus-face nil) + +(defvar sqlplus-output-buffer-keymap nil + "Local in output buffer.") +(make-variable-buffer-local 'sqlplus-output-buffer-keymap) + +(defvar sqlplus-kill-function-inhibitor nil) + +(defvar sqlplus-slip-separator-width 2 + "Only for classic table style.") + +(defvar sqlplus-user-string-history nil) + +(defvar sqlplus-object-types '( "CONSUMER GROUP" "SEQUENCE" "SCHEDULE" "PROCEDURE" "OPERATOR" "WINDOW" + "PACKAGE" "LIBRARY" "PROGRAM" "PACKAGE BODY" "JAVA RESOURCE" "XML SCHEMA" + "JOB CLASS" "TRIGGER" "TABLE" "SYNONYM" "VIEW" "FUNCTION" "WINDOW GROUP" + "JAVA CLASS" "INDEXTYPE" "INDEX" "TYPE" "EVALUATION CONTEXT" )) + +(defvar sqlplus-end-of-source-sentinel "%%@@end-of-source-sentinel@@%%") + +(defconst sqlplus-system-variables + '("appi[nfo]" "array[size]" "auto[commit]" "autop[rint]" "autorecovery" "autot[race]" "blo[ckterminator]" "cmds[ep]" + "colsep" "com[patibility]" "con[cat]" "copyc[ommit]" "copytypecheck" "def[ine]" "describe" "echo" "editf[ile]" + "emb[edded]" "esc[ape]" "feed[back]" "flagger" "flu[sh]" "hea[ding]" "heads[ep]" "instance" "lin[esize]" + "lobof[fset]" "logsource" "long" "longc[hunksize]" "mark[up]" "newp[age]" "null" "numf[ormat]" "num[width]" + "pages[ize]" "pau[se]" "recsep" "recsepchar" "serverout[put]" "shift[inout]" "show[mode]" "sqlbl[anklines]" + "sqlc[ase]" "sqlco[ntinue]" "sqln[umber]" "sqlpluscompat[ibility]" "sqlpre[fix]" "sqlp[rompt]" "sqlt[erminator]" + "suf[fix]" "tab" "term[out]" "ti[me]" "timi[ng]" "trim[out]" "trims[pool]" "und[erline]" "ver[ify]" "wra[p]")) + +(defconst sqlplus-commands + '(("@[@]") + (("/" "r[un]")) + ("acc[ept]" + (font-lock-type-face "num[ber]" "char" "date" "binary_float" "binary_double") + (font-lock-keyword-face "for[mat]" "def[ault]" "[no]prompt" "hide")) + ("a[ppend]") + ("archive log" + (font-lock-keyword-face "list" "stop" "start" "next" "all" "to")) + ("attribute" + (font-lock-keyword-face "ali[as]" "cle[ar]" "for[mat]" "like" "on" "off")) + ("bre[ak]" + (font-lock-keyword-face "on" "row" "report" "ski[p]" "page" "nodup[licates]" "dup[licates]")) + ("bti[tle]" + (font-lock-keyword-face "on" "off") + (font-lock-builtin-face "bold" "ce[nter]" "col" "format" "le[ft]" "r[ight]" "s[kip]" "tab")) + ("c[hange]") + ("cl[ear]" + (font-lock-keyword-face "bre[aks]" "buff[er]" "col[umns]" "comp[utes]" "scr[een]" "sql" "timi[ng]")) + ("col[umn]" + (font-lock-keyword-face "ali[as]" "cle[ar]" "entmap" "on" "off" "fold_a[fter]" "fold_b[efore]" "for[mat]" "hea[ding]" + "jus[tify]" "l[eft]" "c[enter]" "r[ight]" "like" "newl[ine]" "new_v[alue]" "nopri[nt]" "pri[nt]" + "nul[l]" "old_v[alue]" "wra[pped]" "wor[d_wrapped]" "tru[ncated]")) + ("comp[ute]" + (font-lock-keyword-face "lab[el]" "of" "on" "report" "row") + (font-lock-builtin-face "avg" "cou[nt]" "min[imum]" "max[imum]" "num[ber]" "sum" "std" "var[iance]")) + ("conn[ect]" + (font-lock-keyword-face "as" "sysoper" "sysdba")) + ("copy") + ("def[ine]") + ("del" + (font-lock-keyword-face "last")) + ("desc[ribe]") + ("disc[onnect]") + ("ed[it]") + ("exec[ute]") + (("exit" "quit") + (font-lock-keyword-face "success" "failure" "warning" "commit" "rollback")) + ("get" + (font-lock-keyword-face "file" "lis[t]" "nol[ist]")) + ("help") + (("ho[st]" "!" "$")) + ("i[nput]") + ("l[ist]" + (font-lock-keyword-face "last")) + ("passw[ord]") + ("pau[se]") + ("pri[nt]") + ("pro[mpt]") + ("recover" + (font-lock-keyword-face "begin" "end" "backup" "automatic" "from" "logfile" "test" "allow" "corruption" "continue" "default" "cancel" + "standby" "database" "until" "time" "change" "using" "controlfile" "tablespace" "datafile" + "consistent" "with" "[no]parallel" "managed" "disconnect" "session" "[no]timeout" "[no]delay" "next" "no" "expire" + "current" "through" "thread" "sequence" "all" "archivelog" "last" "switchover" "immediate" "[no]wait" + "finish" "skip")) + ("rem[ark]") + ("repf[ooter]" + (font-lock-keyword-face "page" "on" "off") + (font-lock-builtin-face "bold" "ce[nter]" "col" "format" "le[ft]" "r[ight]" "s[kip]" "tab")) + ("reph[eader]" + (font-lock-keyword-face "page" "on" "off") + (font-lock-builtin-face "bold" "ce[nter]" "col" "format" "le[ft]" "r[ight]" "s[kip]" "tab")) + ("sav[e]" + (font-lock-keyword-face "file" "cre[ate]" "rep[lace]" "app[end]")) + ("set" + (font-lock-builtin-face sqlplus-system-variables) + (font-lock-keyword-face "on" "off" "immediate" "trace[only]" "explain" "statistics" "native" "v7" "v8" "all" "linenum" "indent" + "entry" "intermediate" "full" "local" "head" "html" "body" "table" "entmap" "spool" "[pre]format" + "none" "[word_]wrapped" "each" "truncated" "[in]visible" "mixed" "lower" "upper")) + ("sho[w]" + (font-lock-keyword-face "all" "bti[tle]" "err[ors]" "function" "procedure" "package[ body]" "trigger" "view" "type[ body]" + "dimension" "java class" "lno" "parameters" "pno" "recyc[lebin]" "rel[ease]" "repf[ooter]" "reph[eader]" + "sga" "spoo[l]" "sqlcode" "tti[tle]" "user") + (font-lock-builtin-face sqlplus-system-variables)) + ("shutdown" + (font-lock-keyword-face "abort" "immediate" "normal" "transactional" "local")) + ("spo[ol]" + ("cre" "create" "rep" "replace" "app" "append" "off" "out")) + ("sta[rt]") + ("startup" + (font-lock-keyword-face "force" "restrict" "pfile" "quiet" "mount" "open" "nomount" "read" "only" "write" "recover")) + ("store" + (font-lock-keyword-face "set" "cre[ate]" "rep[lace]" "app[end]")) + ("timi[ng]" + (font-lock-keyword-face "start" "show" "stop")) + ("tti[tle]" + (font-lock-keyword-face "tti[tle]" "on" "off") + (font-lock-builtin-face "bold" "ce[nter]" "col" "format" "le[ft]" "r[ight]" "s[kip]" "tab")) + ("undef[ine]") + ("var[iable]" + (font-lock-type-face "number" "[n]char" "byte" "[n]varchar2" "[n]clob" "refcursor" "binary_float" "binary_double")) + ("whenever oserror" + (font-lock-keyword-face "exit" "success" "failure" "commit" "rollback" "continue" "commit" "rollback" "none")) + ("whenever sqlerror" + (font-lock-keyword-face "exit" "success" "failure" "warning" "commit" "rollback" "continue" "none")))) + +(defvar plsql-mode-map nil) + +(defstruct sqlplus-global-struct + font-lock-regexps + objects-alist + side-view-buffer + root-dir +) + +(defvar sqlplus-global-structures (make-hash-table :test 'equal) + "Connect string -> sqlplus-global-struct") + +(defun sqlplus-get-objects-alist (&optional connect-string) + (let ((struct (gethash (car (refine-connect-string (or connect-string sqlplus-connect-string sqlplus-process-p))) + sqlplus-global-structures))) + (when struct + (sqlplus-global-struct-objects-alist struct)))) + +(defun sqlplus-set-objects-alist (objects-alist &optional connect-string) + (let ((struct (gethash (car (refine-connect-string (or connect-string sqlplus-connect-string sqlplus-process-p))) + sqlplus-global-structures))) + (when struct + (setf (sqlplus-global-struct-objects-alist struct) objects-alist)))) + +(defun sqlplus-get-font-lock-regexps (&optional connect-string) + (let ((struct (gethash (car (refine-connect-string (or connect-string sqlplus-connect-string sqlplus-process-p))) + sqlplus-global-structures))) + (when struct + (sqlplus-global-struct-font-lock-regexps struct)))) + +(defun sqlplus-set-font-lock-regexps (font-lock-regexps &optional connect-string) + (let ((struct (gethash (car (refine-connect-string (or connect-string sqlplus-connect-string sqlplus-process-p))) + sqlplus-global-structures))) + (when struct + (setf (sqlplus-global-struct-font-lock-regexps struct) font-lock-regexps)))) + +(defun sqlplus-get-side-view-buffer (&optional connect-string) + (let ((struct (gethash (car (refine-connect-string (or connect-string sqlplus-connect-string sqlplus-process-p))) + sqlplus-global-structures))) + (when struct + (sqlplus-global-struct-side-view-buffer struct)))) + +(defun sqlplus-get-root-dir (&optional connect-string) + (let ((struct (gethash (car (refine-connect-string (or connect-string sqlplus-connect-string sqlplus-process-p))) + sqlplus-global-structures))) + (when struct + (sqlplus-global-struct-root-dir struct)))) + +(defun sqlplus-set-root-dir (root-dir &optional connect-string) + (let ((struct (gethash (car (refine-connect-string (or connect-string sqlplus-connect-string sqlplus-process-p))) + sqlplus-global-structures))) + (when struct + (setf (sqlplus-global-struct-root-dir struct) root-dir)))) + +;;; --- + +(defun sqlplus-initial-strings () + (append sqlplus-initial-strings + (list + (concat "btitle left '" sqlplus-page-separator "'") + (concat "repfooter left '" sqlplus-repfooter "'") + (concat "set pagesize " (number-to-string sqlplus-pagesize))))) + +(defun sqlplus-connect-string-lessp (cs1 cs2) + "Compare two connect strings" + (let ((cs1-pair (split-string cs1 "@")) + (cs2-pair (split-string cs2 "@"))) + (or (string< (cadr cs1-pair) (cadr cs2-pair)) + (and (string= (cadr cs1-pair) (cadr cs2-pair)) + (string< (car cs1-pair) (car cs2-pair)))))) + +(defun sqlplus-divide-connect-strings () + "Returns (active-connect-string-list . inactive-connect-string-list)" + (let* ((active-connect-strings + (sort (delq nil (mapcar (lambda (buffer) + (with-current-buffer buffer + (when (and (eq major-mode 'sqlplus-mode) + sqlplus-connect-string) + (let ((cs (car (refine-connect-string sqlplus-connect-string)))) + (when (and (get-buffer (sqlplus-get-process-buffer-name cs)) + (get-process (sqlplus-get-process-name cs))) + (downcase cs)))))) + (buffer-list))) + 'sqlplus-connect-string-lessp)) + (inactive-connect-strings + (sort (delq nil (mapcar (lambda (pair) + (unless (member (downcase (car pair)) active-connect-strings) (downcase (car pair))) ) + sqlplus-connect-strings-alist)) + 'sqlplus-connect-string-lessp))) + (setq active-connect-strings (remove-duplicates active-connect-strings :test 'equal)) + (setq inactive-connect-strings (remove-duplicates inactive-connect-strings :test 'equal)) + (cons active-connect-strings inactive-connect-strings))) + +(defun sqlplus-connections-menu (menu) + (condition-case err + (let* ((connect-strings-pair (sqlplus-divide-connect-strings)) + (active-connect-strings (car connect-strings-pair)) + (inactive-connect-strings (cdr connect-strings-pair))) + (append + (list ["New connection..." sqlplus t]) + (list ["Tnsnames.ora" sqlplus-find-tnsnames t]) + (list ["Command Line" sqlplus-command-line t]) + (when (eq major-mode 'sqlplus-mode) + (list + "----" + ["Evaluate Statement" sqlplus-send-current sqlplus-connect-string] + ["Explain Statement" sqlplus-explain sqlplus-connect-string] + ["Evaluate Statement (HTML)" sqlplus-send-current-html sqlplus-connect-string] + ["Evaluate Region" sqlplus-send-region (and (mark) sqlplus-connect-string)])) + (when orcl-mode + (list + "----" + ["Send Commit" sqlplus-send-commit sqlplus-connect-string] + ["Send Rollback" sqlplus-send-rollback sqlplus-connect-string] + ["Restart Connection" sqlplus-restart-connection sqlplus-connect-string] + ["Show History" sqlplus-show-history sqlplus-connect-string] + ["Get Source from DB" sqlplus-get-source sqlplus-connect-string] + ["Interrupt Evaluation" sqlplus-send-interrupt sqlplus-connect-string] + ["Compare schema to filesystem" sqlplus-compare-schema-to-filesystem sqlplus-connect-string] + "----" + (list "Output" + ["Show window" sqlplus-buffer-display-window t] + "----" + ["Redisplay" sqlplus-buffer-redisplay-current t] + ["Previous" sqlplus-buffer-prev-command t] + ["Next" sqlplus-buffer-next-command t] + "----" + ["Scroll Right" sqlplus-buffer-scroll-right t] + ["Scroll Left" sqlplus-buffer-scroll-left t] + ["Scroll Down" sqlplus-buffer-scroll-down t] + ["Scroll Up" sqlplus-buffer-scroll-up t] + "----" + ["Bottom" sqlplus-buffer-bottom t] + ["Top" sqlplus-buffer-top t] + "----" + ["Erase" sqlplus-buffer-erase t]) + )) + (when inactive-connect-strings + (append + (list "----") + (list (append (list "Recent Connections") + (mapcar (lambda (connect-string) + (vector connect-string (list 'apply ''sqlplus + (list 'sqlplus-read-connect-string connect-string)) t)) inactive-connect-strings))))) + (when active-connect-strings + (append + (list "----") + (mapcar (lambda (connect-string) + (vector connect-string (list 'apply ''sqlplus + (list 'sqlplus-read-connect-string connect-string)) t)) active-connect-strings))) + )) + (error (message (error-message-string err))))) + +(defun sqlplus-send-commit () + "Send 'commit' command to SQL*Process." + (interactive) + (sqlplus-check-connection) + (sqlplus-execute sqlplus-connect-string "commit;" nil nil)) + +(defun sqlplus-send-rollback () + "Send 'rollback' command to SQL*Process." + (interactive) + (sqlplus-check-connection) + (sqlplus-execute sqlplus-connect-string "rollback;" nil nil)) + +(defun sqlplus-show-history () + "Show command history for current connection." + (interactive) + (sqlplus-check-connection) + (sqlplus-verify-buffer sqlplus-connect-string) + (switch-to-buffer (sqlplus-get-history-buffer sqlplus-connect-string))) + +(defun sqlplus-restart-connection () + "Kill SQL*Plus process and start again." + (interactive) + (sqlplus-check-connection) + (sqlplus-verify-buffer sqlplus-connect-string) + (let ((connect-stringos sqlplus-connect-string)) + (unwind-protect + (progn + (setq sqlplus-kill-function-inhibitor t) + (sqlplus-shutdown connect-stringos t)) + (setq sqlplus-kill-function-inhibitor nil)) + (sqlplus connect-stringos (sqlplus-get-input-buffer-name connect-stringos)))) + +(define-skeleton plsql-begin + "begin..end skeleton" + "" ; interactor + "begin" ?\n + > _ ?\n + "end;" >) + +(define-skeleton plsql-loop + "loop..end loop skeleton" + "" ; interactor + "loop" ?\n + > _ ?\n + "end loop;" >) + +(define-skeleton plsql-if + "if..end if skeleton" + "" ; interactor + "if " _ " then" ?\n + > ?\n + "end if;" >) + +;;; SQLPLUS-mode Keymap - + +(unless orcl-mode-map + (setq orcl-mode-map (make-sparse-keymap)) + (define-key orcl-mode-map "\C-c\C-o" 'sqlplus-buffer-display-window) + (define-key orcl-mode-map "\C-c\C-l" 'sqlplus-buffer-redisplay-current) + (define-key orcl-mode-map "\C-c\C-p" 'sqlplus-buffer-prev-command) + (define-key orcl-mode-map [C-S-up] 'sqlplus-buffer-prev-command) + (define-key orcl-mode-map "\C-c\C-n" 'sqlplus-buffer-next-command) + (define-key orcl-mode-map [C-S-down] 'sqlplus-buffer-next-command) + (define-key orcl-mode-map "\C-c\C-b" 'sqlplus-buffer-scroll-right) + (define-key orcl-mode-map [C-S-left] 'sqlplus-buffer-scroll-right) + (define-key orcl-mode-map "\C-c\C-f" 'sqlplus-buffer-scroll-left) + (define-key orcl-mode-map [C-S-right] 'sqlplus-buffer-scroll-left) + (define-key orcl-mode-map "\C-c\M-v" 'sqlplus-buffer-scroll-down) + (define-key orcl-mode-map "\C-c\C-v" 'sqlplus-buffer-scroll-up) + (define-key orcl-mode-map "\C-c>" 'sqlplus-buffer-bottom) + (define-key orcl-mode-map "\C-c<" 'sqlplus-buffer-top) + (define-key orcl-mode-map "\C-c\C-w" 'sqlplus-buffer-erase) + (define-key orcl-mode-map "\C-c\C-m" 'sqlplus-send-commit) + (define-key orcl-mode-map "\C-c\C-a" 'sqlplus-send-rollback) + (define-key orcl-mode-map "\C-c\C-k" 'sqlplus-restart-connection) + (define-key orcl-mode-map "\C-c\C-t" 'sqlplus-show-history) + (define-key orcl-mode-map "\C-c\C-s" 'sqlplus-get-source) + (define-key orcl-mode-map "\C-c\C-i" 'sqlplus-send-interrupt) + (define-key orcl-mode-map [S-return] 'sqlplus-send-user-string) + (define-key orcl-mode-map [tool-bar sqlplus-restart-connection] + (list 'menu-item "Restart connection" 'sqlplus-restart-connection :image sqlplus-kill-image)) + (define-key orcl-mode-map [tool-bar sqlplus-cancel] + (list 'menu-item "Cancel" 'sqlplus-send-interrupt :image sqlplus-cancel-image)) + (define-key orcl-mode-map [tool-bar sqlplus-rollback] + (list 'menu-item "Rollback" 'sqlplus-send-rollback :image sqlplus-rollback-image)) + (define-key orcl-mode-map [tool-bar sqlplus-commit] + (list 'menu-item "Commit" 'sqlplus-send-commit :image sqlplus-commit-image))) + +(unless sqlplus-mode-map + (setq sqlplus-mode-map (make-sparse-keymap)) + (define-key sqlplus-mode-map "\C-c\C-g" 'plsql-begin) + (define-key sqlplus-mode-map "\C-c\C-q" 'plsql-loop) + (define-key sqlplus-mode-map "\C-c\C-z" 'plsql-if) + (define-key sqlplus-mode-map "\C-c\C-r" 'sqlplus-send-region) + (define-key sqlplus-mode-map [C-return] 'sqlplus-send-current) + (define-key sqlplus-mode-map [M-return] 'sqlplus-explain) + (define-key sqlplus-mode-map "\C-c\C-e" 'sqlplus-send-current) + (define-key sqlplus-mode-map "\C-c\C-j" 'sqlplus-send-current-html) + (define-key sqlplus-mode-map [C-S-return] 'sqlplus-send-current-html) + (define-key sqlplus-mode-map "\M-." 'sqlplus-file-get-source) + (define-key sqlplus-mode-map [C-down-mouse-1] 'sqlplus-mouse-select-identifier) + (define-key sqlplus-mode-map [C-mouse-1] 'sqlplus-file-get-source-mouse) + ) + +(easy-menu-add-item nil nil sqlplus-connections-menu t) + +(unless sqlplus-mode-syntax-table + (setq sqlplus-mode-syntax-table (make-syntax-table)) + (modify-syntax-entry ?/ ". 14" sqlplus-mode-syntax-table) ; comment start + (modify-syntax-entry ?* ". 23" sqlplus-mode-syntax-table) + (modify-syntax-entry ?+ "." sqlplus-mode-syntax-table) + (modify-syntax-entry ?. "." sqlplus-mode-syntax-table) + (modify-syntax-entry ?\" "." sqlplus-mode-syntax-table) + (modify-syntax-entry ?\\ "." sqlplus-mode-syntax-table) + (modify-syntax-entry ?- ". 12b" sqlplus-mode-syntax-table) + (modify-syntax-entry ?\n "> b" sqlplus-mode-syntax-table) + (modify-syntax-entry ?= "." sqlplus-mode-syntax-table) + (modify-syntax-entry ?% "w" sqlplus-mode-syntax-table) + (modify-syntax-entry ?< "." sqlplus-mode-syntax-table) + (modify-syntax-entry ?> "." sqlplus-mode-syntax-table) + (modify-syntax-entry ?& "w" sqlplus-mode-syntax-table) + (modify-syntax-entry ?| "." sqlplus-mode-syntax-table) + (modify-syntax-entry ?_ "w" sqlplus-mode-syntax-table) ; _ is word char + (modify-syntax-entry ?\' "\"" sqlplus-mode-syntax-table)) + +;;; SQL*Plus mode + +(defun connect-string-to-string () + (let ((txt (or (car (refine-connect-string sqlplus-connect-string)) "disconnected")) + (result)) + (if (string-match "^\\(.*?\\)\\(\\w*prod\\w*\\)$" txt) + (if (>= emacs-major-version 22) + (setq result (list (list :propertize (substring txt 0 (match-beginning 2)) 'face '((:foreground "blue"))) + (list :propertize (substring txt (match-beginning 2)) 'face '((:foreground "red")(:weight bold))))) + (setq result (setq txt (propertize txt 'face '((:foreground "blue"))))) + (put-text-property (match-beginning 2) (match-end 2) 'face '((:foreground "red")(:weight bold)) txt)) + (setq result + (if (>= emacs-major-version 22) + (list :propertize txt 'face '((:foreground "blue"))) + (setq txt (propertize txt 'face '((:foreground "blue"))))))) + result)) + +(defun sqlplus-font-lock (type-symbol limit) + (let ((sqlplus-font-lock-regexps (sqlplus-get-font-lock-regexps))) + (when sqlplus-font-lock-regexps + (let ((regexp (gethash type-symbol sqlplus-font-lock-regexps))) + (when regexp + (re-search-forward regexp limit t)))))) + +;; Local in input buffer (sqlplus-mode) +(defvar sqlplus-command-overlay nil) +(make-variable-buffer-local 'sqlplus-command-overlay) +(defvar sqlplus-begin-command-overlay-arrow-position nil) +(make-variable-buffer-local 'sqlplus-begin-command-overlay-arrow-position) +(defvar sqlplus-end-command-overlay-arrow-position nil) +(make-variable-buffer-local 'sqlplus-end-command-overlay-arrow-position) + +(defun sqlplus-highlight-current-sqlplus-command() + (when (and window-system sqlplus-command-highlighting-style) + (let* ((pair (sqlplus-mark-current)) + (begin (and (car pair) (save-excursion (goto-char (car pair)) (skip-chars-forward " \t\n") (point)))) + (end (and (cdr pair) (save-excursion (goto-char (cdr pair)) (skip-chars-backward " \t\n") (beginning-of-line) (point)))) + (point-line-beg (save-excursion (beginning-of-line) (point))) + (overlay-begin begin) + (overlay-end end)) + (when (and begin end) + (when (< end point-line-beg) + (save-excursion (goto-char point-line-beg) (when (eobp) (insert "\n"))) + (setq end point-line-beg) + (setq overlay-end end)) + (when (or (>= begin end) (< (point) begin)) + (when (or (< (point) begin) (> begin end)) + (setq overlay-begin nil + overlay-end nil)) + (setq begin nil + end nil))) + (if (and overlay-begin overlay-end (memq sqlplus-command-highlighting-style '(background fringe-and-background))) + (progn + (setq overlay-end (save-excursion + (goto-char overlay-end) + (beginning-of-line 2) + (point))) + (move-overlay sqlplus-command-overlay overlay-begin overlay-end)) + (move-overlay sqlplus-command-overlay 1 1)) + (if (memq sqlplus-command-highlighting-style '(fringe fringe-and-background)) + (progn + (put 'sqlplus-begin-command-overlay-arrow-position 'overlay-arrow-bitmap 'top-left-angle) + (put 'sqlplus-end-command-overlay-arrow-position 'overlay-arrow-bitmap 'bottom-left-angle) + (set-marker sqlplus-begin-command-overlay-arrow-position begin) + (set-marker sqlplus-end-command-overlay-arrow-position end)) + (set-marker sqlplus-begin-command-overlay-arrow-position nil) + (set-marker sqlplus-end-command-overlay-arrow-position nil))))) + +(defun sqlplus-find-begin-of-sqlplus-command () + (save-excursion + (beginning-of-line) + (while (and (not (bobp)) (save-excursion (end-of-line 0) (skip-chars-backward " \t") (equal (char-before) ?-))) + (beginning-of-line 0)) + (point))) + +(defun sqlplus-find-end-of-sqlplus-command () + (save-excursion + (end-of-line) + (while (progn (skip-chars-backward " \t") (and (not (eobp)) (equal (char-before) ?-))) + (end-of-line 2)) + (point))) + +(defun sqlplus-set-font-lock-emacs-structures-for-level (level mode-symbol) + (let ((result (append sql-mode-oracle-font-lock-keywords + (default-value (cond ((equal level 3) 'sqlplus-font-lock-keywords-3) + ((equal level 2) 'sqlplus-font-lock-keywords-2) + ((equal level 1) 'sqlplus-font-lock-keywords-1) + (t nil)))))) + (when (featurep 'plsql) + (setq result (append (symbol-value 'plsql-oracle-font-lock-fix-re) result))) + (setq result + (append + ;; Names for schemas, tables, synonyms, views, columns, sequences, packages, triggers and indexes + (when (> level 2) + (mapcar (lambda (pair) + (let ((type-symbol (car pair)) + (face (cadr pair))) + (cons (eval `(lambda (limit) (sqlplus-font-lock ',type-symbol limit))) face))) + sqlplus-syntax-faces)) + ;; SQL*Plus + (when (eq mode-symbol 'sqlplus-mode) + (unless sqlplus-commands-regexp-1 + (flet ((first-form-fun (cmds) (mapcar (lambda (name) (car (sqlplus-full-forms name))) cmds)) + (all-forms-fun (cmds) (mapcan 'sqlplus-full-forms cmds)) + (sqlplus-commands-regexp-fun (form-fun cmds) (concat "^" (regexp-opt (funcall form-fun cmds) t) "\\b")) + (sqlplus-system-variables-fun (form-fun vars) (concat "\\b" (regexp-opt (funcall form-fun vars) t) "\\b"))) + (flet ((sqlplus-v22-commands-font-lock-keywords-fun + (form-fun) + (delq nil + (mapcar + (lambda (command-info) + (let* ((names (car command-info)) + (names-list (if (listp names) names (list names))) + (sublists (cdr command-info))) + (when sublists + (append (list (sqlplus-commands-regexp-fun form-fun names-list)) + (mapcar (lambda (sublist) + (let ((face (car sublist)) + (regexp (concat "\\b" + (regexp-opt (mapcan (lambda (name) (sqlplus-full-forms name)) + (mapcan (lambda (elem) + (if (symbolp elem) + (copy-list (symbol-value elem)) + (list elem))) + (cdr sublist))) + t) + "\\b"))) + (list regexp '(sqlplus-find-end-of-sqlplus-command) nil (list 1 face)))) + sublists) + (list '("\\(\\w+\\)" (sqlplus-find-end-of-sqlplus-command) nil (1 font-lock-sqlplus-face))))))) + sqlplus-commands)))) + (let ((commands (mapcan + (lambda (command-info) (let ((names (car command-info))) (if (listp names) (copy-list names) (list names)))) + sqlplus-commands))) + (setq sqlplus-commands-regexp-1 (sqlplus-commands-regexp-fun 'first-form-fun commands)) + (setq sqlplus-commands-regexp-23 (sqlplus-commands-regexp-fun 'all-forms-fun commands)) + (if (<= emacs-major-version 21) + (setq sqlplus-system-variables-regexp-1 (sqlplus-system-variables-fun 'first-form-fun sqlplus-system-variables) + sqlplus-system-variables-regexp-23 (sqlplus-system-variables-fun 'all-forms-fun sqlplus-system-variables)) + (setq sqlplus-v22-commands-font-lock-keywords-1 (sqlplus-v22-commands-font-lock-keywords-fun 'first-form-fun) + sqlplus-v22-commands-font-lock-keywords-23 (sqlplus-v22-commands-font-lock-keywords-fun 'all-forms-fun))))))) + (append (list + ;; Comments (REM command) + (cons "^\\(rem\\)\\b\\(.*?\\)$" '((1 font-lock-keyword-face nil nil) (2 font-lock-comment-face t nil))) + ;; Predefined SQL*Plus variables + (cons (concat "\\b" + (regexp-opt '("_CONNECT_IDENTIFIER" "_DATE" "_EDITOR" "_O_VERSION" "_O_RELEASE" "_PRIVILEGE" + "_SQLPLUS_RELEASE" "_USER") t) + "\\b") + 'font-lock-builtin-face) + ;; SQL*Plus commands (+ shortcuts if level >= 2) + (cons + (concat (if (>= level 2) sqlplus-commands-regexp-23 sqlplus-commands-regexp-1) "\\|^\\(@@\\|@\\|!\\|/\\|\\$\\)" ) + 'font-lock-keyword-face)) + (if (<= emacs-major-version 21) + ;; SQL*Plus system variables (+ shortcuts if level >= 2) + (list (cons (if (>= level 2) sqlplus-system-variables-regexp-23 sqlplus-system-variables-regexp-1) 'font-lock-builtin-face)) + ;; ver. >= 22 + (if (>= level 2) sqlplus-v22-commands-font-lock-keywords-23 sqlplus-v22-commands-font-lock-keywords-1)))) + ; (cons "\\b\\([a-zA-Z$_#0-9]+\\)\\b\\.\\(\\b[a-zA-Z$_#0-9]+\\b\\)" '((1 font-lock-type-face nil nil)(2 font-lock-variable-name-face nil nil))) + (list + ;; Extra Oracle syntax highlighting, not recognized by sql-mode or plsql-mode + (cons sqlplus-oracle-extra-types-re 'font-lock-type-face) + (cons sqlplus-oracle-extra-warning-words-re 'font-lock-warning-face) + (cons sqlplus-oracle-extra-types-re 'font-lock-type-face) + (cons sqlplus-oracle-extra-keywords-re 'font-lock-keyword-face) + (cons sqlplus-oracle-plsql-extra-reserved-words-re 'font-lock-keyword-face) + (if (string-match "XEmacs\\|Lucid" emacs-version) + (cons sqlplus-oracle-extra-pseudocolumns-re 'font-lock-preprocessor-face) + (cons sqlplus-oracle-extra-pseudocolumns-re 'font-lock-builtin-face)) + (if (string-match "XEmacs\\|Lucid" emacs-version) + (cons sqlplus-oracle-extra-builtin-functions-re 'font-lock-preprocessor-face) + (cons sqlplus-oracle-extra-builtin-functions-re 'font-lock-builtin-face)) + ;; SQL*Plus variable names, like '&name' or '&&name' + (cons "\\(\\b&[&a-zA-Z$_#0-9]+\\b\\)" 'font-lock-variable-name-face)) + result + ;; Function calls + (when (>= level 2) + (list (cons "\\b\\(\\([a-zA-Z$_#0-9]+\\b\\)\\.\\)?\\(\\b[a-zA-Z$_#0-9]+\\b\\)\\s-*(" + '((2 font-lock-type-face nil t) + (3 font-lock-function-name-face nil nil))))))) + result)) + +(defun sqlplus-mode nil + "Mode for editing and executing SQL*Plus commands. Entry into this mode runs the hook +'sqlplus-mode-hook'. + +Use \\[sqlplus] to start the SQL*Plus interpreter. + +Just position the cursor on or near the SQL*Plus statement you +wish to send and press '\\[sqlplus-send-current]' to run it and +display the results. + +Mode Specific Bindings: + +\\{sqlplus-mode-map}" + (interactive) + (run-hooks 'change-major-mode-hook) + (setq major-mode 'sqlplus-mode + mode-name "SQL*Plus") + (use-local-map sqlplus-mode-map) + (set-syntax-table sqlplus-mode-syntax-table) + (make-local-variable 'comment-start) + (make-local-variable 'comment-end) + (setq comment-start "/* " + comment-end " */") + (orcl-mode 1) + (setq sqlplus-font-lock-keywords-1 (sqlplus-set-font-lock-emacs-structures-for-level 1 major-mode) + sqlplus-font-lock-keywords-2 (sqlplus-set-font-lock-emacs-structures-for-level 2 major-mode) + sqlplus-font-lock-keywords-3 (sqlplus-set-font-lock-emacs-structures-for-level 3 major-mode)) + (when (featurep 'plsql) + (set (make-local-variable 'indent-line-function) + (lambda () (interactive) (condition-case err (funcall (symbol-function 'plsql-indent)) (error (message "Error: %S" err))))) + (set (make-local-variable 'indent-region-function) 'plsql-indent-region) + (set (make-local-variable 'align-mode-rules-list) 'plsql-align-rules-list)) + (setq font-lock-defaults sqlplus-font-lock-defaults) + (unless sqlplus-connect-string + (let ((potential-connect-string (sqlplus-get-potential-connect-string (buffer-file-name)))) + (when (and potential-connect-string + (get-process (sqlplus-get-process-name potential-connect-string))) + (setq sqlplus-connect-string potential-connect-string)))) + (set (make-local-variable 'font-lock-extend-after-change-region-function) + (lambda (beg end old-len) + (cons (save-excursion (goto-char beg) (sqlplus-find-begin-of-sqlplus-command)) + (save-excursion (goto-char end) (sqlplus-find-end-of-sqlplus-command))))) + (unless font-lock-sqlplus-face + (copy-face 'default 'font-lock-sqlplus-face) + (setq font-lock-sqlplus-face 'font-lock-sqlplus-face)) + (turn-on-font-lock) + (unless frame-background-mode + (setq frame-background-mode (if (< (sqlplus-color-percentage (face-background 'default)) 50) 'dark 'light))) + (setq imenu-generic-expression '((nil "^--[ ]*\\([^;.\n]*\\)" 1))) + ;; if input buffer has sqlplus-mode then prepare it for command under cursor selection + (when (and (eq major-mode 'sqlplus-mode) (null sqlplus-begin-command-overlay-arrow-position)) + (setq sqlplus-begin-command-overlay-arrow-position (make-marker) + sqlplus-end-command-overlay-arrow-position (make-marker) + sqlplus-command-overlay (make-overlay 1 1)) + (overlay-put sqlplus-command-overlay 'face 'sqlplus-command-highlight-face) + (when (and (>= emacs-major-version 22) (not (memq 'sqlplus-begin-command-overlay-arrow-position overlay-arrow-variable-list))) + (push 'sqlplus-begin-command-overlay-arrow-position overlay-arrow-variable-list)) + (when (and (>= emacs-major-version 22) (not (memq 'sqlplus-end-command-overlay-arrow-position overlay-arrow-variable-list))) + (push 'sqlplus-end-command-overlay-arrow-position overlay-arrow-variable-list)) + (add-hook 'pre-command-hook (lambda () + (set-marker sqlplus-begin-command-overlay-arrow-position nil) + (set-marker sqlplus-end-command-overlay-arrow-position nil)) + nil t) + (add-hook 'post-command-hook (lambda () + (sqlplus-clear-mouse-selection) + (set-marker sqlplus-begin-command-overlay-arrow-position nil) + (set-marker sqlplus-end-command-overlay-arrow-position nil)) + nil t)) + (run-hooks 'sqlplus-mode-hook)) + +(defun sqlplus-color-percentage (color) + (truncate (* (/ (/ (reduce '+ (color-values color)) 3.0) 65535.0) 100.0))) + +(defun sqlplus-get-potential-connect-string (file-path) + (when file-path + (let* ((file-name (file-name-nondirectory file-path)) + (extension (file-name-extension file-name)) + (case-fold-search t)) + (when (and extension + (string-match (concat "^" sqlplus-session-file-extension "$") extension) + (string-match "@" file-name)) + (car (refine-connect-string (file-name-sans-extension file-name))))))) + +(defun sqlplus-check-connection () + (if orcl-mode + (unless sqlplus-connect-string + (let* ((potential-connect-string (sqlplus-get-potential-connect-string (buffer-file-name))) + (connect-string (car (sqlplus-read-connect-string nil (or potential-connect-string + (caar (sqlplus-divide-connect-strings))))))) + (sqlplus connect-string (buffer-name)))) + (error "Current buffer is not determined to communicate with Oracle"))) + +;;; Utilitities + +(defun sqlplus-echo-in-buffer (buffer-name string &optional force-display hide-after-head) + "Displays string in the named buffer, creating the buffer if needed. If force-display is true, the buffer will appear +if not already shown." + (let ((buffer (get-buffer buffer-name))) + (when buffer + (if force-display (display-buffer buffer)) + (with-current-buffer buffer + (while (and (> (buffer-size) sqlplus-output-buffer-max-size) + (progn (goto-char (point-min)) + (unless (eobp) (forward-char)) + (re-search-forward (concat "^" (regexp-quote sqlplus-output-separator)) nil t))) + (delete-region 1 (- (point) (length sqlplus-output-separator)))) + + (goto-char (point-max)) + (let ((start-point (point))) + (insert string) + (when hide-after-head + (let ((from-pos (string-match "\n" string)) + (keymap (make-sparse-keymap)) + overlay) + (when from-pos + (setq overlay (make-overlay (+ start-point from-pos) (- (+ start-point (length string)) 2))) + (when (or (not (consp buffer-invisibility-spec)) + (not (assq 'hide-symbol buffer-invisibility-spec))) + (add-to-invisibility-spec '(hide-symbol . t))) + (overlay-put overlay 'invisible 'hide-symbol) + (put-text-property start-point (- (+ start-point (length string)) 2) 'help-echo string) + (put-text-property start-point (- (+ start-point (length string)) 2) 'mouse-face 'highlight) + (put-text-property start-point (- (+ start-point (length string)) 2) 'keymap sqlplus-output-buffer-keymap))))) + (if force-display + (set-window-point (get-buffer-window buffer-name) (point-max))))))) + +(defun sqlplus-verify-buffer (connect-string) + (let ((output-buffer-name (sqlplus-get-output-buffer-name connect-string)) + (process-buffer-name (sqlplus-get-process-buffer-name connect-string))) + (when (not (get-buffer process-buffer-name)) + (sqlplus-shutdown connect-string) + (error "No SQL*Plus session! Use 'M-x sqlplus' to start the SQL*Plus interpreter")) + (unless (get-buffer-process process-buffer-name) + (sqlplus-shutdown connect-string) + (error "Buffer '%s' is not talking to anybody!" output-buffer-name))) + t) + +(defun sqlplus-get-context (connect-string &optional id) + (let ((process-buffer (sqlplus-get-process-buffer-name connect-string))) + (when process-buffer + (with-current-buffer process-buffer + (when id + (while (and sqlplus-command-contexts + (not (equal (sqlplus-get-context-value (car sqlplus-command-contexts) :id) id))) + (setq sqlplus-command-contexts (cdr sqlplus-command-contexts)))) + (car sqlplus-command-contexts))))) + +(defun sqlplus-get-context-value (context var-symbol) + (cdr (assq var-symbol context))) + +(defun sqlplus-set-context-value (context var-symbol value) + (let ((association (assq var-symbol context))) + (if association + (setcdr association value) + (setcdr context (cons (cons var-symbol value) (cdr context)))) + context)) + +(defun sqlplus-mark-current () + "Marks the current SQL for sending to the SQL*Plus process. Marks are placed around a region defined by empty lines." + (let (begin end empty-line-p empty-line-p next-line-included tail-p) + (save-excursion + (beginning-of-line) + (setq empty-line-p (when (looking-at "^[ \t]*\\(\n\\|\\'\\)") (point))) + (setq next-line-included (and empty-line-p (save-excursion (skip-chars-forward " \t\n") (> (current-column) 0)))) + (setq tail-p (and empty-line-p + (or (bobp) (save-excursion (beginning-of-line 0) (looking-at "^[ \t]*\n")))))) + (unless tail-p + (save-excursion + (end-of-line) + (re-search-backward "\\`\\|\n[\r\t ]*\n[^ \t]" nil t) + (skip-syntax-forward "-") + (setq begin (point))) + (save-excursion + (beginning-of-line) + (re-search-forward "\n[\r\t ]*\n[^ \t]\\|\\'" nil t) + (unless (zerop (length (match-string 0))) + (backward-char 1)) + (skip-syntax-backward "-") + (setq end (or (and (not next-line-included) empty-line-p) (point))))) + (cons begin end))) + +;;; Transmission Commands + +(defun sqlplus-send-current (arg &optional html) + "Send the current SQL command(s) to the SQL*Plus process. With argument, show results in raw form." + (interactive "P") + (sqlplus-check-connection) + (when (buffer-file-name) + (condition-case err + (save-buffer) + (error (message (error-message-string err))))) + (let ((region (sqlplus-mark-current))) + (setq sqlplus-region-beginning-pos (car region) + sqlplus-region-end-pos (cdr region))) + (if (and sqlplus-region-beginning-pos sqlplus-region-end-pos) + (sqlplus-send-region arg sqlplus-region-beginning-pos sqlplus-region-end-pos nil html) + (error "Point doesn't indicate any command to execute"))) + +(defun sqlplus-send-current-html (arg) + (interactive "P") + (sqlplus-send-current arg t)) + + +;;; SQLPLUS-Output Buffer Operations - + +(defun sqlplus--show-buffer (connect-string fcn args) + (let* ((output-buffer-name (sqlplus-get-output-buffer-name connect-string))) + (sqlplus-verify-buffer connect-string) + (if sqlplus-suppress-show-output-buffer + (with-current-buffer (get-buffer output-buffer-name) + (if fcn (condition-case err (apply fcn args) (error (message (error-message-string err)))))) + (if (not (eq (window-buffer (selected-window)) (get-buffer output-buffer-name))) + (switch-to-buffer-other-window output-buffer-name)) + (if fcn (condition-case err (apply fcn args) (error (message (error-message-string err)))))))) + +(defun sqlplus-show-buffer (&optional connect-string fcn &rest args) + "Makes the SQL*Plus output buffer visible in the other window." + (interactive) + (setq connect-string (or connect-string sqlplus-connect-string)) + (unless connect-string + (error "Current buffer is disconnected!")) + (let ((output-buffer-name (sqlplus-get-output-buffer-name connect-string))) + (if (and output-buffer-name + (eq (current-buffer) (get-buffer output-buffer-name))) + (sqlplus--show-buffer connect-string fcn args) + (save-excursion + (save-selected-window + (sqlplus--show-buffer connect-string fcn args)))))) + +(fset 'sqlplus-buffer-display-window 'sqlplus-show-buffer) + +(defun sqlplus-buffer-scroll-up (&optional connect-string) + "Scroll-up in the SQL*Plus output buffer window." + (interactive) + (sqlplus-show-buffer (or connect-string sqlplus-connect-string) 'scroll-up)) + +(defun sqlplus-buffer-scroll-down (&optional connect-string) + "Scroll-down in the SQL*Plus output buffer window." + (interactive) + (sqlplus-show-buffer (or connect-string sqlplus-connect-string) 'scroll-down)) + +(defun sqlplus-scroll-left (num) + (call-interactively 'scroll-left)) + +(defun sqlplus-scroll-right (num) + (call-interactively 'scroll-right)) + +(defun sqlplus-buffer-scroll-left (num &optional connect-string) + "Scroll-left in the SQL*Plus output buffer window." + (interactive "p") + (sqlplus-show-buffer (or connect-string sqlplus-connect-string) 'sqlplus-scroll-left (* num (/ (window-width) 2)))) + +(defun sqlplus-buffer-scroll-right (num &optional connect-string) + "Scroll-right in the SQL*Plus output buffer window." + (interactive "p") + (sqlplus-show-buffer (or connect-string sqlplus-connect-string) 'sqlplus-scroll-right (* num (/ (window-width) 2)))) + +(defun sqlplus-buffer-mark-current (&optional connect-string) + "Mark the current position in the SQL*Plus output window." + (sqlplus-show-buffer (or connect-string sqlplus-connect-string) 'sqlplus-buffer-make-mark)) + +(defun sqlplus-buffer-make-mark (&optional connect-string) + "Set the sqlplus-buffer-marker." + (setq sqlplus-buffer-mark (copy-marker (point)))) + +(defun sqlplus-buffer-redisplay-current (&optional connect-string) + "Go to the current sqlplus-buffer-mark." + (interactive) + (sqlplus-show-buffer (or connect-string sqlplus-connect-string) 'sqlplus-goto-mark)) + +(defun sqlplus-goto-mark () + (goto-char sqlplus-buffer-mark) + (recenter 0)) + +(defun sqlplus-buffer-top (&optional connect-string) + "Goto the top of the SQL*Plus output buffer." + (interactive) + (sqlplus-show-buffer (or connect-string sqlplus-connect-string) 'sqlplus-beginning-of-buffer)) + +(defun sqlplus-beginning-of-buffer nil (goto-char (point-min))) + +(defun sqlplus-buffer-bottom (&optional connect-string) + "Goto the bottom of the SQL*Plus output buffer." + (interactive) + (sqlplus-show-buffer (or connect-string sqlplus-connect-string) 'sqlplus-end-of-buffer)) + +(defun sqlplus-end-of-buffer nil (goto-char (point-max)) (unless sqlplus-suppress-show-output-buffer (recenter -1))) + +(defun sqlplus-buffer-erase (&optional connect-string) + "Clear the SQL output buffer." + (interactive) + (sqlplus-show-buffer (or connect-string sqlplus-connect-string) 'erase-buffer)) + +(defun sqlplus-buffer-next-command (&optional connect-string) + "Search for the next command in the SQL*Plus output buffer." + (interactive) + (sqlplus-show-buffer (or connect-string sqlplus-connect-string) 'sqlplus-next-command)) + +(defun sqlplus-next-command nil + "Search for the next command in the SQL*Plus output buffer." + (cond ((re-search-forward (concat "^" (regexp-quote sqlplus-output-separator)) nil t) + (forward-line 2) + (recenter 0)) + (t (beep) (message "No more commands.")))) + +(defun sqlplus-buffer-prev-command (&optional connect-string) + "Search for the previous command in the SQL*Plus output buffer." + (interactive) + (sqlplus-show-buffer (or connect-string sqlplus-connect-string) 'sqlplus-previous-command)) + +(defun sqlplus-previous-command nil + "Search for the previous command in the SQL*Plus output buffer." + (let ((start (point))) + (re-search-backward (concat "^" (regexp-quote sqlplus-output-separator)) nil t) + (cond ((re-search-backward (concat "^" (regexp-quote sqlplus-output-separator)) nil t) + (forward-line 2) + (recenter 0)) + (t + (message "No more commands.") (beep) + (goto-char start))))) + +(defun sqlplus-send-interrupt nil + "Send an interrupt the the SQL*Plus interpreter process." + (interactive) + (sqlplus-check-connection) + (let ((connect-string sqlplus-connect-string)) + (sqlplus-verify-buffer connect-string) + (interrupt-process (get-process (sqlplus-get-process-name connect-string))))) + + +;;; SQL Interpreter + +(defun refine-connect-string (connect-string &optional no-slash) + "Z connect stringa do SQL*Plusa wycina haslo, tj. np. 'ponaglenia/x@SID' -> ('ponaglenia@SID' . 'x')." + (let (result passwd) + (when connect-string + (setq result + (if (string-match "\\(\\`[^@/]*?\\)/\\([^/@:]*\\)\\(.*?\\'\\)" connect-string) + (progn + (setq passwd (match-string 2 connect-string)) + (concat (match-string 1 connect-string) (match-string 3 connect-string))) + connect-string)) + (when no-slash + (while (string-match "/" result) + (setq result (replace-match "!" nil t result))))) + (cons result passwd))) + +(defun sqlplus-get-output-buffer-name (connect-string) + (concat "*" (car (refine-connect-string connect-string)) "*")) + +(defun sqlplus-get-input-buffer-name (connect-string) + (concat (car (refine-connect-string connect-string)) (concat "." sqlplus-session-file-extension))) + +(defun sqlplus-get-history-buffer-name (connect-string) + (concat " " (car (refine-connect-string connect-string)) "-hist")) + +(defun sqlplus-get-process-buffer-name (connect-string) + (concat " " (car (refine-connect-string connect-string)))) + +(defun sqlplus-get-process-name (connect-string) + (car (refine-connect-string connect-string))) + +(defun sqlplus-read-connect-string (&optional connect-string default-connect-string) + "Ask user for connect string with password, with DEFAULT-CONNECT-STRING proposed. +DEFAULT-CONNECT-STRING nil means first inactive connect-string on sqlplus-connect-strings-alist. +CONNECT-STRING non nil means ask for password only if CONNECT-STRING has no password itself. +Returns (qualified-connect-string refined-connect-string)." + (unless default-connect-string + (let ((inactive-connect-strings (cdr (sqlplus-divide-connect-strings)))) + (setq default-connect-string + (some (lambda (pair) + (when (member (car pair) inactive-connect-strings) (car pair))) + sqlplus-connect-strings-alist)))) + (let* ((cs (downcase (or connect-string + (read-string (format "Connect string%s: " (if default-connect-string (format " [default %s]" default-connect-string) "")) + nil 'sqlplus-connect-string-history default-connect-string)))) + (pair (refine-connect-string cs)) + (refined-cs (car pair)) + (password (cdr pair)) + (was-password password) + (association (assoc refined-cs sqlplus-connect-strings-alist))) + (unless (or password current-prefix-arg) + (setq password (cdr association))) + (unless password + (setq password (read-passwd (format "Password for %s: " cs)))) + (unless was-password + (if (string-match "@" cs) + (setq cs (replace-match (concat "/" password "@") t t cs)) + (setq cs (concat cs "/" password)))) + (list cs refined-cs))) + +(defun sqlplus (connect-string &optional input-buffer-name output-buffer-flag) + "Create SQL*Plus process connected to Oracle according to +CONNECT-STRING, open (or create) input buffer with specified +name (do not create if INPUT-BUFFER-NAME is nil). +OUTPUT-BUFFER-FLAG has meanings: nil or SHOW-OUTPUT-BUFFER - +create output buffer and show it, DONT-SHOW-OUTPUT-BUFFER - +create output buffer but dont show it, DONT-CREATE-OUTPUT-BUFFER +- dont create output buffer" + (interactive (let ((pair (sqlplus-read-connect-string))) + (list (car pair) (concat (cadr pair) (concat "." sqlplus-session-file-extension))))) + (set (make-local-variable 'comment-start-skip) "/\\*+ *\\|--+ *") + (set (make-local-variable 'comment-multi-line) t) + ;; create sqlplus-session-cache-dir if not exists + (when sqlplus-session-cache-dir + (condition-case err + (unless (file-directory-p sqlplus-session-cache-dir) + (make-directory sqlplus-session-cache-dir t)) + (error (message (error-message-string err))))) + (let* ((was-input-buffer (and input-buffer-name (get-buffer input-buffer-name))) + (input-buffer (or was-input-buffer + (when input-buffer-name + (if sqlplus-session-cache-dir + (let ((buf (find-file-noselect + (concat + (file-name-as-directory sqlplus-session-cache-dir) + (car (refine-connect-string connect-string t)) + (concat "." sqlplus-session-file-extension))))) + (condition-case nil + (with-current-buffer buf + (rename-buffer input-buffer-name)) + (error nil)) + buf) + (get-buffer-create input-buffer-name))))) + (output-buffer (or (and (not (eq output-buffer-flag 'dont-create-output-buffer)) + (get-buffer-create (sqlplus-get-output-buffer-name connect-string))) + (get-buffer (sqlplus-get-output-buffer-name connect-string)))) + (process-name (sqlplus-get-process-name connect-string)) + (process-buffer-name (sqlplus-get-process-buffer-name connect-string)) + (was-process (get-process process-name)) + process-created + (process (or was-process + (let (proc) + (puthash (car (refine-connect-string connect-string)) + (make-sqlplus-global-struct :font-lock-regexps (make-hash-table :test 'equal) + :side-view-buffer (when (featurep 'ide-skel) (sqlplus-create-side-view-buffer connect-string))) + sqlplus-global-structures) + ;; push current connect string to the beginning of sqlplus-connect-strings-alist + (let* ((refined-cs (refine-connect-string connect-string))) + (setq sqlplus-connect-strings-alist (delete* (car refined-cs) sqlplus-connect-strings-alist :test 'string= :key 'car)) + (push refined-cs sqlplus-connect-strings-alist)) + (sqlplus-get-history-buffer connect-string) + (when output-buffer + (with-current-buffer output-buffer + (erase-buffer))) + (setq process-created t + proc (start-process process-name process-buffer-name sqlplus-command connect-string)) + (set-process-sentinel proc (lambda (process event) + (let ((proc-buffer (buffer-name (process-buffer process))) + (output-buffer (get-buffer (sqlplus-get-output-buffer-name (process-name process)))) + err-msg + (exited-abnormally (string-match "\\`exited abnormally with code" event))) + (when output-buffer + (with-current-buffer output-buffer + (goto-char (point-max)) + (insert (format "\n%s" event)) + (when exited-abnormally + (setq sqlplus-connect-strings-alist + (delete* (car (refine-connect-string sqlplus-connect-string)) + sqlplus-connect-strings-alist :test 'string= :key 'car)) + (when proc-buffer + (with-current-buffer proc-buffer + (save-excursion + (goto-char (point-min)) + (when (re-search-forward "^ORA-[0-9]+.*$" nil t) + (setq err-msg (match-string 0)))) + (erase-buffer))) + (when err-msg + (insert (concat "\n" err-msg))))))))) + (process-kill-without-query proc (not sqlplus-kill-processes-without-query-on-exit-flag)) + (set-process-filter proc 'sqlplus-process-filter) + (with-current-buffer (get-buffer process-buffer-name) + (setq sqlplus-process-p connect-string)) + proc)))) + (when output-buffer + (with-current-buffer output-buffer + (orcl-mode 1) + (set (make-local-variable 'line-move-ignore-invisible) t) + (setq sqlplus-output-buffer-keymap (make-sparse-keymap) + sqlplus-connect-string connect-string + truncate-lines t) + (define-key sqlplus-output-buffer-keymap "\C-m" (lambda () (interactive) (sqlplus-output-buffer-hide-show))) + (define-key sqlplus-output-buffer-keymap [S-mouse-2] (lambda (event) (interactive "@e") (sqlplus-output-buffer-hide-show))) + (local-set-key [S-return] 'sqlplus-send-user-string))) + (when input-buffer + (with-current-buffer input-buffer + (setq sqlplus-connect-string connect-string))) + ;; if input buffer was created then switch it to sqlplus-mode + (when (and input-buffer (not was-input-buffer)) + (with-current-buffer input-buffer + (unless (eq major-mode 'sqlplus-mode) + (sqlplus-mode))) + (when font-lock-mode (font-lock-mode 1)) + (set-window-buffer (sqlplus-get-workbench-window) input-buffer)) + ;; if process was created then get information for font lock + (when process-created + (sqlplus-execute connect-string nil nil (sqlplus-initial-strings) 'no-echo) + (let ((plsql-font-lock-level (sqlplus-font-lock-value-in-major-mode font-lock-maximum-decoration 'plsql-mode)) + (sqlplus-font-lock-level (sqlplus-font-lock-value-in-major-mode font-lock-maximum-decoration 'sqlplus-mode))) + (when (or (equal plsql-font-lock-level t) (equal sqlplus-font-lock-level t) + (and (numberp plsql-font-lock-level) (>= plsql-font-lock-level 2)) + (and (numberp sqlplus-font-lock-level) (>= sqlplus-font-lock-level 2))) + (sqlplus-hidden-select connect-string + (concat "select distinct column_name, 'COLUMN', ' ' from user_tab_columns where column_name not like 'BIN$%'\n" + "union\n" + "select username, 'SCHEMA', ' ' from all_users where username not like 'BIN$%'\n" + "union\n" + "select object_name, object_type, decode( status, 'INVALID', 'I', ' ' ) from user_objects\n" + "where object_name not like 'BIN$%'\n" + "and object_type in ('VIEW', 'SEQUENCE', 'PACKAGE', 'TRIGGER', 'TABLE', 'SYNONYM', 'INDEX', 'FUNCTION', 'PROCEDURE');") + 'sqlplus-my-handler)))) + (when input-buffer + (save-selected-window + (when (equal (selected-window) (sqlplus-get-side-window)) + (select-window (sqlplus-get-workbench-window))) + (switch-to-buffer input-buffer))) + (let ((saved-window (cons (selected-window) (window-buffer (selected-window)))) + (input-buffer (get-buffer (sqlplus-get-input-buffer-name connect-string)))) + (when (or (eq output-buffer-flag 'show-output-buffer) (null output-buffer-flag)) + (sqlplus-show-buffer connect-string)) + (if (window-live-p (car saved-window)) + (select-window (car saved-window)) + (if (get-buffer-window (cdr saved-window)) + (select-window (get-buffer-window (cdr saved-window))) + (when (and input-buffer + (get-buffer-window input-buffer)) + (select-window (get-buffer-window input-buffer)))))) + ;; executing initial sequence (between /* init */ and /* end */) + (when (and (not was-process) input-buffer) + (with-current-buffer input-buffer + (save-excursion + (goto-char (point-min)) + (when (re-search-forward (concat "^" sqlplus-init-sequence-start-regexp "\\s-*\n\\(\\(.\\|\n\\)*?\\)\n" sqlplus-init-sequence-end-regexp) nil t) + (when (match-string 1) + (sqlplus-send-region nil (match-beginning 1) (match-end 1) t)))))))) + +;; Command under cursor selection mechanism +(when window-system + (run-with-idle-timer 0 t (lambda () (when (eq major-mode 'sqlplus-mode) (sqlplus-highlight-current-sqlplus-command)))) + (run-with-idle-timer 1 t (lambda () + (when (eq major-mode 'sqlplus-mode) + (if (>= (sqlplus-color-percentage (face-background 'default)) 50) + (set-face-attribute 'sqlplus-command-highlight-face nil + :background (sqlplus-shine-color (face-background 'default) (- sqlplus-command-highlighting-percentage))) + (set-face-attribute 'sqlplus-command-highlight-face nil + :background (sqlplus-shine-color (face-background 'default) sqlplus-command-highlighting-percentage))))))) + +(defun sqlplus-output-buffer-hide-show () + (if (and (consp buffer-invisibility-spec) + (assq 'hide-symbol buffer-invisibility-spec)) + (remove-from-invisibility-spec '(hide-symbol . t)) + (add-to-invisibility-spec '(hide-symbol . t))) + (let ((overlay (car (overlays-at (point))))) + (when overlay + (goto-char (overlay-start overlay)) + (beginning-of-line))) + (recenter 0)) + +(defun sqlplus-font-lock-value-in-major-mode (alist mode-symbol) + (if (consp alist) + (cdr (or (assq mode-symbol alist) (assq t alist))) + alist)) + +(defun sqlplus-get-history-buffer (connect-string) + (let* ((history-buffer-name (sqlplus-get-history-buffer-name connect-string)) + (history-buffer (get-buffer history-buffer-name))) + (unless history-buffer + (setq history-buffer (get-buffer-create history-buffer-name)) + (with-current-buffer history-buffer + (setq sqlplus-cs connect-string) + (add-hook 'kill-buffer-hook 'sqlplus-history-buffer-kill-function nil t))) + history-buffer)) + +(defun sqlplus-history-buffer-kill-function () + (when sqlplus-history-dir + (condition-case err + (progn + (unless (file-directory-p sqlplus-history-dir) + (make-directory sqlplus-history-dir t)) + (append-to-file 1 (buffer-size) (concat (file-name-as-directory sqlplus-history-dir) (car (refine-connect-string sqlplus-cs t)) "-hist.txt"))) + (error (message (error-message-string err)))))) + +(defun sqlplus-soft-shutdown (connect-string) + (unless (some (lambda (buffer) + (with-current-buffer buffer + (and sqlplus-connect-string + (equal (car (refine-connect-string sqlplus-connect-string)) + (car (refine-connect-string connect-string)))))) + (buffer-list)) + (sqlplus-shutdown connect-string))) + +(defun sqlplus-shutdown (connect-string &optional dont-kill-input-buffer) + "Kill input, output and process buffer for specified CONNECT-STRING." + (let ((input-buffers (delq nil (mapcar (lambda (buffer) (with-current-buffer buffer + (when (and (eq major-mode 'sqlplus-mode) + (equal (car (refine-connect-string sqlplus-connect-string)) + (car (refine-connect-string connect-string)))) + buffer))) (buffer-list)))) + (output-buffer (get-buffer (sqlplus-get-output-buffer-name connect-string))) + (history-buffer (get-buffer (sqlplus-get-history-buffer-name connect-string))) + (process-buffer (get-buffer (sqlplus-get-process-buffer-name connect-string)))) + (when history-buffer + (kill-buffer history-buffer)) + (when (and process-buffer + (with-current-buffer process-buffer sqlplus-process-p)) + (when (get-process (sqlplus-get-process-name connect-string)) + (delete-process (sqlplus-get-process-name connect-string))) + (kill-buffer process-buffer)) + (when (and output-buffer + (with-current-buffer output-buffer sqlplus-connect-string)) + (when (buffer-file-name output-buffer) + (with-current-buffer output-buffer + (save-buffer))) + (kill-buffer output-buffer)) + (dolist (input-buffer input-buffers) + (when (buffer-file-name input-buffer) + (with-current-buffer input-buffer + (save-buffer))) + (unless dont-kill-input-buffer + (kill-buffer input-buffer))))) + +(defun sqlplus-magic () + (let (bottom-message pos) + (delete-region (point) (progn (beginning-of-line 3) (point))) + (setq bottom-message (buffer-substring (point) (save-excursion (end-of-line) (point)))) + (setq pos (point)) + (when (re-search-forward "^-------" nil t) + (delete-region pos (progn (beginning-of-line 2) (point))) + (while (re-search-forward "|" (save-excursion (end-of-line) (point)) t) + (save-excursion + (backward-char) + (if (or (bolp) (save-excursion (forward-char) (eolp))) + (while (member (char-after) '(?- ?|)) + (delete-char 1) + (sqlplus-next-line)) + (while (member (char-after) '(?- ?|)) + (delete-char 1) + (insert " ") + (backward-char) + (sqlplus-next-line))))) + (beginning-of-line 3) + (re-search-forward "^---" nil t) + (goto-char (match-beginning 0)) + (delete-region (point) (point-max)) + (insert (format "%s\n\n%s\n" sqlplus-repfooter bottom-message)) + ))) + + +(defun sqlplus-process-command-output (context connect-string begin end interrupted) + (let* ((output-buffer-name (sqlplus-get-output-buffer-name connect-string)) + (output-buffer (get-buffer output-buffer-name)) + (process-buffer (sqlplus-get-process-buffer-name connect-string)) + str + error-list show-errors-p + slips-count + (user-function (sqlplus-get-context-value context :user-function)) + (result-function (sqlplus-get-context-value context :result-table-function)) + (last-compiled-file-path (sqlplus-get-context-value context :last-compiled-file-path)) + (compilation-expected (sqlplus-get-context-value context :compilation-expected)) + (columns-count (sqlplus-get-context-value context :columns-count)) + (sql (sqlplus-get-context-value context :sql)) + (original-buffer (current-buffer)) + explain-plan + table-data) + (setq slips-count columns-count) + (with-temp-buffer + (insert-buffer-substring original-buffer begin end) + (goto-char (point-min)) + (while (re-search-forward (concat "\n+" (regexp-quote sqlplus-page-separator) "\n") nil t) + (replace-match "\n")) + (goto-char (point-min)) + (setq str (buffer-string)) + (while (string-match (concat "^" (regexp-quote sqlplus-repfooter) "\n") str) + (setq str (replace-match "" nil t str))) + + ;; compilation errors? + (goto-char (point-min)) + (skip-chars-forward "\n\t ") + (when (and ;;(not (equal (point) (point-max))) + plsql-auto-parse-errors-flag + output-buffer + last-compiled-file-path + (re-search-forward "^\\(LINE/COL\\|\\(SP2\\|CPY\\|ORA\\)-[0-9]\\{4,5\\}:\\|No errors\\|Nie ma b..d.w\\|Keine Fehler\\|No hay errores\\|Identificateur erron\\|Nessun errore\\|N..o h.. erros\\)" nil t)) + (goto-char (point-min)) + (setq error-list (plsql-parse-errors last-compiled-file-path) + show-errors-p compilation-expected)) + + ;; explain? + (let ((case-fold-search t)) + (goto-char (point-min)) + (skip-chars-forward "\n\t ") + (when (and sql + (string-match "^[\n\t ]*explain\\>" sql) + (looking-at "Explained[.]")) + (delete-region (point-min) (point-max)) + (setq str "") + (sqlplus--send connect-string + "select plan_table_output from table(dbms_xplan.display(null, null, 'TYPICAL'));" + nil + 'no-echo + nil))) + + ;; plan table output? + (goto-char (point-min)) + (skip-chars-forward "\n\t ") + (when (and (looking-at "^PLAN_TABLE_OUTPUT\n") + sqlplus-format-output-tables-flag + (not compilation-expected) + (not show-errors-p)) + (sqlplus-magic) ;; TODO + (goto-char (point-min)) + (re-search-forward "^[^\n]+" nil t) + (delete-region (point-min) (progn (beginning-of-line) (point))) + ;; (setq slips-count 1) + (setq explain-plan t) + (setq table-data (save-excursion (sqlplus-parse-output-table interrupted)))) + + ;; query result? + (goto-char (point-min)) + (when (and sqlplus-format-output-tables-flag + (not compilation-expected) + (not table-data) + (not show-errors-p) + (not (re-search-forward "^LINE/COL\\>" nil t))) + (setq table-data (save-excursion (sqlplus-parse-output-table interrupted)))) + (if user-function + (funcall user-function connect-string context (or table-data str)) + (when output-buffer + (with-current-buffer output-buffer + (save-excursion + (goto-char (point-max)) + (cond (show-errors-p + (insert str) + (plsql-display-errors (file-name-directory last-compiled-file-path) error-list) + (let* ((plsql-buf (get-file-buffer last-compiled-file-path)) + (win (when plsql-buf (car (get-buffer-window-list plsql-buf))))) + (when win + (select-window win)))) + ((and table-data + (car table-data)) + (if result-function + (funcall result-function connect-string table-data) + (let ((b (point)) + (warning-regexp (regexp-opt sqlplus-explain-plan-warning-regexps)) + e) + (sqlplus-draw-table table-data slips-count) + (when interrupted (insert ". . .\n")) + (setq e (point)) + (when explain-plan + (save-excursion + (goto-char b) + (while (re-search-forward warning-regexp nil t) + (add-text-properties (match-beginning 0) (match-end 0) + (list 'face (list (cons 'foreground-color "red") (list :weight 'bold) + (get-text-property (match-beginning 0) 'face)))))))))) + (t + (insert str)))))))))) + +(defun sqlplus-result-online (connect-string context string last-chunk) + (let ((output-buffer (sqlplus-get-output-buffer-name connect-string))) + (when output-buffer + (with-current-buffer output-buffer + (save-excursion + (goto-char (point-max)) + (insert string)))))) + +(defvar sqlplus-prompt-regexp (concat "^" (regexp-quote sqlplus-prompt-prefix) "\\([0-9]+\\)" (regexp-quote sqlplus-prompt-suffix))) + +(defvar sqlplus-page-separator-regexp (concat "^" (regexp-quote sqlplus-page-separator))) + +(defun sqlplus-process-filter (process string) + (with-current-buffer (process-buffer process) + (let* ((prompt-safe-len (+ (max (+ (length sqlplus-prompt-prefix) (length sqlplus-prompt-suffix)) (length sqlplus-page-separator)) 10)) + current-context-id filter-input-processed + (connect-string sqlplus-process-p) + (chunk-begin-pos (make-marker)) + (chunk-end-pos (make-marker)) + (prompt-found (make-marker)) + (context (sqlplus-get-context connect-string current-context-id)) + (current-command-input-buffer-name (sqlplus-get-context-value context :current-command-input-buffer-name)) + (current-command-input-buffer-names (when current-command-input-buffer-name (list current-command-input-buffer-name)))) + (set-marker chunk-begin-pos (max 1 (- (point) prompt-safe-len))) + (goto-char (point-max)) + (insert string) + (unless current-command-input-buffer-names + (setq current-command-input-buffer-names + (delq nil (mapcar (lambda (buffer) (with-current-buffer buffer + (when (and (memq major-mode '(sqlplus-mode plsql-mode)) + sqlplus-connect-string + (equal (car (refine-connect-string sqlplus-connect-string)) + (car (refine-connect-string connect-string)))) + buffer))) (buffer-list))))) + ;; fan animation + (dolist (current-command-input-buffer-name current-command-input-buffer-names) + (let ((input-buffer (get-buffer current-command-input-buffer-name))) + (when input-buffer + (with-current-buffer input-buffer + (setq sqlplus-fan + (cond ((equal sqlplus-fan "|") "/") + ((equal sqlplus-fan "/") "-") + ((equal sqlplus-fan "-") "\\") + ((equal sqlplus-fan "\\") "|"))) + (put-text-property 0 (length sqlplus-fan) 'face '((foreground-color . "red")) sqlplus-fan) + (put-text-property 0 (length sqlplus-fan) 'help-echo (sqlplus-get-context-value context :sql) sqlplus-fan) + (force-mode-line-update))))) + (unwind-protect + (while (not filter-input-processed) + (let* ((context (sqlplus-get-context connect-string current-context-id)) + (dont-parse-result (sqlplus-get-context-value context :dont-parse-result)) + (current-command-input-buffer-name (sqlplus-get-context-value context :current-command-input-buffer-name)) + (result-function (sqlplus-get-context-value context :result-function)) + (skip-to-the-end-of-command (sqlplus-get-context-value context :skip-to-the-end-of-command))) + (set-marker prompt-found nil) + (goto-char chunk-begin-pos) + (set-marker chunk-end-pos + (if (or (re-search-forward sqlplus-prompt-regexp nil t) + (re-search-forward "^SQL> " nil t)) + (progn + (set-marker prompt-found (match-end 0)) + (when (match-string 1) + (setq current-context-id (string-to-number (match-string 1)))) + (match-beginning 0)) + (point-max))) + (cond ((and (equal chunk-begin-pos chunk-end-pos) ; at the end of command + (marker-position prompt-found)) + ;; deactivate fan + (dolist (current-command-input-buffer-name current-command-input-buffer-names) + (let ((input-buffer (get-buffer current-command-input-buffer-name))) + (when input-buffer + (with-current-buffer input-buffer + (remove-text-properties 0 (length sqlplus-fan) '(face nil) sqlplus-fan) + (force-mode-line-update))))) + (delete-region 1 prompt-found) + (when dont-parse-result + (funcall (or result-function 'sqlplus-result-online) connect-string context "" t)) + (sqlplus-set-context-value context :skip-to-the-end-of-command nil) + (set-marker chunk-begin-pos 1)) + ((equal chunk-begin-pos chunk-end-pos) + (when dont-parse-result + (delete-region 1 (point-max))) + (setq filter-input-processed t)) + (dont-parse-result + (funcall (or result-function 'sqlplus-result-online) + connect-string + context + (buffer-substring chunk-begin-pos chunk-end-pos) + (marker-position prompt-found)) + (set-marker chunk-begin-pos chunk-end-pos)) + (t + (when (not skip-to-the-end-of-command) + (goto-char (max 1 (- chunk-begin-pos 4010))) + (let ((page-separator-found + (save-excursion (let ((pos (re-search-forward (concat sqlplus-page-separator-regexp "[^-]*\\(^-\\|^<th\\b\\)") nil t))) + (when (and pos + (or (not (marker-position prompt-found)) + (< pos prompt-found))) + (match-beginning 0)))))) + (when (or (marker-position prompt-found) page-separator-found) + (goto-char (or page-separator-found chunk-end-pos)) + (let ((end-pos (point)) + (cur-msg (or (current-message) ""))) + (sqlplus-set-context-value context :skip-to-the-end-of-command page-separator-found) + (when page-separator-found + (interrupt-process) + (save-excursion + (re-search-backward "[^ \t\n]\n" nil t) + (setq end-pos (match-end 0)))) + (if result-function + (save-excursion (funcall result-function context connect-string 1 end-pos page-separator-found)) + (with-temp-message "Formatting output..." + (save-excursion (sqlplus-process-command-output context connect-string 1 end-pos page-separator-found))) + (message "%s" cur-msg)) + (when page-separator-found + (delete-region 1 (+ page-separator-found (length sqlplus-page-separator))) + (set-marker chunk-end-pos 1)))))) + (set-marker chunk-begin-pos chunk-end-pos))))) + (goto-char (point-max)) + (set-marker chunk-begin-pos nil) + (set-marker chunk-end-pos nil) + (set-marker prompt-found nil))))) + +(defadvice switch-to-buffer (around switch-to-buffer-around-advice (buffer-or-name &optional norecord)) + ad-do-it + (when (and sqlplus-connect-string + (eq major-mode 'sqlplus-mode)) + (let ((side-window (sqlplus-get-side-window)) + (output-buffer (get-buffer (sqlplus-get-output-buffer-name sqlplus-connect-string)))) + (when (and side-window + (not (eq (window-buffer) output-buffer))) + (save-selected-window + (switch-to-buffer-other-window output-buffer)))))) +(ad-activate 'switch-to-buffer) + +(defun sqlplus-kill-function () + (unless sqlplus-kill-function-inhibitor + ;; shutdown connection if it is SQL*Plus output buffer or SQL*Plus process buffer + (if (or (and sqlplus-connect-string (equal (buffer-name) (sqlplus-get-output-buffer-name sqlplus-connect-string))) + sqlplus-process-p) + (sqlplus--enqueue-task 'sqlplus-shutdown (or sqlplus-connect-string sqlplus-process-p)) + ;; input buffer or another buffer connected to SQL*Plus - possibly shutdown + (when sqlplus-connect-string + (let ((counter 0) + (scs sqlplus-connect-string)) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (equal sqlplus-connect-string scs) (incf counter)))) + (when (<= counter 2) + (let* ((process (get-process (sqlplus-get-process-name sqlplus-connect-string)))) + (when (or (not process) + (memq (process-status process) '(exit signal)) + (y-or-n-p (format "Kill SQL*Plus process %s " (car (refine-connect-string sqlplus-connect-string))))) + (sqlplus--enqueue-task 'sqlplus-shutdown sqlplus-connect-string))))))))) + +(defun sqlplus-emacs-kill-function () + ;; save and kill all sqlplus-mode buffers + (let (buffers-to-kill) + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (and sqlplus-connect-string + (eq major-mode 'sqlplus-mode)) + (when (buffer-file-name) + (save-buffer)) + (push buffer buffers-to-kill)))) + (setq sqlplus-kill-function-inhibitor t) + (condition-case nil + (unwind-protect + (dolist (buffer buffers-to-kill) + (kill-buffer buffer)) + (setq sqlplus-kill-function-inhibitor nil)) + (error nil)) + t)) + +(push 'sqlplus-emacs-kill-function kill-emacs-query-functions) + +(add-hook 'kill-buffer-hook 'sqlplus-kill-function) + +;; kill all history buffers so that they can save themselves +(add-hook 'kill-emacs-hook (lambda () + (dolist (buf (copy-list (buffer-list))) + (when (and (string-match "@.*-hist" (buffer-name buf)) + (with-current-buffer buf sqlplus-cs)) + (kill-buffer buf))))) + +(defun sqlplus-find-output-table (interrupted) + "Search for table in last SQL*Plus command result, and return +list (BEGIN END MSG) for first and last table char, or nil if +table is not found." + (let (begin end) + (goto-char (point-min)) + (when (re-search-forward "^[^\n]+\n\\( \\)?-" nil t) + (let (msg + (indent (when (match-string 1) -1))) ; result of 'describe' sqlplus command + (forward-line -1) + ;; (untabify (point) (buffer-size)) + (setq begin (point)) + (when indent + (indent-rigidly begin (point-max) indent) + (goto-char begin)) + (if indent + (progn + (goto-char (point-max)) + (skip-chars-backward "\n\t ") + (setq end (point)) + (goto-char (point-max))) + (or (re-search-forward (concat "^" (regexp-quote sqlplus-repfooter) "\n[\n\t ]*") nil t) + (when interrupted (re-search-forward "\\'" nil t))) ; \\' means end of buffer + (setq end (match-beginning 0)) + (setq msg (buffer-substring (match-end 0) (point-max)))) + (list begin end msg))))) + +(defstruct col-desc + id ; from 0 + name ; column name + start-pos ; char column number + end-pos ; char column number + max-width ; max. column width + preferred-width ; preferred column width + min-prefix-len ; min. prefix (spaces only) + numeric ; y if column is numeric, n if is not, nil if don't know + has-eol ; temporary value for processing current row +) + +(defun sqlplus-previous-line () + (let ((col (current-column))) + (forward-line -1) + (move-to-column col t))) + +(defun sqlplus-next-line () + (let ((col (current-column))) + (forward-line 1) + (move-to-column col t))) + +(defun sqlplus--correct-column-name (max-col-no) + (let ((counter 0) + (big (1- (save-excursion (beginning-of-line) (point))))) + (skip-chars-forward " ") + (when (re-search-forward " [^ \n]" (+ big max-col-no) t) + (backward-char) + (while (< (point) (+ big max-col-no)) + (setq counter (1+ counter)) + (insert " "))) + counter)) + +(defun sqlplus-parse-output-table (interrupted) + "Parse table and return list (COLUMN-INFOS ROWS MSG) where +COLUMN-INFOS is a col-desc structures list, ROWS is a table of +records (record is a list of strings). Return nil if table is +not detected." + (let ((region (sqlplus-find-output-table interrupted))) + (when region + (let ((begin (car region)) + (end (cadr region)) + (last-msg (caddr region)) + (col-counter 0) + column-infos rows + (record-lines 1) + finish) + ;; (message "'%s'\n'%s'" (buffer-substring begin end) last-msg) + (goto-char begin) + ;; we are at the first char of column name + ;; move to the first char of '-----' column separator + (beginning-of-line 2) + (while (not finish) + (if (equal (char-after) ?-) + ;; at the first column separator char + (let* ((beg (point)) + (col-begin (current-column)) + (col-max-width (skip-chars-forward "-")) + ;; after last column separator char + (ed (point)) + (col-end (+ col-begin col-max-width)) + (col-name (let* ((b (progn + (goto-char beg) + (sqlplus-previous-line) + (save-excursion + (let ((counter (sqlplus--correct-column-name (1+ col-end)))) + (setq beg (+ beg counter)) + (setq ed (+ ed counter)))) + (point))) + (e (+ b col-max-width))) + (skip-chars-forward " \t") + (setq b (point)) + (goto-char (min (save-excursion (end-of-line) (point)) e)) + (skip-chars-backward " \t") + (setq e (point)) + (if (> e b) + (buffer-substring b e) + ""))) + (col-preferred-width (string-width col-name))) + ;; (put-text-property 0 (length col-name) 'face '(bold) col-name) + (push (make-col-desc :id col-counter :name col-name :start-pos col-begin + :end-pos col-end :max-width col-max-width :preferred-width col-preferred-width :min-prefix-len col-max-width) + column-infos) + (incf col-counter) + (goto-char ed) + (if (equal (char-after) ?\n) + (progn + (beginning-of-line 3) + (incf record-lines)) + (forward-char))) + (setq finish t))) + (decf record-lines) + (setq column-infos (nreverse column-infos)) + (forward-line -1) + + ;; at the first char of first data cell. + ;; table parsing... + (while (< (point) end) + (let (record last-start-pos) + (dolist (column-info column-infos) + (let ((start-pos (col-desc-start-pos column-info)) + (end-pos (col-desc-end-pos column-info)) + width len value b e l) + (when (and last-start-pos + (<= start-pos last-start-pos)) + (forward-line)) + (setq last-start-pos start-pos) + (move-to-column start-pos) + (setq b (point)) + (move-to-column end-pos) + (setq e (point)) + (move-to-column start-pos) + (setq l (skip-chars-forward " " e)) + (when (and (col-desc-min-prefix-len column-info) + (< l (- e b)) + (< l (col-desc-min-prefix-len column-info))) + (setf (col-desc-min-prefix-len column-info) + (if (looking-at "[0-9]") l nil))) + (move-to-column end-pos) + (skip-chars-backward " " b) + (setq value (if (> (point) b) (buffer-substring b (point)) "")) + (setq len (length value) + width (string-width value)) + (when (and sqlplus-select-result-max-col-width + (> len sqlplus-select-result-max-col-width)) + (setq value (concat (substring value 0 sqlplus-select-result-max-col-width) "...") + len (length value) + width (string-width value))) + (when (> width (col-desc-preferred-width column-info)) + (setf (col-desc-preferred-width column-info) width)) + (when (and (< l (- e b)) + (memq (col-desc-numeric column-info) '(nil y))) + (setf (col-desc-numeric column-info) + (if (string-match "\\` *[-+0-9Ee.,$]+\\'" value) 'y 'n))) + (push value record))) + (forward-line) + (when (> record-lines 1) + (forward-line)) + (setq last-start-pos nil + record (nreverse record)) + (push record rows))) + (setq rows (nreverse rows)) + (list column-infos rows last-msg))))) + +(defun sqlplus-draw-table (lst &optional slips-count) + "SLIPS-COUNT (nil means compute automatically)." + ;; current buffer: SQL*Plus output buffer + (when window-system + (if (>= (sqlplus-color-percentage (face-background 'default)) 50) + (progn + (set-face-attribute 'sqlplus-table-head-face nil + :background (sqlplus-shine-color (face-background 'default) -70) :foreground (face-background 'default)) + (set-face-attribute 'sqlplus-table-even-rows-face nil + :background (sqlplus-shine-color (face-background 'default) -20) :overline (face-background 'default)) + (set-face-attribute 'sqlplus-table-odd-rows-face nil + :background (sqlplus-shine-color (face-background 'default) -30) :overline (face-background 'default))) + (set-face-attribute 'sqlplus-table-head-face nil + :background (sqlplus-shine-color (face-background 'default) +70) :foreground (face-background 'default)) + (set-face-attribute 'sqlplus-table-even-rows-face nil + :background (sqlplus-shine-color (face-background 'default) +20) :overline (face-background 'default)) + (set-face-attribute 'sqlplus-table-odd-rows-face nil + :background (sqlplus-shine-color (face-background 'default) +30) :overline (face-background 'default)))) + (let* ((column-infos (car lst)) + (rows (cadr lst)) + (slip-width 0) + (table-header-height 1) + (table-area-width (1- (let ((side-window (sqlplus-get-side-window))) (if side-window (window-width side-window) (frame-width))))) + ;; may be nil, which means no limit + (table-area-height (let ((side-window (sqlplus-get-side-window))) + (when side-window + (- (window-height side-window) 2 (if mode-line-format 1 0) (if header-line-format 1 0))))) + (column-separator-width (if sqlplus-elegant-style 1.2 (max (length sqlplus-table-col-separator) (length sqlplus-table-col-head-separator)))) + rows-per-slip ;; data rows per slip + (slip-separator-width (if sqlplus-elegant-style 1.5 sqlplus-slip-separator-width)) + (slip-separator (make-string (max 0 (if sqlplus-elegant-style 1 sqlplus-slip-separator-width)) ?\ )) + (last-msg (caddr lst))) + (when sqlplus-elegant-style + (put-text-property 0 1 'display (cons 'space (list :width slip-separator-width)) slip-separator)) + (when (<= table-area-height table-header-height) + (setq table-area-height nil)) + (when (and window-system sqlplus-elegant-style table-area-height (> table-area-height 3)) + ;; overline makes glyph higher... + (setq table-area-height (- table-area-height (round (/ (* 20.0 (- table-area-height 3)) (face-attribute 'default :height)))))) + (when column-infos + (goto-char (point-max)) + (beginning-of-line) + ;; slip width (without separator between slips) + (dolist (col-info column-infos) + (when (col-desc-min-prefix-len col-info) + (setf (col-desc-preferred-width col-info) (max (string-width (col-desc-name col-info)) + (- (col-desc-preferred-width col-info) (col-desc-min-prefix-len col-info))))) + (incf slip-width (+ (col-desc-preferred-width col-info) column-separator-width))) + (when (> slip-width 0) + (setq slip-width (+ (- slip-width column-separator-width) (if sqlplus-elegant-style 1.0 0)))) + ;; computing slip count if not known yet + (unless slips-count + (setq slips-count + (if table-area-height (min (ceiling (/ (float (length rows)) (max 1 (- table-area-height table-header-height 2)))) + (max 1 (floor (/ (float table-area-width) (+ slip-width slip-separator-width))))) + 1))) + (setq slips-count (max 1 (min slips-count (length rows)))) ; slip count <= data rows + (setq rows-per-slip (ceiling (/ (float (length rows)) slips-count))) + (when (> rows-per-slip 0) + (setq slips-count (max 1 (min (ceiling (/ (float (length rows)) rows-per-slip)) slips-count)))) + + (let ((table-begin-point (point))) + (dotimes (slip-no slips-count) + (let ((row-no 0) + (slip-begin-point (point)) + (rows-processed 0)) + ;; column names + (dolist (col-info column-infos) + (let* ((col-name (col-desc-name col-info)) + (spaces (max 0 (- (col-desc-preferred-width col-info) (string-width col-name)))) + (last-col-p (>= (1+ (col-desc-id col-info)) (length column-infos))) + (val (format (if sqlplus-elegant-style " %s%s %s" "%s%s%s") + col-name + (make-string spaces ?\ ) + (if last-col-p "" (if sqlplus-elegant-style " " sqlplus-table-col-separator))))) + (put-text-property 0 (if (or (not sqlplus-elegant-style) last-col-p) (length val) (1- (length val))) + 'face 'sqlplus-table-head-face val) + (when sqlplus-elegant-style + (put-text-property 0 1 'display '(space . (:width 0.5)) val) + (put-text-property (- (length val) (if last-col-p 1 2)) (- (length val) (if last-col-p 0 1)) 'display '(space . (:width 0.5)) val) + (unless last-col-p + (put-text-property (- (length val) 1) (length val) 'display '(space . (:width 0.2)) val))) + (insert val))) + (insert slip-separator) + (insert "\n") + ;; data rows + (while (and (< rows-processed rows-per-slip) + rows) + (let ((row (car rows))) + (setq rows (cdr rows)) + (incf rows-processed) + (let ((col-infos column-infos)) + (dolist (value row) + (let* ((col-info (car col-infos)) + (numeric-p (eq (col-desc-numeric col-info) 'y)) + (min-prefix (col-desc-min-prefix-len col-info))) + (when (and min-prefix + value + (>= (length value) min-prefix)) + (setq value (substring value min-prefix))) + (let* ((spaces (max 0 (- (col-desc-preferred-width col-info) (string-width value)))) + (val (if numeric-p + (format (if sqlplus-elegant-style " %s%s %s" "%s%s%s") + (make-string spaces ?\ ) + value + (if (cdr col-infos) (if sqlplus-elegant-style " " sqlplus-table-col-separator) "")) + (format (if sqlplus-elegant-style " %s%s %s" "%s%s%s") + value + (make-string spaces ?\ ) + (if (cdr col-infos) (if sqlplus-elegant-style " " sqlplus-table-col-separator) ""))))) + (put-text-property 0 (if (and sqlplus-elegant-style (cdr col-infos)) (- (length val) 1) (length val)) + 'face (if (evenp row-no) + 'sqlplus-table-even-rows-face + 'sqlplus-table-odd-rows-face) val) + (when sqlplus-elegant-style + (put-text-property 0 1 'display '(space . (:width 0.5)) val) + (put-text-property (- (length val) (if (cdr col-infos) 2 1)) + (- (length val) (if (cdr col-infos) 1 0)) + 'display '(space . (:width 0.5)) val) + (when (cdr col-infos) + (put-text-property (- (length val) 1) (length val) 'display '(space . (:width 0.2)) val))) + (setq col-infos (cdr col-infos)) + (insert val)))) + (incf row-no) + (insert slip-separator) + (insert "\n")))) + (when (> slip-no 0) + (delete-backward-char 1) + (let ((slip-end-point (point))) + (kill-rectangle slip-begin-point slip-end-point) + (delete-region slip-begin-point (point-max)) + (goto-char table-begin-point) + (end-of-line) + (yank-rectangle) + (goto-char (point-max)) + )))) + (goto-char (point-max)) + (when (and last-msg (> (length last-msg) 0)) + (unless sqlplus-elegant-style (insert "\n")) + (let ((s (format "%s\n\n" (replace-regexp-in-string "\n+" " " last-msg)))) + (when sqlplus-elegant-style + (put-text-property (- (length s) 2) (1- (length s)) 'display '(space . (:height 1.5)) s)) + (insert s))))))) + +(defun sqlplus-send-user-string (str) + (interactive (progn (sqlplus-check-connection) + (if sqlplus-connect-string + (list (read-string "Send to process: " nil 'sqlplus-user-string-history "")) + (error "Works only in SQL*Plus buffer")))) + (let ((connect-string sqlplus-connect-string)) + (sqlplus-verify-buffer connect-string) + (let* ((process (get-process (sqlplus-get-process-name connect-string))) + (output-buffer-name (sqlplus-get-output-buffer-name connect-string))) + (sqlplus-echo-in-buffer output-buffer-name (concat str "\n")) + (send-string process (concat str "\n"))))) + +(defun sqlplus-prepare-update-alist (table-data) + (let ((column-infos (car table-data)) + (rows (cadr table-data)) + (msg (caddr table-data)) + alist) + (dolist (row rows) + (let* ((object-name (car row)) + (object-type (intern (downcase (cadr row)))) + (status (caddr row)) + (regexp-list (cdr (assq object-type alist))) + (pair (cons object-name (equal status "I")))) + (if regexp-list + (setcdr regexp-list (cons pair (cdr regexp-list))) + (setq regexp-list (list pair)) + (setq alist (cons (cons object-type regexp-list) alist))))) + alist)) + +(defun sqlplus-my-update-handler (connect-string table-data) + (let ((alist (sqlplus-prepare-update-alist table-data))) + (when (featurep 'ide-skel) + (funcall 'sqlplus-side-view-update-data connect-string alist)))) + +(defun sqlplus-my-handler (connect-string table-data) + (let ((alist (sqlplus-prepare-update-alist table-data)) + (sqlplus-font-lock-regexps (sqlplus-get-font-lock-regexps connect-string))) + (sqlplus-set-objects-alist alist connect-string) + (when (featurep 'ide-skel) + (funcall 'sqlplus-side-view-update-data connect-string alist)) + (clrhash sqlplus-font-lock-regexps) + (dolist (lst sqlplus-syntax-faces) + (let* ((object-type (car lst)) + (regexp-list (append (caddr lst) (mapcar 'car (cdr (assq object-type alist)))))) + (when regexp-list + (puthash object-type (concat "\\b" (regexp-opt regexp-list t) "\\b") sqlplus-font-lock-regexps)))) + (let ((map sqlplus-font-lock-regexps)) + (mapc (lambda (buffer) + (with-current-buffer buffer + (when (and (memq major-mode '(sqlplus-mode plsql-mode)) + (equal sqlplus-connect-string connect-string)) + (when font-lock-mode (font-lock-mode 1))))) + (buffer-list))))) + +(defun sqlplus-get-source-function (connect-string context string last-chunk) + (let* ((source-text (sqlplus-get-context-value context :source-text)) + (source-type (sqlplus-get-context-value context :source-type)) + (source-name (sqlplus-get-context-value context :source-name)) + (source-extension (sqlplus-get-context-value context :source-extension)) + (name (concat (upcase source-name) "." source-extension)) + finish) + (unless (sqlplus-get-context-value context :finished) + (setq source-text (concat source-text string)) + (sqlplus-set-context-value context :source-text source-text) + (when last-chunk + (if (string-match (regexp-quote sqlplus-end-of-source-sentinel) source-text) + (when (< (length source-text) (+ (length sqlplus-end-of-source-sentinel) 5)) + (setq last-chunk nil + finish "There is no such database object")) + (setq last-chunk nil))) + (when last-chunk + (setq finish t)) + (when finish + (sqlplus-set-context-value context :finished t) + (if (stringp finish) + (message finish) + (with-temp-buffer + (insert source-text) + (goto-char (point-min)) + (re-search-forward (regexp-quote sqlplus-end-of-source-sentinel) nil t) + (replace-match "") + (goto-char (point-max)) + (forward-comment (- (buffer-size))) + (when (equal source-type "TABLE") + (goto-char (point-min)) + (insert (format "table %s\n(\n" source-name)) + (goto-char (point-max)) + (delete-region (re-search-backward "," nil t) (point-max)) + (insert "\n);")) + (insert "\n/\n") + (unless (member source-type '("SEQUENCE" "TABLE" "SYNONYM" "INDEX")) + (insert "show err\n")) + (goto-char (point-min)) + (insert "create " (if (member source-type '("INDEX" "SEQUENCE" "TABLE")) "" "or replace ")) + (setq source-text (buffer-string))) + (with-current-buffer (get-buffer-create name) + (setq buffer-read-only nil) + (erase-buffer) + (insert source-text) + (goto-char (point-min)) + (set-visited-file-name (concat (file-name-as-directory temporary-file-directory) + (concat (make-temp-name (sqlplus-canonize-file-name (concat (upcase source-name) "_") "[$]")) "." source-extension))) + (rename-buffer name) + (condition-case err + (funcall (symbol-function 'plsql-mode)) + (error nil)) + (setq sqlplus-connect-string connect-string + buffer-read-only sqlplus-source-buffer-readonly-by-default-flag) + (save-buffer) + (save-selected-window + (let ((win (selected-window))) + (when (or (equal win (sqlplus-get-side-window)) + (and (fboundp 'ide-skel-side-view-window-p) + (funcall 'ide-skel-side-view-window-p win))) + (setq win (sqlplus-get-workbench-window))) + (set-window-buffer win (current-buffer)))))))))) + +(defun sqlplus-get-source (connect-string name type &optional schema-name) + "Fetch source for database object NAME in current or specified SCHEMA-NAME, and show the source in new buffer. +Possible TYPE values are in 'sqlplus-object-types'." + (interactive (let* ((thing (thing-at-point 'symbol)) + (obj-raw-name (read-string (concat "Object name" (if thing (concat " [default " thing "]") "") ": ") + nil + 'sqlplus-get-source-history (when thing thing))) + (completion-ignore-case t) + (type (completing-read "Object type: " (mapcar (lambda (type) (cons type nil)) sqlplus-object-types) nil t))) + (string-match "^\\(\\([^.]+\\)[.]\\)?\\(.*\\)$" obj-raw-name) + (list sqlplus-connect-string (match-string 3 obj-raw-name) type (match-string 2 obj-raw-name)))) + (setq type (upcase type)) + (let* ((sql + (cond ((equal type "SEQUENCE") + (format (concat "select 'sequence %s' || sequence_name || " + "decode( increment_by, 1, '', ' increment by ' || increment_by ) || " + "case when increment_by > 0 and max_value >= (1.0000E+27)-1 or increment_by < 0 and max_value = -1 then '' " + "else decode( max_value, null, ' nomaxvalue', ' maxvalue ' || max_value) end || " + "case when increment_by > 0 and min_value = 1 or increment_by < 0 and min_value <= (-1.0000E+26)+1 then '' " + "else decode( min_value, null, ' nominvalue', ' minvalue ' || min_value) end || " + "decode( cycle_flag, 'Y', ' cycle', '' ) || " + "decode( cache_size, 20, '', 0, ' nocache', ' cache ' || cache_size ) || " + "decode( order_flag, 'Y', ' order', '' ) " + "from %s where sequence_name = '%s'%s;") + (if schema-name (concat (upcase schema-name) ".") "") + (if schema-name "all_sequences" "user_sequences") + (upcase name) + (if schema-name (format " and sequence_owner = '%s'" (upcase schema-name)) ""))) + ((equal type "TABLE") + (format (concat "select ' ' || column_name || ' ' || data_type || " + "decode( data_type," + " 'VARCHAR2', '(' || to_char( data_length, 'fm9999' ) || ')'," + " 'NUMBER', decode( data_precision," + " null, ''," + " '(' || to_char( data_precision, 'fm9999' ) || decode( data_scale," + " null, ''," + " 0, ''," + " ',' || data_scale ) || ')' )," + " '') || " + "decode( nullable, 'Y', ' not null', '') || ','" + "from all_tab_columns " + "where owner = %s and table_name = '%s' " + "order by column_id;") + (if schema-name (concat "'" (upcase schema-name) "'") "user") + (upcase name))) + ((equal type "SYNONYM") + (format (concat "select " + "decode( owner, 'PUBLIC', 'public ', '' ) || 'synonym ' || " + "decode( owner, 'PUBLIC', '', user, '', owner || '.' ) || synonym_name || ' for ' || " + "decode( table_owner, user, '', table_owner || '.' ) || table_name || " + "decode( db_link, null, '', '@' || db_link ) " + "from all_synonyms where (owner = 'PUBLIC' or owner = %s) and synonym_name = '%s';") + (if schema-name (concat "'" (upcase schema-name) "'") "user") + (upcase name))) + ((equal type "VIEW") + (if schema-name (format "select 'view %s.' || view_name || ' as ', text from all_views where owner = '%s' and view_name = '%s';" + (upcase schema-name) (upcase schema-name) (upcase name)) + (format "select 'view ' || view_name || ' as ', text from user_views where view_name = '%s';" (upcase name)))) + ((or (equal type "PROCEDURE") + (equal type "FUNCTION")) + (if schema-name (format "select text from all_source where owner = '%s' and name = '%s' and type in ('PROCEDURE', 'FUNCTION') order by line;" + (upcase schema-name) (upcase name)) + (format "select text from user_source where name = '%s' and type in ('PROCEDURE', 'FUNCTION') order by line;" + (upcase name)))) + (t + (if schema-name (format "select text from all_source where owner = '%s' and name = '%s' and type = '%s' order by line;" + (upcase schema-name) (upcase name) (upcase type)) + (format "select text from user_source where name = '%s' and type = '%s' order by line;" + (upcase name) (upcase type)))))) + (prolog-commands (list "set echo off" + "set newpage 0" + "set space 0" + "set pagesize 0" + "set feedback off" + "set long 4000" + "set longchunksize 4000" + "set wrap on" + "set heading off" + "set trimspool on" + "set linesize 4000" + "set timing off")) + (extension (if (equal (downcase type) "package") "pks" "sql")) + (source-buffer-name (concat " " (upcase name) "." extension)) + (context-options (list (cons :dont-parse-result 'dont-parse) + (cons :source-text nil) + (cons :source-type type) + (cons :source-name name) + (cons :source-extension extension) + (cons :result-function 'sqlplus-get-source-function)))) + (sqlplus-execute connect-string sql context-options prolog-commands t t) + (sqlplus-execute connect-string (format "select '%s' from dual;" sqlplus-end-of-source-sentinel) context-options prolog-commands t t))) + +(defun sqlplus-canonize-file-name (file-name regexp) + (while (string-match regexp file-name) + (setq file-name (replace-match "!" nil t file-name))) + file-name) + +(defun sqlplus-define-user-variables (string) + (when string + (let (variables-list + define-commands + (index 0)) + (while (setq index (string-match "&+\\(\\(\\sw\\|\\s_\\)+\\)" string index)) + (let ((var-name (match-string 1 string))) + (setq index (+ 2 index)) + (unless (member var-name variables-list) + (push var-name variables-list)))) + (dolist (var-name (reverse variables-list)) + (let* ((default-value (gethash var-name sqlplus-user-variables nil)) + (value (read-string (format (concat "Variable value for %s" (if default-value (format " [default: %s]" default-value) "") ": ") var-name) + nil 'sqlplus-user-variables-history default-value))) + (unless value + (error "There is no value for %s defined" var-name)) + (setq define-commands (cons (format "define %s=%s" var-name value) define-commands)) + (puthash var-name value sqlplus-user-variables))) + define-commands))) + +(defun sqlplus-parse-region (start end) + (let ((sql (buffer-substring start end))) + (save-excursion + ;; Strip whitespace from beginning and end, just to be neat. + (if (string-match "\\`[ \t\n]+" sql) + (setq sql (substring sql (match-end 0)))) + (if (string-match "[ \t\n]+\\'" sql) + (setq sql (substring sql 0 (match-beginning 0)))) + (setq sql (replace-regexp-in-string "^[ \t]*--.*[\n]?" "" sql)) + (when (zerop (length sql)) + (error "Nothing to send")) + ;; Now the string should end with an sqlplus-terminator. + (if (not (string-match "\\(;\\|/\\|[.]\\)\\'" sql)) + (setq sql (concat sql ";")))) + sql)) + +(defun sqlplus-show-html-fun (context connect-string begin end interrupted) + (let ((output-file (expand-file-name (substitute-in-file-name sqlplus-html-output-file-name))) + (sql (sqlplus-get-context-value context :htmlized-html-command)) + (html (buffer-substring begin end)) + (header-html (eval sqlplus-html-output-header))) + (let ((case-fold-search t)) + (while (and (string-match "\\`[ \t\n]*\\(<br>\\|<p>\\)?" html) (match-string 0 html) (> (length (match-string 0 html)) 0)) + (setq html (replace-match "" nil t html))) + (when (> (length html) 0) + (sqlplus-execute connect-string "" nil '("set markup html off") 'no-echo 'dont-show-output-buffer) + (find-file output-file) + (erase-buffer) + (insert (concat "<html>\n" + "<head>\n" + " <meta http-equiv=\"content-type\" content=\"text/html; charset=" sqlplus-html-output-encoding "\">\n" + (sqlplus-get-context-value context :head) "\n" + "</head>\n" + "<body " (sqlplus-get-context-value context :body) ">\n" + (if header-html header-html "") + (if sqlplus-html-output-sql sql "") + "<p>" + html "\n" + "</body>\n" + "</html>")) + (goto-char (point-min)) + (save-buffer))))) + +(defun sqlplus-refine-html (html remove-entities) + (string-match "\\`\"?\\(\\(.\\|\n\\)*?\\)\"?[ \t\n]*\\'" html) + (setq html (match-string 1 html)) + (if remove-entities + (progn + (while (string-match """ html) (setq html (replace-match "\"" nil t html))) + (while (string-match "<" html) (setq html (replace-match "<" nil t html))) + (while (string-match ">" html) (setq html (replace-match ">" nil t html))) + (while (string-match "&" html) (setq html (replace-match "&" nil t html)))) + (while (string-match "&" html) (setq html (replace-match "&" nil t html))) + (while (string-match ">" html) (setq html (replace-match ">" nil t html))) + (while (string-match "<" html) (setq html (replace-match "<" nil t html))) + (while (string-match "\"" html) (setq html (replace-match """ nil t html)))) + (string-match "\\`\"?\\(\\(.\\|\n\\)*?\\)\"?[ \t\n]*\\'" html) + (setq html (match-string 1 html)) + html) + +(defun sqlplus-show-markup-fun (context connect-string begin end interrupted) + (goto-char begin) + (let ((head "") + (body "") + preformat) + (when (re-search-forward (concat "\\bHEAD\\b[ \t\n]*\\(\\(.\\|\n\\)*\\)[ \t\n]*" + "\\bBODY\\b[ \t\n]*\\(\\(.\\|\n\\)*\\)[ \t\n]*" + "\\bTABLE\\b\\(.\\|\n\\)*PREFORMAT[ \t\n]+\\(ON\\|OFF\\)\\b") nil t) + (setq head (match-string 1) + body (match-string 3) + preformat (string= (downcase (match-string 6)) "on")) + (setq head (sqlplus-refine-html head t) + body (sqlplus-refine-html body t)) + (let ((context-options (list (cons :result-function 'sqlplus-show-html-fun) + (cons :current-command-input-buffer-name (sqlplus-get-context-value context :current-command-input-buffer-name)) + (cons :html-command (sqlplus-get-context-value context :html-command)) + (cons :htmlized-html-command (sqlplus-get-context-value context :htmlized-html-command)) + (cons :head head) + (cons :body body))) + (prolog-commands (list "set wrap on" + (format "set linesize %S" (if preformat (1- (frame-width)) 4000)) + "set pagesize 50000" + "btitle off" + "repfooter off" + "set markup html on"))) + (sqlplus-execute connect-string (sqlplus-get-context-value context :html-command) context-options prolog-commands 'no-echo 'dont-show-output-buffer))))) + +(defun sqlplus-htmlize (begin end) + (let (result) + (when (featurep 'htmlize) + (let* ((htmlize-output-type 'font) + (buffer (funcall (symbol-function 'htmlize-region) begin end))) + (with-current-buffer buffer + (goto-char 1) + (re-search-forward "<pre>[ \t\n]*\\(\\(.\\|\n\\)*?\\)[ \t\n]*</pre>" nil t) + (setq result (concat "<pre>" (match-string 1) "</pre>"))) + (kill-buffer buffer))) + (unless result + (setq result (sqlplus-refine-html (buffer-substring begin end) nil))) + result)) + +(defun sqlplus--send (connect-string sql &optional arg no-echo html start end) + (if html + (let* ((context-options (list (cons :result-function 'sqlplus-show-markup-fun) + (cons :current-command-input-buffer-name (buffer-name)) + (cons :html-command sql) + (cons :htmlized-html-command (if (and (eq sqlplus-html-output-sql 'elegant) (featurep 'htmlize)) + (sqlplus-htmlize start end) + (sqlplus-refine-html sql nil)))))) + (sqlplus-execute connect-string "show markup\n" context-options nil 'no-echo 'dont-show-output-buffer)) + (let* ((no-parse (consp arg)) + (context-options (list (cons :dont-parse-result (consp arg)) + (cons :columns-count (if (integerp arg) + (if (zerop arg) nil arg) + (if sqlplus-multi-output-tables-default-flag nil 1))) + (cons :current-command-input-buffer-name (buffer-name)))) + (prolog-commands (list (format "set wrap %s" (if no-parse "on" sqlplus-default-wrap)) + (format "set linesize %s" (if (consp arg) (1- (frame-width)) 4000)) + (format "set pagesize %S" (if no-parse 50000 sqlplus-pagesize)) + (format "btitle %s" + (if no-parse "off" (concat "left '" sqlplus-page-separator "'"))) + (format "repfooter %s" + (if no-parse "off" (concat "left '" sqlplus-repfooter "'")))))) + (sqlplus-execute connect-string sql context-options prolog-commands no-echo)))) + +(defun sqlplus-explain () + (interactive) + (sqlplus-check-connection) + (when (buffer-file-name) + (condition-case err + (save-buffer) + (error (message (error-message-string err))))) + (let* ((region (sqlplus-mark-current))) + (setq sqlplus-region-beginning-pos (car region) + sqlplus-region-end-pos (cdr region)) + (if (and sqlplus-region-beginning-pos sqlplus-region-end-pos) + (let ((sql (sqlplus-parse-region (car region) (cdr region))) + (case-fold-search t)) + (if (string-match "^[\n\t ]*explain[\n\t ]+plan[\t\t ]+for\\>" sql) + (sqlplus--send sqlplus-connect-string sql nil nil nil) + (setq sql (concat (sqlplus-fontify-string sqlplus-connect-string "explain plan for ") sql)) + (sqlplus--send sqlplus-connect-string sql nil nil nil))) + (error "Point doesn't indicate any command to execute")))) + +(defun sqlplus-send-region (arg start end &optional no-echo html) + "Send a region to the SQL*Plus process." + (interactive "P\nr") + (sqlplus-check-connection) + (sqlplus--send sqlplus-connect-string (sqlplus-parse-region start end) arg no-echo html start end)) + +(defun sqlplus-user-command (connect-string sql result-proc) + (let* ((context-options (list (cons :user-function result-proc) + (cons :columns-count 1))) + (prolog-commands (list (format "set wrap %s" sqlplus-default-wrap) + "set linesize 4000" + "set timing off" + "set pagesize 50000" + "btitle off" + (format "repfooter %s" (concat "left '" sqlplus-repfooter "'"))))) + (sqlplus-execute connect-string sql context-options prolog-commands 'no-echo 'dont-show-output-buffer))) + + +(defun sqlplus-hidden-select (connect-string sql result-proc) + (let* ((context-options (list (cons :result-table-function result-proc) + (cons :columns-count 1))) + (prolog-commands (list (format "set wrap %s" sqlplus-default-wrap) + "set linesize 4000" + "set pagesize 50000" + "btitle off" + (format "repfooter %s" (concat "left '" sqlplus-repfooter "'"))))) + (sqlplus-execute connect-string sql context-options prolog-commands 'no-echo 'dont-show-output-buffer))) + +;; "appi[nfo]" -> '("appinfo" "appi") +(defun sqlplus-full-forms (name) + (if (string-match "\\`\\([^[]*\\)?\\[\\([^]]+\\)\\]\\([^]]*\\)?\\'" name) + (list (replace-match "\\1\\2\\3" t nil name) + (replace-match "\\1\\3" t nil name)) + (list name))) + +(defun sqlplus-get-canonical-command-name (name) + (let ((association (assoc (downcase name) sqlplus-system-variables))) + (if association (cdr association) name))) + + +(defun sqlplus-execute (connect-string sql context-options prolog-commands &optional no-echo dont-show-output-buffer) + (sqlplus-verify-buffer connect-string) + (let* ((process-buffer-name (sqlplus-get-process-buffer-name connect-string)) + (process-buffer (get-buffer process-buffer-name)) + (output-buffer-name (sqlplus-get-output-buffer-name connect-string)) + (echo-prolog (concat "\n" sqlplus-output-separator " " (current-time-string) "\n\n")) + (process (get-buffer-process process-buffer-name)) + set-prolog-commands commands command-no + (history-buffer (sqlplus-get-history-buffer connect-string)) + (defines (sqlplus-define-user-variables sql))) + (setq prolog-commands (append (sqlplus-initial-strings) prolog-commands)) + (when process-buffer + (with-current-buffer process-buffer + (setq command-no sqlplus-command-seq) + (incf sqlplus-command-seq) + (setq context-options (append (list (cons :id command-no) (cons :sql sql)) (copy-list context-options))) + (setq sqlplus-command-contexts (reverse (cons context-options (reverse sqlplus-command-contexts)))))) + ;; move all "set" commands from prolog-commands to set-prolog-commands + (setq prolog-commands (delq nil (mapcar (lambda (command) (if (string-match "^\\s-*[sS][eE][tT]\\s-+" command) + (progn + (setq set-prolog-commands + (append set-prolog-commands + (list (substring command (length (match-string 0 command)))))) + nil) + command)) + prolog-commands))) + ;; remove duplicates commands from prolog-commands (last entries win) + (let (spc-alist) + (dolist (command prolog-commands) + (let* ((name (progn (string-match "^\\S-+" command) (downcase (match-string 0 command)))) + (association (assoc name spc-alist))) + (if (and association (not (equal name "define"))) + (setcdr association command) + (setq spc-alist (cons (cons name command) spc-alist))))) + (setq prolog-commands (mapcar (lambda (pair) (cdr pair)) (reverse spc-alist)))) + + (setq prolog-commands (append prolog-commands defines)) + (setq set-prolog-commands (append (list (format "sqlprompt '%s%S%s'" sqlplus-prompt-prefix command-no sqlplus-prompt-suffix)) set-prolog-commands)) + + ;; remove duplicates from set-prolog-commands (last entries win) + (let (spc-alist) + (dolist (set-command set-prolog-commands) + (let* ((name (progn (string-match "^\\S-+" set-command) (downcase (sqlplus-get-canonical-command-name (match-string 0 set-command))))) + (association (assoc name spc-alist))) + (if association + (setcdr association set-command) + (setq spc-alist (cons (cons name set-command) spc-alist))))) + (setq set-prolog-commands (mapcar (lambda (pair) (cdr pair)) (reverse spc-alist)))) + + (setq commands (concat (mapconcat 'identity (append + (list (concat "set " (mapconcat 'identity set-prolog-commands " "))) + prolog-commands + (list sql)) "\n") + "\n")) + (when history-buffer + (with-current-buffer history-buffer + (goto-char (point-max)) + (insert echo-prolog) + (insert (concat commands "\n")))) + (let ((saved-window (cons (selected-window) (window-buffer (selected-window)))) + (input-buffer (get-buffer (sqlplus-get-input-buffer-name connect-string)))) + (unless no-echo + (sqlplus-echo-in-buffer output-buffer-name echo-prolog) + (let ((old-suppress-show-output-buffer sqlplus-suppress-show-output-buffer)) + (unwind-protect + (save-selected-window + (setq sqlplus-suppress-show-output-buffer dont-show-output-buffer) + (when (and output-buffer-name + (get-buffer output-buffer-name)) + (with-current-buffer (get-buffer output-buffer-name) + (sqlplus-buffer-bottom connect-string) + (sqlplus-buffer-mark-current connect-string)))) + (setq sqlplus-suppress-show-output-buffer old-suppress-show-output-buffer))) + (sqlplus-echo-in-buffer output-buffer-name (concat sql "\n\n") nil t) + (save-selected-window + (unless dont-show-output-buffer + (when (and output-buffer-name + (get-buffer output-buffer-name)) + (with-current-buffer (get-buffer output-buffer-name) + (sqlplus-buffer-redisplay-current connect-string)))))) + (if (window-live-p (car saved-window)) + (select-window (car saved-window)) + (if (get-buffer-window (cdr saved-window)) + (select-window (get-buffer-window (cdr saved-window))) + (when (and input-buffer + (get-buffer-window input-buffer)) + (select-window (get-buffer-window input-buffer)))))) + (send-string process commands))) + +(defun sqlplus-fontify-string (connect-string string) + (let* ((input-buffer-name (sqlplus-get-input-buffer-name connect-string)) + (input-buffer (when input-buffer-name (get-buffer input-buffer-name))) + (result string)) + (when (and input-buffer (buffer-live-p input-buffer)) + (with-current-buffer input-buffer + (save-excursion + (goto-char (point-max)) + (let ((pos (point))) + (insert "\n\n") + (insert string) + (font-lock-fontify-block (+ (count "\n" string) 2)) + (setq result (buffer-substring (+ pos 2) (point-max))) + (delete-region pos (point-max)))))) + result)) + +(defvar plsql-mark-backward-list nil) + +(unless plsql-mode-map + (setq plsql-mode-map (copy-keymap sql-mode-map)) + (define-key plsql-mode-map "\M-." 'sqlplus-file-get-source) + (define-key plsql-mode-map [C-down-mouse-1] 'sqlplus-mouse-select-identifier) + (define-key plsql-mode-map [C-mouse-1] 'sqlplus-file-get-source-mouse) + (define-key plsql-mode-map "\C-c\C-g" 'plsql-begin) + (define-key plsql-mode-map "\C-c\C-q" 'plsql-loop) + (define-key plsql-mode-map "\C-c\C-z" 'plsql-if) + (define-key plsql-mode-map "\C-c\C-c" 'plsql-compile) + (define-key plsql-mode-map [tool-bar plsql-prev-mark] + (list 'menu-item "Previous mark" 'plsql-prev-mark + :image plsql-prev-mark-image + :enable 'plsql-mark-backward-list))) + +(defvar plsql-continue-anyway nil + "Local in input buffer (plsql-mode).") +(make-variable-buffer-local 'plsql-continue-anyway) + +(defun sqlplus-switch-to-buffer (buffer-or-path &optional line-no) + (if (fboundp 'ide-skel-select-buffer) + (funcall 'ide-skel-select-buffer buffer-or-path line-no) + (let ((buffer (or (and (bufferp buffer-or-path) buffer-or-path) + (find-file-noselect buffer-or-path)))) + (switch-to-buffer buffer) + (goto-line line-no)))) + +(defun plsql-prev-mark () + (interactive) + (let (finish) + (while (and plsql-mark-backward-list + (not finish)) + (let* ((marker (pop plsql-mark-backward-list)) + (buffer (marker-buffer marker)) + (point (marker-position marker))) + (set-marker marker nil) + (when (and buffer + (or (not (eq (current-buffer) buffer)) + (not (eql (point) point)))) + (sqlplus-switch-to-buffer buffer) + (goto-char point) + (setq finish t)))) + ;; (message "BACK: %S -- FORWARD: %S" plsql-mark-backward-list plsql-mark-forward-list) + (force-mode-line-update) + (sit-for 0))) + +(defun sqlplus-mouse-select-identifier (event) + (interactive "@e") + (with-selected-window (posn-window (event-start event)) + (save-excursion + (let* ((point (posn-point (event-start event))) + (identifier (progn (goto-char point) (thing-at-point 'symbol))) + (ident-regexp (when identifier (regexp-quote identifier)))) + (push (point-marker) plsql-mark-backward-list) + (when ident-regexp + (save-excursion + (while (not (looking-at ident-regexp)) + (backward-char)) + (sqlplus-mouse-set-selection (current-buffer) (point) (+ (point) (length identifier)) 'highlight))))))) + +(defun sqlplus-file-get-source-mouse (event) + (interactive "@e") + (let (ident) + (with-selected-window (posn-window (event-start event)) + (save-excursion + (goto-char (posn-point (event-start event))) + (setq ident (thing-at-point 'symbol)))) + (sqlplus-file-get-source sqlplus-connect-string ident nil) + (sit-for 0))) + +(defun plsql-compile (&optional arg) + "Save buffer and send its content to SQL*Plus. +You must enter connect-string if buffer is disconnected; with +argument you can change connect-string even for connected +buffer." + (interactive "P") + (let (aborted + exists-show-error-command + (case-fold-search t)) + (save-window-excursion + (save-excursion + ;; ask for "/" and "show err" if absent + (let ((old-point (point)) + show-err-needed + exists-run-command best-point finish) + (goto-char (point-min)) + (setq show-err-needed (let ((case-fold-search t)) + (re-search-forward "create\\([ \t\n]+or[ \t\n]+replace\\)?[ \t\n]+\\(package\\|procedure\\|function\\|trigger\\|view\\|type\\)" nil t))) + (goto-char (point-max)) + (forward-comment (- (buffer-size))) + (re-search-backward "^\\s-*show\\s-+err" nil t) + (forward-comment (- (buffer-size))) + (condition-case nil (forward-char) (error nil)) + (setq best-point (point)) + (goto-char (point-min)) + (setq exists-run-command (re-search-forward "^\\s-*/[^*]" nil t)) + (goto-char (point-min)) + (setq exists-show-error-command (or (not show-err-needed) (re-search-forward "^\\s-*show\\s-+err" nil t))) + (while (and (not plsql-continue-anyway) (or (not exists-run-command) (not exists-show-error-command)) (not finish)) + (goto-char best-point) + (let ((c (read-char + (format "Cannot find %s. (I)nsert it at point, (A)bort, (C)ontinue anyway" + (concat (unless exists-run-command "\"/\"") + (unless (or exists-run-command exists-show-error-command) " and ") + (unless exists-show-error-command "\"show err\"")))))) + (cond ((memq c '(?i ?I)) + (unless exists-run-command (insert "/\n")) + (unless exists-show-error-command (insert "show err\n")) + (setq finish t)) + ((memq c '(?a ?A)) + (setq aborted t + finish t)) + ((memq c '(?c ?C)) + (setq plsql-continue-anyway t) + (setq finish t)))))))) + (unless aborted + (save-buffer) + (let* ((buffer (current-buffer)) + (input-buffer-name (buffer-name)) + (file-path (sqlplus-file-truename (buffer-file-name))) + (compilation-buffer (get-buffer sqlplus-plsql-compilation-results-buffer-name)) + (context-options (list (cons :last-compiled-file-path file-path) + (cons :current-command-input-buffer-name input-buffer-name) + (cons :compilation-expected exists-show-error-command))) + (prolog-commands (list (format "set wrap %s" sqlplus-default-wrap) + "set linesize 4000" + (format "set pagesize %S" sqlplus-pagesize) + (format "btitle %s" (concat "left '" sqlplus-page-separator "'")) + (format "repfooter %s" (concat "left '" sqlplus-repfooter "'"))))) + (when (or (not sqlplus-connect-string) + arg) + (setq sqlplus-connect-string (car (sqlplus-read-connect-string nil (caar (sqlplus-divide-connect-strings)))))) + (sqlplus sqlplus-connect-string nil (when plsql-auto-parse-errors-flag 'dont-show-output-buffer)) + (set-buffer buffer) + (force-mode-line-update) + (when font-lock-mode (font-lock-mode 1)) + (when compilation-buffer + (with-current-buffer compilation-buffer + (let ((inhibit-read-only t)) + (erase-buffer)))) + (setq prolog-commands (append prolog-commands (sqlplus-define-user-variables (buffer-string)))) + (sqlplus-execute sqlplus-connect-string (concat "@" file-path) context-options prolog-commands nil exists-show-error-command))))) + +(defun plsql-parse-errors (last-compiled-file-path) + (let ((file-name (file-name-nondirectory last-compiled-file-path)) + error-list) + (put-text-property 0 (length file-name) 'face 'font-lock-warning-face file-name) + (save-excursion + (when (re-search-forward "^LINE/COL\\>" nil t) + (beginning-of-line 3) + (while (re-search-forward "^\\([0-9]+\\)/\\([0-9]+\\)\\s-*\\(\\(.\\|\n\\)*?\\)[\r\t ]*\n\\([\r\t ]*\\(\n\\|\\'\\)\\|[0-9]+\\)" nil t) + (let ((line-no (match-string 1)) + (column-no (match-string 2)) + (errmsg (match-string 3)) + label) + (goto-char (match-beginning 5)) + (while (string-match "\\s-\\s-+" errmsg) + (setq errmsg (replace-match " " nil t errmsg))) + (put-text-property 0 (length line-no) 'face 'font-lock-variable-name-face line-no) + (put-text-property 0 (length column-no) 'face 'font-lock-variable-name-face column-no) + (setq label (concat file-name ":" line-no ":" column-no ": " errmsg)) + (put-text-property 0 (length label) 'mouse-face 'highlight label) + (push label error-list))))) + (save-excursion + (while (re-search-forward "\\s-\\([0-9]+\\):\n\\(ORA-[0-9]+[^\n]*\\)\n" nil t) + (let ((line-no (match-string 1)) + (errmsg (match-string 2)) + label) + (put-text-property 0 (length line-no) 'face 'font-lock-variable-name-face line-no) + (setq label (concat file-name ":" line-no ": " errmsg)) + (put-text-property 0 (length label) 'mouse-face 'highlight label) + (push label error-list)))) + (save-excursion + (while (re-search-forward "\\(\\(SP2\\|CPY\\)-[0-9]+:[^\n]*\\)\n" nil t) + (let ((errmsg (match-string 1)) + label) + (setq label (concat file-name ":" errmsg)) + (put-text-property 0 (length label) 'mouse-face 'highlight label) + (push label error-list)))) + error-list)) + +(defun plsql-display-errors (dir error-list) + (let ((buffer (get-buffer-create sqlplus-plsql-compilation-results-buffer-name))) + (save-selected-window + (save-excursion + (set-buffer buffer) + (let ((inhibit-read-only t)) + (erase-buffer) + (setq default-directory dir) + (insert (format "cd %s\n" default-directory)) + (insert (format "Compilation results\n")) + (compilation-minor-mode 1) + (dolist (msg (reverse error-list)) + (insert msg) + (insert "\n")) + (insert (format "\n(%s errors)\n" (length error-list)))) + (when (and error-list (fboundp 'compile-reinitialize-errors) (funcall (symbol-function 'compile-reinitialize-errors) t))) + (switch-to-buffer-other-window buffer) + (goto-line 1) + (goto-line 3))))) + + +(defun sqlplus-file-truename (file-name) + (if file-name + (file-truename file-name) + file-name)) + +(defun sqlplus--hidden-buffer-name-p (buffer-name) + (equal (elt buffer-name 0) 32)) + +(defun sqlplus-get-workbench-window () + "Return upper left window" + (if (fboundp 'ide-get-workbench-window) + (funcall (symbol-function 'ide-get-workbench-window)) + (let (best-window) + (dolist (win (copy-list (window-list nil 1))) + (when (not (sqlplus--hidden-buffer-name-p (buffer-name (window-buffer win)))) + (if (null best-window) + (setq best-window win) + (let* ((best-window-coords (window-edges best-window)) + (win-coords (window-edges win))) + (when (or (< (cadr win-coords) (cadr best-window-coords)) + (and (= (cadr win-coords) (cadr best-window-coords)) + (< (car win-coords) (car best-window-coords)))) + (setq best-window win)))))) + ;; (message "BEST-WINDOW: %S" best-window) + best-window))) + +(defun sqlplus-get-side-window () + "Return bottom helper window, or nil if not found" + (if (fboundp 'ide-get-side-window) + (funcall (symbol-function 'ide-get-side-window)) + (let* ((workbench-window (sqlplus-get-workbench-window)) + best-window) + (dolist (win (copy-list (window-list nil 1))) + (when (and (not (sqlplus--hidden-buffer-name-p (buffer-name (window-buffer win)))) + (not (eq win workbench-window))) + (if (null best-window) + (setq best-window win) + (when (> (cadr (window-edges win)) (cadr (window-edges best-window))) + (setq best-window win))))) + best-window))) + +(defvar sqlplus--idle-tasks nil) + +(defun sqlplus--enqueue-task (fun &rest params) + (setq sqlplus--idle-tasks (reverse (cons (cons fun params) (reverse sqlplus--idle-tasks))))) + +(defun sqlplus--execute-tasks () + (dolist (task sqlplus--idle-tasks) + (let ((fun (car task)) + (params (cdr task))) + (condition-case var + (apply fun params) + (error (message (error-message-string var)))))) + (setq sqlplus--idle-tasks nil)) + +(add-hook 'post-command-hook 'sqlplus--execute-tasks) + +(defvar sqlplus-mouse-selection nil) + +(defun sqlplus-mouse-set-selection (buffer begin end mouse-face) + (interactive "@e") + (let ((old-buffer-modified-p (buffer-modified-p))) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (unwind-protect + (put-text-property begin end 'mouse-face mouse-face) + (set-buffer-modified-p old-buffer-modified-p) + (setq sqlplus-mouse-selection (when mouse-face (list buffer begin end)))))))) + +(defun sqlplus-clear-mouse-selection () + (when (and sqlplus-mouse-selection + (eq (event-basic-type last-input-event) 'mouse-1) + (not (memq 'down (event-modifiers last-input-event)))) + (sqlplus-mouse-set-selection (car sqlplus-mouse-selection) (cadr sqlplus-mouse-selection) (caddr sqlplus-mouse-selection) nil))) + +(add-hook 'plsql-mode-hook + (lambda () + (modify-syntax-entry ?. "." sql-mode-syntax-table) + (setq sqlplus-font-lock-keywords-1 (sqlplus-set-font-lock-emacs-structures-for-level 1 major-mode)) + (setq sqlplus-font-lock-keywords-2 (sqlplus-set-font-lock-emacs-structures-for-level 2 major-mode)) + (setq sqlplus-font-lock-keywords-3 (sqlplus-set-font-lock-emacs-structures-for-level 3 major-mode)) + (setq font-lock-defaults '((sqlplus-font-lock-keywords-1 sqlplus-font-lock-keywords-2 sqlplus-font-lock-keywords-3) + nil t ((?_ . "w") (?$ . "w") (?# . "w") (?& . "w")))) + (orcl-mode 1) + (use-local-map plsql-mode-map) ; std + (add-hook 'post-command-hook 'sqlplus-clear-mouse-selection nil t))) + +(setq recentf-exclude (cons (concat "^" (regexp-quote (file-name-as-directory temporary-file-directory))) + (when (boundp 'recentf-exclude) + recentf-exclude))) + +(when (fboundp 'ide-register-persistent-var) + (funcall (symbol-function 'ide-register-persistent-var) 'sqlplus-connect-strings-alist + ;; save proc + (lambda (alist) + (mapcar (lambda (pair) + (if sqlplus-save-passwords + pair + (cons (car pair) nil))) + alist)) + ;; load proc + (lambda (alist) + (setq sqlplus-connect-string-history (mapcar (lambda (pair) (car pair)) alist)) + alist))) + +(defun get-all-dirs (root-dir) + (let ((list-to-see (list root-dir)) + result-list) + (while list-to-see + (let* ((dir (pop list-to-see)) + (children (directory-files dir t))) + (push dir result-list) + (dolist (child children) + (when (and (not (string-match "^[.]+"(file-name-nondirectory child))) + (file-directory-p child)) + (push child list-to-see))))) + result-list)) + +(defun sqlplus-command-line () + (interactive) + (if (comint-check-proc "*SQL*") + (pop-to-buffer "*SQL*") + (let* ((pair (sqlplus-read-connect-string nil (when sqlplus-connect-string (car (refine-connect-string sqlplus-connect-string))))) + (qualified-cs (car pair)) + (refined-cs (cadr pair)) + (password (cdr (refine-connect-string qualified-cs)))) + (if (string-match "^\\([^@]*\\)@\\(.*\\)$" refined-cs) + (let ((old-sql-get-login-fun (symbol-function 'sql-get-login))) + (setq sql-user (match-string 1 refined-cs) + sql-password password + sql-database (match-string 2 refined-cs)) + (unwind-protect + (progn + (fset 'sql-get-login (lambda (&rest whatever) nil)) + (sql-oracle)) + (fset 'sql-get-login old-sql-get-login-fun))) + (error "Connect string must be in form login@sid"))))) + +(defun sqlplus-find-tnsnames () + (interactive) + (let* ((ora-home-dir (or (getenv "ORACLE_HOME") (error "Environment variable ORACLE_HOME not set"))) + found + (list-to-see (list ora-home-dir))) + (while (and (not found) list-to-see) + (let* ((dir (pop list-to-see)) + (children (condition-case nil (directory-files dir t) (error nil)))) + (dolist (child children) + (unless found + (if (string-match "admin.tnsnames\.ora$" child) + (progn + (setq found t) + (find-file child)) + (if (and (not (string-match "^[.]+" (file-name-nondirectory child))) + (file-directory-p child)) + (push child list-to-see))))))) + (unless found + (message "File tnsnames.ora not found")))) + +(defun sqlplus-remove-help-echo (list) + "Remove all HELP-ECHO properties from mode-line format value" + (when (listp list) + (if (eq (car list) :propertize) + (while list + (when (eq (cadr list) 'help-echo) + (setcdr list (cdddr list))) + (setq list (cdr list))) + (dolist (elem list) (sqlplus-remove-help-echo elem))))) + +(when (>= emacs-major-version 22) + (sqlplus-remove-help-echo mode-line-modes)) + +(defun sqlplus-get-project-root-dir (path) + (let ((path (file-truename (substitute-in-file-name path))) + dir) + (if (file-directory-p path) + (progn + (setq path (file-name-as-directory path)) + (setq dir path)) + (setq dir (file-name-as-directory (file-name-directory path)))) + (let ((last-project-dir dir) + (dir-list (split-string dir "/")) + is-project) + (while (directory-files dir t (concat "^" "\\(\\.svn\\|CVS\\)$") t) + (setq is-project t + last-project-dir (file-name-as-directory dir) + dir (file-name-as-directory (file-name-directory (directory-file-name dir))))) + (when is-project + (let ((list (nthcdr (1- (length (split-string last-project-dir "/"))) dir-list))) + (cond ((equal (car list) "trunk") + (setq last-project-dir (concat last-project-dir "trunk/"))) + ((member (car list) '("branches" "tags")) + (setq last-project-dir (concat last-project-dir (car list) "/" (when (cdr list) (concat (cadr list) "/"))))) + (t))) + (setq dir last-project-dir))) + dir)) + +(defvar sqlplus-search-buffer-name "*search*") + +(defvar sqlplus-object-types-regexps + '( + ("TABLE" . "\\bcreate\\s+table\\s+[^(]*?\\b#\\b") + ("VIEW" . "\\bview\\s+.*?\\b#\\b") + ("INDEX" . "\\b(constraint|index)\\s+.*?\\b#\\b") + ("TRIGGER" . "\\btrigger\\s+.*?\\b#\\b") + ("SEQUENCE" . "\\bsequence\\s+.*?\\b#\\b") + ("SYNONYM" . "\\bsynonym\\s+.*?\\b#\\b") + ("SCHEMA" . "\\bcreate\\b.*?\\buser\\b.*?\\b#\\b") + ("PROCEDURE" . "\\b(procedure|function)\\b[^(]*?\\b#\\b") + ("PACKAGE" . "\\bpackage\\s+.*?\\b#\\b"))) + +(defvar sqlplus-root-dir-history nil) + +(defvar sqlplus-compare-report-buffer-name "*Comparation Report*") + +(defun sqlplus-compare-schema-to-filesystem (&optional arg) + (interactive "P") + (let* ((connect-string sqlplus-connect-string) + (objects-alist (sqlplus-get-objects-alist sqlplus-connect-string)) + (report-buffer (get-buffer-create sqlplus-compare-report-buffer-name)) + (types-length (- (length objects-alist) 2)) + (root-dir (or (sqlplus-get-root-dir connect-string) + (sqlplus-set-project-for-connect-string connect-string) + (error "Root dir not set"))) + (counter 0)) + (unless objects-alist + (error "Not ready yet - try again later")) + (save-excursion + (switch-to-buffer-other-window report-buffer)) + (with-current-buffer report-buffer + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (format "%s %s vs. %s\n\n" (current-time-string) (car (refine-connect-string connect-string)) root-dir)) + (sit-for 0))) + (dolist (pair objects-alist) + (let ((type (upcase (format "%s" (car pair)))) + (names (cdr pair))) + (unless (member type '("SCHEMA" "COLUMN")) + (incf counter) + (message (format "%s (%d/%d)..." type counter types-length)) + (dolist (name-pair names) + (let* ((name (car name-pair)) + (grep-result (sqlplus-file-get-source sqlplus-connect-string name type 'batch-mode))) + (with-current-buffer report-buffer + (let ((inhibit-read-only t)) + (goto-char (point-max)) + (cond ((eql (length grep-result) 0) + (insert (format "%s %s: not found\n" type name)) + (sit-for 0)) + ((and arg + (> (length grep-result) 1)) + (insert (format "%s %s:\n" type name)) + (dolist (list grep-result) + (insert (format " %s:%d %s\n" (car list) (cadr list) (caddr list)))) + (sit-for 0)) + (t))))))))) + (message "Done.") + (with-current-buffer report-buffer + (goto-char (point-min))))) + +(defun sqlplus-proj-find-files (dir file-predicate &optional dir-predicate) + (setq dir (file-name-as-directory (file-truename (substitute-in-file-name dir)))) + (let (result-list) + (mapcar (lambda (path) + (if (file-directory-p path) + (when (and (file-accessible-directory-p path) + (or (null dir-predicate) + (funcall dir-predicate path))) + (setq result-list (append result-list (sqlplus-proj-find-files path file-predicate dir-predicate)))) + (when (or (null file-predicate) + (funcall file-predicate path)) + (push path result-list)))) + (delete (concat (file-name-as-directory dir) ".") + (delete (concat (file-name-as-directory dir) "..") + (directory-files dir t nil t)))) + result-list)) + +(defvar sqlplus-proj-ignored-extensions '("semantic.cache")) + +(defun sqlplus-mode-file-regexp-list (mode-symbol-list) + (delq nil (mapcar (lambda (element) + (let ((fun-name (if (listp (cdr element)) (cadr element) (cdr element)))) + (when (memq fun-name mode-symbol-list) (cons (car element) fun-name)))) + auto-mode-alist))) + +(defun sqlplus-find-project-files (root-dir mode-symbol-list predicate) + (let ((obj-file-regexp-list (delq nil (mapcar (lambda (element) + (let ((len (length element))) + (unless (and (> len 0) + (equal (elt element (1- len)) ?/)) + (concat (regexp-quote element) "$")))) + (append sqlplus-proj-ignored-extensions completion-ignored-extensions)))) + (mode-file-regexp-list (sqlplus-mode-file-regexp-list mode-symbol-list))) ; (file-path-regexp . major-mode-function-symbol) + (when (and mode-symbol-list + (not mode-file-regexp-list)) + (error (format "No rules for %s major modes in auto-mode-alist." (mapconcat 'identity mode-symbol-list ", ")))) + (sqlplus-proj-find-files root-dir + (lambda (file-name) + (and (not (string-match "#" file-name)) + (not (string-match "semantic.cache" file-name)) + (or (and (not mode-symbol-list) + (not (some (lambda (regexp) + (string-match regexp file-name)) + obj-file-regexp-list))) + (and mode-symbol-list + (some (lambda (element) + (let ((freg (if (string-match "[$]" (car element)) + (car element) + (concat (car element) "$")))) + (when (string-match freg file-name) + (cdr element)))) + mode-file-regexp-list))) + (or (not predicate) + (funcall predicate file-name)))) + (lambda (dir-path) + (not (string-match "/\\(\\.svn\\|CVS\\)$" dir-path)))))) + + +(defun sqlplus-file-get-source (connect-string object-name object-type &optional batch-mode) + (interactive + (progn + (push (point-marker) plsql-mark-backward-list) + (list sqlplus-connect-string (thing-at-point 'symbol) nil))) + (unless object-name + (error "Nothing to search")) + (let* ((root-dir (or (and (not object-type) + (eq major-mode 'plsql-mode) + (buffer-file-name) + (sqlplus-get-project-root-dir (buffer-file-name))) + (sqlplus-get-root-dir connect-string) + (sqlplus-set-project-for-connect-string connect-string) + (error "Root dir not set"))) + (mode-symbol-list '(plsql-mode sql-mode)) + (files-to-grep (sqlplus-find-project-files root-dir mode-symbol-list nil)) + (temp-file-path (concat (file-name-as-directory temporary-file-directory) (make-temp-name "ide-"))) + (search-buffer (get-buffer sqlplus-search-buffer-name)) + (regexp (let ((index 0) + (len (length object-name)) + result) + (setq result + (if object-type + (let ((type (cond ((equal object-type "FUNCTION") "PROCEDURE") + ((equal object-type "PACKAGE BODY") "PACKAGE") + (t object-type)))) + (cdr (assoc type sqlplus-object-types-regexps))) + (mapconcat 'cdr sqlplus-object-types-regexps "|"))) + (unless result + (error "Not implemented")) + (while (and (< index (length result)) + (string-match "#" result index)) + (setq index (+ (match-beginning 0) len)) + (setq result (replace-match object-name t t result))) + (setq index 0) + (while (and (< index (length result)) + (string-match "[$]\\(\\\\b\\)?" result index)) + (setq index (+ (match-end 0) 1)) + (setq result (replace-match "\\$" t t result))) + result)) + grep-command + grep-result) + (when search-buffer + (with-current-buffer search-buffer + (let ((inhibit-read-only t)) + (erase-buffer)))) + ;; (message "Object type: %S, object name: %S, regexp: %S" object-type object-name regexp) + (with-temp-file temp-file-path + (dolist (path files-to-grep) + (insert (concat "'" path "'\n")))) + (let* ((grep-command (format "cat %s | xargs grep -nHiE -e '%s'" temp-file-path regexp)) + (raw-grep-result (split-string (shell-command-to-string grep-command) "\n" t)) + (grep-result (delq nil (mapcar (lambda (line) + (string-match "^\\(.*?\\):\\([0-9]+\\):\\(.*\\)$" line) + (let* ((path (match-string 1 line)) + (line-no (string-to-number (match-string 2 line))) + (text (match-string 3 line)) + (text2 text) + (syn-table (copy-syntax-table)) + (case-fold-search t)) + (modify-syntax-entry ?$ "w" syn-table) + (modify-syntax-entry ?# "w" syn-table) + (modify-syntax-entry ?_ "w" syn-table) + (with-syntax-table syn-table + (when (and (or (and (not object-type) + (> (length raw-grep-result) 1)) + (equal object-type "SYNONYM")) + (string-match "\\<\\(for\\|from\\|on\\|as\\)\\>" text2)) + (setq text2 (substring text2 0 (match-beginning 0)))) + ;; (message "GREP-RESULT: %s" text2) + (unless (or (not (string-match (concat "\\<" (regexp-quote object-name) "\\>") text2)) + (string-match (concat "\\(--\\|\\<pro\\>\\|\\<prompt\\>\\|\\<drop\\>\\|\\<grant\\>\\).*\\<" + (regexp-quote object-name) "\\>") text2) + (and (or (and (not object-type) + (> (length raw-grep-result) 1)) + (equal object-type "TRIGGER")) + (string-match "\\<\\(alter\\|disable\\|enable\\)\\>" text2)) + (and (or (and (not object-type) + (string-match "\\<package\\>" text2) + current-prefix-arg) + (equal object-type "PACKAGE")) + (string-match "\\<body\\>" text2)) + (and (or (and (not object-type) + (string-match "\\<package\\>" text2) + (not current-prefix-arg)) + (equal object-type "PACKAGE BODY")) + (not (string-match "\\<body\\>" text2))) + (and (not object-type) + (not current-prefix-arg) + (string-match "[.]pks$" path))) + (list path line-no text))))) + raw-grep-result)))) + (if batch-mode + grep-result + (cond ((not grep-result) + (error "Not found")) + ((eql (length grep-result) 1) + (sqlplus-switch-to-buffer (caar grep-result) (cadar grep-result)) + (when connect-string + (setq sqlplus-connect-string connect-string))) + (t + (let ((search-buffer (get-buffer-create sqlplus-search-buffer-name))) + (with-current-buffer search-buffer + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (setq default-directory root-dir) + (erase-buffer) + (insert "Root dir: ") + (sqlplus-proj-insert-with-face root-dir 'font-lock-keyword-face) + (insert "; Range: ") + (sqlplus-proj-insert-with-face (mapconcat (lambda (sym) (sqlplus-mode-name-stringify sym)) mode-symbol-list ", ") + 'font-lock-keyword-face) + (insert "; Object type: ") + (sqlplus-proj-insert-with-face (or object-type "unspecified") 'font-lock-keyword-face) + (insert "; Object name: ") + (sqlplus-proj-insert-with-face object-name 'font-lock-keyword-face) + (insert "\n\n") + (compilation-minor-mode 1) + (dolist (result grep-result) + (let ((relative-path (concat "./" (file-relative-name (car result) root-dir))) + (line-no (cadr result)) + (text (caddr result))) + (put-text-property 0 (length relative-path) 'mouse-face 'highlight relative-path) + (insert relative-path) + (insert (format ":%S:1 %s\n" line-no text)))) + (insert (format "\n%d matches found." (length grep-result))) + (goto-char (point-min)) + (when (and grep-result (fboundp 'compile-reinitialize-errors) (funcall (symbol-function 'compile-reinitialize-errors) t))) + (switch-to-buffer-other-window search-buffer) + (goto-line 1) + (goto-line 3)))))))))) + +(defun sqlplus-mode-name-stringify (mode-name) + (let ((name (format "%s" mode-name))) + (replace-regexp-in-string "-" " " + (capitalize + (if (string-match "^\\(.*\\)-mode" name) + (match-string 1 name) + name))))) + +(defun sqlplus-proj-insert-with-face (string face) + (let ((point (point))) + (insert string) + (let ((overlay (make-overlay point (point)))) + (overlay-put overlay 'face face)))) + +(defun sqlplus-set-project-for-connect-string (connect-string) + (if (featurep 'ide-skel) + ;; Prepare sqlplus-root-dir-history (file-name-history) for user convenience + ;; 0. previous project root + ;; 1. current editor file project root + ;; 2. previous choices + ;; 3. new project roots + (let* ((prev-proj-root-dir (sqlplus-get-root-dir connect-string)) + (last-sel-window (funcall 'ide-skel-get-last-selected-window)) + (editor-file-proj-root-dir (when last-sel-window + (let* ((buffer (window-buffer last-sel-window)) + (path (and buffer (buffer-file-name buffer))) + (project (and path (car (funcall 'ide-skel-proj-get-project-create path))))) + (when (funcall 'ide-skel-project-p project) + (funcall 'ide-skel-project-root-path project)))))) + (setq sqlplus-root-dir-history + (delete-dups + (delq nil + (mapcar (lambda (dir) + (when dir + (directory-file-name (file-truename (substitute-in-file-name dir))))) + (append + (list editor-file-proj-root-dir prev-proj-root-dir) + sqlplus-root-dir-history + (mapcar (lambda (project) (funcall 'ide-skel-project-root-path project)) + (symbol-value 'ide-skel-projects))))))) + (let* ((file-name-history (cdr sqlplus-root-dir-history)) + (use-file-dialog nil) + (dir (directory-file-name (file-truename (substitute-in-file-name + (read-directory-name (format "Root dir for %s: " (car (refine-connect-string connect-string))) + (car sqlplus-root-dir-history) + (car sqlplus-root-dir-history) + t + nil)))))) + (funcall 'ide-skel-proj-get-project-create dir) + (sqlplus-set-root-dir dir connect-string) + (message (format "Root dir for %s set to %s" (car (refine-connect-string connect-string)) dir)) + dir)) + (let* ((use-file-dialog nil) + (dir (directory-file-name (file-truename (substitute-in-file-name + (read-directory-name (format "Root dir for %s: " (car (refine-connect-string connect-string))) + nil nil t nil)))))) + (sqlplus-set-root-dir dir connect-string) + (message (format "Root dir for %s set to %s" (car (refine-connect-string connect-string)) dir)) + dir))) + +;;; Plugin for ide-skel.el + +(defstruct sqlplus-tab + id + name ; tab name + symbol ; view/sequence/schema/trigger/index/table/package/synonym/procedure + help-string + (display-start 1) ; display-start in side view window + (data nil) ; '(("name" . status)...), where status t means 'invalid' + draw-function ; parameters: sqlplus-tab + click-function ; parameters: event "@e" + (errors-count 0) + (refresh-in-progress t) + update-select) + +(defvar sqlplus-side-view-connect-string nil) +(make-variable-buffer-local 'sqlplus-side-view-connect-string) + +(defvar sqlplus-side-view-active-tab nil) +(make-variable-buffer-local 'sqlplus-side-view-active-tab) + +(defvar sqlplus-side-view-tabset nil) +(make-variable-buffer-local 'sqlplus-side-view-tabset) + +(defface sqlplus-side-view-face '((t :inherit variable-pitch :height 0.8)) + "Default face used in right view" + :group 'sqlplus) + +(defvar sqlplus-side-view-keymap nil) +(unless sqlplus-side-view-keymap + (setq sqlplus-side-view-keymap (make-sparse-keymap)) + (define-key sqlplus-side-view-keymap [mode-line down-mouse-1] 'ignore) + (define-key sqlplus-side-view-keymap [mode-line mouse-1] 'sqlplus-side-view-tab-click)) + +(defun sqlplus-side-view-tab-click (event) + (interactive "@e") + (with-selected-window (posn-window (event-start event)) + (let* ((previous-sel-tab-info (nth sqlplus-side-view-active-tab sqlplus-side-view-tabset)) + (target (posn-string (event-start event))) + (tab-info (get-text-property (cdr target) 'tab-info (car target)))) + (setf (sqlplus-tab-display-start previous-sel-tab-info) (line-number-at-pos (window-start))) + (setq sqlplus-side-view-active-tab (sqlplus-tab-id tab-info)) + (sqlplus-side-view-redraw (current-buffer) t) + (sqlplus-side-view-buffer-mode-line)))) + +(defun sqlplus-side-view-buffer-mode-line () + (let* ((separator (propertize " " + 'face 'header-line + 'display '(space :width 0.2) + 'pointer 'arrow))) + (setq mode-line-format + (concat separator + (mapconcat (lambda (tab) + (let ((face (if (eq (sqlplus-tab-id tab) sqlplus-side-view-active-tab) + 'tabbar-selected + 'tabbar-unselected)) + (help-echo (concat (sqlplus-tab-help-string tab) + (if (> (sqlplus-tab-errors-count tab) 0) + (format "\n(%s error%s)" (sqlplus-tab-errors-count tab) + (if (> (sqlplus-tab-errors-count tab) 1) "s" "")) + "")))) + (propertize (format " %s " (sqlplus-tab-name tab)) + 'local-map sqlplus-side-view-keymap + 'tab-info tab + 'help-echo help-echo + 'mouse-face 'tabbar-highlight + 'face (if (> (sqlplus-tab-errors-count tab) 0) + (list '(foreground-color . "red") face) + face) + 'pointer 'hand))) + sqlplus-side-view-tabset + separator) + separator)))) + +(defun sqlplus-side-view-click-on-default-handler (event) + (interactive "@e") + (with-selected-window (posn-window (event-start event)) + (let* ((posn-point (posn-point (event-start event))) + (object-name (get-text-property posn-point 'object-name)) + (object-type (get-text-property posn-point 'object-type)) + (type (car event))) + (when (eq type 'mouse-3) + (setq type (car (x-popup-menu t (append (list 'keymap object-name) + (list '(sqlplus-refresh-side-view-buffer "Refresh" t)) + (list '(mouse-1 "Get source from Oracle" t)) + (list '(M-mouse-1 "Search source in filesystem" t)) + (list (list 'C-M-mouse-1 (concat "Set root dir for " (car (refine-connect-string sqlplus-side-view-connect-string))) t)) + ))))) + (cond ((eq type 'mouse-1) + (sqlplus-get-source sqlplus-side-view-connect-string object-name object-type)) + ((eq type 'M-mouse-1) + (sqlplus-file-get-source sqlplus-side-view-connect-string object-name object-type)) + ((eq type 'C-M-mouse-1) + (sqlplus-set-project-for-connect-string sqlplus-side-view-connect-string)) + ((eq type nil)) + (t + (condition-case err + (funcall type) + (error nil))))))) + +(defun sqlplus-side-view-click-on-index-handler (event) + (interactive "@e") + (with-selected-window (posn-window (event-start event)) + (let* ((posn-point (posn-point (event-start event))) + (object-name (get-text-property posn-point 'object-name)) + (object-type (get-text-property posn-point 'object-type)) + (type (car event))) + (when (eq type 'mouse-3) + (setq type (car (x-popup-menu t (append (list 'keymap object-name) + (list '(sqlplus-refresh-side-view-buffer "Refresh" t)) + (list '(mouse-1 "Get source from Oracle" t)) + (list '(M-mouse-1 "Search source in filesystem" t)) + (list (list 'C-M-mouse-1 (concat "Set root dir for " (car (refine-connect-string sqlplus-side-view-connect-string))) t)) + ))))) + (cond ((eq type 'mouse-1) + (sqlplus-get-source sqlplus-side-view-connect-string object-name object-type)) + ((eq type 'M-mouse-1) + (sqlplus-file-get-source sqlplus-side-view-connect-string object-name object-type)) + ((eq type 'C-M-mouse-1) + (sqlplus-set-project-for-connect-string sqlplus-side-view-connect-string)) + ((eq type nil)) + (t + (condition-case err + (funcall type) + (error nil))))))) + +(defun sqlplus-side-view-click-on-schema-handler (event) + (interactive "@e") + (with-selected-window (posn-window (event-start event)) + (let* ((posn-point (posn-point (event-start event))) + (object-name (get-text-property posn-point 'object-name)) + (object-type (get-text-property posn-point 'object-type)) + (last-selected-win (funcall 'ide-skel-get-last-selected-window)) + (type (car event))) + (when (eq type 'mouse-3) + (setq type (car (x-popup-menu t (append (list 'keymap object-name) + (list '(sqlplus-refresh-side-view-buffer "Refresh" t)) + (list '(mouse-1 "Connect to schema" t)) + (list '(M-mouse-1 "Search source in filesystem" t)) + (list (list 'C-M-mouse-1 (concat "Set root dir for " (car (refine-connect-string sqlplus-side-view-connect-string))) t)) + ))))) + (cond ((eq type 'mouse-1) + (when (string-match "@.*$" sqlplus-side-view-connect-string) + (let* ((cs (downcase (concat object-name (match-string 0 sqlplus-side-view-connect-string)))) + (pair (sqlplus-read-connect-string cs cs))) + (select-window (or last-selected-win (funcall 'ide-skel-get-editor-window))) + (sqlplus (car pair) (concat (cadr pair) (concat "." sqlplus-session-file-extension)))))) + ((eq type 'M-mouse-1) + (sqlplus-file-get-source sqlplus-side-view-connect-string object-name object-type)) + ((eq type 'C-M-mouse-1) + (sqlplus-set-project-for-connect-string sqlplus-side-view-connect-string)) + ((eq type nil)) + (t + (condition-case err + (funcall type) + (error nil)))) + (select-window (funcall 'ide-skel-get-last-selected-window))))) + +(defun sqlplus-side-view-click-on-table-handler (event) + (interactive "@e") + (with-selected-window (posn-window (event-start event)) + (let* ((posn-point (posn-point (event-start event))) + (object-name (get-text-property posn-point 'object-name)) + (object-type (get-text-property posn-point 'object-type)) + (type (car event))) + (when (eq type 'mouse-3) + (setq type (car (x-popup-menu t (append (list 'keymap object-name) + (list '(sqlplus-refresh-side-view-buffer "Refresh" t)) + (list '(mouse-1 "Show description" t)) + (list '(C-mouse-1 "Select *" t)) + (list '(S-mouse-1 "Get source from Oracle" t)) + (list '(M-mouse-1 "Search source in filesystem" t)) + (list (list 'C-M-mouse-1 (concat "Set root dir for " (car (refine-connect-string sqlplus-side-view-connect-string))) t)) + ))))) + (cond ((eq type 'mouse-1) + (sqlplus-execute sqlplus-side-view-connect-string + (sqlplus-fontify-string sqlplus-side-view-connect-string (format "desc %s;" object-name)) + nil nil)) + ((eq type 'C-mouse-1) + (sqlplus-execute sqlplus-side-view-connect-string + (sqlplus-fontify-string sqlplus-side-view-connect-string (format "select * from %s;" object-name)) + nil nil)) + ((eq type 'S-mouse-1) + (sqlplus-get-source sqlplus-side-view-connect-string object-name object-type)) + ((eq type 'M-mouse-1) + (sqlplus-file-get-source sqlplus-side-view-connect-string object-name object-type)) + ((eq type 'C-M-mouse-1) + (sqlplus-set-project-for-connect-string sqlplus-side-view-connect-string)) + ((eq type nil)) + (t + (condition-case err + (funcall type) + (error nil)))) + (select-window (funcall 'ide-skel-get-last-selected-window))))) + +(defun sqlplus-side-view-click-on-package-handler (event) + (interactive "@e") + (with-selected-window (posn-window (event-start event)) + (let* ((posn-point (posn-point (event-start event))) + (object-name (get-text-property posn-point 'object-name)) + (object-type (get-text-property posn-point 'object-type)) + (type (car event))) + (when (eq type 'mouse-3) + (setq type (car (x-popup-menu t (append (list 'keymap object-name) + (list '(sqlplus-refresh-side-view-buffer "Refresh" t)) + (list '(S-mouse-1 "Get package header from Oracle" t)) + (list '(mouse-1 "Get package body from Oracle" t)) + (list '(S-M-mouse-1 "Search header source in filesystem" t)) + (list '(M-mouse-1 "Search body source in filesystem" t)) + (list (list 'C-M-mouse-1 (concat "Set root dir for " (car (refine-connect-string sqlplus-side-view-connect-string))) t)) + ))))) + (cond ((eq type 'S-mouse-1) + (sqlplus-get-source sqlplus-side-view-connect-string object-name object-type)) + ((eq type 'mouse-1) + (sqlplus-get-source sqlplus-side-view-connect-string object-name "PACKAGE BODY")) + ((eq type 'M-mouse-1) + (sqlplus-file-get-source sqlplus-side-view-connect-string object-name "PACKAGE BODY")) + ((eq type 'S-M-mouse-1) + (sqlplus-file-get-source sqlplus-side-view-connect-string object-name "PACKAGE")) + ((eq type 'C-M-mouse-1) + (sqlplus-set-project-for-connect-string sqlplus-side-view-connect-string)) + ((eq type nil)) + (t + (condition-case err + (funcall type) + (error nil))))))) + +(defun sqlplus-side-view-default-draw-panel (tab-info click-function) + (let ((pairs (sort (sqlplus-tab-data tab-info) + (lambda (pair1 pair2) (string< (car pair1) (car pair2))))) + (type-name (upcase (symbol-name (sqlplus-tab-symbol tab-info))))) + (dolist (pair pairs) + (let* ((label (format " % -100s" (car pair))) + (km (make-sparse-keymap))) + (define-key km [down-mouse-1] 'ignore) + (define-key km [mouse-1] click-function) + (define-key km [C-down-mouse-1] 'ignore) + (define-key km [C-mouse-1] click-function) + (define-key km [S-down-mouse-1] 'ignore) + (define-key km [S-mouse-1] click-function) + (define-key km [down-mouse-3] 'ignore) + (define-key km [mouse-3] click-function) + (setq label (propertize label + 'mouse-face 'ide-skel-highlight-face + 'face (if (cdr pair) + '(sqlplus-side-view-face (foreground-color . "red")) + 'sqlplus-side-view-face) + 'local-map km + 'pointer 'hand + 'object-name (car pair) + 'object-type type-name)) + (insert label) + (insert "\n"))))) + +(defun sqlplus-refresh-side-view-buffer () + (let* ((tab-info (nth sqlplus-side-view-active-tab sqlplus-side-view-tabset)) + (update-select (sqlplus-tab-update-select tab-info))) + (unless (sqlplus-tab-refresh-in-progress tab-info) + (sqlplus-hidden-select sqlplus-side-view-connect-string update-select 'sqlplus-my-update-handler)))) + +(defun sqlplus-get-default-update-select (symbol) + (concat "select object_name, object_type, decode( status, 'INVALID', 'I', ' ' ) from user_objects\n" + "where object_name not like 'BIN$%'\n" + (format "and object_type = '%s';" (upcase (symbol-name symbol))))) + +(defun sqlplus-create-side-view-buffer (connect-string) + (let* ((original-connect-string connect-string) + (connect-string (car (refine-connect-string connect-string))) + (buffer (funcall 'ide-skel-get-side-view-buffer-create + (concat " Ide Skel Right View SQL " connect-string) + 'right "SQL" (concat "SQL Panel for " connect-string) + (lambda (editor-buffer) + (let ((connect-string sqlplus-side-view-connect-string)) + (with-current-buffer editor-buffer + (and connect-string + (equal (car (refine-connect-string sqlplus-connect-string)) + (car (refine-connect-string connect-string))) + ))))))) + (with-current-buffer buffer + (set 'ide-skel-tabbar-menu-function + (lambda () + (let ((tab-info (nth sqlplus-side-view-active-tab sqlplus-side-view-tabset))) + (list + (unless (sqlplus-tab-refresh-in-progress tab-info) + '(sqlplus-refresh-side-view-buffer "Refresh" t)))))) + (setq sqlplus-side-view-connect-string original-connect-string + sqlplus-side-view-active-tab 0 + sqlplus-side-view-tabset + (list + (make-sqlplus-tab :id 0 :name "Tab" :symbol 'table :help-string "Tables" :draw-function 'sqlplus-side-view-default-draw-panel + :update-select (sqlplus-get-default-update-select 'table) + :click-function 'sqlplus-side-view-click-on-table-handler) + (make-sqlplus-tab :id 1 :name "Vie" :symbol 'view :help-string "Views" :draw-function 'sqlplus-side-view-default-draw-panel + :update-select (sqlplus-get-default-update-select 'view) + :click-function 'sqlplus-side-view-click-on-table-handler) + (make-sqlplus-tab :id 2 :name "Idx" :symbol 'index :help-string "Indexes" :draw-function 'sqlplus-side-view-default-draw-panel + :update-select (sqlplus-get-default-update-select 'index) + :click-function 'sqlplus-side-view-click-on-index-handler) + (make-sqlplus-tab :id 3 :name "Tri" :symbol 'trigger :help-string "Triggers" :draw-function 'sqlplus-side-view-default-draw-panel + :update-select (sqlplus-get-default-update-select 'trigger) + :click-function 'sqlplus-side-view-click-on-default-handler) + (make-sqlplus-tab :id 4 :name "Seq" :symbol 'sequence :help-string "Sequences" :draw-function 'sqlplus-side-view-default-draw-panel + :update-select (sqlplus-get-default-update-select 'sequence) + :click-function 'sqlplus-side-view-click-on-default-handler) + (make-sqlplus-tab :id 5 :name "Syn" :symbol 'synonym :help-string "Synonyms" :draw-function 'sqlplus-side-view-default-draw-panel + :update-select (sqlplus-get-default-update-select 'synonym) + :click-function 'sqlplus-side-view-click-on-default-handler) + (make-sqlplus-tab :id 6 :name "Pkg" :symbol 'package :help-string "PL/SQL Packages" :draw-function 'sqlplus-side-view-default-draw-panel + :update-select (sqlplus-get-default-update-select 'package) + :click-function 'sqlplus-side-view-click-on-package-handler) + (make-sqlplus-tab :id 7 :name "Prc" :symbol 'procedure :help-string "PL/SQL Functions & Procedures" :draw-function 'sqlplus-side-view-default-draw-panel + :update-select (concat "select object_name, object_type, decode( status, 'INVALID', 'I', ' ' ) from user_objects\n" + "where object_name not like 'BIN$%'\n" + "and object_type in ('FUNCTION', 'PROCEDURE');") + :click-function 'sqlplus-side-view-click-on-default-handler) + (make-sqlplus-tab :id 8 :name "Sch" :symbol 'schema :help-string "Schemas" :draw-function 'sqlplus-side-view-default-draw-panel + :update-select "select username, 'SCHEMA', ' ' from all_users where username not like 'BIN$%';" + :click-function 'sqlplus-side-view-click-on-schema-handler) + )) + (sqlplus-side-view-buffer-mode-line)) + buffer)) + +(defun sqlplus-side-view-redraw (sql-view-buffer &optional window-start-from-tab-info) + (with-current-buffer sql-view-buffer + (let* ((point (point)) + (tab-info (nth sqlplus-side-view-active-tab sqlplus-side-view-tabset)) + (window-start (when (and (symbol-value 'ide-skel-current-right-view-window) + (eq (window-buffer (symbol-value 'ide-skel-current-right-view-window)) (current-buffer))) + (if window-start-from-tab-info + (sqlplus-tab-display-start tab-info) + (line-number-at-pos (window-start (symbol-value 'ide-skel-current-right-view-window))))))) + (let ((inhibit-read-only t)) + (setq buffer-read-only nil) + (erase-buffer) + (when (sqlplus-tab-draw-function tab-info) + (funcall (sqlplus-tab-draw-function tab-info) tab-info (sqlplus-tab-click-function tab-info)))) + (if window-start + (let ((pos (save-excursion + (goto-line window-start) + (beginning-of-line) + (point)))) + (set-window-start (symbol-value 'ide-skel-current-right-view-window) pos) + (setf (sqlplus-tab-display-start tab-info) window-start)) + (goto-char point) + (beginning-of-line))))) + +(defun sqlplus-side-view-update-data (connect-string alist) + (let* ((connect-string (car (refine-connect-string connect-string))) + (sql-view-buffer (sqlplus-get-side-view-buffer connect-string)) + was-proc) + (when sql-view-buffer + (with-current-buffer sql-view-buffer + (dolist (pair alist) + (let* ((symbol (if (eq (car pair) 'function) 'procedure (car pair))) + (data-list (cdr pair)) + (tab-info (some (lambda (tab) + (when (eq (sqlplus-tab-symbol tab) symbol) + tab)) + sqlplus-side-view-tabset))) + (when tab-info + (setf (sqlplus-tab-refresh-in-progress tab-info) nil) + (setf (sqlplus-tab-data tab-info) + (if (and (eq symbol 'procedure) + was-proc) + (append (sqlplus-tab-data tab-info) (copy-list data-list)) + data-list)) + (when (eq symbol 'procedure) + (setq was-proc t)) + (setf (sqlplus-tab-errors-count tab-info) + (count t (mapcar 'cdr data-list))) + (when (eql sqlplus-side-view-active-tab (sqlplus-tab-id tab-info)) + (sqlplus-side-view-redraw (current-buffer)))))) + (sqlplus-side-view-buffer-mode-line) + (force-mode-line-update))))) + +(defun sqlplus-side-view-window-function (side event &rest list) + (when (and (eq side 'right) + (symbol-value 'ide-skel-current-right-view-window) + (with-current-buffer (symbol-value 'ide-skel-current-editor-buffer) + sqlplus-connect-string)) + (cond ((memq event '(show editor-buffer-changed)) + (let ((sql-view-buffer (sqlplus-get-side-view-buffer (with-current-buffer (symbol-value 'ide-skel-current-editor-buffer) + sqlplus-connect-string)))) + (when sql-view-buffer + (with-current-buffer sql-view-buffer + (set 'ide-skel-tabbar-enabled t) + (funcall 'ide-skel-side-window-switch-to-buffer (symbol-value 'ide-skel-current-right-view-window) sql-view-buffer))))))) + nil) + +(add-hook 'ide-skel-side-view-window-functions 'sqlplus-side-view-window-function) + + +(provide 'sqlplus) + +;;; sqlplus.el ends here diff --git a/.emacs.d/elisp/stumpwm-mode.el b/.emacs.d/elisp/stumpwm-mode.el new file mode 100644 index 0000000..0d5fa13 --- /dev/null +++ b/.emacs.d/elisp/stumpwm-mode.el @@ -0,0 +1,68 @@ +;;; stumpwm-mode.el --- special lisp mode for evaluating code into running stumpwm + +;; Copyright (C) 2007 Shawn Betts + +;; Maintainer: Shawn Betts +;; Keywords: comm, lisp, tools + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; load this file, set stumpwm-shell-program to point to stumpish and +;; run M-x stumpwm-mode in your stumpwm lisp files. Now, you can +;; easily eval code into a running stumpwm using the regular bindings. + +;;; Code: + +(defvar stumpwm-shell-program "stumpish" + "program name, including path if needed, for the stumpish program.") + +(define-minor-mode stumpwm-mode + "add some bindings to eval code into a running stumpwm using stumpish." + :global nil + :lighter " StumpWM" + :keymap (let ((m (make-sparse-keymap))) + (define-key m (kbd "C-M-x") 'stumpwm-eval-defun) + (define-key m (kbd "C-x C-e") 'stumpwm-eval-last-sexp) + m)) + +(defun stumpwm-eval-region (start end) + (interactive "r") + (let ((s (buffer-substring-no-properties start end))) + (message "%s" + (with-temp-buffer + (call-process stumpwm-shell-program nil (current-buffer) nil + "eval" + s) + (delete-char -1) + (buffer-string))))) + +(defun stumpwm-eval-defun () + (interactive) + (save-excursion + (end-of-defun) + (skip-chars-backward " \t\n\r\f") + (let ((end (point))) + (beginning-of-defun) + (stumpwm-eval-region (point) end)))) + +(defun stumpwm-eval-last-sexp () + (interactive) + (stumpwm-eval-region (save-excursion (backward-sexp) (point)) (point))) + +(provide 'stumpwm-mode) +;;; stumpwm-mode.el ends here diff --git a/.emacs.d/elisp/tabbar.el b/.emacs.d/elisp/tabbar.el new file mode 100644 index 0000000..09db712 --- /dev/null +++ b/.emacs.d/elisp/tabbar.el @@ -0,0 +1,1932 @@ +;;; Tabbar.el --- Display a tab bar in the header line + +;; Copyright (C) 2003, 2004, 2005 David Ponce + +;; Author: David Ponce <david@dponce.com> +;; Maintainer: David Ponce <david@dponce.com> +;; Created: 25 February 2003 +;; Keywords: convenience +;; Revision: $Id: tabbar.el,v 1.69 2006/06/08 08:27:39 ponced Exp $ + +(defconst tabbar-version "2.0") + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth +;; Floor, Boston, MA 02110-1301, USA. + +;;; Commentary: +;; +;; This library provides the Tabbar global minor mode to display a tab +;; bar in the header line of Emacs 21 and later versions. You can use +;; the mouse to click on a tab and select it. Also, three buttons are +;; displayed on the left side of the tab bar in this order: the +;; "home", "scroll left", and "scroll right" buttons. The "home" +;; button is a general purpose button used to change something on the +;; tab bar. The scroll left and scroll right buttons are used to +;; scroll tabs horizontally. Tabs can be divided up into groups to +;; maintain several sets of tabs at the same time (see also the +;; chapter "Core" below for more details on tab grouping). Only one +;; group is displayed on the tab bar, and the "home" button, for +;; example, can be used to navigate through the different groups, to +;; show different tab bars. +;; +;; In a graphic environment, using the mouse is probably the preferred +;; way to work with the tab bar. However, you can also use the tab +;; bar when Emacs is running on a terminal, so it is possible to use +;; commands to press special buttons, or to navigate cyclically +;; through tabs. +;; +;; These commands, and default keyboard shortcuts, are provided: +;; +;; `tabbar-mode' +;; Toggle the Tabbar global minor mode. When enabled a tab bar is +;; displayed in the header line. +;; +;; `tabbar-local-mode' (C-c <C-f10>) +;; Toggle the Tabbar-Local minor mode. Provided the global minor +;; mode is turned on, the tab bar becomes local in the current +;; buffer when the local minor mode is enabled. This permits to +;; see the tab bar in a buffer where the header line is already +;; used by another mode (like `Info-mode' for example). +;; +;; `tabbar-mwheel-mode' +;; Toggle the Tabbar-Mwheel global minor mode. When enabled you +;; can use the mouse wheel to navigate through tabs of groups. +;; +;; `tabbar-press-home' (C-c <C-home>) +;; `tabbar-press-scroll-left' (C-c <C-prior>) +;; `tabbar-press-scroll-right' (C-c <C-next>) +;; Simulate a mouse-1 click on respectively the "home", "scroll +;; left", and "scroll right" buttons. A numeric prefix argument +;; value of 2, or 3, respectively simulates a mouse-2, or mouse-3 +;; click. +;; +;; `tabbar-backward' (C-c <C-left>) +;; `tabbar-forward' (C-c <C-right>) +;; Are the basic commands to navigate cyclically through tabs or +;; groups of tabs. The cycle is controlled by the +;; `tabbar-cycle-scope' option. The default is to navigate +;; through all tabs across all existing groups of tabs. You can +;; change the default behavior to navigate only through the tabs +;; visible on the tab bar, or through groups of tabs only. Or use +;; the more specialized commands below. +;; +;; `tabbar-backward-tab' +;; `tabbar-forward-tab' +;; Navigate through the tabs visible on the tab bar. +;; +;; `tabbar-backward-group' (C-c <C-up>) +;; `tabbar-forward-group' (C-c <C-down>) +;; Navigate through existing groups of tabs. +;; +;; +;; Core +;; ---- +;; +;; The content of the tab bar is represented by an internal data +;; structure: a tab set. A tab set is a collection (group) of tabs, +;; identified by an unique name. In a tab set, at any time, one and +;; only one tab is designated as selected within the tab set. +;; +;; A tab is a simple data structure giving the value of the tab, and a +;; reference to its tab set container. A tab value can be any Lisp +;; object. Each tab object is guaranteed to be unique. +;; +;; A tab set is displayed on the tab bar through a "view" defined by +;; the index of the leftmost tab shown. Thus, it is possible to +;; scroll the tab bar horizontally by changing the start index of the +;; tab set view. +;; +;; The visual representation of a tab bar is a list of valid +;; `header-line-format' template elements, one for each special +;; button, and for each tab found into a tab set "view". When the +;; visual representation of a tab is required, the function specified +;; in the variable `tabbar-tab-label-function' is called to obtain it. +;; The visual representation of a special button is obtained by +;; calling the function specified in `tabbar-button-label-function', +;; which is passed a button name among `home', `scroll-left', or +;; `scroll-right'. There are also options and faces to customize the +;; appearance of buttons and tabs (see the code for more details). +;; +;; When the mouse is over a tab, the function specified in +;; `tabbar-help-on-tab-function' is called, which is passed the tab +;; and should return a help string to display. When a tab is +;; selected, the function specified in `tabbar-select-tab-function' is +;; called, which is passed the tab and the event received. +;; +;; Similarly, to control the behavior of the special buttons, the +;; following variables are available, for respectively the `home', +;; `scroll-left' and `scroll-right' value of `<button>': +;; +;; `tabbar-<button>-function' +;; Function called when <button> is selected. The function is +;; passed the mouse event received. +;; +;; `tabbar-<button>-help-function' +;; Function called with no arguments to obtain a help string +;; displayed when the mouse is over <button>. +;; +;; To increase performance, each tab set automatically maintains its +;; visual representation in a cache. As far as possible, the cache is +;; used to display the tab set, and refreshed only when necessary. +;; +;; Several tab sets can be maintained at the same time. Only one is +;; displayed on the tab bar, it is obtained by calling the function +;; specified in the variable `tabbar-current-tabset-function'. +;; +;; A special tab set is maintained, that contains the list of the +;; currently selected tabs in the existing tab sets. This tab set is +;; useful to show the existing tab sets in a tab bar, and switch +;; between them easily. The function `tabbar-get-tabsets-tabset' +;; returns this special tab set. +;; +;; +;; Buffer tabs +;; ----------- +;; +;; The default tab bar implementation provided displays buffers in +;; dedicated tabs. Selecting a tab, switch (mouse-1), or pop +;; (mouse-2), to the buffer it contains. +;; +;; The list of buffers put in tabs is provided by the function +;; specified in the variable `tabbar-buffer-list-function'. The +;; default function: `tabbar-buffer-list', excludes buffers whose name +;; starts with a space, when they are not visiting a file. +;; +;; Buffers are organized in groups, each one represented by a tab set. +;; A buffer can have no group, or belong to more than one group. The +;; function specified by the variable `tabbar-buffer-groups-function' +;; is called for each buffer to obtain the groups it belongs to. The +;; default function provided: `tabbar-buffer-groups' organizes buffers +;; depending on their major mode (see that function for details). +;; +;; The "home" button toggles display of buffer groups on the tab bar, +;; allowing to easily show another buffer group by clicking on the +;; associated tab. +;; +;; Known problems: +;; +;; Bug item #858306 at <http://sf.net/tracker/?group_id=79309>: +;; tabbar-mode crashes GNU Emacs 21.3 on MS-Windows 98/95. +;; + +;;; History: +;; + +;;; Code: + +;;; Options +;; +(defgroup tabbar nil + "Display a tab bar in the header line." + :group 'convenience) + +(defcustom tabbar-cycle-scope nil + "*Specify the scope of cyclic navigation through tabs. +The following scopes are possible: + +- `tabs' + Navigate through visible tabs only. +- `groups' + Navigate through tab groups only. +- default + Navigate through visible tabs, then through tab groups." + :group 'tabbar + :type '(choice :tag "Cycle through..." + (const :tag "Visible Tabs Only" tabs) + (const :tag "Tab Groups Only" groups) + (const :tag "Visible Tabs then Tab Groups" nil))) + +(defcustom tabbar-auto-scroll-flag t + "*Non-nil means to automatically scroll the tab bar. +That is, when a tab is selected outside of the tab bar visible area, +the tab bar is scrolled horizontally so the selected tab becomes +visible." + :group 'tabbar + :type 'boolean) + +(defvar tabbar-inhibit-functions '(tabbar-default-inhibit-function) + "List of functions to be called before displaying the tab bar. +Those functions are called one by one, with no arguments, until one of +them returns a non-nil value, and thus, prevents to display the tab +bar.") + +(defvar tabbar-current-tabset-function nil + "Function called with no argument to obtain the current tab set. +This is the tab set displayed on the tab bar.") + +(defvar tabbar-tab-label-function nil + "Function that obtains a tab label displayed on the tab bar. +The function is passed a tab and should return a string.") + +(defvar tabbar-select-tab-function nil + "Function that select a tab. +The function is passed a mouse event and a tab, and should make it the +selected tab.") + +(defvar tabbar-help-on-tab-function nil + "Function to obtain a help string for a tab. +The help string is displayed when the mouse is onto the button. The +function is passed the tab and should return a help string or nil for +none.") + +(defvar tabbar-button-label-function nil + "Function that obtains a button label displayed on the tab bar. +The function is passed a button name should return a propertized +string to display.") + +(defvar tabbar-home-function nil + "Function called when clicking on the tab bar home button. +The function is passed the mouse event received.") + +(defvar tabbar-home-help-function nil + "Function to obtain a help string for the tab bar home button. +The help string is displayed when the mouse is onto the button. +The function is called with no arguments.") + +(defvar tabbar-scroll-left-function 'tabbar-scroll-left + "Function that scrolls tabs on left. +The function is passed the mouse event received when clicking on the +scroll left button. It should scroll the current tab set.") + +(defvar tabbar-scroll-left-help-function 'tabbar-scroll-left-help + "Function to obtain a help string for the scroll left button. +The help string is displayed when the mouse is onto the button. +The function is called with no arguments.") + +(defvar tabbar-scroll-right-function 'tabbar-scroll-right + "Function that scrolls tabs on right. +The function is passed the mouse event received when clicking on the +scroll right button. It should scroll the current tab set.") + +(defvar tabbar-scroll-right-help-function 'tabbar-scroll-right-help + "Function to obtain a help string for the scroll right button. +The help string is displayed when the mouse is onto the button. +The function is called with no arguments.") + +;;; Misc. +;; +(eval-and-compile + (defalias 'tabbar-display-update + (if (fboundp 'force-window-update) + #'(lambda () (force-window-update (selected-window))) + 'force-mode-line-update))) + +(defsubst tabbar-click-p (event) + "Return non-nil if EVENT is a mouse click event." + (memq 'click (event-modifiers event))) + +(defun tabbar-shorten (str width) + "Return a shortened string from STR that fits in the given display WIDTH. +WIDTH is specified in terms of character display width in the current +buffer; see also `char-width'. If STR display width is greater than +WIDTH, STR is truncated and an ellipsis string \"...\" is inserted at +end or in the middle of the returned string, depending on available +room." + (let* ((n (length str)) + (sw (string-width str)) + (el "...") + (ew (string-width el)) + (w 0) + (i 0)) + (cond + ;; STR fit in WIDTH, return it. + ((<= sw width) + str) + ;; There isn't enough room for the ellipsis, STR is just + ;; truncated to fit in WIDTH. + ((<= width ew) + (while (< w width) + (setq w (+ w (char-width (aref str i))) + i (1+ i))) + (substring str 0 i)) + ;; There isn't enough room to insert the ellipsis in the middle + ;; of the truncated string, so put the ellipsis at end. + ((zerop (setq sw (/ (- width ew) 2))) + (setq width (- width ew)) + (while (< w width) + (setq w (+ w (char-width (aref str i))) + i (1+ i))) + (concat (substring str 0 i) el)) + ;; Put the ellipsis in the middle of the truncated string. + (t + (while (< w sw) + (setq w (+ w (char-width (aref str i))) + i (1+ i))) + (setq w (+ w ew)) + (while (< w width) + (setq n (1- n) + w (+ w (char-width (aref str n))))) + (concat (substring str 0 i) el (substring str n))) + ))) + +;;; Tab and tab set +;; +(defsubst tabbar-make-tab (object tabset) + "Return a new tab with value OBJECT. +TABSET is the tab set the tab belongs to." + (cons object tabset)) + +(defsubst tabbar-tab-value (tab) + "Return the value of tab TAB." + (car tab)) + +(defsubst tabbar-tab-tabset (tab) + "Return the tab set TAB belongs to." + (cdr tab)) + +(defvar tabbar-tabsets nil + "The tab sets store.") + +(defvar tabbar-tabsets-tabset nil + "The special tab set of existing tab sets.") + +(defvar tabbar-current-tabset nil + "The tab set currently displayed on the tab bar.") +(make-variable-buffer-local 'tabbar-current-tabset) + +(defvar tabbar-init-hook nil + "Hook run after tab bar data has been initialized. +You should use this hook to initialize dependent data.") + +(defsubst tabbar-init-tabsets-store () + "Initialize the tab set store." + (setq tabbar-tabsets (make-vector 31 0) + tabbar-tabsets-tabset (make-symbol "tabbar-tabsets-tabset")) + (put tabbar-tabsets-tabset 'start 0) + (run-hooks 'tabbar-init-hook)) + +(defvar tabbar-quit-hook nil + "Hook run after tab bar data has been freed. +You should use this hook to reset dependent data.") + +(defsubst tabbar-free-tabsets-store () + "Free the tab set store." + (setq tabbar-tabsets nil + tabbar-tabsets-tabset nil) + (run-hooks 'tabbar-quit-hook)) + +;; Define an "hygienic" function free of side effect between its local +;; variables and those of the callee. +(eval-and-compile + (defalias 'tabbar-map-tabsets + (let ((function (make-symbol "function")) + (result (make-symbol "result")) + (tabset (make-symbol "tabset"))) + `(lambda (,function) + "Apply FUNCTION to each tab set, and make a list of the results. +The result is a list just as long as the number of existing tab sets." + (let (,result) + (mapatoms + #'(lambda (,tabset) + (push (funcall ,function ,tabset) ,result)) + tabbar-tabsets) + ,result))))) + +(defun tabbar-make-tabset (name &rest objects) + "Make a new tab set whose name is the string NAME. +It is initialized with tabs build from the list of OBJECTS." + (let* ((tabset (intern name tabbar-tabsets)) + (tabs (mapcar #'(lambda (object) + (tabbar-make-tab object tabset)) + objects))) + (set tabset tabs) + (put tabset 'select (car tabs)) + (put tabset 'start 0) + tabset)) + +(defsubst tabbar-get-tabset (name) + "Return the tab set whose name is the string NAME. +Return nil if not found." + (intern-soft name tabbar-tabsets)) + +(defsubst tabbar-delete-tabset (tabset) + "Delete the tab set TABSET. +That is, remove it from the tab sets store." + (unintern tabset tabbar-tabsets)) + +(defsubst tabbar-tabs (tabset) + "Return the list of tabs in TABSET." + (symbol-value tabset)) + +(defsubst tabbar-tab-values (tabset) + "Return the list of tab values in TABSET." + (mapcar 'tabbar-tab-value (tabbar-tabs tabset))) + +(defsubst tabbar-get-tab (object tabset) + "Search for a tab with value OBJECT in TABSET. +Return the tab found, or nil if not found." + (assoc object (tabbar-tabs tabset))) + +(defsubst tabbar-member (tab tabset) + "Return non-nil if TAB is in TABSET." + (or (eq (tabbar-tab-tabset tab) tabset) + (memq tab (tabbar-tabs tabset)))) + +(defsubst tabbar-template (tabset) + "Return the cached visual representation of TABSET. +That is, a `header-line-format' template, or nil if the cache is +empty." + (get tabset 'template)) + +(defsubst tabbar-set-template (tabset template) + "Set the cached visual representation of TABSET to TEMPLATE. +TEMPLATE must be a valid `header-line-format' template, or nil to +cleanup the cache." + (put tabset 'template template)) + +(defsubst tabbar-selected-tab (tabset) + "Return the tab selected in TABSET." + (get tabset 'select)) + +(defsubst tabbar-selected-value (tabset) + "Return the value of the tab selected in TABSET." + (tabbar-tab-value (tabbar-selected-tab tabset))) + +(defsubst tabbar-selected-p (tab tabset) + "Return non-nil if TAB is the selected tab in TABSET." + (eq tab (tabbar-selected-tab tabset))) + +(defvar tabbar--track-selected nil) + +(defsubst tabbar-select-tab (tab tabset) + "Make TAB the selected tab in TABSET. +Does nothing if TAB is not found in TABSET. +Return TAB if selected, nil if not." + (when (tabbar-member tab tabset) + (unless (tabbar-selected-p tab tabset) + (tabbar-set-template tabset nil) + (setq tabbar--track-selected tabbar-auto-scroll-flag)) + (put tabset 'select tab))) + +(defsubst tabbar-select-tab-value (object tabset) + "Make the tab with value OBJECT, the selected tab in TABSET. +Does nothing if a tab with value OBJECT is not found in TABSET. +Return the tab selected, or nil if nothing was selected." + (tabbar-select-tab (tabbar-get-tab object tabset) tabset)) + +(defsubst tabbar-start (tabset) + "Return the index of the first visible tab in TABSET." + (get tabset 'start)) + +(defsubst tabbar-view (tabset) + "Return the list of visible tabs in TABSET. +That is, the sub-list of tabs starting at the first visible one." + (nthcdr (tabbar-start tabset) (tabbar-tabs tabset))) + +(defun tabbar-add-tab (tabset object &optional append) + "Add to TABSET a tab with value OBJECT if there isn't one there yet. +If the tab is added, it is added at the beginning of the tab list, +unless the optional argument APPEND is non-nil, in which case it is +added at the end." + (let ((tabs (tabbar-tabs tabset))) + (if (tabbar-get-tab object tabset) + tabs + (let ((tab (tabbar-make-tab object tabset))) + (tabbar-set-template tabset nil) + (set tabset (if append + (append tabs (list tab)) + (cons tab tabs))))))) + +(defun tabbar-delete-tab (tab) + "Remove TAB from its tab set." + (let* ((tabset (tabbar-tab-tabset tab)) + (tabs (tabbar-tabs tabset)) + (sel (eq tab (tabbar-selected-tab tabset))) + (next (and sel (cdr (memq tab tabs))))) + (tabbar-set-template tabset nil) + (setq tabs (delq tab tabs)) + ;; When the selected tab is deleted, select the next one, if + ;; available, or the last one otherwise. + (and sel (tabbar-select-tab (car (or next (last tabs))) tabset)) + (set tabset tabs))) + +(defun tabbar-scroll (tabset count) + "Scroll the visible tabs in TABSET of COUNT units. +If COUNT is positive move the view on right. If COUNT is negative, +move the view on left." + (let ((start (min (max 0 (+ (tabbar-start tabset) count)) + (1- (length (tabbar-tabs tabset)))))) + (when (/= start (tabbar-start tabset)) + (tabbar-set-template tabset nil) + (put tabset 'start start)))) + +(defun tabbar-tab-next (tabset tab &optional before) + "Search in TABSET for the tab after TAB. +If optional argument BEFORE is non-nil, search for the tab before +TAB. Return the tab found, or nil otherwise." + (let* (last (tabs (tabbar-tabs tabset))) + (while (and tabs (not (eq tab (car tabs)))) + (setq last (car tabs) + tabs (cdr tabs))) + (and tabs (if before last (nth 1 tabs))))) + +(defun tabbar-current-tabset (&optional update) + "Return the tab set currently displayed on the tab bar. +If optional argument UPDATE is non-nil, call the user defined function +`tabbar-current-tabset-function' to obtain it. Otherwise return the +current cached copy." + (and update tabbar-current-tabset-function + (setq tabbar-current-tabset + (funcall tabbar-current-tabset-function))) + tabbar-current-tabset) + +(defun tabbar-get-tabsets-tabset () + "Return the tab set of selected tabs in existing tab sets." + (set tabbar-tabsets-tabset (tabbar-map-tabsets 'tabbar-selected-tab)) + (tabbar-scroll tabbar-tabsets-tabset 0) + (tabbar-set-template tabbar-tabsets-tabset nil) + tabbar-tabsets-tabset) + +;;; Faces +;; +(defface tabbar-default + '( + ;;(((class color grayscale) (background light)) + ;; :inherit variable-pitch + ;; :height 0.8 + ;; :foreground "gray50" + ;; :background "grey75" + ;; ) + (((class color grayscale) (background dark)) + :inherit variable-pitch + :height 0.8 + :foreground "grey75" + :background "gray50" + ) + (((class mono) (background light)) + :inherit variable-pitch + :height 0.8 + :foreground "black" + :background "white" + ) + (((class mono) (background dark)) + :inherit variable-pitch + :height 0.8 + :foreground "white" + :background "black" + ) + (t + :inherit variable-pitch + :height 0.8 + :foreground "gray50" + :background "gray75" + )) + "Default face used in the tab bar." + :group 'tabbar) + +(defface tabbar-unselected + '((t + :inherit tabbar-default + :box (:line-width 1 :color "white" :style released-button) + )) + "Face used for unselected tabs." + :group 'tabbar) + +(defface tabbar-selected + '((t + :inherit tabbar-default + :box (:line-width 1 :color "white" :style pressed-button) + :foreground "blue" + )) + "Face used for the selected tab." + :group 'tabbar) + +(defface tabbar-highlight + '((t + :underline t + )) + "Face used to highlight a tab during mouse-overs." + :group 'tabbar) + +(defface tabbar-separator + '((t + :inherit tabbar-default + :height 0.1 + )) + "Face used for separators between tabs." + :group 'tabbar) + +(defface tabbar-button + '((t + :inherit tabbar-default + :box (:line-width 1 :color "white" :style released-button) + :foreground "dark red" + )) + "Face used for tab bar buttons." + :group 'tabbar) + +(defface tabbar-button-highlight + '((t + :inherit tabbar-default + )) + "Face used to highlight a button during mouse-overs." + :group 'tabbar) + +(defcustom tabbar-background-color nil + "*Background color of the tab bar. +By default, use the background color specified for the +`tabbar-default' face (or inherited from another face), or the +background color of the `default' face otherwise." + :group 'tabbar + :type '(choice (const :tag "Default" nil) + (color))) + +(defsubst tabbar-background-color () + "Return the background color of the tab bar." + (or tabbar-background-color + (let* ((face 'tabbar-default) + (color (face-background face))) + (while (null color) + (or (facep (setq face (face-attribute face :inherit))) + (setq face 'default)) + (setq color (face-background face))) + color))) + +;;; Buttons and separator look and feel +;; +(defconst tabbar-button-widget + '(cons + (cons :tag "Enabled" + (string) + (repeat :tag "Image" + :extra-offset 2 + (restricted-sexp :tag "Spec" + :match-alternatives (listp)))) + (cons :tag "Disabled" + (string) + (repeat :tag "Image" + :extra-offset 2 + (restricted-sexp :tag "Spec" + :match-alternatives (listp)))) + ) + "Widget for editing a tab bar button. +A button is specified as a pair (ENABLED-BUTTON . DISABLED-BUTTON), +where ENABLED-BUTTON and DISABLED-BUTTON specify the value used when +the button is respectively enabled and disabled. Each button value is +a pair (STRING . IMAGE) where STRING is a string value, and IMAGE a +list of image specifications. +If IMAGE is non-nil, try to use that image, else use STRING. +If only the ENABLED-BUTTON image is provided, a DISABLED-BUTTON image +is derived from it.") + +;;; Home button +;; +(defvar tabbar-home-button-value nil + "Value of the home button.") + +(defconst tabbar-home-button-enabled-image + '((:type pbm :data "\ +P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 0 +6 0 255 255 255 255 255 255 255 255 255 255 9 130 9 255 255 255 255 +255 255 255 255 255 255 26 130 26 255 255 255 255 255 255 255 0 9 26 +41 130 41 26 9 0 255 255 255 255 5 145 140 135 130 125 120 115 5 255 +255 255 255 0 9 26 41 130 41 26 9 0 255 255 255 255 255 255 255 26 130 +26 255 255 255 255 255 255 255 255 255 255 9 130 9 255 255 255 255 255 +255 255 255 255 255 0 6 0 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 +")) + "Default image for the enabled home button.") + +(defconst tabbar-home-button-disabled-image + '((:type pbm :data "\ +P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 0 0 1 2 3 2 1 0 0 255 255 255 255 0 132 128 123 119 114 110 +106 0 255 255 255 255 0 0 1 2 3 2 1 0 0 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 255 +")) + "Default image for the disabled home button.") + +(defcustom tabbar-home-button + (cons (cons "[o]" tabbar-home-button-enabled-image) + (cons "[x]" tabbar-home-button-disabled-image)) + "The home button. +The variable `tabbar-button-widget' gives details on this widget." + :group 'tabbar + :type tabbar-button-widget + :set '(lambda (variable value) + (custom-set-default variable value) + ;; Schedule refresh of button value. + (setq tabbar-home-button-value nil))) + +;;; Scroll left button +;; +(defvar tabbar-scroll-left-button-value nil + "Value of the scroll left button.") + +(defconst tabbar-scroll-left-button-enabled-image + '((:type pbm :data "\ +P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 128 16 48 255 255 255 255 255 255 255 +255 144 28 86 128 0 255 255 255 255 255 255 160 44 92 159 135 113 0 +255 255 255 255 160 44 97 165 144 129 120 117 0 255 255 176 44 98 175 +174 146 127 126 127 128 0 255 255 0 160 184 156 143 136 134 135 137 +138 0 255 255 176 32 67 144 146 144 145 146 148 149 0 255 255 255 255 +160 42 75 140 154 158 159 160 0 255 255 255 255 255 255 160 40 74 154 +170 171 0 255 255 255 255 255 255 255 255 160 41 82 163 0 255 255 255 +255 255 255 255 255 255 255 160 32 48 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 +")) + "Default image for the enabled scroll left button. +A disabled button image will be automatically build from it.") + +(defcustom tabbar-scroll-left-button + (cons (cons " <" tabbar-scroll-left-button-enabled-image) + (cons " =" nil)) + "The scroll left button. +The variable `tabbar-button-widget' gives details on this widget." + :group 'tabbar + :type tabbar-button-widget + :set '(lambda (variable value) + (custom-set-default variable value) + ;; Schedule refresh of button value. + (setq tabbar-scroll-left-button-value nil))) + +;;; Scroll right button +;; +(defvar tabbar-scroll-right-button-value nil + "Value of the scroll right button.") + +(defconst tabbar-scroll-right-button-enabled-image + '((:type pbm :data "\ +P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +48 32 160 255 255 255 255 255 255 255 255 255 255 44 161 71 32 160 255 +255 255 255 255 255 255 255 36 157 163 145 62 32 160 255 255 255 255 +255 255 30 128 133 137 142 124 50 32 160 255 255 255 255 29 120 121 +124 126 126 124 105 42 32 176 255 255 31 126 127 128 128 128 128 126 +124 89 32 255 255 33 134 135 136 137 137 138 119 49 32 176 255 255 34 +143 144 145 146 128 54 32 160 255 255 255 255 36 152 153 134 57 32 160 +255 255 255 255 255 255 38 141 60 32 160 255 255 255 255 255 255 255 +255 48 32 160 255 255 255 255 255 255 255 255 255 255 255 255 255 255 +255 255 255 255 255 255 255 255 +")) + "Default image for the enabled scroll right button. +A disabled button image will be automatically build from it.") + +(defcustom tabbar-scroll-right-button + (cons (cons " >" tabbar-scroll-right-button-enabled-image) + (cons " =" nil)) + "The scroll right button. +The variable `tabbar-button-widget' gives details on this widget." + :group 'tabbar + :type tabbar-button-widget + :set '(lambda (variable value) + (custom-set-default variable value) + ;; Schedule refresh of button value. + (setq tabbar-scroll-right-button-value nil))) + +;;; Separator +;; +(defconst tabbar-separator-widget + '(cons (choice (string) + (number :tag "Space width" 0.2)) + (repeat :tag "Image" + :extra-offset 2 + (restricted-sexp :tag "Spec" + :match-alternatives (listp)))) + "Widget for editing a tab bar separator. +A separator is specified as a pair (STRING-OR-WIDTH . IMAGE) where +STRING-OR-WIDTH is a string value or a space width, and IMAGE a list +of image specifications. +If IMAGE is non-nil, try to use that image, else use STRING-OR-WIDTH. +The value (\"\"), or (0) hide separators.") + +(defvar tabbar-separator-value nil + "Value of the separator used between tabs.") + +(defcustom tabbar-separator (list 0.2) + "Separator used between tabs. +The variable `tabbar-separator-widget' gives details on this widget." + :group 'tabbar + :type tabbar-separator-widget + :set '(lambda (variable value) + (custom-set-default variable value) + ;; Schedule refresh of separator value. + (setq tabbar-separator-value nil))) + +;;; Images +;; +(defcustom tabbar-use-images t + "*Non-nil means to try to use images in tab bar. +That is for buttons and separators." + :group 'tabbar + :type 'boolean + :set '(lambda (variable value) + (custom-set-default variable value) + ;; Schedule refresh of all buttons and separator values. + (setq tabbar-separator-value nil + tabbar-home-button-value nil + tabbar-scroll-left-button-value nil + tabbar-scroll-right-button-value nil))) + +(defsubst tabbar-find-image (specs) + "Find an image, choosing one of a list of image specifications. +SPECS is a list of image specifications. See also `find-image'." + (when (and tabbar-use-images (display-images-p)) + (condition-case nil + (find-image specs) + (error nil)))) + +(defsubst tabbar-disable-image (image) + "From IMAGE, return a new image which looks disabled." + (setq image (copy-sequence image)) + (setcdr image (plist-put (cdr image) :conversion 'disabled)) + image) + +(defsubst tabbar-normalize-image (image &optional margin) + "Make IMAGE centered and transparent. +If optional MARGIN is non-nil, it must be a number of pixels to add as +an extra margin around the image." + (let ((plist (cdr image))) + (or (plist-get plist :ascent) + (setq plist (plist-put plist :ascent 'center))) + (or (plist-get plist :mask) + (setq plist (plist-put plist :mask '(heuristic t)))) + (or (not (natnump margin)) + (plist-get plist :margin) + (plist-put plist :margin margin)) + (setcdr image plist)) + image) + +;;; Button keymaps and callbacks +;; +(defun tabbar-make-mouse-keymap (callback) + "Return a keymap that call CALLBACK on mouse events. +CALLBACK is passed the received mouse event." + (let ((keymap (make-sparse-keymap))) + ;; Pass mouse-1, mouse-2 and mouse-3 events to CALLBACK. + (define-key keymap [header-line down-mouse-1] 'ignore) + (define-key keymap [header-line mouse-1] callback) + (define-key keymap [header-line down-mouse-2] 'ignore) + (define-key keymap [header-line mouse-2] callback) + (define-key keymap [header-line down-mouse-3] 'ignore) + (define-key keymap [header-line mouse-3] callback) + keymap)) + +(defsubst tabbar-make-mouse-event (&optional type) + "Return a mouse click event. +Optional argument TYPE is a mouse-click event or one of the +symbols `mouse-1', `mouse-2' or `mouse-3'. +The default is `mouse-1'." + (if (tabbar-click-p type) + type + (list (or (memq type '(mouse-2 mouse-3)) 'mouse-1) + (or (event-start nil) ;; Emacs 21.4 + (list (selected-window) (point) '(0 . 0) 0))))) + +;;; Buttons +;; +(defconst tabbar-default-button-keymap + (tabbar-make-mouse-keymap 'tabbar-select-button-callback) + "Default keymap of a button.") + +(defun tabbar-help-on-button (window object position) + "Return a help string or nil for none, for the button under the mouse. +WINDOW is the window in which the help was found (unused). +OBJECT is the button label under the mouse. +POSITION is the position in that label. +Call `tabbar-NAME-help-function' where NAME is the button name +associated to OBJECT." + (let* ((name (get-text-property position 'tabbar-button object)) + (funvar (and name + (intern-soft (format "tabbar-%s-help-function" + name))))) + (and (symbol-value funvar) + (funcall (symbol-value funvar))))) + +(defsubst tabbar-click-on-button (name &optional type) + "Handle a mouse click event on button NAME. +Call `tabbar-select-NAME-function' with the received, or simulated +mouse click event. +Optional argument TYPE is a mouse click event type (see the function +`tabbar-make-mouse-event' for details)." + (let ((funvar (intern-soft (format "tabbar-%s-function" name)))) + (when (symbol-value funvar) + (funcall (symbol-value funvar) (tabbar-make-mouse-event type)) + (tabbar-display-update)))) + +(defun tabbar-select-button-callback (event) + "Handle a mouse EVENT on a button. +Pass mouse click events on a button to `tabbar-click-on-button'." + (interactive "@e") + (when (tabbar-click-p event) + (let ((target (posn-string (event-start event)))) + (tabbar-click-on-button + (get-text-property (cdr target) 'tabbar-button (car target)) + event)))) + +(defun tabbar-make-button-keymap (name) + "Return a keymap to handle mouse click events on button NAME." + (if (fboundp 'posn-string) + tabbar-default-button-keymap + (let ((event (make-symbol "event"))) + (tabbar-make-mouse-keymap + `(lambda (,event) + (interactive "@e") + (and (tabbar-click-p ,event) + (tabbar-click-on-button ',name ,event))))))) + +;;; Button callbacks +;; +(defun tabbar-scroll-left (event) + "On mouse EVENT, scroll current tab set on left." + (when (eq (event-basic-type event) 'mouse-1) + (tabbar-scroll (tabbar-current-tabset) -1))) + +(defun tabbar-scroll-left-help () + "Help string shown when mouse is over the scroll left button." + "mouse-1: scroll tabs left.") + +(defun tabbar-scroll-right (event) + "On mouse EVENT, scroll current tab set on right." + (when (eq (event-basic-type event) 'mouse-1) + (tabbar-scroll (tabbar-current-tabset) 1))) + +(defun tabbar-scroll-right-help () + "Help string shown when mouse is over the scroll right button." + "mouse-1: scroll tabs right.") + +;;; Tabs +;; +(defconst tabbar-default-tab-keymap + (tabbar-make-mouse-keymap 'tabbar-select-tab-callback) + "Default keymap of a tab.") + +(defun tabbar-help-on-tab (window object position) + "Return a help string or nil for none, for the tab under the mouse. +WINDOW is the window in which the help was found (unused). +OBJECT is the tab label under the mouse. +POSITION is the position in that label. +Call `tabbar-help-on-tab-function' with the associated tab." + (when tabbar-help-on-tab-function + (let ((tab (get-text-property position 'tabbar-tab object))) + (funcall tabbar-help-on-tab-function tab)))) + +(defsubst tabbar-click-on-tab (tab &optional type) + "Handle a mouse click event on tab TAB. +Call `tabbar-select-tab-function' with the received, or simulated +mouse click event, and TAB. +Optional argument TYPE is a mouse click event type (see the function +`tabbar-make-mouse-event' for details)." + (when tabbar-select-tab-function + (funcall tabbar-select-tab-function + (tabbar-make-mouse-event type) tab) + (tabbar-display-update))) + +(defun tabbar-select-tab-callback (event) + "Handle a mouse EVENT on a tab. +Pass mouse click events on a tab to `tabbar-click-on-tab'." + (interactive "@e") + (when (tabbar-click-p event) + (let ((target (posn-string (event-start event)))) + (tabbar-click-on-tab + (get-text-property (cdr target) 'tabbar-tab (car target)) + event)))) + +(defun tabbar-make-tab-keymap (tab) + "Return a keymap to handle mouse click events on TAB." + (if (fboundp 'posn-string) + tabbar-default-tab-keymap + (let ((event (make-symbol "event"))) + (tabbar-make-mouse-keymap + `(lambda (,event) + (interactive "@e") + (and (tabbar-click-p ,event) + (tabbar-click-on-tab ',tab ,event))))))) + +;;; Tab bar construction +;; +(defun tabbar-button-label (name) + "Return a label for button NAME. +That is a pair (ENABLED . DISABLED), where ENABLED and DISABLED are +respectively the appearance of the button when enabled and disabled. +They are propertized strings which could display images, as specified +by the variable `tabbar-NAME-button'." + (let* ((btn (symbol-value + (intern-soft (format "tabbar-%s-button" name)))) + (on (tabbar-find-image (cdar btn))) + (off (and on (tabbar-find-image (cddr btn))))) + (when on + (tabbar-normalize-image on 1) + (if off + (tabbar-normalize-image off 1) + ;; If there is no disabled button image, derive one from the + ;; button enabled image. + (setq off (tabbar-disable-image on)))) + (cons + (propertize (or (caar btn) " ") 'display on) + (propertize (or (cadr btn) " ") 'display off)))) + +(defun tabbar-line-button (name) + "Return the display representation of button NAME. +That is, a propertized string used as an `header-line-format' template +element." + (let ((label (if tabbar-button-label-function + (funcall tabbar-button-label-function name) + (cons name name)))) + ;; Cache the display value of the enabled/disabled buttons in + ;; variables `tabbar-NAME-button-value'. + (set (intern (format "tabbar-%s-button-value" name)) + (cons + (propertize (car label) + 'tabbar-button name + 'face 'tabbar-button + 'mouse-face 'tabbar-button-highlight + 'pointer 'hand + 'local-map (tabbar-make-button-keymap name) + 'help-echo 'tabbar-help-on-button) + (propertize (cdr label) + 'face 'tabbar-button + 'pointer 'arrow))))) + +(defun tabbar-line-separator () + "Return the display representation of a tab bar separator. +That is, a propertized string used as an `header-line-format' template +element." + (let ((image (tabbar-find-image (cdr tabbar-separator)))) + ;; Cache the separator display value in variable + ;; `tabbar-separator-value'. + (setq tabbar-separator-value + (cond + (image + (propertize " " + 'face 'tabbar-separator + 'pointer 'arrow + 'display (tabbar-normalize-image image))) + ((numberp (car tabbar-separator)) + (propertize " " + 'face 'tabbar-separator + 'pointer 'arrow + 'display (list 'space + :width (car tabbar-separator)))) + ((propertize (or (car tabbar-separator) " ") + 'face 'tabbar-separator + 'pointer 'arrow)))) + )) + +(defsubst tabbar-line-buttons (tabset) + "Return a list of propertized strings for tab bar buttons. +TABSET is the tab set used to choose the appropriate buttons." + (list + (if tabbar-home-function + (car tabbar-home-button-value) + (cdr tabbar-home-button-value)) + (if (> (tabbar-start tabset) 0) + (car tabbar-scroll-left-button-value) + (cdr tabbar-scroll-left-button-value)) + (if (< (tabbar-start tabset) + (1- (length (tabbar-tabs tabset)))) + (car tabbar-scroll-right-button-value) + (cdr tabbar-scroll-right-button-value)) + tabbar-separator-value)) + +(defsubst tabbar-line-tab (tab) + "Return the display representation of tab TAB. +That is, a propertized string used as an `header-line-format' template +element. +Call `tabbar-tab-label-function' to obtain a label for TAB." + (concat (propertize + (if tabbar-tab-label-function + (funcall tabbar-tab-label-function tab) + tab) + 'tabbar-tab tab + 'local-map (tabbar-make-tab-keymap tab) + 'help-echo 'tabbar-help-on-tab + 'mouse-face 'tabbar-highlight + 'face (if (tabbar-selected-p tab (tabbar-current-tabset)) + 'tabbar-selected + 'tabbar-unselected) + 'pointer 'hand) + tabbar-separator-value)) + +(defun tabbar-line-format (tabset) + "Return the `header-line-format' value to display TABSET." + (let* ((sel (tabbar-selected-tab tabset)) + (tabs (tabbar-view tabset)) + (padcolor (tabbar-background-color)) + atsel elts) + ;; Initialize buttons and separator values. + (or tabbar-separator-value + (tabbar-line-separator)) + (or tabbar-home-button-value + (tabbar-line-button 'home)) + (or tabbar-scroll-left-button-value + (tabbar-line-button 'scroll-left)) + (or tabbar-scroll-right-button-value + (tabbar-line-button 'scroll-right)) + ;; Track the selected tab to ensure it is always visible. + (when tabbar--track-selected + (while (not (memq sel tabs)) + (tabbar-scroll tabset -1) + (setq tabs (tabbar-view tabset))) + (while (and tabs (not atsel)) + (setq elts (cons (tabbar-line-tab (car tabs)) elts) + atsel (eq (car tabs) sel) + tabs (cdr tabs))) + (setq elts (nreverse elts)) + ;; At this point the selected tab is the last elt in ELTS. + ;; Scroll TABSET and ELTS until the selected tab becomes + ;; visible. + (with-temp-buffer + (let ((truncate-partial-width-windows nil) + (inhibit-modification-hooks t) + deactivate-mark ;; Prevent deactivation of the mark! + start) + (setq truncate-lines nil + buffer-undo-list t) + (apply 'insert (tabbar-line-buttons tabset)) + (setq start (point)) + (while (and (cdr elts) ;; Always show the selected tab! + (progn + (delete-region start (point-max)) + (goto-char (point-max)) + (apply 'insert elts) + (goto-char (point-min)) + (> (vertical-motion 1) 0))) + (tabbar-scroll tabset 1) + (setq elts (cdr elts))))) + (setq elts (nreverse elts)) + (setq tabbar--track-selected nil)) + ;; Format remaining tabs. + (while tabs + (setq elts (cons (tabbar-line-tab (car tabs)) elts) + tabs (cdr tabs))) + ;; Cache and return the new tab bar. + (tabbar-set-template + tabset + (list (tabbar-line-buttons tabset) + (nreverse elts) + (propertize "%-" + 'face (list :background padcolor + :foreground padcolor) + 'pointer 'arrow))) + )) + +(defun tabbar-line () + "Return the header line templates that represent the tab bar. +Inhibit display of the tab bar in current window if any of the +`tabbar-inhibit-functions' return non-nil." + (cond + ((run-hook-with-args-until-success 'tabbar-inhibit-functions) + ;; Don't show the tab bar. + (setq header-line-format nil)) + ((tabbar-current-tabset t) + ;; When available, use a cached tab bar value, else recompute it. + (or (tabbar-template tabbar-current-tabset) + (tabbar-line-format tabbar-current-tabset))))) + +(defconst tabbar-header-line-format '(:eval (tabbar-line)) + "The tab bar header line format.") + +(defun tabbar-default-inhibit-function () + "Inhibit display of the tab bar in specified windows. +That is dedicated windows, and `checkdoc' status windows." + (or (window-dedicated-p (selected-window)) + (member (buffer-name) + (list " *Checkdoc Status*" + (if (boundp 'ispell-choices-buffer) + ispell-choices-buffer + "*Choices*"))))) + +;;; Cyclic navigation through tabs +;; +(defun tabbar-cycle (&optional backward type) + "Cycle to the next available tab. +The scope of the cyclic navigation through tabs is specified by the +option `tabbar-cycle-scope'. +If optional argument BACKWARD is non-nil, cycle to the previous tab +instead. +Optional argument TYPE is a mouse event type (see the function +`tabbar-make-mouse-event' for details)." + (let* ((tabset (tabbar-current-tabset t)) + (ttabset (tabbar-get-tabsets-tabset)) + ;; If navigation through groups is requested, and there is + ;; only one group, navigate through visible tabs. + (cycle (if (and (eq tabbar-cycle-scope 'groups) + (not (cdr (tabbar-tabs ttabset)))) + 'tabs + tabbar-cycle-scope)) + selected tab) + (when tabset + (setq selected (tabbar-selected-tab tabset)) + (cond + ;; Cycle through visible tabs only. + ((eq cycle 'tabs) + (setq tab (tabbar-tab-next tabset selected backward)) + ;; When there is no tab after/before the selected one, cycle + ;; to the first/last visible tab. + (unless tab + (setq tabset (tabbar-tabs tabset) + tab (car (if backward (last tabset) tabset)))) + ) + ;; Cycle through tab groups only. + ((eq cycle 'groups) + (setq tab (tabbar-tab-next ttabset selected backward)) + ;; When there is no group after/before the selected one, cycle + ;; to the first/last available group. + (unless tab + (setq tabset (tabbar-tabs ttabset) + tab (car (if backward (last tabset) tabset)))) + ) + (t + ;; Cycle through visible tabs then tab groups. + (setq tab (tabbar-tab-next tabset selected backward)) + ;; When there is no visible tab after/before the selected one, + ;; cycle to the next/previous available group. + (unless tab + (setq tab (tabbar-tab-next ttabset selected backward)) + ;; When there is no next/previous group, cycle to the + ;; first/last available group. + (unless tab + (setq tabset (tabbar-tabs ttabset) + tab (car (if backward (last tabset) tabset)))) + ;; Select the first/last visible tab of the new group. + (setq tabset (tabbar-tabs (tabbar-tab-tabset tab)) + tab (car (if backward (last tabset) tabset)))) + )) + (tabbar-click-on-tab tab type)))) + +;;;###autoload +(defun tabbar-backward () + "Select the previous available tab. +Depend on the setting of the option `tabbar-cycle-scope'." + (interactive) + (tabbar-cycle t)) + +;;;###autoload +(defun tabbar-forward () + "Select the next available tab. +Depend on the setting of the option `tabbar-cycle-scope'." + (interactive) + (tabbar-cycle)) + +;;;###autoload +(defun tabbar-backward-group () + "Go to selected tab in the previous available group." + (interactive) + (let ((tabbar-cycle-scope 'groups)) + (tabbar-cycle t))) + +;;;###autoload +(defun tabbar-forward-group () + "Go to selected tab in the next available group." + (interactive) + (let ((tabbar-cycle-scope 'groups)) + (tabbar-cycle))) + +;;;###autoload +(defun tabbar-backward-tab () + "Select the previous visible tab." + (interactive) + (let ((tabbar-cycle-scope 'tabs)) + (tabbar-cycle t))) + +;;;###autoload +(defun tabbar-forward-tab () + "Select the next visible tab." + (interactive) + (let ((tabbar-cycle-scope 'tabs)) + (tabbar-cycle))) + +;;; Button press commands +;; +(defsubst tabbar--mouse (number) + "Return a mouse button symbol from NUMBER. +That is mouse-2, or mouse-3 when NUMBER is respectively 2, or 3. +Return mouse-1 otherwise." + (cond ((eq number 2) 'mouse-2) + ((eq number 3) 'mouse-3) + ('mouse-1))) + +;;;###autoload +(defun tabbar-press-home (&optional arg) + "Press the tab bar home button. +That is, simulate a mouse click on that button. +A numeric prefix ARG value of 2, or 3, respectively simulates a +mouse-2, or mouse-3 click. The default is a mouse-1 click." + (interactive "p") + (tabbar-click-on-button 'home (tabbar--mouse arg))) + +;;;###autoload +(defun tabbar-press-scroll-left (&optional arg) + "Press the tab bar scroll-left button. +That is, simulate a mouse click on that button. +A numeric prefix ARG value of 2, or 3, respectively simulates a +mouse-2, or mouse-3 click. The default is a mouse-1 click." + (interactive "p") + (tabbar-click-on-button 'scroll-left (tabbar--mouse arg))) + +;;;###autoload +(defun tabbar-press-scroll-right (&optional arg) + "Press the tab bar scroll-right button. +That is, simulate a mouse click on that button. +A numeric prefix ARG value of 2, or 3, respectively simulates a +mouse-2, or mouse-3 click. The default is a mouse-1 click." + (interactive "p") + (tabbar-click-on-button 'scroll-right (tabbar--mouse arg))) + +;;; Mouse-wheel support +;; +(require 'mwheel) + +;;; Compatibility +;; +(defconst tabbar--mwheel-up-event + (symbol-value (if (boundp 'mouse-wheel-up-event) + 'mouse-wheel-up-event + 'mouse-wheel-up-button))) + +(defconst tabbar--mwheel-down-event + (symbol-value (if (boundp 'mouse-wheel-down-event) + 'mouse-wheel-down-event + 'mouse-wheel-down-button))) + +(defsubst tabbar--mwheel-key (event-type) + "Return a mouse wheel key symbol from EVENT-TYPE. +When EVENT-TYPE is a symbol return it. +When it is a button number, return symbol `mouse-<EVENT-TYPE>'." + (if (symbolp event-type) + event-type + (intern (format "mouse-%s" event-type)))) + +(defsubst tabbar--mwheel-up-p (event) + "Return non-nil if EVENT is a mouse-wheel up event." + (let ((x (event-basic-type event))) + (if (eq 'mouse-wheel x) + (< (car (cdr (cdr event))) 0) ;; Emacs 21.3 + ;; Emacs > 21.3 + (eq x tabbar--mwheel-up-event)))) + +;;; Basic commands +;; +;;;###autoload +(defun tabbar-mwheel-backward (event) + "Select the previous available tab. +EVENT is the mouse event that triggered this command. +Mouse-enabled equivalent of the command `tabbar-backward'." + (interactive "@e") + (tabbar-cycle t event)) + +;;;###autoload +(defun tabbar-mwheel-forward (event) + "Select the next available tab. +EVENT is the mouse event that triggered this command. +Mouse-enabled equivalent of the command `tabbar-forward'." + (interactive "@e") + (tabbar-cycle nil event)) + +;;;###autoload +(defun tabbar-mwheel-backward-group (event) + "Go to selected tab in the previous available group. +If there is only one group, select the previous visible tab. +EVENT is the mouse event that triggered this command. +Mouse-enabled equivalent of the command `tabbar-backward-group'." + (interactive "@e") + (let ((tabbar-cycle-scope 'groups)) + (tabbar-cycle t event))) + +;;;###autoload +(defun tabbar-mwheel-forward-group (event) + "Go to selected tab in the next available group. +If there is only one group, select the next visible tab. +EVENT is the mouse event that triggered this command. +Mouse-enabled equivalent of the command `tabbar-forward-group'." + (interactive "@e") + (let ((tabbar-cycle-scope 'groups)) + (tabbar-cycle nil event))) + +;;;###autoload +(defun tabbar-mwheel-backward-tab (event) + "Select the previous visible tab. +EVENT is the mouse event that triggered this command. +Mouse-enabled equivalent of the command `tabbar-backward-tab'." + (interactive "@e") + (let ((tabbar-cycle-scope 'tabs)) + (tabbar-cycle t event))) + +;;;###autoload +(defun tabbar-mwheel-forward-tab (event) + "Select the next visible tab. +EVENT is the mouse event that triggered this command. +Mouse-enabled equivalent of the command `tabbar-forward-tab'." + (interactive "@e") + (let ((tabbar-cycle-scope 'tabs)) + (tabbar-cycle nil event))) + +;;; Wrappers when there is only one generic mouse-wheel event +;; +;;;###autoload +(defun tabbar-mwheel-switch-tab (event) + "Select the next or previous tab according to EVENT." + (interactive "@e") + (if (tabbar--mwheel-up-p event) + (tabbar-mwheel-forward-tab event) + (tabbar-mwheel-backward-tab event))) + +;;;###autoload +(defun tabbar-mwheel-switch-group (event) + "Select the next or previous group of tabs according to EVENT." + (interactive "@e") + (if (tabbar--mwheel-up-p event) + (tabbar-mwheel-forward-group event) + (tabbar-mwheel-backward-group event))) + +;;; Minor modes +;; +(defsubst tabbar-mode-on-p () + "Return non-nil if Tabbar mode is on." + (eq (default-value 'header-line-format) + tabbar-header-line-format)) + +;;; Tabbar-Local mode +;; +(defvar tabbar--local-hlf nil) + +;;;###autoload +(define-minor-mode tabbar-local-mode + "Toggle local display of the tab bar. +With prefix argument ARG, turn on if positive, otherwise off. +Returns non-nil if the new state is enabled. +When turned on, if a local header line is shown, it is hidden to show +the tab bar. The tab bar is locally hidden otherwise. When turned +off, if a local header line is hidden or the tab bar is locally +hidden, it is shown again. Signal an error if Tabbar mode is off." + :group 'tabbar + :global nil + (unless (tabbar-mode-on-p) + (error "Tabbar mode must be enabled")) +;;; ON + (if tabbar-local-mode + (if (and (local-variable-p 'header-line-format) + header-line-format) + ;; A local header line exists, hide it to show the tab bar. + (progn + ;; Fail in case of an inconsistency because another local + ;; header line is already hidden. + (when (local-variable-p 'tabbar--local-hlf) + (error "Another local header line is already hidden")) + (set (make-local-variable 'tabbar--local-hlf) + header-line-format) + (kill-local-variable 'header-line-format)) + ;; Otherwise hide the tab bar in this buffer. + (setq header-line-format nil)) +;;; OFF + (if (local-variable-p 'tabbar--local-hlf) + ;; A local header line is hidden, show it again. + (progn + (setq header-line-format tabbar--local-hlf) + (kill-local-variable 'tabbar--local-hlf)) + ;; The tab bar is locally hidden, show it again. + (kill-local-variable 'header-line-format)))) + +;;; Tabbar mode +;; +(defvar tabbar-prefix-key [(control ?c)] + "The common prefix key used in Tabbar mode.") + +(defvar tabbar-prefix-map + (let ((km (make-sparse-keymap))) + (define-key km [(control home)] 'tabbar-press-home) + (define-key km [(control left)] 'tabbar-backward) + (define-key km [(control right)] 'tabbar-forward) + (define-key km [(control up)] 'tabbar-backward-group) + (define-key km [(control down)] 'tabbar-forward-group) + (define-key km [(control prior)] 'tabbar-press-scroll-left) + (define-key km [(control next)] 'tabbar-press-scroll-right) + (define-key km [(control f10)] 'tabbar-local-mode) + km) + "The key bindings provided in Tabbar mode.") + +(defvar tabbar-mode-map + (let ((km (make-sparse-keymap))) + (define-key km tabbar-prefix-key tabbar-prefix-map) + km) + "Keymap to use in Tabbar mode.") + +(defvar tabbar--global-hlf nil) + +;;;###autoload +(define-minor-mode tabbar-mode + "Toggle display of a tab bar in the header line. +With prefix argument ARG, turn on if positive, otherwise off. +Returns non-nil if the new state is enabled. + +\\{tabbar-mode-map}" + :group 'tabbar + :require 'tabbar + :global t + :keymap tabbar-mode-map + (if tabbar-mode +;;; ON + (unless (tabbar-mode-on-p) + ;; Save current default value of `header-line-format'. + (setq tabbar--global-hlf (default-value 'header-line-format)) + (tabbar-init-tabsets-store) + (setq-default header-line-format tabbar-header-line-format)) +;;; OFF + (when (tabbar-mode-on-p) + ;; Turn off Tabbar-Local mode globally. + (mapc #'(lambda (b) + (condition-case nil + (with-current-buffer b + (and tabbar-local-mode + (tabbar-local-mode -1))) + (error nil))) + (buffer-list)) + ;; Restore previous `header-line-format'. + (setq-default header-line-format tabbar--global-hlf) + (tabbar-free-tabsets-store)) + )) + +;;; Tabbar-Mwheel mode +;; +(defvar tabbar-mwheel-mode-map + (let ((km (make-sparse-keymap))) + (if (get 'mouse-wheel 'event-symbol-elements) + ;; Use one generic mouse wheel event + (define-key km [A-mouse-wheel] + 'tabbar-mwheel-switch-group) + ;; Use separate up/down mouse wheel events + (let ((up (tabbar--mwheel-key tabbar--mwheel-up-event)) + (down (tabbar--mwheel-key tabbar--mwheel-down-event))) + (define-key km `[header-line ,down] + 'tabbar-mwheel-backward-group) + (define-key km `[header-line ,up] + 'tabbar-mwheel-forward-group) + (define-key km `[header-line (control ,down)] + 'tabbar-mwheel-backward-tab) + (define-key km `[header-line (control ,up)] + 'tabbar-mwheel-forward-tab) + (define-key km `[header-line (shift ,down)] + 'tabbar-mwheel-backward) + (define-key km `[header-line (shift ,up)] + 'tabbar-mwheel-forward) + )) + km) + "Keymap to use in Tabbar-Mwheel mode.") + +;;;###autoload +(define-minor-mode tabbar-mwheel-mode + "Toggle use of the mouse wheel to navigate through tabs or groups. +With prefix argument ARG, turn on if positive, otherwise off. +Returns non-nil if the new state is enabled. + +\\{tabbar-mwheel-mode-map}" + :group 'tabbar + :require 'tabbar + :global t + :keymap tabbar-mwheel-mode-map + (when tabbar-mwheel-mode + (unless (and mouse-wheel-mode tabbar-mode) + (tabbar-mwheel-mode -1)))) + +(defun tabbar-mwheel-follow () + "Toggle Tabbar-Mwheel following Tabbar and Mouse-Wheel modes." + (tabbar-mwheel-mode (if (and mouse-wheel-mode tabbar-mode) 1 -1))) + +(add-hook 'tabbar-mode-hook 'tabbar-mwheel-follow) +(add-hook 'mouse-wheel-mode-hook 'tabbar-mwheel-follow) + +;;; Buffer tabs +;; +(defgroup tabbar-buffer nil + "Display buffers in the tab bar." + :group 'tabbar) + +(defcustom tabbar-buffer-home-button + (cons (cons "[+]" tabbar-home-button-enabled-image) + (cons "[-]" tabbar-home-button-disabled-image)) + "The home button displayed when showing buffer tabs. +The enabled button value is displayed when showing tabs for groups of +buffers, and the disabled button value is displayed when showing +buffer tabs. +The variable `tabbar-button-widget' gives details on this widget." + :group 'tabbar-buffer + :type tabbar-button-widget + :set '(lambda (variable value) + (custom-set-default variable value) + ;; Schedule refresh of button value. + (setq tabbar-home-button-value nil))) + +(defvar tabbar-buffer-list-function 'tabbar-buffer-list + "Function that returns the list of buffers to show in tabs. +That function is called with no arguments and must return a list of +buffers.") + +(defvar tabbar-buffer-groups-function 'tabbar-buffer-groups + "Function that gives the group names the current buffer belongs to. +It must return a list of group names, or nil if the buffer has no +group. Notice that it is better that a buffer belongs to one group.") + +(defun tabbar-buffer-list () + "Return the list of buffers to show in tabs. +Exclude buffers whose name starts with a space, when they are not +visiting a file. The current buffer is always included." + (delq nil + (mapcar #'(lambda (b) + (cond + ;; Always include the current buffer. + ((eq (current-buffer) b) b) + ((buffer-file-name b) b) + ((char-equal ?\ (aref (buffer-name b) 0)) nil) + ((buffer-live-p b) b))) + (buffer-list)))) + +(defun tabbar-buffer-mode-derived-p (mode parents) + "Return non-nil if MODE derives from a mode in PARENTS." + (let (derived) + (while (and (not derived) mode) + (if (memq mode parents) + (setq derived t) + (setq mode (get mode 'derived-mode-parent)))) + derived)) + +(defun tabbar-buffer-groups () + "Return the list of group names the current buffer belongs to. +Return a list of one element based on major mode." + (list + (cond + ((or (get-buffer-process (current-buffer)) + ;; Check if the major mode derives from `comint-mode' or + ;; `compilation-mode'. + (tabbar-buffer-mode-derived-p + major-mode '(comint-mode compilation-mode))) + "Process" + ) + ((member (buffer-name) + '("*scratch*" "*Messages*")) + "Common" + ) + ((eq major-mode 'dired-mode) + "Dired" + ) + ((memq major-mode + '(help-mode apropos-mode Info-mode Man-mode)) + "Help" + ) + ((memq major-mode + '(rmail-mode + rmail-edit-mode vm-summary-mode vm-mode mail-mode + mh-letter-mode mh-show-mode mh-folder-mode + gnus-summary-mode message-mode gnus-group-mode + gnus-article-mode score-mode gnus-browse-killed-mode)) + "Mail" + ) + (t + ;; Return `mode-name' if not blank, `major-mode' otherwise. + (if (and (stringp mode-name) + ;; Take care of preserving the match-data because this + ;; function is called when updating the header line. + (save-match-data (string-match "[^ ]" mode-name))) + mode-name + (symbol-name major-mode)) + )))) + +;;; Group buffers in tab sets. +;; +(defvar tabbar--buffers nil) + +(defun tabbar-buffer-update-groups () + "Update tab sets from groups of existing buffers. +Return the the first group where the current buffer is." + (let ((bl (sort + (mapcar + #'(lambda (b) + (with-current-buffer b + (list (current-buffer) + (buffer-name) + (if tabbar-buffer-groups-function + (funcall tabbar-buffer-groups-function) + '("Common"))))) + (and tabbar-buffer-list-function + (funcall tabbar-buffer-list-function))) + #'(lambda (e1 e2) + (string-lessp (nth 1 e1) (nth 1 e2)))))) + ;; If the cache has changed, update the tab sets. + (unless (equal bl tabbar--buffers) + ;; Add new buffers, or update changed ones. + (dolist (e bl) + (dolist (g (nth 2 e)) + (let ((tabset (tabbar-get-tabset g))) + (if tabset + (unless (equal e (assq (car e) tabbar--buffers)) + ;; This is a new buffer, or a previously existing + ;; buffer that has been renamed, or moved to another + ;; group. Update the tab set, and the display. + (tabbar-add-tab tabset (car e) t) + (tabbar-set-template tabset nil)) + (tabbar-make-tabset g (car e)))))) + ;; Remove tabs for buffers not found in cache or moved to other + ;; groups, and remove empty tabsets. + (mapc 'tabbar-delete-tabset + (tabbar-map-tabsets + #'(lambda (tabset) + (dolist (tab (tabbar-tabs tabset)) + (let ((e (assq (tabbar-tab-value tab) bl))) + (or (and e (memq tabset + (mapcar 'tabbar-get-tabset + (nth 2 e)))) + (tabbar-delete-tab tab)))) + ;; Return empty tab sets + (unless (tabbar-tabs tabset) + tabset)))) + ;; The new cache becomes the current one. + (setq tabbar--buffers bl))) + ;; Return the first group the current buffer belongs to. + (car (nth 2 (assq (current-buffer) tabbar--buffers)))) + +;;; Tab bar callbacks +;; +(defvar tabbar--buffer-show-groups nil) + +(defsubst tabbar-buffer-show-groups (flag) + "Set display of tabs for groups of buffers to FLAG." + (setq tabbar--buffer-show-groups flag + ;; Redisplay the home button. + tabbar-home-button-value nil)) + +(defun tabbar-buffer-tabs () + "Return the buffers to display on the tab bar, in a tab set." + (let ((tabset (tabbar-get-tabset (tabbar-buffer-update-groups)))) + (tabbar-select-tab-value (current-buffer) tabset) + (when tabbar--buffer-show-groups + (setq tabset (tabbar-get-tabsets-tabset)) + (tabbar-select-tab-value (current-buffer) tabset)) + tabset)) + +(defun tabbar-buffer-button-label (name) + "Return a label for button NAME. +That is a pair (ENABLED . DISABLED), where ENABLED and DISABLED are +respectively the appearance of the button when enabled and disabled. +They are propertized strings which could display images, as specified +by the variable `tabbar-button-label'. +When NAME is 'home, return a different ENABLED button if showing tabs +or groups. Call the function `tabbar-button-label' otherwise." + (let ((lab (tabbar-button-label name))) + (when (eq name 'home) + (let* ((btn tabbar-buffer-home-button) + (on (tabbar-find-image (cdar btn))) + (off (tabbar-find-image (cddr btn)))) + ;; When `tabbar-buffer-home-button' does not provide a value, + ;; default to the enabled value of `tabbar-home-button'. + (if on + (tabbar-normalize-image on 1) + (setq on (get-text-property 0 'display (car lab)))) + (if off + (tabbar-normalize-image off 1) + (setq off (get-text-property 0 'display (car lab)))) + (setcar lab + (if tabbar--buffer-show-groups + (propertize (or (caar btn) (car lab)) 'display on) + (propertize (or (cadr btn) (car lab)) 'display off))) + )) + lab)) + +(defun tabbar-buffer-tab-label (tab) + "Return a label for TAB. +That is, a string used to represent it on the tab bar." + (let ((label (if tabbar--buffer-show-groups + (format "[%s]" (tabbar-tab-tabset tab)) + (format "%s" (tabbar-tab-value tab))))) + ;; Unless the tab bar auto scrolls to keep the selected tab + ;; visible, shorten the tab label to keep as many tabs as possible + ;; in the visible area of the tab bar. + (if tabbar-auto-scroll-flag + label + (tabbar-shorten + label (max 1 (/ (window-width) + (length (tabbar-view + (tabbar-current-tabset))))))))) + +(defun tabbar-buffer-help-on-tab (tab) + "Return the help string shown when mouse is onto TAB." + (if tabbar--buffer-show-groups + (let* ((tabset (tabbar-tab-tabset tab)) + (tab (tabbar-selected-tab tabset))) + (format "mouse-1: switch to buffer %S in group [%s]" + (buffer-name (tabbar-tab-value tab)) tabset)) + (format "mouse-1: switch to buffer %S\n\ +mouse-2: pop to buffer, mouse-3: delete other windows" + (buffer-name (tabbar-tab-value tab))) + )) + +(defun tabbar-buffer-select-tab (event tab) + "On mouse EVENT, select TAB." + (let ((mouse-button (event-basic-type event)) + (buffer (tabbar-tab-value tab))) + (cond + ((eq mouse-button 'mouse-2) + (pop-to-buffer buffer t)) + ((eq mouse-button 'mouse-3) + (delete-other-windows)) + (t + (switch-to-buffer buffer))) + ;; Don't show groups. + (tabbar-buffer-show-groups nil) + )) + +(defun tabbar-buffer-click-on-home (event) + "Handle a mouse click EVENT on the tab bar home button. +mouse-1, toggle the display of tabs for groups of buffers. +mouse-3, close the current buffer." + (let ((mouse-button (event-basic-type event))) + (cond + ((eq mouse-button 'mouse-1) + (tabbar-buffer-show-groups (not tabbar--buffer-show-groups))) + ((eq mouse-button 'mouse-3) + (kill-buffer nil)) + ))) + +(defun tabbar-buffer-help-on-home () + "Return the help string shown when mouse is onto the toggle button." + (concat + (if tabbar--buffer-show-groups + "mouse-1: show buffers in selected group" + "mouse-1: show groups of buffers") + ", mouse-3: close current buffer")) + +(defun tabbar-buffer-track-killed () + "Hook run just before actually killing a buffer. +In Tabbar mode, try to switch to a buffer in the current tab bar, +after the current buffer has been killed. Try first the buffer in tab +after the current one, then the buffer in tab before. On success, put +the sibling buffer in front of the buffer list, so it will be selected +first." + (and (eq header-line-format tabbar-header-line-format) + (eq tabbar-current-tabset-function 'tabbar-buffer-tabs) + (eq (current-buffer) (window-buffer (selected-window))) + (let ((bl (tabbar-tab-values (tabbar-current-tabset))) + (b (current-buffer)) + found sibling) + (while (and bl (not found)) + (if (eq b (car bl)) + (setq found t) + (setq sibling (car bl))) + (setq bl (cdr bl))) + (when (and (setq sibling (or (car bl) sibling)) + (buffer-live-p sibling)) + ;; Move sibling buffer in front of the buffer list. + (save-current-buffer + (switch-to-buffer sibling)))))) + +;;; Tab bar buffer setup +;; +(defun tabbar-buffer-init () + "Initialize tab bar buffer data. +Run as `tabbar-init-hook'." + (setq tabbar--buffers nil + tabbar--buffer-show-groups nil + tabbar-current-tabset-function 'tabbar-buffer-tabs + tabbar-tab-label-function 'tabbar-buffer-tab-label + tabbar-select-tab-function 'tabbar-buffer-select-tab + tabbar-help-on-tab-function 'tabbar-buffer-help-on-tab + tabbar-button-label-function 'tabbar-buffer-button-label + tabbar-home-function 'tabbar-buffer-click-on-home + tabbar-home-help-function 'tabbar-buffer-help-on-home + ) + (add-hook 'kill-buffer-hook 'tabbar-buffer-track-killed)) + +(defun tabbar-buffer-quit () + "Quit tab bar buffer. +Run as `tabbar-quit-hook'." + (setq tabbar--buffers nil + tabbar--buffer-show-groups nil + tabbar-current-tabset-function nil + tabbar-tab-label-function nil + tabbar-select-tab-function nil + tabbar-help-on-tab-function nil + tabbar-button-label-function nil + tabbar-home-function nil + tabbar-home-help-function nil + ) + (remove-hook 'kill-buffer-hook 'tabbar-buffer-track-killed)) + +(add-hook 'tabbar-init-hook 'tabbar-buffer-init) +(add-hook 'tabbar-quit-hook 'tabbar-buffer-quit) + +(provide 'tabbar) + +(run-hooks 'tabbar-load-hook) + +;;; tabbar.el ends here diff --git a/.emacs.d/elisp/vala-mode.el b/.emacs.d/elisp/vala-mode.el new file mode 100644 index 0000000..0358790 --- /dev/null +++ b/.emacs.d/elisp/vala-mode.el @@ -0,0 +1,395 @@ +;;; vala-mode.el --- Vala mode derived mode + +;; Author: 2005 Dylan R. E. Moonfire +;; 2008 Étienne BERSAC +;; Maintainer: Étienne BERSAC <bersace03@laposte.net> +;; Created: 2008 May the 4th +;; Modified: May 2008 +;; Version: 0.1 +;; Keywords: vala languages oop + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; +;; See http://live.gnome.org/Vala for details about Vala language. +;; +;; This is a separate mode to implement the Vala constructs and +;; font-locking. It is mostly the csharp-mode from +;; http://mfgames.com/linux/csharp-mode with vala specific keywords +;; and filename suffixes. +;; +;; Note: The interface used in this file requires CC Mode 5.30 or +;; later. + +;;; .emacs (don't put in (require 'vala-mode)) +;; (autoload 'vala-mode "vala-mode" "Major mode for editing Vala code." t) +;; (setq auto-mode-alist +;; (append '(("\\.vala$" . vala-mode)) auto-mode-alist)) + +;;; Versions: +;; +;; 0.1 : Initial version based on csharp-mode +;; + +;; This is a copy of the function in cc-mode which is used to handle +;; the eval-when-compile which is needed during other times. +(defun c-filter-ops (ops opgroup-filter op-filter &optional xlate) + ;; See cc-langs.el, a direct copy. + (unless (listp (car-safe ops)) + (setq ops (list ops))) + (cond ((eq opgroup-filter t) + (setq opgroup-filter (lambda (opgroup) t))) + ((not (functionp opgroup-filter)) + (setq opgroup-filter `(lambda (opgroup) + (memq opgroup ',opgroup-filter))))) + (cond ((eq op-filter t) + (setq op-filter (lambda (op) t))) + ((stringp op-filter) + (setq op-filter `(lambda (op) + (string-match ,op-filter op))))) + (unless xlate + (setq xlate 'identity)) + (c-with-syntax-table (c-lang-const c-mode-syntax-table) + (delete-duplicates + (mapcan (lambda (opgroup) + (when (if (symbolp (car opgroup)) + (when (funcall opgroup-filter (car opgroup)) + (setq opgroup (cdr opgroup)) + t) + t) + (mapcan (lambda (op) + (when (funcall op-filter op) + (let ((res (funcall xlate op))) + (if (listp res) res (list res))))) + opgroup))) + ops) + :test 'equal))) + +;; This inserts the bulk of the code. +(require 'cc-mode) + +;; These are only required at compile time to get the sources for the +;; language constants. (The cc-fonts require and the font-lock +;; related constants could additionally be put inside an +;; (eval-after-load "font-lock" ...) but then some trickery is +;; necessary to get them compiled.) +(eval-when-compile + (let ((load-path + (if (and (boundp 'byte-compile-dest-file) + (stringp byte-compile-dest-file)) + (cons (file-name-directory byte-compile-dest-file) load-path) + load-path))) + (load "cc-mode" nil t) + (load "cc-fonts" nil t) + (load "cc-langs" nil t))) + +(eval-and-compile + ;; Make our mode known to the language constant system. Use Java + ;; mode as the fallback for the constants we don't change here. + ;; This needs to be done also at compile time since the language + ;; constants are evaluated then. + (c-add-language 'vala-mode 'java-mode)) + +;; Java uses a series of regexes to change the font-lock for class +;; references. The problem comes in because Java uses Pascal (leading +;; space in names, SomeClass) for class and package names, but +;; Camel-casing (initial lowercase, upper case in words, +;; i.e. someVariable) for variables. +;;(error (byte-compile-dest-file)) +;;(error (c-get-current-file)) +(c-lang-defconst c-opt-after-id-concat-key + vala (if (c-lang-const c-opt-identifier-concat-key) + (c-lang-const c-symbol-start))) + +(c-lang-defconst c-basic-matchers-before + vala `( +;;;; Font-lock the attributes by searching for the +;;;; appropriate regex and marking it as TODO. + ;;,`(,(concat "\\(" vala-attribute-regex "\\)") + ;; 0 font-lock-function-name-face) + + ;; Put a warning face on the opener of unclosed strings that + ;; can't span lines. Later font + ;; lock packages have a `font-lock-syntactic-face-function' for + ;; this, but it doesn't give the control we want since any + ;; fontification done inside the function will be + ;; unconditionally overridden. + ,(c-make-font-lock-search-function + ;; Match a char before the string starter to make + ;; `c-skip-comments-and-strings' work correctly. + (concat ".\\(" c-string-limit-regexp "\\)") + '((c-font-lock-invalid-string))) + + ;; Fontify keyword constants. + ,@(when (c-lang-const c-constant-kwds) + (let ((re (c-make-keywords-re nil + (c-lang-const c-constant-kwds)))) + `((eval . (list ,(concat "\\<\\(" re "\\)\\>") + 1 c-constant-face-name))))) + + ;; Fontify all keywords except the primitive types. + ,`(,(concat "\\<" (c-lang-const c-regular-keywords-regexp)) + 1 font-lock-keyword-face) + + ;; Fontify leading identifiers in fully + ;; qualified names like "Foo.Bar". + ,@(when (c-lang-const c-opt-identifier-concat-key) + `((,(byte-compile + `(lambda (limit) + (while (re-search-forward + ,(concat "\\(\\<" ; 1 + "\\(" (c-lang-const c-symbol-key) + "\\)" ; 2 + "[ \t\n\r\f\v]*" + (c-lang-const + c-opt-identifier-concat-key) + "[ \t\n\r\f\v]*" + "\\)" + "\\(" + (c-lang-const + c-opt-after-id-concat-key) + "\\)") + limit t) + (unless (progn + (goto-char (match-beginning 0)) + (c-skip-comments-and-strings limit)) + (or (get-text-property (match-beginning 2) 'face) + (c-put-font-lock-face (match-beginning 2) + (match-end 2) + c-reference-face-name)) + (goto-char (match-end 1))))))))) + )) + +;; Vala does not allow a leading qualifier operator. It also doesn't +;; allow the ".*" construct of Java. So, we redo this regex without +;; the "\\|\\*" regex. +(c-lang-defconst c-identifier-key + vala (concat "\\(" (c-lang-const c-symbol-key) "\\)" ; 1 + (concat "\\(" + "[ \t\n\r\f\v]*" + (c-lang-const c-opt-identifier-concat-key) + "[ \t\n\r\f\v]*" + (concat "\\(" + "\\(" (c-lang-const c-symbol-key) "\\)" + "\\)") + "\\)*"))) + +;; Vala has a few rules that are slightly different than Java for +;; operators. This also removed the Java's "super" and replaces it +;; with the Vala's "base". +(c-lang-defconst c-operators + vala `((prefix "base"))) + +;; Vala directives ? +;; (c-lang-defconst c-opt-cpp-prefix +;; csharp "^\\s *#.*") + + +;; Vala uses the following assignment operators +(c-lang-defconst c-assignment-operators + vala '("=" "*=" "/=" "%=" "+=" "-=" ">>=" "<<=" + "&=" "^=" "|=" "++" "--")) + +;; This defines the primative types for Vala +(c-lang-defconst c-primitive-type-kwds + vala '("void" "char" "int" "float" "double" "string")) + +;; The keywords that define that the following is a type, such as a +;; class definition. +(c-lang-defconst c-type-prefix-kwds + vala '("class" "interface" "struct" "enum" "signal")) + +;; Type modifier keywords. They appear anywhere in types, but modifiy +;; instead create one. +(c-lang-defconst c-type-modifier-kwds + vala '("const")) + +;; Structures that are similiar to classes. +(c-lang-defconst c-class-decl-kwds + vala '("class" "interface")) + +;; The various modifiers used for class and method descriptions. +(c-lang-defconst c-modifier-kwds + vala '("public" "partial" "private" "const" "abstract" + "protected" "ref" "in" "out" "static" "virtual" + "override" "params" "internal" "weak" "owned" + "unowned")) + +;; We don't use the protection level stuff because it breaks the +;; method indenting. Not sure why, though. +(c-lang-defconst c-protection-kwds + vala nil) + +;; Define the keywords that can have something following after them. +(c-lang-defconst c-type-list-kwds + vala '("struct" "class" "interface" "is" "as" + "delegate" "event" "set" "get" "add" "remove" + "callback" "signal" "var" "default")) + +;; This allows the classes after the : in the class declartion to be +;; fontified. +(c-lang-defconst c-typeless-decl-kwds + vala '(":")) + +;; Sets up the enum to handle the list properly +(c-lang-defconst c-brace-list-decl-kwds + vala '("enum" "errordomain")) + +;; We need to remove Java's package keyword +(c-lang-defconst c-ref-list-kwds + vala '("using" "namespace" "construct")) + +;; Follow-on blocks that don't require a brace +(c-lang-defconst c-block-stmt-2-kwds + vala '("for" "if" "switch" "while" "catch" "foreach" "lock")) + +;; Statements that break out of braces +(c-lang-defconst c-simple-stmt-kwds + vala '("return" "continue" "break" "throw")) + +;; Statements that allow a label +;; TODO? +(c-lang-defconst c-before-label-kwds + vala nil) + +;; Constant keywords +(c-lang-defconst c-constant-kwds + vala '("true" "false" "null")) + +;; Keywords that start "primary expressions." +(c-lang-defconst c-primary-expr-kwds + vala '("this" "base")) + +;; We need to treat namespace as an outer block to class indenting +;; works properly. +(c-lang-defconst c-other-block-decl-kwds + vala '("namespace")) + +;; We need to include the "in" for the foreach +(c-lang-defconst c-other-kwds + vala '("in" "sizeof" "typeof")) + +(require 'cc-awk) + +(c-lang-defconst c-at-vsemi-p-fn + vala 'c-awk-at-vsemi-p) + + +(defcustom vala-font-lock-extra-types nil + "*List of extra types (aside from the type keywords) to recognize in Vala mode. +Each list item should be a regexp matching a single identifier.") + +(defconst vala-font-lock-keywords-1 (c-lang-const c-matchers-1 vala) + "Minimal highlighting for Vala mode.") + +(defconst vala-font-lock-keywords-2 (c-lang-const c-matchers-2 vala) + "Fast normal highlighting for Vala mode.") + +(defconst vala-font-lock-keywords-3 (c-lang-const c-matchers-3 vala) + "Accurate normal highlighting for Vala mode.") + +(defvar vala-font-lock-keywords vala-font-lock-keywords-3 + "Default expressions to highlight in Vala mode.") + +(defvar vala-mode-syntax-table + nil + "Syntax table used in vala-mode buffers.") +(or vala-mode-syntax-table + (setq vala-mode-syntax-table + (funcall (c-lang-const c-make-mode-syntax-table vala)))) + +(defvar vala-mode-abbrev-table nil + "Abbreviation table used in vala-mode buffers.") +(c-define-abbrev-table 'vala-mode-abbrev-table + ;; Keywords that if they occur first on a line + ;; might alter the syntactic context, and which + ;; therefore should trig reindentation when + ;; they are completed. + '(("else" "else" c-electric-continued-statement 0) + ("while" "while" c-electric-continued-statement 0) + ("catch" "catch" c-electric-continued-statement 0) + ("finally" "finally" c-electric-continued-statement 0))) + +(defvar vala-mode-map (let ((map (c-make-inherited-keymap))) + ;; Add bindings which are only useful for Vala + map) + "Keymap used in vala-mode buffers.") + +;;(easy-menu-define vala-menu vala-mode-map "Vala Mode Commands" +;; ;; Can use `vala' as the language for `c-mode-menu' +;; ;; since its definition covers any language. In +;; ;; this case the language is used to adapt to the +;; ;; nonexistence of a cpp pass and thus removing some +;; ;; irrelevant menu alternatives. +;; (cons "Vala" (c-lang-const c-mode-menu vala))) + +;;; Autoload mode trigger +(add-to-list 'auto-mode-alist '("\\.vala$" . vala-mode)) +(add-to-list 'auto-mode-alist '("\\.vapi$" . vala-mode)) + +;; Custom variables +(defcustom vala-mode-hook nil + "*Hook called by `vala-mode'." + :type 'hook + :group 'c) + +;;; The entry point into the mode +;;;###autoload +(defun vala-mode () + "Major mode for editing Vala code. +This is a simple example of a separate mode derived from CC Mode +to support a language with syntax similar to +C#/C/C++/ObjC/Java/IDL/Pike. + +The hook `c-mode-common-hook' is run with no args at mode +initialization, then `vala-mode-hook'. + +Key bindings: +\\{vala-mode-map}" + (interactive) + (kill-all-local-variables) + (c-initialize-cc-mode t) + (set-syntax-table vala-mode-syntax-table) + (setq major-mode 'vala-mode + mode-name "Vala" + local-abbrev-table vala-mode-abbrev-table + abbrev-mode t) + (use-local-map c-mode-map) + ;; `c-init-language-vars' is a macro that is expanded at compile + ;; time to a large `setq' with all the language variables and their + ;; customized values for our language. + (c-init-language-vars vala-mode) + ;; `c-common-init' initializes most of the components of a CC Mode + ;; buffer, including setup of the mode menu, font-lock, etc. + ;; There's also a lower level routine `c-basic-common-init' that + ;; only makes the necessary initialization to get the syntactic + ;; analysis and similar things working. + (c-common-init 'vala-mode) + ;;(easy-menu-add vala-menu) + (c-set-style "linux") + (setq indent-tabs-mode t) + (setq c-basic-offset 4) + (setq tab-width 4) + (c-toggle-auto-newline -1) + (c-toggle-hungry-state -1) + (run-hooks 'c-mode-common-hook) + (run-hooks 'vala-mode-hook) + (c-update-modeline)) + +(provide 'vala-mode) + +;;; vala-mode.el ends here diff --git a/.emacs.d/elisp/zencoding b/.emacs.d/elisp/zencoding new file mode 160000 +Subproject 6e5bfd864a679c1f699d03dc27223175cbde07e diff --git a/.emacs.d/functions.el b/.emacs.d/functions.el new file mode 100644 index 0000000..9e831db --- /dev/null +++ b/.emacs.d/functions.el @@ -0,0 +1,212 @@ +(defun quote-region () + (interactive) + (let ((beginning (region-beginning)) + (end (region-end))) + (save-excursion + (goto-char end) + (insert ?') + (goto-char beginning) + (insert ?')))) + +(defun what-face (pos) + "Find out which face the current position uses" + (interactive "d") + (let ((face (or (get-char-property (point) 'read-face-name) + (get-char-property (point) 'face)))) + (if face + (message "Face: %s" face) + (message "No face at %d" pos)))) + +(defun my-comp-finish-function (buf str) + "Don't show compilation window if everything went ok" + (if (string-match "exited abnormally" str) + ;; there were errors + (message "compilation errors, press C-x ` to visit") + ;; no errors, make the compilation window go away in 0.5 seconds + (run-at-time 0.5 nil 'delete-windows-on buf) + (message "NO COMPILATION ERRORS!"))) + +(defun fullscreen () + "Fill the entire screen with emacs" + (interactive) + (x-send-client-message nil 0 nil "_NET_WM_STATE" 32 + '(2 "_NET_WM_STATE_MAXIMIZED_VERT" 0)) + (x-send-client-message nil 0 nil "_NET_WM_STATE" 32 + '(2 "_NET_WM_STATE_MAXIMIZED_HORZ" 0))) + +(defun c-toggle-header-source () + "Toggle between a C source and header file" + (interactive) + (let ((ext (file-name-extension (buffer-file-name))) + (noext (file-name-sans-extension (buffer-file-name)))) + (if (string= (substring ext 0 1) "c") + (find-file (concat noext ".h")) + (find-file (concat noext ".c"))))) + +(defun browse-to-current-file () + "Show current file in browser" + (interactive) + (browse-url buffer-file-name)) + +(defun comment-line () + "Toggle comment on a line" + (interactive) + (save-excursion + (beginning-of-line) + (insert "//"))) + +(defun add-php-keywords () + "Designed for c and c-style languages + +Currently adds | & ! . + = - / % * , < > ? : ->" + ;; Add ! at the beginning of font lock + (font-lock-add-keywords + 'php-mode + '(("\\([!]\\|\\=>\\)" 1 font-lock-operator-face))) + ;; Add the rest at the end of font lock + (font-lock-add-keywords + 'php-mode + '(("\\(->\\|[|.+=&/%*,:?<>-]\\)" 1 font-lock-operator-face) + ("\\(;\\)" 1 font-lock-end-statement)) 1)) + +(defun add-html-keywords () + "Designed for html, show some smarty tags" + (font-lock-add-keywords + 'html-mode + '(("{\\(\\*.*\\*\\)}" 1 font-comment-face) + ("{\\/?\\(extends\\|block\\|foreach\\(else\\)?\\|if\\)" + 1 font-lock-builtin-face) + ("\\$\\(\\(?:\\sw\\|\\s_\\)+\\)\\(?:|\\(\\(?:\\sw\\|\\s_\\)+\\):\\)" + (1 font-lock-variable-name-face) + (2 font-lock-function-name-face)) + ("\\$\\(\\(?:\\sw\\|\\s_\\)+\\)" + 1 font-lock-variable-name-face) + ("{\\(\\(?:\\sw\\|\\s_\\)+\\).*}" + 1 font-lock-function-name-face)))) + +(defun buffer-major-mode (buffer-or-string) + "Find out which major-mode is currently used" + (with-current-buffer buffer-or-string major-mode)) + +(defun setup-system-frame-colours (&rest frame) + (let ((f (if (car frame) + (car frame) + (selected-frame)))) + (progn + (set-frame-font "-*-tamsyn-medium-*-*-*-15-*-*-*-*-80-*-*")))) + +(defun show-init-sections () + (interactive) + (occur ";;\s +.*\s +;;") + (other-window 1)) + +(defun list-functions () + (interactive) + (occur + "\\(?:\\(?:private\\|protected\\|public\\) \\)?function \\(?:\\sw\\)+(\\sw*)")) + +(defun insert-init-title (title width) + (interactive "stitle: \nnwidth: ") + (insert-char ?\; width) + (insert "\n;;") + (insert-char ?\s (floor (/ (- (- width 4.0) (length title)) 2))) + (insert title) + (insert-char ?\s (ceiling (/ (- (- width 4.0) (length title)) 2))) + (insert ";;\n") + (insert-char ?\; width)) + +(defun x-init () + "Initialization only for X" + (require 'lcars-theme) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; THEME SETTINGS ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (lcars-theme-set-faces + 'lcars + + ;; markdown-mode + '(markdown-link-face (:inherit 'link)) + '(markdown-header-face-1 (:inherit 'org-level-1)) + '(markdown-header-face-2 (:inherit 'org-level-2)) + '(markdown-header-face-3 (:inherit 'org-level-3)) + '(markdown-header-face-4 (:inherit 'org-level-4)) + '(markdown-header-face-5 (:inherit 'org-level-5)) + '(markdown-header-face-6 (:inherit 'org-level-6))) + + (add-hook 'emacs-startup-hook 'fullscreen)) + +(defun cli-init () + "Add a space to the linum column" + (setq linum-format "%d ")) + +(defun replace-occurrences (from to) + (save-excursion + (goto-char (point-min)) + (while (search-forward from nil t) + (replace-match to)))) + +(defun replace-html-special-chars () + (replace-occurrences "é" "é")) + +(defun on-before-save () + (if (eq (buffer-major-mode (current-buffer)) 'html-mode) + (replace-html-special-chars)) + (if (not (eq (buffer-major-mode (current-buffer)) 'markdown-mode)) + (delete-trailing-whitespace))) + +(defun on-after-save () + (let ((fname (buffer-file-name))) + (let ((suffix (file-name-extension fname))) + (if (string-equal suffix "el") + (byte-compile-file fname))))) + +(defun on-prog-mode () + (font-lock-add-keywords + nil + '(("\\b\\(0[xX][0-9a-fA-F]+[lL]?\\|[0-9]+\\.?[0-9]*\\([eE][-+]?[0-9]+\\)?\\([lL]\\|[fF]\\|[dD]\\)?\\)\\b" + 0 font-lock-constant-face) + ("\\b\\(\\.[0-9]+\\([eE][-+]?[0-9]+\\)?\\([lL]\\|[fF]\\|[dD]\\)?\\)\\b" + 0 font-lock-constant-face))) + (rainbow-delimiters-mode) + (pretty-lambdas) + (auto-fill-mode 1)) + +(defun on-c-mode () + (local-set-key [f8] 'c-toggle-header-source) + (local-set-key [f9] 'compile) + (local-set-key [C-m] 'newline-and-indent) + (local-set-key [C-return] 'newline)) + +(defun on-html-mode () + (local-set-key [f9] 'browse-to-current-file) + (setq fill-column 73) + (auto-fill-mode)) + +(defun on-php-mode () + (local-set-key [f6] 'comment-line)) + +(defun on-mail-mode () + (turn-on-auto-fill) + (search-forward "\n\n")) + +(defun pretty-lambdas () + (font-lock-add-keywords + nil `(("(\\(lambda\\>\\)" + (0 (progn + (compose-region (match-beginning 1) + (match-end 1) + ?λ))))))) + +;; http://emacs-fu.blogspot.com/2009/01/navigating-through-source-code-using.html +(defun djcb-gtags-create-or-update () + "create or update the gnu global tag file" + (interactive) + (if (not (= 0 (call-process "global" nil nil nil " -p"))) ; tagfile + (let ((olddir default-directory) ; doesn't exist? + (topdir (read-directory-name + "gtags: top of source tree:" default-directory))) + (cd topdir) + (shell-command "gtags && echo 'created tagfile'") + (cd olddir)) ; restore + ;; tagfile already exists; update it + (shell-command "global -u && echo 'updated tagfile'"))) diff --git a/.emacs.d/init.el b/.emacs.d/init.el new file mode 100644 index 0000000..4c74dec --- /dev/null +++ b/.emacs.d/init.el @@ -0,0 +1,342 @@ +;; -*- mode: Emacs-Lisp; -*- +(load "~/.emacs.d/ryuslash-load-path") + +;;; Autopair +(require 'autopair) +(autopair-global-mode t) ; automatically add the other delimiter +(setq autopair-skip-criteria 'always + autopair-autowrap t + autopair-blink nil) +(setq-default autopair-dont-pair '(:string (?\' ?\") :comment (?\'))) + +;; Column marker +(defun set-column-markers (cm1 cm2) + (column-marker-1 cm1) + (column-marker-2 cm2)) + +(require 'column-marker) + +(dolist (hook '(prog-mode-hook html-mode-hook)) + (add-hook hook + (lambda () + (set-column-markers 73 81)))) + +(add-hook 'php-mode-hook + (lambda () + (set-column-markers 76 81))) + +;;; Org mode +(require 'org-crypt) +(require 'org-publish) +(setq + org-tags-exclude-from-inheritance '("crypt") + org-crypt-key "33E8CC1CC4" + org-use-fast-todo-selection t + org-default-notes-file (concat org-directory + "/notes.org") + org-outline-path-complete-in-steps t + org-return-follows-link t + org-log-into-drawer t + org-todo-keywords '((sequence "TODO(t)" + "IN PROGRESS(p)" + "WAITING(w@/!)" + "|" + "DONE(d!/!)" + "CANCELLED(c@/!)")) + org-refile-targets '((org-agenda-files :maxlevel . 5) + (nil :maxlevel . 5)) + org-todo-keyword-faces + '(("TODO" :foreground "red" :weight bold) + ("IN PROGRESS" :foreground "yellow" :weight bold) + ("DONE" :foreground "forest green" :weight bold) + ("WAITING" :foreground "orange" :weight bold) + ("CANCELLED" :foreground "orangered" :weight bold))) +(add-to-list 'auto-mode-alist '("\\.commitmsg$" . org-mode)) +(global-set-key "\C-cl" 'org-store-link) +(global-set-key "\C-cc" 'org-capture) +(global-set-key "\C-ca" 'org-agenda) +(add-hook 'org-mode-hook + (lambda () + (flyspell-mode t) + (auto-fill-mode t))) +(org-crypt-use-before-save-magic) + +;;; Rainbow delimiters +(require 'rainbow-delimiters) +(setq rainbow-delimiters-max-face-count 8) + +;;; Uniquify +(require 'uniquify) +(setq uniquify-buffer-name-style 'post-forward) + +;;; Go +(autoload 'go-mode "go-mode" "Major mode for google go" t) +(autoload 'gofmt "go-mode" "" t) +(autoload 'go-fmt-before-save "go-mode" "" t) +(add-to-list 'auto-mode-alist '("\\.go$" . go-mode)) +(add-hook 'go-mode-hook + (lambda () + (turn-off-auto-fill) + (column-marker-1 -1))) + +;;; Htmlize +(require 'htmlize) +(setq htmlize-output-type 'inline-css) + +;;; Git +(require 'git) + +;;; Markdown mode +(autoload 'markdown-mode "markdown-mode" "Major mode for Markdown" t) +(setq whitespace-style '(face trailing)) ; For use with markdown mode +(add-to-list 'auto-mode-alist '("\\.m\\(ark\\)?do?wn$". markdown-mode)) +(add-hook 'markdown-mode-hook + (lambda () + (whitespace-mode 1) + (turn-on-auto-fill))) + +;;; Zencoding mode +(autoload 'zencoding-mode "zencoding-mode" "Minor mode for zencoding" t) +(add-hook 'sgml-mode-hook 'zencoding-mode) ; Auto-start on any markup + ; modes + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; REQUIRES ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(load-file "~/.emacs.d/functions.el") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; AUTOLOADS ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(autoload 'vala-mode "vala-mode" "Major mode for Vala" t) +(autoload 'csharp-mode "csharp-mode" "Major mode for C#" t) +(autoload 'sqlplus-mode "sqlplus" "Major mode for PL/SQL" t) +(autoload 'batch-mode "batch-mode" "Major mode for Batch" t) +(autoload 'lua-mode "lua-mode" "A Major mode for Lua" t) +(autoload 'php-mode "pi-php-mode" "Major mode for PHP" t) +(autoload 'graphviz-dot-mode "graphviz-dot-mode" "Major mode for dot" t) +(autoload 'cmake-mode "cmake-mode" "Major mode for CMake" t) +(autoload 'rainbow-mode "rainbow-mode" "Minor mode for colors" t) +(autoload 'stumpwm-mode "stumpwm-mode" "Major mode for stumpwm" t) +(autoload 'muttrc-mode "muttrc-mode" "Major mode for muttrc" t) +(autoload 'git-commit-mode "git-commit" "" t) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; VARIABLES ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar font-lock-operator-face 'font-lock-operator-face) +(defvar font-lock-end-statement 'font-lock-end-statement) + +(defadvice server-create-window-system-frame + (after set-system-frame-colours ()) + "Set custom frame colours when creating the first frame on a display" + (message "Running after frame-initialize") + (setup-system-frame-colours)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; SETTINGS ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(setq-default indent-tabs-mode nil) ; spaces, no tabs +(setq-default truncate-lines t) ; don't wrap +(setq-default php-warn-if-mumamo-off nil) ; don't warn me about this +(setq-default tab-width 4) + +(setq inhibit-startup-message t) ; Don't show welcome screen +(setq require-final-newline t) ; Always put final newline +(setq inhibit-default-init t) ; Don't load default library +(setq scroll-conservatively 101) ; scroll only one line +(setq browse-url-browser-function 'browse-url-generic) +(setq browse-url-generic-program (getenv "BROWSER")) +(setq uniquify-buffer-name-style 'reverse) +(setq jit-lock-defer-time 0.2) ; Don't fontlock immediately +(setq ido-save-directory-list-file nil) +(setq ido-auto-merge-delay-time 2) ; Wait before fixing names +(setq mouse-autoselect-window t) +(setq pop-up-windows nil) +(setq mail-header-separator "") + +(setq frame-title-format ; I don't like emacs@cloud, must have file + '(:eval ; name + (concat "emacs: " (buffer-name)))) + +(setq backup-directory-alist ; backup file location + `((".*" . ,temporary-file-directory))) + +(setq auto-save-file-name-transforms ; autosave file location + `((".*" ,temporary-file-directory t))) + +(setq default-frame-alist ; default frame settings + (append '((font . "DejaVu Sans Mono-10:antialias=true")))) + +(if window-system + (x-init) + (cli-init)) + +(fset 'yes-or-no-p 'y-or-n-p) ; switch yes or no to y or n + +(tool-bar-mode -1) ; no toolbar +(menu-bar-mode -1) ; no menubar +(scroll-bar-mode -1) ; no scrollbars +(line-number-mode -1) ; don't show line number in splitter +(global-linum-mode t) ; Show line numbers in gutter +(column-number-mode t) ; show column number in splitter +(global-font-lock-mode t) ; show syntax highlighting, old +(delete-selection-mode t) ; delete selection upon typing +(show-paren-mode t) ; show the opposite paren +(ido-mode t) + +(add-to-list 'compilation-finish-functions 'my-comp-finish-function) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; FILE ASSOCIATIONS ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(add-to-list 'auto-mode-alist '("\\.vala$" . vala-mode)) +(add-to-list 'auto-mode-alist '("\\.vapi$" . vala-mode)) +(add-to-list 'auto-mode-alist '("\\.cs$" . csharp-mode)) +(add-to-list 'auto-mode-alist '("\\.bat$" . batch-mode)) +(add-to-list 'auto-mode-alist '("\\.lua$" . lua-mode)) +(add-to-list 'auto-mode-alist '("\\.php[345]?$" . php-mode)) +(add-to-list 'auto-mode-alist '("\\.js\\(on\\)?$" . js-mode)) +(add-to-list 'auto-mode-alist '("CMakeLists\\.txt$" . cmake-mode)) +(add-to-list 'auto-mode-alist '("\\.cmake$" . cmake-mode)) +(add-to-list 'auto-mode-alist '("\\.css$" . css-mode)) +(add-to-list 'auto-mode-alist '("stumpwmrc" . stumpwm-mode)) +(add-to-list 'auto-mode-alist '(".*mutt.*" . message-mode)) +(add-to-list 'auto-mode-alist '("COMMIT_EDITMSG$" . git-commit-mode)) + +(add-to-list 'file-coding-system-alist '("\\.vala$" . utf-8)) +(add-to-list 'file-coding-system-alist '("\\.vapi$" . utf-8)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; KEYBINDS ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(global-set-key "\C-m" 'newline-and-indent) +(global-set-key (kbd "C-x n r") 'narrow-to-region) +(global-set-key [f5] '(lambda () + (interactive) + (revert-buffer nil t nil))) +(global-set-key [M-left] 'windmove-left) +(global-set-key [M-right] 'windmove-right) +(global-set-key [M-up] 'windmove-up) +(global-set-key [M-down] 'windmove-down) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; HOOKS ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(add-hook 'before-save-hook 'on-before-save) +(add-hook 'after-save-hook 'on-after-save) +(add-hook 'prog-mode-hook 'on-prog-mode) +(add-hook 'c-mode-hook 'on-c-mode) +(add-hook 'html-mode-hook 'on-html-mode) +(add-hook 'php-mode-hook 'on-php-mode) +(add-hook 'message-mode-hook 'on-mail-mode) +(add-hook 'git-commit-mode-hook 'auto-fill-mode) +(add-hook 'css-mode-hook 'rainbow-mode) +(add-hook 'after-make-frame-functions 'setup-system-frame-colours t) + +(add-hook 'gtags-mode-hook + (lambda () + (local-set-key (kbd "M-,") 'gtags-find-tag) ; find a tag, + ; also M-. + (local-set-key (kbd "M-.") 'gtags-find-rtag))) ; reverse + ; tag + +(add-hook 'c-mode-common-hook + (lambda () + (require 'gtags) + (gtags-mode t) + (djcb-gtags-create-or-update))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; SKELETONS ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define-skeleton cmake-project-skeleton + "A cmake project template file" + "Name: " + "cmake_minimum_required(VERSION 2.6)\n" + "project(" str ")\n" + "\n" + "set(" str "_VERSION_MAJOR 0)\n" + "set(" str "_VERSION_MINOR 0)\n" + "set(" str "_VERSION_PATCH 0)\n" + "\n" + "set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} ${PROJECT_SOURCE_DIR})\n" + "add_subdirectory(src)") + +(define-skeleton myaethon-set-varchar-docstring + "A docstring for a varchar setter" + "" + "\/* Setter for the " + (skeleton-read "name: ") + " column\n" + "\n" + '(indent-according-to-mode) + "$value: string, no longer than " + (skeleton-read "len: ") + " characters */" + '(fill-paragraph)) + +(define-skeleton myaethon-set-array-varchar-docstring + "A docstring for an array/varchar setter" + "" + '(setq name (skeleton-read "name: ")) + '(setq len (string-to-number (skeleton-read "length: "))) + '(setq size (floor (/ (- len 1) 2))) + "/* Setter for the " + name + " column\n" + "\n" + '(indent-according-to-mode) + "$value: array, with no more than " + (number-to-string size) + " elements; string, no langer than " + (number-to-string len) + " characters */" + '(fill-paragraph)) + +(define-skeleton myaethon-simple-entity + "A basic database entity" + "" + '(setq name (skeleton-read "Name: ")) + "<?php\n" + "require_once('classes/dbobject.php');\n" + "\n" + "/* Entity for the " (downcase name) " table */\n" + "class " name " extends DB_Object\n" + "{\n" + "/* Table to select data from */\n" + "protected static $tables = '" (downcase name) "';\n" + "\n" + "/* Get the name of this class\n" + "--\n" + "ret: __CLASS__ */\n" + "protected static function get_class_name()\n" + "{\n" + "return __CLASS__;\n" + "}\n" + "\n" + "public function update()\n" + "{\n" + "throw new Exception('Not Implemented.');\n" + "}\n" + "\n" + "public function insert()\n" + "{\n" + "throw new Exception('Not Implemented.');\n" + "}\n" + "}\n" + "\n" + "?>\n" + '(indent-region (point-min) (point-max))) + +(ad-activate 'server-create-window-system-frame) +(add-php-keywords) +(add-html-keywords) +(make-face 'font-lock-operator-face) +(make-face 'font-lock-end-statement) +(set-face-foreground 'font-lock-operator-face "#EDD400") +(set-face-foreground 'font-lock-end-statement "#888A85") + +;; Custom file +(setq custom-file "~/.emacs.d/custom.el") +(load custom-file) diff --git a/.emacs.d/naquadah-theme b/.emacs.d/naquadah-theme new file mode 160000 +Subproject d3099fbe63d5f7c3419f65d8050710065aab055 diff --git a/.emacs.d/ryuslash-load-path.el b/.emacs.d/ryuslash-load-path.el new file mode 100644 index 0000000..984c136 --- /dev/null +++ b/.emacs.d/ryuslash-load-path.el @@ -0,0 +1,10 @@ +(add-to-list 'load-path "~/.emacs.d/elisp") +(add-to-list 'load-path "~/.emacs.d/elisp/git-commit-mode") +(add-to-list 'load-path "~/.emacs.d/elisp/lua-mode") +(add-to-list 'load-path "~/.emacs.d/elisp/markdown-mode") +(add-to-list 'load-path "~/.emacs.d/elisp/pi-php-mode") +(add-to-list 'load-path "~/.emacs.d/elisp/rainbow") +(add-to-list 'load-path "~/.emacs.d/elisp/rainbow-delimiters") +(add-to-list 'load-path "~/.emacs.d/elisp/zencoding") + +(provide 'ryuslash-load-path) |