diff options
Diffstat (limited to '.emacs.d/elisp')
-rw-r--r-- | .emacs.d/elisp/autopair.el | 1069 | ||||
-rw-r--r-- | .emacs.d/elisp/autosmiley.el | 95 | ||||
-rw-r--r-- | .emacs.d/elisp/batch-mode.el | 156 | ||||
-rw-r--r-- | .emacs.d/elisp/cmake-mode.el | 339 | ||||
-rw-r--r-- | .emacs.d/elisp/column-marker.el | 259 | ||||
-rw-r--r-- | .emacs.d/elisp/functions.el | 45 | ||||
m--------- | .emacs.d/elisp/git-commit-mode | 0 | ||||
-rw-r--r-- | .emacs.d/elisp/git.el | 1705 | ||||
-rw-r--r-- | .emacs.d/elisp/go-mode.el | 544 | ||||
-rw-r--r-- | .emacs.d/elisp/graphviz-dot-mode.el | 946 | ||||
-rw-r--r-- | .emacs.d/elisp/htmlize.el | 1671 | ||||
-rw-r--r-- | .emacs.d/elisp/ide-skel.el | 4016 | ||||
-rw-r--r-- | .emacs.d/elisp/lcars-theme.el | 417 | ||||
m--------- | .emacs.d/elisp/markdown-mode | 0 | ||||
m--------- | .emacs.d/elisp/php-mode | 0 | ||||
m--------- | .emacs.d/elisp/rainbow | 0 | ||||
m--------- | .emacs.d/elisp/rainbow-delimiters | 0 | ||||
-rw-r--r-- | .emacs.d/elisp/sqlplus.el | 5151 | ||||
-rw-r--r-- | .emacs.d/elisp/tabbar.el | 1932 | ||||
-rw-r--r-- | .emacs.d/elisp/xmodmap-mode.el | 9 |
20 files changed, 0 insertions, 18354 deletions
diff --git a/.emacs.d/elisp/autopair.el b/.emacs.d/elisp/autopair.el deleted file mode 100644 index ba322e3..0000000 --- a/.emacs.d/elisp/autopair.el +++ /dev/null @@ -1,1069 +0,0 @@ -;;; 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/autosmiley.el b/.emacs.d/elisp/autosmiley.el deleted file mode 100644 index 1037e43..0000000 --- a/.emacs.d/elisp/autosmiley.el +++ /dev/null @@ -1,95 +0,0 @@ -;;; autosmiley.el --- Convert smileys into their graphical representation - -;; Author: Damyan Pepper (gmail account, username damyanp) -;; Created: 20060315 - -;; 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, you can either send email to this -;; program's maintainer or write to: The Free Software Foundation, -;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Defines the minor mode autosmiley-mode that converts smileys like -;; :-) into their graphical representations on the fly. - -;; Tested on: -;; -;; GNU Emacs 22.0.50.1 (i386-mingw-nt5.1.2600) of 2006-03-14 on W2ONE -;; -;; History: -;; -;; 20060315 - First Release - - - -(require 'smiley) - -(defun autosmiley-overlay-p (overlay) - "Return whether OVERLAY is an overlay of autosmiley mode." - (memq (overlay-get overlay 'category) - '(autosmiley))) - -(defun autosmiley-remove-smileys (beg end) - (dolist (o (overlays-in beg end)) - (when (autosmiley-overlay-p o) - (delete-overlay o)))) - -(defvar *autosmiley-counter* 0 - "Each smiley needs to have a unique display string otherwise - adjacent smileys will be merged into a single image. So we put - a counter on each one to make them unique") - -(defun autosmiley-add-smiley (beg end image) - (let ((overlay (make-overlay beg end))) - (overlay-put overlay 'category 'autosmiley) - (overlay-put overlay 'display (append image (list :counter (incf *autosmiley-counter*)))))) - - -(defun autosmiley-add-smileys (beg end) - (save-excursion - (dolist (entry smiley-cached-regexp-alist) - (let ((regexp (car entry)) - (group (nth 1 entry)) - (image (nth 2 entry))) - (when image - (goto-char beg) - (while (re-search-forward regexp end t) - (autosmiley-add-smiley (match-beginning group) (match-end group) image))))))) - - -(defun autosmiley-change (beg end &optional old-len) - (let ((beg-line (save-excursion (goto-char beg) (line-beginning-position))) - (end-line (save-excursion (goto-char end) (line-end-position)))) - (autosmiley-remove-smileys beg-line end-line) - (autosmiley-add-smileys beg-line end-line))) - - -;;;###autoload -(define-minor-mode autosmiley-mode - "Minor mode for automatically replacing smileys in text with -cute little graphical smileys." - :group 'autosmiley :lighter " :)" - (save-excursion - (save-restriction - (widen) - (autosmiley-remove-smileys (point-min) (point-max)) - (if autosmiley-mode - (progn - (unless smiley-cached-regexp-alist - (smiley-update-cache)) - (jit-lock-register 'autosmiley-change)) - (jit-lock-unregister 'autosmiley-change))))) - - -(provide 'autosmiley) diff --git a/.emacs.d/elisp/batch-mode.el b/.emacs.d/elisp/batch-mode.el deleted file mode 100644 index dcc156a..0000000 --- a/.emacs.d/elisp/batch-mode.el +++ /dev/null @@ -1,156 +0,0 @@ -;;; 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 deleted file mode 100644 index 2f51f83..0000000 --- a/.emacs.d/elisp/cmake-mode.el +++ /dev/null @@ -1,339 +0,0 @@ -;============================================================================= -; 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 deleted file mode 100644 index 97a7d07..0000000 --- a/.emacs.d/elisp/column-marker.el +++ /dev/null @@ -1,259 +0,0 @@ -;;; 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/functions.el b/.emacs.d/elisp/functions.el deleted file mode 100644 index 6472c82..0000000 --- a/.emacs.d/elisp/functions.el +++ /dev/null @@ -1,45 +0,0 @@ -(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 deleted file mode 160000 -Subproject ec88948e06f787fcc1c3b9951930ef00b25d0b8 diff --git a/.emacs.d/elisp/git.el b/.emacs.d/elisp/git.el deleted file mode 100644 index 65c95d9..0000000 --- a/.emacs.d/elisp/git.el +++ /dev/null @@ -1,1705 +0,0 @@ -;;; 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 deleted file mode 100644 index 0551a06..0000000 --- a/.emacs.d/elisp/go-mode.el +++ /dev/null @@ -1,544 +0,0 @@ -;;; 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 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 '("append" "cap" "close" "complex" "copy" "imag" "len" - "make" "new" "panic" "print" "println" "real" "recover")) - (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 - ;; assume that labels are alone on the line - (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 deleted file mode 100644 index 6691d0e..0000000 --- a/.emacs.d/elisp/graphviz-dot-mode.el +++ /dev/null @@ -1,946 +0,0 @@ -;;; 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 deleted file mode 100644 index 2b1d9a7..0000000 --- a/.emacs.d/elisp/htmlize.el +++ /dev/null @@ -1,1671 +0,0 @@ -;; 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 deleted file mode 100644 index 90be871..0000000 --- a/.emacs.d/elisp/ide-skel.el +++ /dev/null @@ -1,4016 +0,0 @@ -;; 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 deleted file mode 100644 index c271381..0000000 --- a/.emacs.d/elisp/lcars-theme.el +++ /dev/null @@ -1,417 +0,0 @@ -;;; 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") - (lcars-column-1 . "#666864") - (lcars-column-2 . "#555753") - (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)) - - ;; column-marker - '(column-marker-1 (:background lcars-column-1)) - '(column-marker-2 (:background lcars-column-2))) - -(provide-theme 'lcars) - -;; Local Variables: -;; no-byte-compile: t -;; End: - -;;; lcars-theme.el ends here diff --git a/.emacs.d/elisp/markdown-mode b/.emacs.d/elisp/markdown-mode deleted file mode 160000 -Subproject 3e2f122e4efd06a17987e75e0e82cde1406040f diff --git a/.emacs.d/elisp/php-mode b/.emacs.d/elisp/php-mode deleted file mode 160000 -Subproject 1586fbbb0886c55d1461acd1ee96854b8f20b80 diff --git a/.emacs.d/elisp/rainbow b/.emacs.d/elisp/rainbow deleted file mode 160000 -Subproject 0fd92f979a6f987e1080faa65681b8e54735a90 diff --git a/.emacs.d/elisp/rainbow-delimiters b/.emacs.d/elisp/rainbow-delimiters deleted file mode 160000 -Subproject 779b40f39dd3a0914bafa363ed4d6c14c759671 diff --git a/.emacs.d/elisp/sqlplus.el b/.emacs.d/elisp/sqlplus.el deleted file mode 100644 index 4d5e7d7..0000000 --- a/.emacs.d/elisp/sqlplus.el +++ /dev/null @@ -1,5151 +0,0 @@ -;;; 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/tabbar.el b/.emacs.d/elisp/tabbar.el deleted file mode 100644 index 09db712..0000000 --- a/.emacs.d/elisp/tabbar.el +++ /dev/null @@ -1,1932 +0,0 @@ -;;; Tabbar.el --- Display a tab bar in the header line - -;; Copyright (C) 2003, 2004, 2005 David Ponce - -;; Author: David Ponce <david@dponce.com> -;; Maintainer: David Ponce <david@dponce.com> -;; Created: 25 February 2003 -;; Keywords: convenience -;; Revision: $Id: tabbar.el,v 1.69 2006/06/08 08:27:39 ponced Exp $ - -(defconst tabbar-version "2.0") - -;; This file is not part of GNU Emacs. - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. - -;;; Commentary: -;; -;; This library provides the Tabbar global minor mode to display a tab -;; bar in the header line of Emacs 21 and later versions. You can use -;; the mouse to click on a tab and select it. Also, three buttons are -;; displayed on the left side of the tab bar in this order: the -;; "home", "scroll left", and "scroll right" buttons. The "home" -;; button is a general purpose button used to change something on the -;; tab bar. The scroll left and scroll right buttons are used to -;; scroll tabs horizontally. Tabs can be divided up into groups to -;; maintain several sets of tabs at the same time (see also the -;; chapter "Core" below for more details on tab grouping). Only one -;; group is displayed on the tab bar, and the "home" button, for -;; example, can be used to navigate through the different groups, to -;; show different tab bars. -;; -;; In a graphic environment, using the mouse is probably the preferred -;; way to work with the tab bar. However, you can also use the tab -;; bar when Emacs is running on a terminal, so it is possible to use -;; commands to press special buttons, or to navigate cyclically -;; through tabs. -;; -;; These commands, and default keyboard shortcuts, are provided: -;; -;; `tabbar-mode' -;; Toggle the Tabbar global minor mode. When enabled a tab bar is -;; displayed in the header line. -;; -;; `tabbar-local-mode' (C-c <C-f10>) -;; Toggle the Tabbar-Local minor mode. Provided the global minor -;; mode is turned on, the tab bar becomes local in the current -;; buffer when the local minor mode is enabled. This permits to -;; see the tab bar in a buffer where the header line is already -;; used by another mode (like `Info-mode' for example). -;; -;; `tabbar-mwheel-mode' -;; Toggle the Tabbar-Mwheel global minor mode. When enabled you -;; can use the mouse wheel to navigate through tabs of groups. -;; -;; `tabbar-press-home' (C-c <C-home>) -;; `tabbar-press-scroll-left' (C-c <C-prior>) -;; `tabbar-press-scroll-right' (C-c <C-next>) -;; Simulate a mouse-1 click on respectively the "home", "scroll -;; left", and "scroll right" buttons. A numeric prefix argument -;; value of 2, or 3, respectively simulates a mouse-2, or mouse-3 -;; click. -;; -;; `tabbar-backward' (C-c <C-left>) -;; `tabbar-forward' (C-c <C-right>) -;; Are the basic commands to navigate cyclically through tabs or -;; groups of tabs. The cycle is controlled by the -;; `tabbar-cycle-scope' option. The default is to navigate -;; through all tabs across all existing groups of tabs. You can -;; change the default behavior to navigate only through the tabs -;; visible on the tab bar, or through groups of tabs only. Or use -;; the more specialized commands below. -;; -;; `tabbar-backward-tab' -;; `tabbar-forward-tab' -;; Navigate through the tabs visible on the tab bar. -;; -;; `tabbar-backward-group' (C-c <C-up>) -;; `tabbar-forward-group' (C-c <C-down>) -;; Navigate through existing groups of tabs. -;; -;; -;; Core -;; ---- -;; -;; The content of the tab bar is represented by an internal data -;; structure: a tab set. A tab set is a collection (group) of tabs, -;; identified by an unique name. In a tab set, at any time, one and -;; only one tab is designated as selected within the tab set. -;; -;; A tab is a simple data structure giving the value of the tab, and a -;; reference to its tab set container. A tab value can be any Lisp -;; object. Each tab object is guaranteed to be unique. -;; -;; A tab set is displayed on the tab bar through a "view" defined by -;; the index of the leftmost tab shown. Thus, it is possible to -;; scroll the tab bar horizontally by changing the start index of the -;; tab set view. -;; -;; The visual representation of a tab bar is a list of valid -;; `header-line-format' template elements, one for each special -;; button, and for each tab found into a tab set "view". When the -;; visual representation of a tab is required, the function specified -;; in the variable `tabbar-tab-label-function' is called to obtain it. -;; The visual representation of a special button is obtained by -;; calling the function specified in `tabbar-button-label-function', -;; which is passed a button name among `home', `scroll-left', or -;; `scroll-right'. There are also options and faces to customize the -;; appearance of buttons and tabs (see the code for more details). -;; -;; When the mouse is over a tab, the function specified in -;; `tabbar-help-on-tab-function' is called, which is passed the tab -;; and should return a help string to display. When a tab is -;; selected, the function specified in `tabbar-select-tab-function' is -;; called, which is passed the tab and the event received. -;; -;; Similarly, to control the behavior of the special buttons, the -;; following variables are available, for respectively the `home', -;; `scroll-left' and `scroll-right' value of `<button>': -;; -;; `tabbar-<button>-function' -;; Function called when <button> is selected. The function is -;; passed the mouse event received. -;; -;; `tabbar-<button>-help-function' -;; Function called with no arguments to obtain a help string -;; displayed when the mouse is over <button>. -;; -;; To increase performance, each tab set automatically maintains its -;; visual representation in a cache. As far as possible, the cache is -;; used to display the tab set, and refreshed only when necessary. -;; -;; Several tab sets can be maintained at the same time. Only one is -;; displayed on the tab bar, it is obtained by calling the function -;; specified in the variable `tabbar-current-tabset-function'. -;; -;; A special tab set is maintained, that contains the list of the -;; currently selected tabs in the existing tab sets. This tab set is -;; useful to show the existing tab sets in a tab bar, and switch -;; between them easily. The function `tabbar-get-tabsets-tabset' -;; returns this special tab set. -;; -;; -;; Buffer tabs -;; ----------- -;; -;; The default tab bar implementation provided displays buffers in -;; dedicated tabs. Selecting a tab, switch (mouse-1), or pop -;; (mouse-2), to the buffer it contains. -;; -;; The list of buffers put in tabs is provided by the function -;; specified in the variable `tabbar-buffer-list-function'. The -;; default function: `tabbar-buffer-list', excludes buffers whose name -;; starts with a space, when they are not visiting a file. -;; -;; Buffers are organized in groups, each one represented by a tab set. -;; A buffer can have no group, or belong to more than one group. The -;; function specified by the variable `tabbar-buffer-groups-function' -;; is called for each buffer to obtain the groups it belongs to. The -;; default function provided: `tabbar-buffer-groups' organizes buffers -;; depending on their major mode (see that function for details). -;; -;; The "home" button toggles display of buffer groups on the tab bar, -;; allowing to easily show another buffer group by clicking on the -;; associated tab. -;; -;; Known problems: -;; -;; Bug item #858306 at <http://sf.net/tracker/?group_id=79309>: -;; tabbar-mode crashes GNU Emacs 21.3 on MS-Windows 98/95. -;; - -;;; History: -;; - -;;; Code: - -;;; Options -;; -(defgroup tabbar nil - "Display a tab bar in the header line." - :group 'convenience) - -(defcustom tabbar-cycle-scope nil - "*Specify the scope of cyclic navigation through tabs. -The following scopes are possible: - -- `tabs' - Navigate through visible tabs only. -- `groups' - Navigate through tab groups only. -- default - Navigate through visible tabs, then through tab groups." - :group 'tabbar - :type '(choice :tag "Cycle through..." - (const :tag "Visible Tabs Only" tabs) - (const :tag "Tab Groups Only" groups) - (const :tag "Visible Tabs then Tab Groups" nil))) - -(defcustom tabbar-auto-scroll-flag t - "*Non-nil means to automatically scroll the tab bar. -That is, when a tab is selected outside of the tab bar visible area, -the tab bar is scrolled horizontally so the selected tab becomes -visible." - :group 'tabbar - :type 'boolean) - -(defvar tabbar-inhibit-functions '(tabbar-default-inhibit-function) - "List of functions to be called before displaying the tab bar. -Those functions are called one by one, with no arguments, until one of -them returns a non-nil value, and thus, prevents to display the tab -bar.") - -(defvar tabbar-current-tabset-function nil - "Function called with no argument to obtain the current tab set. -This is the tab set displayed on the tab bar.") - -(defvar tabbar-tab-label-function nil - "Function that obtains a tab label displayed on the tab bar. -The function is passed a tab and should return a string.") - -(defvar tabbar-select-tab-function nil - "Function that select a tab. -The function is passed a mouse event and a tab, and should make it the -selected tab.") - -(defvar tabbar-help-on-tab-function nil - "Function to obtain a help string for a tab. -The help string is displayed when the mouse is onto the button. The -function is passed the tab and should return a help string or nil for -none.") - -(defvar tabbar-button-label-function nil - "Function that obtains a button label displayed on the tab bar. -The function is passed a button name should return a propertized -string to display.") - -(defvar tabbar-home-function nil - "Function called when clicking on the tab bar home button. -The function is passed the mouse event received.") - -(defvar tabbar-home-help-function nil - "Function to obtain a help string for the tab bar home button. -The help string is displayed when the mouse is onto the button. -The function is called with no arguments.") - -(defvar tabbar-scroll-left-function 'tabbar-scroll-left - "Function that scrolls tabs on left. -The function is passed the mouse event received when clicking on the -scroll left button. It should scroll the current tab set.") - -(defvar tabbar-scroll-left-help-function 'tabbar-scroll-left-help - "Function to obtain a help string for the scroll left button. -The help string is displayed when the mouse is onto the button. -The function is called with no arguments.") - -(defvar tabbar-scroll-right-function 'tabbar-scroll-right - "Function that scrolls tabs on right. -The function is passed the mouse event received when clicking on the -scroll right button. It should scroll the current tab set.") - -(defvar tabbar-scroll-right-help-function 'tabbar-scroll-right-help - "Function to obtain a help string for the scroll right button. -The help string is displayed when the mouse is onto the button. -The function is called with no arguments.") - -;;; Misc. -;; -(eval-and-compile - (defalias 'tabbar-display-update - (if (fboundp 'force-window-update) - #'(lambda () (force-window-update (selected-window))) - 'force-mode-line-update))) - -(defsubst tabbar-click-p (event) - "Return non-nil if EVENT is a mouse click event." - (memq 'click (event-modifiers event))) - -(defun tabbar-shorten (str width) - "Return a shortened string from STR that fits in the given display WIDTH. -WIDTH is specified in terms of character display width in the current -buffer; see also `char-width'. If STR display width is greater than -WIDTH, STR is truncated and an ellipsis string \"...\" is inserted at -end or in the middle of the returned string, depending on available -room." - (let* ((n (length str)) - (sw (string-width str)) - (el "...") - (ew (string-width el)) - (w 0) - (i 0)) - (cond - ;; STR fit in WIDTH, return it. - ((<= sw width) - str) - ;; There isn't enough room for the ellipsis, STR is just - ;; truncated to fit in WIDTH. - ((<= width ew) - (while (< w width) - (setq w (+ w (char-width (aref str i))) - i (1+ i))) - (substring str 0 i)) - ;; There isn't enough room to insert the ellipsis in the middle - ;; of the truncated string, so put the ellipsis at end. - ((zerop (setq sw (/ (- width ew) 2))) - (setq width (- width ew)) - (while (< w width) - (setq w (+ w (char-width (aref str i))) - i (1+ i))) - (concat (substring str 0 i) el)) - ;; Put the ellipsis in the middle of the truncated string. - (t - (while (< w sw) - (setq w (+ w (char-width (aref str i))) - i (1+ i))) - (setq w (+ w ew)) - (while (< w width) - (setq n (1- n) - w (+ w (char-width (aref str n))))) - (concat (substring str 0 i) el (substring str n))) - ))) - -;;; Tab and tab set -;; -(defsubst tabbar-make-tab (object tabset) - "Return a new tab with value OBJECT. -TABSET is the tab set the tab belongs to." - (cons object tabset)) - -(defsubst tabbar-tab-value (tab) - "Return the value of tab TAB." - (car tab)) - -(defsubst tabbar-tab-tabset (tab) - "Return the tab set TAB belongs to." - (cdr tab)) - -(defvar tabbar-tabsets nil - "The tab sets store.") - -(defvar tabbar-tabsets-tabset nil - "The special tab set of existing tab sets.") - -(defvar tabbar-current-tabset nil - "The tab set currently displayed on the tab bar.") -(make-variable-buffer-local 'tabbar-current-tabset) - -(defvar tabbar-init-hook nil - "Hook run after tab bar data has been initialized. -You should use this hook to initialize dependent data.") - -(defsubst tabbar-init-tabsets-store () - "Initialize the tab set store." - (setq tabbar-tabsets (make-vector 31 0) - tabbar-tabsets-tabset (make-symbol "tabbar-tabsets-tabset")) - (put tabbar-tabsets-tabset 'start 0) - (run-hooks 'tabbar-init-hook)) - -(defvar tabbar-quit-hook nil - "Hook run after tab bar data has been freed. -You should use this hook to reset dependent data.") - -(defsubst tabbar-free-tabsets-store () - "Free the tab set store." - (setq tabbar-tabsets nil - tabbar-tabsets-tabset nil) - (run-hooks 'tabbar-quit-hook)) - -;; Define an "hygienic" function free of side effect between its local -;; variables and those of the callee. -(eval-and-compile - (defalias 'tabbar-map-tabsets - (let ((function (make-symbol "function")) - (result (make-symbol "result")) - (tabset (make-symbol "tabset"))) - `(lambda (,function) - "Apply FUNCTION to each tab set, and make a list of the results. -The result is a list just as long as the number of existing tab sets." - (let (,result) - (mapatoms - #'(lambda (,tabset) - (push (funcall ,function ,tabset) ,result)) - tabbar-tabsets) - ,result))))) - -(defun tabbar-make-tabset (name &rest objects) - "Make a new tab set whose name is the string NAME. -It is initialized with tabs build from the list of OBJECTS." - (let* ((tabset (intern name tabbar-tabsets)) - (tabs (mapcar #'(lambda (object) - (tabbar-make-tab object tabset)) - objects))) - (set tabset tabs) - (put tabset 'select (car tabs)) - (put tabset 'start 0) - tabset)) - -(defsubst tabbar-get-tabset (name) - "Return the tab set whose name is the string NAME. -Return nil if not found." - (intern-soft name tabbar-tabsets)) - -(defsubst tabbar-delete-tabset (tabset) - "Delete the tab set TABSET. -That is, remove it from the tab sets store." - (unintern tabset tabbar-tabsets)) - -(defsubst tabbar-tabs (tabset) - "Return the list of tabs in TABSET." - (symbol-value tabset)) - -(defsubst tabbar-tab-values (tabset) - "Return the list of tab values in TABSET." - (mapcar 'tabbar-tab-value (tabbar-tabs tabset))) - -(defsubst tabbar-get-tab (object tabset) - "Search for a tab with value OBJECT in TABSET. -Return the tab found, or nil if not found." - (assoc object (tabbar-tabs tabset))) - -(defsubst tabbar-member (tab tabset) - "Return non-nil if TAB is in TABSET." - (or (eq (tabbar-tab-tabset tab) tabset) - (memq tab (tabbar-tabs tabset)))) - -(defsubst tabbar-template (tabset) - "Return the cached visual representation of TABSET. -That is, a `header-line-format' template, or nil if the cache is -empty." - (get tabset 'template)) - -(defsubst tabbar-set-template (tabset template) - "Set the cached visual representation of TABSET to TEMPLATE. -TEMPLATE must be a valid `header-line-format' template, or nil to -cleanup the cache." - (put tabset 'template template)) - -(defsubst tabbar-selected-tab (tabset) - "Return the tab selected in TABSET." - (get tabset 'select)) - -(defsubst tabbar-selected-value (tabset) - "Return the value of the tab selected in TABSET." - (tabbar-tab-value (tabbar-selected-tab tabset))) - -(defsubst tabbar-selected-p (tab tabset) - "Return non-nil if TAB is the selected tab in TABSET." - (eq tab (tabbar-selected-tab tabset))) - -(defvar tabbar--track-selected nil) - -(defsubst tabbar-select-tab (tab tabset) - "Make TAB the selected tab in TABSET. -Does nothing if TAB is not found in TABSET. -Return TAB if selected, nil if not." - (when (tabbar-member tab tabset) - (unless (tabbar-selected-p tab tabset) - (tabbar-set-template tabset nil) - (setq tabbar--track-selected tabbar-auto-scroll-flag)) - (put tabset 'select tab))) - -(defsubst tabbar-select-tab-value (object tabset) - "Make the tab with value OBJECT, the selected tab in TABSET. -Does nothing if a tab with value OBJECT is not found in TABSET. -Return the tab selected, or nil if nothing was selected." - (tabbar-select-tab (tabbar-get-tab object tabset) tabset)) - -(defsubst tabbar-start (tabset) - "Return the index of the first visible tab in TABSET." - (get tabset 'start)) - -(defsubst tabbar-view (tabset) - "Return the list of visible tabs in TABSET. -That is, the sub-list of tabs starting at the first visible one." - (nthcdr (tabbar-start tabset) (tabbar-tabs tabset))) - -(defun tabbar-add-tab (tabset object &optional append) - "Add to TABSET a tab with value OBJECT if there isn't one there yet. -If the tab is added, it is added at the beginning of the tab list, -unless the optional argument APPEND is non-nil, in which case it is -added at the end." - (let ((tabs (tabbar-tabs tabset))) - (if (tabbar-get-tab object tabset) - tabs - (let ((tab (tabbar-make-tab object tabset))) - (tabbar-set-template tabset nil) - (set tabset (if append - (append tabs (list tab)) - (cons tab tabs))))))) - -(defun tabbar-delete-tab (tab) - "Remove TAB from its tab set." - (let* ((tabset (tabbar-tab-tabset tab)) - (tabs (tabbar-tabs tabset)) - (sel (eq tab (tabbar-selected-tab tabset))) - (next (and sel (cdr (memq tab tabs))))) - (tabbar-set-template tabset nil) - (setq tabs (delq tab tabs)) - ;; When the selected tab is deleted, select the next one, if - ;; available, or the last one otherwise. - (and sel (tabbar-select-tab (car (or next (last tabs))) tabset)) - (set tabset tabs))) - -(defun tabbar-scroll (tabset count) - "Scroll the visible tabs in TABSET of COUNT units. -If COUNT is positive move the view on right. If COUNT is negative, -move the view on left." - (let ((start (min (max 0 (+ (tabbar-start tabset) count)) - (1- (length (tabbar-tabs tabset)))))) - (when (/= start (tabbar-start tabset)) - (tabbar-set-template tabset nil) - (put tabset 'start start)))) - -(defun tabbar-tab-next (tabset tab &optional before) - "Search in TABSET for the tab after TAB. -If optional argument BEFORE is non-nil, search for the tab before -TAB. Return the tab found, or nil otherwise." - (let* (last (tabs (tabbar-tabs tabset))) - (while (and tabs (not (eq tab (car tabs)))) - (setq last (car tabs) - tabs (cdr tabs))) - (and tabs (if before last (nth 1 tabs))))) - -(defun tabbar-current-tabset (&optional update) - "Return the tab set currently displayed on the tab bar. -If optional argument UPDATE is non-nil, call the user defined function -`tabbar-current-tabset-function' to obtain it. Otherwise return the -current cached copy." - (and update tabbar-current-tabset-function - (setq tabbar-current-tabset - (funcall tabbar-current-tabset-function))) - tabbar-current-tabset) - -(defun tabbar-get-tabsets-tabset () - "Return the tab set of selected tabs in existing tab sets." - (set tabbar-tabsets-tabset (tabbar-map-tabsets 'tabbar-selected-tab)) - (tabbar-scroll tabbar-tabsets-tabset 0) - (tabbar-set-template tabbar-tabsets-tabset nil) - tabbar-tabsets-tabset) - -;;; Faces -;; -(defface tabbar-default - '( - ;;(((class color grayscale) (background light)) - ;; :inherit variable-pitch - ;; :height 0.8 - ;; :foreground "gray50" - ;; :background "grey75" - ;; ) - (((class color grayscale) (background dark)) - :inherit variable-pitch - :height 0.8 - :foreground "grey75" - :background "gray50" - ) - (((class mono) (background light)) - :inherit variable-pitch - :height 0.8 - :foreground "black" - :background "white" - ) - (((class mono) (background dark)) - :inherit variable-pitch - :height 0.8 - :foreground "white" - :background "black" - ) - (t - :inherit variable-pitch - :height 0.8 - :foreground "gray50" - :background "gray75" - )) - "Default face used in the tab bar." - :group 'tabbar) - -(defface tabbar-unselected - '((t - :inherit tabbar-default - :box (:line-width 1 :color "white" :style released-button) - )) - "Face used for unselected tabs." - :group 'tabbar) - -(defface tabbar-selected - '((t - :inherit tabbar-default - :box (:line-width 1 :color "white" :style pressed-button) - :foreground "blue" - )) - "Face used for the selected tab." - :group 'tabbar) - -(defface tabbar-highlight - '((t - :underline t - )) - "Face used to highlight a tab during mouse-overs." - :group 'tabbar) - -(defface tabbar-separator - '((t - :inherit tabbar-default - :height 0.1 - )) - "Face used for separators between tabs." - :group 'tabbar) - -(defface tabbar-button - '((t - :inherit tabbar-default - :box (:line-width 1 :color "white" :style released-button) - :foreground "dark red" - )) - "Face used for tab bar buttons." - :group 'tabbar) - -(defface tabbar-button-highlight - '((t - :inherit tabbar-default - )) - "Face used to highlight a button during mouse-overs." - :group 'tabbar) - -(defcustom tabbar-background-color nil - "*Background color of the tab bar. -By default, use the background color specified for the -`tabbar-default' face (or inherited from another face), or the -background color of the `default' face otherwise." - :group 'tabbar - :type '(choice (const :tag "Default" nil) - (color))) - -(defsubst tabbar-background-color () - "Return the background color of the tab bar." - (or tabbar-background-color - (let* ((face 'tabbar-default) - (color (face-background face))) - (while (null color) - (or (facep (setq face (face-attribute face :inherit))) - (setq face 'default)) - (setq color (face-background face))) - color))) - -;;; Buttons and separator look and feel -;; -(defconst tabbar-button-widget - '(cons - (cons :tag "Enabled" - (string) - (repeat :tag "Image" - :extra-offset 2 - (restricted-sexp :tag "Spec" - :match-alternatives (listp)))) - (cons :tag "Disabled" - (string) - (repeat :tag "Image" - :extra-offset 2 - (restricted-sexp :tag "Spec" - :match-alternatives (listp)))) - ) - "Widget for editing a tab bar button. -A button is specified as a pair (ENABLED-BUTTON . DISABLED-BUTTON), -where ENABLED-BUTTON and DISABLED-BUTTON specify the value used when -the button is respectively enabled and disabled. Each button value is -a pair (STRING . IMAGE) where STRING is a string value, and IMAGE a -list of image specifications. -If IMAGE is non-nil, try to use that image, else use STRING. -If only the ENABLED-BUTTON image is provided, a DISABLED-BUTTON image -is derived from it.") - -;;; Home button -;; -(defvar tabbar-home-button-value nil - "Value of the home button.") - -(defconst tabbar-home-button-enabled-image - '((:type pbm :data "\ -P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 0 -6 0 255 255 255 255 255 255 255 255 255 255 9 130 9 255 255 255 255 -255 255 255 255 255 255 26 130 26 255 255 255 255 255 255 255 0 9 26 -41 130 41 26 9 0 255 255 255 255 5 145 140 135 130 125 120 115 5 255 -255 255 255 0 9 26 41 130 41 26 9 0 255 255 255 255 255 255 255 26 130 -26 255 255 255 255 255 255 255 255 255 255 9 130 9 255 255 255 255 255 -255 255 255 255 255 0 6 0 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 -")) - "Default image for the enabled home button.") - -(defconst tabbar-home-button-disabled-image - '((:type pbm :data "\ -P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 0 0 1 2 3 2 1 0 0 255 255 255 255 0 132 128 123 119 114 110 -106 0 255 255 255 255 0 0 1 2 3 2 1 0 0 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 255 -")) - "Default image for the disabled home button.") - -(defcustom tabbar-home-button - (cons (cons "[o]" tabbar-home-button-enabled-image) - (cons "[x]" tabbar-home-button-disabled-image)) - "The home button. -The variable `tabbar-button-widget' gives details on this widget." - :group 'tabbar - :type tabbar-button-widget - :set '(lambda (variable value) - (custom-set-default variable value) - ;; Schedule refresh of button value. - (setq tabbar-home-button-value nil))) - -;;; Scroll left button -;; -(defvar tabbar-scroll-left-button-value nil - "Value of the scroll left button.") - -(defconst tabbar-scroll-left-button-enabled-image - '((:type pbm :data "\ -P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 128 16 48 255 255 255 255 255 255 255 -255 144 28 86 128 0 255 255 255 255 255 255 160 44 92 159 135 113 0 -255 255 255 255 160 44 97 165 144 129 120 117 0 255 255 176 44 98 175 -174 146 127 126 127 128 0 255 255 0 160 184 156 143 136 134 135 137 -138 0 255 255 176 32 67 144 146 144 145 146 148 149 0 255 255 255 255 -160 42 75 140 154 158 159 160 0 255 255 255 255 255 255 160 40 74 154 -170 171 0 255 255 255 255 255 255 255 255 160 41 82 163 0 255 255 255 -255 255 255 255 255 255 255 160 32 48 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 -")) - "Default image for the enabled scroll left button. -A disabled button image will be automatically build from it.") - -(defcustom tabbar-scroll-left-button - (cons (cons " <" tabbar-scroll-left-button-enabled-image) - (cons " =" nil)) - "The scroll left button. -The variable `tabbar-button-widget' gives details on this widget." - :group 'tabbar - :type tabbar-button-widget - :set '(lambda (variable value) - (custom-set-default variable value) - ;; Schedule refresh of button value. - (setq tabbar-scroll-left-button-value nil))) - -;;; Scroll right button -;; -(defvar tabbar-scroll-right-button-value nil - "Value of the scroll right button.") - -(defconst tabbar-scroll-right-button-enabled-image - '((:type pbm :data "\ -P2 13 13 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -48 32 160 255 255 255 255 255 255 255 255 255 255 44 161 71 32 160 255 -255 255 255 255 255 255 255 36 157 163 145 62 32 160 255 255 255 255 -255 255 30 128 133 137 142 124 50 32 160 255 255 255 255 29 120 121 -124 126 126 124 105 42 32 176 255 255 31 126 127 128 128 128 128 126 -124 89 32 255 255 33 134 135 136 137 137 138 119 49 32 176 255 255 34 -143 144 145 146 128 54 32 160 255 255 255 255 36 152 153 134 57 32 160 -255 255 255 255 255 255 38 141 60 32 160 255 255 255 255 255 255 255 -255 48 32 160 255 255 255 255 255 255 255 255 255 255 255 255 255 255 -255 255 255 255 255 255 255 255 -")) - "Default image for the enabled scroll right button. -A disabled button image will be automatically build from it.") - -(defcustom tabbar-scroll-right-button - (cons (cons " >" tabbar-scroll-right-button-enabled-image) - (cons " =" nil)) - "The scroll right button. -The variable `tabbar-button-widget' gives details on this widget." - :group 'tabbar - :type tabbar-button-widget - :set '(lambda (variable value) - (custom-set-default variable value) - ;; Schedule refresh of button value. - (setq tabbar-scroll-right-button-value nil))) - -;;; Separator -;; -(defconst tabbar-separator-widget - '(cons (choice (string) - (number :tag "Space width" 0.2)) - (repeat :tag "Image" - :extra-offset 2 - (restricted-sexp :tag "Spec" - :match-alternatives (listp)))) - "Widget for editing a tab bar separator. -A separator is specified as a pair (STRING-OR-WIDTH . IMAGE) where -STRING-OR-WIDTH is a string value or a space width, and IMAGE a list -of image specifications. -If IMAGE is non-nil, try to use that image, else use STRING-OR-WIDTH. -The value (\"\"), or (0) hide separators.") - -(defvar tabbar-separator-value nil - "Value of the separator used between tabs.") - -(defcustom tabbar-separator (list 0.2) - "Separator used between tabs. -The variable `tabbar-separator-widget' gives details on this widget." - :group 'tabbar - :type tabbar-separator-widget - :set '(lambda (variable value) - (custom-set-default variable value) - ;; Schedule refresh of separator value. - (setq tabbar-separator-value nil))) - -;;; Images -;; -(defcustom tabbar-use-images t - "*Non-nil means to try to use images in tab bar. -That is for buttons and separators." - :group 'tabbar - :type 'boolean - :set '(lambda (variable value) - (custom-set-default variable value) - ;; Schedule refresh of all buttons and separator values. - (setq tabbar-separator-value nil - tabbar-home-button-value nil - tabbar-scroll-left-button-value nil - tabbar-scroll-right-button-value nil))) - -(defsubst tabbar-find-image (specs) - "Find an image, choosing one of a list of image specifications. -SPECS is a list of image specifications. See also `find-image'." - (when (and tabbar-use-images (display-images-p)) - (condition-case nil - (find-image specs) - (error nil)))) - -(defsubst tabbar-disable-image (image) - "From IMAGE, return a new image which looks disabled." - (setq image (copy-sequence image)) - (setcdr image (plist-put (cdr image) :conversion 'disabled)) - image) - -(defsubst tabbar-normalize-image (image &optional margin) - "Make IMAGE centered and transparent. -If optional MARGIN is non-nil, it must be a number of pixels to add as -an extra margin around the image." - (let ((plist (cdr image))) - (or (plist-get plist :ascent) - (setq plist (plist-put plist :ascent 'center))) - (or (plist-get plist :mask) - (setq plist (plist-put plist :mask '(heuristic t)))) - (or (not (natnump margin)) - (plist-get plist :margin) - (plist-put plist :margin margin)) - (setcdr image plist)) - image) - -;;; Button keymaps and callbacks -;; -(defun tabbar-make-mouse-keymap (callback) - "Return a keymap that call CALLBACK on mouse events. -CALLBACK is passed the received mouse event." - (let ((keymap (make-sparse-keymap))) - ;; Pass mouse-1, mouse-2 and mouse-3 events to CALLBACK. - (define-key keymap [header-line down-mouse-1] 'ignore) - (define-key keymap [header-line mouse-1] callback) - (define-key keymap [header-line down-mouse-2] 'ignore) - (define-key keymap [header-line mouse-2] callback) - (define-key keymap [header-line down-mouse-3] 'ignore) - (define-key keymap [header-line mouse-3] callback) - keymap)) - -(defsubst tabbar-make-mouse-event (&optional type) - "Return a mouse click event. -Optional argument TYPE is a mouse-click event or one of the -symbols `mouse-1', `mouse-2' or `mouse-3'. -The default is `mouse-1'." - (if (tabbar-click-p type) - type - (list (or (memq type '(mouse-2 mouse-3)) 'mouse-1) - (or (event-start nil) ;; Emacs 21.4 - (list (selected-window) (point) '(0 . 0) 0))))) - -;;; Buttons -;; -(defconst tabbar-default-button-keymap - (tabbar-make-mouse-keymap 'tabbar-select-button-callback) - "Default keymap of a button.") - -(defun tabbar-help-on-button (window object position) - "Return a help string or nil for none, for the button under the mouse. -WINDOW is the window in which the help was found (unused). -OBJECT is the button label under the mouse. -POSITION is the position in that label. -Call `tabbar-NAME-help-function' where NAME is the button name -associated to OBJECT." - (let* ((name (get-text-property position 'tabbar-button object)) - (funvar (and name - (intern-soft (format "tabbar-%s-help-function" - name))))) - (and (symbol-value funvar) - (funcall (symbol-value funvar))))) - -(defsubst tabbar-click-on-button (name &optional type) - "Handle a mouse click event on button NAME. -Call `tabbar-select-NAME-function' with the received, or simulated -mouse click event. -Optional argument TYPE is a mouse click event type (see the function -`tabbar-make-mouse-event' for details)." - (let ((funvar (intern-soft (format "tabbar-%s-function" name)))) - (when (symbol-value funvar) - (funcall (symbol-value funvar) (tabbar-make-mouse-event type)) - (tabbar-display-update)))) - -(defun tabbar-select-button-callback (event) - "Handle a mouse EVENT on a button. -Pass mouse click events on a button to `tabbar-click-on-button'." - (interactive "@e") - (when (tabbar-click-p event) - (let ((target (posn-string (event-start event)))) - (tabbar-click-on-button - (get-text-property (cdr target) 'tabbar-button (car target)) - event)))) - -(defun tabbar-make-button-keymap (name) - "Return a keymap to handle mouse click events on button NAME." - (if (fboundp 'posn-string) - tabbar-default-button-keymap - (let ((event (make-symbol "event"))) - (tabbar-make-mouse-keymap - `(lambda (,event) - (interactive "@e") - (and (tabbar-click-p ,event) - (tabbar-click-on-button ',name ,event))))))) - -;;; Button callbacks -;; -(defun tabbar-scroll-left (event) - "On mouse EVENT, scroll current tab set on left." - (when (eq (event-basic-type event) 'mouse-1) - (tabbar-scroll (tabbar-current-tabset) -1))) - -(defun tabbar-scroll-left-help () - "Help string shown when mouse is over the scroll left button." - "mouse-1: scroll tabs left.") - -(defun tabbar-scroll-right (event) - "On mouse EVENT, scroll current tab set on right." - (when (eq (event-basic-type event) 'mouse-1) - (tabbar-scroll (tabbar-current-tabset) 1))) - -(defun tabbar-scroll-right-help () - "Help string shown when mouse is over the scroll right button." - "mouse-1: scroll tabs right.") - -;;; Tabs -;; -(defconst tabbar-default-tab-keymap - (tabbar-make-mouse-keymap 'tabbar-select-tab-callback) - "Default keymap of a tab.") - -(defun tabbar-help-on-tab (window object position) - "Return a help string or nil for none, for the tab under the mouse. -WINDOW is the window in which the help was found (unused). -OBJECT is the tab label under the mouse. -POSITION is the position in that label. -Call `tabbar-help-on-tab-function' with the associated tab." - (when tabbar-help-on-tab-function - (let ((tab (get-text-property position 'tabbar-tab object))) - (funcall tabbar-help-on-tab-function tab)))) - -(defsubst tabbar-click-on-tab (tab &optional type) - "Handle a mouse click event on tab TAB. -Call `tabbar-select-tab-function' with the received, or simulated -mouse click event, and TAB. -Optional argument TYPE is a mouse click event type (see the function -`tabbar-make-mouse-event' for details)." - (when tabbar-select-tab-function - (funcall tabbar-select-tab-function - (tabbar-make-mouse-event type) tab) - (tabbar-display-update))) - -(defun tabbar-select-tab-callback (event) - "Handle a mouse EVENT on a tab. -Pass mouse click events on a tab to `tabbar-click-on-tab'." - (interactive "@e") - (when (tabbar-click-p event) - (let ((target (posn-string (event-start event)))) - (tabbar-click-on-tab - (get-text-property (cdr target) 'tabbar-tab (car target)) - event)))) - -(defun tabbar-make-tab-keymap (tab) - "Return a keymap to handle mouse click events on TAB." - (if (fboundp 'posn-string) - tabbar-default-tab-keymap - (let ((event (make-symbol "event"))) - (tabbar-make-mouse-keymap - `(lambda (,event) - (interactive "@e") - (and (tabbar-click-p ,event) - (tabbar-click-on-tab ',tab ,event))))))) - -;;; Tab bar construction -;; -(defun tabbar-button-label (name) - "Return a label for button NAME. -That is a pair (ENABLED . DISABLED), where ENABLED and DISABLED are -respectively the appearance of the button when enabled and disabled. -They are propertized strings which could display images, as specified -by the variable `tabbar-NAME-button'." - (let* ((btn (symbol-value - (intern-soft (format "tabbar-%s-button" name)))) - (on (tabbar-find-image (cdar btn))) - (off (and on (tabbar-find-image (cddr btn))))) - (when on - (tabbar-normalize-image on 1) - (if off - (tabbar-normalize-image off 1) - ;; If there is no disabled button image, derive one from the - ;; button enabled image. - (setq off (tabbar-disable-image on)))) - (cons - (propertize (or (caar btn) " ") 'display on) - (propertize (or (cadr btn) " ") 'display off)))) - -(defun tabbar-line-button (name) - "Return the display representation of button NAME. -That is, a propertized string used as an `header-line-format' template -element." - (let ((label (if tabbar-button-label-function - (funcall tabbar-button-label-function name) - (cons name name)))) - ;; Cache the display value of the enabled/disabled buttons in - ;; variables `tabbar-NAME-button-value'. - (set (intern (format "tabbar-%s-button-value" name)) - (cons - (propertize (car label) - 'tabbar-button name - 'face 'tabbar-button - 'mouse-face 'tabbar-button-highlight - 'pointer 'hand - 'local-map (tabbar-make-button-keymap name) - 'help-echo 'tabbar-help-on-button) - (propertize (cdr label) - 'face 'tabbar-button - 'pointer 'arrow))))) - -(defun tabbar-line-separator () - "Return the display representation of a tab bar separator. -That is, a propertized string used as an `header-line-format' template -element." - (let ((image (tabbar-find-image (cdr tabbar-separator)))) - ;; Cache the separator display value in variable - ;; `tabbar-separator-value'. - (setq tabbar-separator-value - (cond - (image - (propertize " " - 'face 'tabbar-separator - 'pointer 'arrow - 'display (tabbar-normalize-image image))) - ((numberp (car tabbar-separator)) - (propertize " " - 'face 'tabbar-separator - 'pointer 'arrow - 'display (list 'space - :width (car tabbar-separator)))) - ((propertize (or (car tabbar-separator) " ") - 'face 'tabbar-separator - 'pointer 'arrow)))) - )) - -(defsubst tabbar-line-buttons (tabset) - "Return a list of propertized strings for tab bar buttons. -TABSET is the tab set used to choose the appropriate buttons." - (list - (if tabbar-home-function - (car tabbar-home-button-value) - (cdr tabbar-home-button-value)) - (if (> (tabbar-start tabset) 0) - (car tabbar-scroll-left-button-value) - (cdr tabbar-scroll-left-button-value)) - (if (< (tabbar-start tabset) - (1- (length (tabbar-tabs tabset)))) - (car tabbar-scroll-right-button-value) - (cdr tabbar-scroll-right-button-value)) - tabbar-separator-value)) - -(defsubst tabbar-line-tab (tab) - "Return the display representation of tab TAB. -That is, a propertized string used as an `header-line-format' template -element. -Call `tabbar-tab-label-function' to obtain a label for TAB." - (concat (propertize - (if tabbar-tab-label-function - (funcall tabbar-tab-label-function tab) - tab) - 'tabbar-tab tab - 'local-map (tabbar-make-tab-keymap tab) - 'help-echo 'tabbar-help-on-tab - 'mouse-face 'tabbar-highlight - 'face (if (tabbar-selected-p tab (tabbar-current-tabset)) - 'tabbar-selected - 'tabbar-unselected) - 'pointer 'hand) - tabbar-separator-value)) - -(defun tabbar-line-format (tabset) - "Return the `header-line-format' value to display TABSET." - (let* ((sel (tabbar-selected-tab tabset)) - (tabs (tabbar-view tabset)) - (padcolor (tabbar-background-color)) - atsel elts) - ;; Initialize buttons and separator values. - (or tabbar-separator-value - (tabbar-line-separator)) - (or tabbar-home-button-value - (tabbar-line-button 'home)) - (or tabbar-scroll-left-button-value - (tabbar-line-button 'scroll-left)) - (or tabbar-scroll-right-button-value - (tabbar-line-button 'scroll-right)) - ;; Track the selected tab to ensure it is always visible. - (when tabbar--track-selected - (while (not (memq sel tabs)) - (tabbar-scroll tabset -1) - (setq tabs (tabbar-view tabset))) - (while (and tabs (not atsel)) - (setq elts (cons (tabbar-line-tab (car tabs)) elts) - atsel (eq (car tabs) sel) - tabs (cdr tabs))) - (setq elts (nreverse elts)) - ;; At this point the selected tab is the last elt in ELTS. - ;; Scroll TABSET and ELTS until the selected tab becomes - ;; visible. - (with-temp-buffer - (let ((truncate-partial-width-windows nil) - (inhibit-modification-hooks t) - deactivate-mark ;; Prevent deactivation of the mark! - start) - (setq truncate-lines nil - buffer-undo-list t) - (apply 'insert (tabbar-line-buttons tabset)) - (setq start (point)) - (while (and (cdr elts) ;; Always show the selected tab! - (progn - (delete-region start (point-max)) - (goto-char (point-max)) - (apply 'insert elts) - (goto-char (point-min)) - (> (vertical-motion 1) 0))) - (tabbar-scroll tabset 1) - (setq elts (cdr elts))))) - (setq elts (nreverse elts)) - (setq tabbar--track-selected nil)) - ;; Format remaining tabs. - (while tabs - (setq elts (cons (tabbar-line-tab (car tabs)) elts) - tabs (cdr tabs))) - ;; Cache and return the new tab bar. - (tabbar-set-template - tabset - (list (tabbar-line-buttons tabset) - (nreverse elts) - (propertize "%-" - 'face (list :background padcolor - :foreground padcolor) - 'pointer 'arrow))) - )) - -(defun tabbar-line () - "Return the header line templates that represent the tab bar. -Inhibit display of the tab bar in current window if any of the -`tabbar-inhibit-functions' return non-nil." - (cond - ((run-hook-with-args-until-success 'tabbar-inhibit-functions) - ;; Don't show the tab bar. - (setq header-line-format nil)) - ((tabbar-current-tabset t) - ;; When available, use a cached tab bar value, else recompute it. - (or (tabbar-template tabbar-current-tabset) - (tabbar-line-format tabbar-current-tabset))))) - -(defconst tabbar-header-line-format '(:eval (tabbar-line)) - "The tab bar header line format.") - -(defun tabbar-default-inhibit-function () - "Inhibit display of the tab bar in specified windows. -That is dedicated windows, and `checkdoc' status windows." - (or (window-dedicated-p (selected-window)) - (member (buffer-name) - (list " *Checkdoc Status*" - (if (boundp 'ispell-choices-buffer) - ispell-choices-buffer - "*Choices*"))))) - -;;; Cyclic navigation through tabs -;; -(defun tabbar-cycle (&optional backward type) - "Cycle to the next available tab. -The scope of the cyclic navigation through tabs is specified by the -option `tabbar-cycle-scope'. -If optional argument BACKWARD is non-nil, cycle to the previous tab -instead. -Optional argument TYPE is a mouse event type (see the function -`tabbar-make-mouse-event' for details)." - (let* ((tabset (tabbar-current-tabset t)) - (ttabset (tabbar-get-tabsets-tabset)) - ;; If navigation through groups is requested, and there is - ;; only one group, navigate through visible tabs. - (cycle (if (and (eq tabbar-cycle-scope 'groups) - (not (cdr (tabbar-tabs ttabset)))) - 'tabs - tabbar-cycle-scope)) - selected tab) - (when tabset - (setq selected (tabbar-selected-tab tabset)) - (cond - ;; Cycle through visible tabs only. - ((eq cycle 'tabs) - (setq tab (tabbar-tab-next tabset selected backward)) - ;; When there is no tab after/before the selected one, cycle - ;; to the first/last visible tab. - (unless tab - (setq tabset (tabbar-tabs tabset) - tab (car (if backward (last tabset) tabset)))) - ) - ;; Cycle through tab groups only. - ((eq cycle 'groups) - (setq tab (tabbar-tab-next ttabset selected backward)) - ;; When there is no group after/before the selected one, cycle - ;; to the first/last available group. - (unless tab - (setq tabset (tabbar-tabs ttabset) - tab (car (if backward (last tabset) tabset)))) - ) - (t - ;; Cycle through visible tabs then tab groups. - (setq tab (tabbar-tab-next tabset selected backward)) - ;; When there is no visible tab after/before the selected one, - ;; cycle to the next/previous available group. - (unless tab - (setq tab (tabbar-tab-next ttabset selected backward)) - ;; When there is no next/previous group, cycle to the - ;; first/last available group. - (unless tab - (setq tabset (tabbar-tabs ttabset) - tab (car (if backward (last tabset) tabset)))) - ;; Select the first/last visible tab of the new group. - (setq tabset (tabbar-tabs (tabbar-tab-tabset tab)) - tab (car (if backward (last tabset) tabset)))) - )) - (tabbar-click-on-tab tab type)))) - -;;;###autoload -(defun tabbar-backward () - "Select the previous available tab. -Depend on the setting of the option `tabbar-cycle-scope'." - (interactive) - (tabbar-cycle t)) - -;;;###autoload -(defun tabbar-forward () - "Select the next available tab. -Depend on the setting of the option `tabbar-cycle-scope'." - (interactive) - (tabbar-cycle)) - -;;;###autoload -(defun tabbar-backward-group () - "Go to selected tab in the previous available group." - (interactive) - (let ((tabbar-cycle-scope 'groups)) - (tabbar-cycle t))) - -;;;###autoload -(defun tabbar-forward-group () - "Go to selected tab in the next available group." - (interactive) - (let ((tabbar-cycle-scope 'groups)) - (tabbar-cycle))) - -;;;###autoload -(defun tabbar-backward-tab () - "Select the previous visible tab." - (interactive) - (let ((tabbar-cycle-scope 'tabs)) - (tabbar-cycle t))) - -;;;###autoload -(defun tabbar-forward-tab () - "Select the next visible tab." - (interactive) - (let ((tabbar-cycle-scope 'tabs)) - (tabbar-cycle))) - -;;; Button press commands -;; -(defsubst tabbar--mouse (number) - "Return a mouse button symbol from NUMBER. -That is mouse-2, or mouse-3 when NUMBER is respectively 2, or 3. -Return mouse-1 otherwise." - (cond ((eq number 2) 'mouse-2) - ((eq number 3) 'mouse-3) - ('mouse-1))) - -;;;###autoload -(defun tabbar-press-home (&optional arg) - "Press the tab bar home button. -That is, simulate a mouse click on that button. -A numeric prefix ARG value of 2, or 3, respectively simulates a -mouse-2, or mouse-3 click. The default is a mouse-1 click." - (interactive "p") - (tabbar-click-on-button 'home (tabbar--mouse arg))) - -;;;###autoload -(defun tabbar-press-scroll-left (&optional arg) - "Press the tab bar scroll-left button. -That is, simulate a mouse click on that button. -A numeric prefix ARG value of 2, or 3, respectively simulates a -mouse-2, or mouse-3 click. The default is a mouse-1 click." - (interactive "p") - (tabbar-click-on-button 'scroll-left (tabbar--mouse arg))) - -;;;###autoload -(defun tabbar-press-scroll-right (&optional arg) - "Press the tab bar scroll-right button. -That is, simulate a mouse click on that button. -A numeric prefix ARG value of 2, or 3, respectively simulates a -mouse-2, or mouse-3 click. The default is a mouse-1 click." - (interactive "p") - (tabbar-click-on-button 'scroll-right (tabbar--mouse arg))) - -;;; Mouse-wheel support -;; -(require 'mwheel) - -;;; Compatibility -;; -(defconst tabbar--mwheel-up-event - (symbol-value (if (boundp 'mouse-wheel-up-event) - 'mouse-wheel-up-event - 'mouse-wheel-up-button))) - -(defconst tabbar--mwheel-down-event - (symbol-value (if (boundp 'mouse-wheel-down-event) - 'mouse-wheel-down-event - 'mouse-wheel-down-button))) - -(defsubst tabbar--mwheel-key (event-type) - "Return a mouse wheel key symbol from EVENT-TYPE. -When EVENT-TYPE is a symbol return it. -When it is a button number, return symbol `mouse-<EVENT-TYPE>'." - (if (symbolp event-type) - event-type - (intern (format "mouse-%s" event-type)))) - -(defsubst tabbar--mwheel-up-p (event) - "Return non-nil if EVENT is a mouse-wheel up event." - (let ((x (event-basic-type event))) - (if (eq 'mouse-wheel x) - (< (car (cdr (cdr event))) 0) ;; Emacs 21.3 - ;; Emacs > 21.3 - (eq x tabbar--mwheel-up-event)))) - -;;; Basic commands -;; -;;;###autoload -(defun tabbar-mwheel-backward (event) - "Select the previous available tab. -EVENT is the mouse event that triggered this command. -Mouse-enabled equivalent of the command `tabbar-backward'." - (interactive "@e") - (tabbar-cycle t event)) - -;;;###autoload -(defun tabbar-mwheel-forward (event) - "Select the next available tab. -EVENT is the mouse event that triggered this command. -Mouse-enabled equivalent of the command `tabbar-forward'." - (interactive "@e") - (tabbar-cycle nil event)) - -;;;###autoload -(defun tabbar-mwheel-backward-group (event) - "Go to selected tab in the previous available group. -If there is only one group, select the previous visible tab. -EVENT is the mouse event that triggered this command. -Mouse-enabled equivalent of the command `tabbar-backward-group'." - (interactive "@e") - (let ((tabbar-cycle-scope 'groups)) - (tabbar-cycle t event))) - -;;;###autoload -(defun tabbar-mwheel-forward-group (event) - "Go to selected tab in the next available group. -If there is only one group, select the next visible tab. -EVENT is the mouse event that triggered this command. -Mouse-enabled equivalent of the command `tabbar-forward-group'." - (interactive "@e") - (let ((tabbar-cycle-scope 'groups)) - (tabbar-cycle nil event))) - -;;;###autoload -(defun tabbar-mwheel-backward-tab (event) - "Select the previous visible tab. -EVENT is the mouse event that triggered this command. -Mouse-enabled equivalent of the command `tabbar-backward-tab'." - (interactive "@e") - (let ((tabbar-cycle-scope 'tabs)) - (tabbar-cycle t event))) - -;;;###autoload -(defun tabbar-mwheel-forward-tab (event) - "Select the next visible tab. -EVENT is the mouse event that triggered this command. -Mouse-enabled equivalent of the command `tabbar-forward-tab'." - (interactive "@e") - (let ((tabbar-cycle-scope 'tabs)) - (tabbar-cycle nil event))) - -;;; Wrappers when there is only one generic mouse-wheel event -;; -;;;###autoload -(defun tabbar-mwheel-switch-tab (event) - "Select the next or previous tab according to EVENT." - (interactive "@e") - (if (tabbar--mwheel-up-p event) - (tabbar-mwheel-forward-tab event) - (tabbar-mwheel-backward-tab event))) - -;;;###autoload -(defun tabbar-mwheel-switch-group (event) - "Select the next or previous group of tabs according to EVENT." - (interactive "@e") - (if (tabbar--mwheel-up-p event) - (tabbar-mwheel-forward-group event) - (tabbar-mwheel-backward-group event))) - -;;; Minor modes -;; -(defsubst tabbar-mode-on-p () - "Return non-nil if Tabbar mode is on." - (eq (default-value 'header-line-format) - tabbar-header-line-format)) - -;;; Tabbar-Local mode -;; -(defvar tabbar--local-hlf nil) - -;;;###autoload -(define-minor-mode tabbar-local-mode - "Toggle local display of the tab bar. -With prefix argument ARG, turn on if positive, otherwise off. -Returns non-nil if the new state is enabled. -When turned on, if a local header line is shown, it is hidden to show -the tab bar. The tab bar is locally hidden otherwise. When turned -off, if a local header line is hidden or the tab bar is locally -hidden, it is shown again. Signal an error if Tabbar mode is off." - :group 'tabbar - :global nil - (unless (tabbar-mode-on-p) - (error "Tabbar mode must be enabled")) -;;; ON - (if tabbar-local-mode - (if (and (local-variable-p 'header-line-format) - header-line-format) - ;; A local header line exists, hide it to show the tab bar. - (progn - ;; Fail in case of an inconsistency because another local - ;; header line is already hidden. - (when (local-variable-p 'tabbar--local-hlf) - (error "Another local header line is already hidden")) - (set (make-local-variable 'tabbar--local-hlf) - header-line-format) - (kill-local-variable 'header-line-format)) - ;; Otherwise hide the tab bar in this buffer. - (setq header-line-format nil)) -;;; OFF - (if (local-variable-p 'tabbar--local-hlf) - ;; A local header line is hidden, show it again. - (progn - (setq header-line-format tabbar--local-hlf) - (kill-local-variable 'tabbar--local-hlf)) - ;; The tab bar is locally hidden, show it again. - (kill-local-variable 'header-line-format)))) - -;;; Tabbar mode -;; -(defvar tabbar-prefix-key [(control ?c)] - "The common prefix key used in Tabbar mode.") - -(defvar tabbar-prefix-map - (let ((km (make-sparse-keymap))) - (define-key km [(control home)] 'tabbar-press-home) - (define-key km [(control left)] 'tabbar-backward) - (define-key km [(control right)] 'tabbar-forward) - (define-key km [(control up)] 'tabbar-backward-group) - (define-key km [(control down)] 'tabbar-forward-group) - (define-key km [(control prior)] 'tabbar-press-scroll-left) - (define-key km [(control next)] 'tabbar-press-scroll-right) - (define-key km [(control f10)] 'tabbar-local-mode) - km) - "The key bindings provided in Tabbar mode.") - -(defvar tabbar-mode-map - (let ((km (make-sparse-keymap))) - (define-key km tabbar-prefix-key tabbar-prefix-map) - km) - "Keymap to use in Tabbar mode.") - -(defvar tabbar--global-hlf nil) - -;;;###autoload -(define-minor-mode tabbar-mode - "Toggle display of a tab bar in the header line. -With prefix argument ARG, turn on if positive, otherwise off. -Returns non-nil if the new state is enabled. - -\\{tabbar-mode-map}" - :group 'tabbar - :require 'tabbar - :global t - :keymap tabbar-mode-map - (if tabbar-mode -;;; ON - (unless (tabbar-mode-on-p) - ;; Save current default value of `header-line-format'. - (setq tabbar--global-hlf (default-value 'header-line-format)) - (tabbar-init-tabsets-store) - (setq-default header-line-format tabbar-header-line-format)) -;;; OFF - (when (tabbar-mode-on-p) - ;; Turn off Tabbar-Local mode globally. - (mapc #'(lambda (b) - (condition-case nil - (with-current-buffer b - (and tabbar-local-mode - (tabbar-local-mode -1))) - (error nil))) - (buffer-list)) - ;; Restore previous `header-line-format'. - (setq-default header-line-format tabbar--global-hlf) - (tabbar-free-tabsets-store)) - )) - -;;; Tabbar-Mwheel mode -;; -(defvar tabbar-mwheel-mode-map - (let ((km (make-sparse-keymap))) - (if (get 'mouse-wheel 'event-symbol-elements) - ;; Use one generic mouse wheel event - (define-key km [A-mouse-wheel] - 'tabbar-mwheel-switch-group) - ;; Use separate up/down mouse wheel events - (let ((up (tabbar--mwheel-key tabbar--mwheel-up-event)) - (down (tabbar--mwheel-key tabbar--mwheel-down-event))) - (define-key km `[header-line ,down] - 'tabbar-mwheel-backward-group) - (define-key km `[header-line ,up] - 'tabbar-mwheel-forward-group) - (define-key km `[header-line (control ,down)] - 'tabbar-mwheel-backward-tab) - (define-key km `[header-line (control ,up)] - 'tabbar-mwheel-forward-tab) - (define-key km `[header-line (shift ,down)] - 'tabbar-mwheel-backward) - (define-key km `[header-line (shift ,up)] - 'tabbar-mwheel-forward) - )) - km) - "Keymap to use in Tabbar-Mwheel mode.") - -;;;###autoload -(define-minor-mode tabbar-mwheel-mode - "Toggle use of the mouse wheel to navigate through tabs or groups. -With prefix argument ARG, turn on if positive, otherwise off. -Returns non-nil if the new state is enabled. - -\\{tabbar-mwheel-mode-map}" - :group 'tabbar - :require 'tabbar - :global t - :keymap tabbar-mwheel-mode-map - (when tabbar-mwheel-mode - (unless (and mouse-wheel-mode tabbar-mode) - (tabbar-mwheel-mode -1)))) - -(defun tabbar-mwheel-follow () - "Toggle Tabbar-Mwheel following Tabbar and Mouse-Wheel modes." - (tabbar-mwheel-mode (if (and mouse-wheel-mode tabbar-mode) 1 -1))) - -(add-hook 'tabbar-mode-hook 'tabbar-mwheel-follow) -(add-hook 'mouse-wheel-mode-hook 'tabbar-mwheel-follow) - -;;; Buffer tabs -;; -(defgroup tabbar-buffer nil - "Display buffers in the tab bar." - :group 'tabbar) - -(defcustom tabbar-buffer-home-button - (cons (cons "[+]" tabbar-home-button-enabled-image) - (cons "[-]" tabbar-home-button-disabled-image)) - "The home button displayed when showing buffer tabs. -The enabled button value is displayed when showing tabs for groups of -buffers, and the disabled button value is displayed when showing -buffer tabs. -The variable `tabbar-button-widget' gives details on this widget." - :group 'tabbar-buffer - :type tabbar-button-widget - :set '(lambda (variable value) - (custom-set-default variable value) - ;; Schedule refresh of button value. - (setq tabbar-home-button-value nil))) - -(defvar tabbar-buffer-list-function 'tabbar-buffer-list - "Function that returns the list of buffers to show in tabs. -That function is called with no arguments and must return a list of -buffers.") - -(defvar tabbar-buffer-groups-function 'tabbar-buffer-groups - "Function that gives the group names the current buffer belongs to. -It must return a list of group names, or nil if the buffer has no -group. Notice that it is better that a buffer belongs to one group.") - -(defun tabbar-buffer-list () - "Return the list of buffers to show in tabs. -Exclude buffers whose name starts with a space, when they are not -visiting a file. The current buffer is always included." - (delq nil - (mapcar #'(lambda (b) - (cond - ;; Always include the current buffer. - ((eq (current-buffer) b) b) - ((buffer-file-name b) b) - ((char-equal ?\ (aref (buffer-name b) 0)) nil) - ((buffer-live-p b) b))) - (buffer-list)))) - -(defun tabbar-buffer-mode-derived-p (mode parents) - "Return non-nil if MODE derives from a mode in PARENTS." - (let (derived) - (while (and (not derived) mode) - (if (memq mode parents) - (setq derived t) - (setq mode (get mode 'derived-mode-parent)))) - derived)) - -(defun tabbar-buffer-groups () - "Return the list of group names the current buffer belongs to. -Return a list of one element based on major mode." - (list - (cond - ((or (get-buffer-process (current-buffer)) - ;; Check if the major mode derives from `comint-mode' or - ;; `compilation-mode'. - (tabbar-buffer-mode-derived-p - major-mode '(comint-mode compilation-mode))) - "Process" - ) - ((member (buffer-name) - '("*scratch*" "*Messages*")) - "Common" - ) - ((eq major-mode 'dired-mode) - "Dired" - ) - ((memq major-mode - '(help-mode apropos-mode Info-mode Man-mode)) - "Help" - ) - ((memq major-mode - '(rmail-mode - rmail-edit-mode vm-summary-mode vm-mode mail-mode - mh-letter-mode mh-show-mode mh-folder-mode - gnus-summary-mode message-mode gnus-group-mode - gnus-article-mode score-mode gnus-browse-killed-mode)) - "Mail" - ) - (t - ;; Return `mode-name' if not blank, `major-mode' otherwise. - (if (and (stringp mode-name) - ;; Take care of preserving the match-data because this - ;; function is called when updating the header line. - (save-match-data (string-match "[^ ]" mode-name))) - mode-name - (symbol-name major-mode)) - )))) - -;;; Group buffers in tab sets. -;; -(defvar tabbar--buffers nil) - -(defun tabbar-buffer-update-groups () - "Update tab sets from groups of existing buffers. -Return the the first group where the current buffer is." - (let ((bl (sort - (mapcar - #'(lambda (b) - (with-current-buffer b - (list (current-buffer) - (buffer-name) - (if tabbar-buffer-groups-function - (funcall tabbar-buffer-groups-function) - '("Common"))))) - (and tabbar-buffer-list-function - (funcall tabbar-buffer-list-function))) - #'(lambda (e1 e2) - (string-lessp (nth 1 e1) (nth 1 e2)))))) - ;; If the cache has changed, update the tab sets. - (unless (equal bl tabbar--buffers) - ;; Add new buffers, or update changed ones. - (dolist (e bl) - (dolist (g (nth 2 e)) - (let ((tabset (tabbar-get-tabset g))) - (if tabset - (unless (equal e (assq (car e) tabbar--buffers)) - ;; This is a new buffer, or a previously existing - ;; buffer that has been renamed, or moved to another - ;; group. Update the tab set, and the display. - (tabbar-add-tab tabset (car e) t) - (tabbar-set-template tabset nil)) - (tabbar-make-tabset g (car e)))))) - ;; Remove tabs for buffers not found in cache or moved to other - ;; groups, and remove empty tabsets. - (mapc 'tabbar-delete-tabset - (tabbar-map-tabsets - #'(lambda (tabset) - (dolist (tab (tabbar-tabs tabset)) - (let ((e (assq (tabbar-tab-value tab) bl))) - (or (and e (memq tabset - (mapcar 'tabbar-get-tabset - (nth 2 e)))) - (tabbar-delete-tab tab)))) - ;; Return empty tab sets - (unless (tabbar-tabs tabset) - tabset)))) - ;; The new cache becomes the current one. - (setq tabbar--buffers bl))) - ;; Return the first group the current buffer belongs to. - (car (nth 2 (assq (current-buffer) tabbar--buffers)))) - -;;; Tab bar callbacks -;; -(defvar tabbar--buffer-show-groups nil) - -(defsubst tabbar-buffer-show-groups (flag) - "Set display of tabs for groups of buffers to FLAG." - (setq tabbar--buffer-show-groups flag - ;; Redisplay the home button. - tabbar-home-button-value nil)) - -(defun tabbar-buffer-tabs () - "Return the buffers to display on the tab bar, in a tab set." - (let ((tabset (tabbar-get-tabset (tabbar-buffer-update-groups)))) - (tabbar-select-tab-value (current-buffer) tabset) - (when tabbar--buffer-show-groups - (setq tabset (tabbar-get-tabsets-tabset)) - (tabbar-select-tab-value (current-buffer) tabset)) - tabset)) - -(defun tabbar-buffer-button-label (name) - "Return a label for button NAME. -That is a pair (ENABLED . DISABLED), where ENABLED and DISABLED are -respectively the appearance of the button when enabled and disabled. -They are propertized strings which could display images, as specified -by the variable `tabbar-button-label'. -When NAME is 'home, return a different ENABLED button if showing tabs -or groups. Call the function `tabbar-button-label' otherwise." - (let ((lab (tabbar-button-label name))) - (when (eq name 'home) - (let* ((btn tabbar-buffer-home-button) - (on (tabbar-find-image (cdar btn))) - (off (tabbar-find-image (cddr btn)))) - ;; When `tabbar-buffer-home-button' does not provide a value, - ;; default to the enabled value of `tabbar-home-button'. - (if on - (tabbar-normalize-image on 1) - (setq on (get-text-property 0 'display (car lab)))) - (if off - (tabbar-normalize-image off 1) - (setq off (get-text-property 0 'display (car lab)))) - (setcar lab - (if tabbar--buffer-show-groups - (propertize (or (caar btn) (car lab)) 'display on) - (propertize (or (cadr btn) (car lab)) 'display off))) - )) - lab)) - -(defun tabbar-buffer-tab-label (tab) - "Return a label for TAB. -That is, a string used to represent it on the tab bar." - (let ((label (if tabbar--buffer-show-groups - (format "[%s]" (tabbar-tab-tabset tab)) - (format "%s" (tabbar-tab-value tab))))) - ;; Unless the tab bar auto scrolls to keep the selected tab - ;; visible, shorten the tab label to keep as many tabs as possible - ;; in the visible area of the tab bar. - (if tabbar-auto-scroll-flag - label - (tabbar-shorten - label (max 1 (/ (window-width) - (length (tabbar-view - (tabbar-current-tabset))))))))) - -(defun tabbar-buffer-help-on-tab (tab) - "Return the help string shown when mouse is onto TAB." - (if tabbar--buffer-show-groups - (let* ((tabset (tabbar-tab-tabset tab)) - (tab (tabbar-selected-tab tabset))) - (format "mouse-1: switch to buffer %S in group [%s]" - (buffer-name (tabbar-tab-value tab)) tabset)) - (format "mouse-1: switch to buffer %S\n\ -mouse-2: pop to buffer, mouse-3: delete other windows" - (buffer-name (tabbar-tab-value tab))) - )) - -(defun tabbar-buffer-select-tab (event tab) - "On mouse EVENT, select TAB." - (let ((mouse-button (event-basic-type event)) - (buffer (tabbar-tab-value tab))) - (cond - ((eq mouse-button 'mouse-2) - (pop-to-buffer buffer t)) - ((eq mouse-button 'mouse-3) - (delete-other-windows)) - (t - (switch-to-buffer buffer))) - ;; Don't show groups. - (tabbar-buffer-show-groups nil) - )) - -(defun tabbar-buffer-click-on-home (event) - "Handle a mouse click EVENT on the tab bar home button. -mouse-1, toggle the display of tabs for groups of buffers. -mouse-3, close the current buffer." - (let ((mouse-button (event-basic-type event))) - (cond - ((eq mouse-button 'mouse-1) - (tabbar-buffer-show-groups (not tabbar--buffer-show-groups))) - ((eq mouse-button 'mouse-3) - (kill-buffer nil)) - ))) - -(defun tabbar-buffer-help-on-home () - "Return the help string shown when mouse is onto the toggle button." - (concat - (if tabbar--buffer-show-groups - "mouse-1: show buffers in selected group" - "mouse-1: show groups of buffers") - ", mouse-3: close current buffer")) - -(defun tabbar-buffer-track-killed () - "Hook run just before actually killing a buffer. -In Tabbar mode, try to switch to a buffer in the current tab bar, -after the current buffer has been killed. Try first the buffer in tab -after the current one, then the buffer in tab before. On success, put -the sibling buffer in front of the buffer list, so it will be selected -first." - (and (eq header-line-format tabbar-header-line-format) - (eq tabbar-current-tabset-function 'tabbar-buffer-tabs) - (eq (current-buffer) (window-buffer (selected-window))) - (let ((bl (tabbar-tab-values (tabbar-current-tabset))) - (b (current-buffer)) - found sibling) - (while (and bl (not found)) - (if (eq b (car bl)) - (setq found t) - (setq sibling (car bl))) - (setq bl (cdr bl))) - (when (and (setq sibling (or (car bl) sibling)) - (buffer-live-p sibling)) - ;; Move sibling buffer in front of the buffer list. - (save-current-buffer - (switch-to-buffer sibling)))))) - -;;; Tab bar buffer setup -;; -(defun tabbar-buffer-init () - "Initialize tab bar buffer data. -Run as `tabbar-init-hook'." - (setq tabbar--buffers nil - tabbar--buffer-show-groups nil - tabbar-current-tabset-function 'tabbar-buffer-tabs - tabbar-tab-label-function 'tabbar-buffer-tab-label - tabbar-select-tab-function 'tabbar-buffer-select-tab - tabbar-help-on-tab-function 'tabbar-buffer-help-on-tab - tabbar-button-label-function 'tabbar-buffer-button-label - tabbar-home-function 'tabbar-buffer-click-on-home - tabbar-home-help-function 'tabbar-buffer-help-on-home - ) - (add-hook 'kill-buffer-hook 'tabbar-buffer-track-killed)) - -(defun tabbar-buffer-quit () - "Quit tab bar buffer. -Run as `tabbar-quit-hook'." - (setq tabbar--buffers nil - tabbar--buffer-show-groups nil - tabbar-current-tabset-function nil - tabbar-tab-label-function nil - tabbar-select-tab-function nil - tabbar-help-on-tab-function nil - tabbar-button-label-function nil - tabbar-home-function nil - tabbar-home-help-function nil - ) - (remove-hook 'kill-buffer-hook 'tabbar-buffer-track-killed)) - -(add-hook 'tabbar-init-hook 'tabbar-buffer-init) -(add-hook 'tabbar-quit-hook 'tabbar-buffer-quit) - -(provide 'tabbar) - -(run-hooks 'tabbar-load-hook) - -;;; tabbar.el ends here diff --git a/.emacs.d/elisp/xmodmap-mode.el b/.emacs.d/elisp/xmodmap-mode.el deleted file mode 100644 index 3002a49..0000000 --- a/.emacs.d/elisp/xmodmap-mode.el +++ /dev/null @@ -1,9 +0,0 @@ -(define-generic-mode 'xmodmap-mode - '(?!) - '("add" "clear" "keycode" "keysym" "pointer" "remove") - nil - '("[xX]modmap\\(rc\\)?\\'") - nil - "Simple mode for xmodmap files.") - -(provide 'xmodmap-mode) |