summaryrefslogtreecommitdiffstats
path: root/.emacs.d
diff options
context:
space:
mode:
authorGravatar Tom Willemsen2011-09-20 01:08:06 +0200
committerGravatar Tom Willemsen2011-09-20 01:08:06 +0200
commit94b05b65efebc19f815f24350bca5473bb28fb46 (patch)
tree72d4c973db5566d9445cdc802a3f20f870a7d5f8 /.emacs.d
parentcd174512ef80597883b6ddf30103a16daee61748 (diff)
downloaddotfiles-94b05b65efebc19f815f24350bca5473bb28fb46.tar.gz
dotfiles-94b05b65efebc19f815f24350bca5473bb28fb46.zip
Split off emacs configs to dotemacs
Diffstat (limited to '.emacs.d')
m---------.emacs.d0
-rw-r--r--.emacs.d/.gitignore5
-rw-r--r--.emacs.d/auto-save-list/.nosearch0
-rw-r--r--.emacs.d/elisp/autopair.el1069
-rw-r--r--.emacs.d/elisp/autosmiley.el95
-rw-r--r--.emacs.d/elisp/batch-mode.el156
-rw-r--r--.emacs.d/elisp/cmake-mode.el339
-rw-r--r--.emacs.d/elisp/column-marker.el259
-rw-r--r--.emacs.d/elisp/functions.el45
m---------.emacs.d/elisp/git-commit-mode0
-rw-r--r--.emacs.d/elisp/git.el1705
-rw-r--r--.emacs.d/elisp/go-mode.el544
-rw-r--r--.emacs.d/elisp/graphviz-dot-mode.el946
-rw-r--r--.emacs.d/elisp/htmlize.el1671
-rw-r--r--.emacs.d/elisp/ide-skel.el4016
-rw-r--r--.emacs.d/elisp/lcars-theme.el417
m---------.emacs.d/elisp/markdown-mode0
m---------.emacs.d/elisp/php-mode0
m---------.emacs.d/elisp/rainbow0
m---------.emacs.d/elisp/rainbow-delimiters0
-rw-r--r--.emacs.d/elisp/sqlplus.el5151
-rw-r--r--.emacs.d/elisp/tabbar.el1932
-rw-r--r--.emacs.d/elisp/xmodmap-mode.el9
-rw-r--r--.emacs.d/elpa/archives/.nosearch0
-rw-r--r--.emacs.d/eshell/.nosearch0
-rw-r--r--.emacs.d/gnus.el60
-rw-r--r--.emacs.d/init.el503
m---------.emacs.d/naquadah-theme0
-rw-r--r--.emacs.d/url/.nosearch0
29 files changed, 0 insertions, 18922 deletions
diff --git a/.emacs.d b/.emacs.d
new file mode 160000
+Subproject 74ad04693c737618672b46b25436c20914ef8d6
diff --git a/.emacs.d/.gitignore b/.emacs.d/.gitignore
deleted file mode 100644
index d90d7da..0000000
--- a/.emacs.d/.gitignore
+++ /dev/null
@@ -1,5 +0,0 @@
-tramp
-elpa
-bookmarks
-abbrev_defs
-custom.el
diff --git a/.emacs.d/auto-save-list/.nosearch b/.emacs.d/auto-save-list/.nosearch
deleted file mode 100644
index e69de29..0000000
--- a/.emacs.d/auto-save-list/.nosearch
+++ /dev/null
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,
-\"&#169;\" *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, \"&#169;\" is exactly equivalent to \"&copy;\".
-
-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 ?&) "&amp;"
- (aref table ?<) "&lt;"
- (aref table ?>) "&gt;"
- ;; 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 ?\") "&quot;"
- )
- 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 &#64;.
-`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 "&#64;" 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
- "&lt;\\(\\(mailto:\\)?\\([-=+_.a-zA-Z0-9]+@[-_.a-zA-Z0-9]+\\)\\)&gt;"
- nil t)
- (let ((address (match-string 3))
- (link-text (match-string 1)))
- (delete-region (match-beginning 0) (match-end 0))
- (insert "&lt;<a href=\"mailto:"
- (htmlize-despam-address address)
- "\">"
- (htmlize-despam-address link-text)
- "</a>&gt;")))
- (goto-char (point-min))
- (while (re-search-forward "&lt;\\(\\(URL:\\)?\\([a-zA-Z]+://[^;]+\\)\\)&gt;"
- nil t)
- (let ((url (match-string 3))
- (link-text (match-string 1)))
- (delete-region (match-beginning 0) (match-end 0))
- (insert "&lt;<a href=\"" url "\">" link-text "</a>&gt;"))))
-
-;; 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&#58;" 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 "&quot;" html) (setq html (replace-match "\"" nil t html)))
- (while (string-match "&lt;" html) (setq html (replace-match "<" nil t html)))
- (while (string-match "&gt;" html) (setq html (replace-match ">" nil t html)))
- (while (string-match "&amp;" html) (setq html (replace-match "&" nil t html))))
- (while (string-match "&" html) (setq html (replace-match "&amp;" nil t html)))
- (while (string-match ">" html) (setq html (replace-match "&gt;" nil t html)))
- (while (string-match "<" html) (setq html (replace-match "&lt;" nil t html)))
- (while (string-match "\"" html) (setq html (replace-match "&quot;" 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)
diff --git a/.emacs.d/elpa/archives/.nosearch b/.emacs.d/elpa/archives/.nosearch
deleted file mode 100644
index e69de29..0000000
--- a/.emacs.d/elpa/archives/.nosearch
+++ /dev/null
diff --git a/.emacs.d/eshell/.nosearch b/.emacs.d/eshell/.nosearch
deleted file mode 100644
index e69de29..0000000
--- a/.emacs.d/eshell/.nosearch
+++ /dev/null
diff --git a/.emacs.d/gnus.el b/.emacs.d/gnus.el
deleted file mode 100644
index 3074aae..0000000
--- a/.emacs.d/gnus.el
+++ /dev/null
@@ -1,60 +0,0 @@
-(setq gnus-select-method '(nntp "news.eternal-september.org"))
-(setq gnus-secondary-select-methods
- '((nnmaildir "gmail"
- (directory "~/documents/mail/gmail/"))
- (nnmaildir "arch"
- (directory "~/documents/mail/arch/"))
- (nnmaildir "aethon"
- (directory "~/documents/mail/aethon/"))
- (nntp "news.gmane.org")
- (nnrss "")))
-
-(setq gnus-auto-subscribed-groups nil)
-(setq gnus-save-newsrc-file nil)
-(setq gnus-read-newsrc-file nil)
-(setq gnus-novice-user t)
-(setq gnus-article-truncate-lines nil)
-
-(setq gnus-parameters
- '(("gmail"
- (display . all))
- ("aethon"
- (display . all)
- ("arch"
- (display . all)))))
-
-(setq gnus-permanently-visible-groups
- "\\(gmail\\|aethon\\|arch\\):INBOX")
-
-(setq nntp-marks-is-evil t)
-
-(setq gnus-check-new-newsgroups nil)
-
-(setq gnus-posting-styles
- '((".*" (address "ryuslash@gmail.com"))
- ("arch:" (address "tom.willemsen@archlinux.us"))
- ("aethon:"
- (address "thomas@aethon.nl")
- (signature-file "~/documents/work/aethon/signature.txt"))))
-
-(setq user-mail-address "ryuslash@gmail.com")
-(setq user-full-name "Tom Willemsen")
-
-(load "tls")
-
-(setq send-mail-function 'smtpmail-send-it
- message-send-mail-function 'message-smtpmail-send-it
- starttls-use-gnutls t
- smtpmail-gnutls-credentials '(("smtp.gmail.com" 587 "ryuslash@gmail.com" nil))
- smtpmail-starttls-credentials '(("smtp.gmail.com" 587 "ryuslash@gmail.com" nil))
- smtpmail-smtp-server "smtp.gmail.com"
- smtpmail-smtp-service 587
- smtpmail-debug-info t
- smtpmail-default-smtp-server "smtp.gmail.com")
-
-(add-hook 'gnus-group-mode-hook 'gnus-topic-mode)
-
-;;; BBDB
-(require 'bbdb)
-(bbdb-initialize 'gnus 'message)
-(bbdb-insinuate-gnus)
diff --git a/.emacs.d/init.el b/.emacs.d/init.el
deleted file mode 100644
index 95b3d64..0000000
--- a/.emacs.d/init.el
+++ /dev/null
@@ -1,503 +0,0 @@
-;; -*- mode: Emacs-Lisp; -*-
-(let ((default-directory "~/.emacs.d/"))
- (normal-top-level-add-subdirs-to-load-path))
-
-;;-----[ Defun ]---------------------------------------------------------
-(defun ext/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 ext/what-major-mode (buffer-or-string)
- "Find out which major-mode is currently used"
- (with-current-buffer buffer-or-string major-mode))
-
-(defun ext/my-comp-finish-function (buf str)
- "Don't show compilation window if everything went ok"
- (if (string-match "exited abnormally" str)
- ;; there were errors
- (message "compilation errors, press C-x ` to visit")
- ;; no errors, make the compilation window go away in 0.5 seconds
- (run-at-time 0.5 nil 'delete-windows-on buf)
- (message "NO COMPILATION ERRORS!")))
-
-(defun ext/pretty-lambdas ()
- (font-lock-add-keywords
- nil `(("(\\(lambda\\>\\)"
- (0 (progn
- (compose-region (match-beginning 1)
- (match-end 1)
- ?λ)))))))
-
-(defun ext/x-urgency-hint (frame arg &optional source)
- (let* ((wm-hints (append (x-window-property
- "WM_HINTS" frame "WM_HINTS"
- (if source
- source
- (string-to-number
- (frame-parameter frame 'outer-window-id)))
- nil t) nil))
- (flags (car wm-hints)))
- (setcar wm-hints
- (if arg
- (logior flags #x00000100)
- (logand flags #xFFFFFEFF)))
- (x-change-window-property "WM_HINTS" wm-hints frame "WM_HINTS" 32 t)))
-
-(defun oni/c-toggle-header-source ()
- "Toggle between a C source and header file"
- (interactive)
- (let ((ext (file-name-extension (buffer-file-name)))
- (noext (file-name-sans-extension (buffer-file-name))))
- (if (string= (substring ext 0 1) "c")
- (find-file (concat noext ".h"))
- (find-file (concat noext ".c")))))
-
-(defun oni/init-show-outline ()
- (interactive)
- (occur ";;-----\\[ .* \\]-+")
- (other-window 1))
-
-(defun oni/replace-occurrences (from to)
- (save-excursion
- (goto-char (point-min))
- (while (search-forward from nil t)
- (replace-match to))))
-
-(defun oni/replace-html-special-chars ()
- (oni/replace-occurrences "é" "&eacute;"))
-
-(defun oni/before-save-hook ()
- (if (eq (ext/what-major-mode (current-buffer)) 'html-mode)
- (oni/replace-html-special-chars))
- (if (not (eq (ext/what-major-mode (current-buffer)) 'markdown-mode))
- (delete-trailing-whitespace)))
-
-(defun oni/after-save-hook ()
- (let* ((fname (buffer-file-name))
- (suffix (file-name-extension fname)))
- (if (string-equal suffix "el")
- (byte-compile-file fname))))
-
-;;-----[ Theme ]---------------------------------------------------------
-(require 'naquadah-theme)
-(eval-after-load 'naquadah-theme
- (naquadah-theme-set-faces
- 'naquadah
-
- ;; markdown-mode
- '(markdown-link-face (:inherit 'link))
- '(markdown-header-face-1 (:inherit 'org-level-1))
- '(markdown-header-face-2 (:inherit 'org-level-2))
- '(markdown-header-face-3 (:inherit 'org-level-3))
- '(markdown-header-face-4 (:inherit 'org-level-4))
- '(markdown-header-face-5 (:inherit 'org-level-5))
- '(markdown-header-face-6 (:inherit 'org-level-6))
-
- '(ac-candidate-face (:inherit 'header-line :box nil))
- '(ac-selection-face (:inherit 'hl-line :box nil))))
-
-;;-----[ Autopair ]------------------------------------------------------
-(require 'autopair)
-(autopair-global-mode t) ; automatically add the other delimiter
-(setq autopair-skip-criteria 'always
- autopair-autowrap t
- autopair-blink nil)
-(setq-default autopair-dont-pair '(:string (?\' ?\") :comment (?\')))
-
-;;-----[ Column marker ]-------------------------------------------------
-(require 'column-marker)
-
-(defun set-column-markers (cm1 cm2)
- (column-marker-1 cm1)
- (column-marker-2 cm2))
-
-;;-----[ Prog mode ]-----------------------------------------------------
-(defconst integer-regex-1
- (eval-when-compile
- (concat "\\b\\(0[xX][0-9a-fA-F]+[lL]?\\|[0-9]+\\.?[0-9]*\\([eE][-+]?"
- "[0-9]+\\)?\\([lL]\\|[fF]\\|[dD]\\)?\\)\\b")))
-
-(defconst integer-regex-2
- (eval-when-compile
- (concat "\\b\\(\\.[0-9]+\\([eE][-+]?[0-9]+\\)?\\([lL]\\|[fF]\\|[dD]"
- "\\)?\\)\\b")))
-
-(defun oni/prog-mode-hook ()
- (font-lock-add-keywords
- nil
- `((,integer-regex-1 0 font-lock-constant-face)
- (,integer-regex-2 0 font-lock-constant-face)))
- (ext/pretty-lambdas)
- (set-column-markers 73 81))
-
-(if (>= emacs-major-version 24)
- (add-hook 'prog-mode-hook 'oni/prog-mode-hook)
- (add-hook 'c-mode-common-hook 'oni/prog-mode-hook)
- (add-hook 'go-mode-hook 'oni/prog-mode-hook)
- (add-hook 'emacs-lisp-mode-hook 'oni/prog-mode-hook))
-
-;;-----[ HTML mode ]-----------------------------------------------------
-(defun oni/html-mode-hook ()
- (set-column-markers 73 81)
- (setq fill-column 73))
-
-(eval-after-load "sgml-mode"
- (progn
- (font-lock-add-keywords
- 'html-mode
- '(("{\\(\\*.*\\*\\)}" 1 font-comment-face)
- ("{\\/?\\(extends\\|block\\|foreach\\(else\\)?\\|if\\|else\\)"
- 1 font-lock-builtin-face)
- ("\\$\\(\\(?:\\sw\\|\\s_\\)+\\)\\(?:|\\(\\(?:\\sw\\|\\s_\\)+\\):\\)"
- (1 font-lock-variable-name-face)
- (2 font-lock-function-name-face))
- ("\\$\\(\\(?:\\sw\\|\\s_\\)+\\)"
- 1 font-lock-variable-name-face)
- ("{\\(\\(?:\\sw\\|\\s_\\)+\\).*}"
- 1 font-lock-function-name-face)))))
-
-(add-hook 'html-mode-hook 'oni/html-mode-hook)
-(add-to-list 'auto-mode-alist '("\\.tpl$" . html-mode))
-
-;;-----[ Org mode ]------------------------------------------------------
-(require 'org-crypt)
-(require 'org-publish)
-
-(defun oni/org-mode-hook ()
- (turn-on-flyspell)
- (turn-on-auto-fill))
-
-(setq
- org-tags-exclude-from-inheritance '("crypt")
- org-crypt-key "33E8CC1CC4"
- org-use-fast-todo-selection t
- org-default-notes-file (concat org-directory
- "/notes.org")
- org-outline-path-complete-in-steps t
- org-return-follows-link t
- org-log-into-drawer t
- org-todo-keywords '((sequence "TODO(t)"
- "IN PROGRESS(p)"
- "WAITING(w@/!)"
- "|"
- "DONE(d!/!)"
- "CANCELLED(c@/!)"))
- org-refile-targets '((org-agenda-files :maxlevel . 5)
- (nil :maxlevel . 5))
- org-todo-keyword-faces
- '(("TODO" :foreground "red" :weight bold)
- ("IN PROGRESS" :foreground "yellow" :weight bold)
- ("DONE" :foreground "forest green" :weight bold)
- ("WAITING" :foreground "orange" :weight bold)
- ("CANCELLED" :foreground "orangered" :weight bold)))
-(add-to-list 'auto-mode-alist '("\\.commitmsg$" . org-mode))
-(global-set-key "\C-cl" 'org-store-link)
-(global-set-key "\C-cc" 'org-capture)
-(global-set-key "\C-ca" 'org-agenda)
-(add-hook 'org-mode-hook 'oni/org-mode-hook)
-(org-crypt-use-before-save-magic)
-
-;;-----[ Rainbow delimiters ]--------------------------------------------
-(require 'rainbow-delimiters)
-(setq rainbow-delimiters-max-face-count 8)
-(global-rainbow-delimiters-mode)
-
-;;-----[ Uniquify ]------------------------------------------------------
-(require 'uniquify)
-(setq uniquify-buffer-name-style 'post-forward)
-
-;;-----[ Go mode ]-------------------------------------------------------
-(defun oni/go-mode-hook ()
- (turn-off-auto-fill))
-
-(autoload 'go-mode "go-mode" "Major mode for google go" t)
-(autoload 'gofmt "go-mode" "" t)
-(autoload 'go-fmt-before-save "go-mode" "" t)
-(add-to-list 'auto-mode-alist '("\\.go$" . go-mode))
-(add-hook 'go-mode-hook 'oni/go-mode-hook)
-
-;;-----[ Htmlize ]-------------------------------------------------------
-(require 'htmlize)
-(setq htmlize-output-type 'inline-css)
-
-;;-----[ Git ]-----------------------------------------------------------
-(require 'git)
-
-;;-----[ Markdown mode ]-------------------------------------------------
-(defun oni/markdown-mode-hook ()
- (whitespace-mode 1)
- (turn-on-auto-fill))
-
-(autoload 'markdown-mode "markdown-mode" "Major mode for Markdown" t)
-(setq whitespace-style '(face trailing)) ; For use with markdown mode
-(add-to-list 'auto-mode-alist '("\\.m\\(ark\\)?do?wn$". markdown-mode))
-(add-hook 'markdown-mode-hook 'oni/markdown-mode-hook)
-
-;;-----[ Xmodmap mode ]--------------------------------------------------
-(autoload 'xmodmap-mode "xmodmap-mode" "Major mode for xmodmap" t)
-(add-to-list 'auto-mode-alist
- '("\\.[xX]modmap\\(rc\\)?$" . xmodmap-mode))
-
-;;-----[ Gtags ]---------------------------------------------------------
-;; http://emacs-fu.blogspot.com/2009/01/navigating-through-source-code-using.html
-(defun oni/gtags-create-or-update ()
- "create or update the gnu global tag file"
- (interactive)
- (if (not (= 0 (call-process "global" nil nil nil " -p"))) ; tagfile
- (let ((olddir default-directory) ; doesn't exist?
- (topdir (read-directory-name
- "gtags: top of source tree:" default-directory)))
- (cd topdir)
- (shell-command "gtags && echo 'created tagfile'")
- (cd olddir)) ; restore
- ;; tagfile already exists; update it
- (shell-command "global -u && echo 'updated tagfile'")))
-
-(defun oni/gtags-mode-hook ()
- (local-set-key "\M-," 'gtags-find-tag)
- (local-set-key "\M-." 'gtags-find-rtag))
-
-(autoload 'gtags-mode "gtags" "Minor mode for using gtags" t)
-(add-hook 'gtags-mode-hook 'oni/gtags-mode-hook)
-
-;;-----[ C mode ]--------------------------------------------------------
-(defun oni/c-mode-common-hook ()
- (gtags-mode t)
- (oni/gtags-create-or-update))
-
-(defun oni/c-mode-hook ()
- (local-set-key [f8] 'oni/c-toggle-header-source)
- (local-set-key [f9] 'compile)
- (local-set-key [C-m] 'newline-and-indent)
- (local-set-key [C-return] 'newline))
-
-(add-hook 'c-mode-common-hook 'oni/c-mode-common-hook)
-(add-hook 'c-mode-hook 'oni/c-mode-hook)
-
-;;-----[ PHP mode ]------------------------------------------------------
-(defconst php-outline-regex
- (eval-when-compile
- (concat "\\(function .*(\\|\\(public\\|private\\|protected\\)\\( "
- "static\\)? \\$\\|class \\sw\\)")))
-
-(defun oni/php-show-outline ()
- (interactive)
- (occur php-outline-regex))
-
-(defun oni/php-mode-hook ()
- (c-set-offset 'arglist-intro '+)
- (c-set-offset 'arglist-close '0)
- (local-set-key [f6] 'comment-line)
- (local-set-key [f7] 'oni/php-show-outline)
- (local-set-key [M-S-up] 'flymake-goto-prev-error)
- (local-set-key [M-S-down] 'flymake-goto-next-error)
- (set-column-markers 76 81)
- (flymake-mode 1))
-
-(eval-after-load "php-mode"
- (progn
- ;; Add ! at the beginning of font lock
- (font-lock-add-keywords
- 'php-mode
- '(("\\([!]\\|\\=>\\)" 1 font-lock-operator-face)))
- ;; Add the rest at the end of font lock
- (font-lock-add-keywords
- 'php-mode
- '(("\\(->\\|[|.+=&/%*,:?<>-]\\)" 1 font-lock-operator-face)
- ("\\(;\\)" 1 font-lock-end-statement)) 1)))
-
-(autoload 'php-mode "php-mode" "Major mode for PHP" t)
-(setq-default php-mode-warn-if-mumamo-off nil) ; don't warn me about this
-(setq php-mode-force-pear t)
-(add-to-list 'auto-mode-alist '("\\.php[345]?$" . php-mode))
-(add-hook 'php-mode-hook 'oni/php-mode-hook)
-
-;;-----[ bidi ]----------------------------------------------------------
-(setq-default bidi-display-reordering nil)
-
-;;-----[ Message ]-------------------------------------------------------
-(defun oni/message-mode-hook ()
- (turn-on-auto-fill)
- (turn-on-flyspell)
- (ispell-change-dictionary (read-string "New dictionary: ")))
-
-(add-hook 'message-mode-hook 'oni/message-mode-hook)
-
-;;-----[ Gnus ]----------------------------------------------------------
-(setq gnus-init-file "~/.emacs.d/gnus")
-
-;;-----[ Autosmiley ]----------------------------------------------------
-(require 'autosmiley)
-
-;;-----[ Jabber ]--------------------------------------------------------
-(defvar ext/jabber-activity-jids-count 0)
-
-(defun ext/jabber-urgency-hint ()
- (let ((count (length jabber-activity-jids)))
- (unless (= ext/jabber-activity-jids-count count)
- (if (zerop count)
- (ext/x-urgency-hint (selected-frame) nil)
- (ext/x-urgency-hint (selected-frame) t))
- (setq ext/jabber-activity-jids-count count))))
-
-(defun oni/jabber-chat-mode-hook ()
- (autosmiley-mode)
- (local-set-key [S-return] 'newline)
- (local-set-key [C-return] 'newline))
-
-(when (require 'jabber-autoloads nil 'noerror)
- (setq jabber-account-list
- '(("ryuslash@gmail.com"
- (:network-server . "talk.google.com")
- (:connection-type . ssl))))
- (setq jabber-history-enabled t)
- (setq jabber-use-global-history nil)
- (add-hook 'jabber-chat-mode-hook 'oni/jabber-chat-mode-hook)
- (add-hook 'jabber-activity-update-hook 'ext/jabber-urgency-hint))
-
-;;-----[ X11 ]-----------------------------------------------------------
-(when window-system
- (setq linum-format " %d")
- (global-unset-key "\C-z"))
-
-;;-----[ CLI ]-----------------------------------------------------------
-(when (not window-system)
- (setq linum-format "%d "))
-
-;;-----[ Texinfo ]-------------------------------------------------------
-(add-hook 'texinfo-mode-hook 'turn-on-auto-fill)
-
-;;-----[ Dot ]-----------------------------------------------------------
-(autoload 'graphviz-dot-mode "graphviz-dot-mode" "Major mode for dot" t)
-(add-to-list 'auto-mode-alist '("\\.dot$" . graphviz-dot-mode))
-
-;;-----[ Cmake ]---------------------------------------------------------
-(define-skeleton cmake-project-skeleton
- "A cmake project template file"
- "Name: "
- "cmake_minimum_required(VERSION 2.6)\n"
- "project(" str ")\n"
- "\n"
- "set(" str "_VERSION_MAJOR 0)\n"
- "set(" str "_VERSION_MINOR 0)\n"
- "set(" str "_VERSION_PATCH 0)\n"
- "\n"
- "set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} ${PROJECT_SOURCE_DIR})\n"
- "add_subdirectory(src)")
-
-(autoload 'cmake-mode "cmake-mode" "Major mode for CMake" t)
-(add-to-list 'auto-mode-alist '("CMakeLists\\.txt$" . cmake-mode))
-(add-to-list 'auto-mode-alist '("\\.cmake$" . cmake-mode))
-
-;;-----[ Rainbow ]-------------------------------------------------------
-(autoload 'rainbow-mode "rainbow-mode" "Minor mode for colors" t)
-
-;;-----[ Git-commit mode ]-----------------------------------------------
-(autoload 'git-commit-mode "git-commit" "" t)
-(add-to-list 'auto-mode-alist '("COMMIT_EDITMSG$" . git-commit-mode))
-(add-hook 'git-commit-mode-hook 'auto-fill-mode)
-
-;;-----[ Ido ]-----------------------------------------------------------
-(ido-mode t)
-(setq ido-save-directory-list-file nil)
-(setq ido-auto-merge-delay-time 2)
-
-;;-----[ Js mode ]-------------------------------------------------------
-(add-to-list 'auto-mode-alist '("\\.js\\(on\\)?$" . js-mode))
-
-;;-----[ CSS mode ]------------------------------------------------------
-(add-to-list 'auto-mode-alist '("\\.css$" . css-mode))
-(add-hook 'css-mode-hook 'rainbow-mode)
-
-;;-----[ ELPA ]----------------------------------------------------------
-(setq package-archives
- '(("ELPA" . "http://tromey.com/elpa/")
- ("gnu" . "http://elpa.gnu.org/packages/")
- ("marmalade" . "http://marmalade-repo.org/packages/")))
-
-;;-----[ Windmove ]------------------------------------------------------
-(windmove-default-keybindings 'meta)
-
-;;-----[ Autocomplete ]--------------------------------------------------
-(when (require 'auto-complete-config nil 'noerror)
- (add-to-list 'ac-dictionary-directories "~/.emacs.d/ac-dict")
- (setq ac-comphist-file "~/.emacs.d/ac-comphist.dat")
- (ac-config-default))
-
-;;-----[ Ide-skel ]------------------------------------------------------
-(require 'ide-skel)
-(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)
-
-;;-----[ Misc ]----------------------------------------------------------
-(defun oni/reload-buffer ()
- (interactive)
- (revert-buffer nil t nil))
-
-(defvar font-lock-operator-face 'font-lock-operator-face)
-(defvar font-lock-end-statement 'font-lock-end-statement)
-
-(setq-default indent-tabs-mode nil)
-(setq-default truncate-lines t)
-(setq-default tab-width 4)
-(setq-default require-final-newline t)
-
-(setq inhibit-startup-message t)
-(setq inhibit-default-init t)
-(setq scroll-conservatively 101)
-(setq browse-url-browser-function 'browse-url-generic)
-(setq browse-url-generic-program (getenv "BROWSER"))
-(setq uniquify-buffer-name-style 'reverse)
-(setq jit-lock-defer-time 0.2)
-(setq mouse-autoselect-window t)
-(setq frame-title-format '(:eval (concat "emacs: " (buffer-name))))
-(setq backup-directory-alist `((".*" . ,temporary-file-directory)))
-(setq auto-save-file-name-transforms
- `((".*" ,temporary-file-directory t)))
-
-(setq default-frame-alist
- (append '((font . "DejaVu Sans Mono:pixelsize=13"))))
-
-(setq initial-frame-alist
- (append '((font . "DejaVu Sans Mono:pixelsize=13"))))
-
-(fset 'yes-or-no-p 'y-or-n-p)
-
-(tool-bar-mode -1)
-(menu-bar-mode -1)
-(line-number-mode -1)
-(global-linum-mode t)
-(column-number-mode t)
-(global-font-lock-mode t)
-(delete-selection-mode t)
-(show-paren-mode t)
-
-(add-to-list 'compilation-finish-functions 'ext/my-comp-finish-function)
-
-(global-set-key "\C-m" 'newline-and-indent)
-(global-set-key (kbd "C-x n r") 'narrow-to-region)
-(global-set-key [f5] 'oni/reload-buffer)
-
-(add-hook 'before-save-hook 'oni/before-save-hook)
-(add-hook 'after-save-hook 'oni/after-save-hook)
-
-(make-face 'font-lock-operator-face)
-(make-face 'font-lock-end-statement)
-(set-face-foreground 'font-lock-operator-face "#EDD400")
-(set-face-foreground 'font-lock-end-statement "#888A85")
-
-;; Custom file
-(setq custom-file "~/.emacs.d/custom.el")
-(if (file-exists-p custom-file)
- (load custom-file))
-
-(defvar home-file "~/wiki.info" "File to open when starting")
-
-(if (file-exists-p home-file)
- (info home-file))
diff --git a/.emacs.d/naquadah-theme b/.emacs.d/naquadah-theme
deleted file mode 160000
-Subproject 42d880560ba0ef838e5f2a037be35e0fd16f8fa
diff --git a/.emacs.d/url/.nosearch b/.emacs.d/url/.nosearch
deleted file mode 100644
index e69de29..0000000
--- a/.emacs.d/url/.nosearch
+++ /dev/null