diff options
Diffstat (limited to 'emacs.d/nxhtml/util')
64 files changed, 0 insertions, 41248 deletions
diff --git a/emacs.d/nxhtml/util/anchored-transpose.el b/emacs.d/nxhtml/util/anchored-transpose.el deleted file mode 100644 index 3a5464c..0000000 --- a/emacs.d/nxhtml/util/anchored-transpose.el +++ /dev/null @@ -1,305 +0,0 @@ -;;; anchored-transpose.el --- Transposes a phrase around an anchor phrase - -;; Copyright (C) 2004 Free Software Foundation, Inc. - -;; Author: Rick Bielawski <rbielaws@i1.net> -;; Keywords: tools convenience - -;; This file is free software; you can redistribute it and/or modify it under -;; the terms of the GNU General Public License as published by the Free -;; Software Foundation; either version 2, or (at your option) any later -;; version. - -;; This file is distributed in the hope that it will be useful, but WITHOUT -;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for -;; more details. - -;;; Commentary: - -;; `anchored-transpose' is an interactive autoload function to transpose -;; portions of a region around an anchor phrase. In other words it swaps -;; two regions. -;; -;; See C-h f anchored-transpose <ret> for a complete description. - -;;; Installing: - -;; 1) Put anchored-transpose.el on your load path. -;; 2) Put the following 2 lines in your .emacs -;; (global-set-key [?\C-x ?t] 'anchored-transpose) ;; Just a suggestion... -;; (autoload 'anchored-transpose "anchored-transpose" nil t) - -;;; History: - -;; 2004-09-24 RGB Seems useable enough to release. -;; 2004-10-15 RGB Only comments and doc strings were updated. -;; 2004-10-22 RGB Added support for 2 phrase selection. -;; 2004-12-01 RGB Added secondary selection support. -;; 2005-07-21 RGB Updated help text and comments. -;; Added support for A C B D and C A D B selection. -;; Fixed bug affecting multi line selections. -;; 2005-09-28 RGB Allow swapping regions with no anchor text between. - -;; Changes by Lennart Borgman -;; 2009-11-25 LB Set and clear secondary selection from keyboard. -;; Always use secondary selection. -;; Keep selections right after swapping. -;; Clear them if not used again. -;; Swap between buffers. -;; Check for read-only. -;; Probably broke something... ;-) - -;;; Code: - -(defvar anchored-transpose-anchor () - "begin/end when `anchored-transpose' is in progress else nil") - -;;;###autoload -(defun anchored-transpose (beg1 end1 flg1 &optional beg2 end2 flg2 win2) - "Transpose portions of the region around an anchor phrase. - -`this phrase but not that word' can be transposed into -`that word but not this phrase' - -I want this phrase but not that word. - |----------------------------|. .This is the entire phrase. - |-------|. . . . . . .This is the anchor phrase. - -First select the entire phrase and type \\[anchored-transpose]. -This set the secondary selection. - -Then select the anchor phrase and type \\[anchored-transpose] -again. Alternatively you can do the selections like this: - -I want this phrase but not that word. - |----------| |---------| Separate phrase selection. - -By default the anchor phrase will automatically include -any surrounding whitespace even if you don't explicitly select -it. Also, it won't include certain trailing punctuation. See -`anchored-transpose-do-fuzzy' for details. A prefix arg prior to -either selection means `no fuzzy logic, use selections -literally'. - -You can select the regions to be swapped separately in any -order. - -After swapping both primary and secondary selection are still -active. They will be canceled after second next command if you -do not swap regions again. \(Second because this allow you to -adjust the regions and try again.) - -You can also swap text between different buffers this way. - -Typing \\[anchored-transpose] with nothing selected clears any -prior selection, ie secondary selection." - (interactive `(,(region-beginning) ,(region-end) - ,current-prefix-arg - ,@anchored-transpose-anchor)) - (setq anchored-transpose-anchor nil) - (when (and mouse-secondary-overlay - mark-active - (overlay-buffer mouse-secondary-overlay) - (/= (overlay-start mouse-secondary-overlay) - (overlay-end mouse-secondary-overlay))) - (if (eq (overlay-buffer mouse-secondary-overlay) (current-buffer)) - (progn - (setq beg2 (overlay-start mouse-secondary-overlay)) - (setq end2 (overlay-end mouse-secondary-overlay)) - (setq flg2 flg1) - (delete-overlay mouse-secondary-overlay)) - (let* ((sec-buf (overlay-buffer mouse-secondary-overlay)) - (sec-win (get-buffer-window sec-buf)) - (sec-new nil)) - (unless sec-win - (setq sec-new t) - (setq sec-win (split-window))) - (with-selected-window sec-win - (set-window-buffer (selected-window) sec-buf) - (goto-char (overlay-start mouse-secondary-overlay))) - (if (not (y-or-n-p "Swap between buffers ")) - (when sec-new (delete-window sec-win)) - (setq beg2 (overlay-start mouse-secondary-overlay)) - (setq end2 (overlay-end mouse-secondary-overlay)) - (setq flg2 flg1) - (setq win2 sec-win))))) - (setq win2 (or win2 (selected-window))) - (if mark-active - (if end2 ; then both regions are marked. swap them. - (if (not (eq win2 (selected-window))) - (anchored-transpose-swap beg1 end1 beg2 end2 win2) - (if (and (< beg1 beg2) ;A C B D - (< end1 end2) - (> end1 beg2)) - (apply 'anchored-transpose-swap - (anchored-transpose-do-fuzzy - beg1 beg2 end1 end2 flg1 flg2 flg1 flg2)) - (if (and (> beg1 beg2) ;C A D B - (> end1 end2) - (> end2 beg1)) - (apply 'anchored-transpose-swap - (anchored-transpose-do-fuzzy - beg2 beg1 end2 end1 flg2 flg1 flg2 flg1)) - (if (and (< beg1 beg2) ;A C D B - (> end1 end2)) - (apply 'anchored-transpose-swap - (anchored-transpose-do-fuzzy - beg1 beg2 end2 end1 flg1 flg2 flg2 flg1)) - (if (and (> beg1 beg2) ;C A B D - (< end1 end2)) - (apply 'anchored-transpose-swap - (anchored-transpose-do-fuzzy - beg2 beg1 end1 end2 flg2 flg1 flg1 flg2)) - (if (<= end1 beg2) ;A B C D - (apply 'anchored-transpose-swap - (anchored-transpose-do-fuzzy - beg1 end1 beg2 end2 flg1 flg1 flg2 flg2)) - (if (<= end2 beg1) ;C D A B - (apply 'anchored-transpose-swap - (anchored-transpose-do-fuzzy - beg2 end2 beg1 end1 flg2 flg2 flg1 flg1)) - (error "Regions have invalid overlap")))))))) - ;; 1st of 2 regions. Save it and wait for the other. - ;;(setq anchored-transpose-anchor (list beg1 end1 flg1)) - (if (or buffer-read-only - (get-char-property beg1 'read-only) - (get-char-property end1 'read-only)) - ;; Fix-me: move test, clean up a bit. - (message "Buffer text is readonly") - (set-secondary-selection beg1 end1) - (setq deactivate-mark t) - (message "%s" (this-command-keys)) - (message (propertize "Transpose: Select second region and call again - (without selection to cancel)" - 'face 'secondary-selection)))) - (if (and mouse-secondary-overlay - (overlay-buffer mouse-secondary-overlay)) - (progn - (cancel-secondary-selection) - (message (propertize "Canceled secondary selection" 'face - 'highlight))) - (message (propertize "Command requires a marked region" 'face - 'highlight))))) - -;;;###autoload -(defun set-secondary-selection (beg end) - "Set the secondary selection to the current region. -This must be bound to a mouse drag event." - (interactive "r") - (move-overlay mouse-secondary-overlay beg end (current-buffer)) - (when (called-interactively-p 'interactive) - ;;(deactivate-mark) - ) - (x-set-selection - 'SECONDARY - (buffer-substring (overlay-start mouse-secondary-overlay) - (overlay-end mouse-secondary-overlay)))) - -;;;###autoload -(defun cancel-secondary-selection () - (interactive) - (delete-overlay mouse-secondary-overlay) - (x-set-selection 'SECONDARY nil)) - -(defun anchored-transpose-do-fuzzy (r1beg r1end r2beg r2end - lit1 lit2 lit3 lit4) - "Returns the first 4 arguments after adjusting their value if necessary. - -I want this phrase but not that word. - |----------------------------|. .This is the entire phrase. - |-------|. . . . . . .This is the anchor phrase. - R1BEG R1END R2BEG R2END - -R1BEG and R1END define the first region and R2BEG and R2END the second. - -The flags, LIT1 thru LIT4 indicate if fuzzy logic should be applied to the -beginning of R1BEG, the end of R1END, the beginning of R2BEG, the end of R2END -respectively. If any flag is nil then fuzzy logic will be applied. Otherwise -the value passed should be returned LITerally (that is, unchanged). - -See `anchored-transpose-fuzzy-begin' and `anchored-transpose-fuzzy-end' for -specifics on what adjustments these routines will make when LITx is nil." - (list - (if lit1 r1beg - (anchored-transpose-fuzzy-begin r1beg r1end "[\t ]+")) - (if lit2 r1end - (anchored-transpose-fuzzy-end r1beg r1end "\\s +")) - (if lit3 r2beg - (anchored-transpose-fuzzy-begin r2beg r2end "[\t ]+")) - (if lit4 r2end - (anchored-transpose-fuzzy-end r2beg r2end "\\s *[.!?]")) - nil)) - -(defun anchored-transpose-fuzzy-end (beg end what) - "Returns END or new value for END based on the regexp WHAT. -BEG and END are buffer positions defining a region. If that region ends -with WHAT then the value for END is adjusted to exclude that matching text. - -NOTE: The regexp is applied differently than `looking-back' applies a regexp. - -Example: if (buffer-string beg end) contains `1234' the regexp `432' matches -it, not `234' as `looking-back' would. Also, your regexp never sees the char -at BEG so the match will always leave at least 1 character to transpose. -The reason for not using looking-back is that it's not greedy enough. -\(looking-back \" +\") will only match one space no matter how many exist." - (let ((str (concat - (reverse (append (buffer-substring (1+ beg) end) nil))))) - (if (string-match (concat "`" what) str) - (- end (length (match-string 0 str))) - end))) - -(defun anchored-transpose-fuzzy-begin (beg end what) - "Returns BEG or a new value for BEG based on the regexp WHAT. -BEG and END are buffer positions defining a region. If the region begins -with WHAT then BEG is adjusted to exclude the matching text. - -NOTE: Your regexp never sees the last char defined by beg/end. This insures -at least 1 char is always left to transpose." - (let ((str (buffer-substring beg (1- end)))) - (if (string-match (concat "`" what) str) - (+ beg (length (match-string 0 str))) - beg))) - -(defun anchored-transpose-swap (r1beg r1end r2beg r2end win2) - "Swaps region r1beg/r1end with r2beg/r2end. Flags are currently ignored. -Point is left at r1end." - (let ((reg1 (buffer-substring r1beg r1end)) - (reg2 nil) - (old-buffer (current-buffer))) - (when win2 - (unless (eq (selected-window) win2) - (select-window win2) - (set-buffer (window-buffer (selected-window))))) - (setq reg2 (delete-and-extract-region r2beg r2end)) - (goto-char r2beg) - (let ((new-mark (point))) - (insert reg1) - (push-mark new-mark)) - ;; I want to leave point at the end of phrase 2 in current buffer. - (save-excursion - (with-current-buffer old-buffer - (goto-char r1beg) - (delete-region r1beg r1end) - (let ((here (point))) - (insert reg2) - (set-secondary-selection here (point))))) - (setq deactivate-mark nil) - (when (eq old-buffer (current-buffer)) - (add-hook 'post-command-hook 'anchored-swap-post-command t t)))) - -(defun anchored-swap-post-command () - (condition-case err - (unless mark-active - (cancel-secondary-selection) - (remove-hook 'post-command-hook 'anchored-swap-post-command t)) - (error (message "anchored-swap-post-command: %s" err)))) - -(provide 'anchored-transpose) - -;; Because I like it this way. So there! -;;; fill-column:78 *** -;;; emacs-lisp-docstring-fill-column:78 *** -;;; -;;; Local Variables: *** -;;; End: *** -;;; anchored-transpose.el ends here. diff --git a/emacs.d/nxhtml/util/appmenu-fold.el b/emacs.d/nxhtml/util/appmenu-fold.el deleted file mode 100644 index 938ab92..0000000 --- a/emacs.d/nxhtml/util/appmenu-fold.el +++ /dev/null @@ -1,79 +0,0 @@ -;;; appmenu-fold.el --- Support form fold-dwim in AppMenu -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: Wed Jan 11 21:48:02 2006 -(defconst appmenu-fold:version "0.51") ;; Version: -;; Last-Updated: Mon Jan 15 03:10:59 2007 (3600 +0100) -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; -;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(require 'fold-dwim nil t) -(eval-when-compile (require 'appmenu)) - -(when (featurep 'fold-dwim) - - (defun appmenu-fold-no-hs-minor-mode () - t) - (defun appmenu-fold-no-outline-minor-mode () - t) - (defun appmenu-fold-setup () - "Adds some tweaks for using fold-dwim in AppMenu." - (let ((fd-map (make-sparse-keymap))) - (define-key fd-map [fold-dwim-toggle] - (list 'menu-item "Fold Dwin Toggle" 'fold-dwim-toggle)) - (define-key fd-map [fold-dwim-hide-all] - (list 'menu-item "Fold Dwin Hide All" 'fold-dwim-hide-all)) - (define-key fd-map [fold-dwim-show-all] - (list 'menu-item "Fold Dwin Show All" 'fold-dwim-show-all)) - ;;(add-to-list 'appmenu-alist (cons t (cons "Folding" fd-map))) - (appmenu-add 'appmenu-fold nil t "Folding" fd-map) - ) -;;; (add-to-list 'appmenu-minor-modes-exclude -;;; '(hs-minor-mode appmenu-fold-no-hs-minor-mode)) -;;; (add-to-list 'appmenu-minor-modes-exclude -;;; '(outline-minor-mode appmenu-fold-no-outline-minor-mode))) - ) - ) - -(provide 'appmenu-fold) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; appmenu-fold.el ends here diff --git a/emacs.d/nxhtml/util/appmenu.el b/emacs.d/nxhtml/util/appmenu.el deleted file mode 100644 index 1f060ef..0000000 --- a/emacs.d/nxhtml/util/appmenu.el +++ /dev/null @@ -1,523 +0,0 @@ -;;; appmenu.el --- A framework for [apps] popup menus. - -;; Copyright (C) 2008 by Lennart Borgman - -;; Author: Lennart Borgman <lennart DOT borgman AT gmail DOT com> -;; Created: Thu Jan 05 14:00:26 2006 -(defconst appmenu:version "0.63") ;; Version: -;; Last-Updated: 2010-01-04 Mon -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; appmenu.el is a framework for creating cooperative context -;; sensitive popup menus with commands from different major and minor -;; modes. For more information see `appmenu-mode'. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; Version 0.61: -;; - Remove support for minor and major menus. -;; - Add support for text and overlay keymaps. -;; - Add customization options. -;; -;; Version 0.62: -;; - Fix problem with keymap at point. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'cl)) -(eval-when-compile (require 'flyspell)) -(eval-when-compile (require 'help-mode)) -(eval-when-compile (require 'ourcomments-util nil t)) -(eval-when-compile (require 'mumamo nil t)) -;;(eval-when-compile (require 'mlinks nil t)) - -;;;###autoload -(defgroup appmenu nil - "Customization group for `appmenu-mode'." - :group 'convenience) - -(defcustom appmenu-show-help nil - "Non-nil means show AppMenu help on AppMenu popup." - :type 'boolean - :group 'appmenu) - -(defcustom appmenu-show-point-menu t - "If non-nil show entries fetched from keymaps at point." - :type 'boolean - :group 'appmenu) - -(defvar appmenu-alist nil - "List of additional menu keymaps. -To change this list use `appmenu-add' and `appmenu-remove'. - -The entries in this list are lists: - - \(ID PRIORITY TEST TITLE DEFINITION) - -ID is a unique identity. - -PRIORITY is a number or a variable whose value is a number -telling where to put this entry when showing the menu. - -TEST should be a form to evaluate. The entry is used if \(eval -TEST) returns non-nil. - -DEFINITION should be either a keymap or a function that returns a -keymap. - -The function must take no argument and return a keymap. If the -function returns nil then the entry is not shown in the popup -menu. Using this you can make context sensitive popup menus. - -For an example of use see mlinks.el.") - -(defun appmenu-sort-by-priority () - "Sort `appmenu-alist' entries by priority." - (setq appmenu-alist - (sort appmenu-alist - (lambda (recA recB) - (let ((priA (nth 1 recA)) - (priB (nth 1 recB))) - (when (symbolp priA) (setq priA (symbol-value priA))) - (when (symbolp priB) (setq priB (symbol-value priB))) - (< priA priB)))))) - -;;;###autoload -(defun appmenu-add (id priority test title definition) - "Add entry to `appmenu-alist'. -Add an entry to this list with ID, PRIORITY, TEST, TITLE and -DEFINITION as explained there." - (assert (symbolp id)) - (unless priority (setq priority 100)) - (assert (numberp priority)) - (assert (stringp title)) - (let ((rec (list id priority test title definition))) - (appmenu-remove id) - (add-to-list 'appmenu-alist rec))) - -(defun appmenu-remove (id) - "Remove entry with id ID from `appmenu-alist'." - (setq appmenu-alist (assq-delete-all id appmenu-alist))) - -(defun appmenu-help () - "Show help for minor mode function `appmenu-mode'." - (interactive) - (describe-function 'appmenu-mode)) - -(defun appmenu-keymap-len (map) - "Return length of keymap MAP." - (let ((ml 0)) - (map-keymap (lambda (e f) (setq ml (1+ ml))) map) - ml)) - -(defvar appmenu-mouse-only - '((flyspell-correct-word appmenu-flyspell-correct-word-before-point))) - -(defun appmenu-flyspell-correct-word-before-point () - "Pop up a menu of possible corrections for misspelled word before point. -Special version for AppMenu." - (interactive) - (flyspell-correct-word-before-point)) - -(defcustom appmenu-at-any-point '(ispell-word) - "Commands that may work at any point in a buffer. -Some important but not too often used commands that may be useful -for most points in a buffer." - :group 'appmenu) - -(defvar appmenu-map-fun) ;; dyn var, silence compiler - -(defun appmenu-make-menu-for-point (this-point) - "Construct a menu based on point THIS-POINT. -This includes some known commands for point and keymap at -point." - (let ((point-map (get-char-property this-point 'keymap)) - (funs appmenu-at-any-point) - (map (make-sparse-keymap "At point")) - (num 0) - last-prefix - this-prefix) - ;; Known for any point - (when point-map - (let ((appmenu-map-fun - (lambda (key fun) - (if (keymapp fun) - (map-keymap appmenu-map-fun fun) - (when (and (symbolp fun) - (fboundp fun)) - (let ((mouse-only (assq fun appmenu-mouse-only))) - (when mouse-only - (setq fun (cadr mouse-only))) - (add-to-list 'funs fun))))))) - (map-keymap appmenu-map-fun point-map))) - (dolist (fun funs) - (let ((desc (when fun (documentation fun)))) - (when desc - (setq desc (car (split-string desc "[\n]"))) - ;;(lwarn t :warning "pk: %s, %s" fun desc) - (setq this-prefix - (car (split-string (symbol-name fun) "[-]"))) - (when (and last-prefix - (not (string= last-prefix this-prefix))) - (define-key map - (vector (intern (format "appmenu-point-div-%s" num))) - (list 'menu-item "--"))) - (setq last-prefix this-prefix) - (setq num (1+ num)) - (define-key map - (vector (intern (format "appmenu-point-%s" num))) - (list 'menu-item desc fun))))) - (when (> num 0) map))) - -(defvar appmenu-level) ;; dyn var -(defvar appmenu-funs) ;; dyn var -(defvar appmenu-events) ;; dyn var -(defvar appmenu-this-point) ;; dyn var - -(defun appmenu-keymap-map-fun (ev def) - (if (keymapp def) - (progn - (add-to-list 'appmenu-funs (list appmenu-level ev)) - (setq appmenu-events (cons ev appmenu-events)) - (setq appmenu-level (1+ appmenu-level)) - - (map-keymap 'appmenu-keymap-map-fun def) - - (setq appmenu-events (cdr appmenu-events)) - (setq appmenu-level (1- appmenu-level))) - (when (and (symbolp def) - (fboundp def)) - (let* ((mouse-only (assq def appmenu-mouse-only)) - (fun (if mouse-only (cadr mouse-only) def)) - (doc (when fun - (if (not (eq fun 'push-button)) - (documentation fun) - (concat - "Button: " - (with-current-buffer (marker-buffer appmenu-this-point) - (or (get-char-property appmenu-this-point 'help-echo) - (let ((action-fun (get-char-property appmenu-this-point 'action))) - (if action-fun - (documentation action-fun) - "No action, ignored")) - "No documentation available"))))))) - (add-to-list 'appmenu-funs (list appmenu-level (cons ev appmenu-events) def doc)))))) - -;;(appmenu-as-help (point)) -(defun appmenu-as-help (this-point) - "Show keybindings specific done current point in buffer. -This shows the binding in the help buffer. - -Tip: This may be helpful if you are using `css-color-mode'." - (interactive (list (copy-marker (point)))) - ;; Split this for debugging - (let ((menu-here - (with-current-buffer (or (and (markerp this-point) - (marker-buffer this-point)) - (current-buffer)) - (unless (markerp this-point) (setq this-point (copy-marker this-point))) - (get-char-property this-point 'keymap)))) - ;;(describe-variable 'menu-here) - (appmenu-as-help-1 menu-here this-point))) - -(defun appmenu-as-help-1 (menu-here this-point) - (let ((appmenu-level 0) - (appmenu-funs nil) - (appmenu-events nil) - (appmenu-this-point this-point)) - (when menu-here - (map-keymap 'appmenu-keymap-map-fun menu-here)) - ;;(describe-variable 'appmenu-funs) - ;; Fix-me: collect info first in case we are in help-buffer! - (with-output-to-temp-buffer (help-buffer) - (help-setup-xref (list #'appmenu-as-help this-point) (interactive-p)) - (with-current-buffer (help-buffer) - (let ((fmt " %s%15s %-30s\n")) - (insert (propertize - ;;"AppMenu: Keys found at point in buffer\n\n" - (format "Appmenu: Key bindings specific to point %s in buffer %S\n\n" - (+ 0 this-point) - (when (markerp this-point) - (buffer-name (marker-buffer this-point)))) - 'face 'font-lock-comment-face)) - (if (not menu-here) - (insert "\n\nThere are no point specific key bindings there now.") - (insert (propertize (format fmt "" "Key" "Function") 'face 'font-lock-function-name-face)) - (insert (propertize (format fmt "" "---" "--------") 'face 'font-lock-function-name-face)) - (dolist (rec appmenu-funs) - (let* ((lev (nth 0 rec)) - (ev (nth 1 rec)) - (fun (nth 2 rec)) - (doc (nth 3 rec)) - (d1 (when doc (car (split-string doc "[\n]"))))) - (if fun - (insert (format fmt - "" ;;(concat "*" (make-string (* 4 lev) ?\ )) - (key-description (reverse ev)) - d1) - (if nil (format "(%s)" fun) "")) - ;;(insert (format "something else=%S\n" rec)) - ))))))))) - - -(defun appmenu-map () - "Return menu keymap to use for popup menu." - (let* ((map (make-sparse-keymap - "AppMenu" - )) - (map-len (appmenu-keymap-len map)) - (map-init-len map-len) - (num-minor 0) - (id 0) - (point-menu (when appmenu-show-point-menu - (appmenu-make-menu-for-point (point))))) - ;; AppMenu itself - (when appmenu-show-help - (define-key map [appmenu-customize] - (list 'menu-item "Customize AppMenu" - (lambda () (interactive) (customize-group 'appmenu)) - :help "Customize AppMenu" - :visible 'appmenu-show-help)) - (define-key map [appmenu-help] - (list 'menu-item "Help for AppMenu" 'appmenu-help - :help "Help for how to use AppMenu" - :visible 'appmenu-show-help)) - (define-key map [appmenu-separator-1] - (list 'menu-item "--"))) - (setq map-len (appmenu-keymap-len map)) - (appmenu-sort-by-priority) - (dolist (rec appmenu-alist) - (let* ((test (nth 2 rec)) - (title (nth 3 rec)) - (mapdef (nth 4 rec)) - (usedef (if (symbolp mapdef) - (funcall mapdef) - mapdef))) - (when (and usedef - (eval test)) - (setq id (1+ id)) - (define-key map - (vector (intern (format "appmenu-%s" id))) - (list 'menu-item title usedef))) - )) - (when point-menu - (setq map-len (appmenu-keymap-len map)) - (when (> map-len map-init-len) - (define-key map [appmenu-at-point-div] - (list 'menu-item "--"))) - (define-key map [appmenu-at-point] - (list 'menu-item "Bound To Point" - point-menu))) - (setq map-len (appmenu-keymap-len map)) - (when (> map-len map-init-len) - map))) - -;; (defun appmenu-get-submenu (menu-command) -;; (let (subtitle submenumap) -;; (if (eq 'menu-item (car menu-command)) -;; (progn (setq subtitle (cadr menu-command)) -;; (setq submenumap (caddr menu-command))) -;; (setq subtitle (car menu-command)) -;; (setq submenumap (cdr menu-command))) -;; (unless (keymapp submenumap) (error "Submenu not a keymap=%s" submenumap)) -;; (cons subtitle submenumap))) - -(defun appmenu-popup () - "Pops up the AppMenu menu." - (interactive) - (let* ((mod (event-modifiers last-input-event)) - (is-mouse (or (memq 'click mod) - (memq 'down mod) - (memq 'drag mod)))) - (when is-mouse - (goto-char (posn-point (event-start last-input-event))) - (sit-for 0.01)) - (let ((menu (appmenu-map))) - (if menu - (popup-menu-at-point menu) - (message "Appmenu is empty"))))) - -(defvar appmenu-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [apps] 'appmenu-popup) - (define-key map [mouse-3] 'appmenu-popup) - (define-key map [(control apps)] 'appmenu-as-help) - map)) - - -;;(setq appmenu-auto-help 4) -(defcustom appmenu-auto-help 2 - "Automatically show help on keymap at current point. -This shows up after the number of seconds in this variable. -If it it nil this feature is off. - -This feature is only on in `appmenu-mode'." - :type '(choice (number :tag "Number of seconds to wait") - (const :tag "Turned off" nil)) - :set (lambda (sym val) - (set-default sym val) - (if val - (add-hook 'post-command-hook 'appmenu-auto-help-post-command nil t) - (remove-hook 'post-command-hook 'appmenu-auto-help-post-command t))) - :group 'appmenu) - -(defcustom appmenu-auto-match-keymaps - '(css-color) - "Keymaps listed here can be avoided." - :type '(set (const unknown) - (const mlink) - (const css-color)) - :group 'appmenu) - -(defvar appmenu-auto-help-timer nil) - -(defun appmenu-dump-keymap (km) - (let ((fun (lambda (ev def) - (message "ev=%S def=%S" ev def) - (when (keymapp def) - (map-keymap fun def))))) - (map-keymap fun km))) - -(defun appmenu-on-keymap (where) - (setq where (or where (point))) - (let* ((rec (get-char-property-and-overlay where 'keymap)) - (kmp (car rec)) - (ovl (cdr rec))) - (when kmp - (or (memq 'unknown appmenu-auto-match-keymaps) - (and (memq 'css-color appmenu-auto-match-keymaps) - (get-text-property where 'css-color-type)) - (and (memq 'mlinks appmenu-auto-match-keymaps) - (boundp 'mlinks-point-hilighter-overlay) - (eq ovl mlinks-point-hilighter-overlay)) - )))) - -(defsubst appmenu-auto-help-add-wcfg (at-point wcfg) - (mumamo-with-buffer-prepared-for-jit-lock - (add-text-properties at-point (1+ at-point) - (list 'point-left 'appmenu-auto-help-maybe-remove - 'appmenu-auto-help-wcfg wcfg)))) - -(defsubst appmenu-auto-help-remove-wcfg (at-point) - (mumamo-with-buffer-prepared-for-jit-lock - (remove-list-of-text-properties at-point (1+ at-point) - '(appmenu-auto-help-wcfg point-left)))) - -(defun appmenu-auto-help-maybe-remove (at-point new-point) - "Run in 'point-left property. -Restores window configuration." - (let ((old-wcfg (get-text-property at-point 'appmenu-auto-help-wcfg))) - (appmenu-auto-help-remove-wcfg at-point) - (if (appmenu-on-keymap new-point) - (appmenu-auto-help-add-wcfg new-point old-wcfg) - (if old-wcfg - (set-window-configuration old-wcfg) - (help-xref-go-back (help-buffer)))))) - -(defun appmenu-as-help-in-timer (win buf) - (condition-case err - (when (and (eq (selected-window) win) - (eq (current-buffer) buf) - appmenu-auto-help - (appmenu-on-keymap (point))) - (let* ((old-help-win (get-buffer-window (help-buffer))) - (wcfg (unless old-help-win - (current-window-configuration)))) - (unless old-help-win - (display-buffer (help-buffer))) - (appmenu-auto-help-add-wcfg (point) wcfg) - (appmenu-as-help (copy-marker (point))))) - (error (message "appmenu-as-help-in-timer: %s" (error-message-string err))))) - -(defun appmenu-auto-help-cancel-timer () - (when (timerp appmenu-auto-help-timer) - (cancel-timer appmenu-auto-help-timer)) - (setq appmenu-auto-help-timer nil)) - -(defun appmenu-auto-help-post-command () - (when (fboundp 'appmenu-as-help) - (condition-case err - (appmenu-auto-help-post-command-1) - (error (message "css-color-post-command: %s" (error-message-string err)))))) - -;; #fff #c9ff33 -(defun appmenu-auto-help-post-command-1 () - (appmenu-auto-help-cancel-timer) - (and appmenu-auto-help - (appmenu-on-keymap (point)) - (not (get-text-property (point) 'appmenu-auto-help-wcfg)) - (setq appmenu-auto-help-timer - (run-with-idle-timer appmenu-auto-help nil 'appmenu-as-help-in-timer - (selected-window) - (current-buffer))))) - - -;;;###autoload -(define-minor-mode appmenu-mode - "Use a context sensitive popup menu. -AppMenu (appmenu.el) is a framework for creating cooperative -context sensitive popup menus with commands from different major -and minor modes. Using this different modes may cooperate about -the use of popup menus. - -There is also the command `appmenu-as-help' that shows the key -bindings at current point in the help buffer. - -The popup menu and the help buffer version are on these keys: - -\\{appmenu-mode-map} - -The variable `appmenu-alist' is where the popup menu entries -comes from. - -If there is a `keymap' property at point then relevant bindings -from this is also shown in the popup menu. - -You can write functions that use whatever information you want in -Emacs to construct these entries. Since this information is only -collected when the popup menu is shown you do not have to care as -much about computation time as for entries in the menu bar." - :global t - :keymap appmenu-mode-map - :group 'appmenu - (if appmenu-mode - (add-hook 'post-command-hook 'appmenu-auto-help-post-command) - (remove-hook 'post-command-hook 'appmenu-auto-help-post-command))) - -(when (and appmenu-mode - (not (boundp 'define-globa-minor-mode-bug))) - (appmenu-mode 1)) - -(provide 'appmenu) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; appmenu.el ends here diff --git a/emacs.d/nxhtml/util/as-external.el b/emacs.d/nxhtml/util/as-external.el deleted file mode 100644 index b1330c1..0000000 --- a/emacs.d/nxhtml/util/as-external.el +++ /dev/null @@ -1,310 +0,0 @@ -;;; as-external.el --- Emacs as an external editor to other apps -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: Mon Jun 25 19:02:49 2007 -(defconst as-external:version "0.6") ;;Version: -;; Last-Updated: 2009-08-04 Tue -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; This little library should make it easier to use Emacs as an -;; external editor in certain cases. One such case is when want to -;; use Emacs as the external editor with the Firefox add-on "It's All -;; Text". -;; -;; See variable `as-external-mode' for more information. -;; -;; -;;; A note on the implementation: -;; -;; You may wonder why this does not use `auto-mode-alist' since it -;; checks the file name in nearly the same way? It is perhaps possible -;; to use that, but there are two things to be aware of: -;; -;; 1. The choice made must override other possible choices. -;; -;; 2. Beside the file name the implementation here also checks if the -;; buffer has clients waiting. That makes the check more reliable. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'cl)) -(eval-when-compile (require 'html-write nil t)) -(eval-when-compile (require 'mlinks nil t)) -(eval-when-compile (require 'mumamo nil t)) -(eval-when-compile (require 'nxhtml-mode nil t)) -(eval-when-compile (require 'ourcomments-util nil t)) -(eval-when-compile (require 'pause nil t)) -(eval-when-compile (require 'server)) -(eval-when-compile (require 'wikipedia-mode nil t)) -(eval-and-compile (require 'wrap-to-fill nil t)) - -;;;###autoload -(defgroup as-external nil - "Settings related to Emacs as external editor." - :group 'nxhtml - :group 'external) - -(defcustom as-external-its-all-text-regexp "/itsalltext/" - "Regular expression matching It's All Text buffer's file." - :type 'regexp - :group 'as-external) - -(defcustom as-external-alist - '( - ("/itsalltext/.*wiki" as-external-for-wiki) - ("/itsalltext/.*mail" as-external-for-mail-mode) - ("/itsalltext/" as-external-for-xhtml) - ) - "List to determine setup if Emacs is used as an external Editor. -Element in this list should have the form - - \(FILE-REGEXP BUFFER-SETUP) - -where FILE-REGEXP should be a regular expression to match -`buffer-file-name'. If it matches then BUFFER-SETUP should be -called in the buffer. - -* Tip when using Firefox's add-on It's All Text: It looks like - the file name used will be constructed from the host url. For - example if your are editing something on - http://www.emacswiki.org/ the file name may be something like - 'www.emacswiki.org.283b1y212e.html'. - - -The list is processed by `as-external-setup'. Note that the first -match is used! - -The default entries in this list supports for Firefox addon It's -All Text: - -- `as-external-for-xhtml'. For text areas on web pages where you - can enter some XHTML code, for example blog comment fields. - -- `as-external-for-mail-mode', for editing web mail messages. - -- `as-external-for-wiki', for mediawiki. - -See also `as-external-mode'." - :type '(repeat - (list (choice (variable :tag "Regexp variable") - regexp) - command)) - :group 'as-external) - -(defcustom as-external-its-all-text-coding 'utf-8 - "Coding system to use for It's All Text buffers. -See also `as-external-for-xhtml'." - :type '(choice (const :tag "No special coding system" nil) - coding-system) - :group 'as-external) - -(defun as-external-fall-back (msg) - "Fallback to text-mode if necessary." - (text-mode) - (lwarn t :warning "%s. Using text-mode" msg)) - -;;;###autoload -(defun as-external-for-xhtml () - "Setup for Firefox addon It's All Text to edit XHTML. -It's All Text is a Firefox add-on for editing textareas with an -external editor. -See URL `https://addons.mozilla.org/en-US/firefox/addon/4125'. - -In this case Emacs is used to edit textarea fields on a web page. -The text will most often be part of a web page later, like on a -blog. Therefore turn on these: - -- `nxhtml-mode' since some XHTML tags may be allowed. -- `nxhtml-validation-header-mode' since it is not a full page. -- `wrap-to-fill-column-mode' to see what you are writing. -- `html-write-mode' to see it even better. - -Also bypass the question for line end conversion when using -emacsw32-eol." - (interactive) - (if (not (fboundp 'nxhtml-mode)) - (as-external-fall-back "Can't find nXhtml") - (nxhtml-mode) - (nxhtml-validation-header-mode 1) - (set (make-local-variable 'wrap-to-fill-left-marg-modes) - '(nxhtml-mode fundamental-mode)) - (wrap-to-fill-column-mode 1) - ;;(visible-point-mode 1) - (when (fboundp 'html-write-mode) (html-write-mode 1)) - (when (boundp 'emacsw32-eol-ask-before-save) - (make-local-variable 'emacsw32-eol-ask-before-save) - (setq emacsw32-eol-ask-before-save nil)))) - - -(defvar as-external-mail-mode-comment-pattern "^>.*$" - "Regular expression for a comment line.") - -(defvar as-external-mail-mode-email-pattern - (concat "[a-z0-9$%(*-=?[_][^<>\")!;:,{}]*" - "\@" - "\\(?:[a-z0-9\-]+\.\\)+[a-z0-9]\\{2,4\\}") - "Regular expression for a mail address.") - -(defvar as-external-mail-mode-font-lock-keywords - (list - (list as-external-mail-mode-comment-pattern - '(0 font-lock-comment-face)) - ;; (list as-external-mail-mode-email-pattern - ;; '(0 font-lock-keyword-face)) - )) - -;;;###autoload -(define-derived-mode as-external-for-mail-mode text-mode "ExtMail " - "Setup for Firefox addon It's All Text to edit mail. -Set normal mail comment markers in column 1 (ie >). - -Set `fill-column' to 90 and enable `wrap-to-fill-column-mode' so -that it will look similar to how it will look in the sent plain -text mail. - -See also `as-external-mode'." - ;; To-do: Look at http://globs.org/articles.php?lng=en&pg=2 - (set (make-local-variable 'comment-column) 0) - (set (make-local-variable 'comment-start) ">") - (set (make-local-variable 'comment-end) "") - (set (make-local-variable 'font-lock-defaults) - '((as-external-mail-mode-font-lock-keywords) nil)) - (setq fill-column 90) - (mlinks-mode 1) - (wrap-to-fill-column-mode 1)) - -;;;###autoload -(defun as-external-for-wiki () - "Setup for Firefox addon It's All Text to edit MediaWikis." - (interactive) - (require 'wikipedia-mode nil t) - (if (not (featurep 'wikipedia-mode)) - (as-external-fall-back "Can't find file wikipedia-mode.el") - (wikipedia-mode))) - - -;;;###autoload -(define-minor-mode as-external-mode - "If non-nil check if Emacs is called as external editor. -When Emacs is called as an external editor for example to edit -text areas on a web page viewed with Firefox this library tries -to help to setup the buffer in a useful way. It may for example -set major and minor modes for the buffer. - -This can for example be useful when blogging or writing comments -on blogs. - -See `as-external-alist' for more information." - :global t - :group 'as-external - ;;(modify-coding-system-alist 'file "/itsalltext/" as-external-its-all-text-coding) - (let ((coding-entry - (cons - as-external-its-all-text-regexp - (cons as-external-its-all-text-coding - as-external-its-all-text-coding)))) - ;;(message "as-external-mode=%s" as-external-mode) - (if as-external-mode - (progn - (add-to-list 'file-coding-system-alist coding-entry) - (add-hook 'server-visit-hook 'as-external-setup t)) - (setq file-coding-system-alist - (delq coding-entry file-coding-system-alist)) - (remove-hook 'server-visit-hook 'as-external-setup)))) - -(defun as-external-setup () - "Check if Emacs is used as an external editor. -If so then turn on useful major and minor modes. -This is done by checking `as-external-alist'." - (condition-case err - (as-external-setup-1) - (error (message "as-external-setup error: %s" err)))) - -(defvar as-external-my-frame nil) -(make-variable-buffer-local 'as-external-my-frame) - -(defvar as-external-last-buffer nil) - -(defun as-external-server-window-fix-frames () - (condition-case err - (with-current-buffer as-external-last-buffer - (unless (buffer-live-p pause-buffer) - (remove-hook 'pause-break-exit-hook 'as-external-server-window-fix-frames) - (setq as-external-my-frame (or as-external-my-frame - (make-frame))) - (dolist (f (frame-list)) - (unless (eq f as-external-my-frame) - (lower-frame f))) - (raise-frame as-external-my-frame))) - (error (message "%s" (error-message-string err))))) - -(defun as-external-server-window (buffer) - (setq server-window nil) - (with-current-buffer buffer - (setq as-external-last-buffer (current-buffer)) - (run-with-idle-timer 2 nil 'as-external-server-window-fix-frames) - (add-hook 'pause-break-exit-hook 'as-external-server-window-fix-frames) - (add-hook 'kill-buffer-hook 'as-external-delete-my-frame nil t))) - -(defun as-external-delete-my-frame () - (let ((win (and (frame-live-p as-external-my-frame) - (get-buffer-window nil as-external-my-frame)))) - (when (and win - (= 1 (length (window-list as-external-my-frame 'no-mini)))) - (delete-frame as-external-my-frame) - (lower-frame)))) - -(defun as-external-setup-1 () - ;; Fix-me: How does one know if the file names are case sensitive? - (unless (when (boundp 'nowait) nowait) ;; dynamically bound in `server-visit-files' - (unless server-window - ;; `server-goto-toplevel' has been done here. - ;; Setup to use a new frame - (setq server-window 'as-external-server-window)) - (catch 'done - (dolist (rec as-external-alist) - (let ((file-regexp (car rec)) - (setup-fun (cadr rec))) - (when (symbolp file-regexp) - (setq file-regexp (symbol-value file-regexp))) - (when (string-match file-regexp (buffer-file-name)) - (funcall setup-fun) - (throw 'done t))))))) - -(provide 'as-external) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; as-external.el ends here diff --git a/emacs.d/nxhtml/util/buffer-bg.el b/emacs.d/nxhtml/util/buffer-bg.el deleted file mode 100644 index d6459d6..0000000 --- a/emacs.d/nxhtml/util/buffer-bg.el +++ /dev/null @@ -1,89 +0,0 @@ -;;; buffer-bg.el --- Changing background color of windows -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-05-22T19:06:23+0200 Thu -;; Version: 0.5 -;; Last-Updated: 2008-05-22T23:19:55+0200 Thu -;; URL: http://www.emacswiki.org/cgi-bin/wiki/buffer-bg.el -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; There is currently no way to change background colors of Emacs -;; windows. This library implements a workaround using overlays. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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: - -(defvar buffer-bg-overlay nil) -(put 'buffer-bg-overlay 'permanent-local t) - -;;;###autoload -(defun buffer-bg-set-color (color buffer) - "Add an overlay with background color COLOR to buffer BUFFER. -If COLOR is nil remove previously added overlay." - (interactive - (let* ((prompt (if buffer-bg-overlay - "Background color (empty string to remove): " - "Background color: ")) - (color (read-color prompt nil t))) - (when (= 0 (length color)) - (setq color nil)) - (list color (current-buffer)) - )) - (if (not color) - (when buffer-bg-overlay - (delete-overlay buffer-bg-overlay) - (setq buffer-bg-overlay nil)) - (save-restriction - (widen) - (setq buffer-bg-overlay - (make-overlay (point-min) (point-max) nil nil t)) - ;; Fix-me: Let the overlay have priority 0 which is the - ;; lowest. Change this to below char properties if this is ever - ;; allowed in Emacs. - (overlay-put buffer-bg-overlay 'priority 0) - (let* ((bg-face (list :background color)) - (bg-after (propertize (make-string 10 ?\n) - 'face bg-face - 'intangible t))) - (overlay-put buffer-bg-overlay 'face bg-face) - ;; This is just confusing, don't use it: - ;;(overlay-put buffer-bg-overlay 'after-string bg-after) - ) - ))) - - -(provide 'buffer-bg) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; buffer-bg.el ends here diff --git a/emacs.d/nxhtml/util/chartg.el b/emacs.d/nxhtml/util/chartg.el deleted file mode 100644 index 7470710..0000000 --- a/emacs.d/nxhtml/util/chartg.el +++ /dev/null @@ -1,844 +0,0 @@ -;;; chartg.el --- Google charts (and maybe other) -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-04-06 Sun -(defconst chart:version "0.2") ;; Version: -;; Last-Updated: -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'cl)) - -(defconst chartg-types - '((line-chartg-x lc) - (line-chartg-xy lxy) - (line-chart ls) - - (bar-chartg-horizontal bhs) - (bar-chartg-vertical bvs) - (bar-chartg-horizontal-grouped bhg) - (bar-chartg-vertical-grouped bvg) - - (pie-2-dimensional p) - (pie-3-dimensional p3) - - (venn-diagram v) - (scatter-plot s) - - (radar-chart r) - (radar-chartg-w-splines rs) - - (geographical-map t) - (meter gom))) - -(defconst chartg-types-keywords - (mapcar (lambda (rec) - (symbol-name (car rec))) - chartg-types)) - -(defvar chartg-mode-keywords-and-states - '(("Output-file:" (accept file-name)) - ("Size:" (accept number)) - ("Data:" (accept number)) - ("Type:" (accept chartg-type)) - )) - -(defvar chartg-mode-keywords - (mapcar (lambda (rec) - (car rec)) - chartg-mode-keywords-and-states)) - -;; Fix-me: I started to implement a parser, but I think I will drop it -;; and wait for Semantic to be easily available instead. Or just use -;; Calc/Org Tables. - -(defvar chartg-intermediate-states - '((end-or-label (or end-of-file label)) - )) - -(defvar chartg-extra-keywords-and-states - '( - ;;("Provider:") - ("Colors:") - ("Solid-fill:") - ("Linear-gradient:") - ("Linear-stripes:") - ("Chartg-title:" (and string end-or-label)) - ("Legends:" (accept string)) - ("Axis-types:") - ("Axis-labels:") - ("Axis-ranges:") - ("Axis-styles:") - ("Bar-thickness:") - ("Bar-chartg-zero-line:") - ("Bar-chartg-zero-line-2:") - ("Line-styles-1:") - ("Line-styles-2:") - ("Grid-lines:") - ("Shape-markers:") - ("Range-markers:") - )) - -(defvar chartg-extra-keywords - (mapcar (lambda (rec) - (car rec)) - chartg-extra-keywords-and-states)) - -(defvar chartg-raw-keywords-and-states - '( - ("Google-chartg-raw:" (accept string)) - )) - -(defvar chartg-raw-keywords - (mapcar (lambda (rec) - (car rec)) - chartg-raw-keywords-and-states)) - -(defvar chartg-mode-keywords-re (regexp-opt chartg-mode-keywords)) -(defvar chartg-extra-keywords-re (regexp-opt chartg-extra-keywords)) -(defvar chartg-types-keywords-re (regexp-opt chartg-types-keywords)) -(defvar chartg-raw-keywords-re (regexp-opt chartg-raw-keywords)) - -(defvar chartg-font-lock-keywords - `((,chartg-mode-keywords-re . font-lock-keyword-face) - (,chartg-extra-keywords-re . font-lock-variable-name-face) - (,chartg-types-keywords-re . font-lock-function-name-face) - (,chartg-raw-keywords-re . font-lock-preprocessor-face) - )) - -(defvar chartg-font-lock-defaults - '(chartg-font-lock-keywords nil t)) - -(defvar chartg-mode-syntax-table - (let ((table (make-syntax-table))) - (modify-syntax-entry ?\n "> " table) - (modify-syntax-entry ?\; "< " table) - table)) - -(defun chartg-create (provider out-file size data type - title legends &optional extras) - "Create a chart image. -PROVIDER is what to use for creating the chart. Currently only -`google' for Google's chart API is supported. - -OUT-FILE is where the image goes. - -SIZE is a cons cell with pixel width and height. - -DATA is the data to draw the chart from. It is a list of data -sets where each data set has the form: - - (list (list NUMBERS ...) (MIN . MAX))) - -TYPE can be the following: - -* Line charts - - - lc: Line chart with only y values. Each dataset is a new - line. - - - lxy: Line chart with both x and y values. For each line there - should be a pair of datasets, the first for x and the second - for y. If the x dataset just contains a single -1 then values - are evenly spaced along the x-axis. - - - ls: Like above, but axis are not drawn. - -* Bar charts: - - - bhs: horizontal bars. - - bvs: vertical bars. - - bhg, bvg: dito grouped. - -* Pie charts: - - - cht=p: one dimensional - - cht=p3: three dimensional - -* Venn diagrams - - - cht=v: data should be specified as - * the first three values specify the relative sizes of three - circles, A, B, and C - * the fourth value specifies the area of A intersecting B - * the fifth value specifies the area of A intersecting C - * the sixth value specifies the area of B intersecting C - * the seventh value specifies the area of A intersecting B - intersecting C - -* Scatter plots - - - cht=s: Supply a pair of datasets, first for x and second for - y coordinates. - -* Radar charts - - - cht=r: straight lines. - - cht=rs: splines. - - You will have to find out the format of the datasets - yourself, I don't understand it ;-) - - Or perhaps mail google? - -* Maps - - - cht=t - - together with - - - chtm=AREA: AREA for provider `google' is currently one of - * africa - * asia - * europe - * middle_east - * south_america - * usa - * world - -* Meter - - - cht=gom: A speed meter type meter. Takes a single value. - -TITLE is a string to use as title. - -LEGENDS is a list of labels to put on the data. - -EXTRAS is a list of extra arguments with the form - - (EXTRA-TYPE EXTRA-VALUE) - -Where EXTRA-TYPE is the extra argument type and EXTRA-VALUE the -value. The following EXTRA-TYPEs are supported: - -* COLORS: value is a list of colors corresponding to the list of - DATA. Each color have the format RRGGBB or RRGGBBTT where the - first form is the normal way to specify colors in rgb-format - and the second has an additional TT for transparence. TT=00 - means completely transparent and TT=FF means completely opaque. - -FILL-AREA are fill colors for data sets in line charts. It should -be a list - - (list COLOR START-INDEX END-INDEX) - -" - (message "(chartg-create %s %s %s %s %s %s %s" provider out-file size data type - title legends) - (unless (symbolp type) - (error "Argument TYPE should be a symbol")) - (unless (assoc type chartg-types) - (error "Unknown chart type: %s" type)) - (cond - ((eq provider 'google) - (let* ((g-type (nth 1 (assoc type chartg-types))) - (width (car size)) - (height (cdr size)) - ;;(size-par (format "&chs=%sx%s" width height)) - ;; - numbers - scales - colors-par - ;; - url - content - ) - (setq url - (format - "http://chart.apis.google.com/chart?cht=%s&chs=%dx%d" g-type width height)) - ;;(setq url (concat url size-par)) - ;; Data and scales - (unless data - (error "No data")) - (dolist (rec data) - (let* ((rec-numbers (car rec)) - (number-str - (let (str) - (dolist (num rec-numbers) - (setq str - (if (not str) - (number-to-string num) - (concat str "," (number-to-string num))))) - str)) - (rec-scale (cadr rec)) - (rec-min (car rec-scale)) - (rec-max (cdr rec-scale)) - (scale-str (when rec-scale (format "%s,%s" rec-min rec-max))) - ) - (if (not numbers) - (progn - (setq numbers (concat "&chd=t:" number-str)) - (when (or scale-str - (memq g-type '(p p3 gom))) - (setq scales (concat "&chds=" scale-str)))) - (setq numbers (concat numbers "|" number-str)) - (when scale-str - (setq scales (concat scales "," scale-str)))))) - (setq url (concat url numbers)) - (when scales (setq url (concat url scales))) - ;; fix-me: encode the url - (when title (setq url (concat url "&chtt=" (url-hexify-string title)))) - (when legends - (let ((url-legends (mapconcat 'url-hexify-string legends "|")) - (arg (if (memq g-type '(p p3 gom)) - "&chl=" - "&chdl="))) - (setq url (concat url arg url-legends)))) - (dolist (extra extras) - (let ((extra-type (car extra)) - (extra-value (cdr extra))) - (cond - ((eq extra-type 'GOOGLE-RAW) - (setq url (concat url extra-value))) - ((eq extra-type 'colors) - ;; Colors - (dolist (color extra-value) - (if (not colors-par) - (setq colors-par (concat "&chco=" color)) - (setq colors-par (concat colors-par "," color)))) - (when colors-par (setq url (concat url colors-par)))) - (t (error "Unsupported extra type: %s" extra-type))))) - - ;;(lwarn t :warning "url=%s" url)(top-level) - ;;(setq url (concat url "&chxt=y")) - (message "Sending %s" url) - (setq content - (with-current-buffer (url-retrieve-synchronously url) - (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - (buffer-substring-no-properties (point) (point-max)) - (view-buffer-other-window (current-buffer)) - (error "Bad content")))) - (let* ((is-html (string-match-p "</body></html>" content)) - (fname (progn - (when is-html - (setq out-file (concat (file-name-sans-extension out-file) ".html"))) - (expand-file-name out-file) - )) - (do-it (or (not (file-exists-p fname)) - (y-or-n-p - (concat "File " fname " exists. Replace it? ")))) - (buf (find-buffer-visiting fname)) - (this-window (selected-window))) - (when do-it - (when buf (kill-buffer buf)) - (with-temp-file fname - (insert content)) - (if (not is-html) - (view-file-other-window fname) - (chartg-show-last-error-file fname)) - (select-window this-window))))) - (t (error "Unknown provider: %s" provider))) - ) - -(defun chartg-show-last-error-file (fname) - (interactive) - (with-output-to-temp-buffer (help-buffer) - (help-setup-xref (list #'chartg-show-last-error-file fname) (interactive-p)) - (with-current-buffer (help-buffer) - (insert "Error, see ") - (insert-text-button "result error page" - 'action - `(lambda (btn) - (browse-url ,fname)))))) - -(defvar chartg-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(meta tab)] 'chartg-complete) - (define-key map [(control ?c) (control ?c)] 'chartg-make-chart) - map)) - -(defun chartg-missing-keywords () - (let ((collection (copy-sequence chartg-mode-keywords))) - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while (re-search-forward chartg-mode-keywords-re nil t) - (setq collection - (delete (match-string-no-properties 0) - collection))))) - collection)) - -;;;###autoload -(defun chartg-complete () - (interactive) - (let* ((here (point)) - (partial (when (looking-back (rx word-start - (optional ?\") - (0+ (any "[a-z]")))) - (match-string-no-properties 0))) - (part-pos (if partial - (match-beginning 0) - (setq partial "") - (point))) - (state (catch 'pos-state (chartg-get-state (point)))) - (msg "No completions") - collection - all - prompt - res) - (when state - (cond - ((or (= (current-column) 0) - (equal state 'need-label)) - (setq collection (append (chartg-missing-keywords) - chartg-extra-keywords - chartg-raw-keywords - nil)) - (setq prompt "Label: ")) - ((equal state '(accept number)) - (setq res nil) - (setq msg (propertize "Needs a number here!" - 'face 'secondary-selection))) - ((equal state '(accept chartg-type)) - (setq collection chartg-types-keywords) - (setq prompt "Chart type: ")) - ((equal state '(accept file-name)) - (setq res - (concat "\"" (read-file-name "Output-file: " - nil - ;; fix-me: handle partial - partial) - "\"")))) - (when collection - (let ((all (if partial - (all-completions partial collection) - collection))) - (setq res (when all - (if (= (length all) 1) - (car all) - (completing-read prompt collection nil t partial))))))) - (if (not res) - (message "%s" msg) - (insert (substring res (length partial)))))) - - -(defun chartg-get-state (want-pos-state) - (let* (par-output-file - par-provider - par-size - par-data par-data-temp - par-data-min par-data-max - par-type - par-title - par-legends - par-google-raw - (here (point)) - token-before-pos - pos-state - (state 'need-label) - (problems - (catch 'problems - (save-restriction - ;;(widen) - (if want-pos-state - (unless (re-search-backward chartg-mode-keywords-re nil t) - (goto-char (point-min))) - (goto-char (point-min))) - (let (this-keyword - this-start - this-end - params - token - token-pos - next-token - found-labels - current-label) - (while (or token - (progn - (setq pos-state state) - (setq token-before-pos (point)) - (condition-case err - (setq token (read (current-buffer))) - (error - (if (eq (car err) 'end-of-file) - (unless (or (eq state 'need-label) - (member '(quote |) state)) - (throw 'problems (format "Unexpected end, state=%s" state))) - (throw 'problems - (error-message-string err))))))) - (message "token=%s, label=%s, state=%s" token current-label state) - (when (and want-pos-state - (>= (point) want-pos-state)) - (when (= (point) want-pos-state) - ;; right after item - (setq pos-state nil)) - (goto-char here) - (throw 'pos-state pos-state)) - (when (and (listp state) (memq 'number state)) - (unless (numberp token) - (save-match-data - (let ((token-str (format "%s" token))) - (setq token-str (replace-regexp-in-string "\\([0-9]\\),\\([0-9]\\)" "\\1\\2" token-str)) - (when (string-match-p "^[0-9]+$" token-str) - (setq token (string-to-number token-str))))))) - (cond ;; state - ;; Label - ((eq state 'need-label) - (unless (symbolp token) - (throw 'problems (format "Expected label, got %s" token))) - (unless (member (symbol-name token) - (append chartg-mode-keywords - chartg-extra-keywords - chartg-raw-keywords - nil)) - (throw 'problems (format "Unknown label %s" token))) - (when (member (symbol-name token) found-labels) - (throw 'problems (format "Label %s defined twice" token))) - (setq current-label token) - (setq found-labels (cons current-label found-labels)) - (setq token nil) - ;;(setq state 'need-value) - (case current-label - ('Output-file: - (setq state '(accept file-name))) - ('Size: - (setq state '(accept number))) - ('Data: - (setq state '(accept number))) - ('Type: - (setq state '(accept chartg-type))) - ('Chartg-title: - (setq state '(accept string))) - ('Legends: - (setq state '(accept string))) - ('Google-chartg-raw: - (setq state '(accept string))) - )) - ;;;; Values - ;; Alt - ((equal state '(accept '| symbol)) - (if (eq '| token) - (case current-label - ('Legends: - (setq token nil) - (setq state '(accept string))) - (t (error "internal error, current-label=%s, state=%s" current-label state))) - (if (symbolp token) - (progn - ;;(setq token nil) - (setq state 'need-label)) - (throw 'problems (format "Expected | or label, got %s" token))))) - ;; Strings - ((equal state '(accept string)) - (unless (stringp token) - (throw 'problems "Expected string")) - (case current-label - ('Chartg-title: - (setq par-title token) - (setq token nil) - (setq state 'need-label)) - ('Legends: - (setq par-legends (cons token par-legends)) - (setq token nil) - (setq state '(accept '| symbol))) - ('Google-chartg-raw: - (setq par-google-raw token) - (setq token nil) - (setq state 'need-label)) - (t (error "internal error, current-label=%s, state=%s" current-label state)))) - ;; Output file - ((equal state '(accept file-name)) - (unless (stringp token) - (throw 'problems "Expected file name string")) - (assert (eq current-label 'Output-file:)) - (setq par-output-file token) - (setq token nil) - (setq state 'need-label)) - ;; Numbers - ((equal state '(accept number)) - (unless (numberp token) - (throw 'problems "Expected number")) - (case current-label - ('Size: - (if (not par-size) - (progn - (setq par-size token) - (setq token nil) - (setq state '(accept number 'x 'X))) - (setq par-size (cons par-size token)) - (setq token nil) - (setq state 'need-label))) - ('Data: - ;;(assert (not par-data-temp)) - (setq par-data-temp (cons token par-data-temp)) - (setq par-data-min token) - (setq par-data-max token) - (setq token nil) - (setq state '(accept number ', '| symbol)) - ) - (t (error "internal error, state=%s, current-label=%s" state current-label))) - ) - ;; Numbers or | - ((equal state '(accept number ', '| symbol)) - (if (numberp token) - (progn - (setq par-data-min (if par-data-min (min par-data-min token) token)) - (setq par-data-max (if par-data-max (max par-data-max token) token)) - (setq par-data-temp (cons token par-data-temp)) - (message "par-data-min/max=%s/%s, token=%s -- %s" par-data-min par-data-max token par-data-temp) - (setq token nil)) - (if (eq ', token) - (setq token nil) - (if (or (eq '| token) - (symbolp token)) - (progn - (unless par-data-temp - (throw 'problems "Empty data set")) - (setq par-data (cons (list (reverse par-data-temp) (cons par-data-min par-data-max)) par-data)) - (setq par-data-temp nil) - (setq par-data-min nil) - (setq par-data-max nil) - (if (not (eq '| token)) - (setq state 'need-label) - (setq state '(accept number)) - (setq token nil))) - (throw 'problems "Expected | or EOF") - )))) - ;; Numbers or x/X - ((equal state '(accept number 'x 'X)) - (assert (eq current-label 'Size:)) - (let ((is-n (numberp token)) - (is-x (memq token '(x X)))) - (unless (or is-n is-x) - (throw 'problems "Expected X or number")) - (if is-x - (progn - (setq token nil) - (setq state '(accept number))) - (setq par-size (cons par-size token)) - (setq token nil) - (setq state 'need-label)))) - ;; Chart type - ((equal state '(accept chartg-type)) - (setq par-type token) - (unless (assoc par-type chartg-types) - (throw 'problems (format "Unknown chart type: %s" par-type))) - (setq token nil) - (setq state 'need-label)) - (t (error "internal error, state=%s" state)))))) - ;; fix-me here - - nil))) - (when want-pos-state - (goto-char here) - (throw 'pos-state state)) - (unless problems - (let ((missing-lab (chartg-missing-keywords))) - (when missing-lab - (setq problems (format "Missing required labels: %s" missing-lab))))) - (if problems - (let ((msg (if (listp problems) - (nth 1 problems) - problems)) - (where (if (listp problems) - (nth 0 problems) - token-before-pos))) - (goto-char where) - (skip-chars-forward " \t") - (error msg)) - (goto-char here) - ;;(defun chartg-create (out-file provider size data type &rest extras) - (setq par-provider 'google) - (setq par-legends (nreverse par-legends)) - (let ((extras nil)) - (when par-google-raw - (setq extras (cons (cons 'GOOGLE-RAW par-google-raw) extras))) - (chartg-create par-provider par-output-file par-size - par-data par-type par-title par-legends extras)) - nil))) - -;;;###autoload -(defun chartg-make-chart () - "Try to make a new chart. -If region is active then make a new chart from data in the -selected region. - -Else if current buffer is in `chartg-mode' then do it from the -chart specifications in this buffer. Otherwise create a new -buffer and initialize it with `chartg-mode'. - -If the chart specifications are complete enough to make a chart -then do it and show the resulting chart image. If not then tell -user what is missing. - -NOTE: This is beta, no alpha code. It is not ready. - -Below are some examples. To test them mark an example and do - - M-x chartg-make-chart - -* Example, simple x-y chart: - - Output-file: \"~/temp-chart.png\" - Size: 200 200 - Data: 3 8 5 | 10 20 30 - Type: line-chartg-xy - -* Example, pie: - - Output-file: \"~/temp-depression.png\" - Size: 400 200 - Data: - 2,160,000 - 3,110,000 - 1,510,000 - 73,600 - 775,000 - 726,000 - 8,180,000 - 419,000 - Type: pie-3-dimensional - Chartg-title: \"Depression hits on Google\" - Legends: - \"SSRI\" - | \"Psychotherapy\" - | \"CBT\" - | \"IPT\" - | \"Psychoanalysis\" - | \"Mindfulness\" - | \"Meditation\" - | \"Exercise\" - - -* Example, pie: - - Output-file: \"~/temp-panic.png\" - Size: 400 200 - Data: - 979,000 - 969,000 - 500,000 - 71,900 - 193,000 - 154,000 - 2,500,000 - 9,310,000 - Type: pie-3-dimensional - Chartg-title: \"Depression hits on Google\" - Legends: - \"SSRI\" - | \"Psychotherapy\" - | \"CBT\" - | \"IPT\" - | \"Psychoanalysis\" - | \"Mindfulness\" - | \"Meditation\" - | \"Exercise\" - - -* Example using raw: - - Output-file: \"~/temp-chartg-slipsen-kostar.png\" - Size: 400 130 - Data: 300 1000 30000 - Type: bar-chartg-horizontal - Chartg-title: \"Vad killen i slips tjänar jämfört med dig och mig\" - Google-chartg-raw: \"&chds=0,30000&chco=00cd00|ff4500|483d8b&chxt=y,x&chxl=0:|Killen+i+slips|Partiledarna|Du+och+jag&chf=bg,s,ffd700\" - - -" - (interactive) - (if mark-active - (let* ((rb (region-beginning)) - (re (region-end)) - (data (buffer-substring-no-properties rb re)) - (buf (generate-new-buffer "*Chart from region*"))) - (switch-to-buffer buf) - (insert data) - (chartg-mode)) - (unless (eq major-mode 'chartg-mode) - (switch-to-buffer (generate-new-buffer "*Chart*")) - (chartg-mode))) - (chartg-get-state nil)) - -;; (defun chartg-from-region (min max) -;; "Try to make a new chart from data in selected region. -;; See `chartg-mode' for examples you can test with this function." -;; (interactive "r") -;; (unless mark-active (error "No region selected")) -;; (let* ((rb (region-beginning)) -;; (re (region-end)) -;; (data (buffer-substring-no-properties rb re)) -;; (buf (generate-new-buffer "*Chart from region*"))) -;; (switch-to-buffer buf) -;; (insert data) -;; (chartg-mode) -;; (chartg-get-state nil))) - -(define-derived-mode chartg-mode fundamental-mode "Chart" - "Mode for specifying charts. -\\{chartg-mode-map} - -To make a chart see `chartg-make-chart'. - -" - (set (make-local-variable 'font-lock-defaults) chartg-font-lock-defaults) - (set (make-local-variable 'comment-start) ";") - ;; Look within the line for a ; following an even number of backslashes - ;; after either a non-backslash or the line beginning. - (set (make-local-variable 'comment-start-skip) - "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") - ;; Font lock mode uses this only when it KNOWS a comment is starting. - (set (make-local-variable 'font-lock-comment-start-skip) ";+ *") - (set (make-local-variable 'comment-add) 1) ;default to `;;' in comment-region - (set (make-local-variable 'comment-column) 40) - ;; Don't get confused by `;' in doc strings when paragraph-filling. - (set (make-local-variable 'comment-use-global-state) t) - (set-syntax-table chartg-mode-syntax-table) - (when (looking-at (rx buffer-start (0+ whitespace) buffer-end)) - (insert ";; Type C-c C-c to make a chart, M-Tab to complete\n")) - (let ((missing (chartg-missing-keywords))) - (when missing - (save-excursion - (goto-char (point-max)) - (dolist (miss missing) - (insert "\n" miss " ")))))) - -;; Tests -;;(chartg-create 'google "temp.png" '(200 . 150) '(((90 70) . nil)) 'pie-3-dimensional "test title" nil '((colors "FFFFFF" "00FF00"))) - -;; Fix-me -(add-to-list 'auto-mode-alist '("\\.mx-chart\\'" . chartg-mode)) - -(provide 'chartg) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; chartg.el ends here diff --git a/emacs.d/nxhtml/util/css-color.el b/emacs.d/nxhtml/util/css-color.el deleted file mode 100644 index 38d400c..0000000 --- a/emacs.d/nxhtml/util/css-color.el +++ /dev/null @@ -1,983 +0,0 @@ -;;; css-color.el --- Highlight and edit CSS colors - -(defconst css-color:version "0.03") -;; Copyright (C) 2008 Niels Giesen - -;; Author: Niels Giesen -;; Keywords: processes, css, extensions, tools -;; Some smaller changes made by Lennart Borgman - -;; Last-Updated: 2009-10-19 Mon - -;; 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: - -;; Edit css-colors in hex, rgb or hsl notation in-place, with -;; immediate feedback by font-locking. Cycle between color-spaces. - -;; Usage: - -;; (autoload 'css-color-mode "css-color" "" t) -;; (add-hook 'css-mode-hook 'css-color-mode-turn-on) - -;; Css-Css-color.el propertizes colours in a CSS stylesheet found by -;; font-locking code with a keymap. From that keymap, you can easily -;; adjust values such as red green and blue, hue, saturation and -;; value, or switch between different color (space) notations. - -;; It supports all 'css-colors', so hex, rgb(), hsl() and even HTML -;; color names (although I wouldn't use them myself, it is nice to be -;; able to quickly convert those), can be used and switched between. - -;; The rgb() notation can be expressed either in percentages or in -;; values between 0-255. - -;; You can cycle between the different formats (with SPACE), so that -;; it is possible to edit the color in hsl mode (which is more -;; intuitive than hsv, although hsv has its merits too), and switch -;; back to rgb or hex if so desired. - -;; With point on a color, the keys - and = to are bound to the down -;; and up functions for channels (or 'fields'). Toggling percentage -;; in rgb() is done with the % key (not sure if that is wise -;; though). The TAB key is bound to go to the next channel, cycling -;; when at the end. color.el propertizes the longhand hexcolours -;; found by the - -;; Caveats: - -;; Notation cycling can often introduce small errors inherent to -;; switching color spaces. Currently there is no check nor a warning -;; for that. - -;; ToDo: - -;; Try and fix those conversion inaccuracies. This cannot be done -;; completely I guess. But maybe we can check whether this has -;; occured, and then warn. - -;;; Change log: - -;; 2009-01-11 Lennart Borgman -;; - Minor code clean up. -;; 2009-05-23 Lennart Borgman -;; - Let bound m1 and m2. - -;;; Code: -(eval-when-compile (require 'cl)) -(eval-when-compile (require 'mumamo nil t)) - -;;;###autoload -(defgroup css-color () - "Customization group for library `css-color'." - :group 'css - :group 'nxhtml) - -(defconst css-color-hex-chars "0123456789abcdefABCDEF" - "Composing chars in hexadecimal notation, save for the hash (#) sign.") - -(defconst css-color-hex-re - "#\\([a-fA-F[:digit:]]\\{6\\}\\|[a-fA-F[:digit:]]\\{3\\}\\)") - -(defconst css-color-hsl-re - "hsla?(\\([[:digit:]]\\{1,3\\}\\),[[:space:]]*\\([[:digit:]]\\{1,3\\}\\(?:\.?[[:digit:]]*\\)\\)%,[[:space:]]*\\([[:digit:]]\\{1,3\\}\\)\\(?:\.?[[:digit:]]*\\)%)") - -(defconst css-color-rgb-re - "rgba?(\\([[:digit:]]\\{1,3\\}\\(?:\.?[[:digit:]]*%\\)?\\),[[:space:]]*\\([[:digit:]]\\{1,3\\}\\(?:\.?[[:digit:]]*%\\)?\\),[[:space:]]*\\([[:digit:]]\\{1,3\\}\\(?:\.?[[:digit:]]*%\\)?\\)\\(:?,[[:space:]]*\\(0\.[0-9]+\\|1\\)\\)?)") - -(defconst css-color-html-colors - '(("AliceBlue" "#F0F8FF") - ("AntiqueWhite" "#FAEBD7") - ("Aqua" "#00FFFF") - ("Aquamarine" "#7FFFD4") - ("Azure" "#F0FFFF") - ("Beige" "#F5F5DC") - ("Bisque" "#FFE4C4") - ("Black" "#000000") - ("BlanchedAlmond" "#FFEBCD") - ("Blue" "#0000FF") - ("BlueViolet" "#8A2BE2") - ("Brown" "#A52A2A") - ("BurlyWood" "#DEB887") - ("CadetBlue" "#5F9EA0") - ("Chartreuse" "#7FFF00") - ("Chocolate" "#D2691E") - ("Coral" "#FF7F50") - ("CornflowerBlue" "#6495ED") - ("Cornsilk" "#FFF8DC") - ("Crimson" "#DC143C") - ("Cyan" "#00FFFF") - ("DarkBlue" "#00008B") - ("DarkCyan" "#008B8B") - ("DarkGoldenRod" "#B8860B") - ("DarkGray" "#A9A9A9") - ("DarkGrey" "#A9A9A9") - ("DarkGreen" "#006400") - ("DarkKhaki" "#BDB76B") - ("DarkMagenta" "#8B008B") - ("DarkOliveGreen" "#556B2F") - ("Darkorange" "#FF8C00") - ("DarkOrchid" "#9932CC") - ("DarkRed" "#8B0000") - ("DarkSalmon" "#E9967A") - ("DarkSeaGreen" "#8FBC8F") - ("DarkSlateBlue" "#483D8B") - ("DarkSlateGray" "#2F4F4F") - ("DarkSlateGrey" "#2F4F4F") - ("DarkTurquoise" "#00CED1") - ("DarkViolet" "#9400D3") - ("DeepPink" "#FF1493") - ("DeepSkyBlue" "#00BFFF") - ("DimGray" "#696969") - ("DimGrey" "#696969") - ("DodgerBlue" "#1E90FF") - ("FireBrick" "#B22222") - ("FloralWhite" "#FFFAF0") - ("ForestGreen" "#228B22") - ("Fuchsia" "#FF00FF") - ("Gainsboro" "#DCDCDC") - ("GhostWhite" "#F8F8FF") - ("Gold" "#FFD700") - ("GoldenRod" "#DAA520") - ("Gray" "#808080") - ("Grey" "#808080") - ("Green" "#008000") - ("GreenYellow" "#ADFF2F") - ("HoneyDew" "#F0FFF0") - ("HotPink" "#FF69B4") - ("IndianRed" "#CD5C5C") - ("Indigo" "#4B0082") - ("Ivory" "#FFFFF0") - ("Khaki" "#F0E68C") - ("Lavender" "#E6E6FA") - ("LavenderBlush" "#FFF0F5") - ("LawnGreen" "#7CFC00") - ("LemonChiffon" "#FFFACD") - ("LightBlue" "#ADD8E6") - ("LightCoral" "#F08080") - ("LightCyan" "#E0FFFF") - ("LightGoldenRodYellow" "#FAFAD2") - ("LightGray" "#D3D3D3") - ("LightGrey" "#D3D3D3") - ("LightGreen" "#90EE90") - ("LightPink" "#FFB6C1") - ("LightSalmon" "#FFA07A") - ("LightSeaGreen" "#20B2AA") - ("LightSkyBlue" "#87CEFA") - ("LightSlateGray" "#778899") - ("LightSlateGrey" "#778899") - ("LightSteelBlue" "#B0C4DE") - ("LightYellow" "#FFFFE0") - ("Lime" "#00FF00") - ("LimeGreen" "#32CD32") - ("Linen" "#FAF0E6") - ("Magenta" "#FF00FF") - ("Maroon" "#800000") - ("MediumAquaMarine" "#66CDAA") - ("MediumBlue" "#0000CD") - ("MediumOrchid" "#BA55D3") - ("MediumPurple" "#9370D8") - ("MediumSeaGreen" "#3CB371") - ("MediumSlateBlue" "#7B68EE") - ("MediumSpringGreen" "#00FA9A") - ("MediumTurquoise" "#48D1CC") - ("MediumVioletRed" "#C71585") - ("MidnightBlue" "#191970") - ("MintCream" "#F5FFFA") - ("MistyRose" "#FFE4E1") - ("Moccasin" "#FFE4B5") - ("NavajoWhite" "#FFDEAD") - ("Navy" "#000080") - ("OldLace" "#FDF5E6") - ("Olive" "#808000") - ("OliveDrab" "#6B8E23") - ("Orange" "#FFA500") - ("OrangeRed" "#FF4500") - ("Orchid" "#DA70D6") - ("PaleGoldenRod" "#EEE8AA") - ("PaleGreen" "#98FB98") - ("PaleTurquoise" "#AFEEEE") - ("PaleVioletRed" "#D87093") - ("PapayaWhip" "#FFEFD5") - ("PeachPuff" "#FFDAB9") - ("Peru" "#CD853F") - ("Pink" "#FFC0CB") - ("Plum" "#DDA0DD") - ("PowderBlue" "#B0E0E6") - ("Purple" "#800080") - ("Red" "#FF0000") - ("RosyBrown" "#BC8F8F") - ("RoyalBlue" "#4169E1") - ("SaddleBrown" "#8B4513") - ("Salmon" "#FA8072") - ("SandyBrown" "#F4A460") - ("SeaGreen" "#2E8B57") - ("SeaShell" "#FFF5EE") - ("Sienna" "#A0522D") - ("Silver" "#C0C0C0") - ("SkyBlue" "#87CEEB") - ("SlateBlue" "#6A5ACD") - ("SlateGray" "#708090") - ("SlateGrey" "#708090") - ("Snow" "#FFFAFA") - ("SpringGreen" "#00FF7F") - ("SteelBlue" "#4682B4") - ("Tan" "#D2B48C") - ("Teal" "#008080") - ("Thistle" "#D8BFD8") - ("Tomato" "#FF6347") - ("Turquoise" "#40E0D0") - ("Violet" "#EE82EE") - ("Wheat" "#F5DEB3") - ("White" "#FFFFFF") - ("WhiteSmoke" "#F5F5F5") - ("Yellow" "#FFFF00") - ("YellowGreen" "#9ACD32"))) - -(defvar css-color-html-re - (concat "\\<\\(" - (funcall 'regexp-opt - (mapcar 'car css-color-html-colors)) - "\\)\\>")) - -(defconst - css-color-color-re - "\\(?:#\\(?:[a-fA-F[:digit:]]\\{6\\}\\|[a-fA-F[:digit:]]\\{3\\}\\)\\|hsl(\\(?:[[:digit:]]\\{1,3\\}\\),[[:space:]]*\\(?:[[:digit:]]\\{1,3\\}\\)%,[[:space:]]*\\(?:[[:digit:]]\\{1,3\\}\\)%)\\|rgba?(\\(?:[[:digit:]]\\{1,3\\}%?\\),[[:space:]]*\\(?:[[:digit:]]\\{1,3\\}%?\\),[[:space:]]*\\(?:[[:digit:]]\\{1,3\\}%?\\)\\(?:,[[:space:]]*\\(?:0.[0-9]+\\|1\\)\\)?)\\)" - "Regular expression containing only shy groups matching any type of CSS color") - -;; (defconst css-color-color-re -;; (concat "\\(?1:" -;; (mapconcat -;; 'identity -;; (list css-color-hex-re -;; css-color-hsl-re -;; css-color-rgb-re) "\\|") -;; "\\)")) - -(defvar css-color-keywords - `((,css-color-hex-re - (0 - (progn - (when (= 7 (- (match-end 0) - (match-beginning 0))) - (put-text-property (match-beginning 0) - (match-end 0) - 'keymap css-color-map)) - (put-text-property (match-beginning 0) - (match-end 0) - 'css-color-type 'hex) - (put-text-property (match-beginning 0) - (match-end 0) - 'rear-nonsticky t) - (put-text-property (match-beginning 0) - (match-end 0) - 'face (list :background - (match-string-no-properties 0) - :foreground - (css-color-foreground-color - (match-string-no-properties 0))))))) - (,css-color-html-re - (0 - (let ((color - (css-color-string-name-to-hex (match-string-no-properties 0)))) - (put-text-property (match-beginning 0) - (match-end 0) - 'keymap css-color-generic-map) - (put-text-property (match-beginning 0) - (match-end 0) - 'css-color-type 'name) - (put-text-property (match-beginning 0) - (match-end 0) - 'rear-nonsticky t) - (put-text-property (match-beginning 0) - (match-end 0) - 'face (list :background - color - :foreground - (css-color-foreground-color - color)))))) - (,css-color-hsl-re - (0 - (let ((color (concat "#" (apply 'css-color-hsl-to-hex - (mapcar 'string-to-number - (list - (match-string-no-properties 1) - (match-string-no-properties 2) - (match-string-no-properties 3))))))) - (put-text-property (match-beginning 0) - (match-end 0) - 'keymap css-color-generic-map) - (put-text-property (match-beginning 0) - (match-end 0) - 'css-color-type 'hsl) - (put-text-property (match-beginning 0) - (match-end 0) - 'rear-nonsticky t) - (put-text-property (match-beginning 0) - (match-end 0) - 'face (list :background - color - :foreground - (css-color-foreground-color - color)))))) - (,css-color-rgb-re - (0 - (let ((color (css-color-string-rgb-to-hex (match-string-no-properties 0)))) - (put-text-property (match-beginning 0) - (match-end 0) - 'keymap css-color-generic-map) - (put-text-property (match-beginning 0) - (match-end 0) - 'css-color-type 'rgb) - (put-text-property (match-beginning 0) - (match-end 0) - 'rear-nonsticky t) - (put-text-property (match-beginning 0) - (match-end 0) - 'face (list :background - color - :foreground - (css-color-foreground-color - color)))))))) - - -;;;###autoload -(define-minor-mode css-color-mode - "Show hex color literals with the given color as background. -In this mode hexadecimal colour specifications like #6600ff are -displayed with the specified colour as background. - -Certain keys are bound to special colour editing commands when -point is at a hexadecimal colour: - -\\{css-color-map}" - :initial-value nil - :group 'css-color - (unless font-lock-defaults - (error "Can't use css-color-mode for this major mode")) - (if css-color-mode - (progn - (unless font-lock-mode (font-lock-mode 1)) - (css-color-font-lock-hook-fun) - (add-hook 'font-lock-mode-hook 'css-color-font-lock-hook-fun nil t)) - (remove-hook 'font-lock-mode-hook 'css-color-font-lock-hook-fun t) - (font-lock-remove-keywords nil css-color-keywords)) - ;;(font-lock-fontify-buffer) - (save-restriction - (widen) - (mumamo-mark-for-refontification (point-min) (point-max)))) - -(put 'css-color-mode 'permanent-local t) - -(defun css-color-turn-on-in-buffer () - "Turn on `css-color-mode' in `css-mode'." - (when (derived-mode-p 'css-mode) - (css-color-mode 1))) - -;;;###autoload -(define-globalized-minor-mode css-color-global-mode css-color-mode - css-color-turn-on-in-buffer - :group 'css-color) - -(defun css-color-font-lock-hook-fun () - "Add css-color pattern to font-lock's." - (if font-lock-mode - (font-lock-add-keywords nil css-color-keywords t) - (css-color-mode -1))) - -(defvar css-color-map - (let ((m (make-sparse-keymap "css-color"))) - (define-key m "=" 'css-color-up) - (define-key m "-" 'css-color-down) - (define-key m "h" 'css-color-hue-up) - (define-key m "H" 'css-color-hue-down) - (define-key m "s" 'css-color-saturation-up) - (define-key m "S" 'css-color-saturation-down) - (define-key m "v" 'css-color-value-up) - (define-key m "V" 'css-color-value-down) - (define-key m "\t" 'css-color-next-channel) - (define-key m " " 'css-color-cycle-type) - m) - "Mode map for `css-color-minor-mode'") - -(defvar css-color-generic-map - (let ((m (make-sparse-keymap "css-color"))) - (define-key m "=" 'css-color-num-up) - (define-key m "-" 'css-color-num-down) - (define-key m " " 'css-color-cycle-type) - (define-key m "%" 'css-color-toggle-percentage) - (define-key m "\t" 'css-color-next-channel) - m) - "Mode map for simple numbers in `css-color-minor-mode'") - -(defun css-color-pal-lumsig (r g b) - "Return PAL luminance signal, but in range 0-255." - (+ - (* 0.3 r) - (* 0.59 g) - (* 0.11 b))) - -(defun css-color-foreground-color (hex-color) - (multiple-value-bind (r g b) (css-color-hex-to-rgb hex-color) - (if (< (css-color-pal-lumsig r g b) 128) - "#fff" - "#000"))) - -;; Normalizing funs -(defun css-color-normalize-hue (h) - (mod (+ (mod h 360) 360) 360)) - -(defun css-color-within-bounds (num min max) - (min (max min num) max)) - -;; Source: hex -(defun css-color-hex-to-rgb (str) - (cond - ((not (string-match "^#?[a-fA-F[:digit:]]*$" str)) - (error "No valid hexadecimal: %s" str)) - ((= 0 (length str)) - nil) - ((= (aref str 0) 35) - (css-color-hex-to-rgb (substring str 1))) - (;;(oddp (length str)) - (= (mod (length str) 2) 1) - (css-color-hex-to-rgb (mapconcat (lambda (c) - (make-string 2 c)) - (string-to-list str) ""))) - (t (cons (string-to-number (substring str 0 2) 16) - (css-color-hex-to-rgb (substring str 2)))))) - -(defun css-color-hex-to-hsv (hex) - (multiple-value-bind (r g b) (css-color-hex-to-rgb hex) - (css-color-rgb-to-hsv r g b))) - -;; Source: rgb -(defun css-color-rgb-to-hex (r g b) - "Return r g b as #rrggbb in hexadecimal, propertized to have -the keymap `css-color-map'" - (format "%02x%02x%02x" r g b)) ;val - -(defun css-color-rgb-to-hsv (r g b) - "Return list of (hue saturation value). -Arguments are: R = red; G = green; B = blue. -Measure saturation and value on a scale from 0 - 100. -GIMP-style, that is." - (let* ((r (float r)) - (g (float g)) - (b (float b)) - (max (max r g b)) - (min (min r g b))) - (values - (round - (cond ((and (= r g) (= g b)) 0) - ((and (= r max) - (>= g b)) - (* 60 (/ (- g b) (- max min)))) - ((and (= r max) - (< g b)) - (+ 360 (* 60 (/ (- g b) (- max min))))) - ((= max g) - (+ 120 (* 60 (/ (- b r) (- max min))))) - ((= max b) - (+ 240 (* 60 (/ (- r g) (- max min))))))) ;hue - (round (* 100 (if (= max 0) 0 (- 1 (/ min max))))) ;sat - (round (/ max 2.55))))) - -(defun css-color-rgb-to-hsl (r g b) - "Return R G B (in range 0-255) converted to HSL (0-360 for hue, rest in %)" - (let* ((r (/ r 255.0)) - (g (/ g 255.0)) - (b (/ b 255.0)) - (h 0) - (s 0) - (l 0) - (v (max r g b)) - (m (min r g b)) - (l (/ (+ m v) 2.0)) - (vm 0) - (r2 0) - (g2 0) - (b2 0)) - (multiple-value-bind (h s v) - (if (<= l 0) - (values h s l) - (setq vm (- v m) - s vm) - (if (>= 0 s) - (values h s l) - (setq s (/ s (if (<= l 0.5) - (+ v m) - (- 2.0 v m)))) - (if (not (= 0 vm)) - (setq r2 (/ (- v r) vm) - g2 (/ (- v g) vm) - b2 (/ (- v b) vm))) - (cond ((= r v) - (setq h (if (= g m) - (+ 5.0 b2) - (- 1.0 g2)))) - ((= g v) - (setq h (if (= b m) - (+ 1.0 r2) - (- 3.0 b2)))) - (t - (setq h (if (= r m) - (+ 3.0 g2) - (- 5.0 r2))))) - (values (/ h 6.0) s l))) - (list (round(* 360 h)) - (* 100 s) - (* 100 l))))) - -;; Source: hsv -(defun css-color-hsv-to-hsl (h s v) - (multiple-value-bind (r g b) (css-color-hsv-to-rgb h s v) - (css-color-rgb-to-hsl r g b))) - -(defun css-color-hsv-to-hex (h s v) - (apply 'css-color-rgb-to-hex (css-color-hsv-to-rgb h s v))) - -(defun css-color-hsv-to-rgb (h s v) - "Convert a point in the Hue, Saturation, Value (aka Brightness) -color space to list of normalized Red, Green, Blue values. - -HUE is an angle in the range of 0 degrees inclusive to 360 -exclusive. The remainder of division by 360 is used for -out-of-range values. -SATURATION is in the range of 0 to 100. -VALUE is in the range of 0 to 100. -Returns a list of values in the range of 0 to 255. -" - ;; Coerce to float and get hue into range. - (setq h (mod h 360.0) - s (/ (float s) 100) - v (/ (float v) 100)) - (let* ((hi (floor h 60.0)) - (f (- (/ h 60.0) hi)) - (p (* v (- 1.0 s))) - (q (* v (- 1.0 (* f s)))) - ;; cannot use variable t, obviously. - (u (* v (- 1.0 (* (- 1.0 f) s)))) - r g b) - (case hi - (0 (setq r v g u b p)) - (1 (setq r q g v b p)) - (2 (setq r p g v b u)) - (3 (setq r p g q b v)) - (4 (setq r u g p b v)) - (5 (setq r v g p b q))) - (mapcar (lambda (color) (round (* 255 color))) (list r g b)))) - -(defun css-color-hsv-to-prop-hexstring (color-data) - (propertize - (apply 'css-color-hsv-to-hex color-data) - 'keymap css-color-map - 'css-color color-data)) - -;; Source: hsl -(defun css-color-hsl-to-rgb-fractions (h s l) - (let (m1 m2) - (if (<= l 0.5) - (setq m2 (* l (+ s 1))) - (setq m2 (- (+ l s) (* l s)))) - (setq m1 (- (* l 2) m2)) - (values (css-color-hue-to-rgb m1 m2 (+ h (/ 1 3.0))) - (css-color-hue-to-rgb m1 m2 h) - (css-color-hue-to-rgb m1 m2 (- h (/ 1 3.0)))))) - -(defun css-color-hsl-to-rgb (h s l) - (multiple-value-bind (r g b) - (css-color-hsl-to-rgb-fractions - (/ h;; (css-color-normalize-hue h) - 360.0) - (/ s 100.0) - (/ l 100.0)) - (values (css-color-within-bounds (* 256 r) 0 255) - (css-color-within-bounds (* 256 g) 0 255) - (css-color-within-bounds (* 256 b) 0 255)))) - -(defun css-color-hsl-to-hex (h s l) - (apply 'css-color-rgb-to-hex - (css-color-hsl-to-rgb h s l))) - -(defun css-color-hue-to-rgb (x y h) - (when (< h 0) (incf h)) - (when (> h 1) (decf h)) - (cond ((< h (/ 1 6.0)) - (+ x (* (- y x) h 6))) - ((< h 0.5) y) - ((< h (/ 2.0 3.0)) - (+ x (* (- y x) (- (/ 2.0 3.0) h) 6))) - (t x))) - -(defun css-color-parse-hsl (str) - (string-match - css-color-hsl-re - str) - (mapcar 'string-to-number - (list - (match-string 1 str) - (match-string 2 str) - (match-string 3 str)))) - -(defun css-color-inchue (color incr) - (multiple-value-bind (h s v) color - (css-color-hsv-to-prop-hexstring - (list (+ incr h) s v)))) - -(defun css-color-incsat (color incr) - (multiple-value-bind (h s v) color - (css-color-hsv-to-prop-hexstring - (list h (css-color-within-bounds (+ incr s) 0 100) v)))) - -(defun css-color-incval (color incr) - (multiple-value-bind (h s v) color - (css-color-hsv-to-prop-hexstring - (list h s (css-color-within-bounds (+ incr v) 0 100))))) - -(defun css-color-hexval-beginning () - (skip-chars-backward css-color-hex-chars) - (if (= (char-after) 35) - (forward-char 1))) - -(defun css-color-replcolor-at-p (fun increment) - (let ((pos (point))) - (css-color-hexval-beginning) - (insert - (funcall fun - (css-color-get-color-at-point) - increment)) - (delete-region (point) (+ (point) 6)) - (goto-char pos))) - -(defun css-color-get-color-at-point () - (save-excursion - (css-color-hexval-beginning) - (let ((saved-color (get-text-property (point) 'css-color))) - (or saved-color - (css-color-hex-to-hsv - (buffer-substring-no-properties (point) (+ (point) 6))))))) - -(defun css-color-adj-hue-at-p (increment) - (interactive "p") - (css-color-replcolor-at-p 'css-color-inchue increment)) - -(defun css-color-adj-saturation-at-p (increment) - (interactive "p") - (css-color-replcolor-at-p 'css-color-incsat increment)) - -(defun css-color-adj-value-at-p (increment) - (interactive "p") - (css-color-replcolor-at-p 'css-color-incval increment)) - -(defun css-color-what-channel () - (let ((pos (point))) - (prog1 - (/ (skip-chars-backward css-color-hex-chars) -2) - (goto-char pos)))) - -(defun css-color-adjust-hex-at-p (incr) - (interactive "p") - (let ((pos (point)) - (channel (css-color-what-channel))) - (css-color-hexval-beginning) - (let ((rgb - (css-color-hex-to-rgb - (buffer-substring-no-properties (point) - (+ 6 (point)))))) - (setf (nth channel rgb) - (css-color-within-bounds - (+ incr (nth channel rgb)) - 0 255)) - (delete-region (point) (+ 6 (point))) - (insert - (propertize - (apply 'format "%02x%02x%02x" rgb) - 'keymap css-color-map - 'css-color nil - 'rear-nonsticky t))) - (goto-char pos))) - -;; channels (r, g, b) -(defun css-color-up (val) - "Adjust R/G/B up." - (interactive "p") - (css-color-adjust-hex-at-p val)) - -(defun css-color-down (val) - "Adjust R/G/B down." - (interactive "p") - (css-color-adjust-hex-at-p (- val))) -;; hue -(defun css-color-hue-up (val) - "Adjust Hue up." - (interactive "p") - (css-color-adj-hue-at-p val)) - -(defun css-color-hue-down (val) - "Adjust Hue down." - (interactive "p") - (css-color-adj-hue-at-p (- val))) -;; saturation -(defun css-color-saturation-up (val) - "Adjust Saturation up." - (interactive "p") - (css-color-adj-saturation-at-p val)) - -(defun css-color-saturation-down (val) - "Adjust Saturation down." - (interactive "p") - (css-color-adj-saturation-at-p (- val))) -;; value -(defun css-color-value-up (val) - "Adjust Value up." - (interactive "p") - (css-color-adj-value-at-p val)) - -(defun css-color-value-down (val) - "Adjust Value down." - (interactive "p") - (css-color-adj-value-at-p (- val))) - -(defun css-color-num-up (arg) - "Adjust HEX number up." - (interactive "p") - (save-excursion - (let ((digits "1234567890")) - (skip-chars-backward digits) - (when - (looking-at "[[:digit:]]+") - (replace-match - (propertize - (let ((num (+ (string-to-number (match-string 0)) arg))) - ;max = 100 when at percentage - (save-match-data - (cond ((looking-at "[[:digit:]]+%") - (setq num (min num 100))) - ((looking-back "hsla?(") - (setq num (css-color-normalize-hue num))) - ((memq 'css-color-type (text-properties-at (point))) - (setq num (min num 255))))) - (number-to-string num)) - 'keymap - css-color-generic-map)))))) - -(defun css-color-num-down (arg) - "Adjust HEX number down." - (interactive "p") - (save-excursion - (let ((digits "1234567890")) - (skip-chars-backward digits) - (when - (looking-at "[[:digit:]]+") - (replace-match - (propertize - (let ((num (- (string-to-number (match-string 0)) arg))) - ;max = 100 when at percentage - (save-match-data - (cond ((looking-back "hsla?(") - (setq num (css-color-normalize-hue num))) - (t (setq num (max 0 num))))) - (number-to-string num)) - 'keymap css-color-generic-map)))))) - - -(defun css-color-beginning-of-color () - "Skip to beginning of color. - -Return list of point and color-type." - (while (memq 'css-color-type (text-properties-at (point))) - (backward-char 1)) - (forward-char 1) - (cons (point) (plist-get (text-properties-at (point)) 'css-color-type))) - -(defun css-color-end-of-color () - "Skip to beginning of color. - -Return list of point and color-type." - (while (plist-get (text-properties-at (point)) 'css-color-type) - (forward-char 1)) - (cons (point) (plist-get (text-properties-at (1- (point))) 'css-color-type))) - -(defun css-color-color-info () - (destructuring-bind ((beg . type) - (end . type)) - (list - (css-color-beginning-of-color) - (css-color-end-of-color)) - (list beg end type (buffer-substring-no-properties beg end)))) - -(defconst css-color-type-circle '#1=(hex hsl rgb name . #1#)) - -(defun css-color-next-type (sym) - (cadr (member sym css-color-type-circle))) - -(defun css-color-cycle-type () - "Cycle color type." - (interactive) - (destructuring-bind (beg end type color) (css-color-color-info) - (if (or (= 0 (length color)) (null type)) - (error "Not at color")) - (delete-region beg end) - (insert - (propertize (funcall - (intern-soft (format "css-color-string-%s-to-%s" - type - (css-color-next-type type))) - color) - 'keymap (if (eq (css-color-next-type type) 'hex) - css-color-map - css-color-generic-map) 'rear-nonsticky t)) - (goto-char beg))) - -(defun css-color-string-hex-to-hsl (str) - (multiple-value-bind (h s l) - (apply 'css-color-rgb-to-hsl - (css-color-hex-to-rgb str)) - (format "hsl(%d,%d%%,%d%%)" - h s l))) - -(defun css-color-string-hsl-to-rgb (str) - (multiple-value-bind (h s l) - (css-color-parse-hsl str) - (apply 'format - "rgb(%d,%d,%d)" - (mapcar 'round (css-color-hsl-to-rgb h s l))))) - -(defun css-color-string-rgb-to-name (str) - (let ((color (css-color-string-rgb-to-hex str))) - (or (car (rassoc (list (upcase color)) css-color-html-colors)) ;if name ok - color))) ;else return hex - -(defun css-color-string-name-to-hex (str) - (let ((str (downcase str))) - (cadr (assoc-if - (lambda (a) - (string= - (downcase a) - str)) - css-color-html-colors)))) - -(defun css-color-string-rgb-to-hex (str) - (save-match-data - (string-match css-color-rgb-re str) - (concat "#" - (apply 'css-color-rgb-to-hex - (mapcar - ;;'string-to-number - (lambda (s) - (if (= (aref s (1- (length s))) ?\%) - (round (* (string-to-number s) 2.55)) - (string-to-number s))) - (list - (match-string-no-properties 1 str) - (match-string-no-properties 2 str) - (match-string-no-properties 3 str))))))) - -(defun css-color-string-hsl-to-hex (str) - (concat "#" (apply 'css-color-hsl-to-hex (css-color-parse-hsl str)))) - -(defun css-color-next-channel () - "Cycle color channel." - (interactive) - (multiple-value-bind (beg end type color) - (save-excursion (css-color-color-info)) - (case type - ((hsl rgb) - (if (not (re-search-forward ",\\|(" end t)) - (goto-char (+ beg 4)))) - (hex - (cond ((> (point) (- end 3)) - (goto-char (+ 1 beg))) - ((= (char-after) 35) - (forward-char 1)) - ((evenp (- (point) beg)) - (forward-char 1)) - (t (forward-char 2))))))) - -(defun css-color-hexify-anystring (str) - (cond ((string-match "^hsl" str) - (css-color-string-hsl-to-hex str)) - ((string-match "^rgb" str) - (css-color-string-rgb-to-hex str)) - (t str))) - -(defun css-color-toggle-percentage () - "Toggle percent ??" - (interactive) - (let ((pos (point))) - (if (eq (nth 2 (save-excursion (css-color-color-info))) 'rgb) - (let ((chars "%1234567890.")) - (skip-chars-backward chars) - (when - (looking-at "[[:digit:]]+\\(?:\.?[[:digit:]]*%\\)?%?") - (let ((s (match-string 0))) - (replace-match - (propertize - (if (= (aref s (1- (length s))) ?\%) - (number-to-string (round (* (string-to-number s) 2.55))) - (format "%d%%" (/ (string-to-number s) 2.55))) - 'keymap css-color-generic-map - 'rear-nonsticky t))) - ;;(goto-char pos) - )) - (message "No toggling at point.")))) - -;; provide some backwards-compatibility to hexcolor.el: -(defvar css-color-fg-history nil) -(defvar css-color-bg-history nil) - -;;;###autoload -(defun css-color-test (fg-color bg-color) - "Test colors interactively. -The colors are displayed in the echo area. You can specify the -colors as any viable css color. Example: - - red - #f00 - #0C0 - #b0ff00 - hsla(100, 50%, 25%) - rgb(255,100,120)" - (interactive (list (completing-read "Foreground color: " - css-color-html-colors - nil nil nil nil css-color-fg-history) - (completing-read "Background color: " - css-color-html-colors - nil nil nil nil css-color-bg-history))) - (let* ((s (concat " Foreground: " fg-color ", Background: " bg-color " "))) - (put-text-property 0 (length s) - 'face (list - :foreground (css-color-hexify-anystring fg-color) - :background (css-color-hexify-anystring bg-color)) - s) - (message "Here are the colors: %s" s))) - -(defun css-color-run-tests () - (interactive) - (unless - (progn - (assert - (string= (css-color-string-hex-to-hsl "#ffff00") "hsl(60,100%,50%)")) - (assert - (string= (css-color-string-rgb-to-hex "rgb(255, 50%, 0)")"#ff7f00")) - (assert - (string= (css-color-string-hsl-to-rgb "hsl(60, 100%, 50%)") "rgb(255,255,0)")) - (assert - (string= (css-color-string-hsl-to-hex "hsl(60, 100%, 50%)") "#ffff00"))) - (message "All tests passed"))) - -(provide 'css-color) -;;; css-color.el ends here diff --git a/emacs.d/nxhtml/util/css-palette.el b/emacs.d/nxhtml/util/css-palette.el deleted file mode 100644 index 44287be..0000000 --- a/emacs.d/nxhtml/util/css-palette.el +++ /dev/null @@ -1,471 +0,0 @@ -;;; css-palette.el - -(defconst css-palette:version "0.02") -;; Copyright (C) 2008 Niels Giesen - -;; Author: Niels Giesen <nielsforkgiesen@gmailspooncom, but please -;; replace the kitchen utensils with a dot before hitting "Send"> -;; Keywords: processes, css, multimedia, extensions, tools -;; Homepage: http://niels.kicks-ass.org/ - -;; 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: - -;; css-palette defines commands to have "palettes" inside a block -;; comment to circumvent the absence of (color or other) variable -;; definitions in the CSS specification. It can import and export GIMP -;; color palettes. See the documentation of `css-palette-mode' -;; for details of usage. - -;;; Installation: - -;; Something like: - -;; put it in your load-path. - -;; (autoload 'css-palette-mode "css-palette" "" t) -;; (add-hook 'css-mode-hook -;; (lambda () -;; (css-palette-mode t))) - -;; Notes: - -;; css-palette depends on css-color.el to do font-locking. - -;; ccs-palette is orthogonal to css-mode, so it could probably be used -;; inside other language modes, provided they support multiline block -;; comments. - -;;; Change log: - -;; 2009-01-11 Lennart Borgman -;; - Minor code clean up. - -;;; Code: -(require 'css-color) -(eval-when-compile (require 'cl)) ;i'm a bad bad boy... - -(defconst css-palette-hex-chars "0123456789abcdefABCDEF" - "Composing chars in hexadecimal notation, save for the hash (#) sign.") - -(defvar css-palette-mode-map - (let ((m (make-sparse-keymap))) - (define-key m "\C-c\C-c" 'css-palette-update-all) - (define-key m "\C-c\C-i" 'css-palette-insert-reference) - (define-key m "\C-c\C-p" 'css-palette-import-from-GIMP) - (define-key m "\C-c\C-f" 'css-palette-insert-files) - m) - "Mode map for `css-palette-mode'") - -;;;###autoload -(define-minor-mode css-palette-mode - "Minor mode for palettes in CSS. - -The mode `css-palette-mode' acts on the first COLORS declaration in your - file of the form: - -COLORS: -\( -c0 \"#6f5d25\" ;tainted sand -c1 \"#000000\" ;Black -c2 \"#cca42b\" ;goldenslumber -c3 \"#6889cb\" ;far off sky -c4 \"#fff\" ;strange aeons -) - -Such declarations should appear inside a block comment, in order - to be parsed properly by the LISP reader. - -Type \\[css-palette-update-all], and any occurence of - - color: #f55; /*[c3]*/ - -will be updated with - - color: #6899cb; /*[c3]*/ - -The following commands are available to insert key-value pairs - and palette declarations: - \\{css-palette-mode-map} - -You can extend or redefine the types of palettes by defining a - new palette specification of the form (PATTERN REGEXP - REF-FOLLOWS-VALUE), named according to the naming scheme - css-palette:my-type, where - -PATTERN is a pattern containing two (%s) format directives which - will be filled in with the variable and its value, - -REGEXP is a regular expression to match a value - variable - pattern, - -and REF-FOLLOWS-VALUE defined whether or not the reference comes - after the value. This allows for more flexibility. - -Note that, although the w3c spec at URL - `http://www.w3.org/TR/CSS2/syndata.html#comments' says that - comments \" may occur anywhere between tokens, and their - contents have no influence on the rendering\", Internet - Explorer does not think so. Better keep all your comments after - a \"statement\", as per the default. This means `css-palette' - is ill-suited for use within shorthands. - -See variable `css-palette:colors' for an example of a palette - type. - -The extension mechanism means that palette types can be used to - contain arbitrary key-value mappings. - -Besides the colors palette, css-palette defines the palette - definition variables `css-palette:colors-outside' and - `css-palette:files', for colors with the reference outside and - for file url()'s respectively. - -You can fine-control which palette types css-palette should look - at via the variable `css-palette-types'. - -" - nil - "-palette" - css-palette-mode-map - (css-color-mode +1)) - -;;;###autoload -(defgroup css-palette nil - "Customization group for css-palette library. - -See function `css-palette-mode' for documentation" - :group 'css-color) - -(defcustom css-palette:colors - `("%s; /*[%s]*/ " - ,(concat "\\(" - css-color-color-re -;; (mapconcat -;; 'identity -;; (list css-color-hex-re -;; css-color-hsl-re -;; css-color-rgb-re) "\\|") - "\\)" - "[[:space:]]*;[[:space:]]*\/\\*\\[\\([^[:space:]]+\\)\\]\\*\/") - t) - "Color palette specification. - -See function `css-palette-mode' for documentation" - :group 'css-palette - :type '(list - (string :tag "Pattern") - (regexp :tag "Regexp") - (boolean :tag "Reversed"))) - -(defcustom css-palette:files - '("url(%s); /*[%s]*/ " - "url(\\([^)]+\\))[[:space:]]*;[[:space:]]*\/\\*\\[\\([^[:space:]]+\\)\\]\\*\/" - t) - "File palette specification. - -See function `css-palette-mode' for documentation" - :group 'css-palette - :type '(list - (string :tag "Pattern") - (regexp :tag "Regexp") - (boolean :tag "Reversed"))) - -(defcustom css-palette-types - '(colors) - "List of palette types to check for in buffer. - -See function `css-palette-mode' for documentation" - :group 'css-palette - :type '(repeat (symbol :tag "Palette type"))) -(make-variable-buffer-local 'css-palette-types) - -;; (defun css-palette-mode-turn-on () -;; "Turn on `css-palette-mode'." -;; (css-palette-mode 1)) - -;; ;;;###autoload -;; (defcustom css-palette-mode-activate-p nil -;; "Start `css-palette-mode' when `css-mode' is activated." -;; :group 'css-palette -;; :set (lambda (sym val) -;; (set-default sym val) -;; (if val -;; (add-hook 'css-mode-hook 'css-palette-mode-turn-on) -;; (remove-hook 'css-mode-hook 'css-palette-mode-turn-on))) -;; :type 'boolean) - -(defun css-palette-turn-on-in-buffer () - "Turn on `css-palette-mode' in `css-mode'." - (when (derived-mode-p 'css-mode) - (message "turn-on-in-b:before (css-palette-mode 1) cb=%s" (current-buffer)) - (css-palette-mode 1) - (message "turn-on-in-b:after (css-palette-mode 1)") - )) - -;;;###autoload -(define-globalized-minor-mode css-palette-global-mode css-palette-mode - css-palette-turn-on-in-buffer - :group 'css-color) - -(defun css-palette-get (key spec) - (plist-get - (css-palette-spec-to-plist - (symbol-value - (intern-soft - (format "css-palette:%s" spec)))) key)) - -(defun css-palette-spec-to-plist (palette) - (destructuring-bind (pattern regexp ref-follows-value) palette - (list :regexp regexp - :pattern pattern - :ref-follows-value ref-follows-value))) - -(defun css-palette-choose-type () - (intern-soft - (if (null (cdr css-palette-types)) - (car css-palette-types) - (completing-read "Type: " - (mapcar 'symbol-name css-palette-types))))) - -(defun css-palette-get-declaration (type) - "Return `css-palette' declaration of TYPE in current buffer. - -If none is found, throw an error." - (let ((type (symbol-name type))) - (save-excursion - (goto-char (point-min)) - (or (re-search-forward (format "%s:" - (upcase type)) nil t) - (error "No %s declaration found in buffer; check value of variable - `css-palette-types'" type)) - (let ((palette (read (current-buffer)))) - ;; Check (could be better..) - (if (not (and - (listp palette) - (= 0 (% (length palette) 2)))) - (error "Invalid %s " type)) - palette)))) - -(defun css-palette-update (type) -"Update buffer references for palette of TYPE." - (interactive (list - (css-palette-choose-type))) - (let ((palette (css-palette-get-declaration type)) - (regexp (css-palette-get :regexp type)) - (ref-follows-value (css-palette-get :ref-follows-value type))) - (flet ((getval (key palette) - (let ((value (plist-get palette (intern-soft key)))) - (if (null value) - (error - "%S not specified in %S palette " - key - type - ;; (signal 'css-palette-not-found-error nil) - ) - value)))) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward - regexp - (point-max) t) - (replace-match - (getval (match-string-no-properties (if ref-follows-value 2 1)) palette) - nil nil nil (if ref-follows-value 1 2)))))) - (css-color-mode 1)) - -(defun css-palette-update-all () - "Update all references for palettes in `css-palette-types'" - (interactive) - (catch 'err - (mapc (lambda (type) - (condition-case err - (css-palette-update type) - (if (y-or-n-p (format "%s, skip? " err)) - nil))) - css-palette-types))) - -;; Reference Insertion -(defun css-palette-insert-reference (type) - "Insert `css-palette' reference of TYPE at point." - (interactive - (list (css-palette-choose-type))) - (let* ((palette (css-palette-get-declaration type)) - (ref-follows-value (css-palette-get :ref-follows-value type)) - (pattern (css-palette-get :pattern type)) - (var - (completing-read (format "%s variable: " - (capitalize - (substring (symbol-name type) - 0 -1))) - (loop for i on - palette - by 'cddr - collect - (css-palette-colorify - (symbol-name (car i)) - (cadr i))))) - (val (plist-get palette (read var)))) - (insert (apply 'format - pattern - (if ref-follows-value - (list val var) - (list var val)))) - (css-color-mode +1))) - -(defun css-palette-hex-color-p (str) - (string-match "#\\([a-fA-F[:digit:]]\\{6\\}\\|[a-fA-F[:digit:]]\\{3\\}\\)" str)) - -(defun css-palette-colorify (string color) - (let ((color (if (css-palette-hex-color-p color) - color - "#000"))) - (propertize string - 'font-lock-face - (list :background color - :foreground (css-color-foreground-color color) - string) - 'fontified t))) - -;; Imports -(defun css-palette-from-existing-colors () - (interactive) - (let ((palette) - (count -1)) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "#[[:digit:]a-fA-F]\\{6\\}\\>" nil t) - (if (not (member (match-string-no-properties 0) palette)) - (setq palette (append (list - (match-string-no-properties 0) - (intern(format "c%d" (incf count)))) - palette))) - (save-match-data (re-search-forward ";" nil t)) - (insert (format "/*[%S]*/" (cadr (member (match-string-no-properties 0) palette)))))) - (insert (format "COLORS:\n%S" (nreverse palette))) - (forward-sexp -1) - (forward-char 1) - (while - (not (looking-at ")")) - (forward-sexp 2) - (newline) - (indent-for-tab-command)))) - -(defun css-palette-newest-GIMP-dir () - "Return newest (version-wise) ~/.gimp-n.n/palettes directory on disk. - -Return `nil' if none such directory is found." - (catch 'none - (concat - (or - (car - (last - (directory-files "~/" t "^.gimp-[[:digit:].]\\{3,\\}"))) - (throw 'none ())) - "/palettes/"))) - -(defun css-palette-import-from-GIMP () - "Import GIMP palette file as a `css-palette' palette. - -GIMP palettes can be made with the GIMP or on-line tools such as -found at URL `http://colourlovers.com'." - (interactive) - (let ((file (read-file-name "File: " (css-palette-newest-GIMP-dir))) - (this-buffer (current-buffer)) - (count -1)) - (insert "\nCOLORS:\n(\n") - (with-temp-buffer - (insert-file-contents file) - (goto-char (point-min)) - (while (re-search-forward - (concat - "^" - "[[:space:]]*\\([[:digit:]]+\\)" ;red - "[[:space:]]+\\([[:digit:]]+\\)" ;green - "[[:space:]]+\\([[:digit:]]+\\)" ;blue - "[[:space:]]+\\(.*\\)$") ;name (=> used as comment) - nil t) - (destructuring-bind (rb re gb ge bb be nb ne &rest ignore) - (cddr (match-data t)) - (let ((color - (apply 'format "c%d \"#%02x%02x%02x\" ;%s\n" - (incf count) - (append - (mapcar 'string-to-number - (list - (buffer-substring-no-properties rb re) - (buffer-substring-no-properties gb ge) - (buffer-substring-no-properties bb be))) - (list (buffer-substring-no-properties nb ne)))))) - (with-current-buffer this-buffer - (insert color)))))) - (insert ")") - (message "C-c C-c to update colors"))) - -(defun css-palette-insert-files (dir) - "Insert a `css-palette' declaration for all files in DIR. - -Filenames are relative. -Main use-case: an image directory." - (interactive "DDirectory: ") - (save-excursion - (let ((image-count -1)) - (insert "\nFILES:\n(\n") - (mapc - (lambda (f) - (insert - (format "file-%d %S\n" - (incf image-count) - (file-relative-name - f - (file-name-directory (buffer-file-name)))))) - (directory-files dir t "...+")) - (insert ")\n\n")))) - -;; Exports -(defun css-palette-export-to-GIMP (type name columns) - "Export the COLORS declaration to a GIMP (.gpl) palette. - -See also `gpl-mode' at URL -`http://niels.kicks-ass.org/public/elisp/gpl.el'." - (interactive - (list - (css-palette-choose-type) - (read-string "Name: ") - (read-number "Number of columns: " 2))) - (let ((palette (css-palette-get-declaration type))) - (find-file - (concat (css-palette-newest-GIMP-dir) - name - ".gpl")) - (insert - (format "GIMP Palette -Name: %s -Columns: %d -# -" name columns)) - (loop for i on palette - by 'cddr - do - (multiple-value-bind (r g b)(css-color-hex-to-rgb - (css-color-hexify-anystring (cadr i))) - (insert (format "%3d %3d %3d\t%s\n" - r g b - (car i)))))) - (if (featurep 'gpl) - (gpl-mode))) - -(provide 'css-palette) -;; css-palette.el ends here diff --git a/emacs.d/nxhtml/util/css-simple-completion.el b/emacs.d/nxhtml/util/css-simple-completion.el deleted file mode 100644 index 95bf27b..0000000 --- a/emacs.d/nxhtml/util/css-simple-completion.el +++ /dev/null @@ -1,238 +0,0 @@ -;;; css-simple-completion.el --- Partly context aware css completion -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2009-11-22 Sun -;; Version: -;; Last-Updated: 2009-11-22 Sun -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Simple partly context aware completion. Context is based on -;; guessing mainly. -;; -;; This can be combined with with flymake-css.el that can check the -;; syntax. -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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, 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: - -;; Fix-me: bad structure, does not fit completion frameworks -(defun css-simple-completing-w-pred (regexp matnum prompt collection) - (let (pre start len) - (when (looking-back regexp (line-beginning-position) t) - (setq pre (downcase (match-string matnum))) - (setq len (length pre)) - (setq start (match-beginning matnum)) - (unless (try-completion pre collection) - (throw 'result nil)) - (throw 'result (list start - (completing-read prompt - collection - (lambda (alt) - (and (>= (length alt) len) - (string= pre - (substring alt 0 len)))) - t - pre)))))) - -(defun css-simple-complete () - "Try to complete at current point. -This tries to complete keywords, but no CSS values. - -This is of course a pity since the value syntax is a bit -complicated. However you can at least check the syntax with -flymake-css if you want to." - (interactive) - (let ((context (css-simple-guess-context)) - result - cur - pre - start) - (setq result - (catch 'result - - (case context - - ( 'css-media-ids - (css-simple-completing-w-pred "\\<[a-z0-9-]*" 0 "Media type: " css-media-ids)) - - ( 'css-at-ids - (css-simple-completing-w-pred "@\\([a-z0-9-]*\\)" 1 "At rule: @" css-at-ids)) - - ( 'css-property-ids - (css-simple-completing-w-pred "\\<[a-z-]*" 0 "CSS property name: " css-property-ids)) - - ( 'css-simple-selectors - - ;; Fix-me: Break out the first two - (when (looking-back "\\W#\\([a-z0-9-]*\\)") - (setq cur (match-string 1)) - (setq start (match-beginning 1)) - (throw 'result (list (point) - (read-string (concat "Html tag Id: " cur))))) - (when (looking-back "\\W\\.\\([a-z0-9-]*\\)") - (setq cur (match-string 1)) - (setq start (match-beginning 1)) - (throw 'result (list (point) - (read-string (concat "CSS class name: " cur))))) - - (css-simple-completing-w-pred "[a-z0-9]:\\([a-z0-9-]*\\)" 1 "Pseudo id: " css-pseudo-ids) - - (css-simple-completing-w-pred "[a-z0-9-]+" 0 "HTML tag: " (cddr css-simple-selectors)) - - (when (looking-back "\\<\\(?:#\\|\\.\\)") - (setq pre nil) - (while t - (setq pre (completing-read "HTML tag, id or CSS class: " css-simple-selectors nil nil pre)) - (if (string= (substring pre 0 1) "#") - (if (or (= 1 (length pre)) - (and (> (length pre) 2) - (string= (substring pre 0 3) "# ("))) - (throw 'result (list (point) (concat "#" (read-string "Html tag id: #")))) - (throw 'result (list (point) pre))) - (if (string= (substring pre 0 1) ".") - (if (or (= 1 (length pre)) - (and (> (length pre) 2) - (string= (substring pre 0 3) ". ("))) - (throw 'result (list (point) (concat "." (read-string "CSS class name: .")))) - (throw 'result (list (point) pre))) - (when (member pre css-simple-selectors) - (throw 'result (list (point) pre))))) - )))))) - (message "result=%S" result) - (if result - (let ((str (cadr result)) - (len (- (point) (car result)))) - (insert (substring str len))) - (message "No matching alternatives")))) - -(defun css-simple-guess-context () - "Try to find a context matching none constant. -Return the symbol corresponding to the context or nil if none -could be found. - -The symbols are the names of the defconst holding the possibly -matching ids. - -* Note: This function assumes that comments are fontified before - point." - ;; Kind of hand-written backward parser ... ;-) - (let ((ignore-case t) ;; fix-me - (here (point)) - (after-colon (and (not (bobp)) (eq (char-before) ?:))) - ret) - (prog1 - (catch 'return - ;; No completion in comments. - (when (eq (get-text-property (point) 'face) - 'font-lock-comment-face) - (throw 'return nil)) - - ;; If we are not on whitespace then don't complete - (css-simple-skip-backwards-to-code) - (unless (or (eobp) - (= (char-syntax (char-after)) ?\ ) - (< (point) here)) - (throw 'return nil)) - - ;; Skip backwards to see if after first selector - (let ((here2 (1+ (point)))) - (while (/= here2 (point)) - (setq here2 (point)) - (css-simple-skip-backwards-to-code) - (when (and (not (bobp)) - (eq (char-before) ?,)) - (backward-char)) - (skip-chars-backward "#.:a-z0-9-"))) - ;; Selector - (when (or (bobp) - (eq (char-before) ?})) - (throw 'return 'css-simple-selectors)) - - ;; Property names - (when (memq (char-before) '( ?{ ?\; )) - (throw 'return 'css-property-ids)) - - ;; If we are in the value we can't complete there yet. - (when (eq (char-before) ?:) - (throw 'return nil)) - - - ;; @ - (goto-char here) - (skip-chars-backward "a-z0-9-") - (when (eq (char-before) ?@) - (throw 'return 'css-at-ids)) - - ;; @media ids - (when (looking-back "@media\\W+") - (throw 'return 'css-media-ids)) - - ) - (goto-char here)))) -;;; Fix-me: complete these ... -;;css-descriptor-ids ;; Removed or? - -(defun css-simple-skip-backwards-to-code () - "Skip backwards until we reach code. -Requires that comments are fontified." - (let ((here (1+ (point)))) - (while (/= here (point)) - (setq here (point)) - (skip-syntax-backward " ") - (unless (bobp) - (when (memq (get-text-property (1- (point)) 'face) - '(font-lock-comment-face font-lock-comment-delimiter-face)) - (goto-char (or (previous-single-property-change (1- (point)) 'face) - (point-min)))))))) - -(defconst css-simple-selectors - '(". (for class)" - "# (for id)" - ;; HTML 4.01 tags - "a" "abbr" "acronym" "address" "applet" "area" "b" "base" "basefont" "bdo" "big" - "blockquote" "body" "br" "button" "caption" "center" "cite" "code" "col" - "colgroup" "dd" "del" "dfn" "dir" "div" "dl" "dt" "em" "fieldset" "font" "form" - "frame" "frameset" "head" "h1" "h2" "h3" "h4" "h5" "h6" "hr" "html" "i" "iframe" "img" - "input" "ins" "kbd" "label" "legend" "li" "link" "map" "menu" "meta" "noframes" - "noscript" "object" "ol" "optgroup" "option" "p" "param" "pre" "q" "s" "samp" - "script" "select" "small" "span" "strike" "strong" "style" "sub" "sup" "table" - "tbody" "td" "textarea" "tfoot" "th" "thead" "title" "tr" "tt" "u" "ul" "var" - )) - -(provide 'css-simple-completion) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; css-simple-completion.el ends here diff --git a/emacs.d/nxhtml/util/cus-new-user.el b/emacs.d/nxhtml/util/cus-new-user.el deleted file mode 100644 index c727425..0000000 --- a/emacs.d/nxhtml/util/cus-new-user.el +++ /dev/null @@ -1,803 +0,0 @@ -;;; cus-new-user.el --- Customize some important options -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2009-07-10 Fri -;; Version: 0.2 -;; Last-Updated: 2009-07-10 Fri -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Customize significant options for which different user -;; environment expectations might dictate different defaults. -;; -;; After an idea of Scot Becker on Emacs Devel. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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, 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: - -(defvar cusnu-my-skin-widget nil) - -(defvar cusnu-insert-os-spec-fun nil) - -;;(customize-for-new-user) -;;;###autoload -(defun customize-for-new-user (&optional name) - "Show special customization page for new user. -" - (interactive) - ;;(setq debug-on-error t) - ;;(setq buffer-read-only t) - (require 'cus-edit) - (let ((inhibit-read-only t) - fill-pos) - (pop-to-buffer (custom-get-fresh-buffer (or name "*Customizations for New Users*"))) - (buffer-disable-undo) - (Custom-mode) - (erase-buffer) - (widget-insert (propertize "Easy Customization for New Users\n" 'face '(:weight bold :height 1.5))) - (setq fill-pos (point)) - (widget-insert - "Below are some custom options that new users often may want to -tweak since they may make Emacs a bit more like what they expect from -using other software in their environment. - -After this, at the bottom of this page, is a tool for exporting your own specific options. -You choose which to export, make a description and give the group of options a new and click a button. -Then you just mail it or put it on the web for others to use. - -Since Emacs runs in many environment and an Emacs user may use -several of them it is hard to decide by default what a user -wants/expects. Therefor you are given the possibility to easily -do those changes here. - -Note that this is just a collection of normal custom options. -There are no new options here. - - -") - (fill-region fill-pos (point)) - - ;; Normal custom buffer header - (let ((init-file (or custom-file user-init-file))) - ;; Insert verbose help at the top of the custom buffer. - (when custom-buffer-verbose-help - (widget-insert "Editing a setting changes only the text in this buffer." - (if init-file - " -To apply your changes, use the Save or Set buttons. -Saving a change normally works by editing your init file." - " -Currently, these settings cannot be saved for future Emacs sessions, -possibly because you started Emacs with `-q'.") - "\nFor details, see ") - (widget-create 'custom-manual - :tag "Saving Customizations" - "(emacs)Saving Customizations") - (widget-insert " in the ") - (widget-create 'custom-manual - :tag "Emacs manual" - :help-echo "Read the Emacs manual." - "(emacs)Top") - (widget-insert ".")) - (widget-insert "\n") - ;; The custom command buttons are also in the toolbar, so for a - ;; time they were not inserted in the buffer if the toolbar was in use. - ;; But it can be a little confusing for the buffer layout to - ;; change according to whether or nor the toolbar is on, not to - ;; mention that a custom buffer can in theory be created in a - ;; frame with a toolbar, then later viewed in one without. - ;; So now the buttons are always inserted in the buffer. (Bug#1326) -;;; (when (not (and (bound-and-true-p tool-bar-mode) (display-graphic-p))) - (if custom-buffer-verbose-help - (widget-insert "\n - Operate on all settings in this buffer that are not marked HIDDEN:\n")) - (let ((button (lambda (tag action active help icon) - (widget-insert " ") - (if (eval active) - (widget-create 'push-button :tag tag - :help-echo help :action action)))) - (commands custom-commands)) - (apply button (pop commands)) ; Set for current session - (apply button (pop commands)) ; Save for future sessions - (if custom-reset-button-menu - (progn - (widget-insert " ") - (widget-create 'push-button - :tag "Reset buffer" - :help-echo "Show a menu with reset operations." - :mouse-down-action 'ignore - :action 'custom-reset)) - (widget-insert "\n") - (apply button (pop commands)) ; Undo edits - (apply button (pop commands)) ; Reset to saved - (apply button (pop commands)) ; Erase customization - (widget-insert " ") - (pop commands) ; Help (omitted) - (apply button (pop commands)))) ; Exit - (widget-insert "\n\n") - - (widget-insert (propertize "\nThis part is for your own use\n" 'face '(:weight bold :height 1.5))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Editor emulator level - - (widget-insert "\n") - (setq fill-pos (point)) - (widget-insert -"Emacs can emulate some common editing behaviours (and some uncommon too). -For the most common ones you can decide if you want to use them here: -") - (fill-region fill-pos (point)) - (cusnu-mark-part-desc fill-pos (point)) - - ;; CUA Mode - (cusnu-insert-options '((cua-mode custom-variable))) - - ;; Viper Mode - (widget-insert "\n") - (widget-insert (propertize "Viper" 'face 'custom-variable-tag)) - (widget-insert ":") - (setq fill-pos (point)) - (widget-insert " - Viper is currently set up in a special way, please see the - command `viper-mode'. You can use custom to set up most of - it. However if you want to load Viper at startup you must - explicitly include \(require 'viper) in your .emacs. -") - (fill-region fill-pos (point)) - - ;; Viper Mode - (backward-delete-char 1) - (cusnu-insert-options '((viper-mode custom-variable))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; OS specific - - (widget-insert "\n") - (setq fill-pos (point)) - (widget-insert (format "OS specific options (%s): \n" system-type)) - (fill-region fill-pos (point)) - (cusnu-mark-part-desc fill-pos (point)) - - (if cusnu-insert-os-spec-fun - (funcall cusnu-insert-os-spec-fun) - (widget-insert "No OS specific customizations.\n")) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Disputed settings - - (widget-insert "\n") - (setq fill-pos (point)) - (widget-insert -"Some old time Emacs users want to change the options below: -") - (fill-region fill-pos (point)) - (cusnu-mark-part-desc fill-pos (point)) - - (cusnu-insert-options '((global-visual-line-mode custom-variable))) - (cusnu-insert-options '((word-wrap custom-variable))) - (cusnu-insert-options '((blink-cursor-mode custom-variable))) - (cusnu-insert-options '((tool-bar-mode custom-variable))) - (cusnu-insert-options '((tooltip-mode custom-variable))) - ;;(cusnu-insert-options '((initial-scratch-message custom-variable))) - - (widget-insert "\n") - (widget-insert (propertize "\n\nThis part is for exporting to others\n\n" 'face '(:weight bold :height 1.5))) - (setq fill-pos (point)) - (widget-insert -"My skin options - This is for exporting custom options to other users -\(or maybe yourself on another computer). -This works the following way: - -- You add a description of your options and the options you want to export below. -Then you click on `Export my skin options'. -This creates a file that you can send to other Emacs users. -They simply open that file in Emacs and follow the instructions there to test your options -and maybe save them for later use if they like them. -\(You can follow the instructions yourself to see how it works.) - -Please change the group symbol name to something specific for you. -") - (fill-region fill-pos (point)) - (cusnu-mark-part-desc fill-pos (point)) - - (widget-insert "\n") - (set (make-local-variable 'cusnu-my-skin-widget) - (car - (cusnu-insert-options '((cusnu-my-skin-options custom-variable))))) - (widget-insert "\n") - (widget-create 'push-button - :tag "Export my skin options " - :action (lambda (&rest ignore) - (let ((use-dialog-box nil)) - (call-interactively 'cusnu-export-my-skin-options)))) - (widget-insert "\n") - (widget-create 'push-button - :tag "Customize my skin options " - :action (lambda (&rest ignore) - (let ((use-dialog-box nil)) - (call-interactively 'cusnu-customize-my-skin-options)))) - (widget-insert "\n") - (widget-create 'push-button - :tag "Reset those options to saved values" - :action (lambda (&rest ignore) - (let ((use-dialog-box nil)) - (call-interactively 'cusnu-reset-my-skin-options)))) - - ;; Finish setup buffer - (mapc 'custom-magic-reset custom-options) - (cusnu-make-xrefs) - (widget-setup) - (buffer-enable-undo) - (goto-char (point-min))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Example on Emacs+Emacw32 -(eval-when-compile (require 'emacsw32 nil t)) -(when (fboundp 'emacsw32-version) - (defun cusnu-emacsw32-show-custstart (&rest args) - (emacsw32-show-custstart)) - (setq cusnu-insert-os-spec-fun 'cusnu-insert-emacsw32-specific-part) - (defun cusnu-insert-emacsw32-specific-part () - (cusnu-insert-options '((w32-meta-style custom-variable))) - (widget-insert "\n") - (widget-insert (propertize "EmacsW32" 'face 'custom-variable-tag)) - (widget-insert " - Easy setup for Emacs+EmacsW32.") - (widget-insert "\n ") - (widget-create 'push-button :tag "Customize EmacsW32" - ;;:help-echo help - :action 'cusnu-emacsw32-show-custstart) - (widget-insert "\n"))) -;; End example -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun cusnu-mark-part-desc (beg end) - (let ((ovl (make-overlay beg end))) - (overlay-put ovl 'face 'highlight))) - -(defun cusnu-make-xrefs (&optional beg end) - (save-restriction - (when (or beg end) - (unless beg (setq beg (point-min))) - (unless end (setq end (point-max))) - (narrow-to-region beg end)) - (let ((here (point))) - (goto-char (point-min)) - (cusnu-help-insert-xrefs 'cusnu-help-xref-button) - (goto-char here)))) - -(defun widget-info-link-action (widget &optional event) - "Open the info node specified by WIDGET." - (info-other-window (widget-value widget))) - -(defun widget-documentation-string-value-create (widget) - ;; Insert documentation string. - (let ((doc (widget-value widget)) - (indent (widget-get widget :indent)) - (shown (widget-get (widget-get widget :parent) :documentation-shown)) - (start (point))) - (if (string-match "\n" doc) - (let ((before (substring doc 0 (match-beginning 0))) - (after (substring doc (match-beginning 0))) - button) - (when (and indent (not (zerop indent))) - (insert-char ?\s indent)) - (insert before ?\s) - (widget-documentation-link-add widget start (point)) - (setq button - (widget-create-child-and-convert - widget (widget-get widget :visibility-widget) - :help-echo "Show or hide rest of the documentation." - :on "Hide Rest" - :off "More" - :always-active t - :action 'widget-parent-action - shown)) - (when shown - (setq start (point)) - (when (and indent (not (zerop indent))) - (insert-char ?\s indent)) - (insert after) - (widget-documentation-link-add widget start (point)) - (cusnu-make-xrefs start (point)) - ) - (widget-put widget :buttons (list button))) - (when (and indent (not (zerop indent))) - (insert-char ?\s indent)) - (insert doc) - (widget-documentation-link-add widget start (point)))) - (insert ?\n)) -(defun cusnu-help-xref-button (match-number type what &rest args) - (let ((beg (match-beginning match-number)) - (end (match-end match-number))) - (if nil - (let ((ovl (make-overlay beg end))) - (overlay-put ovl 'face 'highlight)) - (let* ((tag (match-string match-number)) - (value what) - (wid-type (cond - ((eq type 'help-variable) - 'variable-link) - ((eq type 'help-function) - 'function-link) - ((eq type 'help-info) - 'custom-manual) - (t nil))) - ) - (when wid-type - (delete-region beg end) - (backward-char) - ;;(tag action active help icon) - (widget-create wid-type - ;;tag - :value value - :tag tag - :keymap custom-mode-link-map - :follow-link 'mouse-face - :button-face 'custom-link - :mouse-face 'highlight - :pressed-face 'highlight - ;;:help-echo help - ))))) - ) - -;; Override default ... ;-) -(define-widget 'documentation-link 'link - "Link type used in documentation strings." - ;;:tab-order -1 - :help-echo "Describe this symbol" - :button-face 'custom-link - :action 'widget-documentation-link-action) - -(defun cusnu-xref-niy (&rest ignore) - (message "Not implemented yet")) - -(defun cusnu-describe-function (wid &rest ignore) - (let ((fun (widget-get wid :what)) - ) - (describe-function fun))) - -(defun cusnu-help-insert-xrefs (help-xref-button) - ;; The following should probably be abstracted out. - (unwind-protect - (progn - ;; Info references - (save-excursion - (while (re-search-forward help-xref-info-regexp nil t) - (let ((data (match-string 2))) - (save-match-data - (unless (string-match "^([^)]+)" data) - (setq data (concat "(emacs)" data)))) - (funcall help-xref-button 2 'help-info data)))) - ;; URLs - (save-excursion - (while (re-search-forward help-xref-url-regexp nil t) - (let ((data (match-string 1))) - (funcall help-xref-button 1 'help-url data)))) - ;; Mule related keywords. Do this before trying - ;; `help-xref-symbol-regexp' because some of Mule - ;; keywords have variable or function definitions. - (if help-xref-mule-regexp - (save-excursion - (while (re-search-forward help-xref-mule-regexp nil t) - (let* ((data (match-string 7)) - (sym (intern-soft data))) - (cond - ((match-string 3) ; coding system - (and sym (coding-system-p sym) - (funcall help-xref-button 6 'help-coding-system sym))) - ((match-string 4) ; input method - (and (assoc data input-method-alist) - (funcall help-xref-button 7 'help-input-method data))) - ((or (match-string 5) (match-string 6)) ; charset - (and sym (charsetp sym) - (funcall help-xref-button 7 'help-character-set sym))) - ((assoc data input-method-alist) - (funcall help-xref-button 7 'help-character-set data)) - ((and sym (coding-system-p sym)) - (funcall help-xref-button 7 'help-coding-system sym)) - ((and sym (charsetp sym)) - (funcall help-xref-button 7 'help-character-set sym))))))) - ;; Quoted symbols - (save-excursion - (while (re-search-forward help-xref-symbol-regexp nil t) - (let* ((data (match-string 8)) - (sym (intern-soft data))) - (if sym - (cond - ((match-string 3) ; `variable' &c - (and (or (boundp sym) ; `variable' doesn't ensure - ; it's actually bound - (get sym 'variable-documentation)) - (funcall help-xref-button 8 'help-variable sym))) - ((match-string 4) ; `function' &c - (and (fboundp sym) ; similarly - (funcall help-xref-button 8 'help-function sym))) - ((match-string 5) ; `face' - (and (facep sym) - (funcall help-xref-button 8 'help-face sym))) - ((match-string 6)) ; nothing for `symbol' - ((match-string 7) -;;; this used: -;;; #'(lambda (arg) -;;; (let ((location -;;; (find-function-noselect arg))) -;;; (pop-to-buffer (car location)) -;;; (goto-char (cdr location)))) - (funcall help-xref-button 8 'help-function-def sym)) - ((and - (facep sym) - (save-match-data (looking-at "[ \t\n]+face\\W"))) - (funcall help-xref-button 8 'help-face sym)) - ((and (or (boundp sym) - (get sym 'variable-documentation)) - (fboundp sym)) - ;; We can't intuit whether to use the - ;; variable or function doc -- supply both. - (funcall help-xref-button 8 'help-symbol sym)) - ((and - (or (boundp sym) - (get sym 'variable-documentation)) - (or - (documentation-property - sym 'variable-documentation) - (condition-case nil - (documentation-property - (indirect-variable sym) - 'variable-documentation) - (cyclic-variable-indirection nil)))) - (funcall help-xref-button 8 'help-variable sym)) - ((fboundp sym) - (funcall help-xref-button 8 'help-function sym))))))) - ;; An obvious case of a key substitution: - (save-excursion - (while (re-search-forward - ;; Assume command name is only word and symbol - ;; characters to get things like `use M-x foo->bar'. - ;; Command required to end with word constituent - ;; to avoid `.' at end of a sentence. - "\\<M-x\\s-+\\(\\sw\\(\\sw\\|\\s_\\)*\\sw\\)" nil t) - (let ((sym (intern-soft (match-string 1)))) - (if (fboundp sym) - (funcall help-xref-button 1 'help-function sym))))) - ;; Look for commands in whole keymap substitutions: - (save-excursion - ;; Make sure to find the first keymap. - (goto-char (point-min)) - ;; Find a header and the column at which the command - ;; name will be found. - - ;; If the keymap substitution isn't the last thing in - ;; the doc string, and if there is anything on the - ;; same line after it, this code won't recognize the end of it. - (while (re-search-forward "^key +binding\n\\(-+ +\\)-+\n\n" - nil t) - (let ((col (- (match-end 1) (match-beginning 1)))) - (while - (and (not (eobp)) - ;; Stop at a pair of blank lines. - (not (looking-at "\n\\s-*\n"))) - ;; Skip a single blank line. - (and (eolp) (forward-line)) - (end-of-line) - (skip-chars-backward "^ \t\n") - (if (and (>= (current-column) col) - (looking-at "\\(\\sw\\|\\s_\\)+$")) - (let ((sym (intern-soft (match-string 0)))) - (if (fboundp sym) - (funcall help-xref-button 0 'help-function sym)))) - (forward-line)))))) - ;;(set-syntax-table stab) - )) - -(defun cusnu-insert-options (options) - (widget-insert "\n") - (setq custom-options - (append - (if (= (length options) 1) - (mapcar (lambda (entry) - (widget-create (nth 1 entry) - ;;:documentation-shown t - :custom-state 'unknown - :tag (custom-unlispify-tag-name - (nth 0 entry)) - :value (nth 0 entry))) - options) - (let ((count 0) - (length (length options))) - (mapcar (lambda (entry) - (prog2 - (message "Creating customization items ...%2d%%" - (/ (* 100.0 count) length)) - (widget-create (nth 1 entry) - :tag (custom-unlispify-tag-name - (nth 0 entry)) - :value (nth 0 entry)) - (setq count (1+ count)) - (unless (eq (preceding-char) ?\n) - (widget-insert "\n")) - (widget-insert "\n"))) - options))) - custom-options)) - (unless (eq (preceding-char) ?\n) - (widget-insert "\n")) - custom-options - ) - -(defun cusnu-is-custom-obj (sym) - "Return non-nil if symbol SYM is customizable." - (or (get sym 'custom-type) - (get sym 'face) - (get sym 'custom-group) - )) - -(define-widget 'custom-symbol 'symbol - "A customizable symbol." - :prompt-match 'cusnu-is-custom-obj - :prompt-history 'widget-variable-prompt-value-history - :complete-function (lambda () - (interactive) - (lisp-complete-symbol 'cusnu-is-custom-obj)) - :tag "Custom option") - -(defun cusnu-set-my-skin-options (sym val) - (set-default sym val) - (let ((group (nth 0 val)) - (doc (nth 1 val)) - (members (nth 2 val))) - (custom-declare-group group nil doc) - (put group 'custom-group nil) - (dolist (opt members) - (let ((type (cusnu-get-opt-main-type opt))) - (when type - (custom-add-to-group group opt type)))))) - -(defun cusnu-get-opt-main-type (opt) - (when opt - (cond ((get opt 'face) 'custom-face) - ((get opt 'custom-type) 'custom-variable) - ((get opt 'custom-group) 'custom-group)))) - -(defgroup all-my-loaded-skin-groups nil - "All your loaded skin groups." - :group 'environment - :group 'convenience) - -(defun cusnu-custom-group-p (symbol) - (and (intern-soft symbol) - (or (and (get symbol 'custom-loads) - (not (get symbol 'custom-autoload))) - (get symbol 'custom-group)))) - -(defcustom cusnu-my-skin-options '(my-skin-group "My skin group.\n\n\n\n\n" nil) - "Your custom skin-like options. -The purpose of this variable is to provide for easy export a -selection of variables you choose to set to other users. - -To send these values to other users you export them to a file -with `cusnu-export-my-skin-options'." - :type '(list (symbol :tag "My custom group symbol name (should be specific to you)") - (string :tag "My custom group description") - (repeat :tag "Add your custom options below" - (custom-symbol :tag "My custom option"))) - :set 'cusnu-set-my-skin-options - :group 'all-my-loaded-skin-groups) - -;;(cusnu-ring-bell "bell") -(defun cusnu-ring-bell (format-string &rest args) - (message "%s" (propertize (apply - 'format format-string args) 'face 'secondary-selection)) - (ding) - (throw 'bell nil)) - -;;;###autoload -(defun cusnu-export-my-skin-options (file) - "Export to file FILE custom options in `cusnu-my-skin-options'. -The options is exported to elisp code that other users can run to -set the options that you have added to `cusnu-my-skin-options'. - -For more information about this see `cusnu-export-cust-group'." - (interactive '(nil)) - (catch 'bell - (let ((grp (nth 0 cusnu-my-skin-options)) - buf) - (let ((state (plist-get (cdr cusnu-my-skin-widget) :custom-state))) - (case state - ((set saved) nil) ;;(error "test, state=%s" state)) - (standard (cusnu-ring-bell "Please enter your options first")) - (t (cusnu-ring-bell "My Skin Options must be saved or set, use the State button, %s" state)))) - (unless (nth 2 cusnu-my-skin-options) - (cusnu-ring-bell "You have not added any of your options")) - (unless file - (setq file (read-file-name "Save to file: "))) - (when (file-exists-p file) - (cusnu-ring-bell "File %s already exists, choose another file name" file)) - (setq buf (find-file-other-window file)) - (with-current-buffer buf - (unless (eq major-mode 'emacs-lisp-mode) (emacs-lisp-mode)) - (unless (file-exists-p (buffer-file-name)) - (erase-buffer))) - (cusnu-export-cust-group grp buf)))) - -(defun cusnu-customize-my-skin-options () - (interactive) - (customize-group-other-window (nth 0 cusnu-my-skin-options))) - -(defun cusnu-reset-my-skin-options () - "Reset to my defaults for those options. -" - (interactive) - (cusnu-reset-group-options-to-my-defaults (nth 0 cusnu-my-skin-options))) - -(defun cusnu-reset-group-options-to-my-defaults (group) - (dolist (sym-typ (get group 'custom-group)) - (let ((symbol (nth 0 sym-typ)) - ;;(type (cusnu-get-opt-main-type symbol)) - (type (nth 1 sym-typ)) - defval) - (cond - ((eq type 'custom-variable) - ;; First try reset to saved. - (let* ((set (or (get symbol 'custom-set) 'set-default)) - (value (get symbol 'saved-value)) - (comment (get symbol 'saved-variable-comment))) - (cond ((or comment value) - (put symbol 'variable-comment comment) - (custom-push-theme 'theme-value symbol 'user 'set (car-safe value)) - (condition-case err - (funcall set symbol (eval (car value))) - (error (message "%s" err)))) - ;; If symbol was not saved then reset to standard. - (t - (unless (get symbol 'standard-value) - (error "No standard setting known for %S" symbol)) - (put symbol 'variable-comment nil) - (put symbol 'customized-value nil) - (put symbol 'customized-variable-comment nil) - (custom-push-theme 'theme-value symbol 'user 'reset) - (custom-theme-recalc-variable symbol) - (put symbol 'saved-value nil) - (put symbol 'saved-variable-comment nil) - )))) - ((eq type 'custom-face) - ;; First try reset to saved - (let* ((value (get symbol 'saved-face)) - (comment (get symbol 'saved-face-comment))) - (cond ((or value comment) - (put symbol 'customized-face nil) - (put symbol 'customized-face-comment nil) - (custom-push-theme 'theme-face symbol 'user 'set value) - (face-spec-set symbol value t) - (put symbol 'face-comment comment)) - ;; If symbol was not saved then reset to standard. - (t - (setq value (get symbol 'face-defface-spec)) - (unless value - (error "No standard setting for this face")) - (put symbol 'customized-face nil) - (put symbol 'customized-face-comment nil) - (custom-push-theme 'theme-face symbol 'user 'reset) - (face-spec-set symbol value t) - (custom-theme-recalc-face symbol) - ;; Do this later. - (put symbol 'saved-face nil) - (put symbol 'saved-face-comment nil) - )))) - (t (error "not iy")))))) - -(defun cusnu-export-cust-group (group buf) - "Export custom group GROUP to end of buffer BUF. -Only the options that has been customized will be exported. - -The group is exported as elisp code. Running the code will -create a group with just those members. After this it opens a -customization buffer with the new group. - -The code will also set the options to the customized values, but -it will not save them in the users init file. - -See also the comment in the exported file." - (let (start - (doc (get group 'group-documentation)) - groups options faces - (members (mapcar (lambda (rec) - (car rec)) - (get group 'custom-group)))) - (with-current-buffer buf - (insert (format-time-string ";; Here is my skin custom group %Y-%m-%d.\n")) - (font-lock-mode 1) - (insert (format ";;;;;; Customization group name: %s\n" group)) - (insert ";;\n") - (let ((here (point))) - (insert doc "\n") - (comment-region here (point)) - (fill-region here (point))) - (cusnu-get-options-and-faces members 'groups 'options 'faces) - (unless (or options faces) - (cusnu-ring-bell "There are no options or faces in %s customized by you" group)) - (insert " -;; This file defines the group and sets the options in it, but does -;; not save the values to your init file. -;; -;; To set the values evaluate this file. To do that open this file in Emacs and to -;; -;; M-x eval-buffer -;; -;; To go back to your default evaluate next line (place point at the end and to C-x C-e): -") - (insert (format ";; (cusnu-reset-group-options-to-my-defaults '%s)\n\n" group)) - (insert (format "(let ((grp '%s))\n" group)) - (insert (format " (custom-declare-group grp nil %S)\n" doc)) - (insert " (put grp 'custom-group nil)\n") - (insert (format " (custom-add-to-group 'all-my-loaded-skin-groups '%s 'custom-group)\n" group)) - (dolist (opt members) - (let ((type (cusnu-get-opt-main-type opt))) - (when type - (insert (format " (custom-add-to-group grp '%s '%s)\n" - opt type))))) - (insert " (custom-set-variables\n") - (dolist (opt options) - (let ((my-val (or (get opt 'saved-value) - (get opt 'customized-value)))) - (when my-val - (insert (format " '(%s %S)\n" opt (custom-quote (symbol-value opt))))))) - (insert " )\n") - (insert " (custom-set-faces\n") - (dolist (opt faces) - (let ((my-val (get opt 'customized-face))) - (when my-val - (insert (format " '(%s %S)\n" opt my-val))))) - (insert " ))\n") - (insert (format "\n(customize-group '%s)\n" group)) - ))) - -(defun cusnu-get-options-and-faces (members groups-par options-par faces-par) - (dolist (sym members) - (insert (format ";; sym=%s\n" sym)) - (cond ((and (get sym 'custom-type) - (or (get sym 'saved-value) - (get sym 'customize-value))) - (add-to-list options-par sym)) - ((and (get sym 'face) - (get sym 'customized-face)) - (add-to-list faces-par sym)) - ((get sym 'custom-group) - (unless (memq sym groups-par) ;; Don't loop - (cusnu-get-options-and-faces groups-par options-par faces-par))) - (t (insert ";; Not a custom variable or face: %s\n" sym))))) - -(provide 'cus-new-user) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; cus-new-user.el ends here diff --git a/emacs.d/nxhtml/util/custsets.el b/emacs.d/nxhtml/util/custsets.el deleted file mode 100644 index 0495dd8..0000000 --- a/emacs.d/nxhtml/util/custsets.el +++ /dev/null @@ -1,83 +0,0 @@ -;;; custsets.el --- Sets of named customizations -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-03-25T00:17:06+0100 Mon -;; Version: -;; Last-Updated: -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; After an idea expressed by among other Stephen Turnbull on the -;; emacs devel list. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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: - -(defcustom custsets-sets - '( - ("Windows" - (cua-mode t) - ) - ) - "Sets of customizations." - :group 'custsets) - -(defun custsets-turn-on (set-name) - (interactive "sCustomization set: ") - (let ((set (assoc-string set-name custsets-sets t))) - (unless set - (error "Can't find customization set %s" set-name)) - (dolist (opt-rec (cdr set)) - (let* ((opt (car opt-rec)) - (val (cdr opt-rec)) - (saved-opt (get opt 'saved-value)) - (saved-val saved-opt) ;; fix-me - (ask (if saved-opt - (format "You have currently customized %s to %s. Change this to %s? " - opt saved-opt val) - (format "Customize %s to %s? " opt val))) - ) - (when (y-or-n-p ask) - (customize-set-variable opt val) - (customize-set-value opt val) - (customize-mark-to-save opt)) - ) - ) - (custom-save-all))) - - -(provide 'custsets) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; custsets.el ends here diff --git a/emacs.d/nxhtml/util/ecb-batch-compile.el b/emacs.d/nxhtml/util/ecb-batch-compile.el deleted file mode 100644 index bdd86c6..0000000 --- a/emacs.d/nxhtml/util/ecb-batch-compile.el +++ /dev/null @@ -1,65 +0,0 @@ -;;; ecb-batch-compile.el --- Compile ecb in batch mode -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-08-25T04:46:35+0200 Mon -;; Version: -;; Last-Updated: -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Batch byte compile ecb: -;; -;; emacs -Q -l ecb-batch-compile -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'cl)) -(eval-and-compile (require 'udev-ecb nil t)) - -(let* ((this-file load-file-name) - (this-dir (file-name-directory this-file)) - ) - (add-to-list 'load-path this-dir)) - -;;(require 'udev-cedet) -;;(udev-cedet-load-cedet t) - -(eval-when (eval) - (udev-ecb-load-ecb) - (ecb-byte-compile)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ecb-batch-compile.el ends here diff --git a/emacs.d/nxhtml/util/ediff-url.el b/emacs.d/nxhtml/util/ediff-url.el deleted file mode 100644 index 12329bd..0000000 --- a/emacs.d/nxhtml/util/ediff-url.el +++ /dev/null @@ -1,188 +0,0 @@ -;;; ediff-url.el --- Diffing buffer against downloaded url -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: Sat Nov 24 2007 -;; Version: 0.56 -;; Last-Updated: 2010-03-18 Thu -;; URL: http://bazaar.launchpad.net/~nxhtml/nxhtml/main/annotate/head%3A/util/ediff-url.el -;; -;; Features that might be required by this library: -;; - ;; `mail-prsvr', `mm-util', `timer', `url-parse', `url-util', - ;; `url-vars'. -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; This file contains a simple function, `ediff-url', to help you -;; update a single file from the web. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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: - -(require 'url-util) -(eval-when-compile (require 'cl)) - -(defvar ediff-url-read-url-history nil) - -(defun ediff-url-redir-launchpad (url) - "Check if bazaar list page on Launchpad. -If URL is a description page for a file uploaded to EmacsWiki -suggest to use the download URL instead." - (let* ((bazaar-url "http://bazaar.launchpad.net/") - (bazaar-len (length bazaar-url))) - (if (and (< bazaar-len (length url)) - (string= bazaar-url (substring url 0 bazaar-len))) - (let* ((url-show-status nil) ;; just annoying showing status here - (buffer (url-retrieve-synchronously url)) - (handle nil) - (http-status nil) - ;; Fix-me: better more flexible pattern? - (dl-patt "<a href=\"\\(.*?\\)\">download file</a>") - dl-url) - (unless buffer - (message "Got empty buffer for %s" url) - (throw 'command-level nil)) - (with-current-buffer buffer - (if (= 0 (buffer-size)) - (progn - (message "Got empty page for %s" url) - (throw 'command-level nil)) - (require 'url-http) - (setq http-status (url-http-parse-response)) - (if (memq http-status '(200 201)) - (progn - (goto-char (point-min)) - (unless (search-forward "\n\n" nil t) - (error "Could not find header end in buffer for %s" url)) - (unless (re-search-forward dl-patt nil t) - (error "Could not find download link")) - (setq dl-url (match-string 1)) - (set-buffer-modified-p nil) - (kill-buffer buffer) - dl-url) - (kill-buffer buffer) - (setq buffer nil) - (setq http-status - (concat (number-to-string http-status) - (case http-status - (401 " (unauthorized)") - (403 " (forbidden)") - (404 " (not found)") - (408 " (request timeout)") - (410 " (gone)") - (500 " (internal server error)") - (503 " (service unavailable)") - (504 " (gateway timeout)") - (530 " (user access denied)") - ))) - (message "Got status %s for %s" http-status url) - (throw 'command-level nil))))) - url))) - -(defun ediff-url-redir-emacswiki-description-page (url) - "Check if description page on EmacsWiki. -If URL is a description page for a file uploaded to EmacsWiki -suggest to use the download URL instead." - ;;(let* ((desc-url "http://www.emacswiki.org/emacs/") - (let* ((emacswiki-url "http://www.emacswiki.org/") - (emacswiki-len (length emacswiki-url))) - (if (and (< emacswiki-len (length url)) - (string= emacswiki-url (substring url 0 emacswiki-len)) - (not (string-match-p "/download/" url))) - (let ((prompt - (concat "This seem to be the description page on EmacsWiki," - "\n\tdo you want the download url instead? "))) - (when (y-or-n-p prompt) - ;;(let ((start (+ 6 (string-match "/wiki/" url)))) - (let ((start (+ 7 (string-match "/emacs/" url)))) - (concat (substring url 0 start) - "download/" - (substring url start))))) - ;; Not on the wiki, just return the url: - url))) - -(defcustom ediff-url-redirects '(ediff-url-redir-emacswiki-description-page - ediff-url-redir-launchpad - ) - "List of functions checking url given to `ediff-url'. -Each function should take an URL as argument and return this URL -or a new URL." - :type '(repeat function) - :group 'ediff) - -;;;###autoload -(defun ediff-url (url) - "Compare current buffer to a web URL using `ediff-buffers'. -Check URL using `ediff-url-redirects' before fetching the file. - -This is for checking downloaded file. A the file may have a comment -telling the download URL of thise form in the header: - - ;; URL: http://the-server.net/the-path/the-file.el - -If not the user is asked for the URL." - (interactive (let ((url-init (url-get-url-at-point))) - (unless url-init - (when (eq major-mode 'emacs-lisp-mode) - (save-excursion - (goto-char (point-min)) - (when (re-search-forward "URL:[ \t]*" nil t) - (setq url-init (url-get-url-at-point)))))) - (list (read-from-minibuffer "Url for download file: " - (cons (or url-init "") 1) ;nil - nil nil - 'ediff-url-read-url-history - ;;url-init - )))) - (catch 'command-level ;; Fix-me: remove and let go to top later - (unless (> (length url) 0) - (message "No URL given, aborted by user") - (throw 'command-level nil)) - ;; Check if URL seems reasonable - (dolist (fun ediff-url-redirects) - (setq url (funcall fun url))) - ;; Fetch URL and run ediff - (let* ((url-buf-name (concat "URL=" url)) - (url-buf (get-buffer url-buf-name))) - (when url-buf - (unless (y-or-n-p "Use previously downloaded url? ") - (kill-buffer url-buf) - (setq url-buf nil))) - (unless url-buf - (setq url-buf (get-buffer-create url-buf-name)) - (let ((current-major major-mode)) - (with-current-buffer url-buf - (url-insert-file-contents url) - ;; Assume same modes: - (funcall current-major)))) - (ediff-buffers url-buf (current-buffer))))) - -(provide 'ediff-url) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ediff-url.el ends here diff --git a/emacs.d/nxhtml/util/ffip.el b/emacs.d/nxhtml/util/ffip.el deleted file mode 100644 index 42d1893..0000000 --- a/emacs.d/nxhtml/util/ffip.el +++ /dev/null @@ -1,304 +0,0 @@ -;;; ffip.el --- Find files in project -;; -;; Authors: extracted from rinari by Phil Hagelberg and Doug Alcorn -;; Changed by Lennart Borgman -;; Created: 2008-08-14T23:46:22+0200 Thu -;; Version: 0.3 -;; Last-Updated: 2008-12-28 Sun -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'cl)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Project data - -;; Fix-me: Change the inner structure of ffip projects -(defvar ffip-project-name nil "Project name.") -(defvar ffip-project-roots nil "Project directory roots.") -(defvar ffip-project-type nil "Project type, `ffip-project-file-types'.") -(defcustom ffip-project-file-types - (list - '(ruby "\\(\\.el$\\|\\.rb$\\|\\.js$\\|\\.emacs\\)") - (list 'nxhtml (concat - (regexp-opt '(".html" ".htm" ".xhtml" - ".css" - ".js" - ".png" ".gif" - )) - "\\'")) - ) - "Project types and file types. -The values in this list are used to determine if a file belongs -to the current ffip project. Entries have the form - - \(TYPE FILE-REGEXP) - -TYPE is the parameter set by `ffip-set-current-project'. Files -matching FILE-REGEXP within the project roots are members of the -project." - :type '(repeat (list - (symbol :tag "Type") - (regexp :tag "File regexp"))) - :group 'ffip) - -(defvar ffip-project-file-matcher nil "Project file matcher.") -(defvar ffip-project-files-table nil "Project file cache.") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Project handling - -(defun ffip-reset-project () - "Clear project data." - (remove-hook 'after-save-hook 'ffip-after-save) - (setq ffip-project-name nil) - (setq ffip-project-roots nil) - (setq ffip-project-files-table nil) - (setq ffip-project-type nil) - (setq ffip-project-file-matcher nil)) -;;(ffip-reset-project) - -(defun ffip-is-current (name root type) - "Return non-nil if NAME, ROOT and TYPE match current ffip project. -See `ffip-set-current-project'." - (and name - (string= ffip-project-name name) - (eq ffip-project-type type) - (equal ffip-project-roots root))) - -;;;###autoload -(defun ffip-set-current-project (name root type) - "Setup ffip project NAME with top directory ROOT of type TYPE. -ROOT can either be just a directory or a list of directory where -the first used just for prompting purposes and the files in the -rest are read into the ffip project. - -Type is a type in `ffip-project-file-types'." - (unless (ffip-is-current name root type) - (ffip-reset-project) - (setq ffip-project-name name) - (setq ffip-project-type type) - (setq ffip-project-roots root) - (message "Project %s with %s files setup for find-files-in-project" - name (length ffip-project-files-table)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; File cache handling - -(defun ffip-cache-project-files (file-regexp) - "Read files and cache their names within the ffip project." - (let ((root ffip-project-roots)) - (message "... reading files in %s ..." root) - (add-hook 'after-save-hook 'ffip-after-save) - (if (not (listp root)) - (ffip-populate-files-table root file-regexp) - (setq root (cdr root)) - (dolist (r root) - (ffip-populate-files-table r file-regexp))))) - -(defun ffip-file-matcher () - (when ffip-project-type - (cadr (assoc ffip-project-type ffip-project-file-types)))) - -(defun ffip-project-files () - "Get a list of all files in ffip project. -The members in the list has the format - - \(SHORT-NAME . FULL-NAME) - -where SHORT-NAME is a unique name (normally file name without -directory) and FULL-NAME is the full file name." - (unless ffip-project-files-table - (let ((file-regexp (ffip-file-matcher))) - (ffip-cache-project-files file-regexp))) - ffip-project-files-table) - -;; Fix-me: Seems better to rewrite this to use -;; project-find-settings-file. -(defun ffip-project-root (&optional dir) - (setq dir (or dir - ffip-project-roots - default-directory)) - ;;(locate-dominating-file "." "\\`\\find-file-in-project.el\\'") - (let ((root (locate-dominating-file dir - ;;"\\`\\.emacs-project\\'" - "\\`\\.dir-settings\\.el\\'" - ))) - (if root - (file-name-directory root) - dir))) - -(defun ffip-populate-files-table (file file-regexp) - ;;(message "ffip-populate-files-table.file=%s" file) - (if (file-directory-p file) - (mapc (lambda (file) - (ffip-populate-files-table file file-regexp)) - (directory-files (expand-file-name file) t "^[^\.]")) - (let* ((file-name (file-name-nondirectory file)) - (existing-record (assoc file-name ffip-project-files-table)) - (unique-parts (ffip-get-unique-directory-names file - (cdr existing-record)))) - (when (or (not file-regexp) - (string-match file-regexp file-name)) - (if existing-record - (let ((new-key (concat file-name " - " (car unique-parts))) - (old-key (concat (car existing-record) " - " - (cadr unique-parts)))) - (setf (car existing-record) old-key) - (setq ffip-project-files-table - (acons new-key file ffip-project-files-table))) - (setq ffip-project-files-table - (acons file-name file ffip-project-files-table))))))) - -(defun ffip-get-unique-directory-names (path1 path2) - (let* ((parts1 (and path1 (split-string path1 "/" t))) - (parts2 (and path2 (split-string path2 "/" t))) - (part1 (pop parts1)) - (part2 (pop parts2)) - (looping t)) - (while (and part1 part2 looping) - (if (equal part1 part2) - (setq part1 (pop parts1) part2 (pop parts2)) - (setq looping nil))) - (list part1 part2))) - -(defun ffip-file-is-in-project (file-name) - "Return non-nil if file is in current ffip project." - (save-match-data - (let ((file-regexp (ffip-file-matcher)) - (roots ffip-project-roots) - regexp) - (if (not (listp roots)) - (setq roots (list roots)) - (setq roots (cdr roots))) - (catch 'found - (dolist (root roots) - (setq file-regexp (concat root ".*" file-regexp)) - (when (string-match file-regexp file-name) - (throw 'found t))))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Updating on file changes - -(defun ffip-add-file-if-in-project (file-name) - "Add file to cache if it in ffip project." - (when (ffip-file-is-in-project file-name) - ;; We have already checked so just use nil for the matcher. - (ffip-populate-files-table file-name nil))) - -;; For after-save-hook -(defun ffip-after-save () - "Check if a file should be added to cache." - (condition-case err - (ffip-add-file-if-in-project buffer-file-name) - (error (message "%s" (error-message-string err))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Interactive functions - -;;;###autoload -(defun ffip-find-file-in-dirtree (root) - "Find files in directory tree ROOT." - (interactive "DFind file in directory tree: ") - ;; Setup a temporary - (let ((ffip-project-name nil) - (ffip-project-roots nil) - (ffip-project-files-table nil) - (ffip-project-type nil) - (ffip-project-file-matcher nil)) - (ffip-set-current-project "(temporary)" root nil) - (call-interactively 'ffip-find-file-in-project))) - -(defun ffip-find-file-in-project (file) - "Find files in current ffip project." - (interactive - (list - (let* ((prompt (format "Find file in project %s: " - ffip-project-name))) - (if (memq ido-mode '(file 'both)) - (ido-completing-read prompt - (mapcar 'car (ffip-project-files))) - (let ((files (mapcar 'car (ffip-project-files)))) - (completing-read prompt - files - (lambda (elem) (member elem files)) - t)))))) - (find-file (cdr (assoc file ffip-project-files-table)))) - -;;(global-set-key (kbd "C-x C-M-f") 'find-file-in-project) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Fix-me: This part should go somewhere else -(eval-after-load 'ruby-mode - '(progn - (defun ffip-rails-project-files (&optional file) - (let ((default-directory (or file (rails-root)))) - (unless (and ffip-project-roots - (string= default-directory ffip-project-roots)) - (ffip-set-current-project - "Rails proj" - root - (list default-directory - (expand-file-name "app") - (expand-file-name "lib") - (expand-file-name "test")) - 'ruby - ))) - (ffip-project-files)) - - (defun ffip-find-file-in-rails (file) - (interactive - (list (if (memq ido-mode '(file 'both)) - (ido-completing-read - "Find file in project: " - (mapcar 'car (ffip-rails-project-files))) - (completing-read "Find file in project: " - (mapcar 'car (rails-project-files)))))) - (find-file (cdr (assoc file ffip-project-files-table)))) - - (define-key ruby-mode-map (kbd "C-x C-M-f") 'find-file-in-rails) - (eval-after-load 'nxhtml-mode - '(define-key nxhtml-mode-map (kbd "C-x C-M-f") 'find-file-in-rails)))) - -(provide 'ffip) -;;; ffip.el ends here diff --git a/emacs.d/nxhtml/util/fold-dwim.el b/emacs.d/nxhtml/util/fold-dwim.el deleted file mode 100644 index 11b3a3d..0000000 --- a/emacs.d/nxhtml/util/fold-dwim.el +++ /dev/null @@ -1,466 +0,0 @@ -;;; fold-dwim.el -- Unified user interface for Emacs folding modes -;; -;; Copyright (C) 2004 P J Heslin -;; -;; Author: Peter Heslin <p.j.heslin@dur.ac.uk> -;; URL: http://www.dur.ac.uk/p.j.heslin/Software/Emacs/Download/fold-dwim.el -(defconst fold-dwim:version "1.4") -;; -;; 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. -;; -;; If you do not have a copy of the GNU General Public License, you -;; can obtain one by writing to the Free Software Foundation, Inc., 59 -;; Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -;;; Overview: -;; -;; DWIM stands for "do what I mean", as in the idea that one keystroke -;; can do different things depending on the context. In this package, -;; it means that, if the cursor is in a currently hidden folded -;; construction, we want to show it; if it's not, we want to hide -;; whatever fold the cursor is in. -;; -;; Some editors other than Emacs provide a single mechanism for -;; folding text which various file types can exploit. The advantage -;; of this arrangement is that the user only has to know one set of -;; folding commands; the disadvantage is that the various file types -;; are limited to using whatever functionality is provided centrally. -;; Emacs by contrast provides a very general and powerful framework -;; for hiding text, which major modes can use as they see fit. The -;; advantage of this is that each major mode can deal with folding in -;; the way that is suitable for that type of file; the disadvantage is -;; that different major modes have different styles of folding, and -;; provide different key bindings. -;; -;; In practice, matters are simpler than that, since most major modes -;; delegate the task of folding to packages like outline.el and -;; hideshow.el. The key bindings for these two packages alone, -;; however, are numerous and for some people hard to type. Another -;; usability complication arises when a package like AucTeX uses -;; outline-minor-mode for some folds, and provides its own -;; key-bindings for other kinds of folds. Likewise, nXML-mode -;; provides its own style of folding for certain types of files, but -;; for files that don't fit that paradigm (such as XHTML), you may -;; want to use outline-minor-mode instead. -;; -;; The goal of this package is to reduce this complexity to three -;; globally-defined keystrokes: one to toggle the state of the fold at -;; point, whatever its type may be, one to hide all folds of all types -;; in the buffer, and one to show all folds. -;; -;; This package currently knows about folding-mode (from folding.el), -;; hs-minor-mode (from hideshow.el), outline-minor-mode (from -;; outline.el), TeX-fold-mode (from AUCTeX), and nXML-mode outlining. -;; More could be added. It is not necessary to have folding.el, -;; AUCTeX or nXML-mode installed, if you just want to use it with the -;; built-in modes. - -;;; Usage: -;; -;; You will need to have one or more of following minor modes switched -;; on: hs-minor-mode, outline-minor-mode, TeX-fold-mode, folding-mode. -;; Otherwise no folds may be found. There are three functions to try: -;; -;; fold-dwim-toggle: try to show any hidden text at the cursor; if no -;; hidden text is found, try to hide the text at the cursor. -;; -;; fold-dwim-hide-all: hide all folds in the buffer. -;; -;; fold-dwim-show-all: show all folds in the buffer. - -;;; Configuration -;; -;; This package binds no keys by default, so you need to find three -;; free and convenient key-bindings. This is what I use: -;; -;; (global-set-key (kbd "<f7>") 'fold-dwim-toggle) -;; (global-set-key (kbd "<M-f7>") 'fold-dwim-hide-all) -;; (global-set-key (kbd "<S-M-f7>") 'fold-dwim-show-all) -;; - -;;; Advanced Configuration -;; -;; With respect to outline-minor-mode (or outline-mode), dwim-fold -;; provides two different styles of usage. The first is a "nested" -;; style which only shows top-level headings when you fold the whole -;; buffer, and then allows you to drill down progressively through the -;; other levels. The other is a "flat" style, whereby folding the -;; entire buffer shows all headings at every level. -;; -;; The default is "flat", but if you want to change the default, you -;; can set the value of fold-dwim-outline-style-default to be 'flat or -;; 'nested. If you wish to override the default for a particular -;; major mode, put a value of either 'flat or 'nested for the -;; fold-dwim-outline-style property of the major-mode symbol, like so: -;; -;; (put 'org-mode 'fold-dwim-outline-style 'nested) -;; -;; At present, there is no way to customize nXML-mode outlining to use -;; the nested style, since it is not really supported by that mode -;; (there is no function to hide all text and subheadings in the -;; buffer). - -;;; Compatibility -;; -;; Tested with GNU Emacs CVS (from Sept. 10, 2004), AUCTeX version -;; 11.53, nxml-mode version 20041004, folding.el version 2.97. -;; -;; If there are any other important major or minor modes that do -;; folding and that could usefully be handled in this package, please -;; let me know. - -;;; Bugs -;; -;; It is possible that some of the various folding modes may interact -;; badly if used together; I have not tested all permutations. -;; -;; The function fold-dwim-hide tries various folding modes in -;; succession, and stops when it finds one that successfully makes a -;; fold at point. This means that the order in which those modes are -;; tried is significant. I have not spent a lot of time thinking -;; about what the optimal order would be; all I care about is that -;; hideshow and TeX-fold have priority over outline-minor-mode (since -;; for me they usually fold smaller chunks of the file). -;; -;; I don't use folding.el myself, so that functionality is not well -;; tested. - -;;; Changes -;; -;; 1.0 Initial release -;; 1.1 Bugfix: test if folding-mode is bound -;; 1.2 fold-dwim-hide-all and -show-all operate only on active region -;; in transient-mark-mode. -;; 1.3 Added outline-mode (Lennart Borgman) -;; 1.4 Removed nxml-mode style folding (Lennart Borgman) -;; + some functions used by nXhtml. - -(require 'outline) -(require 'hideshow) - -;;;###autoload -(defgroup fold-dwim nil - "Unified interface to folding commands" - :prefix "fold-dwim-" - :group 'editing) - -(defcustom fold-dwim-outline-style-default 'flat - "Default style in which to fold in outline-minor-mode: 'nested or - 'flat." - :type '(choice (const :tag "Flat (show all headings)" flat) - (const :tag "Nested (nest headings hierarchically)" nested)) - :group 'fold-dwim) - -(defvar fold-dwim-toggle-selective-display 'nil - "Set this non-nil to make fold-dwim functions use selective - display (folding of all lines indented as much or more than the - current line). Probably only useful for minor modes like - makefile-mode that don't provide a more intelligent way of - folding.") - -(make-variable-buffer-local - 'fold-dwim-toggle-selective-display) - -(defun fold-dwim-maybe-recenter () - "It's annoyingly frequent that hiding a fold will leave you -with point on the top or bottom line of the screen, looking at -nothing but an ellipsis. TODO: only recenter if we end up near -the top or bottom of the screen" - (recenter)) - -(defun fold-dwim-toggle-selective-display () - "Set selective display to indentation of current line" - (interactive) - (if (numberp selective-display) - (set-selective-display nil) - (save-excursion - (beginning-of-line) - (skip-chars-forward " \t") - (let ((col (current-column))) - (if (zerop col) - (set-selective-display nil) - (set-selective-display col)))))) - -(defun fold-dwim-hide-all () - "Hide all folds of various kinds in the buffer or region" - (interactive) - (save-excursion - (save-restriction - (when (and transient-mark-mode mark-active) - (narrow-to-region (region-beginning) (region-end))) - (when (and (boundp 'TeX-fold-mode) TeX-fold-mode) - (TeX-fold-buffer)) - (when hs-minor-mode - (hs-hide-all)) - (when (or outline-minor-mode (eq major-mode 'outline-mode)) - (if (fold-dwim-outline-nested-p) - (hide-sublevels 1) - (hide-body))) - ;; (when (derived-mode-p 'nxml-mode) - ;; (nxml-hide-all-text-content)) - (when (and (boundp 'folding-mode) folding-mode) - (folding-whole-buffer)))) - (fold-dwim-maybe-recenter)) - -(defun fold-dwim-show-all () - "Show all folds of various kinds in the buffer or region" - (interactive) - (save-excursion - (save-restriction - (when (and transient-mark-mode mark-active) - (narrow-to-region (region-beginning) (region-end))) - (when (and (boundp 'TeX-fold-mode) TeX-fold-mode) - (TeX-fold-clearout-buffer)) - (when hs-minor-mode - (hs-show-all)) - ;; (when (derived-mode-p 'nxml-mode) - ;; (nxml-show-all)) - (when (or outline-minor-mode (eq major-mode 'outline-mode)) - (show-all)) - (when (and (boundp 'folding-mode) folding-mode) - (folding-open-buffer)) - (when fold-dwim-toggle-selective-display - (set-selective-display 'nil))))) - -(defun fold-dwim-hide () - "Hide one item" - (or (and (boundp 'TeX-fold-mode) - TeX-fold-mode - (let ((type (fold-dwim-auctex-env-or-macro))) - (when type - (TeX-fold-item type)))) - ;; Look for html headers. - (when (and (derived-mode-p 'nxml-mode 'html-mode) - outline-minor-mode) - (when (save-excursion - (save-match-data - (looking-back (rx "<" (optional "/") - "h" (any "1-6") - (0+ (not (any "<"))))))) - (hide-entry) - t)) - (and hs-minor-mode - (when (save-excursion - (or (hs-find-block-beginning) (hs-inside-comment-p))) - (hs-hide-block) - (hs-already-hidden-p))) - ;; (and (derived-mode-p 'nxml-mode) - ;; (condition-case nil - ;; (save-excursion - ;; (nxml-back-to-section-start)) - ;; (error nil)) - ;; (nxml-hide-text-content)) - (and (boundp 'folding-mode) - folding-mode - (condition-case nil - (save-excursion - (folding-hide-current-entry) - t) - (error nil))) - (when (or outline-minor-mode (eq major-mode 'outline-mode)) - (if (fold-dwim-outline-nested-p) - (hide-subtree) - (hide-entry)))) - (fold-dwim-maybe-recenter)) - - -(defun fold-dwim-show () - "If point is in a closed or temporarily open fold, - open it. Returns nil if nothing was done" - (save-excursion - (let ((stop)) - (when (and (or outline-minor-mode (eq major-mode 'outline-mode)) - (or (fold-dwim-outline-invisible-p (line-end-position)) - (and (bolp) - (not (bobp)) - (fold-dwim-outline-invisible-p (1- (point)))))) - (if (not (fold-dwim-outline-nested-p)) - (show-entry) - (show-children) - (show-entry)) - (setq stop "outline-minor-mode")) - (when (and (not stop) - hs-minor-mode - (hs-already-hidden-p)) - (hs-show-block) - (setq stop "hs-minor-mode")) - (when (and (not stop) - (boundp 'TeX-fold-mode) - TeX-fold-mode) - (let ((overlays (overlays-at (point)))) - (while overlays - (when (eq (overlay-get (car overlays) 'category) 'TeX-fold) - (delete-overlay (car overlays)) - (setq stop "Tex-fold-mode")) - (setq overlays (cdr overlays))))) - ;; (when (and (not stop) - ;; (derived-mode-p 'nxml-mode)) - ;; (let ((overlays (overlays-at (point)))) - ;; (while (and overlays (not stop)) - ;; (when (overlay-get (car overlays) 'nxml-outline-display) - ;; (setq stop "nxml folding")) - ;; (setq overlays (cdr overlays)))) - ;; (when stop - ;; (nxml-show))) - (when (and (not stop) - (boundp 'folding-mode) - folding-mode - (save-excursion - (beginning-of-line) - (let ((current-line-mark (folding-mark-look-at))) - (when (and (numberp current-line-mark) - (= current-line-mark 0)) - (folding-show-current-entry) - (setq stop "folding-mode")))))) - stop))) - -;;;###autoload -(defun fold-dwim-toggle () - "Toggle visibility or some other visual things. -Try toggling different visual things in this order: - -- Images shown at point with `inlimg-mode' -- Text at point prettified by `html-write-mode'. - -For the rest it unhides if possible, otherwise hides in this -order: - -- `org-mode' header or something else using that outlines. -- Maybe `fold-dwim-toggle-selective-display'. -- `Tex-fold-mode' things. -- In html if `outline-minor-mode' and after heading hide content. -- `hs-minor-mode' things. -- `outline-minor-mode' things. (Turns maybe on this.) - -It uses `fold-dwim-show' to show any hidden text at point; if no -hidden fold is found, try `fold-dwim-hide' to hide the -construction at the cursor. - -Note: Also first turn on `fold-dwim-mode' to get the keybinding -for this function from it." - (interactive) - (fold-dwim-mode 1) - (cond - ((get-char-property (point) 'html-write) - (html-write-toggle-current-tag)) - ((get-char-property (point) 'inlimg-img) - (inlimg-toggle-display (point))) - ((eq major-mode 'org-mode) - (org-cycle)) - ((and (fboundp 'outline-cycle) - outline-minor-mode) - (outline-cycle)) - (t - (unless (or outline-minor-mode hs-minor-mode) - (outline-minor-mode 1)) - (if fold-dwim-toggle-selective-display - (fold-dwim-toggle-selective-display) - (let ((unfolded (fold-dwim-show))) - (if unfolded - (message "Fold DWIM showed: %s" unfolded) - (fold-dwim-hide))))))) - -;;;###autoload -(define-minor-mode fold-dwim-mode - "Key binding for `fold-dwim-toggle'." - :global t - :group 'nxhtml - :group 'foldit - nil) - -;; Fix-me: Maybe move to fold-dwim and rethink? -(defvar fold-dwim-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control ?c) ?+] 'fold-dwim-toggle) - map)) - -;;;###autoload -(defun fold-dwim-unhide-hs-and-outline () - "Unhide everything hidden by Hide/Show and Outline. -Ie everything hidden by `hs-minor-mode' and -`outline-minor-mode'." - (interactive) - (hs-show-all) - (show-all)) - -;;;###autoload -(defun fold-dwim-turn-on-hs-and-hide () - "Turn on minor mode `hs-minor-mode' and hide. -If major mode is derived from `nxml-mode' call `hs-hide-block' -else call `hs-hide-all'." - (interactive) - (hs-minor-mode 1) - (foldit-mode 1) - (if (derived-mode-p 'nxml-mode) - (hs-hide-block) - (hs-hide-all))) - -;;;###autoload -(defun fold-dwim-turn-on-outline-and-hide-all () - "Turn on `outline-minor-mode' and call `hide-body'." - (interactive) - (outline-minor-mode 1) - (foldit-mode 1) - (hide-body)) - -(defun fold-dwim-auctex-env-or-macro () - (let ((type (cond - ;; Fold macro before env, unless it's begin or end - ((save-excursion - (let ((macro-start (TeX-find-macro-start))) - (and macro-start - (not (= macro-start (point))) - (goto-char macro-start) - (not (looking-at - (concat (regexp-quote TeX-esc) - "\\(begin\\|end\\)[ \t]*{")))))) - 'macro) - ((and (eq major-mode 'context-mode) - (save-excursion - (ConTeXt-find-matching-start) (point))) - 'env) - ((and (eq major-mode 'texinfo-mode) - (save-excursion - (Texinfo-find-env-start) (point))) - 'env) - ((and (eq major-mode 'latex-mode) - (condition-case nil - (save-excursion - (LaTeX-find-matching-begin) (point) - (not (looking-at "\\\\begin[ \t]*{document}"))) - (error nil))) - 'env) - (t - nil)))) - type)) - -(defun fold-dwim-outline-invisible-p (pos) - "The version of this function in outline.el doesn't work so - well for our purposes, because it doesn't distinguish between - invisibility caused by outline, and that of other modes." - (save-excursion - (goto-char pos) - (let ((overlays (overlays-at (point))) - (found-one)) - (while overlays - (when (eq (overlay-get (car overlays) 'invisible) 'outline) - (setq found-one t)) - (setq overlays (cdr overlays))) - found-one))) - -(defun fold-dwim-outline-nested-p () - "Are we using the flat or nested style for outline-minor-mode?" - (let ((style (get major-mode 'fold-dwim-outline-style))) - (if style - (eq style 'nested) - (eq fold-dwim-outline-style-default 'nested)))) - -(provide 'fold-dwim) diff --git a/emacs.d/nxhtml/util/foldit.el b/emacs.d/nxhtml/util/foldit.el deleted file mode 100644 index 0ffacc3..0000000 --- a/emacs.d/nxhtml/util/foldit.el +++ /dev/null @@ -1,357 +0,0 @@ -;;; foldit.el --- Helpers for folding -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2009-08-10 Mon -;; Version: -;; Last-Updated: -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Defines `foldit-mode' which puts visual clues on hidden regions. -;; Does not do any folding itself but works with `outline-minor-mode' -;; and `hs-minor-mode'. -;; -;; Fix-me: reveal-mode does not work with this and I have no idea why -;; ... -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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, 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: - -;; Fix-me: start-tag-beg/start-tag-end are workarounds for smaller -;; bugs in hs-minor-mode and outline-minor-mode. Maybe try to fix -;; them... - but there are a whole bunch of other invisibilty related -;; bugs that ought to be fixed first since otherwise it is impossible -;; to know where point goes after hiding/unhiding. - -(eval-when-compile (require 'cl)) -(eval-when-compile (require 'hideshow)) -(eval-when-compile (require 'mumamo nil t)) -(eval-when-compile (require 'outline)) - -(defsubst foldit-overlay-priority () - (1+ (or (and (boundp 'mlinks-link-overlay-priority) - mlinks-link-overlay-priority) - 100))) - -;;;###autoload -(defgroup foldit nil - "Customization group for foldit folding helpers." - :group 'nxhtml) - -(defvar foldit-temp-at-point-ovl nil) -(make-variable-buffer-local 'foldit-temp-at-point-ovl) - -;;;###autoload -(define-minor-mode foldit-mode - "Minor mode providing visual aids for folding. -Shows some hints about what you have hidden and how to reveal it. - -Supports `hs-minor-mode', `outline-minor-mode' and major modes -derived from `outline-mode'." - :lighter nil - (if foldit-mode - (progn - ;; Outline - (add-hook 'outline-view-change-hook 'foldit-outline-change nil t) - ;; Add our overlays - (when (or (and (boundp 'outline-minor-mode) outline-minor-mode) - ;; Fix-me: mumamo - (derived-mode-p 'outline-mode)) (foldit-outline-change)) - ;; hs - (unless (local-variable-p 'hs-set-up-overlay) - (set (make-local-variable 'hs-set-up-overlay) 'foldit-hs-set-up-overlay)) - ;; Add our overlays - (when (or (and (boundp 'hs-minor-mode) hs-minor-mode)) - (save-restriction - (widen) - (let (ovl) - (dolist (ovl (overlays-in (point-min) (point-max))) - (when (eq (overlay-get ovl 'invisible) 'hs) - (funcall hs-set-up-overlay ovl))))))) - ;; Outline - (remove-hook 'outline-view-change-hook 'foldit-outline-change t) - ;; hs - (when (and (local-variable-p 'hs-set-up-overlay) - (eq hs-set-up-overlay 'foldit-hs-set-up-overlay)) - (kill-local-variable 'hs-set-up-overlay)) - ;; Remove our overlays - (save-restriction - (widen) - (let (ovl prop) - (dolist (ovl (overlays-in (point-min) (point-max))) - (when (setq prop (overlay-get ovl 'foldit)) - (case prop - ;;('display (overlay-put ovl 'display nil)) - ('foldit (delete-overlay ovl)) - (t (delete-overlay ovl)) - ))))))) - -(defcustom foldit-avoid '(org-mode) - "List of major modes to avoid." - :group 'foldit) - -;;;###autoload -(define-globalized-minor-mode foldit-global-mode foldit-mode - (lambda () (foldit-mode 1)) - :group 'foldit) - -(defun foldit-hidden-line-str (hidden-lines type) - "String to display for hidden lines. -HIDDEN-LINES are the number of lines and TYPE is a string -indicating how they were hidden." - (propertize (format " ...(%d %slines)" hidden-lines type) - 'face 'shadow)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Outline - -(defvar foldit-outline-keymap - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'foldit-outline-show-entry) - (define-key map [down-mouse-1] 'foldit-outline-show-entry) - (define-key map [S-tab] 'mlinks-backward-link) - (define-key map [tab] 'mlinks-forward-link) - (define-key map "\t" 'mlinks-forward-link) - map)) - -(defun foldit-outline-change () - "Check outline overlays. -Run this in `outline-view-change-hook'." - ;; We get the variables FROM and TO here from `outline-flag-region' - ;; so let us use them. But O is hidden... - (let* (from - to - num-lines - ovl - (tag "")) - (cond - ((and (boundp 'start) - start - (boundp 'end) - end) - (setq from start) - (setq to end)) - (t - (setq from (point-min)) - (setq to (point-max)))) - (dolist (ovl (overlays-in from to)) - (when (eq (overlay-get ovl 'invisible) 'outline) - (setq num-lines (count-lines (overlay-start ovl) (overlay-end ovl))) - (overlay-put ovl 'display (concat - (propertize "+" 'face 'mode-line) - "" - tag (foldit-hidden-line-str num-lines ""))) - (overlay-put ovl 'foldit 'display) ;; Should be a list... - (overlay-put ovl 'keymap foldit-outline-keymap) - (overlay-put ovl 'face 'lazy-highlight) - (overlay-put ovl 'mouse-face 'highlight) - (overlay-put ovl 'help-echo "Press RET to show hidden part") - (overlay-put ovl 'mlinks-link t) - (overlay-put ovl 'priority (foldit-overlay-priority)) - (mumamo-with-buffer-prepared-for-jit-lock - (let* ((start-tag-beg (overlay-start ovl)) - (start-tag-end start-tag-beg)) - (put-text-property start-tag-beg (+ start-tag-beg 1) - 'foldit-tag-end (copy-marker start-tag-end)))) - )))) - -(defvar foldit-outline-hide-again-keymap - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'foldit-outline-hide-again) - (define-key map [down-mouse-1] 'foldit-outline-hide-again) - (define-key map [S-tab] 'mlinks-backward-link) - (define-key map [tab] 'mlinks-forward-link) - (define-key map "\t" 'mlinks-forward-link) - map)) - -(defun foldit-outline-show-entry () - "Show hidden entry." - (interactive) - (let ((tag-end (get-text-property (point) 'foldit-tag-end))) - (show-entry) - (mumamo-with-buffer-prepared-for-jit-lock - (set-text-properties (point) (+ (point) 2) 'foldit-tag-end)) - (when tag-end (goto-char tag-end)) - (foldit-add-temp-at-point-overlay "-" - foldit-outline-hide-again-keymap - "Press RET to hide again"))) - -(defun foldit-outline-hide-again () - "Hide entry again." - (interactive) - (when (overlayp foldit-temp-at-point-ovl) - (delete-overlay foldit-temp-at-point-ovl)) - (hide-entry)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Hide/Show - -(defvar foldit-hs-start-tag-end-func 'foldit-hs-default-start-tag-end) -(make-variable-buffer-local 'foldit-hs-start-tag-end-func) -(put 'foldit-hs-start-tag-end-func 'permanent-local t) - -(defun foldit-hs-default-start-tag-end (beg) - "Find end of hide/show tag beginning at BEG." - (min (+ beg 65) - (save-excursion - (goto-char beg) - (line-end-position)))) - -(defvar foldit-hs-keymap - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'foldit-hs-show-block) - (define-key map [down-mouse-1] 'foldit-hs-show-block) - (define-key map [S-tab] 'mlinks-backward-link) - (define-key map [tab] 'mlinks-forward-link) - (define-key map "\t" 'mlinks-forward-link) - map)) - -(defvar foldit-hs-hide-again-keymap - (let ((map (make-sparse-keymap))) - (define-key map "\r" 'foldit-hs-hide-again) - (define-key map [down-mouse-1] 'foldit-hs-hide-again) - (define-key map [S-tab] 'mlinks-backward-link) - (define-key map [tab] 'mlinks-forward-link) - (define-key map "\t" 'mlinks-forward-link) - map)) - -(defun foldit-hs-set-up-overlay (ovl) - "Set up overlay OVL for hide/show." - (let* ((num-lines (count-lines (overlay-start ovl) (overlay-end ovl))) - (here (point)) - (start-tag-beg (overlay-start ovl)) - (start-tag-end (funcall foldit-hs-start-tag-end-func start-tag-beg)) - (tag (buffer-substring start-tag-beg start-tag-end))) - (goto-char here) - ;;(overlay-put ovl 'isearch-open-invisible t) - (overlay-put ovl 'display (concat - (propertize "+" 'face 'mode-line) - " " - tag (foldit-hidden-line-str num-lines "h"))) - (overlay-put ovl 'foldit 'display) - (overlay-put ovl 'keymap foldit-hs-keymap) - (overlay-put ovl 'face 'next-error) - (overlay-put ovl 'face 'lazy-highlight) - (overlay-put ovl 'mouse-face 'highlight) - (overlay-put ovl 'help-echo "Press RET to show hidden part") - (overlay-put ovl 'mlinks-link t) - (overlay-put ovl 'priority (foldit-overlay-priority)) - (mumamo-with-buffer-prepared-for-jit-lock - (put-text-property start-tag-beg (+ start-tag-beg 1) - 'foldit-tag-end (copy-marker start-tag-end))))) - -(defun foldit-hs-show-block () - "Show hidden block." - (interactive) - (let ((tag-end (get-text-property (point) 'foldit-tag-end))) - (hs-show-block) - (mumamo-with-buffer-prepared-for-jit-lock - (set-text-properties (point) (+ (point) 2) 'foldit-tag-end)) - (when tag-end (goto-char tag-end)) - (foldit-add-temp-at-point-overlay "-" - foldit-hs-hide-again-keymap - "Press RET to hide again"))) - -(defun foldit-hs-hide-again () - "Hide hide/show block again." - (interactive) - (when (overlayp foldit-temp-at-point-ovl) - (delete-overlay foldit-temp-at-point-ovl)) - (hs-hide-block)) - - -;;; Fix-me: break out this -;; >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -(defun foldit-add-temp-at-point-overlay (marker keymap msg) - "Add a temporary overlay with a marker MARKER and a keymap KEYMAP. -The overlay is also given the help echo MSG. - -This overlay is removed as soon as point moves from current point." - (let ((ovl (make-overlay (point) (1+ (point)))) - (real (buffer-substring (point) (1+ (point))))) - (overlay-put ovl 'isearch-open-invisible t) - (overlay-put ovl 'display (concat - (propertize marker 'face 'mode-line) - " " - msg - real)) - (overlay-put ovl 'foldit 'foldit) - (overlay-put ovl 'keymap keymap) - (overlay-put ovl 'face 'lazy-highlight) - (overlay-put ovl 'mouse-face 'highlight) - (overlay-put ovl 'help-echo msg) - (overlay-put ovl 'mlinks-link t) - (overlay-put ovl 'priority (foldit-overlay-priority)) - (setq foldit-temp-at-point-ovl ovl) - (add-hook 'post-command-hook - 'foldit-remove-temp-at-point-overlay - nil t))) - -(defun foldit-remove-temp-at-point-overlay () - "Remove overlay made by `foldit-add-temp-at-point-overlay'." - (condition-case err - (unless (and foldit-temp-at-point-ovl - (overlay-buffer foldit-temp-at-point-ovl) - (= (overlay-start foldit-temp-at-point-ovl) - (point))) - (delete-overlay foldit-temp-at-point-ovl) - (setq foldit-temp-at-point-ovl nil) - (remove-hook 'post-command-hook 'foldit-remove-temp-at-point-overlay t) - ) - (error (message "foldit-remove-temp-at-point-overlay: %s" - (propertize (error-message-string err)))))) -;; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< - - - -;; (defun put-before-on-invis () -;; (let* (o -;; (io (catch 'io -;; (dolist (o (overlays-at (1+ (point)))) -;; (when (overlay-get o 'invisible) -;; (throw 'io o))))) -;; (str (propertize "IOSTRING" -;; 'face 'secondary-selection -;; ))) -;; (overlay-put io 'before-string str) -;; ;;(overlay-put io 'display "display") -;; (overlay-put io 'display nil) -;; ;;(overlay-put io 'after-string "AFTER") -;; )) - -(provide 'foldit) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; foldit.el ends here diff --git a/emacs.d/nxhtml/util/fupd.el b/emacs.d/nxhtml/util/fupd.el deleted file mode 100644 index bb8b3af..0000000 --- a/emacs.d/nxhtml/util/fupd.el +++ /dev/null @@ -1,127 +0,0 @@ -;;; fupd.el --- Helper functions for updating files -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: Tue Feb 28 17:21:20 2006 -;; Version: 0.1 -;; Last-Updated: Tue Feb 20 21:09:20 2007 (3600 +0100) -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Helper functions for updating files. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(defun fupd-has-contents (file content) - "Check if file FILE contains CONTENT. -Return a vector with these elements: -- elt 0: t if file contains CONTENT and buffer is not modified. -- elt 1: t if file contains CONTENT. -- elt 2: file buffer if file exists. -- elt 3: nil unless file already was in a buffer." - (let (ok same buffer old-buffer) - (when (file-exists-p file) - (setq buffer (get-file-buffer file)) - (setq old-buffer (when buffer t)) - (unless buffer - (setq buffer (find-file-noselect file))) - (with-current-buffer buffer - (setq same (string= - content - (buffer-substring-no-properties - (point-min) (point-max))))) - (setq ok (and same - (not (buffer-modified-p buffer))))) - (vector ok same buffer old-buffer))) - -(defun fupd-ok (ret-val) - "Return t if RET-VAL indicate file is uptodate. -RET-VAL should be the return value from `fupd-has-contents'." - (elt ret-val 0)) - -(defun fupd-kill-new-buffer (ret-val) - "Kill new buffer indicated by RET-VAL. -RET-VAL should be the return value from `fupd-has-contents'." - (unless (elt ret-val 3) - (let ((buffer (elt ret-val 2))) - (when (bufferp buffer) - ;;(message "fupd-kill-new-buffer: %s" (buffer-file-name buffer))(sit-for 4) - (kill-buffer buffer))))) - -;;(fupd-has-contents buffer-file-name (buffer-string)) -;;(fupd-update-file buffer-file-name (buffer-string)) -(defun fupd-update-file (file content) - "Update file FILE with content CONTENT. -Do nothing if the file already has that content. If the file was -not in a buffer before kill the file's buffer afterwards. - -Return t if the file was updated, otherwise nil." - (let* ((osbo (fupd-has-contents file content)) - (ok (elt osbo 0)) - (same (elt osbo 1)) - (buff (elt osbo 2)) - (oldb (elt osbo 3)) - wrote - ) - (unless ok - (if buff - (with-current-buffer buff - (unless same - (erase-buffer) - (insert content)) - (save-buffer) - (setq wrote t) - (unless oldb - (kill-buffer (current-buffer)))) - (with-temp-buffer - (insert content) - (write-file file)))) - wrote)) - -;; (defun fupd-copy-file (from-file to-file) -;; (let ( -;; (from-buff (find-buffer-visiting from-file)) -;; (to-buff (find-buffer-visiting to-file)) -;; (from-attr (file-attributes from-file)) -;; (to-attr (file-attributes to-file)) -;; (from-size (nth 7 from-attr)) -;; (to-size (nth 7 to-attr)) -;; (from-mod (nth 5 from-attr)) -;; (to-mode (nth 5 to-attr)) -;; ) -;; )) - -(provide 'fupd) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; fupd.el ends here diff --git a/emacs.d/nxhtml/util/gimpedit.el b/emacs.d/nxhtml/util/gimpedit.el deleted file mode 100644 index e624e9f..0000000 --- a/emacs.d/nxhtml/util/gimpedit.el +++ /dev/null @@ -1,172 +0,0 @@ -;;; gimpedit.el --- Edit files with GIMP -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: Wed May 23 14:59:50 2007 -(defconst gimpedit:version "0.31") ;;Version: -;; Last-Updated: 2009-11-03 Tue -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; - ;; `setup-helper', `w32-reg-iface', `w32-regdat'. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Simple interface to start editing with GIMP. -;; -;; If you want to edit files from within Emacs see the doc string of -;; `gimpedit-edit-buffer'. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-and-compile (require 'w32-regdat nil t)) - -;; (message "%S" (gimpedit-get-remote-command)) -(defun gimpedit-get-remote-command () - (if (featurep 'w32-regdat) - (save-match-data - (let ((cmd (w32-regdat-gimp-win-remote-cmd)) - cmd-list) - (while (< 0 (length cmd)) - (cond - ((or (string-match (rx string-start - ?\" - (submatch - (0+ (not (any ?\")))) - ?\" - (0+ space)) - cmd) - (string-match (rx string-start - (submatch - (0+ (not (any space)))) - (0+ space)) - cmd)) - (setq cmd-list (cons (match-string-no-properties 1 cmd) cmd-list)) - (setq cmd (substring cmd (match-end 0)))))) - (cadr cmd-list))) - (if (memq system-type '(windows-nt)) - (let (prog) - (catch 'found-prog - (dolist (num '(2 3 4 5 6 7 8 9)) - (setq prog (concat (getenv "ProgramFiles") - "\\GIMP-2.0\\bin\\gimp-2." - (number-to-string num) - ".exe")) - (when (file-exists-p prog) - (throw 'found-prog prog))))) - "gimp"))) - -;;;###autoload -(defgroup gimpedit nil - "Customization group for GIMP." - :group 'external - :group 'nxhtml) - -(defcustom gimpedit-remote-command (gimpedit-get-remote-command) - "Program name to use when calling GIMP remotely. -This could be be the full path to the program used when opening -files with GIMP or a just the program file name if it is in the -executables path. - -Example: - - The value is fetched from the registry on MS Windows if - possible or is else given the default value: - - \"C:\\Program Files\\GIMP-2.0\\bin\\gimp-2.6.exe\" - - On other system it has the default value - - \"gimp\"." - :type '(choice (file :tag "Full file name" :must-match t) - (string :tag "File name (must be in path)")) - :group 'gimpedit) - -;;;###autoload -(defun gimpedit-edit-file (image-file &optional extra-args) - "Edit IMAGE-FILE with GIMP. -See also `gimpedit-edit-file'." - (interactive (list (or (get-char-property (point) 'image-file) - (read-file-name "Image to edit in GIMP: ")))) - (setq image-file (expand-file-name image-file)) - (apply 'call-process gimpedit-remote-command - nil - 0 - nil - (reverse (cons image-file (reverse extra-args)))) - (let ((msg " Asked GIMP to open %s - you may have to switch to GIMP")) - (put-text-property 0 (length msg) 'face 'highlight msg) - (message msg (file-name-nondirectory image-file)))) - -;;;###autoload -(defun gimpedit-edit-buffer () - "Edit image file in current buffer with GIMP. -See also `gimpedit-edit-file'. - -You may also be interested in gimpedit-mode with which you can edit -gimp files from within Emacs using GIMP's scripting -possibilities. See - - URL `http://www.emacswiki.org/emacs/GimpMode'" - (interactive) - (unless (buffer-file-name) - (error - "Can't edit in GIMP because this buffer does not have a file name.")) - (gimpedit-edit-file (buffer-file-name))) - -;;;###autoload -(defun gimpedit-can-edit (file-name) - (and file-name - (member (downcase (file-name-extension file-name)) - '("png" "gif" "jpg" "jpeg")))) - -;; (defcustom gimpedit-point-key-bindings '(([(control ?c) ?&] gimpedit-edit-file)) -;; "Key bindings suggested for image links etc." -;; :type '(repeat (list key-sequence function)) -;; :group 'gimpedit) - -;; (defun gimpedit-add-point-bindings (map) -;; "Add `gimpedit-point-key-bindings' to point keymap MAP. -;; Set it up like this: - -;; (eval-after-load 'gimpedit -;; '(gimpedit-add-point-bindings MY-MAP)) - -;; There must also be a character property `image-file' at point for this -;; to work." -;; (dolist (binding gimpedit-point-key-bindings) -;; (let ((key (nth 0 binding)) -;; (fun (nth 1 binding))) -;; (define-key map key fun)))) - -(provide 'gimpedit) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; gimpedit.el ends here diff --git a/emacs.d/nxhtml/util/gpl.el b/emacs.d/nxhtml/util/gpl.el deleted file mode 100644 index a109555..0000000 --- a/emacs.d/nxhtml/util/gpl.el +++ /dev/null @@ -1,213 +0,0 @@ -;;; gpl.el --- Highlight and edit gpl color palettes - -(defconst gpl:version "0.01") -;; Copyright (C) 2008 Niels Giesen - -;; Author: Niels Giesen -;; Keywords: extensions, tools - -;; 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: - -;; GPL provides font-locking and has functions to edit the values -;; of colors (hue, saturation value, red, green and blue vals) -;; in-place in a simple, intuitive, and lightweight fashion. See the -;; documentation of `gpl-mode'. - -;; The methods and keybindings used are roughly the same as in the new -;; css-color mode. I should maybe have abstracted both color notation -;; models better, but did not feel like it. With under 200 lines of -;; code, it did not seem worth the effort. - -;; The css-color.el used is the one by Niels Giesen, at -;; `http://niels.kicks-ass.org/public/elisp/css-color.el'. - -;; Installation: - -;; Put this file in your load-path. Put a declaration such as - -;; (autoload 'gpl-mode "gpl") -;; (add-to-list 'auto-mode-alist -;; '("\\.gpl\\'" . gpl-mode)) - -;; In your initialization file (e.g. ~/.emacs) to make sure `gpl-mode' -;; is started anytime you open a *.gpl file, and gpl-mode is only -;; loaded when needed. - -;;; Code: -(require 'css-color) - -(defvar gpl-keywords - '(("^[[:space:]]*\\([a-fA-F[:digit:]]\\{1,3\\}\\)[[:space:]]+\\([a-fA-F[:digit:]]\\{1,3\\}\\)[[:space:]]+\\([a-fA-F[:digit:]]\\{1,3\\}\\)" - (0 - (let ((color (concat "#" (apply 'css-color-rgb-to-hex - (mapcar 'string-to-number - (list - (match-string-no-properties 1) - (match-string-no-properties 2) - (match-string-no-properties 3))))))) - - (put-text-property (match-beginning 0) - (match-end 0) - 'keymap gpl-map) - (put-text-property (match-beginning 0) - (match-end 0) - 'face (list :background - color - :foreground - (css-color-foreground-color - color)))))))) - -;;;###autoload -(define-derived-mode gpl-mode fundamental-mode "GPL" - "Mode for font-locking and editing color palettes of the GPL format. - -Such palettes are used and produced by free software applications -such as the GIMP, Inkscape, Scribus, Agave and on-line tools such -as http://colourlovers.com. - -You can also use -URL `http://niels.kicks-ass.org/public/elisp/css-palette.el' to import -such palette into a css-file as hexadecimal color palette." - (setq font-lock-defaults - '((gpl-keywords) - t))) - -(defvar gpl-map - (let ((m (make-sparse-keymap))) - (define-key m "=" 'gpl-up) - (define-key m "-" 'gpl-down) - (define-key m "h" 'gpl-hue-up) - (define-key m "H" 'gpl-hue-down) - (define-key m "v" 'gpl-value-up) - (define-key m "V" 'gpl-value-down) - (define-key m "s" 'gpl-saturation-up) - (define-key m "S" 'gpl-saturation-down) - m) - "Mode map for `gpl-mode'") - -(defun gpl-get-color-at-point () - (or (get-text-property (point) 'color) - (apply 'css-color-rgb-to-hsv - (gpl-get-rgb-list-at-point)))) - -(defun gpl-get-rgb-list-at-point () - (mapcar 'string-to-number - (split-string - (buffer-substring-no-properties - (point-at-bol) - (+ 11 (point-at-bol))) "[[:space:]]+" t))) - -(defun gpl-replcolor-at-p (fun increment) - (let ((pos (point))) - (beginning-of-line) - (insert - (funcall fun - (gpl-get-color-at-point) - increment)) - (delete-region (point) (+ (point) 11)) - (goto-char pos))) - -(defun gpl-hsv-to-gimp-color (h s v) - (propertize - (apply 'format "%3d %3d %3d" - (css-color-hsv-to-rgb h s v)) - 'keymap gpl-map - 'color (list h s v))) - -(defun gpl-what-channel () - (/ (- (point) (point-at-bol)) 4)) - -(defun gpl-adjust-channel-at-p (incr) - (interactive "p") - (let ((pos (point)) - (channel (gpl-what-channel))) - (beginning-of-line) - (let ((rgb - (gpl-get-rgb-list-at-point))) - (setf (nth channel rgb) - (css-color-within-bounds - (+ incr (nth channel rgb)) - 0 255)) - (delete-region (point) (+ 11 (point))) - (insert - (propertize - (apply 'format "%3d %3d %3d" rgb) - 'keymap gpl-map - 'color nil))) - (goto-char pos))) - -(defun gpl-inchue (color incr) - (destructuring-bind (h s v) color - (gpl-hsv-to-gimp-color - (+ incr h) s v))) - -(defun gpl-incsat (color incr) - (destructuring-bind (h s v) color - (gpl-hsv-to-gimp-color - h (css-color-within-bounds (+ incr s) 0 100) v))) - -(defun gpl-incval (color incr) - (destructuring-bind (h s v) color - (gpl-hsv-to-gimp-color - h s (css-color-within-bounds (+ incr v) 0 100)))) - -(defun gpl-adj-hue-at-p (increment) - (interactive "p") - (gpl-replcolor-at-p 'gpl-inchue increment)) - -(defun gpl-adj-saturation-at-p (increment) - (interactive "p") - (gpl-replcolor-at-p 'gpl-incsat increment)) - -(defun gpl-adj-value-at-p (increment) - (interactive "p") - (gpl-replcolor-at-p 'gpl-incval increment)) - -;; channels (r, g, b) -(defun gpl-up (val) - (interactive "p") - (gpl-adjust-channel-at-p val)) - -(defun gpl-down (val) - (interactive "p") - (gpl-adjust-channel-at-p (- val))) -;; hue -(defun gpl-hue-up (val) - (interactive "p") - (gpl-adj-hue-at-p val)) - -(defun gpl-hue-down (val) - (interactive "p") - (gpl-adj-hue-at-p (- val))) -;; saturation -(defun gpl-saturation-up (val) - (interactive "p") - (gpl-adj-saturation-at-p val)) - -(defun gpl-saturation-down (val) - (interactive "p") - (gpl-adj-saturation-at-p (- val))) -;; value -(defun gpl-value-up (val) - (interactive "p") - (gpl-adj-value-at-p val)) - -(defun gpl-value-down (val) - (interactive "p") - (gpl-adj-value-at-p (- val))) - -(provide 'gpl) -;;; gpl.el ends here diff --git a/emacs.d/nxhtml/util/hfyview.el b/emacs.d/nxhtml/util/hfyview.el deleted file mode 100644 index 0e0450d..0000000 --- a/emacs.d/nxhtml/util/hfyview.el +++ /dev/null @@ -1,651 +0,0 @@ -;;; hfyview.el --- View current buffer as html in web browser - -;; Copyright (C) 2005, 2006, 2007 by Lennart Borgman - -;; Author: Lennart Borgman -;; Created: Fri Oct 21 2005 -(defconst hfyview:version "0.63") ;; Version: -;; Last-Updated: 2010-04-16 Fri -;; Keywords: printing -;; URL: http://OurComments.org/Emacs/DL/elisp/hfyview.el -;; Compatibility: -;; -;; -;; Features that might be required by this library: -;; - ;; `easymenu'. -;; -;; -;; htmlfontify.el is part of Emacs. -;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; This file shows the current buffer in your web browser with all -;; the colors it has. The purpose is mainly to make it possible to -;; easily print what you see in Emacs in colors on different -;; platforms. -;; -;; Put this file in your load-path and in your .emacs this: -;; -;; (require 'hfyview) -;; -;; This defines the commands `hfyview-buffer', `hfyview-region' and -;; `hfyview-window' which will show the whole or a part of the buffer -;; in your web browser. -;; -;; You can add those commands to the menus by customizing -;; `hfyview-quick-print-in-files-menu' to t. This will add an entry -;; "Quick Print (Using Web Browser)" to the files menu. -;; -;; -;; There is also a command `hfyview-frame' to take a "screen shot" of -;; your current frame and produce an html look-alike page. If you -;; turn on `hfyview-frame-mode' you get this function on the <apps> -;; key in most situations. -;; -;; -;; You can see an example of the output here: -;; -;; http://ourcomments.org/Emacs/nXhtml/doc/htmlfontify-example.html -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; 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. -;; -;; To find out more about the GNU General Public License you can visit -;; Free Software Foundation's website http://www.fsf.org/. Or, write -;; to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'cl)) -(eval-when-compile (require 'htmlfontify)) -(require 'easymenu) - -(defvar hfyview-selected-window) - -(defvar hfyview-frame-mode-emulation-map - (let ((m (make-sparse-keymap))) - ;;(define-key m [apps] 'hfyview-frame) - m)) - -(defvar hfyview-frame-mode-emulation-maps - (list (cons 'hfyview-frame-mode hfyview-frame-mode-emulation-map))) - -;; Fix-me: which are needed? Probably only viper, but have to test. -(defconst hfyview-frame-mode-other-maps - '( - hfyview-frame-mode-emulation-map - minibuffer-local-completion-map - minibuffer-local-filename-completion-map - minibuffer-local-isearch-map - minibuffer-local-map - ;; minibuffer-local-must-match-filename-map - minibuffer-local-must-match-map - minibuffer-local-ns-map - viper-minibuffer-map - isearch-mode-map)) - -(define-minor-mode hfyview-frame-mode - "Define some useful things for `hfyview-frame'. -The <apps> key is bound to `hfyview-frame' in this mode. When -this mode is on you can push <apps> to get all of what you see on -the screen. Without it the minibuffer/echo area will not be -shown." - :global t - :group 'htmlfontify - (if hfyview-frame-mode - (progn - (add-hook 'pre-command-hook 'hfy-grab-minibuffer-content) - (add-hook 'post-command-hook 'hfy-grab-echo-content) - (add-to-list 'emulation-mode-map-alists 'hfyview-frame-mode-emulation-maps) - (dolist (map hfyview-frame-mode-other-maps) - (define-key (symbol-value map) [(apps)] 'hfyview-frame) - ) - ) - (remove-hook 'pre-command-hook 'hfy-grab-minibuffer-content) - (remove-hook 'post-command-hook 'hfy-grab-echo-content) - (setq emulation-mode-map-alists (delq 'hfyview-frame-mode-emulation-maps emulation-mode-map-alists)) - (dolist (map hfyview-frame-mode-other-maps) - (define-key (symbol-value map) [(apps)] nil)))) - -(defun hfyview-fontify-region (start end) - "Fontify region between START and END the htmlfontify way." - ;; If the last command in mumamo resulted in a change of major-mode - ;; the big bug watcher in mumamo will get us if we do not tell that - ;; we know what we are doing: - (let ((mumamo-just-changed-major nil)) - (if start - (save-restriction - (widen) - (narrow-to-region start end) - (assert (= end (point-max))) - (assert (= start (point-min))) - (htmlfontify-buffer)) - (htmlfontify-buffer)))) - -(defun hfyview-buffer-1(start end show-source) - "Convert current buffer between START and END to html. -If SHOW-SOURCE is non-nil then also show produced html in other -window." - (let ((hbuf (hfyview-fontify-region start end))) - (with-current-buffer hbuf - (setq buffer-file-name nil) - (browse-url-of-buffer)) - (when show-source (switch-to-buffer-other-window hbuf)) - hbuf)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;; Menus - -(defvar hfyview-print-menu (make-sparse-keymap "QP")) -(defvar hfyview-print-region-menu (make-sparse-keymap "QPR")) -(defvar hfyview-print-window-menu (make-sparse-keymap "QPW")) -(defun hfyview-add-to-files-menu () - "Add \"Quick Print\" entry to file menu." - ;; Why did I redo this??? - (setq hfyview-print-menu (make-sparse-keymap "QP")) - (setq hfyview-print-region-menu (make-sparse-keymap "QPR")) - (setq hfyview-print-window-menu (make-sparse-keymap "QPW")) - ;; Main - (define-key-after menu-bar-file-menu [hfyview-print] - (list 'menu-item - "Quick Print (Using Web Browser)" - hfyview-print-menu - :visible 'hfyview-print-visible) - 'separator-print) - ;; Main submenu - (define-key hfyview-print-menu [hfyview-browser-frame-pre] - '(menu-item "Print Preview Frame" hfyview-frame - :help "Print preview frame with web browser")) - (define-key hfyview-print-menu [hfyview-browser-window-pre] - '(menu-item "Print Preview Window" hfyview-window - :help "Print preview window with web browser")) - (define-key hfyview-print-menu [hfyview-browser-region-pre] - (list 'menu-item "Print Preview Region" 'hfyview-region - :help "Print preview region with web browser" - :enable 'mark-active)) - (define-key hfyview-print-menu [hfyview-separator-pre] - '(menu-item "--")) - (define-key hfyview-print-menu [hfyview-browser-pre] - '(menu-item "Print Preview Buffer" hfyview-buffer - :help "Print preview buffer with web browser" - :visible t)) - ) - -;;;###autoload -(defcustom hfyview-quick-print-in-files-menu nil - "Add Quick print entries to File menu if non-nil. -If you set this to nil you have to restart Emacs to get rid of -the Quick Print entry." - :type 'boolean - :set (lambda (sym val) - (set-default sym val) - (if val - (hfyview-add-to-files-menu))) - :group 'hfy-view) - -(defvar hfyview-print-visible t - "Non-nil means show Quick Print entry on the file menu.") - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;; Interactive commands - -;;;###autoload -(defun hfyview-buffer (arg) - "Convert buffer to html preserving faces and show in web browser. -With command prefix ARG also show html source in other window." - (interactive "P") - (hfyview-buffer-1 nil nil arg)) - -;;;###autoload -(defun hfyview-region (arg) - "Convert region to html preserving faces and show in web browser. -With command prefix ARG also show html source in other window." - (interactive "P") - (hfyview-buffer-1 (region-beginning) (region-end) arg)) - -;;;###autoload -(defun hfyview-window (arg) - "Convert window to html preserving faces and show in web browser. -With command prefix ARG also show html source in other window." - (interactive "P") - (hfyview-buffer-1 (window-start) (window-end) arg)) - -;;;###autoload -(defun hfyview-frame (whole-buffers) - "Convert frame to html preserving faces and show in web browser. -Make an XHTML view of the current Emacs frame. Put it in a buffer -named *hfyview-frame* and show that buffer in a web browser. - -If WHOLE-BUFFERS is non-nil then the whole content of the buffers -is shown in the XHTML page, otherwise just the part that is -visible currently on the frame. - -If you turn on the minor mode `hfyview-frame-mode' you can also -get the minibuffer/echo area in the output. See this mode for -details. - -With command prefix also show html source in other window." - (interactive (list (y-or-n-p "Enter y for whole buffers, n for only visible part? "))) - (let ((title "Emacs - Frame Dump") - buf) - (setq title (frame-parameter (selected-frame) 'name)) - (setq buf (hfyview-frame-1 whole-buffers title)) - (when current-prefix-arg - (switch-to-buffer-other-window buf)))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;; Internal commands - -(defconst hfyview-modline-format - ;; There seems to be a bug in Firefox that prevents this from - ;; displaying correctly. Anyway this is just a quick and reasonable - ;; approximation. - (concat "<div style=\"width:%sem; color:%s; background:%s; white-space:pre; overflow:hidden; font-family:monospace;\">" - ;; Using <pre> gives empty line above and below - ;;"<pre>" - "-- (Unix)%s <b>%s</b> (%s%s) " - (make-string 6 ?-) - "%s" ;; Viper - (make-string 200 ?-) - ;;"</pre>" - "</div>")) - -(defun hfyview-get-minors () - "Return string with active minor mode highlighters." - (let ((minors "")) - (dolist (mr minor-mode-alist) - (let ((mm (car mr)) - (ml (cadr mr))) - (when (symbol-value mm) - (when (stringp ml) - (setq minors (concat minors ml)))))) - minors)) - -;; (hfyview-dekludge-string "<i> ") -(defun hfyview-dekludge-string (str) - "Return html quoted string STR." - (mapconcat (lambda (c) - (hfy-html-quote - (char-to-string c))) - (append str) - "")) - -(defvar viper-mode-string) ;; Silence compiler - -(defun hfyview-fontify-win-to (win tag whole-buffer) - "Return html code for window WIN. -Sorround the code with the html tag <TAG>. -WHOLE-BUFFER corresponds to the similar argument for -`hfyview-frame-1'." - (let* ((bstart (unless whole-buffer (window-start win))) - (bend (unless whole-buffer (window-end win))) - (hbuf (hfyview-fontify-region bstart bend)) - (edges (window-edges win)) - (width (- (nth 2 edges) (nth 0 edges))) - (height (- (nth 3 edges) (nth 1 edges))) - (border-color (or (hfy-triplet "SystemActiveBorder") - "gray")) - start - end - css-start - css-end - mod-fgcolor - mod-bgcolor - mod-width - mod - bu-name - ma-name - minors - (window-start-line (point-min)) - (window-end-line (point-max)) - (is-selected-window (eq win hfyview-selected-window)) - (mark-viper "") - ) - ;; Fix-me: fetch style too - (with-current-buffer (window-buffer win) - (unless whole-buffer - (save-restriction - (widen) - (setq window-start-line (line-number-at-pos bstart)) - (setq window-end-line (line-number-at-pos bend)) - (unless (or (< (line-number-at-pos (point-min)) window-start-line) - (> (line-number-at-pos (point-max)) window-end-line)) - (setq whole-buffer t)) - ) - ) - (setq mod-fgcolor (face-attribute (if is-selected-window 'mode-line 'mode-line-inactive) :foreground)) - (setq mod-bgcolor (face-attribute (if is-selected-window 'mode-line 'mode-line-inactive) :background)) - (setq mod-fgcolor (hfy-triplet mod-fgcolor)) - (setq mod-bgcolor (hfy-triplet mod-bgcolor)) - (setq mod (if (buffer-modified-p) "**" "--")) - (when buffer-read-only - (setq mod "%%")) - (setq bu-name (buffer-name)) - (setq ma-name mode-name) - (setq minors (hfyview-get-minors)) - (when (and (local-variable-p 'viper-mode-string) viper-mode-string) - (setq mark-viper viper-mode-string)) - ) - ;; Compensate for scroll-bars - (setq mod-width (+ width 1)) - (with-current-buffer hbuf - (setq width (- width 2.5)) - (setq width (* 0.57 width)) - (setq height (+ height 2)) ;; For pre - ;;(setq height (+ height 1.2)) ;; For horisontal scrollbar - (setq height (* 1.16 height)) - (goto-char (point-min)) - (re-search-forward "<body.*?>") - (setq start (point)) - (insert - (format "<%s style=\"width:%sem; height:%sem; border: 1px solid %s; overflow:%s; padding:4px;\">\n" - tag width height border-color - (if whole-buffer "auto" "hidden") ;; overflow - )) - (goto-char (point-max)) - (setq end (search-backward "</body>")) - (unless whole-buffer - (insert - (format "\n<div style=\"margin-top:2em; color: red; text-align: center; \"> Truncated to line %s - %s! </div>\n" - window-start-line window-end-line))) - (insert "</" tag ">\n") - ;;(lwarn t :warning "%s" mark-viper) - (insert (format hfyview-modline-format - width - mod-fgcolor mod-bgcolor mod - (hfyview-dekludge-string bu-name) - (hfyview-dekludge-string ma-name) - (hfyview-dekludge-string minors) - (hfyview-dekludge-string mark-viper))) - (setq end (point)) - (goto-char (point-min)) - (search-forward "<style type=\"text/css\"><!--") - (beginning-of-line) - (setq css-start (point)) - (search-forward "--></style>") - (setq css-end (point)) - (set-buffer-modified-p nil) - (setq buffer-file-name nil)) - (list hbuf start end css-start css-end))) - -;; (defun hfyview-window-framed () -;; "Just a test" -;; (interactive) -;; (let* ((res (hfyview-fontify-win-to (selected-window) "div" nil)) -;; (hbuf (nth 0 res))) -;; (with-current-buffer hbuf -;; (browse-url-of-buffer)))) - -(defun hfyview-fontify-tree-win (win whole-buffer) - "Return html code for window WIN. -WHOLE-BUFFER corresponds to the similar argument for -`hfyview-frame-1'." - (with-selected-window win - (let* ((start (window-start)) - (end (window-end)) - (res (hfyview-fontify-win-to win "div" whole-buffer)) - (hbuf (nth 0 res))) - (with-current-buffer hbuf - (rename-buffer (generate-new-buffer-name (format "%s %s-%s" win start end)))) - ;;(lwarn t :warning "win=%s, hbuf=%s" win hbuf) - res))) - -(defun hfyview-fontify-tree (wt whole-buffers) - "Return list of html code for all windows in tree WT. -WT should be the result of function `window-tree' or a subtree of -this. For WHOLE-BUFFERS see `hfyview-frame-1'." - (if (not (listp wt)) - (hfyview-fontify-tree-win wt whole-buffers) - (let ((ret)) - (dolist (w (cddr wt)) - (setq ret (cons (hfyview-fontify-tree w whole-buffers) ret))) - (list (car wt) ret)))) - -(defun hfyview-frame-to-html (res) - "Return list with css and html code for frame. -RES is the collected result from `hfyview-fontify-tree'." - (let ((html "") - (css "") - (first (car res)) - (td "<td style=\"vertical-align:top;\">") - h) - (cond - ((memq first '(nil t)) - (dolist (sub (reverse (cadr res))) - (let* ((fres (hfyview-frame-to-html sub)) - (h (nth 0 fres)) - (c (nth 1 fres))) - (when first (setq h (concat "<tr>\n" h "</tr>\n"))) - (setq html (concat html h)) - (setq css (concat css c)))) - (unless first - (setq html (concat "<tr>" html "</tr>\n"))) - (setq html (concat "<table border=\"0\" cellpadding=\"0\" cellspacing=\"0\">\n" html "</table>\n")) - (setq html (concat td html "</td>\n")) - ) - ((bufferp first) - ;; (buf start end) - (let* ((buf (nth 0 res)) - (sta (nth 1 res)) - (end (nth 2 res)) - (cst (nth 3 res)) - (cnd (nth 4 res)) - (h - ;;(concat "<td>" "temp" "</td>\n") - (with-current-buffer buf (buffer-substring-no-properties sta end))) - (c - ;;(concat "<td>" "temp" "</td>\n") - (with-current-buffer buf (buffer-substring-no-properties cst cnd)))) - (setq h (concat td h - "</td>\n")) - (setq html (concat html h)) - (setq css c) - (kill-buffer buf))) - (t - (error "Uh?"))) - (list html css))) - -(defconst hfyview-xhtml-header - "<?xml version=\"1.0\" encoding=\"utf-8\"?> -<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" -\"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\"> -<html xmlns=\"http://www.w3.org/1999/xhtml\"> - <head> - <title>%s</title> -<style type=\"text/css\"><!-- -body { font-family: outline-courier new; font-stretch: normal; font-weight: 500; font-style: normal; color: rgb(0, 0, 0); font-size: 10pt; text-decoration: none; } - --></style> -%s - </head> - <body>\n") - -(defvar hfyview-xhtml-footer "</body>\n</html>\n") - -(defun hfyview-wm-border-color () - "Return CSS code for color to use in window borders." - (or (hfy-triplet "SystemActiveTitle") - (hfy-triplet "blue"))) - -(defvar hfy-grabbed-echo-content nil) -(defvar hfy-grabbed-minibuffer-content nil) -(defvar hfyview-prompt-face nil) - -(defun hfyview-frame-minibuff (use-grabbed) - "Return html code for minibuffer. -If USE-GRABBED is non-nil use what has been grabbed by -`hfy-grab-echo-content' or `hfy-grab-minibuffer-content'. -Otherwise make a default content for the minibuffer." - (if (and use-grabbed - (or hfy-grabbed-echo-content - hfy-grabbed-minibuffer-content)) - (let* ((str (if hfy-grabbed-echo-content - hfy-grabbed-echo-content - hfy-grabbed-minibuffer-content)) - (tmpbuf (get-buffer-create "*hfy-minibuff-temp*")) - (hbuf (with-current-buffer tmpbuf - (let ((inhibit-read-only t)) - (erase-buffer) - ;; Fix-me: move the propertize to a new - ;; copy-buffer in hfy-fontify-buffer. Explained - ;; in mail to Vivek. - (insert (propertize str - 'read-only nil - 'intangible nil - 'field nil - 'modification-hooks nil - 'insert-in-front-hooks nil - 'insert-behind-hooks nil - 'point-entered nil - 'point-left nil - 'font-sticky nil - 'rear-nonsticky nil - )) - (htmlfontify-buffer)))) - bdy-start - bdy-end - bdy-txt - css-start - css-end - css-txt) - (with-current-buffer hbuf - (goto-char (point-min)) - (search-forward "<style type=\"text/css\"><!--") - (beginning-of-line) - (setq css-start (point)) - (search-forward "--></style>") - (setq css-end (point)) - (goto-char (point-min)) - (search-forward "<pre>") - (setq bdy-start (point)) - (goto-char (point-max)) - (search-backward "</pre>") - (setq bdy-end (point)) - (list (buffer-substring css-start css-end) - (buffer-substring bdy-start bdy-end)))) - (let ((mini-bg (face-attribute hfyview-prompt-face :background)) - (mini-fg (face-attribute hfyview-prompt-face :foreground))) - (if (eq mini-fg 'unspecified) - (setq mini-fg "") - (setq mini-fg (concat "color:" (hfy-triplet mini-fg) "; "))) - (if (eq mini-bg 'unspecified) - (setq mini-bg "") - (setq mini-bg (concat "background:" (hfy-triplet mini-bg) "; "))) - (list nil - (concat - "<span style=\"" mini-fg mini-bg "\">" - " M-x " - "</span>" - " " - "hfyview-frame" - ))))) - -(defun hfyview-frame-1(whole-buffers frame-title) - "Return buffer with html code for current frame. -If WHOLE-BUFFERS is non-nil then make scrollable buffers in the -html output. Otherwise just make html code for the currently -visible part of the buffers. - -FRAME-TITLE is the title to show on the resulting html page." - (let* ((wt (window-tree)) - (hfyview-selected-window (selected-window)) - (res (hfyview-fontify-tree (car wt) whole-buffers)) - (title-bg-color (hfyview-wm-border-color)) - (title-color (or (hfy-triplet "SystemHilightText") - "white")) - (title-style (concat (format "background-color:%s; color:%s;" title-bg-color title-color) - "border: none; padding:4px; vertical-align: middle;")) - (outbuf (get-buffer-create "frame")) - html - css - ;; (face-attribute 'minibuffer-prompt :foreground) - (hfyview-prompt-face (plist-get minibuffer-prompt-properties 'face)) - minibuf - (frame-width (* 0.56 (frame-width))) - table-style - (icon-file (expand-file-name "../etc/images/icons/emacs_16.png" exec-directory)) - (img-tag (if (file-exists-p icon-file) - (concat "<img src=\"file://" icon-file "\" height=\"16\" width=\"16\" />"))) - mini-css - mini-html - ) - (setq table-style - (format "border: solid %s; width:%sem;" - (hfyview-wm-border-color) - frame-width - )) - (setq minibuf (hfyview-frame-minibuff hfyview-frame-mode)) - (setq mini-css (nth 0 minibuf)) - (setq mini-html (nth 1 minibuf)) - (when (string= mini-html "") (setq mini-html " ")) - (setq res (hfyview-frame-to-html res)) - (setq html (nth 0 res)) - (setq css (nth 1 res)) - (with-current-buffer outbuf - ;;(lwarn t :warning "outbuf=%s" outbuf) - (erase-buffer) - (insert (format hfyview-xhtml-header - (concat "Emacs frame dump - " frame-title) - css) - (if mini-css mini-css "") - (format "<table border=\"0\" cellpadding=\"0\" cellspacing=\"0\" style=\"%s\">\n" table-style) - "<tr>\n" - (format "<td style=\"%s\">%s %s</td>\n" title-style img-tag - (hfyview-dekludge-string frame-title)) - "</tr>\n" - "<tr>\n" - html - "</tr>\n" - "<tr>\n" - "<td style=\"padding:1px;\">\n" - mini-html - "</td>\n" - "</tr>\n" - "</table>\n" - hfyview-xhtml-footer) - (browse-url-of-buffer) - outbuf))) - -(defun hfy-grab-echo-content () - "Return echo area content." - (setq hfy-grabbed-echo-content (current-message))) - -(defun hfy-grab-minibuffer-content () - "Return minibuffer content." - ;;(interactive) - (let* ((mw (minibuffer-window)) - (mb (window-buffer mw))) - (setq hfy-grabbed-minibuffer-content - (with-current-buffer mb - (buffer-substring - (point-min) (point-max))) - ))) - -;;(add-hook 'pre-command-hook 'grab-minibuffer-content nil t) -;;(remove-hook 'pre-command-hook 'grab-minibuffer-content) t) - -(provide 'hfyview) -;;; hfyview.el ends here diff --git a/emacs.d/nxhtml/util/hl-needed.el b/emacs.d/nxhtml/util/hl-needed.el deleted file mode 100644 index 7a160b6..0000000 --- a/emacs.d/nxhtml/util/hl-needed.el +++ /dev/null @@ -1,402 +0,0 @@ -;;; hl-needed.el --- Turn on highlighting of line and column when needed -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: Fri Nov 30 21:19:18 2007 -;; Version: 0.60 -;; Last-Updated: 2010-03-19 Fri -;; URL: http://www.emacswiki.org/cgi-bin/wiki/hl-needed.el -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; - ;; `hl-line', `vline'. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; This is yet another highlight line and/or column idea. The idea is -;; to try to show line and column only when it is probably most -;; needed. See `hl-needed-mode' for more info. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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: - -(require 'hl-line) -(require 'vline nil t) - -;;;###autoload -(defgroup hl-needed nil - "Customization group for `hl-needed-mode'." - :group 'convenience) - -(defcustom hl-needed-always nil - "Highlight always. -This is similar to turning on `vline-mode' and `hl-line-mode'" - :type 'boolean - :group 'hl-needed) - -(defcustom hl-needed-mark-line t - "Highlight line." - :type 'boolean - :group 'hl-needed) - -(defcustom hl-needed-mark-column t - "Highlight column." - :type 'boolean - :group 'hl-needed) - -(defcustom hl-needed-in-readonly-buffers nil - "Do not highlight in read-only buffers unless non-nil." - :type 'boolean - :group 'hl-needed) - -(defcustom hl-needed-not-in-modes - '(wab-compilation-mode - custom-mode) - "List of modes where highlighting should not be done." - :type '(repeat function) - :group 'hl-needed) - -;;(setq hl-needed-idle-time 5) -(defcustom hl-needed-idle-time 20 - "Highligh current line and/or column if Emacs is idle for more seconds. -If nil do not turn on `hl-line-mode' when Emacs is idle." - :type '(choice (const :tag "Don't turn on when Emacs is idle" nil) - (integer :tag "Turn on after (seconds)")) - :group 'hl-needed) - -(defcustom hl-needed-on-mouse t - "Highlight current line and/or column on clicks." - :type 'boolean - :group 'hl-needed) - -(defcustom hl-needed-on-new-window t - "Highlight current line and/or column on new window selection." - :type 'boolean - :group 'hl-needed) - -(defcustom hl-needed-on-new-buffer t - "Highlight current line and/or column on new buffer selection." - :type 'boolean - :group 'hl-needed) - -(defcustom hl-needed-on-config-change t - "Highlight current line and/or column on window conf change." - :type 'boolean - :group 'hl-needed) - -(defcustom hl-needed-on-scrolling t - "Highlight current line and/or column after scrolling." - :type 'boolean - :group 'hl-needed) - -(defvar hl-needed-face 'hl-needed-face) -(defface hl-needed-face - '((t (:inherit highlight))) - "Face for flashing." - :group 'hl-needed) - -(defcustom hl-needed-flash-delay 0.0 - "Time to wait before turning on flash highlighting. -If a key is pressed before this flash highlighting is not done." - :type 'float - :group 'hl-needed) - -(defcustom hl-needed-flash-duration 1.0 - "Turn off flash highlighting after this number of second. -Highlighting is turned off only if it was turned on because of -some change. It will not be turned off if it was turned on -because Emacs was idle for more than `hl-needed-idle-time'. - -The default time is choosen to not disturb too much. I believe -human short attention may often be of this time. \(Compare eye -contact time.)" - :type 'float - :group 'hl-needed) - -(defcustom hl-needed-currently-fun 'hl-needed-currently - "Function that checks if highlighting should be done. -The function should return nil if not needed and non-nil -otherwise." - :type 'function - :group 'hl-needed) - -(defvar hl-needed-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control ?c) ?? ??] 'hl-needed-show) - map)) - -;;;###autoload -(define-minor-mode hl-needed-mode - "Try to highlight current line and column when needed. -This is a global minor mode. It can operate in some different -ways: - -- Highlighting can be on always, see `hl-needed-always'. - -Or, it can be turned on depending on some conditions. In this -case highlighting is turned off after each command and turned on -again in the current window when either: - -- A new window was selected, see `hl-needed-on-new-window'. -- A new buffer was selected, see `hl-needed-on-new-buffer'. -- Window configuration was changed, see `hl-needed-on-config-change'. -- Buffer was scrolled see `hl-needed-on-scrolling'. -- A window was clicked with the mouse, see `hl-needed-on-mouse'. - -After this highlighting may be turned off again, normally after a -short delay, see `hl-needed-flash'. - -If either highlighting was not turned on or was turned off again -it will be turned on when - -- Emacs has been idle for `hl-needed-idle-time' seconds. - -See also `hl-needed-not-in-modes' and `hl-needed-currently-fun'. - -Note 1: For columns to be highlighted vline.el must be available. - -Note 2: This mode depends on `hl-line-mode' and `vline-mode' and -tries to cooperate with them. If you turn on either of these that -overrides the variables for turning on the respective -highlighting here." - :global t - :group 'hl-needed - ;;:keymap hl-needed-mode-map - (if hl-needed-mode - (progn - ;;(unless (memq major-mode hl-needed-not-in-modes) (setq hl-needed-window t)) - (when (featurep 'hl-needed) (hl-needed-show)) - (add-hook 'post-command-hook 'hl-needed-post-command) - (add-hook 'pre-command-hook 'hl-needed-pre-command) - (add-hook 'window-configuration-change-hook 'hl-needed-config-change) - ) - (remove-hook 'post-command-hook 'hl-needed-post-command) - (remove-hook 'pre-command-hook 'hl-needed-pre-command) - (remove-hook 'window-configuration-change-hook 'hl-needed-config-change) - (hl-needed-cancel-timer) - (hl-needed-cancel-flash-timer) - (hl-needed-hide))) - -(defvar hl-needed-timer nil) -(defvar hl-needed-flash-timer nil) -(defvar hl-needed-window nil) -(defvar hl-needed-buffer nil) -(defvar hl-needed-window-start nil) -(defvar hl-needed-flash-this nil) -(defvar hl-needed-config-change nil) - -(defvar hl-needed-old-blink nil) -(defun hl-needed-show () - "Highlight current line and/or column now." - (interactive) - (when (with-no-warnings (called-interactively-p)) - (setq hl-needed-flash-this nil) - (unless hl-needed-mode - (message "Use hl-needed-hide to remove highlighting"))) - (setq hl-needed-old-blink nil) ;; So blink is not turned on by hl-needed-hide - (hl-needed-hide) - (unless (active-minibuffer-window) - (setq hl-needed-old-blink blink-cursor-mode) - (when blink-cursor-mode - (blink-cursor-mode -1) - ;;(when (timerp blink-cursor-timer) (cancel-timer blink-cursor-timer)) - (blink-cursor-end) - ) - (unless hl-line-mode - (when hl-needed-mark-line - (let ((hl-line-mode t) - (hl-line-sticky-flag nil) - (hl-line-face hl-needed-face)) - (hl-line-highlight)))) - (unless vline-mode - (when hl-needed-mark-column - (when (featurep 'vline) - (let ((vline-style 'face) - (vline-face hl-line-face) - (vline-current-window-only t)) - (vline-show))))))) - -(defun hl-needed-hide () - (interactive) - (when (and hl-needed-old-blink - (not blink-cursor-mode)) - (blink-cursor-mode 1)) - (setq hl-needed-old-blink nil) - (unless hl-line-mode - (hl-line-unhighlight)) - (when (featurep 'vline) - (unless vline-mode - (vline-clear)))) - -(defun hl-needed-cancel-timer () - (when (timerp hl-needed-timer) (cancel-timer hl-needed-timer)) - (setq hl-needed-timer nil)) - -(defun hl-needed-start-timer (wait) - (hl-needed-cancel-timer) - (setq hl-needed-timer - (run-with-idle-timer wait - nil 'hl-needed-show-in-timer))) - -(defun hl-needed-show-in-timer () - "Turn on with special error handling. -Erros may go unnoticed in timers. This should prevent it." - (condition-case err - (save-match-data ;; runs in timer - (hl-needed-show)) - (error - (lwarn 'hl-needed-show - :error "%s" (error-message-string err))))) - -(defun hl-needed-hide-in-timer () - "Turn off with special error handling. -Erros may go unnoticed in timers. This should prevent it." - (condition-case err - (unless hl-needed-always - (hl-needed-hide)) - (error - (lwarn 'hl-needed-hide - :error "%s" (error-message-string err))))) - -(defun hl-needed-hide-flash-in-timer () - "Turn off with special error handling. -Erros may go unnoticed in timers. This should prevent it." - (condition-case err - (unless hl-needed-always - (hl-needed-hide) - (hl-needed-start-timer hl-needed-idle-time)) - (error - (lwarn 'hl-needed-hide - :error "%s" (error-message-string err))))) - -(defun hl-needed-currently () - "Check if `hl-line-mode' is needed in buffer." - ;; Check for change of buffer and window - (if hl-needed-always - t - (unless (or (memq major-mode hl-needed-not-in-modes) - isearch-mode - (and buffer-read-only - (not hl-needed-in-readonly-buffers))) - (or (and hl-needed-on-new-window - (not (eq hl-needed-window (selected-window)))) - ;;(progn (message "here1") nil) - (and hl-needed-on-new-buffer - (not (eq hl-needed-buffer (current-buffer)))) - ;;(progn (message "here2") nil) - (and hl-needed-on-config-change - hl-needed-config-change) - ;;(progn (message "here3") nil) - (and hl-needed-on-mouse - (listp last-input-event) - (memq (car last-input-event) '(mouse-1 mouse-2 mouse-3))) - ;;(progn (message "here4") nil) - (and hl-needed-on-scrolling - (and (not (eq hl-needed-window-start (window-start))) - (< 1 - (abs - (- (line-number-at-pos hl-needed-window-start) - (line-number-at-pos (window-start))))))))))) - -(defun hl-needed-cancel-flash-timer () - (when (timerp hl-needed-flash-timer) (cancel-timer hl-needed-flash-timer)) - (setq hl-needed-flash-timer nil)) - -(defun hl-needed-start-maybe-flash-timer () - (when (and hl-needed-flash-this - (not hl-needed-always)) - (hl-needed-cancel-flash-timer) - (setq hl-needed-flash-timer - (run-with-timer (+ hl-needed-flash-delay hl-needed-flash-duration) - nil 'hl-needed-hide-flash-in-timer)))) - -(defvar hl-needed-pre-command-time (current-time)) - -(defun hl-needed-check () - ;; Cancel `hl-line-mode' and timer - (unless (active-minibuffer-window) - (if (funcall hl-needed-currently-fun) - (progn - ;; Some time calc for things that pause to show us where we are: - (let* ((time-pre hl-needed-pre-command-time) - (time-now (current-time)) - (pre (+ (nth 1 time-pre) (* 0.0000001 (nth 2 time-pre)))) - (now (+ (nth 1 time-now) (* 0.0000001 (nth 2 time-now))))) - (if (< 1 (- now pre)) ;; Fix-me: option? - nil ;; Don't show anything here, it just disturbs - ;;(hl-needed-show) - (hl-needed-start-timer hl-needed-flash-delay) - (hl-needed-start-maybe-flash-timer)))) - ;; Submit an idle timer that can turn highlighting on. - (hl-needed-start-timer hl-needed-idle-time))) - (setq hl-needed-config-change nil) - (unless (active-minibuffer-window) - (setq hl-needed-window (selected-window)) - (setq hl-needed-buffer (current-buffer)) - (setq hl-needed-window-start (window-start)))) - -(defvar hl-needed-after-active-minibuffer nil) - -(defun hl-needed-pre-command () - ;;(message "active-minibuffer-window=%s" (active-minibuffer-window)) - (setq hl-needed-after-active-minibuffer (active-minibuffer-window)) - (condition-case err - (progn - (hl-needed-cancel-timer) - (hl-needed-cancel-flash-timer) - (hl-needed-hide) - (setq hl-needed-flash-this hl-needed-flash-duration) - (setq hl-needed-pre-command-time (current-time))) - (error - (message "hl-needed-pre-command error: %s" err)))) - -(defun hl-needed-post-command () - (condition-case err - (if (eq last-command 'keyboard-quit) - (hl-needed-hide) - (hl-needed-check)) - (error - (message "hl-needed-post-command error: %s" err)))) - -(defvar hl-needed-minibuffer-active nil) - -(defun hl-needed-config-change () - (condition-case err - (if (active-minibuffer-window) - (setq hl-needed-minibuffer-active t) - ;; Changing buffer in the echo area is a config change. Catch this: - (setq hl-needed-config-change (not hl-needed-after-active-minibuffer)) - (setq hl-needed-after-active-minibuffer nil) - (setq hl-needed-minibuffer-active nil)) - (error - (message "hl-needed-config-change error: %s" err)))) - -(provide 'hl-needed) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; hl-needed.el ends here diff --git a/emacs.d/nxhtml/util/html-write.el b/emacs.d/nxhtml/util/html-write.el deleted file mode 100644 index c7a7c76..0000000 --- a/emacs.d/nxhtml/util/html-write.el +++ /dev/null @@ -1,455 +0,0 @@ -;;; html-write.el --- Hide some tags for writing text in XHTML -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-10-03T01:29:44+0200 Thu -(defconst html-write:version "0.6") ;; Version: -;; Last-Updated: 2009-08-11 Tue -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; The minor mode `html-write-mode' displays simple tags like <i>, -;; <b>, <em>, <strong> or <a> with appropriate faces (for example bold -;; and italic) instead of displaying the tags. -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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: - -;; Silence byte compiler -(defvar jit-lock-start) -(defvar jit-lock-end) - -(eval-when-compile (require 'mumamo)) ;; Just for the defmacro ... -(eval-when-compile (require 'mlinks nil t)) - -;;;###autoload -(defgroup html-write nil - "Customization group for html-write." - :group 'nxhtml - :group 'convenience) - -(defface html-write-base - '((t (:inherit font-lock-type-face))) - "Face from which other faces inherits." - :group 'html-write) - -(defface html-write-em - '((t (:inherit html-write-base :slant italic))) - "Face used for <em> tags." - :group 'html-write) - -(defface html-write-strong - '((t (:inherit html-write-base :weight bold))) - "Face used for <strong> tags." - :group 'html-write) - -(defface html-write-link - '((t (:inherit html-write-base :underline t))) - "Face used for <a> tags." - :group 'html-write) - -(defconst html-write-tag-list - '(("i" html-write-em-tag-actions) - ("b" html-write-strong-tag-actions) - ("em" html-write-em-tag-actions) - ("strong" html-write-strong-tag-actions) - ("a" html-write-a-tag-actions) - ;;("img" html-write-img-tag-actions t) - ) - "List of tags that should be hidden. -A record in the list has the format - - \(TAG HANDLE [SINGLE]) - -where -- TAG is the tag name string. - -- HANDLE is a function to call when hiding the tag. It takes - three parameters, TAG-BEGIN, TAG-END and OVERLAY. TAG-BEGIN - and TAG-END are start and end of the start tag. OVERLAY is an - overlay used for faces, keymaps etc that covers the whole tag." - ) - -(defun html-write-em-tag-actions (tag-begin tag-end overlay) - "Do actions for <em> tags for tag between TAG-BEGIN and TAG-END. -OVERLAY is the overlay added by `html-write-mode' for this tag." - (overlay-put overlay 'face 'html-write-em)) - -(defun html-write-strong-tag-actions (tag-begin tag-end overlay) - "Do actions for <strong> tags for tag between TAG-BEGIN and TAG-END. -OVERLAY is the overlay added by `html-write-mode' for this tag." - (overlay-put overlay 'face 'html-write-strong)) - -;; Fix-me -(defun html-write-img-tag-actions (tag-begin tag-end overlay) - "Do actions for <img> tags for tag between TAG-BEGIN and TAG-END. -OVERLAY is the overlay added by `html-write-mode' for this tag." - (save-match-data - (let ((here (point-marker)) - href) - (save-restriction - (narrow-to-region tag-begin tag-end) - (goto-char tag-begin) - (when (looking-at (rx (*? anything) - (1+ space) - "src=\"" - (submatch - (+ (not (any "\"\n")))) - "\"")) - (setq href (match-string-no-properties 1)))) - (when href - (overlay-put overlay 'display (concat "image " href)) - (overlay-put overlay 'html-write-url href)) - (goto-char (point))))) - -(defun html-write-point-entered-echo (left entered) - (let ((msg (get-char-property entered 'help-echo))) - (when msg (message "%s" msg)))) - -(defun html-write-a-tag-actions (tag-begin tag-end overlay) - "Do actions for <a> tags for tag between TAG-BEGIN and TAG-END. -OVERLAY is the overlay added by `html-write-mode' for this tag." - (save-match-data - (let ((here (point-marker)) - href) - (save-restriction - (narrow-to-region tag-begin tag-end) - (goto-char tag-begin) - (when (looking-at (rx (*? anything) - (1+ space) - "href=\"" - (submatch - (+ (not (any "\"\n")))) - "\"")) - (setq href (match-string-no-properties 1)))) - (when href - (overlay-put overlay 'face 'html-write-link) - (overlay-put overlay 'help-echo href) - ;; Fix-me: Seems like point-entered must be a text prop - (overlay-put overlay 'point-entered 'html-write-point-entered-echo) - (overlay-put overlay 'mouse-face 'highlight) - (if (eq ?# (string-to-char href)) - (setq href (concat "file:///" buffer-file-name href)) - (when (file-exists-p href) - (setq href (expand-file-name href)))) - (overlay-put overlay 'html-write-url href)) - (goto-char (point))))) - -(defun html-write-get-tag-ovl () - "Get tag overlay at current point." - (catch 'ranges - (dolist (ovl (overlays-at (point))) - (let ((ranges (overlay-get ovl 'html-write))) - (when ranges - (throw 'ranges ovl)))))) - -(defun html-write-toggle-current-tag () - "Toggle display of tag at current point." - (interactive) - (let* ((ovl (html-write-get-tag-ovl)) - (hiding-ranges (overlay-get ovl 'html-write)) - (invis (get-text-property (caar hiding-ranges) 'invisible)) - (ovl-start (overlay-start ovl)) - (ovl-end (overlay-end ovl))) - (if invis - (progn - (overlay-put ovl 'html-face (overlay-get ovl 'face)) - (overlay-put ovl 'face 'highlight) - (dolist (range hiding-ranges) - (let ((start (car range)) - (end (cdr range))) - (mumamo-with-buffer-prepared-for-jit-lock - (put-text-property start end 'invisible nil))))) - (delete-overlay ovl) - (html-write-hide-tags ovl-start ovl-end)))) - -(defun html-write-browse-link () - "Browse link in current tag." - (interactive) - (let* ((ovl (html-write-get-tag-ovl)) - (url (overlay-get ovl 'html-write-url))) - (unless url - (error "No link in this tag")) - (browse-url url) - )) - -(defvar html-write-keymap - (let ((map (make-sparse-keymap)) - keys) - (define-key map [(control ?c) ?+] 'html-write-toggle-current-tag) - (define-key map [(control ?c) ?!] 'html-write-browse-link) - (define-key map [mouse-1] 'html-write-browse-link) - (when (featurep 'mlinks) - (setq keys (where-is-internal 'mlinks-goto mlinks-mode-map)) - (dolist (key keys) - (define-key map key 'html-write-mlinks-goto)) - (setq keys (where-is-internal 'mlinks-goto-other-window mlinks-mode-map)) - (dolist (key keys) - (define-key map key 'html-write-mlinks-goto-other-window)) - (setq keys (where-is-internal 'mlinks-goto-other-frame mlinks-mode-map)) - (dolist (key keys) - (define-key map key 'html-write-mlinks-goto-other-frame)) - ) - map)) - -(defun html-write-mlinks-goto () - "Goto link." - (interactive) - (html-write-mlinks-goto-1 'mlinks-goto)) - -(defun html-write-mlinks-goto-other-window () - "Goto link in other window." - (interactive) - (html-write-mlinks-goto-1 'mlinks-goto-other-window)) - -(defun html-write-mlinks-goto-other-frame () - "Goto link in other frame." - (interactive) - (html-write-mlinks-goto-1 'mlinks-goto-other-frame)) - -(defun html-write-mlinks-goto-1 (goto-fun) - (let* ((ovl (html-write-get-tag-ovl)) - (ovl-start (overlay-start ovl)) - (ovl-end (overlay-end ovl)) - (here (point-marker))) - (goto-char ovl-start) - (skip-chars-forward "^\"" ovl-end) - (forward-char) - (unless (funcall goto-fun) (goto-char here)) - )) - -;;(html-write-make-hide-tags-regexp) -(defun html-write-make-hide-tags-regexp () - "Make regexp used for finding tags to hide." - ;; fix-me: single tags. Fix-me: what did I mean??? Maybe < etc... - (let ((tags-re - (mapconcat 'identity - (mapcar (lambda (elt) - (if (stringp elt) - elt - (car elt))) - html-write-tag-list) - "\\|"))) - (concat - "<\\(?1:" - "\\(?:" tags-re "\\)" - "\\)[^>]*>\\(?3:[^<]*\\)\\(?2:</\\1>\\)" - ))) - -(defvar html-write-pending-changes nil) -(make-variable-buffer-local 'html-write-pending-changes) -(put 'html-write-pending-changes 'permanent-local t) - - -(defun html-write-hide-tags (start end) - "Hide tags matching `html-write-tag-list' between START and END." - ;;(message "html-write-hide-tags %s %s" start end) - (let ((here (point-marker)) - (buffer-name (buffer-file-name)) - (dbg nil)) - (save-restriction - (widen) - (goto-char start) - (save-match-data - (let ((hide-tags-regexp (html-write-make-hide-tags-regexp))) - (when dbg (message "before search start=%s end=%s, point=%s" start end (point))) - (while (re-search-forward hide-tags-regexp end t) - (let* ((ovl (make-overlay (match-beginning 0) (match-end 0) - nil t nil)) - (tag-fun (cadr (assoc (match-string-no-properties 1) - html-write-tag-list))) - hiding-ranges) - ;;(overlay-put ovl 'face 'font-lock-variable-name-face) - (overlay-put ovl 'keymap html-write-keymap) - (setq hiding-ranges - (list (cons (1- (match-beginning 1)) (match-beginning 3)) - (cons (match-beginning 2) (match-end 2)))) - (overlay-put ovl 'html-write hiding-ranges) - (mumamo-with-buffer-prepared-for-jit-lock - (dolist (range hiding-ranges) - (let ((start (car range)) - (end (cdr range))) - (put-text-property start end 'invisible 'html-write) - ;; Fix-me: more careful rear-nonsticky? - (put-text-property (1- end) end - 'rear-nonsticky '(invisible))))) - ;; Let tag-fun override - (when tag-fun - (funcall tag-fun (match-end 1) (match-beginning 3) ovl)) - ))))) - (goto-char here))) - -(defun html-write-reveal-tags (start end) - "Reveal tags between START and END." - (let ((here (point-marker))) - (save-restriction - (widen) - (goto-char (point-min)) - (save-match-data - (mumamo-with-buffer-prepared-for-jit-lock - (remove-text-properties start - end - '(invisible html-write)) - (dolist (ovl (overlays-in start end)) - (when (overlay-get ovl 'html-write) - (let ((end (overlay-end ovl))) - (remove-list-of-text-properties (1- end) end '(rear-nonsticky)) - (delete-overlay ovl))))))) - (goto-char here))) - -;;;###autoload -(define-minor-mode html-write-mode - "Minor mode for convenient display of some HTML tags. -When this mode is on a tag in `html-write-tag-list' is displayed as -the inner text of the tag with a face corresponding to the tag. -By default for example <i>...</i> is displayed as italic and -<a>...</a> is displayed as an underlined clickable link. - -Only non-nested tags are hidden. The idea is just that it should -be easier to read and write, not that it should look as html -rendered text. - -See the customization group `html-write' for more information about -faces. - -The following keys are defined when you are on a tag handled by -this minor mode: - -\\{html-write-keymap} - -IMPORTANT: Most commands you use works also on the text that is -hidden. The movement commands is an exception, but as soon as -you edit the buffer you may also change the hidden parts. - -Hint: Together with `wrap-to-fill-column-mode' this can make it -easier to see what text you are actually writing in html parts of -a web file." - :group 'html-write - (if t - (if html-write-mode - (html-write-font-lock t) - (html-write-font-lock nil) - (save-restriction - (widen) - (html-write-reveal-tags (point-min) (point-max)))))) -(put html-write-mode 'permanent-local t) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Font lock - -(defun html-write-jit-extend-after-change (start end old-len) - "For JIT lock extending. -Should be on `jit-lock-after-change-extend-region-functions'. - -START, END and OLD-LEN are the parameters from after change." - (let ((our-ovls nil)) - (dolist (ovl (append (overlays-in start end) - (overlays-at start) - nil)) - ;; Leave the overlays until re-fontification time, but note their extent. - (when (overlay-get ovl 'html-write) - (setq jit-lock-start (min jit-lock-start (overlay-start ovl))) - (setq jit-lock-end (max jit-lock-end (overlay-end ovl))))))) - - -(defun html-write-fontify (bound) - ;;(message "html-write-fontify %s" bound) - (let (tag-ovl) - ;;(save-match-data - (let* ((hide-tags-regexp (html-write-make-hide-tags-regexp)) - (next-tag (re-search-forward hide-tags-regexp bound t)) - (tag-beg (when next-tag (match-beginning 0))) - (tag-end (when next-tag (match-end 0))) - (tag-nam (when next-tag (match-string-no-properties 1))) - (tag-fun (when next-tag (cadr (assoc tag-nam html-write-tag-list)))) - tag-hid - (old-start (next-single-char-property-change (max (point-min) (1- (point))) 'html-write nil bound))) - ;;(message "here a old-start=%s, tag-beg/end=%s/%s" old-start tag-beg tag-end) - (setq tag-ovl (when next-tag (make-overlay tag-beg tag-end))) - (when old-start - ;; Fix-me: maybe valid, perhaps better keep it then? - (let ((ovl (catch 'ovl - (dolist (o (append (overlays-at old-start) - (overlays-in old-start (1+ old-start)) - nil)) - (when (overlay-get o 'html-write) - (throw 'ovl o)))))) - (when ovl ;; fix-me: there should be one... - ;;(message "here b") - (mumamo-with-buffer-prepared-for-jit-lock - (remove-list-of-text-properties (overlay-start ovl) (overlay-end ovl) '(invisible html-write))) - (delete-overlay ovl)))) - ;;(html-write-hide-tags start end) - ;;(message "here d, tag-ovl=%s" tag-ovl) - (when tag-ovl - (overlay-put tag-ovl 'face 'font-lock-variable-name-face) - (overlay-put tag-ovl 'keymap html-write-keymap) - (setq tag-hid - (list (cons (1- (match-beginning 1)) (match-beginning 3)) - (cons (match-beginning 2) (match-end 2)))) - (overlay-put tag-ovl 'html-write tag-hid) - (when tag-fun - (funcall tag-fun (match-end 1) (match-beginning 3) tag-ovl)) - (mumamo-with-buffer-prepared-for-jit-lock - (dolist (range tag-hid) - (let ((start (car range)) - (end (cdr range))) - (put-text-property start end 'invisible 'html-write) - ;;(put-text-property start end 'html-write t) - ;; Fix-me: more careful rear-nonsticky? - (put-text-property (1- end) end - 'rear-nonsticky '(invisible))))))) - ;;) - (when tag-ovl - (set-match-data (list (copy-marker (overlay-start tag-ovl)) - (copy-marker (overlay-end tag-ovl)))) - (goto-char (1+ (overlay-end tag-ovl))) - t))) - -(defun html-write-font-lock (on) - ;; See mlinks.el - (let* ((add-or-remove (if on 'font-lock-add-keywords 'font-lock-remove-keywords)) - (fontify-fun 'html-write-fontify) - (args (list nil `(( ,fontify-fun ( 0 'html-write-base t )))))) - (when fontify-fun - (when on (setq args (append args (list t)))) - (apply add-or-remove args) - (font-lock-mode -1) - (font-lock-mode 1) - ))) - -(provide 'html-write) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; html-write.el ends here diff --git a/emacs.d/nxhtml/util/idn.el b/emacs.d/nxhtml/util/idn.el deleted file mode 100644 index 21f7a4c..0000000 --- a/emacs.d/nxhtml/util/idn.el +++ /dev/null @@ -1,151 +0,0 @@ -;;; idn.el --- Recommended Identifier Profiles for IDN -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2010-03-24 Wed -;; Version: 0.1 -;; Last-Updated: 2010-03-26 Fri -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; - ;; `nxhtml-base'. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Functions for handling IDN chars defined by -;; `http://www.unicode.org/reports/tr39/'. -;; -;; See `idn-is-recommended'. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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, 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: - -;; Fix-me: You have to change this if you are not using nXhtml: -(require 'nxhtml-base) -(defvar uts39-datadir (expand-file-name "etc/uts39/" nxhtml-install-dir)) - -(defun idn-init (bv) - (save-match-data - (let* ((idnchars-file (expand-file-name "idnchars.txt" uts39-datadir)) - (idnchars-old (find-buffer-visiting idnchars-file)) - (idnchars-buf (or idnchars-old - (if (not (file-exists-p idnchars-file)) - (message "Can't find file %S" idnchars-file) - (find-file-noselect idnchars-file)))) - here - (range-patt (rx bol - (group (repeat 4 (any xdigit))) - (optional ".." - (group (repeat 4 (any xdigit)))))) - (num-idn 0)) - (when idnchars-buf - (with-current-buffer idnchars-buf - (setq here (point)) - (save-restriction - (widen) - (goto-char (point-min)) - (while (re-search-forward range-patt nil t) - (let* ((str-beg (match-string 0)) - (str-end (match-string 2)) - (beg (string-to-number str-beg 16)) - (end (or (when str-end (string-to-number str-end 16)) - beg))) - ;;(message "str-beg=%S str-end=%S" str-beg str-end) - (dotimes (ii (1+ (- end beg))) - (let ((num (+ ii beg))) - ;;(message "setting idn-char %s #%4x" num num) - (setq num-idn (1+ num-idn)) - (aset bv num t)))))) - (goto-char here)) - (unless idnchars-old (kill-buffer idnchars-buf)) - (message "Found %d IDN chars" num-idn) - t)))) - -(defconst idn-char-vector - (let ((bv (make-bool-vector (* 256 256) nil))) - (when (idn-init bv) - ;; (string-to-number "002D" 16) - ;; Make a quick sanity check: - (unless (and (not (aref bv 44)) - (aref bv 45)) - (message "idn-char-vector: Bad idn data in file idnchars.txt")) - bv)) - "Boolean vector with recommended IDN chars.") - - -;;(idn-is-recommended 0) -;;(idn-is-recommended 65535) -(defsubst idn-is-recommended (char) - "Return t if character CHAR is a recommended IDN char. -See URL `http://www.unicode.org/reports/tr39/'. - -Data is initialized from the file idnchars.txt in the directory -`uts39-datadir'. This file is fetched from the above URL." - (aref idn-char-vector char)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Below are some help functions that can be commented out. - -;;(global-set-key [f9] 'idn-char-at-point) -(defun idn-char-at-point (pos) - "Tell if char at POS is an recommended IDN char. -Default POS is current point." - (interactive "d") - (let* ((this-char (char-after pos)) - (recommended (idn-is-recommended this-char))) - (message "IDN char at point: %s (#%000x)" recommended this-char))) - -(defun idn-list-chars () - "Show all IDN chars. -For more info see `idn-is-recommended'. - -Note: This may crash Emacs currently, at least on w32." - (interactive) - (with-output-to-temp-buffer (help-buffer) - (help-setup-xref (list #'idn-list-chars) (interactive-p)) - (with-current-buffer (help-buffer) - (insert - "Recommended Identifier Characters for IDN:\n\n") - (let ((col 0) - (cnt 0)) - (dotimes (nn (length idn-char-vector)) - (when (aref idn-char-vector nn) - (setq cnt (1+ cnt)) - (setq col (mod (1+ col) 20)) - (when (= col 0) (insert "\n ")) - (insert " " (char-to-string nn)))) - (insert "\n\n" - (format "There were %d IDN chars defined in `idn-char-vector'." cnt)) - )))) - -(provide 'idn) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; idn.el ends here diff --git a/emacs.d/nxhtml/util/inlimg.el b/emacs.d/nxhtml/util/inlimg.el deleted file mode 100644 index 9b07fb3..0000000 --- a/emacs.d/nxhtml/util/inlimg.el +++ /dev/null @@ -1,429 +0,0 @@ -;;; inlimg.el --- Display images inline -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-09-27 -(defconst inlimg:version "0.7") ;; Version: -;; Last-Updated: 2009-07-14 Tue -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Display images inline. See `inlimg-mode' for more information. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'cl)) -(eval-when-compile (require 'mumamo nil t)) -(eval-when-compile (require 'ourcomments-util nil t)) - -(defvar inlimg-assoc-ext - '((png (".png")) - (gif (".gif")) - (tiff (".tiff")) - (jpeg (".jpg" ".jpeg")) - (xpm (".xpm")) - (xbm (".xbm")) - (pbm (".pbm")))) - -(defvar inlimg-img-regexp nil) -(make-variable-buffer-local 'inlimg-img-regexp) -(put 'inlimg-img-regexp 'permanent-local t) - -(defvar inlimg-img-regexp-html - (rx (or (and "<img" - (1+ space) - (0+ (1+ (not (any " <>"))) - (1+ space)) - "src=\"" - (group (1+ (not (any "\"")))) - "\"" - (*? anything) - "/>") - (and "url(" - ?\" - (group (1+ (not (any "\)")))) - ?\" - ")" - ) - (and "url(" - (group (+? (not (any ")")))) - ")" - ) - ))) - -(defvar inlimg-img-regexp-org - (rx-to-string - `(and "[[file:" - (group (+? (not (any "\]"))) - ,(let ((types nil)) - (dolist (typ image-types) - (when (image-type-available-p typ) - (dolist (ext (cadr (assoc typ inlimg-assoc-ext))) - (setq types (cons ext types))))) - (cons 'or types))) - "]" - (optional "[" - (+? (not (any "\]"))) - "]") - "]" - ))) - -(defconst inlimg-modes-img-values - '( - (html-mode inlimg-img-regexp-html) - (org-mode inlimg-img-regexp-org) - )) - -(defun inlimg-img-spec-p (spec) - (assoc spec inlimg-modes-img-values)) - -;;;###autoload -(defgroup inlimg nil - "Customization group for inlimg." - :group 'nxhtml) - -(defcustom inlimg-margins '(50 . 5) - "Margins when displaying image." - :type '(cons (integer :tag "Left margin") - (integer :tag "Top margin")) - :set (lambda (sym val) - (set-default sym val) - (when (fboundp 'inlimg-update-all-buffers) - (inlimg-update-all-buffers))) - :group 'inlimg) - -(defcustom inlimg-slice '(0 0 400 100) - "How to slice images." - :type '(choice (const :tag "Show whole images" nil) - (list :tag "Show slice of image" - (integer :tag "Top") - (integer :tag "Left") - (integer :tag "Width") - (integer :tag "Height"))) - :set (lambda (sym val) - (set-default sym val) - (when (fboundp 'inlimg-update-all-buffers) - (inlimg-update-all-buffers))) - :group 'inlimg) - -(define-widget 'inlimg-spec-widget 'symbol - "An inline image specification." - :complete-function (lambda () - (interactive) - (lisp-complete-symbol 'inlimg-img-spec-p)) - :prompt-match 'inlimg-img-spec-p - :prompt-history 'widget-function-prompt-value-history - :match-alternatives '(inlimg-img-spec-p) - :validate (lambda (widget) - (unless (inlimg-img-spec-p (widget-value widget)) - (widget-put widget :error (format "Invalid function: %S" - (widget-value widget))) - widget)) - :value 'org-mode - :tag "Inlimg image values spec name") - -;; (customize-option 'inlimg-mode-specs) -(defcustom inlimg-mode-specs - '( - (xml-mode html-mode) - (sgml-mode html-mode) - (nxml-mode html-mode) - (php-mode html-mode) - (css-mode html-mode) - ) - "Equivalent mode for image tag search. -Note that derived modes \(see info) are recognized by default. - -To add new image tag patterns modify `inlimg-modes-img-values'." - :type '(repeat - (list (major-mode-function :tag "Major mode") - (inlimg-spec-widget :tag "Use tags as specified in"))) - :group 'inlimg) - -(defface inlimg-img-tag '((t :inherit 'lazy-highlight)) - "Face added to img tag when displaying image." - :group 'inlimg) - -(defface inlimg-img-remote '((t :inherit 'isearch-fail)) - "Face used for notes telling image is remote." - :group 'inlimg) - -(defface inlimg-img-missing '((t :inherit 'trailing-whitespace)) - "Face used for notes telling image is missing." - :group 'inlimg) - -(defvar inlimg-img-keymap - (let ((map (make-sparse-keymap))) - (define-key map [(control ?c) ?+] 'inlimg-toggle-display) - (define-key map [(control ?c) ?%] 'inlimg-toggle-slicing) - map) - "Keymap on image overlay.") - -(eval-after-load 'gimp - '(gimp-add-point-bindings inlimg-img-keymap)) - -(defsubst inlimg-ovl-p (ovl) - "Return non-nil if OVL is an inlimg image overlay." - (overlay-get ovl 'inlimg-img)) - -(defun inlimg-ovl-valid-p (ovl) - (and (overlay-get ovl 'inlimg-img) - inlimg-img-regexp - (save-match-data - (let ((here (point))) - (goto-char (overlay-start ovl)) - (prog1 - (looking-at (symbol-value inlimg-img-regexp)) - (goto-char here)))))) - -(defun inlimg-next (pt display-image) - "Display or hide next image after point PT. -If DISPLAY-IMAGE is non-nil then display image, otherwise hide it. - -Return non-nil if an img tag was found." - (when inlimg-img-regexp - (let (src dir beg end img ovl remote beg-face) - (goto-char pt) - (save-match-data - (when (re-search-forward (symbol-value inlimg-img-regexp) nil t) - (setq src (or (match-string-no-properties 1) - (match-string-no-properties 2) - (match-string-no-properties 3))) - (setq beg (match-beginning 0)) - (setq beg-face (get-text-property beg 'face)) - (setq remote (string-match "^https?://" src)) - (setq end (- (line-end-position) 0)) - (setq ovl (catch 'old-ovl - (dolist (ovl (overlays-at beg)) - (when (inlimg-ovl-p ovl) - (throw 'old-ovl ovl))) - nil)) - (unless ovl - (setq ovl (make-overlay beg end)) - (overlay-put ovl 'inlimg-img t) - (overlay-put ovl 'priority 100) - (overlay-put ovl 'face 'inlimg-img-tag) - (overlay-put ovl 'keymap inlimg-img-keymap)) - (overlay-put ovl 'image-file src) - (overlay-put ovl 'inlimg-slice inlimg-slice) - (if display-image - (unless (memq beg-face '(font-lock-comment-face font-lock-string-face)) - (unless remote - (setq dir (if (buffer-file-name) - (file-name-directory (buffer-file-name)) - default-directory)) - (setq src (expand-file-name src dir))) - (if (or remote (not (file-exists-p src))) - (setq img (propertize - (if remote " Image is on the web " " Image not found ") - 'face (if remote 'inlimg-img-remote 'inlimg-img-missing))) - (setq img (create-image src nil nil - :relief 5 - :margin inlimg-margins)) - (setq img (inlimg-slice-img img inlimg-slice))) - (let ((str (copy-sequence "\nX"))) - (setq str (propertize str 'face 'inlimg-img-tag)) - (put-text-property 1 2 'display img str) - (overlay-put ovl 'after-string str))) - (overlay-put ovl 'after-string nil)))) - ovl))) - -(defun inlimg-slice-img (img slice) - (if (not slice) - img - (let* ((sizes (image-size img t)) - (width (car sizes)) - (height (cdr sizes)) - (sl-left (nth 0 slice)) - (sl-top (nth 1 slice)) - (sl-width (nth 2 slice)) - (sl-height (nth 3 slice))) - (when (> sl-left width) (setq sl-left 0)) - (when (> (+ sl-left sl-width) width) (setq sl-width (- width sl-left))) - (when (> sl-top height) (setq sl-top 0)) - (when (> (+ sl-top sl-height) height) (setq sl-height (- height sl-top))) - (setq img (list img)) - (setq img (cons (append '(slice) - slice - (list sl-top sl-left sl-width sl-height) - nil) - img))))) - -;;;###autoload -(define-minor-mode inlimg-mode - "Display images inline. -Search buffer for image tags. Display found images. - -Image tags are setup per major mode in `inlimg-mode-specs'. - -Images are displayed on a line below the tag referencing them. -The whole image or a slice of it may be displayed, see -`inlimg-slice'. Margins relative text are specified in -`inlimg-margins'. - -See also the commands `inlimg-toggle-display' and -`inlimg-toggle-slicing'. - -Note: This minor mode uses `font-lock-mode'." - :keymap nil - :group 'inlimg - (if inlimg-mode - (progn - (let ((major-mode (or (and (boundp 'mumamo-multi-major-mode) - mumamo-multi-major-mode - (fboundp 'mumamo-main-major-mode) - (mumamo-main-major-mode)) - major-mode))) - (inlimg-get-buffer-img-values) - (unless inlimg-img-regexp - (message "inlim-mode: No image spec, can't do anything")) - (add-hook 'font-lock-mode-hook 'inlimg-on-font-lock-off)) - (inlimg-font-lock t)) - (inlimg-font-lock nil) - (inlimg-delete-overlays))) -(put 'inlimg-mode 'permanent-local t) - -(defun inlimg-delete-overlays () - (save-restriction - (widen) - (let (ovl) - (dolist (ovl (overlays-in (point-min) (point-max))) - (when (inlimg-ovl-p ovl) - (delete-overlay ovl)))))) - -(defun inlimg-get-buffer-img-values () - (let* (rec - (spec (or (catch 'spec - (dolist (rec inlimg-mode-specs) - (when (derived-mode-p (car rec)) - (throw 'spec (nth 1 rec))))) - major-mode)) - (values (when spec (nth 1 (assoc spec inlimg-modes-img-values)))) - ) - (setq inlimg-img-regexp values) - )) - -(defun inlimg--global-turn-on () - (inlimg-get-buffer-img-values) - (when inlimg-img-regexp - (inlimg-mode 1))) - -;;;###autoload -(define-globalized-minor-mode inlimg-global-mode inlimg-mode inlimg--global-turn-on) - -;;;###autoload -(defun inlimg-toggle-display (point) - "Toggle display of image at point POINT. -See also the command `inlimg-mode'." - (interactive (list (point))) - (let ((here (point)) - (ovl - (catch 'ovl - (dolist (ovl (overlays-at (point))) - (when (inlimg-ovl-p ovl) - (throw 'ovl ovl))))) - is-displayed) - (if (not ovl) - (message "No image at point %s" here) - (setq is-displayed (overlay-get ovl 'after-string)) - (inlimg-next (overlay-start ovl) (not is-displayed)) - (goto-char here)))) - -;;;###autoload -(defun inlimg-toggle-slicing (point) - "Toggle slicing of image at point POINT. -See also the command `inlimg-mode'." - (interactive (list (point))) - (let* ((here (point)) - (ovl - (catch 'ovl - (dolist (ovl (overlays-at (point))) - (when (inlimg-ovl-p ovl) - (throw 'ovl ovl))))) - (inlimg-slice inlimg-slice) - is-displayed) - (if (not ovl) - (message "No image at point %s" here) - (setq is-displayed (overlay-get ovl 'after-string)) - (when (overlay-get ovl 'inlimg-slice) - (setq inlimg-slice nil)) - (inlimg-next (overlay-start ovl) is-displayed) - (goto-char here)))) - - -(defun inlimg-font-lock-fun (bound) - (let ((here (point)) - old-ovls new-ovls ovl) - (goto-char (line-beginning-position)) - (dolist (ovl (overlays-in (point) bound)) - (when (inlimg-ovl-p ovl) - (setq old-ovls (cons ovl old-ovls)))) - (while (and (< (point) bound) - (setq ovl (inlimg-next (point) t))) - (setq new-ovls (cons ovl new-ovls))) - (dolist (ovl old-ovls) - (unless (inlimg-ovl-valid-p ovl) - (delete-overlay ovl) - )))) - -;; Fix-me: This stops working for changes with nxhtml-mumamo-mode, but -;; works for nxhtml-mode and html-mumamo-mode... -(defvar inlimg-this-is-not-font-lock-off nil) -(defun inlimg-font-lock (on) - (let ((add-or-remove (if on 'font-lock-add-keywords 'font-lock-remove-keywords)) - (link-fun)) - (funcall add-or-remove nil - `((inlimg-font-lock-fun - 1 - mlinks-link - prepend))) - (let ((inlimg-this-is-not-font-lock-off t) - (mumamo-multi-major-mode nil)) - (font-lock-mode -1) - (font-lock-mode 1)))) - -(defun inlimg-on-font-lock-off () - (unless (or inlimg-this-is-not-font-lock-off - (and (boundp 'mumamo-multi-major-mode) - mumamo-multi-major-mode)) - (when inlimg-mode - (inlimg-mode -1) - ))) -(put 'inlimg-on-font-lock-off 'permanent-local-hook t) - - -(provide 'inlimg) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; inlimg.el ends here diff --git a/emacs.d/nxhtml/util/key-cat.el b/emacs.d/nxhtml/util/key-cat.el deleted file mode 100644 index ac4938c..0000000 --- a/emacs.d/nxhtml/util/key-cat.el +++ /dev/null @@ -1,329 +0,0 @@ -;;; key-cat.el --- List key bindings by category -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: Sat Jan 28 2006 -;; Version: 0.25 -;; Last-Updated: 2009-05-09 Sat -;; Keywords: -;; Compatibility: -;; -;; Requires Emacs 22. -;; -;; Features that might be required by this library: -;; - ;; `cl'. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Display help that looks like a reference sheet for common -;; commands. -;; -;; To use this in your .emacs put -;; -;; (require 'key-cat) -;; -;; Then use the command -;; -;; M-x key-cat-help -;; -;; For more information see that command. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'cl)) - -(defconst key-cat-cmd-list - '( - (error-testing - (commands - :visible nil - hallo - key-cat-help - key-cat-where-is - )) - ("Help" - (commands - help-for-help - info-emacs-manual - info - )) - ("Special Functions and Keys" - ;; For similar functions that are most often bound to a specific key - (commands - key-cat-tab - key-cat-complete - ) - ) - ("Files, Buffers and Windows" - (commands - find-file - save-buffer - write-file - split-window-vertically - split-window-horizontally - delete-other-windows - other-window - buffer-menu - )) - ("Search and replace" - (commands - isearch-forward - isearch-backward - query-replace - isearch-forward-regexp - isearch-backward-regexp - query-replace-regexp - occur - lgrep - rgrep - )) - ("Lines" - (commands - move-beginning-of-line - move-end-of-line - kill-line - )) - ("Words" - (commands - forward-word - backward-word - kill-word - )) - ("Region" - (commands - set-mark-command - ;;cua-set-mark - kill-region - copy-region-as-kill - yank - yank-pop - )) - ("Undo" - (commands - undo - )) - ("Viper" - (commands - :visible (lambda() - (and (featurep 'viper) - viper-mode)) - viper-next-line - viper-previous-line - viper-forward-word - viper-backward-word - viper-forward-Word - viper-backward-Word - viper-repeat - viper-forward-char - viper-backward-char - viper-next-line-at-bol - viper-previous-line-at-bol - viper-command-argument - viper-digit-argument - )) - ) - "List with common commands to display by `key-cat-help'. -The elements of this list corresponds to sections to show in the -help. Each element consists of sublists beginning with the -keyword 'commands. The sublists may after 'command contain the -keyword :visible which takes a variable or function as argument. -If the argument evaluates to non-nil the list is shown." - ) - - -(defvar key-cat-cmd-list-1 nil) - -(defun key-cat-help() - "Display reference sheet style help for common commands. -See also `key-cat-cmd-list'." - (interactive) - (if (> 22 emacs-major-version) - (message "Sorry, this requires Emacs 22 or later") - ;; Delay to get correct bindings when running through M-x - (setq key-cat-cmd-list-1 key-cat-cmd-list) - (run-with-timer 0.1 nil 'key-cat-help-internal))) - -(defun key-cat-help-internal() ;(category) - (message "Please wait ...") - (condition-case err - (save-match-data ;; runs in timer - (let ((result)) - (help-setup-xref (list #'key-cat-help) - (interactive-p)) - ;; (push (list "Changing commands" - ;; (list - ;; 'command - ;; indent-line-function - ;; )) - ;; key-cat-cmd-list-1) - (dolist (catentry key-cat-cmd-list-1) - (let ((category (car catentry)) - (commands (cdr catentry)) - (cmds) - (keyw) - (visible) - (visible-fun) - (cmdstr) - (doc)) - (dolist (cmdlist commands) - (setq cmdlist (cdr cmdlist)) - (setq visible t) - (while (keywordp (setq keyw (car cmdlist))) - (setq cmdlist (cdr cmdlist)) - (case keyw - (:visible (setq visible-fun (pop cmdlist)) - (setq visible (if (symbolp visible-fun) - (progn - (symbol-value visible-fun)) - (funcall visible-fun))) - ) - )) - (when visible - (dolist (cmd cmdlist) - (setq cmds (cons cmd cmds))))) - (when cmds - (push (format "\n%s:\n" - (let ((s (format "%s" category))) - (put-text-property 0 (length s) - 'face (list - 'bold - ) - s) - s)) - result)) - (setq cmds (reverse cmds)) - (dolist (cmd cmds) - (setq cmdstr - (let ((s "Where to find it:" )) - (put-text-property 0 (length s) - 'face '(:slant italic - :background "RGB:dd/dd/ff" - ) s) s)) - (if (not (functionp cmd)) - (cond - ((eq 'key-cat-tab cmd) - (let ((s "Indent line")) - (put-text-property 0 (length s) 'face '(:foreground "blue") s) - (push s result)) - (push ":\n" result) - (push (concat - " " - "Indent current line (done by specific major mode function).\n") - result) - (push (format " %17s %s\n" cmdstr (key-description [tab])) result) - ) - ((eq 'key-cat-complete cmd) - (let ((s "Completion")) - (put-text-property 0 (length s) 'face '(:foreground "blue") s) - (push s result)) - (push ":\n" result) - (push (concat - " " - "Performe completion at point (done by specific major mode function).\n") - result) - (push (format " %17s %s\n" cmdstr (key-description [meta tab])) result) - ) - (t - (let ((s (format "`%s': (not a function)\n" cmd))) - (put-text-property 0 (length s) 'face '(:foreground "red") s) - (push s result)))) - (let ((keys (key-cat-where-is cmd))) - (push (format "`%s':\n" cmd) result) - (setq doc (documentation cmd t)) - (push - (concat - " " - (if doc - (substring doc 0 (string-match "\n" doc)) - "(not documented)") - "\n") - result) - (if (not keys) - (if (interactive-form cmd) - (push (format " %17s M-x %s\n" cmdstr cmd) result) - (let ((s "(not an interactive command)")) - (put-text-property 0 (length s) 'face '(:foreground "red") s) - (push (format " %17s %s\n" cmdstr s) result))) - (dolist (key keys) - (push (format " %17s " cmdstr) result) - (push (format "%s\n" - (if (eq (elt key 0) 'xmenu-bar) - "Menus" - (key-description key))) - result) - (setq cmdstr "")))))))) - (save-excursion - (with-current-buffer (help-buffer) - (with-output-to-temp-buffer (help-buffer) - (insert - (let ((s "Some important commands\n")) - (put-text-property 0 (length s) - 'face '(:weight bold - :height 1.5 - :foreground "RGB:00/00/66") s) - s)) - (setq result (reverse result)) - (dolist (r result) - (insert r)) - ))) - (message ""))) - (error (message "%s" (error-message-string err))))) - -;; Mostly copied from `where-is': -(defun key-cat-where-is (definition) - "Return key sequences that invoke the command DEFINITION. -Argument is a command definition, usually a symbol with a function definition." - (let ((func (indirect-function definition)) - (defs nil) - (all-keys)) - ;; In DEFS, find all symbols that are aliases for DEFINITION. - (mapatoms (lambda (symbol) - (and (fboundp symbol) - (not (eq symbol definition)) - (eq func (condition-case () - (indirect-function symbol) - (error symbol))) - (push symbol defs)))) - ;; Look at all the symbols--first DEFINITION, - ;; then its aliases. - (dolist (symbol (cons definition defs)) - (let* ((remapped (command-remapping symbol)) - (keys (where-is-internal - ;;symbol overriding-local-map nil nil remapped))) - symbol nil nil nil remapped))) - (when keys - (dolist (key keys) - (setq all-keys (cons key all-keys)))))) - all-keys)) - - - -(provide 'key-cat) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; key-cat.el ends here diff --git a/emacs.d/nxhtml/util/majmodpri.el b/emacs.d/nxhtml/util/majmodpri.el deleted file mode 100644 index 7bdbea6..0000000 --- a/emacs.d/nxhtml/util/majmodpri.el +++ /dev/null @@ -1,448 +0,0 @@ -;;; majmodpri.el --- Major mode priorities handling -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-08-26 -(defconst majmodpri:version "0.62") ;;Version: -;; Last-Updated: 2009-04-30 Thu -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Different elisp libraries may try to handle the same type of files. -;; They normally do that by entering their major mode for a file type -;; in `auto-mode-alist' or the other lists affecting `normal-mode'. -;; Since the libraries may be loaded in different orders in different -;; Emacs sessions this can lead to rather stochastic choices of major -;; mode. -;; -;; This library tries to give the control of which major modes will be -;; used back to the user. It does that by letting the user set up -;; priorities among the major modes. This priorities are used to sort -;; the lists used by `normal-mode'. -;; -;; To setup this libray and get more information do -;; -;; M-x customize-group RET majmodpri RET -;; -;; Or, see the commands `majmodpri-sort-lists'. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'mumamo nil t)) -(eval-when-compile (require 'ourcomments-indirect-fun nil t)) - -;;;; Idle sorting - -(defvar majmodpri-idle-sort-timer nil) - -(defun majmodpri-cancel-idle-sort () - "Cancel idle sorting request." - (when majmodpri-idle-sort-timer - (cancel-timer majmodpri-idle-sort-timer) - (setq majmodpri-idle-sort-timer nil))) - -(defun majmodpri-start-idle-sort () - "Request idle sorting." - (majmodpri-cancel-idle-sort) - (setq majmodpri-idle-sort-timer - (run-with-idle-timer 0 nil 'majmodpri-sort-lists-in-timer))) - -(defun majmodpri-sort-lists-in-timer () - (condition-case err - (save-match-data ;; runs in timer - (majmodpri-sort-lists)) - (error (message "(majmodpri-sort-lists): %s" err)))) - - -;;;; Sorting - -(defvar majmodpri-schwarzian-ordnum nil) -(defun majmodpri-schwarzian-in (rec) - "Transform REC before sorting." - (setq majmodpri-schwarzian-ordnum (1+ majmodpri-schwarzian-ordnum)) - (let ((mode (cdr rec))) - (list - (list mode majmodpri-schwarzian-ordnum) - rec))) - -(defun majmodpri-schwarzian-out (rec) - "Get original value of REC after sorting." - (cadr rec)) - -;; Fix-me: default for Emacs 22?? -(defcustom majmodpri-no-nxml (< emacs-major-version 23) - "Don't use multi major modes with nxml if non-nil. -The default for Emacs prior to version 23 is to not use this -multi major modes by default since there are some problems. - -This gives those multi major mode lower priority, but it does not -prevent use of them." - :type 'boolean - :group 'majmodpri) - -;; (majmodpri-priority 'html-mumamo-mode) -;; (majmodpri-priority 'nxhtml-mumamo-mode) -(defsubst majmodpri-priority (mode) - "Return major mode MODE priority." - (if (and majmodpri-no-nxml - ;; (symbolp mode) - ;; (save-match-data - ;; (string-match "nxhtml-mumamo" (symbol-name mode)))) - (let* ((real (or (ourcomments-indirect-fun mode) - mode)) - (chunk (when real (get real 'mumamo-chunk-family))) - (major-mode (when chunk - (cadr chunk)))) - (when major-mode - (derived-mode-p 'nxml-mode)))) - 0 - (length (memq mode majmodpri-mode-priorities)))) - -(defun majmodpri-compare-auto-modes (rec1 rec2) - "Compare record REC1 and record REC2. -Comparision: - -- First check `majmodpri-mode-priorities'. -- Then use old order in list." - (let* ((schw1 (car rec1)) - (schw2 (car rec2)) - (mod1 (nth 0 schw1)) - (mod2 (nth 0 schw2)) - (ord1 (nth 1 schw1)) - (ord2 (nth 1 schw2)) - (pri1 (majmodpri-priority mod1)) - (pri2 (majmodpri-priority mod2))) - (cond - ((/= pri1 pri2) (> pri1 pri2)) - (t (> ord1 ord2))))) - -;;(benchmark 100 (quote (majmodpri-sort-lists))) -;;(defvar my-auto-mode-alist nil) -(defun majmodpri-sort-auto-mode-alist () - "Sort `auto-mode-alist' after users priorities." - (setq majmodpri-schwarzian-ordnum 0) - ;; Do not reorder function part, but put it first. - (let (fun-list - mod-list) - (dolist (rec auto-mode-alist) - (if (listp (cdr rec)) - (setq fun-list (cons rec fun-list)) - (setq mod-list (cons rec mod-list)))) - (setq fun-list (nreverse fun-list)) - (setq auto-mode-alist - (append - fun-list - (mapcar 'majmodpri-schwarzian-out - (sort - (mapcar 'majmodpri-schwarzian-in mod-list) - 'majmodpri-compare-auto-modes)))))) - -(defun majmodpri-sort-magic-list (magic-mode-list-sym) - "Sort list MAGIC-MODE-LIST-SYM after users priorities." - (let ((orig-ordnum 0)) - (set magic-mode-list-sym - ;; S out - (mapcar (lambda (rec) - (cadr rec)) - ;; Sort - (sort - ;; S in - (mapcar (lambda (rec) - (setq orig-ordnum (1+ orig-ordnum)) - (let ((mode (cdr rec))) - (list - (list mode orig-ordnum) - rec))) - (symbol-value magic-mode-list-sym)) - (lambda (rec1 rec2) - (let* ((schw1 (car rec1)) - (schw2 (car rec2)) - (mod1 (nth 0 schw1)) - (mod2 (nth 0 schw2)) - (ord1 (nth 1 schw1)) - (ord2 (nth 1 schw2)) - (pri1 (majmodpri-priority mod1)) - (pri2 (majmodpri-priority mod2))) - (cond - ((/= pri1 pri2) (> pri1 pri2)) - (t (> ord1 ord2)))))))))) - -;;;###autoload -(defun majmodpri-sort-lists () - "Sort the list used when selecting major mode. -Only sort those lists choosen in `majmodpri-lists-to-sort'. -Sort according to priorities in `majmodpri-mode-priorities'. -Keep the old order in the list otherwise. - -The lists can be sorted when loading elisp libraries, see -`majmodpri-sort-after-load'. - -See also `majmodpri-apply-priorities'." - (interactive) - ;;(message "majmodpri-sort-lists running ...") - (majmodpri-cancel-idle-sort) - (when (memq 'magic-mode-alist majmodpri-lists-to-sort) - (majmodpri-sort-magic-list 'magic-mode-alist)) - (when (memq 'auto-mode-alist majmodpri-lists-to-sort) - (majmodpri-sort-auto-mode-alist)) - (when (memq 'magic-fallback-mode-alist majmodpri-lists-to-sort) - (majmodpri-sort-magic-list 'magic-fallback-mode-alist)) - ;;(message "majmodpri-sort-lists running ... (done)") - ) - - -;;;###autoload -(defun majmodpri-apply () - "Sort major mode lists and apply to existing buffers. -Note: This function is suitable to add to -`desktop-after-read-hook'. It will restore the multi major modes -in buffers." - (majmodpri-apply-priorities t)) - -(defun majmodpri-sort-apply-to-current () - "Sort lists and apply to current buffer." - (majmodpri-sort-lists) - (add-hook 'find-file-hook 'normal-mode t t)) - -(defun majmodpri-check-normal-mode () - "Like `normal-mode', but keep major mode if same." - (let ((keep-mode-if-same t) - (old-major-mode major-mode) - (old-mumamo-multi-major-mode (when (boundp 'mumamo-multi-major-mode) - mumamo-multi-major-mode))) - (report-errors "File mode specification error: %s" - (set-auto-mode t)) - ;;(msgtrc "majmodpri-check %s %s %s" (current-buffer) major-mode mumamo-multi-major-mode) - (unless (and (eq old-major-mode major-mode) - (or (not old-mumamo-multi-major-mode) - (eq old-mumamo-multi-major-mode mumamo-multi-major-mode))) - (msgtrc "majmodpri-check changing") - (report-errors "File local-variables error: %s" - (hack-local-variables)) - ;; Turn font lock off and on, to make sure it takes account of - ;; whatever file local variables are relevant to it. - (when (and font-lock-mode - ;; Font-lock-mode (now in font-core.el) can be ON when - ;; font-lock.el still hasn't been loaded. - (boundp 'font-lock-keywords) - (eq (car font-lock-keywords) t)) - (setq font-lock-keywords (cadr font-lock-keywords)) - (font-lock-mode 1)) - (message "majmodpri-apply-priorities: buffer=%s, %s,%s => %s,%s" - (current-buffer) - old-major-mode - old-mumamo-multi-major-mode - major-mode - (when (boundp 'mumamo-multi-major-mode) - mumamo-multi-major-mode))))) - -;;;###autoload -(defun majmodpri-apply-priorities (change-modes) - "Apply major mode priorities. -First run `majmodpri-sort-lists' and then if CHANGE-MODES is -non-nil apply to existing file buffers. If interactive ask -before applying." - (interactive '(nil)) - (message "majmodpri-apply-priorities running ...") - (majmodpri-sort-lists) - (when (or change-modes - (with-no-warnings (called-interactively-p))) - (let (file-buffers) - (dolist (buffer (buffer-list)) - (with-current-buffer buffer - (let ((name (buffer-name)) - (file buffer-file-name)) - (or (string= (substring name 0 1) " ") ;; Internal - (not file) - (setq file-buffers (cons buffer file-buffers)))))) - (if (not file-buffers) - (when change-modes - ;;(message "majmodpri-apply-priorities: No file buffers to change modes in") - ) - (when (with-no-warnings (called-interactively-p)) - (setq change-modes - (y-or-n-p "Check major mode in all file visiting buffers? "))) - (when change-modes - (dolist (buffer file-buffers) - (with-current-buffer buffer - (let ((old-major major-mode)) - (majmodpri-check-normal-mode) - ))))))) - (message "majmodpri-apply-priorities running ... (done)")) - - -;;;; Custom - -;;;###autoload -(defgroup majmodpri nil - "Customization group for majmodpri.el" - :group 'nxhtml - ) - -(defcustom majmodpri-mode-priorities - '( - cperl-mumamo-mode - csound-sgml-mumamo-mode - django-nxhtml-mumamo-mode - django-html-mumamo-mode - embperl-nxhtml-mumamo-mode - embperl-html-mumamo-mode - eruby-nxhtml-mumamo-mode - eruby-html-mumamo-mode - genshi-nxhtml-mumamo-mode - genshi-html-mumamo-mode - jsp-nxhtml-mumamo-mode - jsp-html-mumamo-mode - laszlo-nxml-mumamo-mode - metapost-mumamo-mode - mjt-nxhtml-mumamo-mode - mjt-html-mumamo-mode - noweb2-mumamo-mode - ;;org-mumamo-mode - perl-mumamo-mode - smarty-nxhtml-mumamo-mode - smarty-html-mumamo-mode - ;;tt-html-mumamo-mode - - nxhtml-mumamo-mode - html-mumamo-mode - nxml-mumamo-mode - nxml-mode - - javascript-mode - ;;espresso-mode - rhtml-mode - ) - "Priority list for major modes. -Modes that comes first have higher priority. -See `majmodpri-sort-lists' for more information." - :type '(repeat symbol) - :set (lambda (sym val) - (set-default sym val) - (when (and (boundp 'majmodpri-sort-after-load) - majmodpri-sort-after-load) - (majmodpri-start-idle-sort))) - :group 'majmodpri) - -(defcustom majmodpri-lists-to-sort - '(magic-mode-alist auto-mode-alist magic-fallback-mode-alist) - ;;nil - "Which major mode lists to sort. -See `majmodpri-sort-lists' for more information." - :type '(set (const magic-mode-alist) - (const auto-mode-alist) - (const magic-fallback-mode-alist)) - :set (lambda (sym val) - (set-default sym val) - (when (and (boundp 'majmodpri-sort-after-load) - majmodpri-sort-after-load) - (majmodpri-start-idle-sort))) - :group 'majmodpri) - -(defcustom majmodpri-sort-after-load - '( - chart - gpl - ;;nxhtml-autoload - php-mode - rnc-mode - ruby-mode - ) - "Sort major mode lists after loading elisp libraries if non-nil. -This should not really be needed since just loading a library -should not change how Emacs behaves. There are however quite a -few thirt party libraries that does change `auto-mode-alist' -\(including some of my own) since that sometimes seems -reasonable. Some of them are in the default value of this -variable. - -There are two possibilities for sorting here: - -- Value=list of features (default). Sort immediately after loading a - library in the list. Apply to current buffer. - -- Value=t. Sort after loading any library. Sorting is then not - done immediately. Instead it runs in an idle timer. This - means that if several elisp libraries are loaded in a command - then the sorting will only be done once, after the command has - finished. After sorting apply to all buffers. - -Note that the default does break Emacs rule that loading a -library should not change how Emacs behave. On the other hand -the default tries to compensate for that the loaded libraries -breaks this rule by changing `auto-mode-alist'. - -See `majmodpri-sort-lists' for more information." - :type '(choice (const :tag "Never" nil) - (const :tag "After loading any elisp library" t) - (repeat :tag "After loading specified features" symbol)) - :set (lambda (sym val) - (set-default sym val) - ;; Clean up `after-load-alist' first. - (setq after-load-alist - (delq nil - (mapcar (lambda (rec) - (unless (member (cadr rec) - '((majmodpri-start-idle-sort) - (majmodpri-sort-lists))) - rec)) - after-load-alist))) - (when val - ;;(message "majmodpri-sort-after-load: val=%s" val) - (let ((sort-and-apply nil)) - (if (not (listp val)) - (add-to-list 'after-load-alist - (if (eq val t) - '(".*" (majmodpri-start-idle-sort)) - '("." (majmodpri-sort-lists)))) - (dolist (feat val) - ;;(message "feat=%s" feat) - (if (featurep feat) - (setq sort-and-apply t) - (if (eq val t) - (eval-after-load feat '(majmodpri-start-idle-sort)) - (eval-after-load feat '(majmodpri-sort-apply-to-current)))))) - (when sort-and-apply - ;;(message "majmodpri-sort-after-load: sort-and-apply") - (majmodpri-apply-priorities t)) - (if (eq val t) - (majmodpri-start-idle-sort) - (majmodpri-apply-priorities t))))) - :group 'majmodpri) - - -(provide 'majmodpri) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; majmodpri.el ends here diff --git a/emacs.d/nxhtml/util/markchars.el b/emacs.d/nxhtml/util/markchars.el deleted file mode 100644 index e1179b7..0000000 --- a/emacs.d/nxhtml/util/markchars.el +++ /dev/null @@ -1,151 +0,0 @@ -;;; markchars.el --- Mark chars fitting certain characteristics -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2010-03-22 Mon -;; Version: -;; Last-Updated: 2010-03-25 Thu -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; Required feature `markchars' was not provided. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Mark special chars, by default non-ascii, non-IDN chars. See -;; `markchars-mode'. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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, 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: - -(require 'idn) - -;;;###autoload -(defgroup markchars nil - "Customization group for `markchars-mode'." - :group 'convenience) - -(defface markchars-light - '((t (:underline "light blue"))) - "Light face for `markchars-mode' char marking." - :group 'markchars) - -(defface markchars-heavy - '((t (:underline "magenta"))) - "Heavy face for `markchars-mode' char marking." - :group 'markchars) - -(defcustom markchars-face 'markchars-heavy - "Pointer to face used for marking chars." - :type 'face - :group 'markchars) - -;; (markchars-nonidn-fun (point-max)) -;; åäö -;; character: å (229, #o345, #xe5) -;; (idn-is-recommended 229) => t -;; 152F ; 00B7 0034 ; SL # ( ᔯ → ·4 ) CANADIAN SYLLABICS YWE → MIDDLE DOT, DIGIT FOUR # {source:835} ᐧ4 {[source:696]} - -(defun markchars-nonidn-fun (bound) - "Font lock matcher for non-IDN, non-ascii chars." - (let* ((beg (catch 'beg - (while (< (point) bound) - (let ((char (char-after))) - (unless (or (< char 256) - (idn-is-recommended char)) - (throw 'beg (point))) - (forward-char))))) - (end (when beg - (catch 'end - (while (< (point) bound) - (let ((char (char-after (point)))) - (when (or (< char 256) - (idn-is-recommended char)) - (throw 'end (point))) - (forward-char))))))) - (when beg - (setq end (or end bound)) - (set-match-data (list (copy-marker beg) (copy-marker end))) - t))) - -(defcustom markchars-keywords (or (when (fboundp 'idn-is-recommended) 'markchars-nonidn-fun) - "[[:nonascii:]]+") - "Regexp or function for font lock to use for characters to mark. -By default it matches non-IDN, non-ascii chars." - :type '(choice (const :tag "Non-ascii chars" "[[:nonascii:]]+") - (const :tag "Non IDN chars (Unicode.org tr39 suggestions)" markchars-nonidn-fun)) - :group 'markchars) - -(defvar markchars-used-keywords nil - "Keywords currently used for font lock.") -(put 'markchars-used-keywords 'permanent-local t) - -(defun markchars-set-keywords () - "Set `markchars-used-keywords' from options." - (set (make-local-variable 'markchars-used-keywords) - (list - (list markchars-keywords - (list 0 '(put-text-property (match-beginning 0) (match-end 0) - 'face markchars-face)))))) - -;;;###autoload -(define-minor-mode markchars-mode - "Mark special characters. -Which characters to mark are defined by `markchars-keywords'. - -The default is to mark non-IDN, non-ascii chars with a magenta -underline. - -For information about IDN chars see `idn-is-recommended'. - -If you change anything in the customization group `markchars' you -must restart this minor mode for the changes to take effect." - :group 'markchars - :lighter " ø" - (if markchars-mode - (progn - (markchars-set-keywords) - (font-lock-add-keywords nil markchars-used-keywords)) - (font-lock-remove-keywords nil markchars-used-keywords)) - ;; Fix-me: Something like mumamo-mark-for-refontification should be in Emacs. - (if (fboundp 'mumamo-mark-for-refontification) - (save-restriction - (widen) - (mumamo-mark-for-refontification (point-min) (point-max))) - (font-lock-fontify-buffer))) - -;;;###autoload -(define-globalized-minor-mode markchars-global-mode markchars-mode - (lambda () (markchars-mode 1)) - :group 'markchars) - -(provide 'markchars) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; markchars.el ends here diff --git a/emacs.d/nxhtml/util/mlinks.el b/emacs.d/nxhtml/util/mlinks.el deleted file mode 100644 index 0f81654..0000000 --- a/emacs.d/nxhtml/util/mlinks.el +++ /dev/null @@ -1,1367 +0,0 @@ -;;; mlinks.el --- Minor mode making major mode dependent links -;; -;; Author: Lennar Borgman -;; Created: Tue Jan 16 2007 -(defconst mlinks:version "0.28") ;;Version: -;; Last-Updated: 2010-01-05 Tue -;; Keywords: -;; Compatibility: -;; -;; Fxeatures that might be required by this library: -;; -;; `appmenu', `cl', `mail-prsvr', `mm-util', `ourcomments-util', -;; `url-expand', `url-methods', `url-parse', `url-util', -;; `url-vars'. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; This file implements the minor mode `mlinks-mode' that create -;; hyperlinks for different major modes. Such links can be visible or -;; invisible. The meanings of the links are defined per mode. -;; -;; Examples: -;; -;; - In in html style modes the links are visible they can mean either -;; open a file for editing, go to an achnor or view the link in a -;; web browser etc. -;; -;; - In emacs lisp mode the links are invisible, but maybe highlighed -;; when point or mouse is on them. (Having them highlighted when -;; point is on them can be a quick way to check that you have -;; spelled a symbol correct.) The meanings of the links in emacs -;; lisp mode are go to definition. -;; -;; Common to links that open a buffer in Emacs is that you can the -;; buffer opened in the same window, the other window or in a new -;; frame. The same key binding is used in all major modes for this. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; FIX-ME: url-hexify-string etc -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'cl)) -(eval-when-compile (require 'appmenu nil t)) -(eval-when-compile (require 'mumamo nil t)) -(eval-when-compile (require 'ourcomments-util nil t)) - -(require 'rx) -(require 'url-parse) -(require 'url-expand) - -(defvar mlinks-point-hilighter-overlay nil) -(make-variable-buffer-local 'mlinks-point-hilighter-overlay) -(put 'mlinks-point-hilighter-overlay 'permanent-local t) - -;;;###autoload -(defgroup mlinks nil - "Customization group for `mlinks-mode'." - :group 'nxhtml - :group 'hypermedia) - -(defvar mlinks-link-face 'mlinks-link-face) -(defface mlinks-link-face - '((t (:inherit highlight))) - "Face normally active links have on them." - :group 'mlinks) - -(defvar mlinks-hyperactive-link-face 'mlinks-hyperactive-link-face) -(defface mlinks-hyperactive-link-face - '((t (:inherit isearch))) - "Face hyper active links have on them." - :group 'mlinks) - -(defvar mlinks-font-lock-face 'mlinks-font-lock-face) -(defface mlinks-font-lock-face - '((t :inherit link)) - "Default face for MLinks' links." - :group 'mlinks) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Mode function bindings - -;;(customize-option mlinks-mode-functions) -(defcustom mlinks-mode-functions - '( - ;; For message buffer etc. - (fundamental-mode - ((goto mlinks-elisp-goto) - (hili mlinks-elisp-hili) - (hion t) - ) - ) - (emacs-lisp-mode - ((goto mlinks-elisp-goto) - (hili mlinks-elisp-hili) - (hion t) - ) - ) - ;; *scractch* - (lisp-interaction-mode - ((goto mlinks-elisp-goto) - (hili mlinks-elisp-hili) - (hion t) - ) - ) - (help-mode - ((goto mlinks-elisp-goto) - (hili mlinks-elisp-hili) - (hion t) - ) - ) - (Info-mode - ((goto mlinks-elisp-goto) - (hili mlinks-elisp-hili) - (hion t) - ) - ) - (Custom-mode - ((goto mlinks-elisp-custom-goto) - (hili mlinks-elisp-hili) - (hion t) - (fontify mlinks-custom-fontify) - ) - ) - (text-mode - ((goto mlinks-goto-plain-url) - (hion t) - (fontify mlinks-plain-urls-fontify) - ) - ) - (nxhtml-mode - ((hion t) - (fontify mlinks-html-fontify) - (goto mlinks-html-style-goto) - ) - ) - (nxml-mode - ((hion t) - (fontify mlinks-html-fontify) - (goto mlinks-html-style-goto) - ) - ) - (sgml-mode - ((hion t) - (fontify mlinks-html-fontify) - (goto mlinks-html-style-goto) - ) - ) - (html-mode - ((hion t) - (fontify mlinks-html-fontify) - (goto mlinks-html-style-goto) - ) - ) - ) - "Defines MLinks hyperlinks for major modes. -" - ;; Each element in the list is a list with two elements - - ;; \(MAJOR-MODE SETTINGS) - - ;; where MAJOR-MODE is the major mode for which the settings SETTINGS should be used. - ;; SETTINGS is an association list which can have the following element types - - ;; \(hili HILIGHT-FUN) ;; Mandatory - ;; \(goto GOTO-FUN) ;; Mandatory - ;; \(hion HION-BOOL) ;; Optional - ;; \(next NEXT-FUN) ;; Optional - ;; \(prev PREV-FUN) ;; Optional - - ;; Where - ;; - HILIGHT-FUN is the function to hilight a link when point is - ;; inside the link. This is done when Emacs is idle. - ;; - GOTO-FUN is the function to follow the link at point. - ;; - HION-BOOL is t or nil depending on if hilighting should be on - ;; by default. - ;; - NEXT-FUN is the function to go to the next link. - ;; - PREV-FUN is the function to go to the previous link." - ;; ;;:type '(repeat (alist :key-type symbol :value-type (alist :key-type symbol :value symbol))) - :type '(alist :key-type major-mode-function - :value-type (list - (set - (const :tag "Enable MLinks in this major mode" hion) - (const :tag "Mark All Links" mark) - (list :tag "Enable" (const :tag "Hilighting" hili) function) - (list :tag "Enable" (const :tag "Follow Link" goto) function) - (list :tag "Enable" (const :tag "Goto Next Link" next) function) - (list :tag "Enable" (const :tag "Goto Previous Link" prev) function) - ))) - :group 'mlinks) - - -(defun mlinks-get-mode-value (which) - (let* ((major major-mode) - (mode-rec (assoc major mlinks-mode-functions))) - (catch 'mode-rec - (while (and major - (not mode-rec)) - (setq major (get major 'derived-mode-parent)) - (setq mode-rec (assoc major mlinks-mode-functions)) - (when mode-rec (throw 'mode-rec nil)))) - (when mode-rec - (let* ((mode (car mode-rec)) - (funs-alist (cadr mode-rec)) - (funs (assoc which funs-alist))) - (cdr funs))))) - - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Minor modes - -;; (appmenu-dump-keymap mlinks-mode-map) -(defvar mlinks-mode-map - (let ((m (make-sparse-keymap "mlinks"))) - (define-key m [(control ?c) ?\r ?\r] 'mlinks-goto) - (define-key m [(control ?c) ?\r ?w] 'mlinks-goto-other-window) - (define-key m [(control ?c) ?\r ?f] 'mlinks-goto-other-frame) - (define-key m [(control ?c) ?\r ?n] 'mlinks-next-saved-position) - (define-key m [(control ?c) ?\r ?p] 'mlinks-prev-saved-position) - (define-key m [(control ?c) ?\r S-tab] 'mlinks-backward-link) - (define-key m [(control ?c) ?\r tab] 'mlinks-forward-link) - (define-key m [(control ?c) ?\r ?h] 'mlinks-toggle-hilight) - (define-key m [(control ?c) ?\r ?c] 'mlinks-copy-link-text) - m)) - -;;;###autoload -(define-minor-mode mlinks-mode - "Recognizes certain parts of a buffer as hyperlinks. -The hyperlinks are created in different ways for different major -modes with the help of the functions in the list -`mlinks-mode-functions'. - -The hyperlinks can be hilighted when point is over them. Use -`mlinks-toggle-hilight' to toggle this feature for the current -buffer. - -All keybindings in this mode are by default done under the prefi§x -key - - C-c RET - -which is supposed to be a kind of mnemonic for link (alluding to -the RET key commonly used in web browser to follow a link). -\(Unfortunately this breaks the rules in info node `Key Binding -Conventions'.) Below are the key bindings defined by this mode: - -\\{mlinks-mode-map} - -For some major modes `mlinks-backward-link' and -`mlinks-forward-link' will take you to the previous/next link. -By default the link moved to will be active, see -`mlinks-active-links'. - -" - nil - " L" - nil - :keymap mlinks-mode-map - :group 'mlinks - (if mlinks-mode - (progn - (mlinks-add-appmenu) - (mlinks-start-point-hilighter) - (mlinks-add-font-lock)) - (mlinks-stop-point-hilighter) - (when mlinks-point-hilighter-overlay - (when (overlayp mlinks-point-hilighter-overlay) - (delete-overlay mlinks-point-hilighter-overlay)) - (setq mlinks-point-hilighter-overlay nil)) - (mlinks-remove-font-lock))) -(put 'mlinks-mode 'permanent-local t) - -(defun mlinks-turn-on-in-buffer () - (let ((hion (unless (and (boundp 'mumamo-set-major-running) - mumamo-set-major-running) - (mlinks-get-mode-value 'hion)))) - (when hion (mlinks-mode 1)))) - -;;;###autoload -(define-globalized-minor-mode mlinks-global-mode mlinks-mode - mlinks-turn-on-in-buffer - "Turn on `mlink-mode' in all buffer where it is specified. -This is specified in `mlinks-mode-functions'." - :group 'mlinks) - -;; The problem with global minor modes: -(when (and mlinks-global-mode - (not (boundp 'define-global-minor-mode-bug))) - (mlinks-global-mode 1)) - -;;(define-toggle mlinks-active-links t -(define-minor-mode mlinks-active-links - "Use quick movement keys on active links if non-nil. -When moving to an mlink with `mlinks-forward-link' or -`mlinks-backward-link' the link moved to will be in an active -state. This is marked with a new color \(the face `isearch'). -When the new color is shown the following keys are active - -\\{mlinks-hyperactive-point-hilighter-keymap} -Any command cancels this state." - :global t - :init-value t - :group 'mlinks) - - - -(defun mlinks-link-text-prop-range (pos) - (let* ((link-here (get-text-property pos 'mlinks-link)) - (beg (when link-here (previous-single-char-property-change (+ pos 1) 'mlinks-link))) - (end (when link-here (next-single-char-property-change (- pos 0) 'mlinks-link)))) - (when (and beg end) - (cons beg end)))) - -(defun mlinks-link-range (pos) - (or (mlinks-link-text-prop-range pos) - (let ((funs-- (mlinks-get-mode-value 'hili))) - (when funs-- - (save-match-data - (run-hook-with-args-until-success 'funs--)))))) - -(defun mlinks-link-at-point () - "Get link at point." - (mlinks-point-hilighter-1) - (when (and mlinks-point-hilighter-overlay - (overlay-buffer mlinks-point-hilighter-overlay)) - (let* ((ovl mlinks-point-hilighter-overlay) - (beg (overlay-start ovl)) - (end (overlay-end ovl))) - (buffer-substring-no-properties beg end)))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; At point highligher - -(defvar mlinks-point-hilighter-timer nil) - -(defun mlinks-stop-point-hilighter () - (when (timerp mlinks-point-hilighter-timer) - (cancel-timer mlinks-point-hilighter-timer) - (setq mlinks-point-hilighter-timer nil))) - -(defun mlinks-start-point-hilighter () - (mlinks-stop-point-hilighter) - (setq mlinks-point-hilighter-timer - (run-with-idle-timer 0.1 t 'mlinks-point-hilighter))) - -(defvar mlinks-link-overlay-priority 100) - -(defun mlinks-make-point-hilighter-overlay (bounds) - (unless mlinks-point-hilighter-overlay - (setq mlinks-point-hilighter-overlay - (make-overlay (car bounds) (cdr bounds))) - (overlay-put mlinks-point-hilighter-overlay 'priority mlinks-link-overlay-priority) - (overlay-put mlinks-point-hilighter-overlay 'mouse-face 'highlight) - (mlinks-set-normal-point-hilight) - )) - -(defun mlinks-point-hilighter () - "Mark link at point if any. -This moves the hilight point overlay to point or deletes it." - ;; This runs in a timer, protect it. - (condition-case err - (let ((inhibit-point-motion-hooks t)) - (mlinks-point-hilighter-1)) - (error "mlinks-point-hilighter error: %s" (error-message-string err)))) - -(defun mlinks-point-hilighter-1 () - (when mlinks-mode - (let ((bounds-- (mlinks-link-range (point)))) - (if bounds-- - (if mlinks-point-hilighter-overlay - (move-overlay mlinks-point-hilighter-overlay (car bounds--) (cdr bounds--)) - (mlinks-make-point-hilighter-overlay bounds--)) - (when mlinks-point-hilighter-overlay - (delete-overlay mlinks-point-hilighter-overlay)))))) - -(defvar mlinks-hyperactive-point-hilighter-keymap - (let ((m (make-sparse-keymap "mlinks"))) - (define-key m [S-tab] 'mlinks-backward-link) - (define-key m [tab] 'mlinks-forward-link) - (define-key m "\t" 'mlinks-forward-link) - (define-key m [?\r] 'mlinks-goto) - (define-key m [?w] 'mlinks-goto-other-window) - (define-key m [?f] 'mlinks-goto-other-frame) - (define-key m [mouse-1] 'mlinks-goto) - (set-keymap-parent m mlinks-mode-map) - m)) - -(defvar mlinks-point-hilighter-keymap - (let ((m (make-sparse-keymap "mlinks"))) - (define-key m [mouse-1] 'mlinks-goto) - (set-keymap-parent m mlinks-mode-map) - m)) - -(defun mlinks-point-hilighter-pre-command () - (condition-case err - (unless (let ((map (overlay-get mlinks-point-hilighter-overlay 'keymap))) - (where-is-internal this-command - (list - map))) - (mlinks-set-normal-point-hilight) - (unless mlinks-point-hilighter-timer - (delete-overlay mlinks-point-hilighter-overlay))) - (error (message "mlinks-point-hilighter-pre-command: %s" err)))) -(put 'mlinks-point-hilighter-pre-command 'permanent-local t) - -(defun mlinks-set-hyperactive-point-hilight () - "Make link hyper active, ie add some special key binding. -Used after jumping specifically to a link. The idea is that the -user may want to easily jump between links in this state." - (add-hook 'pre-command-hook 'mlinks-point-hilighter-pre-command nil t) - (mlinks-point-hilighter) - (overlay-put mlinks-point-hilighter-overlay 'face mlinks-hyperactive-link-face) - (overlay-put mlinks-point-hilighter-overlay 'keymap mlinks-hyperactive-point-hilighter-keymap)) - -(defun mlinks-set-normal-point-hilight () - "Make link normally active as if you happened to be on it." - (remove-hook 'pre-command-hook 'mlinks-point-hilighter-pre-command t) - (mlinks-point-hilighter) - (overlay-put mlinks-point-hilighter-overlay 'face mlinks-link-face) - (overlay-put mlinks-point-hilighter-overlay 'keymap mlinks-point-hilighter-keymap)) - -(defun mlinks-set-point-hilight-after-jump-to () - "Set hilight style after jump to link." - (if mlinks-active-links - (mlinks-set-hyperactive-point-hilight) - (mlinks-set-normal-point-hilight))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Jumping around - -(defvar mlinks-places nil) -(make-variable-buffer-local 'mlinks-placesn) -(put 'mlinks-places 'permanent-local t) - -(defvar mlinks-places-n 0) -(make-variable-buffer-local 'mlinks-places-n) -(put 'mlinks-places-n 'permanent-local t) - -(defun mlinks-has-links () - (or (mlinks-get-mode-value 'fontify) - (when (and (boundp 'mumamo-multi-major-mode) mumamo-multi-major-mode) - ;; Fix-me: just assume multi major has it... Need a list of - ;; major modes. There is no way to get such a list for the - ;; multi major mode (since you can't know what the chunk - ;; functions will return. However you can get a list of - ;; current chunks major mode. - t - ))) - -(defun mlinks-backward-link () - "Go to previous `mlinks-mode' link in buffer." - (interactive) - (if (not (mlinks-has-links)) - (message "There is no way to go to previous link for this major mode") - (let ((res (mlinks-prev-link))) - (if res - (progn - (goto-char res) - (mlinks-set-point-hilight-after-jump-to)) - (message "No previous link found"))))) - -(defun mlinks-forward-link () - "Go to next `mlinks-mode' link in buffer." - (interactive) - (if (not (mlinks-has-links)) - (message "There is no way to go to next link for this major mode") - (let ((res (mlinks-next-link))) - (if res - (progn - (goto-char res) - (mlinks-set-point-hilight-after-jump-to)) - (message "No next link found"))))) - - -(defun mlinks-goto () - "Follow `mlinks-mode' link at current point. -Save the current position so that they can be move to again by -`mlinks-prev-saved-position' and `mlinks-next-saved-position'. - -Return non-nil if link was followed, otherewise nil." - (interactive) - (mlinks-goto-1 nil)) - -(defun mlinks-goto-other-window () - "Like `mlinks-goto' but opens in other window. -Uses `switch-to-buffer-other-window'." - (interactive) - (mlinks-goto-1 'other-window)) - -(defun mlinks-goto-other-frame () - "Like `mlinks-goto' but opens in other frame. -Uses `switch-to-buffer-other-frame'." - (interactive) - (mlinks-goto-1 'other-frame)) - -(defun mlinks-goto-1(where) - (push-mark) - (let* ((funs (mlinks-get-mode-value 'goto)) - (old (point-marker)) - (mlinks-temp-buffer-where where) - (res (run-hook-with-args-until-success 'funs))) - (if (not res) - (progn - (message "Don't know how to follow this MLink link") - nil) - (unless (= old (point-marker)) - (let* ((prev (car mlinks-places))) - (when (or (not prev) - ;;(not (markerp prev)) - (not (marker-buffer prev)) - (/= old prev)) - (setq mlinks-places (cons old mlinks-places)) - (setq mlinks-places-n (length mlinks-places)))))))) - - -(defun mlinks-prev-saved-position () - "Go to previous position saved by `mlinks-goto'." - (interactive) - (unless (mlinks-goto-n (1- mlinks-places-n)) - (message "No previous MLink position"))) - -(defun mlinks-next-saved-position () - "Go to next position saved by `mlinks-goto'." - (interactive) - (unless (mlinks-goto-n (1+ mlinks-places-n)) - (message "No next MLink position"))) - -(defun mlinks-goto-n (to) - (if (not mlinks-places) - (message "No saved MLinks positions") - (let ((minp 1) - (maxp (length mlinks-places))) - (if (<= to minp) - (progn - (setq to minp) - (message "Going to first MLinks position")) - (if (>= to maxp) - (progn - (setq to maxp) - (message "Going to last MLinks position")))) - (setq mlinks-places-n to) - (let ((n (- maxp to)) - (places mlinks-places) - place - buffer - point) - (while (> n 0) - (setq places (cdr places)) - (setq n (1- n))) - (setq place (car places)) - (mlinks-switch-to-buffer (marker-buffer place)) - (goto-char place))))) - -(defvar mlinks-temp-buffer-where nil) -(defun mlinks-switch-to-buffer (buffer) - (mlinks-switch-to-buffer-1 buffer mlinks-temp-buffer-where)) - -(defun mlinks-switch-to-buffer-1(buffer where) - (cond - ((null where) - (switch-to-buffer buffer)) - ((eq where 'other-window) - (switch-to-buffer-other-window buffer)) - ((eq where 'other-frame) - (switch-to-buffer-other-frame buffer)) - (t - (error "Invalid argument, where=%s" where)))) - -;; FIXME: face, var -(defun mlinks-custom (var) - (customize-option var) - ) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; AppMenu support - -(defun mlinks-appmenu () - (when mlinks-mode - ;; Fix-me: reverse the list - (let ((link-val (mlinks-link-at-point)) - (map (make-sparse-keymap "mlinks")) - (num 2)) - (when (mlinks-get-mode-value 'prev) - (define-key map [mlinks-next-link] - (list 'menu-item "Next Link" 'mlinks-forward-link))) - (when (mlinks-get-mode-value 'next) - (define-key map [mlinks-prev-link] - (list 'menu-item "Previous Link" 'mlinks-backward-link))) - (when link-val - (let* ((possible (when (member major-mode '(html-mode nxhtml-mode nxml-mode sqml-mode text-mode)) - (mlinks-html-possible-href-actions link-val))) - (mailto (assoc 'mailto possible)) - (view-web (assoc 'view-web possible)) - (view-web-base (assoc 'view-web-base possible)) - (edit (assoc 'edit possible)) - (file (nth 1 edit)) - (anchor (nth 2 edit)) - (choices) - (answer) - ) - (when (> (length map) num) - (define-key map [mlinks-href-sep] (list 'menu-item "--"))) - (setq num (length map)) - (when view-web - (define-key map [mlinks-href-view-web] - (list 'menu-item "Browse Link Web Url" - `(lambda () (interactive) - (browse-url ,link-val))))) - (when view-web-base - (define-key map [mlinks-href-view-web-based] - (list 'menu-item "Browse Link Web Url (base URL found)" - `(lambda () (interactive) - (browse-url (cdr ,view-web-base)))))) - (when mailto - (define-key map [mlinks-href-mail] - (list 'menu-item (concat "&Mail to " (substring link-val 7)) - `(lambda () (interactive) - (mlinks-html-mail-to ,link-val))))) - (when edit - (when (and (file-exists-p file) - (not anchor) - (assoc 'upload possible)) - (let ((abs-file (expand-file-name file))) - (define-key map [mlinks-href-upload] - (list 'menu-item "Upload Linked File" - `(lambda () (interactive) - (html-upl-upload-file ,abs-file)))))) - (when (and (file-exists-p file) - (not anchor) - (assoc 'edit-gimp possible)) - (let ((abs-file (expand-file-name file))) - (define-key map [mlinks-href-edit-gimp] - (list 'menu-item "Edit Linked File with GIMP" - `(lambda () (interactive) - (gimpedit-edit-file ,abs-file)))))) - (when (and (file-exists-p file) - (assoc 'view-local possible)) - (let ((url (concat "file:///" (expand-file-name file)))) - (when anchor - (let ((url-anchor (concat url "#" anchor))) - (define-key map [mlinks-href-view-file-at] - (list 'menu-item (concat "Browse Linked File URL at #" anchor) - `(lambda () (interactive) - (browse-url ,url-anchor)))))) - (define-key map [mlinks-href-view-file] - (list 'menu-item "&Browse Linked File URL" - `(lambda () (interactive) - (browse-url ,url)))))) - (when (> (length map) num) - (define-key map [mlinks-href-sep-2] (list 'menu-item "--"))) - (setq num (length map)) - (unless (equal file (buffer-file-name)) - (define-key map [mlinks-href-edit] - (list 'menu-item "&Open Linked File" - `(lambda () (interactive) (mlinks-goto)))) - (define-key map [mlinks-href-edit-window] - (list 'menu-item "&Open Linked File in Other Window" - `(lambda () (interactive) (mlinks-goto-other-window)))) - (define-key map [mlinks-href-edit-frame] - (list 'menu-item "&Open Linked File in New Frame" - `(lambda () (interactive) (mlinks-goto-other-frame)))) - ) - (when (and (file-exists-p file) anchor) - (define-key map [mlinks-href-edit-at] - (list 'menu-item (concat "Open Linked File &at #" anchor) - `(lambda () (interactive) - (mlinks-goto))))) - ) - (when (> (length map) num) - (define-key map [mlinks-href-sep-1] (list 'menu-item "--"))) - (setq num (length map)) - (when link-val - (define-key map [mlinks-href-copy-link] - (list 'menu-item "&Copy Link Text" - 'mlinks-copy-link-text))))) - (when (> (length map) 2) - map)))) - -(defun mlinks-add-appmenu () - "Add entries for MLinks to AppMenu." - (when (featurep 'appmenu) - (appmenu-add 'mlinks 100 'mlinks-mode "Current MLink" 'mlinks-appmenu))) - -(defun mlinks-copy-link-text () - "Copy text of `mlinks-mode' link at point to clipboard." - (interactive) - (mlinks-point-hilighter) - (let ((ovl mlinks-point-hilighter-overlay)) - (if (and ovl - (overlayp ovl) - (overlay-buffer ovl) - (eq (current-buffer) - (overlay-buffer ovl)) - (<= (overlay-start ovl) - (point)) - (>= (overlay-end ovl) - (point))) - (let* ((beg (overlay-start ovl)) - (end (overlay-end ovl)) - (str (buffer-substring beg end))) - (copy-region-as-kill beg end) - (message "Copied %d chars to clipboard" (length str))) - (message "No link here to copy")))) - - - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;; text-mode etc ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar mlinks-plain-urls-regexp - (rx-to-string `(or (submatch (optional "mailto:") - (regexp ,(concat - ;;"[a-z0-9$%(*-=?[_][^<>\")!;:,{}]*" - "[a-z0-9$%(*=?[_-][^<>\")!;:,{}]*" - "\@" - "\\(?:[a-z0-9\-]+\.\\)+[a-z0-9]\\{2,4\\}"))) - (submatch (or (regexp "https?://") - "www.") - (1+ (any ,url-get-url-filename-chars)) - ) - ))) - -(defun mlinks-plain-urls-fontify (bound) - (mlinks-fontify bound mlinks-plain-urls-regexp 0)) - -(defun mlinks-goto-plain-url () - (let* ((range (mlinks-link-range (point))) - (link (when range (buffer-substring-no-properties (car range) (cdr range))))) - ;;(mlinks-html-href-act-on link) - (when (= 0 (string-match mlinks-plain-urls-regexp link)) - (let ((which (if (match-end 1) 1 2))) - (cond - ((= 1 which) - (mlinks-html-mail-to link) - t) - ((= 2 which) - (browse-url link) - t) - (t nil)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;; nxhtml-mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun mlinks-html-style-goto () - (mlinks-html-style-mode-fun t)) - -(defvar mlinks-html-link-regexp - ;; This value takes care of nxhtml-strval-mode (and is therefore a little bit incorrect ...) - ;;"\\(?:^\\|[[:space:]]\\)\\(?:href\\|src\\)[[:space:]]*=[[:space:]]*\"\\([^<«\"]*\\)\"" - (rx (or "^" space) - (or "href" "src") - (0+ space) - "=" - (0+ space) - (submatch - (or - (seq "\"" - (and - (0+ (not (any "\"")))) - "\"") - (seq "'" - (and - (0+ (not (any "\'")))) - "'"))))) - -(defun mlinks-html-style-mode-fun (goto) - (let (start - end - bounds) - (save-excursion - (forward-char) - (when (< 0 (skip-chars-forward "^\"'" (line-end-position))) - (forward-char) - (save-match-data - (when (looking-back - mlinks-html-link-regexp - (line-beginning-position -1)) - (let ((which (if (match-beginning 1) 1 2))) - (setq start (1+ (match-beginning which))) - (setq end (1- (match-end which)))) - (setq bounds (cons start end)))))) - (when start - (if (not goto) - bounds - (let ((href-val (buffer-substring-no-properties start end))) - (mlinks-html-href-act-on href-val)) - t)))) - -(defun mlink-check-file-to-edit (file) - (assert (file-name-absolute-p file)) - (let ((file-dir (file-name-directory file))) - (unless (file-directory-p file-dir) - (if (file-directory-p (file-name-directory file)) - (if (yes-or-no-p (format "Directory %s does not exist. Create it? " file-dir)) - (make-directory file-dir) - (setq file nil)) - (if (yes-or-no-p (format "Directory %s and its parent does not exist. Create them? " file-dir)) - (make-directory file-dir t) - (setq file nil)))) - file)) - -(defun mlinks-html-edit-at (file &optional anchor) - (let ((abs-file (if (file-name-absolute-p file) - file - (expand-file-name file)))) - (if (or (file-directory-p abs-file) - (string= abs-file - (file-name-as-directory abs-file))) - (if (file-directory-p abs-file) - (when (y-or-n-p (format "Do you want to edit the directory %s? : " abs-file)) - (dired abs-file)) - (message "Can't find directory %s" abs-file)) - (when (mlink-check-file-to-edit abs-file) - (let ((b (find-file-noselect abs-file))) - (mlinks-switch-to-buffer b)) - (when anchor - (let ((here (point)) - (anchor-regexp (concat "\\(?:id\\|name\\)[[:space:]]*=[[:space:]]*\"" anchor "\""))) - (goto-char (point-min)) - (if (search-forward-regexp anchor-regexp nil t) - (backward-char 2) - (message "Anchor \"%s\" not found" anchor) - (goto-char here)))))))) - -(defun mlinks-html-mail-to (addr) - (browse-url addr)) - -(defun mlinks-html-href-act-on (href-val) - (if href-val - (let* ((possible (mlinks-html-possible-href-actions href-val)) - (edit (assoc 'edit possible)) - (file (nth 1 edit)) - (anchor (nth 2 edit)) - ) - (cond (edit - (mlinks-html-edit-at file anchor) - t) - ((assoc 'mailto possible) - (when (y-or-n-p "This is a mail address. Do you want to send a message to this mail address? ") - (mlinks-html-mail-to href-val))) - ((assoc 'view-web possible) - (when (y-or-n-p "Can't edit this URL, it is on the web. View the URL in your web browser? ") - (browse-url href-val))) - ((assoc 'view-web-base possible) - (when (y-or-n-p "Can't edit, based URL is to the web. View resulting URL in your web browser? ") - (browse-url (cdr (assoc 'view-web-base possible))))) - (t - (message "Do not know how to handle this URL")) - )) - (message "No value for href attribute"))) - -(defun mlinks-html-possible-href-actions (link) - (let ((urlobj (url-generic-parse-url link)) - (edit nil) - (possible nil)) - (cond ((member (url-type urlobj) '("http" "https")) - (add-to-list 'possible (cons 'view-web link))) - ((member (url-type urlobj) '("mailto")) - (add-to-list 'possible (cons 'mailto link))) - ((url-host urlobj) - (message "Do not know how to handle this URL")) - (t (setq edit t))) - (when edit - (let ((base-href (mlinks-html-find-base-href))) - (when base-href - (let ((baseobj (url-generic-parse-url base-href))) - (setq edit nil) - (cond ((member (url-type baseobj) '("http" "https")) - (add-to-list 'possible (cons 'view-web-base (url-expand-file-name link base-href)))) - ((url-host urlobj) - (message "Do not know how to handle this URL")) - (t (setq edit t))))) - (when edit - (let* ((full (split-string (url-filename urlobj) "#")) - (file (nth 0 full)) - (anchor (nth 1 full)) - ) - (when (equal file "") - (setq file (buffer-file-name))) - (when base-href - ;; We know at this point it is not a http url - (setq file (expand-file-name file base-href))) - (let ((ext (downcase (file-name-extension file)))) - (when (member ext '("htm" "html")) - (add-to-list 'possible (cons 'view-local (list file anchor)))) - (when (and (featurep 'gimpedit) - (member ext '("gif" "png" "jpg" "jpeg"))) - (add-to-list 'possible (cons 'edit-gimp (list file anchor))))) - (when (featurep 'html-upl) - (add-to-list 'possible (cons 'upload (list file anchor)))) - (add-to-list 'possible (cons 'edit (list file anchor))))))) - possible)) - -(defun mlinks-html-find-base-href () - "Return base href found in the current file." - (let ((base-href)) - (save-excursion - (goto-char (point-min)) - (while (and (not base-href) - (search-forward-regexp "<!--[^!]*-->\\|<base[[:space:]]" nil t)) - (when (equal " " (char-to-string (char-before))) - (backward-char 6) - (when (looking-at "<base [^>]*href *= *\"\\(.*?\\)\"") - (setq base-href (match-string-no-properties 1)))))) - base-href)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;; Custom-mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun mlinks-elisp-custom-goto () - (mlinks-elisp-mode-fun 'custom)) - -(defvar mlinks-custom-link-regexp - (rx "`" - (group - (1+ (not (any "'")))) - "'")) - -(defun mlinks-custom-fontify (bound) - (mlinks-fontify bound mlinks-custom-link-regexp 0)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;; emacs-lisp-mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun mlinks-elisp-goto () - (mlinks-elisp-mode-fun 'source)) - -(defun mlinks-elisp-hili () - (mlinks-elisp-mode-fun nil)) - -(defun mlinks-elisp-mode-fun (goto) - (let ((symbol-name (thing-at-point 'symbol))) - (when symbol-name - (let ((bounds-- (bounds-of-thing-at-point 'symbol)) - ret--) - (if (save-excursion - (goto-char (cdr bounds--)) - (looking-back (concat "(\\(?:require\\|featurep\\)\s+'" symbol-name) - (line-beginning-position))) - (progn - (setq ret-- bounds--) - (when goto - (mlinks-elisp-mode-require symbol-name))) - (when (mlinks-elisp-mode-symbol symbol-name goto) - (setq ret-- bounds--))) - ret--)))) - -(defun mlinks-elisp-function (symbol) - "Go to an elisp function." - (interactive "aElisp function: ") - (mlinks-elisp-mode-symbol (symbol-name symbol) 'source)) - -(defun mlinks-elisp-mode-symbol (symbol-name-- goto--) - ;; Fix-me: use uninterned variables (see mail from Miles) - ;; Make these names a bit strange because they are boundp at the time of checking: - (let ((symbol-- (intern-soft symbol-name--)) - defs--) - (when (and symbol-- (boundp symbol--)) - (add-to-list 'defs-- 'variable)) - (when (fboundp symbol--) - (add-to-list 'defs-- 'function)) - (when (facep symbol--) - (add-to-list 'defs-- 'face)) - ;; Avoid some fails hits - (when (memq symbol-- - '(goto t - bounds-- funs-- ret-- - symbol-- defs-- symbol-name-- goto--)) - (setq defs-- nil)) - (let (defs-places - def) - (if (not goto--) - (progn - defs--) - (if (not defs--) - (progn - (message "Could not find definition of '%s" symbol-name--) - nil) - (dolist (type (cond - ((eq goto-- 'source) - '(nil defvar defface)) - ((eq goto-- 'custom) - '(defvar defface)) - (t - (error "Bad goto-- value: %s" goto--)))) - (condition-case err - (add-to-list 'defs-places - (cons - type - (save-excursion - (let* ((bp (find-definition-noselect symbol-- type)) - (b (car bp)) - (p (cdr bp))) - (unless p - (with-current-buffer b - (save-restriction - (widen) - (setq bp (find-definition-noselect symbol-- type))))) - bp)))) - (error - ;;(lwarn '(mlinks) :error "%s" (error-message-string err)) - (when t - (cond - ((eq (car err) 'search-failed)) - ((and (eq (car err) 'error) - (string= (error-message-string err) - (format "Don't know where `%s' is defined" symbol--)))) - (t - (message "%s: %s" (car err) (error-message-string err)))))))) - (if (= 1 (length defs-places)) - (setq def (car defs-places)) - (let ((many nil) - lnk) - (dolist (d defs-places) - (if (not lnk) - (setq lnk (cdr d)) - (unless (equal lnk (cdr d)) - (setq many t)))) - (if (not many) - (setq def (car defs-places)) - (let* ((alts (mapcar (lambda (elt) - (let ((type (car elt)) - str) - (setq str - (cond - ((not type) - "Function") - ((eq type 'defvar) - "Variable") - ((eq type 'defface) - "Face"))) - (cons str elt))) - defs-places)) - (stralts (mapcar (lambda (elt) - (car elt)) - alts)) - (completion-ignore-case t) - (stralt (completing-read "Type: " stralts nil t)) - (alt (assoc stralt alts))) - (setq def (cdr alt)))))) - (when def - (cond - ((eq goto-- 'source) - ;; Be sure to go to the real sources from CVS: - (let* ((buf (car (cdr def))) - ;; Avoid going to source - ;;(file (find-source-lisp-file (with-current-buffer buf buffer-file-name)) ) - (file (with-current-buffer buf buffer-file-name)) - (orig-buf (find-file-noselect file))) - (mlinks-switch-to-buffer orig-buf) - (let ((p (cdr (cdr def)))) - ;; Fix-me: Move this test to a more general place. - (if (or (< p (point-min)) - (> p (point-max))) - ;; Check for cloned indirect buffers. - (progn - (setq orig-buf - (catch 'view-in-buf - (dolist (indirect-buf (buffer-list)) - ;;(message "base-buffer=%s, orig-buf=%s, eq => %s" (buffer-base-buffer indirect-buf) orig-buf (eq (buffer-base-buffer indirect-buf) orig-buf)) - (when (eq (buffer-base-buffer indirect-buf) orig-buf) - (with-current-buffer indirect-buf - ;;(message "indirect-buf=%s" indirect-buf) - (unless (or (< p (point-min)) - (> p (point-max))) - ;;(message "switching") - ;;(mlinks-switch-to-buffer indirect-buf) - (message "mlinks: Switching to indirect buffer because of narrowing") - (throw 'view-in-buf indirect-buf) - )) - )))) - (when orig-buf - (mlinks-switch-to-buffer orig-buf)) - ;;(message "cb=%s" (current-buffer)) - (if (or (< p (point-min)) - (> p (point-max))) - (when (y-or-n-p (format "%s is invisible because of narrowing. Widen? " symbol--)) - (widen) - (goto-char p)) - (goto-char p))) - (goto-char p))))) - ((eq goto-- 'custom) - (mlinks-custom symbol--)) - (t - (error "Back goto-- value again: %s" goto--))))))))) - -(defun mlinks-elisp-mode-require (module) - (let ((where mlinks-temp-buffer-where)) - (cond - ((null where) - (find-library module)) - ((eq where 'other-window) - (other-window 1) - (find-library module)) - ((eq where 'other-frame) - (make-frame-command) - (find-library module)) - (t - (error "Invalid argument, where=%s" where))))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;; Helpers when adopting for modes ;;;;;;;;;;;;;;;;; - -;;; Save this, do not delete this comment: - -;; (defun mlinks-hit-test () -;; "Just a helper function for adding support for new modes." -;; (let* ( -;; (s0 (if (match-string 0) (match-string 0) "")) -;; (s1 (if (match-string 1) (match-string 1) "")) -;; (s2 (if (match-string 2) (match-string 2) "")) -;; (s3 (if (match-string 3) (match-string 3) "")) -;; ) -;; (message "match0=%s, match1=%s, match2=%s, match3=%s" s0 s1 s2 s3))) - -;; (defun mlinks-handle-reg-fun-list (reg-fun-list) -;; "Just a helper function." -;; (let (done -;; regexp -;; hitfun -;; m -;; p -;; b -;; ) -;; (dolist (rh reg-fun-list) -;; (message "rh=%s" rh);(sit-for 2) -;; (unless done -;; (setq regexp (car rh)) -;; (setq hitfun (cadr rh)) -;; (message "regexp=%s, hitfun=%s" regexp hitfun);(sit-for 1) -;; (when (and (save-match-data -;; (setq m (re-search-backward regexp (line-beginning-position) t)) -;; (> p (match-beginning 0)))) -;; (setq done t) -;; (setq b (match-beginning 0)) -;; (setq e (match-end 0)) -;; ) -;; (if (not (and b e -;; (< b p) -;; (< p e))) -;; (message "MLinks Mode did not find any link here") -;; (goto-char b) -;; (if (not (looking-at regexp)) -;; (error "Internal error, regexp %s, no match looking-at" regexp) -;; (let ((last (car mlinks-places)) -;; (m (make-marker))) -;; (set-marker m (line-beginning-position)) -;; (when (or (not last) -;; (/= m last)) -;; (setq mlinks-places (cons m mlinks-places)))) -;; (funcall hitfun)) -;; ))))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Font Lock use - -(defvar mlinks-link-update-pos-max nil) -(make-variable-buffer-local 'mlinks-link-update-pos-max) -(put 'mlinks-link-update-pos-max 'permanent-local t) - -(defun mlinks-remove-font-lock () - "Remove info from font-lock." - (when (mlinks-want-font-locking) - (mlink-font-lock nil))) - -(defun mlinks-add-font-lock () - "Add info to font-lock." - (when (mlinks-want-font-locking) - (mlink-font-lock t))) - -(defun mlinks-want-font-locking () - (or (mlinks-get-mode-value 'fontify) - (mlinks-get-mode-value 'next-mark))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Font Lock integration - -(defun mlink-font-lock (on) - (let* ((add-or-remove (if on 'font-lock-add-keywords 'font-lock-remove-keywords)) - (fontify-fun (car (mlinks-get-mode-value 'fontify))) - (args (list nil `(( ,fontify-fun ( 0 mlinks-font-lock-face t )))))) - (when fontify-fun - ;; Note: Had a lot of trouble with this which I modelled first - ;; after dlink. Using hi-lock as a model made it work with - ;; mumamo too. - ;; - ;; Next arg, HOW, is needed to get it to work with mumamo. This - ;; adds it last, like hi-lock. - (when on (setq args (append args (list t)))) - (apply add-or-remove args) - (font-lock-mode -1) - (font-lock-mode 1)))) - -(defun mlinks-html-fontify (bound) - (mlinks-fontify bound mlinks-html-link-regexp 1)) - -(defun mlinks-fontify (bound regexp border) - (let ((start (point)) - end-start - stop next-stop - (more t) - old-beg old-end - (wn 1) - ret) - ;; Note: we shouldnot use save-match-data here. Instead - ;; set-match-data is called below! - (if (not (re-search-forward regexp bound t)) - (setq end-start bound) - (setq ret t) - (setq end-start (- (point) 2)) - (let* ((which (if (match-beginning 1) 1 2)) - (beg (+ (match-beginning which) border)) - (end (- (match-end which) border))) - (put-text-property beg end 'mlinks-link t) - (set-match-data (list (copy-marker end) (copy-marker beg))))) - (setq stop start) - (setq next-stop -1) - (while (and (> 100 (setq wn (1+ wn))) - (setq next-stop (next-single-char-property-change stop 'mlinks-link nil end-start)) - (/= next-stop stop)) - (setq stop next-stop) - (if (get-text-property stop 'mlinks-link) - (setq old-beg stop) - (when old-beg - (remove-list-of-text-properties old-beg stop '(mlinks-link 'mouse-face))))) - ret)) - -(defun mlinks-next-link () - "Find next link, fontify as necessary." - (let* ((here (point)) - (prev-pos (point)) - (fontified-here (get-text-property (max (point-min) (1- prev-pos)) 'fontified)) - (fontified-to (next-single-char-property-change prev-pos 'fontified)) - (pos (next-single-char-property-change prev-pos 'mlinks-link nil - (or fontified-to (point-max)))) - (fontified-all (and fontified-here (not fontified-to))) - ready - next-fontified-to) - (while (not (or ready - (and fontified-all - (not pos)))) - (if pos - (progn - (unless (get-text-property pos 'mlinks-link) - ;; Get to next link - (setq prev-pos pos) - (setq pos (next-single-char-property-change prev-pos 'mlinks-link nil - (or fontified-to (point-max))))) - (when pos - (setq ready (get-text-property pos 'mlinks-link)) - (setq prev-pos pos) - (unless ready (setq pos nil)))) - (unless (or fontified-all fontified-to) - (if (get-text-property prev-pos 'fontified) - (setq fontified-all - (not (setq fontified-to - (next-single-char-property-change prev-pos 'fontified)))) - (setq fontified-to ( or (previous-single-char-property-change prev-pos 'fontified) - 1)))) - (setq next-fontified-to (min (+ fontified-to 5000) - (point-max))) - (mumamo-with-buffer-prepared-for-jit-lock - (progn - (put-text-property fontified-to next-fontified-to 'fontified t) - (font-lock-fontify-region fontified-to next-fontified-to))) - (setq fontified-to (next-single-char-property-change (1- next-fontified-to) - 'fontified)) - (setq fontified-all (not fontified-to)) - (setq pos (next-single-char-property-change prev-pos 'mlinks-link nil - (or fontified-to (point-max)))))) - (when ready prev-pos))) - -(defun mlinks-prev-link () - "Find previous link, fontify as necessary." - (let* ((prev-pos (point)) - (fontified-from (previous-single-char-property-change prev-pos 'fontified)) - (fontified-here (get-text-property (max (point-min) (1- prev-pos)) 'fontified)) - (fontified-all (and fontified-here (not fontified-from))) - (pos (when fontified-here - (previous-single-char-property-change prev-pos 'mlinks-link nil - (or fontified-from 1)))) - ready - next-fontified-from) - (while (not (or ready - (and fontified-all - (not pos)))) - (assert (numberp prev-pos) t) - (if pos - (progn - (when (and (> (1- pos) (point-min)) - (get-text-property (1- pos) 'mlinks-link)) - ;; Get out of current link - (setq prev-pos pos) - (setq pos (previous-single-char-property-change prev-pos 'mlinks-link nil - (or fontified-from 1)))) - (when pos - (setq prev-pos pos) - (setq ready (and (get-text-property pos 'fontified) - (or (= 1 pos) - (not (get-text-property (1- pos) 'mlinks-link))) - (get-text-property pos 'mlinks-link))) - (unless ready (setq pos nil)))) - (setq next-fontified-from (max (- fontified-from 5000) - (point-min))) - (mumamo-with-buffer-prepared-for-jit-lock - (progn - (put-text-property next-fontified-from fontified-from 'fontified t) - (font-lock-fontify-region next-fontified-from fontified-from))) - (setq fontified-from (previous-single-char-property-change - (1+ next-fontified-from) 'fontified)) - (setq fontified-all (not fontified-from)) - (setq pos (previous-single-char-property-change prev-pos 'mlinks-link nil - (or fontified-from 1))))) - (when ready pos))) - - -;;; This is for the problem reported by some Asian users: -;;; -;;; Lisp error: (invalid-read-syntax "] in a list") -;;; -;; Local Variables: -;; coding: utf-8 -;; End: - -(provide 'mlinks) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; mlinks.el ends here diff --git a/emacs.d/nxhtml/util/mumamo-aspnet.el b/emacs.d/nxhtml/util/mumamo-aspnet.el deleted file mode 100644 index c6bb2c7..0000000 --- a/emacs.d/nxhtml/util/mumamo-aspnet.el +++ /dev/null @@ -1,227 +0,0 @@ -;;; mumamo-aspnet.el --- Support for ASP .Net in `mumamo-mode'. -;; -;;;;; John: Please change here to what you want: -;; Author: John J Foerch (jjfoerch A earthlink O net) -;; Maintainer: -;; Created: ?? -;; Version: == -;; Last-Updated: Wed Dec 12 21:55:11 2007 (3600 +0100) -;; URL: http://OurComments.org/Emacs/Emacs.html -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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, 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Support for ASP .Net in `mumamo-mode'. If you want to use VB then -;; you have to get the vb mode that this is written for here: -;; -;; http://www.emacswiki.org/cgi-bin/wiki/VbDotNetMode -;; -;; A C# mode is already included in nXhtml. That is the one that this -;; library has been tested with. -;; -;; -;;; Usage: -;; -;; Put this file in you Emacs `load-path' and add in your .emacs: -;; -;; (eval-after-load 'mumamo -;; (require 'mumamo-aspnet) -;; (mumamo-aspnet-add-me)) -;; -;; A file with the extension .aspx will no be opened with nxhtml-mode -;; as the main major mode and with chunks in csharp-mode etc. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(eval-when-compile (require 'mumamo)) - -;;; - -;; (defun mumamo-aspnet-add-me() -;; "Make mumamo aware of the ASP.Net extension." -;; (add-to-list 'mumamo-chunk-family-list -;; '("ASP.Net nXhtml Family" nxhtml-mode -;; (mumamo-chunk-aspnet -;; mumamo-chunk-aspnet-script -;; mumamo-chunk-inlined-style -;; mumamo-chunk-inlined-script -;; mumamo-chunk-style= -;; mumamo-chunk-onjs= -;; )) -;; t) -;; (add-to-list 'mumamo-chunk-family-list -;; '("ASP.Net XHTML Family" html-mode -;; (mumamo-chunk-aspnet -;; mumamo-chunk-aspnet-script -;; mumamo-chunk-inlined-style -;; mumamo-chunk-inlined-script -;; mumamo-chunk-style= -;; mumamo-chunk-onjs= -;; )) -;; t) - - -;; (add-to-list 'mumamo-filenames-list -;; '("\\.aspx\\'" "ASP.Net nXhtml Family")) -;; ;; Make it SET for current session in Custom. -;; (customize-set-variable 'mumamo-filenames-list mumamo-filenames-list) -;; (customize-set-value 'mumamo-filenames-list mumamo-filenames-list) - -;; ;; this is how to set up mode aliases, should we need them. -;; (add-to-list 'mumamo-major-modes '(csharp-mode csharp-mode)) -;; (add-to-list 'mumamo-major-modes '(vbnet-mode vbnet-mode)) -;; ;; Make it SET for current session in Custom. -;; (customize-set-variable 'mumamo-major-modes mumamo-major-modes) -;; (customize-set-value 'mumamo-major-modes mumamo-major-modes) -;; ) - - -;;; aspnet - -(defvar mumamo-aspnet-page-language-mode-spec nil - "A mumamo mode-spec for the default language of an ASP.Net page. -This is what is set with the directive `@ Page Language' on the -page. - -Internal variable.") -(make-variable-buffer-local 'mumamo-aspnet-page-language-mode-spec) -;;(add-to-list 'mumamo-survive 'mumamo-aspnet-page-language-mode-spec) -(put 'mumamo-aspnet-page-language-mode-spec 'permanent-local t) - -(defconst mumamo-aspnet-language-regex - (rx (0+ (not (any ">"))) - word-start "language" (0+ space) "=" (0+ space) ?\" (submatch (0+ (not (any ?\" ?>)))) ?\" - )) - -(defun mumamo-aspnet-get-page-language-mode-spec () - (or mumamo-aspnet-page-language-mode-spec - (save-excursion - (goto-char (point-min)) - (when (search-forward "<%@ Page") - (let ((case-fold-search t)) - (when (looking-at mumamo-aspnet-language-regex) - (mumamo-aspnet-mode-spec-for-language (match-string 1)))))) - 'fundamental-mode)) - -(defun mumamo-aspnet-get-mode-for-chunk (&optional chunk-type) - (cond ((eq chunk-type 'script) - (mumamo-get-major-mode-substitute - (or (if (looking-at mumamo-aspnet-language-regex) - (mumamo-aspnet-mode-spec-for-language (match-string 1)) - (mumamo-aspnet-get-page-language-mode-spec)) - 'fundamental-mode) - 'fontification)) - ((eq chunk-type 'directive) - 'fundamental-mode) - ;;(t (mumamo-mode-from-modespec - (t (mumamo-get-major-mode-substitute - (mumamo-aspnet-get-page-language-mode-spec) - 'fontification - )))) - - -(defun mumamo-chunk-aspnet(pos min max) - "Find <% ... %>." - (mumamo-find-possible-chunk pos min max - 'mumamo-search-bw-exc-start-aspnet - 'mumamo-search-bw-exc-end-jsp - 'mumamo-search-fw-exc-start-jsp - 'mumamo-search-fw-exc-end-jsp)) - -(defun mumamo-search-bw-exc-start-aspnet(pos min) - ;;(let ((exc-start (mumamo-search-bw-exc-start-str pos min "<%"))) - (let ((exc-start (mumamo-chunk-start-bw-str pos min "<%"))) - (when (and exc-start - (<= exc-start pos)) - (cons exc-start - (mumamo-aspnet-get-mode-for-chunk - (if (eq (char-after exc-start) ?@) - 'directive)))))) - -(defconst mumamo-aspnet-script-tag-start-regex - (rx "<script" word-end - (0+ (not (any ">"))) - word-start "runat" (0+ space) "=" (0+ space) ?\" "server" ?\" - (0+ (not (any ">"))) - ">" - )) - -(defun mumamo-aspnet-mode-spec-for-language (language) - (let ((language (downcase language))) - (cond ((equal language "c#") 'csharp-mode) - ((equal language "vb") 'vbnet-mode) - (t 'fundamental-mode)))) - -(defun mumamo-search-bw-exc-start-aspnet-script(pos min) - (goto-char (+ pos 7)) - (let ((marker-start (search-backward "<script" min t)) - exc-mode - exc-start) - (when marker-start - (when (looking-at mumamo-aspnet-script-tag-start-regex) - (setq exc-start (match-end 0)) - (setq exc-mode (mumamo-aspnet-get-mode-for-chunk 'script)) - (goto-char exc-start) - (when (<= exc-start pos) - (cons (point) exc-mode)))))) - -(defun mumamo-search-fw-exc-start-aspnet-script(pos max) - (goto-char (1+ pos)) - (skip-chars-backward "^<") - ;; Handle <![CDATA[ - (when (and - (eq ?< (char-before)) - (eq ?! (char-after)) - (not (bobp))) - (backward-char) - (skip-chars-backward "^<")) - (unless (bobp) - (backward-char 1)) - (let ((exc-start (search-forward "<script" max t)) - exc-mode) - (when exc-start - (goto-char (- exc-start 7)) - (when (looking-at mumamo-aspnet-script-tag-start-regex) - (goto-char (match-end 0)) - (point) - )))) - -(defun mumamo-chunk-aspnet-script(pos min max) - "Find inlined script, <script runat=\"server\">...</script>." - (mumamo-find-possible-chunk pos min max - 'mumamo-search-bw-exc-start-aspnet-script - 'mumamo-search-bw-exc-end-inlined-script - 'mumamo-search-fw-exc-start-aspnet-script - 'mumamo-search-fw-exc-end-inlined-script)) - -;; Fix-me: define a multi major mode for asp. Or maybe just drop this -;; file? - -(provide 'mumamo-aspnet) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; mumamo-aspnet.el ends here diff --git a/emacs.d/nxhtml/util/mumamo-fun.el b/emacs.d/nxhtml/util/mumamo-fun.el deleted file mode 100644 index eb3c5c2..0000000 --- a/emacs.d/nxhtml/util/mumamo-fun.el +++ /dev/null @@ -1,3333 +0,0 @@ -;;; mumamo-fun.el --- Multi major mode functions -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-03-09T01:35:21+0100 Sun -;; Version: 0.51 -;; Last-Updated: 2008-08-04T17:54:29+0200 Mon -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; `backquote', `bytecomp', `cl', `flyspell', `ispell', `mumamo', -;; `sgml-mode'. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Defines some "multi major modes" functions. See mumamo.el for more -;; information. -;; -;;;; Usage: -;; -;; See mumamo.el for how to use the multi major mode functions -;; defined here. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'cl)) -(eval-when-compile (add-to-list 'load-path default-directory)) -(eval-when-compile (require 'mumamo)) -(eval-when-compile (require 'sgml-mode)) -;;(mumamo-require) - -;;;#autoload -;;(defun mumamo-fun-require ()) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; File wide key bindings - -(defun mumamo-multi-mode-map () - "Return mumamo multi mode keymap." - (symbol-value - (intern-soft (concat (symbol-name mumamo-multi-major-mode) "-map")))) - -;; (defun mumamo-multi-mode-hook-symbol () -;; "Return mumamo multi mode hook symbol." -;; (intern-soft (concat (symbol-name mumamo-multi-major-mode) "-hook"))) - -;;;###autoload -(defun mumamo-define-html-file-wide-keys () - "Define keys in multi major mode keymap for html files." - (let ((map (mumamo-multi-mode-map))) - (define-key map [(control ?c) (control ?h) ?b] 'nxhtml-browse-file) - )) -;; (defun mumamo-add-html-file-wide-keys (hook) -;; (add-hook hook 'mumamo-define-html-file-wide-keys) -;; ) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Chunk search routines for XHTML things - -(defun mumamo-chunk-attr= (pos min max attr= attr=is-regex attr-regex submode) - "This should work similar to `mumamo-find-possible-chunk'. -See `mumamo-chunk-style=' for an example of use. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-chunk-attr=-new pos max attr= attr=is-regex attr-regex submode)) - -(defun mumamo-chunk-attr=-new-fw-exc-fun (pos max) - ;;(msgtrc "(mumamo-chunk-attr=-new-fw-exc-fun %s %s)" pos max) - (save-match-data - (let ((here (point)) - first-dq - next-dq - (this-chunk (mumamo-get-existing-new-chunk-at pos))) - (if this-chunk - (goto-char (overlay-end this-chunk)) - (goto-char (overlay-end mumamo-last-chunk))) - (setq first-dq (search-forward "\"" max t)) - (unless (bobp) - (backward-char) - (condition-case err - (with-syntax-table (standard-syntax-table) - (setq next-dq (scan-sexps (point) 1))) - (error nil))) - (prog1 - next-dq - (goto-char here))))) - -(defun mumamo-chunk-attr=-new-find-borders-fun (start-border end-border dummy) - ;;(setq borders (funcall find-borders-fun start-border end-border exc-mode)) - (save-match-data - (let ((here (point)) - (end2 (when end-border (1- end-border))) - start2) - (goto-char start-border) - (save-match-data - (setq start2 (search-forward "\"" (+ start-border 200) t))) - (goto-char here) - (list start2 end2)))) - -(defun mumamo-chunk-attr=-new (pos - ;;min - max - attr= - attr=is-regex - attr-regex - submode) - ;;(message "\n(mumamo-chunk-attr=-new %s %s %s %s %s %s)" pos max attr= attr=is-regex attr-regex submode) - ;;(mumamo-condition-case err - (condition-case err - (save-match-data - (let ((here (point)) - (next-attr= (progn - ;; fix-me: - (if (not attr=is-regex) - (goto-char (+ pos (length attr=))) - (goto-char pos) - (skip-chars-forward "a-zA-Z=")) - (goto-char pos) - (if attr=is-regex - (re-search-forward attr= max t) - (search-forward attr= max t)))) - next-attr-sure - ;;next-attr= - start start-border - end end-border - exc-mode - borders - exc-start-next - exc-end-next - exc-start-next - exc-end-next - (tries 0) - (min (1- pos)) - look-max - ) - ;; make sure if we have find prev-attr= or not - (unless (eq (char-after) ?\") - (setq next-attr= nil)) - (when next-attr= - (forward-char) - (skip-chars-forward "^\"") - (setq look-max (+ (point) 2))) - (while (and next-attr= - (< min (point)) - (not next-attr-sure) - (< tries 5)) - ;;(msgtrc "attr=-new: min=%s, point=%s" min (point)) - (setq tries (1+ tries)) - ;;(if (not (re-search-backward "<[^?]" (- min 300) t)) - (if (not (re-search-backward "<[^?]\\|\?>" (- min 300) t)) - (setq next-attr= nil) - ;;(if (looking-at attr-regex) - (if (let ((here (point))) - (prog1 - (re-search-forward attr-regex look-max t) - (goto-char here))) - ;;(if (mumamo-end-in-code (point) next-attr= 'php-mode) - (setq next-attr-sure 'found) - (unless (bobp) - (backward-char) - ;;(msgtrc "attr=-new 1: min=%s, point=%s" min (point)) - (setq next-attr= (if attr=is-regex - (re-search-backward attr= (- min 300) t) - (search-backward attr= (- min 300) t))))))) - (unless next-attr-sure (setq next-attr= nil)) - - - ;; find prev change and if inside style= the next change - (when next-attr= - (setq exc-start-next (match-beginning 1)) - (setq exc-end-next (match-end 2)) - (when (>= exc-start-next pos) - (if (> pos exc-end-next) - (progn - (setq start (+ (match-end 2) 1)) - ;;(setq start-border (+ (match-end 2) 2)) - ) - (setq exc-mode submode) - (setq start (match-beginning 1)) - (setq start-border (match-beginning 2)) - (setq end (1+ (match-end 2))) - (setq end-border (1- end))) - )) - ;; find next change - (unless end - (if start - (goto-char start) - (goto-char pos) - (search-backward "<" min t)) - ;;(msgtrc "attr=-new 2: min=%s, point=%s" min (point)) - (setq next-attr= (if attr=is-regex - (re-search-forward attr= max t) - (search-forward attr= max t))) - (when (and next-attr= - (search-backward "<" min t)) - (when (looking-at attr-regex) - (setq end (match-beginning 1))))) - (when start (assert (>= start pos) t)) - (when end (assert (<= pos end) t)) - ;;(message "start-border=%s end-border=%s" start-border end-border) - (when (or start-border end-border) - (setq borders (list start-border end-border nil))) - ;; (message "mumamo-chunk-attr=-new: %s" - ;; (list start - ;; end - ;; exc-mode - ;; borders - ;; nil ;; parseable-by - ;; 'mumamo-chunk-attr=-new-fw-exc-fun ;; fw-exc-fun - ;; 'mumamo-chunk-attr=-new-find-borders-fun ;; find-borders-fun - ;; )) - (goto-char here) - (setq end nil) - (when (or start end) - (list start - end - exc-mode - borders - nil ;; parseable-by - 'mumamo-chunk-attr=-new-fw-exc-fun ;; fw-exc-fun - 'mumamo-chunk-attr=-new-find-borders-fun ;; find-borders-fun - )))) - (error (mumamo-display-error 'mumamo-chunk-attr=-new "%s" (error-message-string err))) - )) - -;;;; xml pi - -(defvar mumamo-xml-pi-mode-alist - '(("php" . php-mode) - ("python" . python-mode)) - "Alist used by `mumamo-chunk-xml-pi' to get exception mode." ) - -;; Fix-me: make it possible to make the borders part of the php chunk -;; so that parsing of them by nxml may be skipped. Or, rather if the -;; borders are not part of the chunk then assume nxml can not parse -;; the chunk and the borders. -;; (defun mumamo-search-bw-exc-start-xml-pi-1 (pos min lt-chars) -;; "Helper for `mumamo-chunk-xml-pi'. -;; POS is where to start search and MIN is where to stop. -;; LT-CHARS is just <?. - -;; Actual use is in `mumamo-search-bw-exc-start-xml-pi'." -;; (let ((exc-start (mumamo-chunk-start-bw-str (+ pos 2) min lt-chars)) -;; spec -;; exc-mode -;; hit) -;; (when exc-start -;; (goto-char exc-start) -;; (when (and (not (looking-at "xml")) -;; (looking-at (rx (0+ (any "a-z"))))) -;; ;; (setq exc-start (match-end 0)) include it in sub chunk instead -;; (setq exc-start (- exc-start 2)) -;; (setq spec (match-string-no-properties 0)) -;; (setq exc-mode (assoc spec mumamo-xml-pi-mode-alist)) -;; (when exc-mode (setq exc-mode (cdr exc-mode))) -;; (setq hit t) -;; ) -;; (when hit -;; (unless exc-mode -;; ;;(setq exc-mode 'fundamental-mode) -;; ;; Fix-me: Better assume php-mode -;; (setq exc-mode 'php-mode)) -;; (when (<= exc-start pos) -;; ;;(cons exc-start exc-mode) -;; (list exc-start exc-mode nil) -;; ))))) - -;; (defun mumamo-search-bw-exc-start-xml-pi (pos min) -;; "Helper for `mumamo-chunk-xml-pi'. -;; POS is where to start search and MIN is where to stop." -;; (mumamo-search-bw-exc-start-xml-pi-1 pos min "<?")) - -(defun mumamo-search-fw-exc-start-xml-pi-new (pos max) - (let ((here (point)) - start - spec - exc-mode - ret) - (setq start (search-forward "<?" max t)) - (when (and start - (looking-at (rx (0+ (any "a-z"))))) - (setq spec (match-string-no-properties 0)) - (unless (string= spec "xml") - (when (= 0 (length spec)) - (setq spec "php")) - (setq exc-mode (assoc spec mumamo-xml-pi-mode-alist)) - (if exc-mode - (setq exc-mode (cdr exc-mode)) - (setq exc-mode 'mumamo-bad-mode)) - (setq ret (list (- start 2) exc-mode nil)))) - (goto-char here) - ret)) - -(defun mumamo-xml-pi-end-is-xml-end (pos) - "Return t if the ?> at pos is end of <?xml." - (when (> 1000 pos) -;;; (assert (and (= (char-after pos) ??) -;;; (= (char-after (1+ pos)) ?>))) - (save-excursion - (save-restriction - (widen) - (save-match-data - (when (search-backward "<" (- pos 150) t) - (when (looking-at (rx line-start "<\?xml" (1+ space))) - (mumamo-msgfntfy "mumamo-xml-pi-end-is-xml-end %s => t" pos) - t))))))) - -;; (defun mumamo-search-bw-exc-end-xml-pi (pos min) -;; "Helper for `mumamo-chunk-xml-pi'. -;; POS is where to start search and MIN is where to stop." -;; ;; Fix me: merge xml header -;; (mumamo-msgfntfy "mumamo-search-bw-exc-end-xml-pi %s %s" pos min) -;; ;;(let ((end-pos (mumamo-chunk-end-bw-str pos min "?>"))) -;; (let ((end-pos (mumamo-chunk-end-bw-str-inc pos min "?>"))) -;; (mumamo-msgfntfy " end-pos=%s" end-pos) -;; (when end-pos -;; (unless (or (mumamo-xml-pi-end-is-xml-end end-pos) -;; (= (save-restriction -;; (widen) -;; (char-after (- end-pos 1))) -;; ?<)) -;; (mumamo-msgfntfy " returning end-pos") -;; end-pos)))) - -(defun mumamo-search-fw-exc-end-xml-pi (pos max) - "Helper for `mumamo-chunk-xml-pi'. -POS is where to start search and MAX is where to stop." - ;; Fix me: merge xml header - ;;(let ((end-pos (mumamo-chunk-end-fw-str pos max "?>"))) - (save-match-data - (let ((end-pos (mumamo-chunk-end-fw-str-inc pos max "?>"))) - (when end-pos - (unless (mumamo-xml-pi-end-is-xml-end end-pos) - end-pos))))) - -(defun mumamo-search-fw-exc-start-xml-pi-1 (pos max lt-chars) - "Helper for `mumamo-chunk-xml-pi'. -POS is where to start search and MAX is where to stop. - -Used in `mumamo-search-fw-exc-start-xml-pi'. For an explanation -of LT-CHARS see `mumamo-search-bw-exc-start-xml-pi-1'." - (goto-char pos) - (skip-chars-backward "a-zA-Z") - ;;(let ((end-out (mumamo-chunk-start-fw-str (point) max lt-chars))) - (let ((end-out (mumamo-chunk-start-fw-str-inc (point) max lt-chars)) - spec - exc-mode - hit) - (when (looking-at "xml") - (if t ;(= 1 pos) - (setq end-out (mumamo-chunk-start-fw-str-inc (1+ (point)) max lt-chars)) - (setq end-out nil))) - (when end-out - ;; Get end-out: - (if (looking-at (rx (0+ (any "a-z")))) - (progn - ;;(setq end-out (match-end 0)) - (setq end-out (- (match-beginning 0) 2)) - (setq spec (match-string-no-properties 0)) - (setq exc-mode (assoc spec mumamo-xml-pi-mode-alist)) - (if exc-mode - (setq exc-mode (cdr exc-mode)) - (setq exc-mode 'php-mode)) - (setq end-out (list end-out exc-mode nil)) - ) - (setq end-out nil)) - end-out))) - -(defun mumamo-search-fw-exc-start-xml-pi-old (pos max) - "Helper for `mumamo-chunk-xml-pi'. -POS is where to start search and MAX is where to stop." - (mumamo-search-fw-exc-start-xml-pi-1 pos max "<?")) - -;; Add a find-borders-fun here so that for example src="<?php some -;; code ?>" can be handled. -;; -;; Fix-me: Maybe generalize for other values than <?php -(defun mumamo-find-borders-xml-pi (start end exc-mode) - (let (start-border - end-border - (inc t) - ;;(begin-mark "<?php") - (begin-mark "<?") - (end-mark "?>") - (here (point))) - (if (and inc) ;; exc-mode) - (progn - (when start - ;;(setq start-border (+ start (length begin-mark))) - (goto-char (+ start (length begin-mark))) - (skip-chars-forward "=a-zA-Z") - (setq start-border (point)) - ) - (when end - (setq end-border - (- end (length end-mark))))) - (if (and (not inc) (not exc-mode)) - (progn - (when start - (setq start-border - (+ start (length end-mark)))) - (when end - (setq end-border (- end (length begin-mark))) - ;;(goto-char end) - ;;(skip-chars-forward "=a-zA-Z") - ;;(setq end-border (point)) - )))) - (goto-char here) - (when (or start-border end-border) - (list start-border end-border)))) - -(defun mumamo-chunk-xml-pi (pos min max) - "Find process instruction, <? ... ?>. Return range and wanted mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - ;; (mumamo-find-possible-chunk pos min max - ;; 'mumamo-search-bw-exc-start-xml-pi - ;; 'mumamo-search-bw-exc-end-xml-pi - ;; 'mumamo-search-fw-exc-start-xml-pi-old - ;; 'mumamo-search-fw-exc-end-xml-pi - ;; 'mumamo-find-borders-xml-pi) - (mumamo-possible-chunk-forward pos max - 'mumamo-search-fw-exc-start-xml-pi-new - 'mumamo-search-fw-exc-end-xml-pi - 'mumamo-find-borders-xml-pi)) - - -;;;; <style ...> - -(defconst mumamo-style-tag-start-regex - (rx "<style" - space - (0+ (not (any ">"))) - "type" - (0+ space) - "=" - (0+ space) - ?\" - "text/css" - ?\" - (0+ (not (any ">"))) - ">" - ;; FIX-ME: Commented out because of bug in Emacs - ;; - ;;(optional (0+ space) "<![CDATA[") - )) - -;; (defun mumamo-search-bw-exc-start-inlined-style (pos min) -;; "Helper for `mumamo-chunk-inlined-style'. -;; POS is where to start search and MIN is where to stop." -;; (goto-char (+ pos 6)) -;; (let ((marker-start (search-backward "<style" min t)) -;; exc-mode -;; exc-start) -;; (when marker-start -;; (when (looking-at mumamo-style-tag-start-regex) -;; (setq exc-start (match-end 0)) -;; (goto-char exc-start) -;; (when (<= exc-start pos) -;; ;;(cons (point) 'css-mode) -;; ;;(list (point) 'css-mode '(nxml-mode)) -;; ;; Fix-me: Kubica looping problem -;; (list (point) 'css-mode) -;; ) -;; )))) - -;; (defun mumamo-search-bw-exc-end-inlined-style (pos min) -;; "Helper for `mumamo-chunk-inlined-style'. -;; POS is where to start search and MIN is where to stop." -;; (mumamo-chunk-end-bw-str pos min "</style>")) - -;; (defun mumamo-search-fw-exc-start-inlined-style-old (pos max) -;; "Helper for `mumamo-chunk-inlined-style'. -;; POS is where to start search and MAX is where to stop." -;; (goto-char (1+ pos)) -;; (skip-chars-backward "^<") -;; ;; Handle <![CDATA[ -;; (when (and -;; (eq ?< (char-before)) -;; (eq ?! (char-after)) -;; (not (bobp))) -;; (backward-char) -;; (skip-chars-backward "^<")) -;; (unless (bobp) -;; (backward-char 1)) -;; (let ((exc-start (search-forward "<style" max t)) -;; exc-mode) -;; (when exc-start -;; (goto-char (- exc-start 6)) -;; (when (looking-at mumamo-style-tag-start-regex) -;; (goto-char (match-end 0)) -;; (point) -;; )))) - -(defun mumamo-search-fw-exc-end-inlined-style (pos max) - "Helper for `mumamo-chunk-inlined-style'. -POS is where to start search and MAX is where to stop." - (save-match-data - (mumamo-chunk-end-fw-str pos max "</style>"))) - -;; (defun mumamo-chunk-inlined-style-old (pos min max) -;; "Find <style>...</style>. Return range and 'css-mode. -;; See `mumamo-find-possible-chunk' for POS, MIN and MAX." -;; (mumamo-find-possible-chunk pos min max -;; 'mumamo-search-bw-exc-start-inlined-style -;; 'mumamo-search-bw-exc-end-inlined-style -;; 'mumamo-search-fw-exc-start-inlined-style-old -;; 'mumamo-search-fw-exc-end-inlined-style)) - -(defun mumamo-search-fw-exc-start-inlined-style (pos max) - "Helper for `mumamo-chunk-inlined-style'. -POS is where to start search and MAX is where to stop." - (goto-char (1+ pos)) - (skip-chars-backward "^<") - ;; Handle <![CDATA[ - (when (and - (eq ?< (char-before)) - (eq ?! (char-after)) - (not (bobp))) - (backward-char) - (skip-chars-backward "^<")) - (unless (bobp) - (backward-char 1)) - (let ((exc-start (search-forward "<style" max t)) - exc-mode) - (when exc-start - (goto-char (- exc-start 6)) - (when (looking-at mumamo-style-tag-start-regex) - (goto-char (match-end 0)) - (list (point) 'css-mode nil) - )))) - -(defun mumamo-chunk-inlined-style (pos min max) - "Find <style>...</style>. Return range and 'css-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-possible-chunk-forward pos max - 'mumamo-search-fw-exc-start-inlined-style - 'mumamo-search-fw-exc-end-inlined-style)) - -;;;; <script ...> - -(defconst mumamo-script-tag-start-regex - (rx "<script" - space - (0+ (not (any ">"))) - "type" - (0+ space) - "=" - (0+ space) - ?\" - ;;(or "text" "application") - ;;"/" - ;;(or "javascript" "ecmascript") - "text/javascript" - ?\" - (0+ (not (any ">"))) - ">" - ;; FIX-ME: Commented out because of bug in Emacs - ;; - ;;(optional (0+ space) "<![CDATA[" ) - )) - -;; (defun mumamo-search-bw-exc-start-inlined-script (pos min) -;; "Helper for `mumamo-chunk-inlined-script'. -;; POS is where to start search and MIN is where to stop." -;; (goto-char (+ pos 7)) -;; (let ((marker-start (when (< min (point)) (search-backward "<script" min t))) -;; exc-mode -;; exc-start) -;; (when marker-start -;; (when (looking-at mumamo-script-tag-start-regex) -;; (setq exc-start (match-end 0)) -;; (goto-char exc-start) -;; (when (<= exc-start pos) -;; ;;(cons (point) 'javascript-mode) -;; (list (point) 'javascript-mode '(nxml-mode)) -;; ) -;; )))) - -;; (defun mumamo-search-bw-exc-end-inlined-script (pos min) -;; "Helper for `mumamo-chunk-inlined-script'. -;; POS is where to start search and MIN is where to stop." -;; (mumamo-chunk-end-bw-str pos min "</script>")) - -;; (defun mumamo-search-fw-exc-start-inlined-script-old (pos max) -;; "Helper for `mumamo-chunk-inlined-script'. -;; POS is where to start search and MAX is where to stop." -;; (goto-char (1+ pos)) -;; (skip-chars-backward "^<") -;; ;; Handle <![CDATA[ -;; (when (and -;; (eq ?< (char-before)) -;; (eq ?! (char-after)) -;; (not (bobp))) -;; (backward-char) -;; (skip-chars-backward "^<")) -;; (unless (bobp) -;; (backward-char 1)) -;; (let ((exc-start (search-forward "<script" max t)) -;; exc-mode) -;; (when exc-start -;; (goto-char (- exc-start 7)) -;; (when (looking-at mumamo-script-tag-start-regex) -;; (goto-char (match-end 0)) -;; (point) -;; )))) - -(defun mumamo-search-fw-exc-end-inlined-script (pos max) - "Helper for `mumamo-chunk-inlined-script'. -POS is where to start search and MAX is where to stop." - (save-match-data - (mumamo-chunk-end-fw-str pos max "</script>"))) - -;; (defun mumamo-chunk-inlined-script-old (pos min max) -;; "Find <script>...</script>. Return range and 'javascript-mode. -;; See `mumamo-find-possible-chunk' for POS, MIN and MAX." -;; (mumamo-find-possible-chunk pos min max -;; 'mumamo-search-bw-exc-start-inlined-script -;; 'mumamo-search-bw-exc-end-inlined-script -;; 'mumamo-search-fw-exc-start-inlined-script-old -;; 'mumamo-search-fw-exc-end-inlined-script)) - -(defun mumamo-search-fw-exc-start-inlined-script (pos max) - "Helper for `mumamo-chunk-inlined-script'. -POS is where to start search and MAX is where to stop." - (goto-char (1+ pos)) - (skip-chars-backward "^<") - ;; Handle <![CDATA[ - (when (and - (eq ?< (char-before)) - (eq ?! (char-after)) - (not (bobp))) - (backward-char) - (skip-chars-backward "^<")) - (unless (bobp) - (backward-char 1)) - (let ((exc-start (search-forward "<script" max t)) - exc-mode) - (when exc-start - (goto-char (- exc-start 7)) - (when (looking-at mumamo-script-tag-start-regex) - (goto-char (match-end 0)) - (list (point) 'javascript-mode '(nxml-mode)) - )))) - -(defun mumamo-chunk-inlined-script (pos min max) - "Find <script>...</script>. Return range and 'javascript-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-possible-chunk-forward pos max - 'mumamo-search-fw-exc-start-inlined-script - 'mumamo-search-fw-exc-end-inlined-script)) - -;;;; on[a-z]+=\"javascript:" - -(defconst mumamo-onjs=-attr= - (rx - ;;"on[a-z]+=" - (or "onclick" "ondblclick" "onmousedown" "onmousemove" "onmouseout" "onmouseover" "onmouseup" "onkeydown" "onkeypress" "onkeyup") - "=")) - -(defconst mumamo-onjs=-attr-regex - (rx point - (or "<" "?>") - (* (not (any ">"))) - space - (submatch - ;;"on" (1+ (any "a-za-z")) - (or "onclick" "ondblclick" "onmousedown" "onmousemove" "onmouseout" "onmouseover" "onmouseup" "onkeydown" "onkeypress" "onkeyup") - "=") - (0+ space) - ?\" - (submatch - (opt "javascript:") - (0+ - (not (any "\"")))) - )) - -(defun mumamo-chunk-onjs=(pos min max) - "Find javascript on...=\"...\". Return range and 'javascript-mode." - (mumamo-chunk-attr= pos min max mumamo-onjs=-attr= t mumamo-onjs=-attr-regex - 'javascript-mode)) - -;;;; py:somthing=\"python\" - -(defconst mumamo-py:=-attr= "py:[a-z]+=") - -(defconst mumamo-py:=-attr-regex - (rx point - (or "<" "?>") - (* (not (any ">"))) - space - (submatch - "py:" (1+ (any "a-za-z")) - "=") - (0+ space) - ?\" - (submatch - (0+ - (not (any "\"")))) - )) - -(defun mumamo-chunk-py:=(pos min max) - "Find python py:...=\"...\". Return range and 'python-mode." - (mumamo-chunk-attr= pos min max mumamo-py:=-attr= t mumamo-py:=-attr-regex - 'python-mode)) - -(defun mumamo-chunk-py:match (pos min max) - (save-match-data - (let ((here (point)) - (py:match (progn - (goto-char pos) - (re-search-forward (rx "py:match" - (1+ space) - (0+ (not (any ">"))) - word-start - (submatch "path=") - (0+ space) - ?\" - (submatch - (0+ - (not (any "\""))))) - max t))) - start end borders - ) - (when py:match - (setq start (match-beginning 1)) - (setq end (match-end 2)) - (setq borders (list (match-end 1) (1- end))) - ) - (goto-char here) - (when start - (list start - end - 'python-mode - borders - nil ;; parseable-by - 'mumamo-chunk-attr=-new-fw-exc-fun ;; fw-exc-fun - 'mumamo-chunk-attr=-new-find-borders-fun ;; find-borders-fun - ))))) - -;;;; style= - -(defconst mumamo-style=start-regex - (rx "<" - (0+ (not (any ">"))) - space - (submatch "style=") - (0+ space) - ?\" - (submatch - (0+ - (not (any "\"")))) - )) - -(defun mumamo-chunk-style=(pos min max) - "Find style=\"...\". Return range and 'css-mode." - (mumamo-chunk-attr= pos min max "style=" nil mumamo-style=start-regex - 'css-mode)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; HTML w html-mode - -(put 'mumamo-alt-php-tags-mode 'permanent-local t) -(define-minor-mode mumamo-alt-php-tags-mode - "Minor mode for using '(?php' instead of '<?php' in buffer. -When turning on this mode <?php is replace with (?php in the buffer. -If you write the buffer to file (?php is however written as <?php. - -When turning off this mode (?php is replace with <?php in the buffer. - -The purpose of this minor mode is to work around problems with -using the `nxml-mode' parser in php files. `nxml-mode' knows -damned well that you can not have the character < in strings and -I can't make it forget that. For PHP programmers it is however -very convient to use <?php ... ?> in strings. - -There is no reason to use this minor mode unless you want XML -validation and/or completion in your php file. If you do not -want that then you can simply use a multi major mode based on -`html-mode' instead of `nxml-mode'/`nxhtml-mode'. Or, of course, -just `php-mode' if there is no html code in the file." - :lighter "<?php " - (if mumamo-alt-php-tags-mode - (progn - ;;(unless mumamo-multi-major-mode (error "Only for mumamo multi major modes")) - (unless (let ((major-mode (mumamo-main-major-mode))) - (derived-mode-p 'nxml-mode)) - ;;(error "Mumamo multi major mode must be based on nxml-mode") - ) - (unless (memq 'mumamo-chunk-alt-php (caddr mumamo-current-chunk-family)) - (error "Mumamo multi major must have chunk function mumamo-chunk-alt-php")) - - ;; Be paranoid about the file/content write hooks - (when (<= emacs-major-version 22) - (with-no-warnings - (when local-write-file-hooks ;; obsolete, but check! - (error "Will not do this because local-write-file-hooks is non-nil")))) - (remove-hook 'write-contents-functions 'mumamo-alt-php-write-contents t) - (when write-contents-functions - (error "Will not do this because write-contents-functions is non-nil")) - (when (delq 'recentf-track-opened-file (copy-sequence write-file-functions)) - (error "Will not do this because write-file-functions is non-nil")) - - (add-hook 'write-contents-functions 'mumamo-alt-php-write-contents t t) - (put 'write-contents-functions 'permanent-local t) - (save-restriction - (let ((here (point))) - (widen) - (goto-char (point-min)) - (while (search-forward "<?php" nil t) - (replace-match "(?php")) - (goto-char (point-min)) - (while (search-forward "<?=" nil t) - (replace-match "(?=")) - (goto-char (point-min)) - (while (search-forward "?>" nil t) - (replace-match "?)")) - (goto-char here)))) - (save-restriction - (let ((here (point))) - (widen) - (goto-char (point-min)) - (while (search-forward "(?php" nil t) - (replace-match "<?php")) - (goto-char (point-min)) - (while (search-forward "(?=" nil t) - (replace-match "<?=")) - (goto-char (point-min)) - (while (search-forward "?)" nil t) - (replace-match "?>")) - (goto-char here))) - (remove-hook 'write-contents-functions 'mumamo-alt-php-write-contents t))) - -(defun mumamo-chunk-alt-php (pos min max) - "Find (?php ... ?), return range and `php-mode'. -Workaround for the problem that I can not tame `nxml-mode' to recognize <?php. - -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (when mumamo-alt-php-tags-mode - (mumamo-quick-static-chunk pos min max "(?php" "?)" t 'php-mode t))) - -(defun mumamo-chunk-alt-php= (pos min max) - "Find (?= ... ?), return range and `php-mode'. -Workaround for the problem that I can not tame `nxml-mode' to recognize <?php. - -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (when mumamo-alt-php-tags-mode - (mumamo-quick-static-chunk pos min max "(?=" "?)" t 'php-mode t))) - -;;;###autoload -(define-mumamo-multi-major-mode html-mumamo-mode - "Turn on multiple major modes for (X)HTML with main mode `html-mode'. -This covers inlined style and javascript and PHP." - ("HTML Family" html-mode - (mumamo-chunk-xml-pi - mumamo-chunk-alt-php - mumamo-chunk-alt-php= - mumamo-chunk-inlined-style - mumamo-chunk-inlined-script - mumamo-chunk-style= - mumamo-chunk-onjs= - ))) -(add-hook 'html-mumamo-mode-hook 'mumamo-define-html-file-wide-keys) -(mumamo-inherit-sub-chunk-family 'html-mumamo-mode) - -;; (define-mumamo-multi-major-mode xml-pi-only-mumamo-mode -;; "Test" -;; ("HTML Family" html-mode -;; (mumamo-chunk-xml-pi -;; ))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; XHTML w nxml-mode - -(defun mumamo-alt-php-write-contents () - "For `write-contents-functions' when `mumamo-chunk-alt-php' is used." - (let ((here (point))) - (save-match-data - (save-restriction - (widen) - (condition-case nil - (atomic-change-group - (progn - (goto-char (point-min)) - (while (search-forward "(?php" nil t) - (replace-match "<?php")) - (goto-char (point-min)) - (while (search-forward "(?=" nil t) - (replace-match "<?=")) - (goto-char (point-min)) - (while (search-forward "?)" nil t) - (replace-match "?>")) - (basic-save-buffer-1) - (signal 'mumamo-error-ind-0 nil))) - (mumamo-error-ind-0))) - (set-buffer-modified-p nil)) - (goto-char here)) - ;; saved, return t - t) - -;;;###autoload -(define-mumamo-multi-major-mode nxml-mumamo-mode - "Turn on multiple major modes for (X)HTML with main mode `nxml-mode'. -This covers inlined style and javascript and PHP. - -See also `mumamo-alt-php-tags-mode'." - ("nXml Family" nxml-mode - (mumamo-chunk-xml-pi - mumamo-chunk-alt-php - mumamo-chunk-inlined-style - mumamo-chunk-inlined-script - mumamo-chunk-style= - mumamo-chunk-onjs= - ))) -(add-hook 'nxml-mumamo-mode-hook 'mumamo-define-html-file-wide-keys) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Mason (not ready) -;; http://www.masonhq.com/docs/manual/Devel.html#examples_and_recommended_usage - -(defun mumamo-chunk-mason-perl-line (pos min max) - (mumamo-whole-line-chunk pos min max "%" 'perl-mode)) - -(defun mumamo-chunk-mason-perl-single (pos min max) - (mumamo-quick-static-chunk pos min max "<% " " %>" t 'perl-mode t)) - -(defun mumamo-chunk-mason-perl-block (pos min max) - (mumamo-quick-static-chunk pos min max "<%perl>" "</%perl>" t 'perl-mode t)) - -(defun mumamo-chunk-mason-perl-init (pos min max) - (mumamo-quick-static-chunk pos min max "<%init>" "</%init>" t 'perl-mode t)) - -(defun mumamo-chunk-mason-perl-once (pos min max) - (mumamo-quick-static-chunk pos min max "<%once>" "</%once>" t 'perl-mode t)) - -(defun mumamo-chunk-mason-perl-cleanup (pos min max) - (mumamo-quick-static-chunk pos min max "<%cleanup>" "</%cleanup>" t 'perl-mode t)) - -(defun mumamo-chunk-mason-perl-shared (pos min max) - (mumamo-quick-static-chunk pos min max "<%shared>" "</%shared>" t 'perl-mode t)) - -(defun mumamo-chunk-mason-simple-comp (pos min max) - (mumamo-quick-static-chunk pos min max "<& " " &>" t 'text-mode t)) - -(defun mumamo-chunk-mason-args (pos min max) - ;; Fix-me: perl-mode is maybe not the best here? - (mumamo-quick-static-chunk pos min max "<%args>" "</%args>" t 'perl-mode t)) - -(defun mumamo-chunk-mason-doc (pos min max) - (mumamo-quick-static-chunk pos min max "<%doc>" "</%doc>" t 'mumamo-comment-mode t)) - -(defun mumamo-chunk-mason-text (pos min max) - (mumamo-quick-static-chunk pos min max "<%text>" "</%text>" t 'text-mode t)) - -;; component calls with content - -;; (defun mumamo-chunk-mason-compcont-bw-exc-start-fun (pos min) -;; (let ((exc-start (mumamo-chunk-start-bw-str-inc pos min "<&| "))) -;; (and exc-start -;; (<= exc-start pos) -;; (cons exc-start 'html-mode)))) - -;; (defun mumamo-chunk-mason-compcont-fw-exc-start-fun-old (pos max) -;; (mumamo-chunk-start-fw-str-inc pos max "<&| ")) - -(defun mumamo-chunk-mason-compcont-fw-exc-end-fun (pos max) - (mumamo-chunk-end-fw-str-inc pos max "</&>")) - -(defun mumamo-chunk-mason-compcont-find-borders-fun (start end dummy) - (when dummy - (list - (when start - (save-match-data - (let ((here (point)) - ret) - (goto-char start) - (when (re-search-forward "[^>]* &>" end t) - (setq ret (point)) - (goto-char here) - ret)) - )) - (when end (- end 4)) - dummy))) - -;; (defun mumamo-chunk-mason-compcont-old (pos min max) -;; (mumamo-find-possible-chunk-new pos -;; max -;; 'mumamo-chunk-mason-compcont-bw-exc-start-fun -;; 'mumamo-chunk-mason-compcont-fw-exc-start-fun-old -;; 'mumamo-chunk-mason-compcont-fw-exc-end-fun -;; 'mumamo-chunk-mason-compcont-find-borders-fun)) - -(defun mumamo-chunk-mason-compcont-fw-exc-start-fun (pos max) - (let ((where (mumamo-chunk-start-fw-str-inc pos max "<&| "))) - (when where - (list where 'html-mode nil)))) - -(defun mumamo-chunk-mason-compcont (pos min max) - (mumamo-possible-chunk-forward pos max - 'mumamo-chunk-mason-compcont-fw-exc-start-fun - 'mumamo-chunk-mason-compcont-fw-exc-end-fun - 'mumamo-chunk-mason-compcont-find-borders-fun)) - -;;;###autoload -(define-mumamo-multi-major-mode mason-html-mumamo-mode - "Turn on multiple major modes for Mason using main mode `html-mode'. -This covers inlined style and javascript." - ("Mason html Family" html-mode - ( - mumamo-chunk-mason-perl-line - mumamo-chunk-mason-perl-single - mumamo-chunk-mason-perl-block - mumamo-chunk-mason-perl-init - mumamo-chunk-mason-perl-once - mumamo-chunk-mason-perl-cleanup - mumamo-chunk-mason-perl-shared - mumamo-chunk-mason-simple-comp - mumamo-chunk-mason-compcont - mumamo-chunk-mason-args - mumamo-chunk-mason-doc - mumamo-chunk-mason-text - mumamo-chunk-inlined-style - mumamo-chunk-inlined-script - mumamo-chunk-style= - mumamo-chunk-onjs= - ))) -(add-hook 'mason-html-mumamo-mode-hook 'mumamo-define-html-file-wide-keys) -(mumamo-inherit-sub-chunk-family-locally 'mason-html-mumamo-mode 'mason-html-mumamo-mode) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Embperl - -(defun mumamo-chunk-embperl-<- (pos min max) - "Find [- ... -], return range and `perl-mode'. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-quick-static-chunk pos min max "[-" "-]" t 'perl-mode t)) - -(defun mumamo-chunk-embperl-<+ (pos min max) - "Find [+ ... +], return range and `perl-mode'. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-quick-static-chunk pos min max "[+" "+]" t 'perl-mode nil)) - -(defun mumamo-chunk-embperl-<! (pos min max) - "Find [! ... !], return range and `perl-mode'. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-quick-static-chunk pos min max "[!" "!]" t 'perl-mode t)) - -(defun mumamo-chunk-embperl-<$ (pos min max) - "Find [$ ... $], return range and `perl-mode'. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - ;; This is a bit tricky since [$var] etc must be avoided. - (let* ((begin-mark "[$") - (end-mark "$]") - (good-chars '(32 ;space - 10 ;line feed - 9 ;tab - )) - ;; (search-bw-exc-start (lambda (pos min) - ;; (let ((not-found t) - ;; (next-char nil) - ;; (exc-start (mumamo-chunk-start-bw-str - ;; pos min begin-mark)) - ;; (here (point))) - ;; (while (and not-found - ;; exc-start) - ;; (setq next-char (char-after (+ (point) 2))) - ;; (if (memq next-char good-chars) - ;; (setq not-found nil) - ;; (setq exc-start - ;; (search-backward begin-mark - ;; min t)))) - ;; (when (and exc-start - ;; (<= exc-start pos)) - ;; (cons exc-start 'perl-mode))))) - ;; (search-bw-exc-end (lambda (pos min) - ;; (mumamo-chunk-end-bw-str pos min end-mark))) - ;; (search-fw-exc-start-old (lambda (pos max) - ;; (let ((not-found t) - ;; (next-char nil) - ;; (exc-start (mumamo-chunk-start-fw-str - ;; pos max begin-mark)) - ;; (here (point))) - ;; (while (and not-found - ;; exc-start) - ;; (setq next-char (char-after)) - ;; (if (memq next-char good-chars) - ;; (setq not-found nil) - ;; (setq exc-start - ;; (search-forward begin-mark - ;; max t)))) - ;; exc-start))) - (search-fw-exc-start (lambda (pos max) - (let ((not-found t) - (next-char nil) - (exc-start (mumamo-chunk-start-fw-str - pos max begin-mark)) - (here (point))) - (while (and not-found - exc-start) - (setq next-char (char-after)) - (if (memq next-char good-chars) - (setq not-found nil) - (setq exc-start - (search-forward begin-mark - max t)))) - (list exc-start 'perl-mode)))) - (search-fw-exc-end (lambda (pos max) - (save-match-data - (mumamo-chunk-end-fw-str pos max end-mark)))) - ) - ;; (mumamo-find-possible-chunk pos min max - ;; search-bw-exc-start - ;; search-bw-exc-end - ;; search-fw-exc-start-old - ;; search-fw-exc-end) - (mumamo-possible-chunk-forward pos max - search-fw-exc-start - search-fw-exc-end) - )) - -;;;###autoload -(define-mumamo-multi-major-mode embperl-html-mumamo-mode - "Turn on multiple major modes for Embperl files with main mode `html-mode'. -This also covers inlined style and javascript." - ("Embperl HTML Family" html-mode - (mumamo-chunk-embperl-<- - mumamo-chunk-embperl-<+ - mumamo-chunk-embperl-<! - mumamo-chunk-embperl-<$ - mumamo-chunk-inlined-style - mumamo-chunk-inlined-script - mumamo-chunk-style= - mumamo-chunk-onjs= - ))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; django - -(defun mumamo-chunk-django4(pos min max) - "Find {% comment %}. Return range and `django-mode'. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-quick-static-chunk pos min max "{% comment %}" "{% endcomment %}" t 'mumamo-comment-mode t)) - -(defun mumamo-chunk-django3(pos min max) - "Find {# ... #}. Return range and `django-mode'. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-quick-static-chunk pos min max "{#" "#}" t 'mumamo-comment-mode t)) - -(defun mumamo-chunk-django2(pos min max) - "Find {{ ... }}. Return range and `django-mode'. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-quick-static-chunk pos min max "{{" "}}" t 'django-variable-mode t)) - -(defun mumamo-chunk-django (pos min max) - "Find {% ... %}. Return range and `django-mode'. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (let ((chunk (mumamo-quick-static-chunk pos min max "{%" "%}" t 'django-mode t))) - (when chunk - (setcdr (last chunk) '(mumamo-template-indentor)) - chunk))) - -;; (defun mumamo-search-bw-exc-start-django (pos min) -;; "Helper for `mumamo-chunk-django'. -;; POS is where to start search and MIN is where to stop." -;; (let ((exc-start (mumamo-chunk-start-bw-str-inc pos min "{%"))) -;; (and exc-start -;; (<= exc-start pos) -;; (cons exc-start 'django-mode)))) - -;; (defun mumamo-search-bw-exc-start-django2(pos min) -;; "Helper for `mumamo-chunk-django2'. -;; POS is where to start search and MIN is where to stop." -;; (let ((exc-start (mumamo-chunk-start-bw-str-inc pos min "{{"))) -;; (and exc-start -;; (<= exc-start pos) -;; (cons exc-start 'django-mode)))) - -;; (defun mumamo-search-bw-exc-start-django3(pos min) -;; "Helper for `mumamo-chunk-django3'. -;; POS is where to start search and MIN is where to stop." -;; (let ((exc-start (mumamo-chunk-start-bw-str-inc pos min "{#"))) -;; (and exc-start -;; (<= exc-start pos) -;; (cons exc-start 'mumamo-comment-mode)))) - -;; (defun mumamo-search-bw-exc-start-django4(pos min) -;; "Helper for `mumamo-chunk-django4'. -;; POS is where to start search and MIN is where to stop." -;; (let ((exc-start (mumamo-chunk-start-bw-str-inc pos min -;; "{% comment %}"))) -;; (and exc-start -;; (<= exc-start pos) -;; (cons exc-start 'mumamo-comment-mode)))) - -;; (defun mumamo-search-bw-exc-end-django (pos min) -;; "Helper for `mumamo-chunk-django'. -;; POS is where to start search and MIN is where to stop." -;; (mumamo-chunk-end-bw-str-inc pos min "%}")) - -;; (defun mumamo-search-bw-exc-end-django2(pos min) -;; "Helper for `mumamo-chunk-django2'. -;; POS is where to start search and MIN is where to stop." -;; (mumamo-chunk-end-bw-str-inc pos min "}}")) - -;; (defun mumamo-search-bw-exc-end-django3(pos min) -;; "Helper for `mumamo-chunk-django3'. -;; POS is where to start search and MIN is where to stop." -;; (mumamo-chunk-end-bw-str-inc pos min "#}")) - -;; (defun mumamo-search-bw-exc-end-django4(pos min) -;; "Helper for `mumamo-chunk-django4'. -;; POS is where to start search and MIN is where to stop." -;; (mumamo-chunk-end-bw-str-inc pos min "{% endcomment %}")) - -(defun mumamo-search-fw-exc-start-django (pos max) - "Helper for `mumamo-chunk-django'. -POS is where to start search and MAX is where to stop." - (mumamo-chunk-start-fw-str-inc pos max "{%")) - -(defun mumamo-search-fw-exc-start-django2(pos max) - "Helper for `mumamo-chunk-django2'. -POS is where to start search and MAX is where to stop." - (mumamo-chunk-start-fw-str-inc pos max "{{")) - -(defun mumamo-search-fw-exc-start-django3(pos max) - "Helper for `mumamo-chunk-django3'. -POS is where to start search and MAX is where to stop." - (mumamo-chunk-start-fw-str-inc pos max "{#")) - -(defun mumamo-search-fw-exc-start-django4(pos max) - "Helper for `mumamo-chunk-django4'. -POS is where to start search and MAX is where to stop." - (mumamo-chunk-start-fw-str-inc pos max "{% comment %}")) - -(defun mumamo-search-fw-exc-end-django (pos max) - "Helper for `mumamo-chunk-django'. -POS is where to start search and MAX is where to stop." - (mumamo-chunk-end-fw-str-inc pos max "%}")) - -(defun mumamo-search-fw-exc-end-django2(pos max) - "Helper for `mumamo-chunk-django2'. -POS is where to start search and MAX is where to stop." - (mumamo-chunk-end-fw-str-inc pos max "}}")) - -(defun mumamo-search-fw-exc-end-django3(pos max) - "Helper for `mumamo-chunk-django3'. -POS is where to start search and MAX is where to stop." - (mumamo-chunk-end-fw-str-inc pos max "#}")) - -(defun mumamo-search-fw-exc-end-django4(pos max) - "Helper for `mumamo-chunk-django4'. -POS is where to start search and MAX is where to stop." - (mumamo-chunk-end-fw-str-inc pos max "{% endcomment %}")) - -;;;###autoload -(define-mumamo-multi-major-mode django-html-mumamo-mode - "Turn on multiple major modes for Django with main mode `html-mode'. -This also covers inlined style and javascript." - ("Django HTML Family" html-mode - (mumamo-chunk-django4 - mumamo-chunk-django - mumamo-chunk-django2 - mumamo-chunk-django3 - mumamo-chunk-inlined-style - mumamo-chunk-inlined-script - mumamo-chunk-style= - mumamo-chunk-onjs= - ))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Genshi / kid - -;; {% python ... %} -(defun mumamo-chunk-genshi%(pos min max) - "Find {% python ... %}. Return range and `genshi-mode'. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-quick-static-chunk pos min max "{% python" "%}" t 'python-mode t)) - -;; ${expr} -(defun mumamo-chunk-genshi$(pos min max) - "Find ${ ... }, return range and `python-mode'. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (let ((chunk - (mumamo-quick-static-chunk pos min max "${" "}" t 'python-mode t))) - (when chunk - ;; Test for clash with %} - (let ((sub-mode (nth 2 chunk)) - (start (nth 0 chunk))) - (if sub-mode - chunk - ;;(message "point.1=%s" (point)) - (when (and start - (eq ?% (char-before start))) - ;;(message "point.2=%s" (point)) - ;;(message "clash with %%}, chunk=%s" chunk) - ;;(setq chunk nil) - (setcar chunk (1- start)) - ) - ;;(message "chunk.return=%s" chunk) - chunk))))) - -;; Fix-me: Because of the way chunks currently are searched for there -;; is an error when a python chunk is used. This is because mumamo -;; gets confused by the %} ending and the } ending. This can be -;; solved by running a separate phase to get the chunks first and -;; during that phase match start and end of the chunk. - - -;; Note: You will currently get fontification errors if you use -;; python chunks - -;; {% python ... %} - -;; The reason is that the chunk routines currently do not know when -;; to just look for the } or %} endings. However this should not -;; affect your editing normally. - -;;;###autoload -(define-mumamo-multi-major-mode genshi-html-mumamo-mode - "Turn on multiple major modes for Genshi with main mode `html-mode'. -This also covers inlined style and javascript." - ("Genshi HTML Family" html-mode - ( - ;;mumamo-chunk-genshi% - mumamo-chunk-genshi$ - mumamo-chunk-py:= - mumamo-chunk-py:match - mumamo-chunk-xml-pi - mumamo-chunk-inlined-style - mumamo-chunk-inlined-script - mumamo-chunk-style= - mumamo-chunk-onjs= - ))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; MJT - -;; ${expr} -(defun mumamo-chunk-mjt$(pos min max) - "Find ${ ... }, return range and `javascript-mode'. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-quick-static-chunk pos min max "${" "}" t 'javascript-mode t)) - -;;;###autoload -(define-mumamo-multi-major-mode mjt-html-mumamo-mode - "Turn on multiple major modes for MJT with main mode `html-mode'. -This also covers inlined style and javascript." - ("MJT HTML Family" html-mode - ( - mumamo-chunk-mjt$ - mumamo-chunk-xml-pi - mumamo-chunk-inlined-style - mumamo-chunk-inlined-script - mumamo-chunk-style= - mumamo-chunk-onjs= - ))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; smarty - -(defun mumamo-chunk-smarty-literal (pos min max) - "Find {literal} ... {/literal}. Return range and 'html-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-quick-static-chunk pos min max "{literal}" "{/literal}" t 'html-mode t)) - -(defun mumamo-chunk-smarty-t (pos min max) - "Find {t} ... {/t}. Return range and 'html-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-quick-static-chunk pos min max "{t}" "{/t}" t 'text-mode t)) - -(defun mumamo-chunk-smarty-comment (pos min max) - "Find {* ... *}. Return range and 'mumamo-comment-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-quick-static-chunk pos min max "{*" "*}" t 'mumamo-comment-mode nil)) - -(defun mumamo-chunk-smarty (pos min max) - "Find { ... }. Return range and 'smarty-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-quick-static-chunk pos min max "{" "}" t 'smarty-mode nil)) - -;;;###autoload -(define-mumamo-multi-major-mode smarty-html-mumamo-mode - "Turn on multiple major modes for Smarty with main mode `html-mode'. -This also covers inlined style and javascript." - ("Smarty HTML Family" html-mode - (mumamo-chunk-xml-pi - mumamo-chunk-style= - mumamo-chunk-onjs= - ;;mumamo-chunk-inlined-style - ;;mumamo-chunk-inlined-script - mumamo-chunk-smarty-literal - mumamo-chunk-smarty-t - mumamo-chunk-smarty-comment - mumamo-chunk-smarty - ))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; ssjs - server side javascript - -;; http://www.sitepoint.com/blogs/2009/03/10/server-side-javascript-will-be-as-common-as-php/ -;; -;; It looks like there are different syntaxes, both -;; -;; <script runat="server">...</script> and <% ... %>. - -(defun mumamo-chunk-ssjs-% (pos min max) - "Find <% ... %>. Return range and 'javascript-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-quick-static-chunk pos min max "<%" "%>" t 'javascript-mode t)) - -(defconst mumamo-ssjs-tag-start-regex - (rx "<script" - space - (0+ (not (any ">"))) - "runat" - (0+ space) - "=" - (0+ space) - ?\" - ;;(or "text" "application") - ;;"/" - ;;(or "javascript" "ecmascript") - (or "server" "both" "server-proxy") - ?\" - (0+ (not (any ">"))) - ">" - ;; FIX-ME: Commented out because of bug in Emacs - ;; - ;;(optional (0+ space) "<![CDATA[" ) - )) - -;; (defun mumamo-search-bw-exc-start-inlined-ssjs (pos min) -;; "Helper for `mumamo-chunk-inlined-ssjs'. -;; POS is where to start search and MIN is where to stop." -;; (goto-char (+ pos 7)) -;; (let ((marker-start (when (< min (point)) (search-backward "<script" min t))) -;; exc-mode -;; exc-start) -;; (when marker-start -;; (when (looking-at mumamo-ssjs-tag-start-regex) -;; (setq exc-start (match-end 0)) -;; (goto-char exc-start) -;; (when (<= exc-start pos) -;; ;;(cons (point) 'javascript-mode) -;; (list (point) 'javascript-mode '(nxml-mode)) -;; ) -;; )))) - -;; (defun mumamo-search-fw-exc-start-inlined-ssjs-old (pos max) -;; "Helper for `mumamo-chunk-inlined-ssjs'. -;; POS is where to start search and MAX is where to stop." -;; (goto-char (1+ pos)) -;; (skip-chars-backward "^<") -;; ;; Handle <![CDATA[ -;; (when (and -;; (eq ?< (char-before)) -;; (eq ?! (char-after)) -;; (not (bobp))) -;; (backward-char) -;; (skip-chars-backward "^<")) -;; (unless (bobp) -;; (backward-char 1)) -;; (let ((exc-start (search-forward "<script" max t)) -;; exc-mode) -;; (when exc-start -;; (goto-char (- exc-start 7)) -;; (when (looking-at mumamo-ssjs-tag-start-regex) -;; (goto-char (match-end 0)) -;; (point) -;; )))) - -(defun mumamo-search-fw-exc-start-inlined-ssjs (pos max) - "Helper for `mumamo-chunk-inlined-ssjs'. -POS is where to start search and MAX is where to stop." - (goto-char (1+ pos)) - (skip-chars-backward "^<") - ;; Handle <![CDATA[ - (when (and - (eq ?< (char-before)) - (eq ?! (char-after)) - (not (bobp))) - (backward-char) - (skip-chars-backward "^<")) - (unless (bobp) - (backward-char 1)) - (let ((exc-start (search-forward "<script" max t)) - exc-mode) - (when exc-start - (goto-char (- exc-start 7)) - (when (looking-at mumamo-ssjs-tag-start-regex) - (goto-char (match-end 0)) - (list (point) 'javascript-mode) - )))) - -(defun mumamo-chunk-inlined-ssjs (pos min max) - "Find <script runat=...>...</script>. Return range and 'javascript-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - ;; (mumamo-find-possible-chunk pos min max - ;; 'mumamo-search-bw-exc-start-inlined-ssjs - ;; 'mumamo-search-bw-exc-end-inlined-script - ;; 'mumamo-search-fw-exc-start-inlined-ssjs-old - ;; 'mumamo-search-fw-exc-end-inlined-script) - (mumamo-possible-chunk-forward pos max - 'mumamo-search-fw-exc-start-inlined-ssjs - 'mumamo-search-fw-exc-end-inlined-script)) - -;;;###autoload -(define-mumamo-multi-major-mode ssjs-html-mumamo-mode - "Turn on multiple major modes for SSJS with main mode `html-mode'. -This covers inlined style and javascript." - ("HTML Family" html-mode - (mumamo-chunk-inlined-style - mumamo-chunk-inlined-script - mumamo-chunk-inlined-ssjs - mumamo-chunk-ssjs-% - mumamo-chunk-style= - mumamo-chunk-onjs= - ))) -(add-hook 'html-mumamo-mode-hook 'mumamo-define-html-file-wide-keys) -(mumamo-inherit-sub-chunk-family 'ssjs-html-mumamo-mode) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; gsp - -(defun mumamo-chunk-gsp (pos min max) - "Find <% ... %>. Return range and 'groovy-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-quick-static-chunk pos min max "<%" "%>" t 'groovy-mode t)) - -;;;###autoload -(define-mumamo-multi-major-mode gsp-html-mumamo-mode - "Turn on multiple major modes for GSP with main mode `html-mode'. -This also covers inlined style and javascript." - ("GSP HTML Family" html-mode - (mumamo-chunk-gsp - mumamo-chunk-inlined-style - mumamo-chunk-inlined-script - mumamo-chunk-style= - mumamo-chunk-onjs= - ))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; jsp - Java Server Pages - -(defun mumamo-chunk-jsp (pos min max) - "Find <% ... %>. Return range and 'java-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-quick-static-chunk pos min max "<%" "%>" t 'java-mode t)) - -;;;###autoload -(define-mumamo-multi-major-mode jsp-html-mumamo-mode - "Turn on multiple major modes for JSP with main mode `html-mode'. -This also covers inlined style and javascript." - ("JSP HTML Family" html-mode - (mumamo-chunk-jsp - mumamo-chunk-inlined-style - mumamo-chunk-inlined-script - mumamo-chunk-style= - mumamo-chunk-onjs= - ))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; eruby - -;; Fix-me: Maybe take care of <%= and <%- and -%>, but first ask the -;; ruby people if this is worth doing. -;; -;; See also http://wiki.rubyonrails.org/rails/pages/UnderstandingViews -(defun mumamo-chunk-eruby (pos min max) - "Find <% ... %>. Return range and 'ruby-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (let ((chunk (mumamo-quick-static-chunk pos min max "<%" "%>" t 'ruby-mode t))) - (when chunk - ;; Put indentation type on 'mumamo-next-indent on the chunk: - ;; Fix-me: use this! - (setcdr (last chunk) '(mumamo-template-indentor)) - chunk))) - -(defun mumamo-chunk-eruby-quoted (pos min max) - "Find \"<%= ... %>\". Return range and 'ruby-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX. - -This is a workaround for problems with strings." - (let ((chunk (mumamo-quick-static-chunk pos min max "\"<%=" "%>\"" t 'ruby-mode t))) - (when chunk - ;; Put indentation type on 'mumamo-next-indent on the chunk: - ;; Fix-me: use this! - (setcdr (last chunk) '(mumamo-template-indentor)) - chunk))) - -(defun mumamo-chunk-eruby-comment (pos min max) - "Find <%# ... %>. Return range and 'ruby-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX. - -This is needed since otherwise the end marker is thought to be -part of a comment." - (mumamo-quick-static-chunk pos min max "<%#" "%>" t 'mumamo-comment-mode t)) - -;; (defun mumamo-search-bw-exc-start-ruby (pos min) -;; "Helper for `mumamo-chunk-ruby'. -;; POS is where to start search and MIN is where to stop." -;; (let ((exc-start (mumamo-chunk-start-bw-str pos min "<%"))) -;; (when (and exc-start -;; (<= exc-start pos)) -;; (cons exc-start 'ruby-mode)))) - -;;;###autoload -(define-mumamo-multi-major-mode eruby-mumamo-mode - "Turn on multiple major mode for eRuby with unspecified main mode. -Current major-mode will be used as the main major mode." - ("eRuby Family" nil - (mumamo-chunk-eruby-comment - mumamo-chunk-eruby - ))) - -;;;###autoload -(define-mumamo-multi-major-mode eruby-html-mumamo-mode - "Turn on multiple major modes for eRuby with main mode `html-mode'. -This also covers inlined style and javascript." - ("eRuby Html Family" html-mode - ( - mumamo-chunk-eruby-comment - mumamo-chunk-eruby - mumamo-chunk-inlined-style - mumamo-chunk-inlined-script - mumamo-chunk-style= - mumamo-chunk-onjs= - ))) - -;;;###autoload -(define-mumamo-multi-major-mode eruby-javascript-mumamo-mode - "Turn on multiple major modes for eRuby with main mode `javascript-mode'." - ("eRuby Html Family" javascript-mode - ( - mumamo-chunk-eruby-comment - mumamo-chunk-eruby-quoted - mumamo-chunk-eruby - ;;mumamo-chunk-inlined-style - ;;mumamo-chunk-inlined-script - ;;mumamo-chunk-style= - ;;mumamo-chunk-onjs= - ))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; heredoc - -(defcustom mumamo-heredoc-modes - '( - ("HTML" html-mode) - ("CSS" css-mode) - ("JAVASCRIPT" javascript-mode) - ("JAVA" java-mode) - ("GROOVY" groovy-mode) - ("SQL" sql-mode) - ) - "Matches for heredoc modes. -The entries in this list have the form - - (REGEXP MAJOR-MODE-SPEC) - -where REGEXP is a regular expression that should match the -heredoc marker line and MAJOR-MODE-SPEC is the major mode spec to -use in the heredoc part. - -The major mode spec is translated to a major mode using -`mumamo-major-mode-from-modespec'." - :type '(repeat - (list - regexp - (function :tag "Major mode"))) - :group 'mumamo-modes) - -(defun mumamo-mode-for-heredoc (marker) - "Return major mode associated with MARKER. -Use first match in `mumamo-heredoc-modes'. -If no match use `text-mode'." - (let ((mode (catch 'mode - (save-match-data - (dolist (rec mumamo-heredoc-modes) - (let ((regexp (nth 0 rec)) - (mode (nth 1 rec))) - (when (string-match regexp marker) - (throw 'mode mode)))))))) - (if mode - (mumamo-major-mode-from-modespec mode) - 'text-mode))) - -(defun mumamo-chunk-heredoc (pos min max lang) - "This should work similar to `mumamo-find-possible-chunk'. -POS, MIN and MAX have the same meaning as there. - -LANG is the programming language. -Supported values are 'perl." - ;; Fix-me: LANG - ;; Fix-me: use mumamo-end-in-code - (mumamo-condition-case err - (let ((old-point (point))) - (goto-char pos) - (beginning-of-line) - (let (next-<< - (want-<< t) - heredoc-mark - end-mark-len - heredoc-line - delimiter - skipped - (skip-b "") - start-inner - end - exc-mode - fw-exc-fun - border-fun - allow-code-after - start-outer - ps - ) - (goto-char pos) - (beginning-of-line) - (case lang - ('sh - (setq allow-code-after t) - (while want-<< - (setq next-<< (search-forward "<<" max t)) - (if (not next-<<) - (setq want-<< nil) ;; give up - ;; Check inside string or comment. - (setq ps (parse-partial-sexp (line-beginning-position) (point))) - (unless (or (nth 3 ps) (nth 4 ps)) - (setq want-<< nil)))) - (when next-<< - (setq start-outer (- (point) 2)) - (when (= (char-after) ?-) - (setq skip-b "\t*") - (unless (eolp) (forward-char))) - ;; fix-me: space - (setq skipped (skip-chars-forward " \t")) - (when (memq (char-after) '(?\" ?\')) - (setq delimiter (list (char-after)))) - (if (and (> skipped 0) (not delimiter)) - (setq heredoc-mark "") - (when (looking-at (rx-to-string - `(and (regexp ,(if delimiter - (concat delimiter "\\([^\n<>;]+\\)" delimiter) - "\\([^ \t\n<>;]+\\)")) - (or blank line-end)))) - (setq heredoc-mark (buffer-substring-no-properties - (match-beginning 1) - (match-end 1))))) - (when heredoc-mark - (setq heredoc-line (buffer-substring-no-properties (point-at-bol) (point-at-eol))) - (setq start-inner (1+ (point-at-eol))) - (setq end-mark-len (length heredoc-mark)) - ))) - ('w32-ps (error "No support for windows power shell yet")) - ('php - (while want-<< - (setq next-<< (search-forward "<<<" max t)) - ;; Check inside string or comment. - (if (not next-<<) - (setq want-<< nil) ;; give up - (setq ps (parse-partial-sexp (line-beginning-position) (- (point) 0))) - (unless (or (nth 3 ps) (nth 4 ps)) - (setq want-<< nil)))) - (when next-<< - (setq start-outer (- (point) 3)) - (skip-chars-forward " \t") - (when (looking-at (concat "\\([^\n;]*\\)[[:blank:]]*\n")) - (setq heredoc-mark (buffer-substring-no-properties - (match-beginning 1) - (match-end 1))) - (setq heredoc-line (buffer-substring-no-properties (point-at-bol) (point-at-eol))) - ;; fix-me: nowdoc - (when (and (= ?\' (string-to-char heredoc-mark)) - (= ?\' (string-to-char (substring heredoc-mark (1- (length heredoc-mark)))))) - (setq heredoc-mark (substring heredoc-mark 1 (- (length heredoc-mark) 1)))) - (setq end-mark-len (1+ (length heredoc-mark))) - (setq start-inner (match-end 0))))) - ('perl - (setq allow-code-after t) - (while want-<< - (setq next-<< (search-forward "<<" max t)) - (if (not next-<<) - (setq want-<< nil) ;; give up - ;; Check inside string or comment. - (setq ps (parse-partial-sexp (line-beginning-position) (point))) - (unless (or (nth 3 ps) (nth 4 ps)) - (setq want-<< nil)))) - (when next-<< - (setq start-outer (- (point) 2)) - ;; fix-me: space - (setq skipped (skip-chars-forward " \t")) - (when (memq (char-after) '(?\" ?\')) - (setq delimiter (list (char-after)))) - (if (and (> skipped 0) (not delimiter)) - (setq heredoc-mark "") ;; blank line - (when (looking-at (rx-to-string - `(and (regexp ,(if delimiter - (concat delimiter "\\([^\n;]*\\)" delimiter) - "\\([^ \t\n<>;]+\\)")) - (or blank ";")))) - (setq heredoc-mark (buffer-substring-no-properties - (match-beginning 1) - (match-end 1))))) - (when heredoc-mark - (setq heredoc-line (buffer-substring-no-properties (point-at-bol) (point-at-eol))) - ;;(setq start-inner (1+ (match-end 0))) - (setq start-inner (1+ (point-at-eol))) - (setq end-mark-len (length heredoc-mark)) - ))) - ('python - (unless (eobp) (forward-char)) - (while want-<< - (setq next-<< (re-search-forward "\"\"\"\\|'''" max t)) - (setq start-outer (- (point) 3)) - (if (not next-<<) - (setq want-<< nil) ;; give up - ;; Check inside string or comment. - (setq ps (parse-partial-sexp (line-beginning-position) (- (point) 3))) - (unless (or (nth 3 ps) (nth 4 ps)) - (setq want-<< nil))))) - ('ruby - (while want-<< - (setq next-<< (search-forward "<<" max t)) - (if (not next-<<) - (setq want-<< nil) ;; give up - ;; Check inside string or comment. - (setq ps (parse-partial-sexp (line-beginning-position) (point))) - (unless (or (nth 3 ps) (nth 4 ps)) - (setq want-<< nil)))) - (when next-<< - (setq start-outer (- (point) 2)) - (when (= (char-after) ?-) - (setq skip-b "[ \t]*") - (forward-char)) - (when (looking-at (concat "[^\n[:blank:]]*")) - (setq heredoc-mark (buffer-substring-no-properties - (match-beginning 0) - (match-end 0))) - (setq end-mark-len (length heredoc-mark)) - (setq heredoc-line (buffer-substring-no-properties (point-at-bol) (point-at-eol))) - (setq start-inner (match-end 0))))) - (t (error "next-<< not implemented for lang %s" lang))) - (when start-inner (assert (<= pos start-inner) t)) - (goto-char old-point) - (when (or start-inner end) - (let ((endmark-regexp - (case lang - ('sh (concat "^" skip-b heredoc-mark "$")) - ('php (concat "^" heredoc-mark ";?$")) - ('perl (concat "^" heredoc-mark "$")) - ('python (concat "^" heredoc-mark "[[:space:]]*")) - ('ruby (concat "^" skip-b heredoc-mark "$")) - (t (error "mark-regexp not implemented for %s" lang))))) - ;; Fix-me: rename start-inner <=> start-outer... - (setq border-fun `(lambda (start end exc-mode) - ;; Fix-me: use lengths... - (list - (if ,allow-code-after nil (+ start (- ,start-inner ,start-outer 1))) - (when end (- end ,end-mark-len))))) - (setq fw-exc-fun `(lambda (pos max) - (save-match-data - (let ((here (point))) - (goto-char pos) - (prog1 - (when (re-search-forward ,endmark-regexp max t) - (- (point) 1 ,(length heredoc-mark)) - (- (point) 0) - ) - (goto-char here))))))) - (setq exc-mode (mumamo-mode-for-heredoc heredoc-line)) - (list start-inner end exc-mode nil nil fw-exc-fun nil) - ;; Fix me: Add overriding for inner chunks (see - ;; http://www.emacswiki.org/emacs/NxhtmlMode#toc13). Maybe - ;; make fw-exc-fun a list (or a cons, since overriding is - ;; probably all that I want to add)? And make the - ;; corresponding chunk property a list too? - ;;(list start-outer end exc-mode (list start-inner end) nil fw-exc-fun border-fun 'heredoc) - (list (if allow-code-after start-inner start-outer) - end exc-mode (list start-inner end) nil fw-exc-fun border-fun 'heredoc) - ))) - (error (mumamo-display-error 'mumamo-chunk-heredoc - "%s" (error-message-string err))))) - - -;;;; Unix style sh heredoc - -(defun mumamo-chunk-sh-heredoc (pos min max) - "Find sh here docs. -See `mumamo-find-possible-chunk' for POS, MIN -and MAX." - (let ((r (mumamo-chunk-heredoc pos min max 'sh))) - r)) - -;;;###autoload -(define-mumamo-multi-major-mode sh-heredoc-mumamo-mode - "Turn on multiple major modes for sh heredoc document. -See `mumamo-heredoc-modes' for how to specify heredoc major modes." - ("SH HereDoc" sh-mode - (mumamo-chunk-sh-heredoc - ))) -(mumamo-inherit-sub-chunk-family 'sh-heredoc-mumamo-mode) - - -;;;; PHP heredoc - -(defun mumamo-chunk-php-heredoc (pos min max) - "Find PHP here docs. -See `mumamo-find-possible-chunk' for POS, MIN -and MAX." - (let ((r (mumamo-chunk-heredoc pos min max 'php))) - r)) - -;;;###autoload -(define-mumamo-multi-major-mode php-heredoc-mumamo-mode - "Turn on multiple major modes for PHP heredoc document. -See `mumamo-heredoc-modes' for how to specify heredoc major modes." - ("PHP HereDoc" php-mode - (mumamo-chunk-php-heredoc - ))) -(mumamo-inherit-sub-chunk-family 'php-heredoc-mumamo-mode) -(mumamo-inherit-sub-chunk-family-locally 'php-heredoc-mumamo-mode 'html-mumamo-mode) - - -;;;; Perl heredoc - -(defun mumamo-chunk-perl-heredoc (pos min max) - "Find perl here docs. -See `mumamo-find-possible-chunk' for POS, MIN -and MAX." - (let ((r (mumamo-chunk-heredoc pos min max 'perl))) - r)) - -;;;###autoload -(define-mumamo-multi-major-mode perl-heredoc-mumamo-mode - "Turn on multiple major modes for Perl heredoc document. -See `mumamo-heredoc-modes' for how to specify heredoc major modes." - ("Perl HereDoc" perl-mode - (mumamo-chunk-perl-heredoc - ))) -(mumamo-inherit-sub-chunk-family 'perl-heredoc-mumamo-mode) - -;;;###autoload -(define-mumamo-multi-major-mode cperl-heredoc-mumamo-mode - "Turn on multiple major modes for Perl heredoc document. -See `mumamo-heredoc-modes' for how to specify heredoc major modes." - ("Perl HereDoc" cperl-mode - (mumamo-chunk-perl-heredoc - ))) -(mumamo-inherit-sub-chunk-family 'cperl-heredoc-mumamo-mode) - - -;;;; Python heredoc - -(defun mumamo-chunk-python-heredoc (pos min max) - "Find python here docs. -See `mumamo-find-possible-chunk' for POS, MIN -and MAX." - (let ((r (mumamo-chunk-heredoc pos min max 'python))) - r)) - -;;;###autoload -(define-mumamo-multi-major-mode python-heredoc-mumamo-mode - "Turn on multiple major modes for Perl heredoc document. -See `mumamo-heredoc-modes' for how to specify heredoc major modes." - ("Python HereDoc" python-mode - (mumamo-chunk-python-heredoc - ))) -(mumamo-inherit-sub-chunk-family 'python-heredoc-mumamo-mode) - - -;;;; Ruby heredoc - -(defun mumamo-chunk-ruby-heredoc (pos min max) - "Find Ruby here docs. -See `mumamo-find-possible-chunk' for POS, MIN -and MAX." - (let ((r (mumamo-chunk-heredoc pos min max 'ruby))) - r)) - -;;;###autoload -(define-mumamo-multi-major-mode ruby-heredoc-mumamo-mode - "Turn on multiple major modes for Ruby heredoc document. -See `mumamo-heredoc-modes' for how to specify heredoc major modes." - ("Ruby HereDoc" ruby-mode - (mumamo-chunk-ruby-heredoc - ))) -(mumamo-inherit-sub-chunk-family 'ruby-heredoc-mumamo-mode) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Tex meta - -;; (defun mumamo-search-bw-textext-start (pos min) -;; "Helper for `mumamo-chunk-textext'. -;; POS is where to start search and MIN is where to stop." -;; (let ((exc-start (mumamo-chunk-start-bw-str pos min "textext(\"")) -;; (exc-mode 'plain-tex-mode)) -;; (when exc-start -;; (when (<= exc-start pos) -;; (cons exc-start exc-mode))))) - -(defconst mumamo-textext-end-regex - (rx "textext(" - (0+ - (0+ (not (any "\"()"))) - ?\" - (0+ (not (any "\""))) - ?\" - ) - (0+ (not (any "\"()"))) - ")")) - -(defun mumamo-textext-test-is-end (pos) - "Helper for `mumamo-chunk-textext'. -Return POS if POS is at the end of textext chunk." - (when pos - (let ((here (point)) - hit) - (goto-char (+ 2 pos)) - (when (looking-back mumamo-textext-end-regex) - (setq hit t)) - (goto-char here) - (when hit pos)))) - -;; (defun mumamo-search-bw-textext-end (pos min) -;; "Helper for `mumamo-chunk-textext'. -;; POS is where to start search and MIN is where to stop." -;; (let ((end (mumamo-chunk-end-bw-str pos min "\")")) -;; res) -;; (while (and end -;; (not (setq res (mumamo-textext-test-is-end end)))) -;; (setq end (mumamo-chunk-end-bw-str (1- end) min "\")"))) -;; res)) - -;; (defun mumamo-search-fw-textext-start-old (pos max) -;; "Helper for `mumamo-chunk-textext'. -;; POS is where to start search and MAX is where to stop." -;; (mumamo-chunk-start-fw-str pos max "textext(\"")) - -(defun mumamo-search-fw-textext-start (pos max) - "Helper for `mumamo-chunk-textext'. -POS is where to start search and MAX is where to stop." - (let ((where (mumamo-chunk-start-fw-str pos max "textext(\""))) - (when where - (list where 'plain-tex-mode)))) - -(defun mumamo-search-fw-textext-end (pos max) - "Helper for `mumamo-chunk-textext'. -POS is where to start search and MAX is where to stop." - (save-match-data - (let ((end (mumamo-chunk-end-fw-str pos max "\")"))) - (mumamo-textext-test-is-end end)))) - -(defun mumamo-chunk-textext (pos min max) - "Find textext or TEX chunks. Return range and 'plain-tex-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - ;; (mumamo-find-possible-chunk pos min max - ;; 'mumamo-search-bw-textext-start - ;; 'mumamo-search-bw-textext-end - ;; 'mumamo-search-fw-textext-start-old - ;; 'mumamo-search-fw-textext-end) - (mumamo-possible-chunk-forward pos max - 'mumamo-search-fw-textext-start - 'mumamo-search-fw-textext-end)) - -;; (defun mumamo-search-bw-verbatimtex-start (pos min) -;; "Helper for `mumamo-chunk-verbatimtextext'. -;; POS is where to start search and MIN is where to stop." -;; (let ((exc-start (mumamo-chunk-start-bw-str pos min "\nverbatimtex")) -;; (exc-mode 'plain-tex-mode)) -;; (when exc-start -;; (when (<= exc-start pos) -;; (cons exc-start exc-mode))))) - -;; (defun mumamo-search-bw-verbatimtex-end (pos min) -;; "Helper for `mumamo-chunk-verbatimtextext'. -;; POS is where to start search and MIN is where to stop." -;; (mumamo-chunk-end-bw-str pos min "\netex")) - -;; (defun mumamo-search-fw-verbatimtex-start-old (pos max) -;; "Helper for `mumamo-chunk-verbatimtextext'. -;; POS is where to start search and MAX is where to stop." -;; (mumamo-chunk-start-fw-str pos max "\nverbatimtex")) - -(defun mumamo-search-fw-verbatimtex-start (pos max) - "Helper for `mumamo-chunk-verbatimtextext'. -POS is where to start search and MAX is where to stop." - (let ((where (mumamo-chunk-start-fw-str pos max "\nverbatimtex"))) - (when where - (list where 'plain-tex-mode)))) - -(defun mumamo-search-fw-verbatimtex-end (pos max) - "Helper for `mumamo-chunk-verbatimtextext'. -POS is where to start search and MAX is where to stop." - (save-match-data - (mumamo-chunk-end-fw-str pos max "\netex"))) - -(defun mumamo-chunk-verbatimtex (pos min max) - "Find verbatimtex - etex chunks. Return range and 'plain-tex-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - ;; (mumamo-find-possible-chunk pos min max - ;; 'mumamo-search-bw-verbatimtex-start - ;; 'mumamo-search-bw-verbatimtex-end - ;; 'mumamo-search-fw-verbatimtex-start-old - ;; 'mumamo-search-fw-verbatimtex-end) - (mumamo-possible-chunk-forward pos max - 'mumamo-search-fw-verbatimtex-start - 'mumamo-search-fw-verbatimtex-end)) - -;; (defun mumamo-search-bw-btex-start (pos min) -;; "Helper for `mumamo-chunk-btex'. -;; POS is where to start search and MIN is where to stop." -;; (let ((exc-start (mumamo-chunk-start-bw-str pos min "\nverbatimtex")) -;; (exc-mode 'plain-tex-mode)) -;; (when exc-start -;; (when (<= exc-start pos) -;; (cons exc-start exc-mode))))) - -;; (defun mumamo-search-bw-btex-end (pos min) -;; "Helper for `mumamo-chunk-btex'. -;; POS is where to start search and MIN is where to stop." -;; (mumamo-chunk-end-bw-str pos min "\netex")) - -;; (defun mumamo-search-fw-btex-start-old (pos max) -;; "Helper for `mumamo-chunk-btex'. -;; POS is where to start search and MAX is where to stop." -;; (mumamo-chunk-start-fw-str pos max "\nverbatimtex")) - -(defun mumamo-search-fw-btex-start (pos max) - "Helper for `mumamo-chunk-btex'. -POS is where to start search and MAX is where to stop." - (let ((where (mumamo-chunk-start-fw-str pos max "\nverbatimtex"))) - (when where - (list where 'plain-tex-mode)))) - -(defun mumamo-search-fw-btex-end (pos max) - "Helper for `mumamo-chunk-btex'. -POS is where to start search and MAX is where to stop." - (save-match-data - (mumamo-chunk-end-fw-str pos max "\netex"))) - -(defun mumamo-chunk-btex (pos min max) - "Find btex - etex chunks. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - ;; (mumamo-find-possible-chunk pos min max - ;; 'mumamo-search-bw-btex-start - ;; 'mumamo-search-bw-btex-end - ;; 'mumamo-search-fw-btex-start-old - ;; 'mumamo-search-fw-btex-end) - (mumamo-possible-chunk-forward pos max - 'mumamo-search-fw-btex-start - 'mumamo-search-fw-btex-end)) - -;;;###autoload -(define-mumamo-multi-major-mode metapost-mumamo-mode - "Turn on multiple major modes for MetaPost." - ("MetaPost TeX Family" metapost-mode - (mumamo-chunk-textext - mumamo-chunk-verbatimtex - ))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; OpenLaszlo - -(defconst mumamo-lzx-method-tag-start-regex - (rx "<method" - (optional - space - (0+ (not (any ">")))) - ">" - ;; FIX-ME: Commented out because of bug in Emacs - ;; - ;;(optional (0+ space) "<![CDATA[" ) - )) - -(defun mumamo-search-bw-exc-start-inlined-lzx-method (pos min) - "Helper for `mumamo-chunk-inlined-lzx-method'. -POS is where to start search and MIN is where to stop." - (goto-char (+ pos 7)) - (let ((marker-start (search-backward "<method" min t)) - exc-mode - exc-start) - (when marker-start - (when (looking-at mumamo-lzx-method-tag-start-regex) - (setq exc-start (match-end 0)) - (goto-char exc-start) - (when (<= exc-start pos) - (cons (point) 'javascript-mode)) - )))) - -;; (defun mumamo-search-bw-exc-end-inlined-lzx-method (pos min) -;; "Helper for `mumamo-chunk-inlined-lzx-method'. -;; POS is where to start search and MIN is where to stop." -;; (mumamo-chunk-end-bw-str pos min "</method>")) - -;; (defun mumamo-search-fw-exc-start-inlined-lzx-method-old (pos max) -;; "Helper for `mumamo-chunk-inlined-lzx-method'. -;; POS is where to start search and MAX is where to stop." -;; (goto-char (1+ pos)) -;; (skip-chars-backward "^<") -;; ;; Handle <![CDATA[ -;; (when (and -;; (eq ?< (char-before)) -;; (eq ?! (char-after)) -;; (not (bobp))) -;; (backward-char) -;; (skip-chars-backward "^<")) -;; (unless (bobp) -;; (backward-char 1)) -;; (let ((exc-start (search-forward "<method" max t)) -;; exc-mode) -;; (when exc-start -;; (goto-char (- exc-start 7)) -;; (when (looking-at mumamo-lzx-method-tag-start-regex) -;; (goto-char (match-end 0)) -;; (point) -;; )))) - -(defun mumamo-search-fw-exc-start-inlined-lzx-method (pos max) - "Helper for `mumamo-chunk-inlined-lzx-method'. -POS is where to start search and MAX is where to stop." - (goto-char (1+ pos)) - (skip-chars-backward "^<") - ;; Handle <![CDATA[ - (when (and - (eq ?< (char-before)) - (eq ?! (char-after)) - (not (bobp))) - (backward-char) - (skip-chars-backward "^<")) - (unless (bobp) - (backward-char 1)) - (let ((exc-start (search-forward "<method" max t)) - exc-mode) - (when exc-start - (goto-char (- exc-start 7)) - (when (looking-at mumamo-lzx-method-tag-start-regex) - (goto-char (match-end 0)) - (list (point) 'javascript-mode) - )))) - -(defun mumamo-search-fw-exc-end-inlined-lzx-method (pos max) - "Helper for `mumamo-chunk-inlined-lzx-method'. -POS is where to start search and MAX is where to stop." - (save-match-data - (mumamo-chunk-end-fw-str pos max "</method>"))) - -(defun mumamo-chunk-inlined-lzx-method (pos min max) - "Find <method>...</method>. Return range and 'javascript-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - ;; (mumamo-find-possible-chunk pos min max - ;; 'mumamo-search-bw-exc-start-inlined-lzx-method - ;; 'mumamo-search-bw-exc-end-inlined-lzx-method - ;; 'mumamo-search-fw-exc-start-inlined-lzx-method-old - ;; 'mumamo-search-fw-exc-end-inlined-lzx-method) - (mumamo-possible-chunk-forward pos max - 'mumamo-search-fw-exc-start-inlined-lzx-method - 'mumamo-search-fw-exc-end-inlined-lzx-method)) - -(defconst mumamo-lzx-handler-tag-start-regex - (rx "<handler" - (optional - space - (0+ (not (any ">")))) - ">" - ;; FIX-ME: Commented out because of bug in Emacs - ;; - ;;(optional (0+ space) "<![CDATA[" ) - )) - -;; (defun mumamo-search-bw-exc-start-inlined-lzx-handler (pos min) -;; "Helper for `mumamo-chunk-inlined-lzx-handler'. -;; POS is where to start search and MIN is where to stop." -;; (goto-char (+ pos 8)) -;; (let ((marker-start (search-backward "<handler" min t)) -;; exc-mode -;; exc-start) -;; (when marker-start -;; (when (looking-at mumamo-lzx-handler-tag-start-regex) -;; (setq exc-start (match-end 0)) -;; (goto-char exc-start) -;; (when (<= exc-start pos) -;; (cons (point) 'javascript-mode)) -;; )))) - -;; (defun mumamo-search-bw-exc-end-inlined-lzx-handler (pos min) -;; "Helper for `mumamo-chunk-inlined-lzx-handler'. -;; POS is where to start search and MIN is where to stop." -;; (mumamo-chunk-end-bw-str pos min "</handler>")) - -;; (defun mumamo-search-fw-exc-start-inlined-lzx-handler-old (pos max) -;; "Helper for `mumamo-chunk-inlined-lzx-handler'. -;; POS is where to start search and MAX is where to stop." -;; (goto-char (1+ pos)) -;; (skip-chars-backward "^<") -;; ;; Handle <![CDATA[ -;; (when (and -;; (eq ?< (char-before)) -;; (eq ?! (char-after)) -;; (not (bobp))) -;; (backward-char) -;; (skip-chars-backward "^<")) -;; (unless (bobp) -;; (backward-char 1)) -;; (let ((exc-start (search-forward "<handler" max t)) -;; exc-mode) -;; (when exc-start -;; (goto-char (- exc-start 8)) -;; (when (looking-at mumamo-lzx-handler-tag-start-regex) -;; (goto-char (match-end 0)) -;; (point) -;; )))) - -(defun mumamo-search-fw-exc-start-inlined-lzx-handler (pos max) - "Helper for `mumamo-chunk-inlined-lzx-handler'. -POS is where to start search and MAX is where to stop." - (goto-char (1+ pos)) - (skip-chars-backward "^<") - ;; Handle <![CDATA[ - (when (and - (eq ?< (char-before)) - (eq ?! (char-after)) - (not (bobp))) - (backward-char) - (skip-chars-backward "^<")) - (unless (bobp) - (backward-char 1)) - (let ((exc-start (search-forward "<handler" max t)) - exc-mode) - (when exc-start - (goto-char (- exc-start 8)) - (when (looking-at mumamo-lzx-handler-tag-start-regex) - (goto-char (match-end 0)) - (list (point) 'javascript-mode) - )))) - -(defun mumamo-search-fw-exc-end-inlined-lzx-handler (pos max) - "Helper for `mumamo-chunk-inlined-lzx-handler'. -POS is where to start search and MAX is where to stop." - (save-match-data - (mumamo-chunk-end-fw-str pos max "</handler>"))) - -(defun mumamo-chunk-inlined-lzx-handler (pos min max) - "Find <handler>...</handler>. Return range and 'javascript-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - ;; (mumamo-find-possible-chunk pos min max - ;; 'mumamo-search-bw-exc-start-inlined-lzx-handler - ;; 'mumamo-search-bw-exc-end-inlined-lzx-handler - ;; 'mumamo-search-fw-exc-start-inlined-lzx-handler-old - ;; 'mumamo-search-fw-exc-end-inlined-lzx-handler) - (mumamo-possible-chunk-forward pos max - 'mumamo-search-fw-exc-start-inlined-lzx-handler - 'mumamo-search-fw-exc-end-inlined-lzx-handler)) - - -;;;###autoload -(define-mumamo-multi-major-mode laszlo-nxml-mumamo-mode - "Turn on multiple major modes for OpenLaszlo." - ("OpenLaszlo Family" nxml-mode - (mumamo-chunk-inlined-script - mumamo-chunk-inlined-lzx-method - mumamo-chunk-inlined-lzx-handler - ))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; csound - -;; (defun mumamo-search-bw-exc-start-csound-orc (pos min) -;; "Helper for `mumamo-chunk-csound-orc'. -;; POS is where to start search and MIN is where to stop." -;; (let ((exc-start (mumamo-chunk-start-bw-str pos min "<csinstruments>"))) -;; (and exc-start -;; (<= exc-start pos) -;; (cons exc-start 'csound-orc-mode)))) - -;; (defun mumamo-search-bw-exc-end-csound-orc (pos min) -;; "Helper for `mumamo-chunk-csound-orc'. -;; POS is where to start search and MIN is where to stop." -;; (mumamo-chunk-end-bw-str pos min "</csinstruments>")) - -;; (defun mumamo-search-fw-exc-start-csound-orc-old (pos max) -;; "Helper for `mumamo-chunk-csound-orc'. -;; POS is where to start search and MAX is where to stop." -;; (mumamo-chunk-start-fw-str pos max "<csinstruments>")) - -(defun mumamo-search-fw-exc-start-csound-orc (pos max) - "Helper for `mumamo-chunk-csound-orc'. -POS is where to start search and MAX is where to stop." - (let ((where (mumamo-chunk-start-fw-str pos max "<csinstruments>"))) - (when where - (list where 'csound-orc-mode)))) - -(defun mumamo-search-fw-exc-end-csound-orc (pos max) - "Helper for `mumamo-chunk-csound-orc'. -POS is where to start search and MAX is where to stop." - (save-match-data - (mumamo-chunk-end-fw-str pos max "</csinstruments>"))) - -(defun mumamo-chunk-csound-orc (pos min max) - "Find <csinstruments>...</...>. Return range and 'csound-orc-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - ;; (mumamo-find-possible-chunk pos min max - ;; 'mumamo-search-bw-exc-start-csound-orc - ;; 'mumamo-search-bw-exc-end-csound-orc - ;; 'mumamo-search-fw-exc-start-csound-orc-old - ;; 'mumamo-search-fw-exc-end-csound-orc) - (mumamo-possible-chunk-forward pos max - 'mumamo-search-fw-exc-start-csound-orc - 'mumamo-search-fw-exc-end-csound-orc)) - -;; (defun mumamo-search-bw-exc-start-csound-sco (pos min) -;; "Helper for `mumamo-chunk-csound-sco'. -;; POS is where to start search and MIN is where to stop." -;; (let ((exc-start (mumamo-chunk-start-bw-str pos min "<csscore>"))) -;; (and exc-start -;; (<= exc-start pos) -;; (cons exc-start 'csound-sco-mode)))) - -;; (defun mumamo-search-bw-exc-end-csound-sco (pos min) -;; "Helper for `mumamo-chunk-csound-sco'. -;; POS is where to start search and MIN is where to stop." -;; (mumamo-chunk-end-bw-str pos min "</csscore>")) - -;; (defun mumamo-search-fw-exc-start-csound-sco-old (pos max) -;; "Helper for `mumamo-chunk-csound-sco'. -;; POS is where to start search and MAX is where to stop." -;; (mumamo-chunk-start-fw-str pos max "<csscore>")) - -(defun mumamo-search-fw-exc-start-csound-sco (pos max) - "Helper for `mumamo-chunk-csound-sco'. -POS is where to start search and MAX is where to stop." - (let ((where (mumamo-chunk-start-fw-str pos max "<csscore>"))) - (when where - (list where 'csound-sco-mode)))) - -(defun mumamo-search-fw-exc-end-csound-sco (pos max) - "Helper for `mumamo-chunk-csound-sco'. -POS is where to start search and MAX is where to stop." - (save-match-data - (mumamo-chunk-end-fw-str pos max "</csscore>"))) - -(defun mumamo-chunk-csound-sco (pos min max) - "Found <csscore>...</csscore>. Return range and 'csound-sco-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - ;; (mumamo-find-possible-chunk pos min max - ;; 'mumamo-search-bw-exc-start-csound-sco - ;; 'mumamo-search-bw-exc-end-csound-sco - ;; 'mumamo-search-fw-exc-start-csound-sco-old - ;; 'mumamo-search-fw-exc-end-csound-sco) - (mumamo-possible-chunk-forward pos max - 'mumamo-search-fw-exc-start-csound-sco - 'mumamo-search-fw-exc-end-csound-sco)) - -;;;###autoload -(define-mumamo-multi-major-mode csound-sgml-mumamo-mode - "Turn on mutiple major modes for CSound orc/sco Modes." - ("CSound orc/sco Modes" sgml-mode - (mumamo-chunk-csound-sco - mumamo-chunk-csound-orc - ))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; noweb - -;;;###autoload -(defgroup mumamo-noweb2 nil - "Customization group for `noweb2-mumamo-mode'." - :group 'mumamo-modes) - -(defcustom mumamo-noweb2-mode-from-ext - '( - ("php" . php-mode) - ("c" . c-mode) - ) - "File extension regexp to major mode mapping. -Used by `noweb2-mumamo-mode'." - :type '(repeat - (cons regexp major-mode-function)) - :group 'mumamo-noweb2) - -(defvar mumamo-noweb2-found-mode-from-ext nil - "Major modes determined from file names. Internal use.") - -(defun mumamo-noweb2-chunk-start-fw (pos max) - "Helper for `mumamo-noweb2-chunk'. -POS is where to start search and MAX is where to stop." - (let ((where (mumamo-chunk-start-fw-re pos max "^<<\\(.*?\\)>>=")) - (exc-mode 'text-mode)) - (when where - (let* ((file-name (match-string-no-properties 1)) - (file-ext (when file-name (file-name-extension file-name)))) - (when file-ext - (setq exc-mode (catch 'major - (dolist (rec mumamo-noweb2-mode-from-ext) - (when (string-match (car rec) file-ext) - (throw 'major (cdr rec)))) - nil)))) - (list where exc-mode)))) - -;; (defun mumamo-noweb2-chunk-start-bw (pos min) -;; "Helper for `mumamo-noweb2-chunk'. -;; POS is where to start search and MIN is where to stop." -;; (let ((exc-start (mumamo-chunk-start-bw-re pos min "^<<\\(.*?\\)>>=")) -;; (exc-mode 'text-mode)) -;; (when exc-start -;; (let* ((file-name (match-string 1)) -;; (file-ext (when file-name (file-name-extension file-name)))) -;; (when file-ext -;; (setq exc-mode (catch 'major -;; (dolist (rec mumamo-noweb2-mode-from-ext) -;; (when (string-match (car rec) file-ext) -;; (throw 'major (cdr rec)))) -;; nil)) -;; (unless exc-mode -;; (setq exc-mode -;; (cdr (assoc file-ext mumamo-noweb2-found-mode-from-ext))) -;; (unless exc-mode -;; ;; Get the major mode from file name -;; (with-temp-buffer -;; (setq buffer-file-name file-name) -;; (condition-case err -;; (normal-mode) -;; (error (message "error (normal-mode): %s" -;; (error-message-string err)))) -;; (setq exc-mode (or major-mode -;; 'text-mode)) -;; (add-to-list 'mumamo-noweb2-found-mode-from-ext -;; (cons file-ext exc-mode))) -;; )))) -;; (cons exc-start exc-mode)))) - -(defun mumamo-noweb2-chunk-end-fw (pos max) - "Helper for `mumamo-noweb2-chunk'. -POS is where to start search and MAX is where to stop." - (save-match-data - (mumamo-chunk-end-fw-re pos max "^@"))) - -;; (defun mumamo-noweb2-chunk-end-bw (pos min) -;; "Helper for `mumamo-noweb2-chunk'. -;; POS is where to start search and MIN is where to stop." -;; (mumamo-chunk-end-bw-re pos min "^@")) - -(defun mumamo-noweb2-code-chunk (pos min max) - "Find noweb chunks. Return range and found mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (save-match-data - ;; (mumamo-find-possible-chunk pos min max - ;; 'mumamo-noweb2-chunk-start-bw - ;; 'mumamo-noweb2-chunk-end-bw - ;; 'mumamo-noweb2-chunk-start-fw-old - ;; 'mumamo-noweb2-chunk-end-fw) - (mumamo-possible-chunk-forward pos max - 'mumamo-noweb2-chunk-start-fw - 'mumamo-noweb2-chunk-end-fw))) - - -;;;###autoload -(define-mumamo-multi-major-mode noweb2-mumamo-mode - "Multi major mode for noweb files." - ("noweb Family" latex-mode - (mumamo-noweb2-code-chunk))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Template-Toolkit - - - -;; (setq auto-mode-alist -;; (append '(("\\.tt2?$" . tt-mode)) auto-mode-alist )) - -;;(require 'tt-mode) -(defun mumamo-chunk-tt (pos min max) - "Find [% ... %], return range and `tt-mode'. -See `mumamo-find-possible-chunk' for POS, MIN and MAX. - -This is for Template Toolkit. -See URL `http://dave.org.uk/emacs/' for `tt-mode'." - (mumamo-quick-static-chunk pos min max "[%" "%]" t 'tt-mode nil)) - -(define-mumamo-multi-major-mode tt-html-mumamo-mode - "Turn on multiple major modes for TT files with main mode `nxhtml-mode'. -TT = Template-Toolkit. - -This also covers inlined style and javascript." - ("TT HTML Family" html-mode - (mumamo-chunk-tt - mumamo-chunk-inlined-style - mumamo-chunk-inlined-script - mumamo-chunk-style= - mumamo-chunk-onjs= - ))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Asp - -;;;; asp <%@language="javscript"%> - -(defvar mumamo-asp-default-major 'asp-js-mode) -(make-variable-buffer-local 'mumamo-asp-default-major) -(put 'mumamo-asp-default-major 'permanent-local t) - -(defconst mumamo-asp-lang-marker - (rx "<%@" - (0+ space) - "language" - (0+ space) - "=" - (0+ space) - "\"" - (submatch (1+ (not (any "\"")))) - "\"" - (0+ space))) - -(defun mumamo-search-fw-exc-start-jsp (pos min max) - ;; fix-me - ) -(defun mumamo-chunk-asp (pos min max) - "Find <% ... %>. Return range and 'asp-js-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - ;; Fix-me: this is broken! - ;; (mumamo-find-possible-chunk pos min max - ;; 'mumamo-search-bw-exc-start-asp - ;; 'mumamo-search-bw-exc-end-jsp - ;; 'mumamo-search-fw-exc-start-jsp-old - ;; 'mumamo-search-fw-exc-end-jsp) - (mumamo-possible-chunk-forward pos max - 'mumamo-search-fw-exc-start-asp - 'mumamo-search-fw-exc-end-jsp)) - - -;;;; asp <% ...> - -(defun mumamo-chunk-asp% (pos min max) - "Find <% ... %>. Return range and 'asp-js-mode or 'asp-vb-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (let* ((chunk (mumamo-quick-static-chunk pos min max "<%" "%>" t 'java-mode t)) - (beg (nth 0 chunk)) - (here (point)) - glang) - (when chunk - (goto-char beg) - (if (looking-at mumamo-asp-lang-marker) - (progn - (setq glang (downcase (match-string 1))) - (cond - ((string= glang "javascript") - (setq mumamo-asp-default-major 'asp-js-mode)) - ((string= glang "vbscript") - (setq mumamo-asp-default-major 'asp-vb-mode)) - ) - (setcar (nthcdr 2 chunk) 'mumamo-comment-mode)) - (setcar (nthcdr 2 chunk) mumamo-asp-default-major)) - chunk))) - -;;;; asp <script ...> - -(defconst mumamo-asp-script-tag-start-regex - (rx "<script" - space - (0+ (not (any ">"))) - "language" - (0+ space) - "=" - (0+ space) - ?\" - ;;(or "text" "application") - ;;"/" - ;;(or "javascript" "ecmascript") - ;; "text/javascript" - (submatch - (or "javascript" "vbscript")) - ?\" - (0+ (not (any ">"))) - ">" - ;; FIX-ME: Commented out because of bug in Emacs - ;; - ;;(optional (0+ space) "<![CDATA[" ) - )) - -;; (defun mumamo-asp-search-bw-exc-start-inlined-script (pos min) -;; "Helper function for `mumamo-asp-chunk-inlined-script'. -;; POS is where to start search and MIN is where to stop." -;; (goto-char (+ pos 7)) -;; (let ((marker-start (search-backward "<script" min t)) -;; (exc-mode 'asp-vb-mode) -;; exc-start -;; lang) -;; (when marker-start -;; (when (looking-at mumamo-asp-script-tag-start-regex) -;; (setq lang (downcase (match-string-no-properties 1))) -;; (cond -;; ((string= lang "javascript") -;; (setq exc-mode 'asp-js-mode)) -;; ((string= lang "vbscript") -;; (setq exc-mode 'asp-vb-mode)))) -;; (setq exc-start (match-end 0)) -;; (goto-char exc-start) -;; (when (<= exc-start pos) -;; (cons (point) exc-mode)) -;; ))) - -;; (defun mumamo-asp-search-fw-exc-start-inlined-script-old (pos max) -;; "Helper for `mumamo-chunk-inlined-script'. -;; POS is where to start search and MAX is where to stop." -;; (goto-char (1+ pos)) -;; (skip-chars-backward "^<") -;; ;; Handle <![CDATA[ -;; (when (and -;; (eq ?< (char-before)) -;; (eq ?! (char-after)) -;; (not (bobp))) -;; (backward-char) -;; (skip-chars-backward "^<")) -;; (unless (bobp) -;; (backward-char 1)) -;; (let ((exc-start (search-forward "<script" max t)) -;; exc-mode) -;; (when exc-start -;; (goto-char (- exc-start 7)) -;; (when (looking-at mumamo-asp-script-tag-start-regex) -;; (goto-char (match-end 0)) -;; (point) -;; )))) - -(defun mumamo-asp-search-fw-exc-start-inlined-script (pos max) - "Helper for `mumamo-chunk-inlined-script'. -POS is where to start search and MAX is where to stop." - (goto-char (1+ pos)) - (skip-chars-backward "^<") - ;; Handle <![CDATA[ - (when (and - (eq ?< (char-before)) - (eq ?! (char-after)) - (not (bobp))) - (backward-char) - (skip-chars-backward "^<")) - (unless (bobp) - (backward-char 1)) - (let ((exc-start (search-forward "<script" max t)) - (exc-mode 'asp-vb-mode) - (lang "vbscript")) - (when exc-start - (goto-char (- exc-start 7)) - (when (looking-at mumamo-asp-script-tag-start-regex) - (goto-char (match-end 0)) - (setq lang (downcase (match-string-no-properties 1))) - (cond - ((string= lang "javascript") - (setq exc-mode 'asp-js-mode)) - ((string= lang "vbscript") - (setq exc-mode 'asp-vb-mode))) - (list (point) exc-mode) - )))) - -(defun mumamo-asp-chunk-inlined-script (pos min max) - "Find <script language=... runat=...>...</script>. Return 'asp-js-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - ;; (mumamo-find-possible-chunk pos min max - ;; 'mumamo-asp-search-bw-exc-start-inlined-script - ;; 'mumamo-search-bw-exc-end-inlined-script - ;; 'mumamo-asp-search-fw-exc-start-inlined-script-old - ;; 'mumamo-search-fw-exc-end-inlined-script) - (mumamo-possible-chunk-forward pos max - 'mumamo-asp-search-fw-exc-start-inlined-script - 'mumamo-search-fw-exc-end-inlined-script)) - -;;;###autoload -(define-mumamo-multi-major-mode asp-html-mumamo-mode - "Turn on multiple major modes for ASP with main mode `html-mode'. -This also covers inlined style and javascript." - ("ASP Html Family" html-mode - (mumamo-chunk-asp% - mumamo-asp-chunk-inlined-script - mumamo-chunk-inlined-script - mumamo-chunk-style= - mumamo-chunk-onjs= - ))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Org-mode - -(defcustom mumamo-org-submodes - '( - (emacs-lisp emacs-lisp-mode) - (ruby ruby-mode) - (python python-mode) - (sh sh-mode) - (R R-mode) - (ditaa picture-mode) - ) - "Alist for conversion of org #+BEGIN_SRC specifier to major mode. -Works kind of like `mumamo-major-modes'. - -This may be used for example for org-babel \(see URL -`http://orgmode.org/worg/org-contrib/babel/')." - :type '(alist - :key-type (symbol :tag "Symbol in #BEGIN_SRC specifier") - :value-type (repeat (choice - (command :tag "Major mode") - (symbol :tag "Major mode (not yet loaded)"))) - ) - :group 'mumamo-modes) - -(defun mumamo-org-mode-from-spec (major-spec) - "Translate MAJOR-SPEC to a major mode. -Translate MAJOR-SPEC used in #BEGIN_SRC to a major mode. - -See `mumamo-org-submodes' for an explanation." - (mumamo-major-mode-from-spec major-spec mumamo-org-submodes)) - -(defun mumamo-chunk-org-html (pos min max) - "Find #+BEGIN_HTML ... #+END_HTML, return range and `html-mode'. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-quick-static-chunk pos min max "#+BEGIN_HTML" "#+END_HTML" nil 'html-mode nil)) - -;; (defun mumamo-search-bw-org-src-start (pos min) -;; "Helper for `mumamo-chunk-org-src'. -;; POS is where to start search and MIN is where to stop." -;; (let* ((exc-start (mumamo-chunk-start-bw-str pos min "#+BEGIN_SRC")) -;; (exc-mode (when exc-start -;; (let ((here (point))) -;; (goto-char exc-start) -;; (prog1 -;; (read (current-buffer)) -;; (goto-char here)))))) -;; (setq exc-mode (mumamo-org-mode-from-spec exc-mode)) -;; ;;(setq exc-mode (eval exc-mode)) -;; ;;(setq exc-mode 'text-mode) -;; ;;(when exc-mode (setq exc-mode (quote exc-mode))) -;; ;;(assert (eq exc-mode 'emacs-lisp-mode) t) -;; (when exc-start -;; (when (<= exc-start pos) -;; (cons exc-start exc-mode))))) - -;; (defun mumamo-search-bw-org-src-end (pos min) -;; "Helper for `mumamo-chunk-org-src'. -;; POS is where to start search and MIN is where to stop." -;; (mumamo-chunk-end-bw-str pos min "#+END_SRC")) - -;; (defun mumamo-search-fw-org-src-start-old (pos max) -;; "Helper for `mumamo-chunk-org-src'. -;; POS is where to start search and MAX is where to stop." -;; (mumamo-chunk-start-fw-str pos max "#+BEGIN_SRC")) - -(defun mumamo-search-fw-org-src-start (pos max) - "Helper for `mumamo-chunk-org-src'. -POS is where to start search and MAX is where to stop." - (let ((where (mumamo-chunk-start-fw-str pos max "#+BEGIN_SRC"))) - (when where - (let ((exc-mode (let ((here (point))) - (goto-char where) - (prog1 - (read (current-buffer)) - (goto-char here))))) - (setq exc-mode (mumamo-org-mode-from-spec exc-mode)) - (list where exc-mode))))) - -(defun mumamo-search-fw-org-src-end (pos max) - "Helper for `mumamo-chunk-org-src'. -POS is where to start search and MAX is where to stop." - (save-match-data - (mumamo-chunk-end-fw-str pos max "#+END_SRC"))) - -(defun mumamo-chunk-org-src (pos min max) - "Find #+BEGIN_SRC ... #+END_SRC, return range and choosen major mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX. - -See Info node `(org) Literal Examples' for how to specify major -mode." - ;; (mumamo-find-possible-chunk pos min max - ;; 'mumamo-search-bw-org-src-start - ;; 'mumamo-search-bw-org-src-end - ;; 'mumamo-search-fw-org-src-start-old - ;; 'mumamo-search-fw-org-src-end) - (mumamo-possible-chunk-forward pos max - 'mumamo-search-fw-org-src-start - 'mumamo-search-fw-org-src-end)) - -;;;###autoload -(define-mumamo-multi-major-mode org-mumamo-mode - "Turn on multiple major modes for `org-mode' files with main mode `org-mode'. -** Note about HTML subchunks: -Unfortunately this only allows `html-mode' (not `nxhtml-mode') in -sub chunks." - ("Org Mode + Html" org-mode - (mumamo-chunk-org-html - mumamo-chunk-org-src - ))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Mako - -;; See http://www.makotemplates.org/docs/syntax.html - -;;; Comments mode -;; Fix-me: move to mumamo.el -(defconst mumamo-comment-font-lock-keywords - (list - (cons "\\(.*\\)" (list 1 font-lock-comment-face)) - )) -(defvar mumamo-comment-font-lock-defaults - '(mumamo-comment-font-lock-keywords t t)) - -(define-derived-mode mumamo-comment-mode nil "Comment chunk" - "For comment blocks." - (set (make-local-variable 'font-lock-defaults) mumamo-comment-font-lock-defaults)) - - - -(defun mumamo-chunk-mako-<% (pos min max) - "Find <% ... %> and <%! ... %>. Return range and `python-mode'. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - ;; (mumamo-find-possible-chunk pos min max - ;; 'mumamo-mako-<%-bw-start - ;; 'mumamo-mako-<%-bw-end - ;; 'mumamo-mako-<%-fw-start-old - ;; 'mumamo-mako-<%-fw-end - ;; 'mumamo-mako-<%-find-borders) - (let ((chunk (mumamo-possible-chunk-forward pos max - 'mumamo-mako-<%-fw-start - 'mumamo-mako-<%-fw-end - 'mumamo-mako-<%-find-borders - ))) - (when chunk - (setcdr (last chunk) '(mumamo-template-indentor)) - chunk))) - -(defun mumamo-mako-<%-find-borders (start end exc-mode) - (when exc-mode - (list - (when start - (+ start - (if (eq ?! (char-after (+ start 2))) - 3 - 2))) - (when end (- end 2)) - exc-mode))) - -;; (defun mumamo-mako-<%-bw-start (pos min) -;; (let ((here (point)) -;; start -;; ret -;; ) -;; (goto-char (+ pos 3)) -;; (setq start (re-search-backward "<%!?\\(?:[ \t]\\|$\\)" min t)) -;; (when (and start (<= start pos)) -;; (setq ret (list start 'python-mode))) -;; (goto-char here) -;; ret)) - -;; (defun mumamo-mako-<%-bw-end (pos min) -;; (mumamo-chunk-end-bw-str-inc pos min "%>")) ;; ok - -;; (defun mumamo-mako-<%-fw-start-old (pos max) -;; (let ((here (point)) -;; start -;; ret) -;; (goto-char pos) -;; (setq start -;; (re-search-forward "<%!?\\(?:[ \t]\\|$\\)" max t)) -;; (when start -;; (setq ret (match-beginning 0))) -;; (goto-char here) -;; ret)) - -(defun mumamo-mako-<%-fw-start (pos max) - (let ((here (point)) - start - ret) - (goto-char pos) - (setq start - (re-search-forward "<%!?\\(?:[ \t]\\|$\\)" max t)) - (when start - (setq ret (match-beginning 0))) - (goto-char here) - (when ret - (list ret 'python-mode)))) - -(defun mumamo-mako-<%-fw-end (pos max) - (save-match-data - (mumamo-chunk-end-fw-str-inc pos max "%>"))) ;; ok - - - -(defun mumamo-chunk-mako-% (pos min max) - "Find % python EOL. Return range and `python-mode'. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (let ((chunk (mumamo-whole-line-chunk pos min max "%" 'python-mode))) - (when chunk - (setcdr (last chunk) '(mumamo-template-indentor)) - chunk))) - -(defun mumamo-chunk-mako-one-line-comment (pos min max) - "Find ## comment EOL. Return range and `python-mode'. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-whole-line-chunk pos min max "##" 'mumamo-comment-mode)) - -;; Fix-me: Move this to mumamo.el -;; Fix-me: does not work with new chunk div -(defun mumamo-whole-line-chunk-fw-exc-end-fun (pos max) - (let ((here (point))) - (goto-char pos) - (prog1 - (line-end-position) - (goto-char here)))) - -(defun mumamo-whole-line-chunk (pos min max marker mode) - (let* ((here (point)) - (len-marker (length marker)) - (pattern (rx-to-string `(and bol (0+ blank) ,marker blank) t)) - (whole-line-chunk-borders-fun - `(lambda (start end dummy) - (let ((start-border (+ start ,len-marker))) - (list start-border nil)))) - beg - end - ret) - (goto-char pos) - (setq beg (re-search-forward pattern max t)) - (when beg - (setq beg (- beg len-marker 1)) - (setq end (line-end-position)) - (setq ret (list beg - end - mode - (let ((start-border (+ beg len-marker))) - (list start-border nil)) - nil - 'mumamo-whole-line-chunk-fw-exc-end-fun - whole-line-chunk-borders-fun - ))) - (goto-char here) - ret)) - -;; (defun mumamo-single-regexp-chunk (pos min max begin-mark end-mark mode) -;; "Not ready yet. `mumamo-quick-static-chunk'" -;; (let ((here (point)) -;; (len-marker (length marker)) -;; beg -;; end -;; ret) -;; (goto-char pos) -;; (setq beg (line-beginning-position)) -;; (setq end (line-end-position)) -;; (unless (or (when min (< beg min)) -;; (when max (> end max)) -;; (= pos end)) -;; (goto-char beg) -;; (skip-chars-forward " \t") -;; (when (and -;; (string= marker (buffer-substring-no-properties (point) (+ (point) len-marker))) -;; (memq (char-after (+ (point) len-marker)) -;; '(?\ ?\t ?\n)) -;; (>= pos (point))) -;; (setq ret -;; (list (point) -;; end -;; mode -;; (let ((start-border (+ (point) len-marker))) -;; (list start-border nil)))))) -;; (unless ret -;; (let ((range-regexp -;; (concat "^[ \t]*" -;; "\\(" -;; (regexp-quote marker) -;; "[ \t\n].*\\)$"))) -;; ;; Backward -;; (goto-char pos) -;; (unless (= pos (line-end-position)) -;; (goto-char (line-beginning-position))) -;; (setq beg (re-search-backward range-regexp min t)) -;; (when beg (setq beg (match-end 1))) -;; ;; Forward, take care of indentation part -;; (goto-char pos) -;; (unless (= pos (line-end-position)) -;; (goto-char (line-beginning-position))) -;; (setq end (re-search-forward range-regexp max t)) -;; (when end (setq end (match-beginning 1)))) -;; (setq ret (list beg end))) -;; (goto-char here) -;; ;;(setq ret nil) -;; ret)) - - -(defun mumamo-chunk-mako-<%doc (pos min max) - (mumamo-quick-static-chunk pos min max "<%doc>" "</%doc>" t 'mumamo-comment-mode t)) - -(defun mumamo-chunk-mako-<%include (pos min max) - (mumamo-quick-static-chunk pos min max "<%include" "/>" t 'html-mode t)) - -(defun mumamo-chunk-mako-<%inherit (pos min max) - (mumamo-quick-static-chunk pos min max "<%inherit" "/>" t 'html-mode t)) - -(defun mumamo-chunk-mako-<%namespace (pos min max) - (mumamo-quick-static-chunk pos min max "<%namespace" "/>" t 'html-mode t)) - -(defun mumamo-chunk-mako-<%page (pos min max) - (mumamo-quick-static-chunk pos min max "<%page" "/>" t 'html-mode t)) - -;; Fix-me: this is not correct -(defun mumamo-chunk-mako-<%def (pos min max) - (mumamo-quick-static-chunk pos min max "<%def" "</%def>" t 'html-mode t)) - -(defun mumamo-chunk-mako$(pos min max) - "Find ${ ... }, return range and `python-mode'. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (mumamo-quick-static-chunk pos min max "${" "}" t 'python-mode t)) - -;;;###autoload -(define-mumamo-multi-major-mode mako-html-mumamo-mode - "Turn on multiple major modes for Mako with main mode `html-mode'. -This also covers inlined style and javascript." -;; Fix-me: test case -;; -;; Fix-me: Add chunks for the tags, but make sure these are made -;; invisible to nxml-mode parser. -;; -;; Fix-me: Maybe finally add that indentation support for one-line chunks? - ("Mako HTML Family" html-mode - ( - mumamo-chunk-mako-one-line-comment - mumamo-chunk-mako-<%doc - mumamo-chunk-mako-<%include - mumamo-chunk-mako-<%inherit - mumamo-chunk-mako-<%namespace - mumamo-chunk-mako-<%page - - mumamo-chunk-mako-<%def - ;;mumamo-chunk-mako-<%namesp:name - ;;mumamo-chunk-mako-<%call - ;;mumamo-chunk-mako-<%text - - mumamo-chunk-mako-<% - mumamo-chunk-mako-% - mumamo-chunk-mako$ - - mumamo-chunk-xml-pi - mumamo-chunk-inlined-style - mumamo-chunk-inlined-script - mumamo-chunk-style= - mumamo-chunk-onjs= - ))) -(mumamo-inherit-sub-chunk-family-locally 'mako-html-mumamo-mode 'mako-html-mumamo-mode) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; XSL - -;;;###autoload -(define-mumamo-multi-major-mode xsl-nxml-mumamo-mode - "Turn on multi major mode for XSL with main mode `nxml-mode'. -This covers inlined style and javascript." - ("XSL nXtml Family" nxml-mode - ( - mumamo-chunk-inlined-style - mumamo-chunk-inlined-script - ))) - -;;;###autoload -(define-mumamo-multi-major-mode xsl-sgml-mumamo-mode - "Turn on multi major mode for XSL with main mode `sgml-mode'. -This covers inlined style and javascript." - ("XSL SGML Family" sgml-mode - ( - mumamo-chunk-inlined-style - mumamo-chunk-inlined-script - ))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Markdown - -(defun mumamo-chunk-markdown-html-1 (pos min max) - (save-restriction - (goto-char pos) - (narrow-to-region (or min (point)) (or max (point-max))) - (save-match-data - (let ((here (point))) - (when (re-search-forward (rx (* space) - (submatch "<") - (* (any "a-z")) - (or ">" (any " \t\n"))) - nil t) - (let ((beg (match-beginning 1)) - (end)) - (goto-char beg) - (condition-case err - (progn - (while (not (sgml-skip-tag-forward 1))) - (setq end (point))) - (error (message "mumamo-chunk-markdown-html-1: %s" err))) - (goto-char here) - (when (and beg end) - (cons beg end)))))))) - -(defun mumamo-chunk-markdown-html-fw-exc-fun (pos max) - (let ((beg-end (mumamo-chunk-markdown-html-1 pos nil max))) - (cdr beg-end))) - -(defun mumamo-chunk-markdown-html (pos min max) - "Find a chunk of html code in `markdown-mode'. -Return range and `html-mode'. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - (let ((beg-end (mumamo-chunk-markdown-html-1 pos nil max))) - (when beg-end - (let ((beg (car beg-end)) - (end (cdr beg-end))) - (list beg end 'html-mode - nil ;; borders - nil ;; parseable y - 'mumamo-chunk-markdown-html-fw-exc-fun - nil ;; find-borders fun - ))))) - -;;;###autoload -(define-mumamo-multi-major-mode markdown-html-mumamo-mode - "Turn on multi major markdown mode in buffer. -Main major mode will be `markdown-mode'. -Inlined html will be in `html-mode'. - -You need `markdown-mode' which you can download from URL -`http://jblevins.org/projects/markdown-mode/'." - ("Markdown HTML Family" markdown-mode - ( - mumamo-chunk-markdown-html - ))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Latex related - -(defun mumamo-latex-closure-chunk (pos min max) - (mumamo-quick-static-chunk pos min max "\\begin{clojure}" "\\end{clojure}" t 'clojure-mode t)) - -;;;###autoload -(define-mumamo-multi-major-mode latex-clojure-mumamo-mode - "Turn on multi major mode latex+clojure. -Main major mode will be `latex-mode'. -Subchunks will be in `clojure-mode'. - -You will need `clojure-mode' which you can download from URL -`http://github.com/jochu/clojure-mode/tree'." - ("Latex+clojur Family" latex-mode - ( - mumamo-latex-closure-chunk - ))) - -(add-to-list 'auto-mode-alist '("\\.lclj\\'" . latex-clojure-mumamo-mode)) - - -(defun mumamo-latex-haskell-chunk (pos min max) - (mumamo-quick-static-chunk pos min max "\\begin{code}" "\\end{code}" t 'haskell-mode t)) - -;;;###autoload -(define-mumamo-multi-major-mode latex-haskell-mumamo-mode - "Turn on multi major mode latex+haskell. -Main major mode will be `latex-mode'. -Subchunks will be in `haskell-mode'. - -You will need `haskell-mode' which you can download from URL -`http://projects.haskell.org/haskellmode-emacs/'." - ("Latex+haskell Family" latex-mode - ( - mumamo-latex-haskell-chunk - ))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Python + ReST - -;; From Martin Soto - -(defun python-rst-long-string-chunk (pos min max) - "Find Python long strings. Return range and 'mumamo-comment-mode. -See `mumamo-find-possible-chunk' for POS, MIN and MAX." - ;;(mumamo-quick-static-chunk pos min max "\"\"\"((" "))\"\"\"" nil 'rst-mode nil)) - (mumamo-quick-static-chunk pos min max "\"\"\"" "\"\"\"" t 'rst-mode t)) - -;;;###autoload -(define-mumamo-multi-major-mode python-rst-mumamo-mode - "Turn on multiple major modes for Python with RestructuredText docstrings." - ("Python ReST Family" python-mode - ( - python-rst-long-string-chunk - ))) - - -(provide 'mumamo-fun) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; mumamo-fun.el ends here diff --git a/emacs.d/nxhtml/util/mumamo-regions.el b/emacs.d/nxhtml/util/mumamo-regions.el deleted file mode 100644 index 077be60..0000000 --- a/emacs.d/nxhtml/util/mumamo-regions.el +++ /dev/null @@ -1,311 +0,0 @@ -;;; mumamo-regions.el --- user defined regions with mumamo -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2009-05-31 Sun -;; Version: 0.5 -;; Last-Updated: 2009-06-01 Mon -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Add temporary mumamo chunks (called mumamo regions). This are -;; added interactively from a highlighted region. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'cl)) -(eval-when-compile (require 'mumamo)) -(eval-when-compile (require 'ourcomments-widgets)) -(require 'ps-print) ;; For ps-print-ensure-fontified - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Internal side functions etc - -(defvar mumamo-regions nil - "List of active mumamo regions. Internal use only. -The entries in this list should be like this - - \(OVL-DEF OVL-CHUNK) - -where OVL-DEF is an overlay containing the definitions, ie `major-mode'. -OVL-CHUNK is the definitions set up temporarily for mumamo chunks. - -The fontification functions in mumamo looks in this list, but the -chunk dividing functions defined by -`define-mumamo-multi-major-mode' does not. The effect is that -the normal chunks exists regardless of what is in this list, but -fontification etc is overridden by what this list says.") -(make-variable-buffer-local 'mumamo-regions) -(put 'mumamo-regions 'permanent-local t) - -(defun mumamo-add-region-1 (major start end buffer) - "Add a mumamo region with major mode MAJOR from START to END. -Return the region. The returned value can be used in -`mumamo-clear-region'. - -START and END should be markers in the buffer BUFFER. They may -also be nil in which case they extend the region to the buffer -boundaries." - (unless mumamo-multi-major-mode - (mumamo-temporary-multi-major)) - (or (not start) - (markerp start) - (eq (marker-buffer start) buffer) - (error "Bad arg start: %s" start)) - (or (not end) - (markerp end) - (eq (marker-buffer end) buffer) - (error "Bad arg end: %s" end)) - (let ((ovl (make-overlay start end))) - (overlay-put ovl 'mumamo-region 'defined) - (overlay-put ovl 'face 'mumamo-region) - (overlay-put ovl 'priority 2) - (mumamo-region-set-major ovl major) - (setq mumamo-regions (cons (list ovl nil) mumamo-regions)) - (mumamo-mark-for-refontification (overlay-start ovl) (overlay-end ovl)) - (message "Added mumamo region from %d to %d" (+ 0 start) (+ 0 end)) - ovl)) - -(defun mumamo-clear-region-1 (region-entry) - "Clear mumamo region REGION-ENTRY. -The entry must have been returned from `mumamo-add-region-1'." - (let ((buffer (overlay-buffer (car region-entry))) - (entry (cdr region-entry))) - (when (buffer-live-p buffer) - (with-current-buffer buffer - (let ((ovl1 (car region-entry)) - (ovl2 (cadr region-entry))) - (delete-overlay ovl1) - (when ovl2 - (mumamo-mark-for-refontification (overlay-start ovl2) (overlay-end ovl2)) - (delete-overlay ovl2)) - (setq mumamo-regions (delete region-entry mumamo-regions))))))) - -(defvar mumamo-region-priority 0) -(make-variable-buffer-local 'mumamo-region-priority) -(put 'mumamo-region-priority 'permanent-local t) - -(defun mumamo-get-region-from-1 (point) - "Return mumamo region values for POINT. -The return value is either mumamo chunk or a cons with -information about where regions starts to hide normal chunks. -Such a cons has the format \(BELOW . OVER) where each of them is -a position or nil." - (when mumamo-regions - (save-restriction - (widen) - (let* ((start nil) - (end nil) - (major nil) - hit-reg - ret-val) - (catch 'found-major - (dolist (reg mumamo-regions) - (assert (eq (overlay-get (car reg) 'mumamo-region) 'defined) t) - (assert (or (not (cadr reg)) (overlayp (cadr reg)))) - (let* ((this-ovl (car reg)) - (this-start (overlay-start this-ovl)) - (this-end (overlay-end this-ovl))) - (when (<= this-end point) - (setq start this-end)) - (when (< point this-start) - (setq end this-start)) - (when (and (<= this-start point) - (< point this-end)) - (setq major (overlay-get this-ovl 'mumamo-major-mode)) - (setq start (max this-start (or start this-start))) - (setq end (min this-end (or end this-end))) - (setq hit-reg reg) - (throw 'found-major nil))))) - (if major - (progn - (setq ret-val (nth 1 hit-reg)) - (when ret-val (assert (eq (overlay-get ret-val 'mumamo-region) 'used) t)) - (if ret-val - (move-overlay ret-val start end) - (setq ret-val (make-overlay start end nil t nil)) ;; fix-me - (setcar (cdr hit-reg) ret-val) - (overlay-put ret-val 'mumamo-region 'used) - (overlay-put ret-val 'priority ;; above normal chunks + chunks on chunks - (setq mumamo-region-priority (1+ mumamo-region-priority))) - ;;(overlay-put ret-val 'face '(:background "chocolate")) ;; temporary - (overlay-put ret-val 'mumamo-major-mode - (overlay-get (car hit-reg) 'mumamo-major-mode)))) - (setq ret-val (cons start end))) - ;;(message "mumamo-get-region-from-1, point=%s ret-val=%s" point ret-val) - ret-val)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; User side functions - -(defun mumamo-temporary-multi-major () - "Turn on a temporary multi major mode from buffers current mode. -Define one if no one exists. It will have no chunk dividing -routines. It is meant mainly to be used with mumamo regions when -there is no mumamo multi major mode in the buffer and the user -wants to add a mumamo region \(which requires a multi major mode -to work)." - (when mumamo-multi-major-mode - (error "Mumamo is already active in buffer")) - (let* ((temp-mode-name (concat "mumamo-1-" - (symbol-name major-mode))) - (temp-mode-sym (intern-soft temp-mode-name))) - (unless (and temp-mode-sym - (fboundp temp-mode-sym)) - (setq temp-mode-sym (intern temp-mode-name)) - (eval - `(define-mumamo-multi-major-mode ,temp-mode-sym - "Temporary multi major mode." - ("Temporary" ,major-mode nil)))) - (put temp-mode-sym 'mumamo-temporary major-mode) - (funcall temp-mode-sym))) - -(defface mumamo-region - '((t (:background "white"))) - "Face for mumamo-region regions." - :group 'mumamo) - -;;;###autoload -(defun mumamo-add-region () - "Add a mumamo region from selection. -Mumamo regions are like another layer of chunks above the normal chunks. -They does not affect the normal chunks, but they overrides them. - -To create a mumamo region first select a visible region and then -call this function. - -If the buffer is not in a multi major mode a temporary multi -major mode will be created applied to the buffer first. -To get out of this and get back to a single major mode just use - - M-x normal-mode" - (interactive) - (if (not mark-active) - (message (propertize "Please select a visible region first" 'face 'secondary-selection)) - (let ((beg (region-beginning)) - (end (region-end)) - (maj (mumamo-region-read-major))) - (mumamo-add-region-1 maj (copy-marker beg) (copy-marker end) (current-buffer)) - (setq deactivate-mark t)))) - -;;;###autoload -(defun mumamo-add-region-from-string () - "Add a mumamo region from string at point. -Works as `mumamo-add-region' but for string or comment at point. - -Buffer must be fontified." - (interactive) - ;; assure font locked. - (require 'ps-print) - (ps-print-ensure-fontified (point-min) (point-max)) - (let ((the-face (get-text-property (point) 'face))) - (if (not (memq the-face - '(font-lock-doc-face - font-lock-string-face - font-lock-comment-face))) - (message "No string or comment at point") - (let ((beg (previous-single-property-change (point) 'face)) - (end (next-single-property-change (point) 'face)) - (maj (mumamo-region-read-major))) - (setq beg (or (when beg (1+ beg)) - (point-min))) - (setq end (or (when end (1- end)) - (point-max))) - (mumamo-add-region-1 maj (copy-marker beg) (copy-marker end) (current-buffer)))))) -;; (dolist (o (overlays-in (point-min) (point-max))) (delete-overlay o)) -(defun mumamo-clear-all-regions () - "Clear all mumamo regions in buffer. -For information about mumamo regions see `mumamo-add-region'." - (interactive) - (unless mumamo-multi-major-mode - (error "There can be no mumamo regions to clear unless in multi major modes")) - (while mumamo-regions - (mumamo-clear-region-1 (car mumamo-regions)) - (setq mumamo-regions (cdr mumamo-regions))) - (let ((old (get mumamo-multi-major-mode 'mumamo-temporary))) - (when old (funcall old))) - (message "Cleared all mumamo regions")) - -(defun mumamo-region-read-major () - "Prompt user for major mode. -Accept only single major mode, not mumamo multi major modes." - (let ((major (read-command "Major mode: "))) - (unless (major-modep major) (error "Not a major mode: %s" major)) - (when (mumamo-multi-major-modep major) (error "Multi major modes not allowed: %s" major)) - (when (let ((major-mode major)) - (derived-mode-p 'nxml-mode)) - (error "%s is based on nxml-mode and can't be used here" major)) - major)) - -(defun mumamo-region-at (point) - "Return mumamo region at POINT." - (let ((ovls (overlays-at (point)))) - (catch 'overlay - (dolist (o ovls) - (when (overlay-get o 'mumamo-region) - (throw 'overlay o))) - nil))) - -(defun mumamo-region-set-major (ovl major) - "Change major mode for mumamo region at point. -For information about mumamo regions see `mumamo-add-region'. - -If run non-interactively then OVL should be a mumamo region and -MAJOR the major mode to set for that region." - (interactive - (list (or (mumamo-region-at (point)) - (error "There is no mumamo region at point")) - (mumamo-region-read-major))) - (overlay-put ovl 'mumamo-major-mode `(,major)) - (overlay-put ovl 'help-echo (format "Mumamo region, major mode `%s'" major))) - -(defun mumamo-clear-region (ovl) - "Clear the mumamo region at point. -For information about mumamo regions see `mumamo-add-region'. - -If run non-interactively then OVL should be the mumamo region to -clear." - (interactive - (list (or (mumamo-region-at (point)) - (error "There is no mumamo region at point")))) - (let ((region-entry (rassoc (list ovl) mumamo-regions))) - (unless region-entry - (error "No mumamo region found at point")) - (mumamo-clear-region-1 region-entry))) - - -(provide 'mumamo-regions) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; mumamo-regions.el ends here diff --git a/emacs.d/nxhtml/util/mumamo-trace.el b/emacs.d/nxhtml/util/mumamo-trace.el deleted file mode 100644 index 72b839b..0000000 --- a/emacs.d/nxhtml/util/mumamo-trace.el +++ /dev/null @@ -1,6 +0,0 @@ -(trace-function-background 'mumamo-fontify-region-1) -(trace-function-background 'mumamo-fontify-region-with) -(trace-function-background 'mumamo-mark-for-refontification) -(trace-function-background 'syntax-ppss-flush-cache) - -;;(untrace-all) diff --git a/emacs.d/nxhtml/util/mumamo.el b/emacs.d/nxhtml/util/mumamo.el deleted file mode 100644 index c59300f..0000000 --- a/emacs.d/nxhtml/util/mumamo.el +++ /dev/null @@ -1,9101 +0,0 @@ -;;; mumamo.el --- Multiple major modes in a buffer -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Maintainer: -;; Created: Fri Mar 09 2007 -(defconst mumamo:version "0.91") ;;Version: -;; Last-Updated: 2009-10-19 Mon -;; URL: http://OurComments.org/Emacs/Emacs.html -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; `appmenu', `apropos', `backquote', `button', `bytecomp', `cl', -;; `comint', `compile', `easymenu', `flyspell', `grep', `ido', -;; `ispell', `mail-prsvr', `mlinks', `mm-util', `nxml-enc', -;; `nxml-glyph', `nxml-mode', `nxml-ns', `nxml-outln', -;; `nxml-parse', `nxml-rap', `nxml-util', `ourcomments-util', -;; `recentf', `ring', `rng-dt', `rng-loc', `rng-match', -;; `rng-parse', `rng-pttrn', `rng-uri', `rng-util', `rng-valid', -;; `rx', `sgml-mode', `timer', `tool-bar', `tree-widget', -;; `url-expand', `url-methods', `url-parse', `url-util', -;; `url-vars', `wid-edit', `xmltok'. -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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, 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;;; Commentary: -;; -;; In some cases you may find that it is quite hard to write one major -;; mode that does everything for the type of file you want to handle. -;; That is the case for example for a PHP file where there comes -;; useful major modes with Emacs for the html parts, and where you can -;; get a major mode for PHP from other sources (see EmacsWiki for -;; Aaron Hawleys php-mode.el, or the very similar version that comes -;; with nXhtml). -;; -;; Using one major mode for the HTML part and another for the PHP part -;; sounds like a good solution. But this means you want to use (at -;; least) two major modes in the same buffer. -;; -;; This file implements just that, support for MUltiple MAjor MOdes -;; (mumamo) in a buffer. -;; -;; -;;;; Usage: -;; -;; The multiple major mode support is turned on by calling special -;; functions which are used nearly the same way as major modes. See -;; `mumamo-defined-multi-major-modes' for more information about those -;; functions. -;; -;; Each such function defines how to take care of a certain mix of -;; major functions in the buffer. We call them "multi major modes". -;; -;; You may call those functions directly (like you can with major mode -;; functions) or you may use them in for example `auto-mode-alist'. -;; -;; You can load mumamo in your .emacs with -;; -;; (require 'mumamo-fun) -;; -;; or you can generate an autoload file from mumamo-fun.el -;; -;; Note that no multi major mode functions are defined in this file. -;; Together with this file comes the file mumamo-fun.el that defines -;; some such functions. All those functions defined in that file are -;; marked for autoload. -;; -;; -;; -;; Thanks to Stefan Monnier for beeing a good and knowledgeable -;; speaking partner for some difficult parts while I was trying to -;; develop this. -;; -;; Thanks to RMS for giving me support and ideas about the programming -;; interface. That simplified the code and usage quite a lot. -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;;; How to add support for a new mix of major modes -;; -;; This is done by creating a new function using -;; `define-mumamo-multi-major-mode'. See that function for more -;; information. -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;;; Information for major mode authors -;; -;; There are a few special requirements on major modes to make them -;; work with mumamo: -;; -;; - fontification-functions should be '(jit-lock-function). However -;; nxml-mode derivates can work too, see the code for more info. -;; -;; - narrowing should be respected during fontification and -;; indentation when font-lock-dont-widen is non-nil. -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;;; Information for minor mode authors -;; -;; Some minor modes are written to be specific for the file edited in -;; the buffer and some are written to be specific for a major -;; modes. Others are emulating another editor. Those are probably -;; global, but might still have buffer local values. -;; -;; Those minor modes that are not meant to be specific for a major -;; mode should probably survive changing major mode in the -;; buffer. That is mostly not the case in Emacs today. -;; -;; There are (at least) two type of values for those minor modes that -;; sometimes should survive changing major mode: buffer local -;; variables and functions added locally to hooks. -;; -;; * Some buffer local variables are really that - buffer local. Other -;; are really meant not for the buffer but for the major mode or -;; some minor mode that is local to the buffer. -;; -;; If the buffer local variable is meant for the buffer then it is -;; easy to make them survive changing major mode: just add -;; -;; (put 'VARIABLE 'permanent-local t) -;; -;; to those variables. That will work regardless of the way major -;; mode is changed. -;; -;; If one only wants the variables to survive the major mode change -;; that is done when moving between chunks with different major -;; modes then something different must be used. To make a variable -;; survive this, but not a major mode change for the whole buffer, -;; call any the function `mumamo-make-variable-buffer-permanent': -;; -;; (mumamo-make-variable-buffer-permanent 'VARIABLE) -;; -;; * For functions entered to local hooks use this -;; -;; (put 'FUNSYM 'permanent-local-hook t) -;; (add-hook 'HOOKSYM 'FUNSYM nil t) -;; -;; where HOOKSYM is the hook and FUNSYM is the function. -;; -;; * Some functions that are run in `change-major-mode' and dito -;; after- must be avoided when mumamo changes major mode. The -;; functions to avoid should be listed in -;; -;; `mumamo-change-major-mode-no-nos' -;; `mumamo-after-change-major-mode-no-nos' -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;;; Comments on code etc: -;; -;; This is yet another way to try to get different major modes for -;; different chunks of a buffer to work. (I borrowed the term "chunk" -;; here from multi-mode.el.) I am aware of two main previous elisp -;; packages that tries to do this, multi-mode.el and mmm-mode.el. -;; (See http://www.emacswiki.org/cgi-bin/wiki/MultipleModes where -;; there are also some other packages mentioned.) The solutions in -;; those are a bit different from the approach here. -;; -;; The idea of doing it the way mumamo does it is of course based on a -;; hope that switching major mode when moving between chunks should be -;; quick. I found that it took from 0 - 62 000 ms, typically 0 - 16 -;; 000 ms on a 3ghz cpu. However unfortunately this is not the whole -;; truth. It could take longer time, depending on what is run in the -;; hooks: The major mode specific hook, `after-change-major-mode-hook' -;; and `change-major-mode-hook'. -;; -;; Because it currently may take long enough time switching major mode -;; when moving between chunks to disturb smooth moving around in the -;; buffer I have added a way to let the major mode switching be done -;; after moving when Emacs is idle. This is currently the default, but -;; see the custom variable `mumamo-set-major-mode-delay'. -;; -;; Since the intention is to set up the new major mode the same way as -;; it should have been done if this was a major mode for the whole -;; buffer these hooks must be run. However if this idea is developed -;; further some of the things done in these hooks (like switching on -;; minor modes) could perhaps be streamlined so that switching minor -;; modes off and then on again could be avoided. In fact there is -;; already tools for this in mumamo.el, see the section below named -;; "Information for minor mode authors". -;; -;; Another problem is that the major modes must use -;; `font-lock-fontify-region-function'. Currently the only major -;; modes I know that does not do this are `nxml-mode' and its -;; derivatives. -;; -;; The indentation is currently working rather ok, but with the price -;; that buffer modified is sometimes set even though there are no -;; actual changes. That seems a bit unnecessary and it could be -;; avoided if the indentation functions for the the various major -;; modes were rewritten so that you could get the indentation that -;; would be done instead of actually doing the indentation. (Or -;; mumamo could do this better, but I do not know how right now.) -;; -;; See also "Known bugs and problems etc" below. -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;;; Known bugs: -;; -;; - See the various FIX-ME for possible bugs. See also below. -;; -;; -;;;; Known problems and ideas: -;; -;; - There is no way in Emacs to tell a mode not to change -;; fontification when changing to or from that mode. -;; -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;;; Code: - -(eval-when-compile (require 'cl)) -(eval-when-compile (require 'cc-engine)) -(eval-when-compile (require 'desktop)) -(eval-when-compile (require 'flyspell)) -(eval-when-compile (require 'rngalt nil t)) -(eval-when-compile (require 'nxml-mode nil t)) -(eval-when-compile - (when (featurep 'nxml-mode) - (require 'rng-valid nil t) - ;;(require 'rngalt nil t) - )) -(eval-when-compile (require 'sgml-mode)) ;; For sgml-xml-mode -;; For `define-globalized-minor-mode-with-on-off': -;;(require 'ourcomments-util) - - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; rng-valid.el support - -(defvar rng-get-major-mode-chunk-function nil - "Function to use to get major mode chunk. -It should take one argument, the position where to get the major -mode chunk. - -This is to be set by multiple major mode frame works, like -mumamo. - -See also `rng-valid-nxml-major-mode-chunk-function' and -`rng-end-major-mode-chunk-function'. Note that all three -variables must be set.") -(make-variable-buffer-local 'rng-get-major-mode-chunk-function) -(put 'rng-get-major-mode-chunk-function 'permanent-local t) - -(defvar rng-valid-nxml-major-mode-chunk-function nil - "Function to use to check if nxml can parse major mode chunk. -It should take one argument, the chunk. - -For more info see also `rng-get-major-mode-chunk-function'.") -(make-variable-buffer-local 'rng-valid-nxml-major-mode-chunk-function) -(put 'rng-valid-nxml-major-mode-chunk-function 'permanent-local t) - -(defvar rng-end-major-mode-chunk-function nil - "Function to use to get the end of a major mode chunk. -It should take one argument, the chunk. - -For more info see also `rng-get-major-mode-chunk-function'.") -(make-variable-buffer-local 'rng-end-major-mode-chunk-function) -(put 'rng-end-major-mode-chunk-function 'permanent-local t) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Some variables - -(defvar mumamo-major-mode-indent-line-function nil) -(make-variable-buffer-local 'mumamo-major-mode-indent-line-function) - -(defvar mumamo-buffer-locals-per-major nil) -(make-variable-buffer-local 'mumamo-buffer-locals-per-major) -(put 'mumamo-buffer-locals-per-major 'permanent-local t) - -(defvar mumamo-just-changed-major nil - "Avoid refontification when switching major mode. -Set to t by `mumamo-set-major'. Checked and reset to nil by -`mumamo-jit-lock-function'.") -(make-variable-buffer-local 'mumamo-just-changed-major) - -(defvar mumamo-multi-major-mode nil - "The function that handles multiple major modes. -If this is nil then multiple major modes in the buffer is not -handled by mumamo. - -Set by functions defined by `define-mumamo-multi-major-mode'.") -(make-variable-buffer-local 'mumamo-multi-major-mode) -(put 'mumamo-multi-major-mode 'permanent-local t) - -(defvar mumamo-set-major-running nil - "Internal use. Handling of mumamo turn off.") - -(defun mumamo-chunk-car (chunk prop) - (car (overlay-get chunk prop))) - -(defun mumamo-chunk-cadr (chunk prop) - (cadr (overlay-get chunk prop))) - -;; (let ((l '(1 2))) (setcar (nthcdr 1 l) 10) l) -;; setters -(defsubst mumamo-chunk-value-set-min (chunk-values min) - "In CHUNK-VALUES set min value to MIN. -CHUNK-VALUES should have the format return by -`mumamo-create-chunk-values-at'." - (setcar (nthcdr 0 chunk-values) min)) -(defsubst mumamo-chunk-value-set-max (chunk-values max) - "In CHUNK-VALUES set max value to MAX. -See also `mumamo-chunk-value-set-min'." - (setcar (nthcdr 1 chunk-values) max)) -(defsubst mumamo-chunk-value-set-syntax-min (chunk-values min) - "In CHUNK-VALUES set min syntax diff value to MIN. -See also `mumamo-chunk-value-set-min'." - (setcar (nthcdr 3 chunk-values) min)) -(defsubst mumamo-chunk-value-set-syntax-max (chunk-values max) - "In CHUNK-VALUES set max syntax diff value to MAX. -See also `mumamo-chunk-value-set-min'." - (setcar (nthcdr 3 chunk-values) max)) -;; getters -(defsubst mumamo-chunk-value-min (chunk-values) - "Get min value from CHUNK-VALUES. -See also `mumamo-chunk-value-set-min'." - (nth 0 chunk-values)) -(defsubst mumamo-chunk-value-max (chunk-values) - "Get max value from CHUNK-VALUES. -See also `mumamo-chunk-value-set-min'." - (nth 1 chunk-values)) -(defsubst mumamo-chunk-value-major (chunk-values) - "Get major value from CHUNK-VALUES. -See also `mumamo-chunk-value-set-min'." - (nth 2 chunk-values)) -(defsubst mumamo-chunk-value-syntax-min (chunk-values) - "Get min syntax diff value from CHUNK-VALUES. -See also `mumamo-chunk-value-set-min'." - (nth 3 chunk-values)) -(defsubst mumamo-chunk-value-syntax-max (chunk-values) - "Get max syntax diff value from CHUNK-VALUES. -See also `mumamo-chunk-value-set-min'." - (nth 4 chunk-values)) -(defsubst mumamo-chunk-value-parseable-by (chunk-values) - "Get parseable-by from CHUNK-VALUES. -See also `mumamo-chunk-value-set-min'. -For parseable-by see `mumamo-find-possible-chunk'." - (nth 5 chunk-values)) -;; (defsubst mumamo-chunk-prev-chunk (chunk-values) -;; "Get previous chunk from CHUNK-VALUES. -;; See also `mumamo-chunk-value-set-min'." -;; (nth 6 chunk-values)) -(defsubst mumamo-chunk-value-fw-exc-fun (chunk-values) - "Get function that find chunk end from CHUNK-VALUES. -See also `mumamo-chunk-value-set-min'." - (nth 6 chunk-values)) - -(defsubst mumamo-chunk-major-mode (chunk) - "Get major mode specified in CHUNK." - ;;(assert chunk) - ;;(assert (overlay-buffer chunk)) - (let ((mode-spec (if chunk - (mumamo-chunk-car chunk 'mumamo-major-mode) - (mumamo-main-major-mode)))) - (mumamo-major-mode-from-modespec mode-spec))) - -(defsubst mumamo-chunk-syntax-min-max (chunk no-obscure) - (when chunk - (let* ((ovl-end (overlay-end chunk)) - (ovl-start (overlay-start chunk)) - (syntax-min (min ovl-end - (+ ovl-start - (or (overlay-get chunk 'mumamo-syntax-min-d) - 0)))) - ;;(dummy (msgtrc "chunk-syntax-min-max:syntax-min=%s, chunk=%S" syntax-min chunk)) - (syntax-max - (max ovl-start - (- (overlay-end chunk) - (or (overlay-get chunk 'mumamo-syntax-max-d) - 0) - (if (= (1+ (buffer-size)) - (overlay-end chunk)) - 0 - ;; Note: We must subtract one here because - ;; overlay-end is +1 from the last point in the - ;; overlay. - ;; - ;; This cured the problem with - ;; kubica-freezing-i.html that made Emacs loop - ;; in `font-lock-extend-region-multiline'. But - ;; was it really this one, I can't find any - ;; 'font-lock-multiline property. So it should - ;; be `font-lock-extend-region-whole-lines'. - ;; - ;; Should not the problem then be the value of font-lock-end? - ;; - ;; Fix-me: however this is not correct since it - ;; leads to not fontifying the last character in - ;; the chunk, see bug 531324. - ;; - ;; I think this is cured by now. I have let - ;; bound `font-lock-extend-region-functions' - ;; once more before the call to - ;; `font-lock-fontify-region'. - 0 - ;;0 - )))) - (obscure (unless no-obscure (overlay-get chunk 'obscured))) - (region-info (cadr obscure)) - (obscure-min (car region-info)) - (obscure-max (cdr region-info)) - ;;(dummy (message "syn-mn-mx:obs=%s r-info=%s ob=%s/%s" obscure region-info obscure-min obscure-max )) - (actual-min (max (or obscure-min ovl-start) - (or syntax-min ovl-start))) - (actual-max (min (or obscure-max ovl-end) - (or syntax-max ovl-end))) - (maj (mumamo-chunk-car chunk 'mumamo-major-mode)) - ;;(dummy (message "syn-mn-mx:obs=%s r-info=%s ob=%s/%s ac=%s/%s" obscure region-info obscure-min obscure-max actual-min actual-max)) - ) - (cons actual-min actual-max)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Macros - -;; Borrowed from font-lock.el -(defmacro mumamo-save-buffer-state (varlist &rest body) - "Bind variables according to VARLIST and eval BODY restoring buffer state. -Do not record undo information during evaluation of BODY." - (declare (indent 1) (debug let)) - (let ((modified (make-symbol "modified"))) - `(let* ,(append varlist - `((,modified (buffer-modified-p)) - (buffer-undo-list t) - (inhibit-read-only t) - (inhibit-point-motion-hooks t) - (inhibit-modification-hooks t) - deactivate-mark - buffer-file-name - buffer-file-truename)) - (progn - ,@body) - (unless ,modified - (restore-buffer-modified-p nil))))) - -;; From jit-lock.el: -(defmacro mumamo-jit-with-buffer-unmodified (&rest body) - "Eval BODY, preserving the current buffer's modified state." - (declare (debug t)) - (let ((modified (make-symbol "modified"))) - `(let ((,modified (buffer-modified-p))) - (unwind-protect - (progn ,@body) - (unless ,modified - (restore-buffer-modified-p nil)))))) - -(defmacro mumamo-with-buffer-prepared-for-jit-lock (&rest body) - "Execute BODY in current buffer, overriding several variables. -Preserves the `buffer-modified-p' state of the current buffer." - (declare (debug t)) - `(mumamo-jit-with-buffer-unmodified - (let ((buffer-undo-list t) - (inhibit-read-only t) - (inhibit-point-motion-hooks t) - (inhibit-modification-hooks t) - deactivate-mark - buffer-file-name - buffer-file-truename) - ,@body))) - -(defmacro mumamo-condition-case (var body-form &rest handlers) - "Like `condition-case', but optional. -If `mumamo-use-condition-case' is non-nil then do - - (condition-case VAR - BODY-FORM - HANDLERS). - -Otherwise just evaluate BODY-FORM." - (declare (indent 2) (debug t)) - `(if (not mumamo-use-condition-case) - (let* ((debugger (or mumamo-debugger 'debug)) - (debug-on-error (if debugger t debug-on-error))) - ,body-form) - (condition-case ,var - ,body-form - ,@handlers))) - -(defmacro mumamo-msgfntfy (format-string &rest args) - "Give some messages during fontification. -This macro should just do nothing during normal use. However if -there are any problems you can uncomment one of the lines in this -macro and recompile/reeval mumamo.el to get those messages. - -You have to search the code to see where you will get them. All -uses are in this file. - -FORMAT-STRING and ARGS have the same meaning as for the function -`message'." - ;;(list 'apply (list 'quote 'msgtrc) format-string (append '(list) args)) - ;;(list 'apply (list 'quote 'message) format-string (append '(list) args)) - ;;(list 'progn 'apply (list 'quote 'message) format-string (append '(list) args) nil) - ;; (condition-case err - ;; (list 'apply (list 'quote 'message) format-string (append '(list) args)) ;; <-- - ;; (error (message "err in msgfntfy %S" err))) - ;;(message "%s %S" format-string args) - ;;(list 'apply (list 'quote 'message) (list 'concat "%s: " format-string) - ;; (list 'get-internal-run-time) (append '(list) args)) - ) -;;(mumamo-msgfntfy "my-format=%s" (get-internal-run-time)) - -(defmacro mumamo-msgindent (format-string &rest args) - "Give some messages during indentation. -This macro should just do nothing during normal use. However if -there are any problems you can uncomment one of the lines in this -macro and recompile/reeval mumamo.el to get those messages. - -You have to search the code to see where you will get them. All -uses are in this file. - -FORMAT-STRING and ARGS have the same meaning as for the function -`message'." - ;;(list 'apply (list 'quote 'msgtrc) format-string (append '(list) args)) - ;;(list 'apply (list 'quote 'message) format-string (append '(list) args)) ;; <--- - ;;(list 'apply (list 'quote 'message) (list 'concat "%s: " format-string) - ;; (list 'get-internal-run-time) (append '(list) args)) - ) - -(defmacro mumamo-with-major-mode-setup (major for-what &rest body) - "Run code with some local variables set as in specified major mode. -Set variables as needed for major mode MAJOR when doing FOR-WHAT -and then run BODY using `with-syntax-table'. - -FOR-WHAT is used to choose another major mode than MAJOR in -certain cases. It should be 'fontification or 'indentation. - -Note: We must let-bind the variables here instead of make them buffer -local since they otherwise could be wrong at \(point) in top -level \(ie user interaction level)." - (declare (indent 2) (debug t)) - `(let ((need-major-mode (mumamo-get-major-mode-substitute ,major ,for-what))) - ;;(msgtrc "mumamo-with-major-mode-setup %s => %s, modified=%s" ,major need-major-mode (buffer-modified-p)) - ;;(msgtrc "with-major-mode-setup <<<<<<<<<< body=%S\n>>>>>>>>>>" '(progn ,@body)) - ;;(msgtrc "with-major-mode-setup:in buffer %s after-chunk=%s" (current-buffer) (when (boundp 'after-chunk) after-chunk)) - (let ((major-mode need-major-mode) - (evaled-set-mode (mumamo-get-major-mode-setup need-major-mode))) - ;;(message ">>>>>> before %s" evaled-set-mode) - ;;(message ">>>>>> before %s, body=%s" evaled-set-mode (list ,@body)) - (funcall (symbol-value evaled-set-mode) - (list 'progn - ,@body)) - ;;(mumamo-msgfntfy "<<<<<< after evaled-set-mode modified=%s" (buffer-modified-p)) - ))) - -(defmacro mumamo-with-major-mode-fontification (major &rest body) - "With fontification variables set as major mode MAJOR eval BODY. -This is used during font locking and indentation. The variables -affecting those are set as they are in major mode MAJOR. - -See the code in `mumamo-fetch-major-mode-setup' for exactly which -local variables that are set." - (declare (indent 1) (debug t)) - `(mumamo-with-major-mode-setup ,major 'fontification - ,@body)) -;; Fontification disappears in for example *grep* if -;; font-lock-mode-major-mode is 'permanent-local t. -;;(put 'font-lock-mode-major-mode 'permanent-local t) - -(defmacro mumamo-with-major-mode-indentation (major &rest body) - "With indentation variables set as in another major mode do things. -Same as `mumamo-with-major-mode-fontification' but for -indentation. See that function for some notes about MAJOR and -BODY." - (declare (indent 1) (debug t)) - `(mumamo-with-major-mode-setup ,major 'indentation ,@body)) - -;; fix-me: tell no sub-chunks in sub-chunks -;;;###autoload -(defmacro define-mumamo-multi-major-mode (fun-sym spec-doc chunks) - "Define a function that turn on support for multiple major modes. -Define a function FUN-SYM that set up to divide the current -buffer into chunks with different major modes. - -The documentation string for FUN-SYM should contain the special -documentation in the string SPEC-DOC, general documentation for -functions of this type and information about chunks. - -The new function will use the definitions in CHUNKS \(which is -called a \"chunk family\") to make the dividing of the buffer. - -The function FUN-SYM can be used to setup a buffer instead of a -major mode function: - -- The function FUN-SYM can be called instead of calling a major - mode function when you want to use multiple major modes in a - buffer. - -- The defined function can be used instead of a major mode - function in for example `auto-mode-alist'. - -- As the very last thing FUN-SYM will run the hook FUN-SYM-hook, - just as major modes do. - -- There is also a general hook, `mumamo-turn-on-hook', which is - run when turning on mumamo with any of these functions. This - is run right before the hook specific to any of the functions - above that turns on the multiple major mode support. - -- The multi major mode FUN-SYM has a keymap named FUN-SYM-map. - This overrides the major modes' keymaps since it is handled as - a minor mode keymap. - -- There is also a special mumamo keymap, `mumamo-map' that is - active in every buffer with a multi major mode. This is also - handled as a minor mode keymap and therefor overrides the major - modes' keymaps. - -- However when this support for multiple major mode is on the - buffer is divided into chunks, each with its own major mode. - -- The chunks are fontified according the major mode assigned to - them for that. - -- Indenting is also done according to the major mode assigned to - them for that. - -- The actual major mode used in the buffer is changed to the one - in the chunk when moving point between these chunks. - -- When major mode is changed the hooks for the new major mode, - `after-change-major-mode-hook' and `change-major-mode-hook' are - run. - -- There will be an alias for FUN-SYM called mumamo-alias-FUN-SYM. - This can be used to check whic multi major modes have been - defined. - -** A little bit more technical description: - -The dividing of a buffer into chunks is done during fontification -by `mumamo-get-chunk-at'. - -The name of the function is saved in in the buffer local variable -`mumamo-multi-major-mode' when the function is called. - -All functions defined by this macro is added to the list -`mumamo-defined-multi-major-modes'. - -Basically Mumamo handles only major modes that uses jit-lock. -However as a special effort also `nxml-mode' and derivatives -thereof are handled. Since it seems impossible to me to restrict -those major modes fontification to only a chunk without changing -`nxml-mode' the fontification is instead done by -`html-mode'/`sgml-mode' for chunks using `nxml-mode' and its -derivates. - -CHUNKS is a list where each entry have the format - - \(CHUNK-DEF-NAME MAIN-MAJOR-MODE SUBMODE-CHUNK-FUNCTIONS) - -CHUNK-DEF-NAME is the key name by which the entry is recognized. -MAIN-MAJOR-MODE is the major mode used when there is no chunks. -If this is nil then `major-mode' before turning on this mode will -be used. - -SUBMODE-CHUNK-FUNCTIONS is a list of the functions that does the -chunk division of the buffer. They are tried in the order they -appear here during the chunk division process. - -If you want to write new functions for chunk divisions then -please see `mumamo-find-possible-chunk'. You can perhaps also -use `mumamo-quick-static-chunk' which is more easy-to-use -alternative. See also the file mumamo-fun.el where there are -many routines for chunk division. - -When you write those new functions you may want to use some of -the functions for testing chunks: - - `mumamo-test-create-chunk-at' `mumamo-test-create-chunks-at-all' - `mumamo-test-easy-make' `mumamo-test-fontify-region' - -These are in the file mumamo-test.el." - ;;(let ((c (if (symbolp chunks) (symbol-value chunks) chunks))) (message "c=%S" c)) - (let* (;;(mumamo-describe-chunks (make-symbol "mumamo-describe-chunks")) - (turn-on-fun (if (symbolp fun-sym) - fun-sym - (error "Parameter FUN-SYM must be a symbol"))) - (turn-on-fun-alias (intern (concat "mumamo-alias-" (symbol-name fun-sym)))) - ;; Backward compatibility nXhtml v 1.60 - (turn-on-fun-old (when (string= (substring (symbol-name fun-sym) -5) - "-mode") - (intern (substring (symbol-name fun-sym) 0 -5)))) - (turn-on-hook (intern (concat (symbol-name turn-on-fun) "-hook"))) - (turn-on-map (intern (concat (symbol-name turn-on-fun) "-map"))) - (turn-on-hook-doc (concat "Hook run at the very end of `" - (symbol-name turn-on-fun) "'.")) - (chunks2 (if (symbolp chunks) - (symbol-value chunks) - chunks)) - (docstring - (concat - spec-doc - " - - - -This function is called a multi major mode. It sets up for -multiple major modes in the buffer in the following way: - -" - ;; Fix-me: During byte compilation the next line is not - ;; expanded as I thought because the functions in CHUNKS - ;; are not defined. How do I fix this? Move out the - ;; define-mumamo-multi-major-mode calls? - (funcall 'mumamo-describe-chunks chunks2) - " -At the very end this multi major mode function runs first the hook -`mumamo-turn-on-hook' and then `" (symbol-name turn-on-hook) "'. - -There is a keymap specific to this multi major mode, but it is -not returned by `current-local-map' which returns the chunk's -major mode's local keymap. - -The multi mode keymap is named `" (symbol-name turn-on-map) "'. - - - -The main use for a multi major mode is to use it instead of a -normal major mode in `auto-mode-alist'. \(You can of course call -this function directly yourself too.) - -The value of `mumamo-multi-major-mode' tells you which multi -major mode if any has been turned on in a buffer. For more -information about multi major modes please see -`define-mumamo-multi-major-mode'. - -Note: When adding new font-lock keywords for major mode chunks -you should use the function `mumamo-refresh-multi-font-lock' -afterwards. -" ))) - `(progn - ;;(add-to-list 'mumamo-defined-multi-major-modes (cons (car ',chunks2) ',turn-on-fun)) - (mumamo-add-to-defined-multi-major-modes (cons (car ',chunks2) ',turn-on-fun)) - (defvar ,turn-on-hook nil ,turn-on-hook-doc) - (defvar ,turn-on-map (make-sparse-keymap) - ,(concat "Keymap for multi major mode function `" - (symbol-name turn-on-fun) "'")) - (defvar ,turn-on-fun nil) - (make-variable-buffer-local ',turn-on-fun) - (put ',turn-on-fun 'permanent-local t) - (put ',turn-on-fun 'mumamo-chunk-family (copy-tree ',chunks2)) - (put ',turn-on-fun-alias 'mumamo-chunk-family (copy-tree ',chunks2)) - (defun ,turn-on-fun nil ,docstring - (interactive) - (let ((old-major-mode (or mumamo-major-mode - major-mode))) - (kill-all-local-variables) - (run-hooks 'change-major-mode-hook) - (setq mumamo-multi-major-mode ',turn-on-fun) - (setq ,turn-on-fun t) - (mumamo-add-multi-keymap ',turn-on-fun ,turn-on-map) - (setq mumamo-current-chunk-family (copy-tree ',chunks2)) - (mumamo-turn-on-actions old-major-mode) - (run-hooks ',turn-on-hook))) - (defalias ',turn-on-fun-alias ',turn-on-fun) - (when (intern-soft ',turn-on-fun-old) - (defalias ',turn-on-fun-old ',turn-on-fun)) - ))) - -;;;###autoload -(defun mumamo-add-to-defined-multi-major-modes (entry) - (add-to-list 'mumamo-defined-multi-major-modes entry)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Debugging etc - -(defsubst mumamo-while (limit counter where) - (let ((count (symbol-value counter))) - (if (= count limit) - (progn - (msgtrc "Reached (while limit=%s, where=%s)" limit where) - nil) - (set counter (1+ count))))) - -;; (defun dbg-smarty-err () -;; ;; (insert "}{") - -;; ;; (insert "}{") -;; ;; (backward-char) -;; ;; (backward-char) -;; ;; (search-backward "}") - -;; ;; This gives an error rather often, but not always: -;; (delete-char 3) -;; (search-backward "}") -;; ) - -;; (defun dbg-smarty-err2 () -;; (forward-char 5) -;; (insert "}{") -;; ;; Start in nxhtml part and make sure the insertion is in smarty -;; ;; part. Gives reliably an error if moved backward so point stay in -;; ;; the new nxhtml-mode part, otherwise not. -;; ;; -;; ;; Eh, no. If chunk family is changed and reset there is no more an -;; ;; error. -;; ;; -;; ;; Seems to be some race condition, but I am unable to understand -;; ;; how. I believed that nxml always left in a reliable state. Is -;; ;; this a state problem in mumamo or nxml? I am unable to make it -;; ;; happen again now. -;; ;; -;; ;; I saw one very strange thing: The error message got inserted in -;; ;; the .phps buffer once. How could this happen? Is this an Emacs -;; ;; bug? Can't see how this could happen since it is the message -;; ;; function that outputs the message. A w32 race condition? Are -;; ;; people aware that the message queue runs in parallell? (I have -;; ;; tried to ask on the devel list, but got no answer at that time.) -;; (backward-char 2) -;; ) - - -(defvar msgtrc-buffer - "*Messages*" - ;;"*trace-output*" - "Buffer or name of buffer for trace messages. -See `msgtrc'." - ) - -(defun msgtrc (format-string &rest args) - "Print message to `msgtrc-buffer'. -Arguments FORMAT-STRING and ARGS are like for `message'." - (if nil - nil ;;(apply 'message format-string args) - ;; bug#3350 prevents use of this: - (let ((trc-buffer (get-buffer-create msgtrc-buffer)) - ;; Cure 3350: Stop insert from deactivating the mark - (deactivate-mark)) - (with-current-buffer trc-buffer - (goto-char (point-max)) - (insert "MU:" (apply 'format format-string args) "\n") - ;;(insert "constant string\n") - (when buffer-file-name (write-region nil nil buffer-file-name)))))) - -(defvar mumamo-message-file-buffer nil) -(defsubst mumamo-msgtrc-to-file () - "Start writing message to file. Erase `msgtrc-buffer' first." - (unless mumamo-message-file-buffer - (setq mumamo-message-file-buffer (find-file-noselect "c:/emacs/bugs/temp-messages.txt")) - (setq msgtrc-buffer mumamo-message-file-buffer) - (with-current-buffer mumamo-message-file-buffer - (erase-buffer)))) - -(defvar mumamo-display-error-lwarn nil - "Set to t to call `lwarn' on fontification errors. -If this is t then `*Warnings*' buffer will popup on fontification -errors.") -(defvar mumamo-display-error-stop nil - "Set to t to stop fontification on errors.") - -(defun mumamo-message-with-face (msg face) - "Put MSG with face FACE in *Messages* buffer." - (let ((start (+ (with-current-buffer msgtrc-buffer - (point-max)) - 1)) - ;; This is for the echo area: - (msg-with-face (propertize (format "%s" msg) - 'face face))) - - (msgtrc "%s" msg-with-face) - ;; This is for the buffer: - (with-current-buffer msgtrc-buffer - (goto-char (point-max)) - (backward-char) - (put-text-property start (point) - 'face face)))) - -;;(run-with-idle-timer 1 nil 'mumamo-show-report-message) -(defun mumamo-show-report-message () - "Tell the user there is a long error message." - (save-match-data ;; runs in timer - (mumamo-message-with-face - "MuMaMo error, please look in the *Messages* buffer" - 'highlight))) - -;; This code can't be used now because `debugger' is currently not -;; useable in timers. I keep it here since I hope someone will make it -;; possible in the future. -;; -;; (defmacro mumamo-get-backtrace-if-error (bodyform) -;; "Evaluate BODYFORM, return a list with error message and backtrace. -;; If there is an error in BODYFORM then return a list with the -;; error message and the backtrace as a string. Otherwise return -;; nil." -;; `(let* ((debugger -;; (lambda (&rest debugger-args) -;; (let ((debugger-ret (with-output-to-string (backtrace)))) -;; ;; I believe we must put the result in a buffer, -;; ;; otherwise `condition-case' might erase it: -;; (with-current-buffer (get-buffer-create "TEMP GET BACKTRACE") -;; (erase-buffer) -;; (insert debugger-ret))))) -;; (debug-on-error t) -;; (debug-on-signal t)) -;; (mumamo-condition-case err -;; (progn -;; ,bodyform -;; nil) -;; (error -;; (let* ((errmsg (error-message-string err)) -;; (dbg1-ret -;; (with-current-buffer -;; (get-buffer "TEMP GET BACKTRACE") (buffer-string))) -;; ;; Remove lines from this routine: -;; (debugger-lines (split-string dbg1-ret "\n")) -;; (dbg-ret (mapconcat 'identity (nthcdr 6 debugger-lines) "\n")) -;; ) -;; (list errmsg (concat errmsg "\n" dbg-ret))))))) - -;;(mumamo-display-error 'test-lwarn-type "testing 1=%s, 2=%s" "one" 'two) -(defun mumamo-display-error (lwarn-type format-string &rest args) - "Display a message plus traceback in the *Messages* buffer. -Use this for errors that happen during fontification or when -running a timer. - -LWARN-TYPE is used as the type argument to `lwarn' if warnings -are displayed. FORMAT-STRING and ARGS are used as the -corresponding arguments to `message' and `lwarn'. - -All the output from this function in the *Messages* buffer is -displayed with the highlight face. After the message printed by -`message' is traceback from where this function was called. -Note: There is no error generated, just a traceback that is put -in *Messages* as above. - -Display an error message using `message' and colorize it using -the `highlight' face to make it more prominent. Add a backtrace -colored with the `highlight' face to the buffer *Messages*. Then -display the error message once again after this so that the user -can see it. - -If `mumamo-display-error-lwarn' is non-nil, indicate the error by -calling `lwarn'. This will display the `*Warnings*' buffer and -thus makes it much more easy to spot that there was an error. - -If `mumamo-display-error-stop' is non-nil raise an error that may -stop fontification." - - ;; Warnings are sometimes disturbning, make it optional: - (when mumamo-display-error-lwarn - (apply 'lwarn lwarn-type :error format-string args)) - - (let ((format-string2 (concat "%s: " format-string)) - (bt (with-output-to-string (backtrace)))) - - (mumamo-message-with-face - (concat - (apply 'format format-string2 lwarn-type args) - "\n" - (format "** In buffer %s\n" (current-buffer)) - bt) - 'highlight) - - ;; Output message once again so the user can see it: - (apply 'message format-string2 lwarn-type args) - ;; But ... there might be more messages so wait until things has - ;; calmed down and then show a message telling that there was an - ;; error and that there is more information in the *Messages* - ;; buffer. - (run-with-idle-timer 1 nil 'mumamo-show-report-message) - - ;; Stop fontifying: - (when mumamo-display-error-stop - ;;(font-lock-mode -1) - (setq font-lock-mode nil) - (when (timerp jit-lock-context-timer) - (cancel-timer jit-lock-context-timer)) - (when (timerp jit-lock-defer-timer) - (cancel-timer jit-lock-defer-timer)) - (apply 'error format-string2 lwarn-type args)))) - - -(defun mumamo-debug-to-backtrace (&rest debugger-args) - "This function should give a backtrace during fontification errors. -The variable `debugger' should then be this function. See the -function `debug' for an explanation of DEBUGGER-ARGS. - -Fix-me: Can't use this function yet since the display routines -uses safe_eval and safe_call." - (mumamo-display-error 'mumamo-debug-to-backtrace - "%s" - (nth 1 debugger-args))) - -;; (defun my-test-err3 () -;; (interactive) -;; (let ((debugger 'mumamo-debug-to-backtrace) -;; (debug-on-error t)) -;; (my-err) -;; )) -;;(my-test-err3() - -;;(set-default 'mumamo-use-condition-case nil) -;;(set-default 'mumamo-use-condition-case t) -(defvar mumamo-use-condition-case t) -(make-variable-buffer-local 'mumamo-use-condition-case) -(put 'mumamo-use-condition-case 'permanent-local t) - -(defvar mumamo-debugger 'mumamo-debug-to-backtrace) -(make-variable-buffer-local 'mumamo-debugger) -(put 'mumamo-debugger 'permanent-local t) - -;; (defun my-test-err4 () -;; (interactive) -;; (mumamo-condition-case err -;; (my-errx) -;; (arith-error (message "here")) -;; (error (message "%s, %s" err (error-message-string err))) -;; )) - -(defvar mumamo-warned-once nil) -(make-variable-buffer-local 'mumamo-warned-once) -(put 'mumamo-warned-once 'permanent-local t) - - ; (append '(0 1) '(a b)) -(defun mumamo-warn-once (type message &rest args) - "Warn only once with TYPE, MESSAGE and ARGS. -If the same problem happens again then do not warn again." - (let ((msgrec (append (list type message) args))) - (unless (member msgrec mumamo-warned-once) - (setq mumamo-warned-once - (cons msgrec mumamo-warned-once)) - ;;(apply 'lwarn type :warning message args) - (apply 'message (format "%s: %s" type message) args) - ))) - -(defun mumamo-add-help-tabs () - "Add key bindings for moving between buttons. -Add bindings similar to those in `help-mode' for moving between -text buttons." - (local-set-key [tab] 'forward-button) - (local-set-key [(meta tab)] 'backward-button) - (local-set-key [(shift tab)] 'backward-button) - (local-set-key [backtab] 'backward-button)) - -(defun mumamo-insert-describe-button (symbol type) - "Insert a text button that describes SYMBOL of type TYPE." - (let ((func `(lambda (btn) - (funcall ',type ',symbol)))) - (mumamo-add-help-tabs) - (insert-text-button - (symbol-name symbol) - :type 'help-function - 'face 'link - 'action func))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Custom group - -;;;###autoload -(defgroup mumamo nil - "Customization group for multiple major modes in a buffer." - :group 'editing - :group 'languages - :group 'sgml - :group 'nxhtml - ) - -;;(setq mumamo-set-major-mode-delay -1) -;;(setq mumamo-set-major-mode-delay 5) -(defcustom mumamo-set-major-mode-delay idle-update-delay - "Delay this number of seconds before setting major mode. -When point enters a region where the major mode should be -different than the current major mode, wait until Emacs has been -idle this number of seconds before switching major mode. - -If negative switch major mode immediately. - -Ideally the switching of major mode should occur immediately when -entering a region. However this can make movements a bit unsmooth -for some major modes on a slow computer. Therefore on a slow -computer use a short delay. - -If you have a fast computer and want to use mode specific -movement commands then set this variable to -1. - -I tried to measure the time for switching major mode in mumamo. -For most major modes it took 0 ms, but for `nxml-mode' and its -derivate it took 20 ms on a 3GHz CPU." - :type 'number - :group 'mumamo) - - -(defgroup mumamo-display nil - "Customization group for mumamo chunk display." - :group 'mumamo) - -(defun mumamo-update-this-buffer-margin-use () - (mumamo-update-buffer-margin-use (current-buffer))) - -(define-minor-mode mumamo-margin-info-mode - "Display chunk info in margin when on. -Display chunk depth and major mode where a chunk begin in left or -right margin. \(The '-mode' part of the major mode is stripped.) - -See also `mumamo-margin-use'. - -Note: When `linum-mode' is on the right margin is always used -now \(since `linum-mode' uses the left)." - :group 'mumamo-display - (mumamo-update-this-buffer-margin-use) - (if mumamo-margin-info-mode - (progn - ;;(add-hook 'window-configuration-change-hook 'mumamo-update-this-buffer-margin-use nil t) - (add-hook 'linum-mode-hook 'mumamo-update-this-buffer-margin-use nil t) - ) - ;;(remove-hook 'window-configuration-change-hook 'mumamo-update-this-buffer-margin-use t) - (remove-hook 'linum-mode-hook 'mumamo-update-this-buffer-margin-use t) - )) -;;(put 'mumamo-margin-info-mode 'permanent-local t) - -(defun mumamo-margin-info-mode-turn-off () - (mumamo-margin-info-mode -1)) -(put 'mumamo-margin-info-mode-turn-off 'permanent-local-hook t) - -(define-globalized-minor-mode mumamo-margin-info-global-mode mumamo-margin-info-mode - (lambda () (when (and (boundp 'mumamo-multi-major-mode) - mumamo-multi-major-mode) - (mumamo-margin-info-mode 1))) - :group 'mumamo-display) - -(defcustom mumamo-margin-use '(left-margin 13) - "Display chunk info in left or right margin if non-nil." - :type '(list (radio (const :tag "Display chunk info in left margin" left-margin) - (const :tag "Display chunk info in right margin" right-margin)) - (integer :tag "Margin width (when used)" :value 13)) - :set (lambda (sym val) - (set-default sym val) - (when (fboundp 'mumamo-update-all-buffers-margin-use) - (mumamo-update-all-buffers-margin-use))) - :group 'mumamo-display) - -(defun mumamo-update-all-buffers-margin-use () - (dolist (buf (buffer-list)) - (mumamo-update-buffer-margin-use buf))) - -(define-minor-mode mumamo-no-chunk-coloring - "Use no background colors to distinguish chunks. -When this minor mode is on in a buffer no chunk coloring is done -in that buffer. This is overrides `mumamo-chunk-coloring'. It -is meant for situations when you temporarily need to remove the -background colors." - :lighter " ø" - :group 'mumamo-display - (font-lock-mode -1) - (font-lock-mode 1)) -(put 'mumamo-no-chunk-coloring 'permanent-local t) - - -;; (setq mumamo-chunk-coloring 4) -(defcustom mumamo-chunk-coloring 0 - "Color chunks with depth greater than or equal to this. -When 0 all chunks will be colored. If 1 all sub mode chunks will -be colored, etc." - :type '(integer :tag "Color chunks with depth greater than this") - :group 'mumamo-display) - -(defface mumamo-background-chunk-major - '((((class color) (min-colors 88) (background dark)) - ;;:background "blue3") - :background "MidnightBlue") - (((class color) (min-colors 88) (background light)) - ;;:background "lightgoldenrod2") - :background "cornsilk") - (((class color) (min-colors 16) (background dark)) - :background "blue4") - (((class color) (min-colors 16) (background light)) - :background "cornsilk") - (((class color) (min-colors 8)) - :background "blue") - (((type tty) (class mono)) - :inverse-video t) - (t :background "gray")) - "Background colors for chunks in sub modes. -You should only specify :background here, otherwise it will -interfere with syntax highlighting." - :group 'mumamo-display) - -(defface mumamo-background-chunk-submode1 - '((((class color) (min-colors 88) (background dark)) - ;;:background "blue3") - :background "DarkGreen" - ;;:background "#081010" - ) - (((class color) (min-colors 88) (background light)) - ;;:background "lightgoldenrod2") - :background "Azure") - (((class color) (min-colors 16) (background dark)) - :background "blue3") - (((class color) (min-colors 16) (background light)) - :background "azure") - (((class color) (min-colors 8)) - :background "Blue") - (((type tty) (class mono)) - :inverse-video t) - (t :background "gray")) - "Background colors for chunks in major mode. -You should only specify :background here, otherwise it will -interfere with syntax highlighting." - :group 'mumamo-display) - -(defface mumamo-background-chunk-submode2 - '((((class color) (min-colors 88) (background dark)) - ;;:background "blue3") - :background "dark green") - (((class color) (min-colors 88) (background light)) - ;;:background "lightgoldenrod2") - :background "#e6ff96") - (((class color) (min-colors 16) (background dark)) - :background "blue3") - (((class color) (min-colors 16) (background light)) - :background "azure") - (((class color) (min-colors 8)) - :background "blue") - (((type tty) (class mono)) - :inverse-video t) - (t :background "gray")) - "Background colors for chunks in major mode. -You should only specify :background here, otherwise it will -interfere with syntax highlighting." - :group 'mumamo-display) - -(defface mumamo-background-chunk-submode3 - '((((class color) (min-colors 88) (background dark)) - ;;:background "blue3") - :background "dark green") - (((class color) (min-colors 88) (background light)) - ;;:background "lightgoldenrod2") - :background "#f7d1f4") - ;;:background "green") - (((class color) (min-colors 16) (background dark)) - :background "blue3") - (((class color) (min-colors 16) (background light)) - :background "azure") - (((class color) (min-colors 8)) - :background "blue") - (((type tty) (class mono)) - :inverse-video t) - (t :background "gray")) - "Background colors for chunks in major mode. -You should only specify :background here, otherwise it will -interfere with syntax highlighting." - :group 'mumamo-display) - -(defface mumamo-background-chunk-submode4 - '((((class color) (min-colors 88) (background dark)) - ;;:background "blue3") - :background "dark green") - (((class color) (min-colors 88) (background light)) - ;;:background "lightgoldenrod2") - :background "orange") - (((class color) (min-colors 16) (background dark)) - :background "blue3") - (((class color) (min-colors 16) (background light)) - :background "azure") - (((class color) (min-colors 8)) - :background "blue") - (((type tty) (class mono)) - :inverse-video t) - (t :background "gray")) - "Background colors for chunks in major mode. -You should only specify :background here, otherwise it will -interfere with syntax highlighting." - :group 'mumamo-display) - -(defcustom mumamo-background-chunk-major 'mumamo-background-chunk-major - "Background colors for chunks in major mode. -Pointer to face with background color. - -If you do not want any special background color use the face named -default." - :type 'face - :group 'mumamo-display) - -(defcustom mumamo-background-chunk-submode1 'mumamo-background-chunk-submode1 - "Background colors for chunks in sub modes. -Pointer to face with background color. - -If you do not want any special background color use the face named -default." - :type 'face - :group 'mumamo-display) - -(defcustom mumamo-background-chunk-submode2 'mumamo-background-chunk-submode2 - "Background colors for chunks in sub modes. -Pointer to face with background color. - -If you do not want any special background color use the face named -default." - :type 'face - :group 'mumamo-display) - -(defcustom mumamo-background-chunk-submode3 'mumamo-background-chunk-submode3 - "Background colors for chunks in sub modes. -Pointer to face with background color. - -If you do not want any special background color use the face named -default." - :type 'face - :group 'mumamo-display) - -(defcustom mumamo-background-chunk-submode4 'mumamo-background-chunk-submode4 - "Background colors for chunks in sub modes. -Pointer to face with background color. - -If you do not want any special background color use the face named -default." - :type 'face - :group 'mumamo-display) - -;; Fix-me: use and enhance this -(defcustom mumamo-background-colors '(mumamo-background-chunk-major - mumamo-background-chunk-submode1 - mumamo-background-chunk-submode2 - mumamo-background-chunk-submode3 - mumamo-background-chunk-submode4 - ) - "List of background colors in order of use. -First color is for main major mode chunks, then for submode -chunks, sub-submode chunks etc. Colors are reused in cyclic -order. - -The default colors are choosen so that inner chunks has a more -standing out color the further in you get. This is supposed to -be helpful when you make mistakes and the chunk nesting is not -what you intended. - -Note: Only the light background colors have been set by me. The -dark background colors might currently be unuseful. -Contributions and suggestions are welcome! - -The values in the list should be symbols. Each symbol should either be - - 1: a variable symbol pointing to a face (or beeing nil) - 2: a face symbol - 3: a function with one argument (subchunk depth) returning a - face symbol" - :type '(repeat symbol) - :group 'mumamo-display) - -;;(mumamo-background-color 0) -;;(mumamo-background-color 1) -;;(mumamo-background-color 2) -(defun mumamo-background-color (sub-chunk-depth) - (when (and (not mumamo-no-chunk-coloring) - (or (not (integerp mumamo-chunk-coloring)) ;; Old values - (>= sub-chunk-depth mumamo-chunk-coloring))) - (let* ((idx (when mumamo-background-colors - (mod sub-chunk-depth (length mumamo-background-colors)))) - (sym (when idx (nth idx mumamo-background-colors))) - fac) - (when sym - (when (boundp sym) - (setq fac (symbol-value sym)) - (unless (facep fac) (setq fac nil))) - (unless fac - (when (facep sym) - (setq fac sym))) - (unless fac - (when (fboundp sym) - (setq fac (funcall sym sub-chunk-depth)))) - (when fac - (unless (facep fac) - (setq fac nil))) - fac - )))) - -(defface mumamo-border-face-in - '((t (:inherit font-lock-preprocessor-face :bold t :italic t :underline t))) - "Face for marking borders." - :group 'mumamo-display) - -(defface mumamo-border-face-out - '((t (:inherit font-lock-preprocessor-face :bold t :italic t :underline t))) - "Face for marking borders." - :group 'mumamo-display) - - -(defgroup mumamo-indentation nil - "Customization group for mumamo chunk indentation." - :group 'mumamo) - -(defcustom mumamo-submode-indent-offset 2 - "Indentation of submode relative outer major mode. -If this is nil then indentation first non-empty line in a -subchunk will \(normally) be 0. See however -`mumamo-indent-line-function-1' for special handling of first -line in subsequent subchunks. - -See also `mumamo-submode-indent-offset-0'." - :type '(choice integer - (const :tag "No special")) - :group 'mumamo-indentation) - -(defcustom mumamo-submode-indent-offset-0 0 - "Indentation of submode at column 0. -This value overrides `mumamo-submode-indent-offset' when the -outer major mode above has indentation 0." - :type '(choice integer - (const :tag "No special")) - :group 'mumamo-indentation) - -(defcustom mumamo-indent-major-to-use - '( - ;;(nxhtml-mode html-mode) - (html-mode nxhtml-mode) - ) - "Major mode to use for indentation. -This is normally the major mode specified for the chunk. Here you -can make exceptions." - :type '(repeat - (list (symbol :tag "Major mode symbol specified") - (command :tag "Major mode to use"))) - :group 'mumamo-indentation) - -;;(mumamo-indent-get-major-to-use 'nxhtml-mode) -;;(mumamo-indent-get-major-to-use 'html-mode) -(defun mumamo-indent-get-major-to-use (major depth) - (or (and (= depth 0) - (cadr (assq major mumamo-indent-major-to-use))) - major)) - -(defcustom mumamo-indent-widen-per-major - '( - (php-mode (use-widen)) - (nxhtml-mode (use-widen (html-mumamo-mode nxhtml-mumamo-mode))) - (html-mode (use-widen (html-mumamo-mode nxhtml-mumamo-mode))) - ) - "Wether do widen buffer during indentation. -If not then the buffer is narrowed to the current chunk when -indenting a line in a chunk." - :type '(repeat - (list (symbol :tag "Major mode symbol") - (set - (const :tag "Widen buffer during indentation" use-widen) - (repeat (command :tag "Widen if multi major is any of those")) - ))) - :group 'mumamo-indentation) - - -;;;###autoload -(defgroup mumamo-hi-lock-faces nil - "Faces for hi-lock that are visible in mumamo multiple modes. -This is a workaround for the problem that text properties are -always hidden behind overlay dito. - -This faces are not as visible as those that defines background -colors. However they use underlining so they are at least -somewhat visible." - :group 'hi-lock - :group 'mumamo-display - :group 'faces) - -(defface hi-mumamo-yellow - '((((min-colors 88) (background dark)) - (:underline "yellow1")) - (((background dark)) (:underline "yellow")) - (((min-colors 88)) (:underline "yellow1")) - (t (:underline "yellow"))) - "Default face for hi-lock mode." - :group 'mumamo-hi-lock-faces) - -(defface hi-mumamo-pink - '((((background dark)) (:underline "pink")) - (t (:underline "pink"))) - "Face for hi-lock mode." - :group 'mumamo-hi-lock-faces) - -(defface hi-mumamo-green - '((((min-colors 88) (background dark)) - (:underline "green1")) - (((background dark)) (:underline "green")) - (((min-colors 88)) (:underline "green1")) - (t (:underline "green"))) - "Face for hi-lock mode." - :group 'mumamo-hi-lock-faces) - -(defface hi-mumamo-blue - '((((background dark)) (:underline "light blue")) - (t (:underline "light blue"))) - "Face for hi-lock mode." - :group 'mumamo-hi-lock-faces) - -(defface hi-mumamo-black-b - '((t (:weight bold :underline t))) - "Face for hi-lock mode." - :group 'mumamo-hi-lock-faces) - -(defface hi-mumamo-blue-b - '((((min-colors 88)) (:weight bold :underline "blue1")) - (t (:weight bold :underline "blue"))) - "Face for hi-lock mode." - :group 'mumamo-hi-lock-faces) - -(defface hi-mumamo-green-b - '((((min-colors 88)) (:weight bold :underline "green1")) - (t (:weight bold :underline "green"))) - "Face for hi-lock mode." - :group 'mumamo-hi-lock-faces) - -(defface hi-mumamo-red-b - '((((min-colors 88)) (:weight bold :underline "red1")) - (t (:weight bold :underline "red"))) - "Face for hi-lock mode." - :group 'mumamo-hi-lock-faces) - - -;; (defcustom mumamo-check-chunk-major-same nil -;; "Check if main major mode is the same as normal mode." -;; :type 'boolean -;; :group 'mumamo) - -;; (customize-option 'mumamo-major-modes) -;;(require 'django) - -(defgroup mumamo-modes nil - "Customization group for mumamo chunk modes." - :group 'mumamo) - -(defcustom mumamo-major-modes - '( - (asp-js-mode - js-mode ;; Not autoloaded in the pretest - javascript-mode - espresso-mode - ecmascript-mode) - (asp-vb-mode - visual-basic-mode) - ;;(css-mode fundamental-mode) - (javascript-mode - js-mode ;; Not autoloaded in the pretest - javascript-mode - espresso-mode - ;;js2-fl-mode - ecmascript-mode) - (java-mode - jde-mode - java-mode) - (groovy-mode - groovy-mode) - ;; For Emacs 22 that do not have nxml by default - ;; Fix me: fallback when autoload fails! - (nxhtml-mode - nxhtml-mode - html-mode) - ) - "Alist for conversion of chunk major mode specifier to major mode. -Each entry has the form - - \(MAJOR-SPEC MAJORMODE ...) - -where the symbol MAJOR-SPEC specifies the code type and should -match the value returned from `mumamo-find-possible-chunk'. The -MAJORMODE symbols are major modes that can be used for editing -that code type. The first available MAJORMODE is the one that is -used. - -The MAJOR-SPEC symbols are used by the chunk definitions in -`define-mumamo-multi-major-mode'. - -The major modes are not specified directly in the chunk -definitions. Instead a chunk definition contains a symbol that -is looked up in this list to find the chunk's major mode. - -The reason for doing it this way is to make it possible to use -new major modes with existing multi major modes. If for example -someone writes a new CSS mode that could easily be used instead -of the current one in `html-mumamo-mode'. - -Lookup in this list is done by `mumamo-major-mode-from-modespec'." - :type '(alist - :key-type (symbol :tag "Symbol for major mode spec in chunk") - :value-type (repeat (choice - (command :tag "Major mode") - (symbol :tag "Major mode (not yet loaded)"))) - ) - :group 'mumamo-modes) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; JIT lock functions - -(defun mumamo-jit-lock-function (start) - "This function is added to `fontification-functions' by mumamo. -START is a parameter given to functions in that hook." - (mumamo-msgfntfy "mumamo-jit-lock-function %s, ff=%s, just-changed=%s" - start - (when start - (save-restriction - (widen) - (get-text-property start 'fontified))) - mumamo-just-changed-major) - ;;(msgtrc "jit-lock-function %s, ff=%s, just-changed=%s" start (get-text-property start 'fontified) mumamo-just-changed-major) - ;;(msgtrc "mumamo-jit-lock-function enter: font-lock-keywords-only def=%s" (default-value 'font-lock-keywords-only)) - (if mumamo-just-changed-major - (setq mumamo-just-changed-major nil)) - (let ((ret (jit-lock-function start))) - (mumamo-msgfntfy "mumamo-jit-lock-function EXIT %s, ff=%s, just-changed=%s" - start - (when start - (save-restriction - (widen) - (get-text-property start 'fontified))) - mumamo-just-changed-major) - ;;(msgtrc "mumamo-jit-lock-function exit: font-lock-keywords-only def=%s" (default-value 'font-lock-keywords-only)) - ret)) - -(defun mumamo-jit-lock-register (fun &optional contextual) - "Replacement for `jit-lock-register'. -Avoids refontification, otherwise same. FUN and CONTEXTUAL has -the some meaning as there." - (add-hook 'jit-lock-functions fun nil t) - (when (and contextual jit-lock-contextually) - (set (make-local-variable 'jit-lock-contextually) t)) - - ;;(jit-lock-mode t) - ;; - ;; Replace this with the code below from jit-lock-mode t part: - (setq jit-lock-mode t) - - ;; Mark the buffer for refontification. - ;; This is what we want to avoid in mumamo: - ;;(jit-lock-refontify) - - ;; Install an idle timer for stealth fontification. - (when (and jit-lock-stealth-time (null jit-lock-stealth-timer)) - (setq jit-lock-stealth-timer - (run-with-idle-timer jit-lock-stealth-time t - 'jit-lock-stealth-fontify))) - - ;; Create, but do not activate, the idle timer for repeated - ;; stealth fontification. - (when (and jit-lock-stealth-time (null jit-lock-stealth-repeat-timer)) - (setq jit-lock-stealth-repeat-timer (timer-create)) - (timer-set-function jit-lock-stealth-repeat-timer - 'jit-lock-stealth-fontify '(t))) - - ;; Init deferred fontification timer. - (when (and jit-lock-defer-time (null jit-lock-defer-timer)) - (setq jit-lock-defer-timer - (run-with-idle-timer jit-lock-defer-time t - 'jit-lock-deferred-fontify))) - - ;; Initialize contextual fontification if requested. - (when (eq jit-lock-contextually t) - (unless jit-lock-context-timer - (setq jit-lock-context-timer - (run-with-idle-timer jit-lock-context-time t - 'jit-lock-context-fontify))) - (setq jit-lock-context-unfontify-pos - (or jit-lock-context-unfontify-pos (point-max)))) - - ;; Setup our hooks. - ;;(add-hook 'after-change-functions 'jit-lock-after-change t t) - ;;(add-hook 'after-change-functions 'mumamo-jit-lock-after-change t t) - (add-hook 'after-change-functions 'mumamo-after-change t t) - ;; Set up fontification to call jit: - (let ((ff (reverse fontification-functions))) - (mapc (lambda (f) - ;;(unless (eq f 'jit-lock-function) - (remove-hook 'fontification-functions f t)) - ;;) - ff)) - (add-hook 'fontification-functions 'mumamo-jit-lock-function nil t) - ) - -;; Fix-me: integrate this with fontify-region! -(defvar mumamo-find-chunks-timer nil) -(make-variable-buffer-local 'mumamo-find-chunks-timer) -(put 'mumamo-find-chunks-timer 'permanent-local t) - -(defvar mumamo-find-chunk-delay idle-update-delay) -(make-variable-buffer-local 'mumamo-find-chunk-delay) -(put 'mumamo-find-chunk-delay 'permanent-local t) - -(defun mumamo-stop-find-chunks-timer () - "Stop timer that find chunks." - (when (and mumamo-find-chunks-timer - (timerp mumamo-find-chunks-timer)) - (cancel-timer mumamo-find-chunks-timer)) - (setq mumamo-find-chunks-timer nil)) - -(defun mumamo-start-find-chunks-timer () - "Start timer that find chunks." - (mumamo-stop-find-chunks-timer) - ;; (setq mumamo-find-chunks-timer - ;; (run-with-idle-timer mumamo-find-chunk-delay nil - ;; 'mumamo-find-chunks-in-timer (current-buffer))) - ) - -(defun mumamo-find-chunks-in-timer (buffer) - "Run `mumamo-find-chunks' in buffer BUFFER in a timer." - (mumamo-msgfntfy "mumamo-find-chunks-in-timer %s" buffer) - ;;(message "mumamo-find-chunks-in-timer %s" buffer) - (condition-case err - (when (buffer-live-p buffer) - (with-current-buffer buffer - (mumamo-find-chunks nil "mumamo-find-chunks-in-timer"))) - (error (message "mumamo-find-chunks error: %s" err)))) - - -(defvar mumamo-last-chunk nil) -(make-variable-buffer-local 'mumamo-last-chunk) -(put 'mumamo-last-chunk 'permanent-local t) - -(defvar mumamo-last-change-pos nil) -(make-variable-buffer-local 'mumamo-last-change-pos) -(put 'mumamo-last-change-pos 'permanent-local t) - -;; Fix-me: maybe this belongs to contextual fontification? Eh, -;; no. Unfortunately there is not way to make that handle more than -;; multiple lines. -(defvar mumamo-find-chunk-is-active nil - "Protect from recursive calls.") - -;; Fix-me: temporary things for testing new chunk routines. -(defvar mumamo-find-chunks-level 0) -(setq mumamo-find-chunks-level 0) - -(defvar mumamo-old-tail nil) -(make-variable-buffer-local 'mumamo-old-tail) -(put 'mumamo-old-tail 'permanent-local t) - -(defun mumamo-update-obscure (chunk pos) - "Update obscure cache." - (let ((obscured (overlay-get chunk 'obscured)) - region-info) - (unless (and obscured (= (car obscured) pos)) - (setq region-info (mumamo-get-region-from pos)) - ;;(msgtrc "update-obscure:region-info=%s" region-info) - ;; This should not be a chunk here - (mumamo-put-obscure chunk pos region-info)))) - -(defun mumamo-put-obscure (chunk pos region-or-chunk) - "Cache obscure info." - (assert (overlayp chunk) t) - (when pos (assert (or (markerp pos) (integerp pos)) t)) - (let* ((region-info (if (overlayp region-or-chunk) - (cons (overlay-start region-or-chunk) - (overlay-end region-or-chunk)) - region-or-chunk)) - (obscured (when pos (list pos region-info)))) - ;;(msgtrc "put-obscure:region-info=%s, obscured=%s" region-info obscured) - (when region-info (assert (consp region-info) t)) - (assert (not (overlayp region-info)) t) - (overlay-put chunk 'obscured obscured) - (setq obscured (overlay-get chunk 'obscured)) - ;;(msgtrc " obscured=%s" obscured) - )) - -(defun mumamo-get-region-from (point) - "Return mumamo region values for POINT." - ;; Note: `mumamo-get-region-from-1' is defined in mumamo-regions.el - (when (fboundp 'mumamo-get-region-from-1) - (mumamo-get-region-from-1 point))) - -(defun mumamo-clear-chunk-ppss-cache (chunk) - (overlay-put chunk 'mumamo-ppss-cache nil) - (overlay-put chunk 'mumamo-ppss-last nil) - (overlay-put chunk 'mumamo-ppss-stats nil)) - -(defun mumamo-find-chunks (end tracer) - "Find or create chunks from last known chunk. -Ie, start from the end of `mumamo-last-chunk' if this is -non-nil, otherwise 1. - -If END is nil then continue till end of buffer or until any input -is available. In this case the return value is undefined. - -Otherwise END must be a position in the buffer. Return the -mumamo chunk containing the position. If `mumamo-last-chunk' -ends before END then create chunks upto END." - (when mumamo-multi-major-mode - (let ((chunk (mumamo-find-chunks-1 end tracer)) - region-info) - (when (and end chunk (featurep 'mumamo-regions)) - (setq region-info (mumamo-get-region-from end)) - ;;(msgtrc "find-chunks:region-info=%s" region-info) - (if (overlayp region-info) - (setq chunk region-info) - ;;(overlay-put chunk 'obscured (list end region-info)))) - (mumamo-put-obscure chunk end region-info))) - ;;(msgtrc "find-chunks ret chunk=%s" chunk) - chunk))) - -(defun mumamo-move-to-old-tail (first-check-from) - "Divide the chunk list. -Make it two parts. The first, before FIRST-CHECK-FROM is still -correct but we want to check those after. Put thosie in -`mumamo-old-tail'." - (let ((while-n0 0)) - (while (and (mumamo-while 500 'while-n0 "mumamo-last-chunk first-check-from") - mumamo-last-chunk - first-check-from - (< first-check-from (overlay-end mumamo-last-chunk))) - (overlay-put mumamo-last-chunk 'mumamo-next-chunk mumamo-old-tail) - (setq mumamo-old-tail mumamo-last-chunk) - (overlay-put mumamo-old-tail 'mumamo-is-new nil) - (when nil ;; For debugging - (overlay-put mumamo-old-tail - 'face - (list :background - (format "red%d" (overlay-get mumamo-old-tail 'mumamo-depth))))) - (setq mumamo-last-chunk - (overlay-get mumamo-last-chunk 'mumamo-prev-chunk))))) - -(defun mumamo-delete-empty-chunks-at-end () - ;; fix-me: later? Delete empty chunks at end, will be recreated if really needed - (let ((while-n1 0)) - (while (and (mumamo-while 500 'while-n1 "mumamo-last-chunk del empty chunks") - mumamo-last-chunk - ;;(= (point-max) (overlay-end mumamo-last-chunk)) - (= (overlay-end mumamo-last-chunk) (overlay-start mumamo-last-chunk))) - ;;(msgtrc "delete-overlay at end") - (delete-overlay mumamo-last-chunk) - (setq mumamo-last-chunk (overlay-get mumamo-last-chunk 'mumamo-prev-chunk)) - (when mumamo-last-chunk (overlay-put mumamo-last-chunk 'mumamo-next-chunk nil))))) - - -(defun mumamo-delete-chunks-upto (ok-pos) - "Delete old chunks upto OK-POS." - (or (not mumamo-old-tail) - (overlay-buffer mumamo-old-tail) - (setq mumamo-old-tail nil)) - (let ((while-n2 0)) - (while (and (mumamo-while 500 'while-n2 "mumamo-old-tail") - (and mumamo-old-tail (< (overlay-start mumamo-old-tail) ok-pos))) - (mumamo-mark-for-refontification (overlay-start mumamo-old-tail) (overlay-end mumamo-old-tail)) - ;;(msgtrc "find-chunks:ok-pos=%s, not eq delete %s" ok-pos mumamo-old-tail) - (delete-overlay mumamo-old-tail) - (setq mumamo-old-tail (overlay-get mumamo-old-tail 'mumamo-next-chunk)) - (or (not mumamo-old-tail) - (overlay-buffer mumamo-old-tail) - (setq mumamo-old-tail nil))))) - -(defun mumamo-reuse-old-tail-head () - ;;(msgtrc "reusing %S" mumamo-old-tail) - (setq mumamo-last-chunk mumamo-old-tail) - (overlay-put mumamo-last-chunk 'mumamo-is-new t) - (mumamo-clear-chunk-ppss-cache mumamo-last-chunk) - (overlay-put mumamo-last-chunk 'face (mumamo-background-color (overlay-get mumamo-last-chunk 'mumamo-depth))) - (setq mumamo-old-tail (overlay-get mumamo-old-tail 'mumamo-next-chunk))) - -(defun mumamo-old-tail-fits (this-new-values) - (and mumamo-old-tail - (overlay-buffer mumamo-old-tail) - (mumamo-new-chunk-equal-chunk-values mumamo-old-tail this-new-values))) - -(defun mumamo-find-chunks-1 (end tracer) ;; min max) - ;; Note: This code must probably be reentrant. The globals changed - ;; here are `mumamo-last-chunk' and `mumamo-old-tail'. They must be - ;; handled as a pair. - (mumamo-msgfntfy "") - (setq mumamo-find-chunks-level (1+ mumamo-find-chunks-level)) - (unless (and (overlayp mumamo-last-chunk) (overlay-buffer mumamo-last-chunk)) (setq mumamo-last-chunk nil)) - (save-restriction - (widen) - (let* ((mumamo-find-chunks-1-active t) - (here (point)) - ;; Any changes? - (change-min (car mumamo-last-change-pos)) - (change-max (cdr mumamo-last-change-pos)) - (chunk-at-change-min (when change-min (mumamo-get-existing-new-chunk-at change-min nil))) - (chunk-at-change-min-start (when chunk-at-change-min (overlay-start chunk-at-change-min))) - ;; Check if change is near border - (this-syntax-min-max - (when chunk-at-change-min - (mumamo-update-obscure chunk-at-change-min chunk-at-change-min-start) - (mumamo-chunk-syntax-min-max chunk-at-change-min nil))) - (this-syntax-min (car this-syntax-min-max)) - (in-min-border (when this-syntax-min (>= this-syntax-min change-min))) - (first-check-from (if chunk-at-change-min - (if (or in-min-border - ;; Fix-me: 20? - (> 20 (- change-min chunk-at-change-min-start))) - (max 1 - (- chunk-at-change-min-start 1)) - chunk-at-change-min-start) - (when change-min - (goto-char change-min) - (skip-chars-backward "^\n") - (unless (bobp) (backward-char)) - (prog1 (point) (goto-char here)))))) - (when (and chunk-at-change-min (= 0 (- (overlay-end chunk-at-change-min) - (overlay-start chunk-at-change-min)))) - (assert in-min-border)) ;; 0 len must be in border - (setq mumamo-last-change-pos nil) - (when chunk-at-change-min - (mumamo-move-to-old-tail first-check-from) - (mumamo-delete-empty-chunks-at-end)) - ;; Now mumamo-last-chunk is the last in the top chain and - ;; mumamo-old-tail the first in the bottom chain. - - (let* ( - ;;(last-chunk-is-closed (when mumamo-last-chunk (overlay-get mumamo-last-chunk 'mumamo-is-closed))) - (last-chunk-is-closed t) - (ok-pos (or (and mumamo-last-chunk - (- (overlay-end mumamo-last-chunk) - ;;(or (and last-chunk-is-closed 1) - (or (and (/= (overlay-end mumamo-last-chunk) - (1+ (buffer-size))) - 1) - 0))) - 0)) - (end-param end) - (end (or end (point-max))) - this-new-values - this-new-chunk - prev-chunk - first-change-pos - interrupted - (while-n3 0)) - (when (>= ok-pos end) - (setq this-new-chunk (mumamo-get-existing-new-chunk-at end nil)) - (unless this-new-chunk - (error "Could not find new chunk ok-pos-new=%s > end=%s (ovls at end=%s), level=%d, old-tail=%s, %S" - ok-pos end (overlays-in end end) - mumamo-find-chunks-level mumamo-old-tail tracer))) - (unless this-new-chunk - (save-match-data - (unless mumamo-find-chunk-is-active - ;;(setq mumamo-find-chunk-is-active t) - (mumamo-stop-find-chunks-timer) - (mumamo-save-buffer-state nil - (progn - - ;; Loop forward until end or buffer end ... - (while (and (mumamo-while 1500 'while-n3 "until end") - (or (not end) - (<= ok-pos end)) - ;;(prog1 t (msgtrc "ok-pos=%s in while" ok-pos)) - (< ok-pos (point-max)) - (not (setq interrupted (and (not end) - (input-pending-p))))) - ;; Narrow to speed up. However the chunk divider may be - ;; before ok-pos here. Assume that the marker is not - ;; longer than 200 chars. fix-me. - (narrow-to-region (max (- ok-pos 200) 1) - (1+ (buffer-size))) - ;; If this was after a change within one chunk then tell that: - (let ((use-change-max (when (and change-max - chunk-at-change-min - (overlay-buffer chunk-at-change-min) - (< change-max - (overlay-end chunk-at-change-min)) - (or (not mumamo-last-chunk) - (> change-max (overlay-end mumamo-last-chunk)))) - change-max)) - (use-chunk-at-change-min (when (or (not mumamo-last-chunk) - (not (overlay-buffer mumamo-last-chunk)) - (not chunk-at-change-min) - (not (overlay-buffer chunk-at-change-min)) - (> (overlay-end chunk-at-change-min) - (overlay-end mumamo-last-chunk))) - chunk-at-change-min - ))) - (setq this-new-values (mumamo-find-next-chunk-values - mumamo-last-chunk - first-check-from - use-change-max - use-chunk-at-change-min))) - (if (not this-new-values) - (setq ok-pos (point-max)) - (setq first-check-from nil) - (setq ok-pos (or (mumamo-new-chunk-value-max this-new-values) ;;(overlay-end this-chunk) - (point-max))) - ;;(msgtrc "ok-pos=%s, point-max=%s max=%s" ok-pos (point-max) (mumamo-new-chunk-value-max this-new-values)) - ;; With the new organization all chunks are created here. - (if (mumamo-old-tail-fits this-new-values) - (mumamo-reuse-old-tail-head) - (mumamo-delete-chunks-upto ok-pos) - ;; Create chunk and chunk links - (setq mumamo-last-chunk (mumamo-new-create-chunk this-new-values)) - ;;(setq last-chunk-is-closed (overlay-get mumamo-last-chunk 'mumamo-is-closed)) - (unless first-change-pos - (setq first-change-pos (mumamo-new-chunk-value-min this-new-values)))))) - (setq this-new-chunk mumamo-last-chunk))) - (widen) - (when (or interrupted - (and mumamo-last-chunk - (overlayp mumamo-last-chunk) - (overlay-buffer mumamo-last-chunk) - (buffer-live-p (overlay-buffer mumamo-last-chunk)) - (< (overlay-end mumamo-last-chunk) (point-max)))) - (mumamo-start-find-chunks-timer) - ) - (when first-change-pos - (setq jit-lock-context-unfontify-pos - (if jit-lock-context-unfontify-pos - (min jit-lock-context-unfontify-pos first-change-pos) - first-change-pos)))) - (goto-char here) - (setq mumamo-find-chunk-is-active nil))) - - ;; fix-me: continue here - (when chunk-at-change-min (mumamo-clear-chunk-ppss-cache chunk-at-change-min)) - (setq mumamo-find-chunks-level (1- mumamo-find-chunks-level)) - ;; Avoid empty overlays at the end of the buffer. Those can - ;; come from for example deleting to the end of the buffer. - (when this-new-chunk - ;; Fix-me: can this happen now? - (setq prev-chunk (overlay-get this-new-chunk 'mumamo-prev-chunk)) - (when (and prev-chunk - (overlay-buffer prev-chunk) - (= (overlay-start this-new-chunk) (overlay-end this-new-chunk)) - (= (overlay-start prev-chunk) (overlay-end prev-chunk))) - (overlay-put prev-chunk 'mumamo-next-chunk nil) - (overlay-put prev-chunk 'mumamo-prev-chunk nil) - ;;(msgtrc "find-chunks:deleting this-new-chunk %s" this-new-chunk) - (delete-overlay this-new-chunk) - (setq this-new-chunk prev-chunk) - ) - (while (and mumamo-old-tail - (overlay-buffer mumamo-old-tail) - (= (overlay-start mumamo-old-tail) (overlay-end mumamo-old-tail))) - (assert (not (eq mumamo-old-tail (overlay-get mumamo-old-tail 'mumamo-next-chunk))) t) - (setq prev-chunk mumamo-old-tail) - (setq mumamo-old-tail (overlay-get mumamo-old-tail 'mumamo-next-chunk)) - ;;(msgtrc "mumamo-find-chunks-1:after mumamo-old-tail=%s" mumamo-old-tail) - (delete-overlay prev-chunk) - ) - ) - ;;(unless (overlay-get mumamo-last-chunk 'mumamo-is-closed) - (unless t ;(= (overlay-end mumamo-last-chunk) (save-restriction (widen) (point-max))) - ;; Check that there are no left-over old chunks - (save-restriction - (widen) - (dolist (o (overlays-in (point-min) (point-max))) - (when (and (overlay-get o 'mumamo-depth) - (not (overlay-get o 'mumamo-is-new))) - (error "mumamo-find-chunks: left over chunk: %s end=%s, last-chunk=%s" o end mumamo-last-chunk))))) - (when end-param - ;;(msgtrc "find-chunks:Exit.end-param=%s, this-new-chunk=%s, point-max=%s, last=%s" end-param this-new-chunk (point-max) mumamo-last-chunk) - (let* ((ret this-new-chunk) - (ret-beg (overlay-start ret)) - (ret-end (overlay-end ret))) - (unless (and (<= ret-beg end-param) - (<= end-param ret-end)) - (error "mumamo-find-chunks: Bad ret=%s, end=%s" ret end-param)) - ;;(msgtrc "find-chunks=>%S" ret) - ret)))))) - -(defun mumamo-find-chunk-after-change (min max) - "Save change position after a buffer change. -This should be run after a buffer change. For MIN see -`after-change-functions'." - ;; Fix-me: Maybe use a list of all min, max instead? - (mumamo-start-find-chunks-timer) - ;;(msgtrc "(mumamo-find-chunk-after-change %s %s)" min max) - (setq min (copy-marker min nil)) - (setq max (copy-marker max t)) - (setq mumamo-last-change-pos - (if mumamo-last-change-pos - (let* ((old-min (car mumamo-last-change-pos)) - (old-max (cdr mumamo-last-change-pos)) - (new-min (min min old-min)) - (new-max (max max old-max))) - (cons new-min new-max)) - (cons min max)))) - -(defun mumamo-after-change (min max old-len) - "Everything that needs to be done in mumamo after a change. -This is run in the `after-change-functions' hook. For MIN, MAX -and OLD-LEN see that variable." - ;;(msgtrc "mumamo-after-change BEGIN min/max/old-len=%s/%s/%s" min max old-len) - ;;(msgtrc "mumamo-after-change BEGIN") - (mumamo-find-chunk-after-change min max) - (mumamo-jit-lock-after-change min max old-len) - (mumamo-msgfntfy "mumamo-after-change EXIT") - ;;(msgtrc "mumamo-after-change EXIT mumamo-last-change-pos=%s" mumamo-last-change-pos) - ) - -(defun mumamo-jit-lock-after-change (min max old-len) - ;; Fix-me: Should not this be on - ;; jit-lock-after-change-externd-region-functions?? - "Replacement for `jit-lock-after-change'. -Does the nearly the same thing as that function, but takes -care of that there might be different major modes at MIN and MAX. -It also marks for refontification only in the current mumamo chunk. - -OLD-LEN is the pre-change length. - -Jit-lock after change functions is organized this way: - -`jit-lock-after-change' (doc: Mark the rest of the buffer as not -fontified after a change) is added locally to the hook -`after-change-functions'. This function runs -`jit-lock-after-change-extend-region-functions'." - (when (and jit-lock-mode (not memory-full)) - (mumamo-msgfntfy "mumamo-jit-lock-after-change ENTER %s %s %s" min max old-len) - ;; Why is this nil?: - (mumamo-msgfntfy " mumamo-jit-lock-after-change: font-lock-extend-after-change-region-function=%s" font-lock-extend-after-change-region-function) - (let* ((ovl-min (mumamo-get-existing-new-chunk-at min nil)) - (ovl-max (when (or (not ovl-min) - (< (overlay-end ovl-min) max)) - (mumamo-get-existing-new-chunk-at max nil))) - (major-min (when ovl-min (mumamo-chunk-major-mode ovl-min))) - (major-max (when ovl-max (mumamo-chunk-major-mode ovl-max))) - (r-min nil) - (r-max nil) - (new-min min) - (new-max max)) - (if (and major-min (eq major-min major-max)) - (setq r-min - (when major-min - (mumamo-jit-lock-after-change-1 min max old-len major-min))) - (setq r-min - (when major-min - (mumamo-jit-lock-after-change-1 min max old-len major-min))) - (setq r-max - (when major-max - (mumamo-jit-lock-after-change-1 min max old-len major-max)))) - (mumamo-msgfntfy "mumamo-jit-lock-after-change r-min,max=%s,%s major-min,max=%s,%s" r-min r-max major-min major-max) - (when r-min - (setq new-min (min new-min (car r-min))) - (setq new-max (max new-max (cdr r-min)))) - (when r-max - (setq new-min (min new-min (car r-max))) - (setq new-max (max new-max (cdr r-max)))) - (setq new-min (max new-min (point-min))) - (setq new-max (min new-max (point-max))) - ;; Make sure we change at least one char (in case of deletions). - (setq new-max (min (max new-max (1+ new-min)) (point-max))) - (mumamo-msgfntfy "mumamo-jit-lock-after-change new-min,max=%s,%s" new-min new-max) - (mumamo-mark-for-refontification new-min new-max) - - ;; Mark the change for deferred contextual refontification. - ;;(setq jit-lock-context-unfontify-pos nil) (setq message-log-max t) - (when jit-lock-context-unfontify-pos - (setq jit-lock-context-unfontify-pos - ;; Here we use `start' because nothing guarantees that the - ;; text between start and end will be otherwise refontified: - ;; usually it will be refontified by virtue of being - ;; displayed, but if it's outside of any displayed area in the - ;; buffer, only jit-lock-context-* will re-fontify it. - (min jit-lock-context-unfontify-pos new-min)) - ;;(with-current-buffer (get-buffer "*Messages*") (erase-buffer)) - (mumamo-msgfntfy "mumamo-jit-lock-after-change EXIT unfontify-pos=%s" jit-lock-context-unfontify-pos) - ;;(message "mumamo-jit-lock-after-change.unfontify-pos=%s" jit-lock-context-unfontify-pos) - )))) -;;(min jit-lock-context-unfontify-pos jit-lock-start)))))) -;;(put 'mumamo-jit-lock-after-change 'permanent-local-hook t) -(put 'mumamo-after-change 'permanent-local-hook t) - -(defun mumamo-jit-lock-after-change-1 (min max old-len major) - "Extend the region the same way jit-lock does it. -This function tries to extend the region between MIN and MAX the -same way jit-lock does it after a change. OLD-LEN is the -pre-change length. - -The extending of the region is done as if MAJOR was the major -mode." - (mumamo-with-major-mode-fontification major - `(progn - (let ((jit-lock-start ,min) - (jit-lock-end ,max)) - ;;(mumamo-msgfntfy "mumamo-mumamo-jit-lock-after-change-1 jlacer=%s" ,jit-lock-after-change-extend-region-functions) - (mumamo-with-buffer-prepared-for-jit-lock - ;;(font-lock-extend-jit-lock-region-after-change ,min ,max ,old-len) - (run-hook-with-args 'jit-lock-after-change-extend-region-functions min max old-len) - ;;(setq jit-lock-end (min (max jit-lock-end (1+ min)) (point-max))) - -;;; ;; Just run the buffer local function: -;;; (dolist (extend-fun jit-lock-after-change-extend-region-functions) -;;; (when (fboundp extend-fun) -;;; (funcall extend-fun ,min ,max ,old-len))) - ) - (setq min jit-lock-start) - (setq max jit-lock-end) - ;;(syntax-ppss-flush-cache min) - ))) - (mumamo-msgfntfy "mumamo-mumamo-jit-lock-after-change-1 EXIT %s" (cons min max)) - (cons min max)) - -(defun mumamo-mark-chunk () - "Mark chunk and move point to beginning of chunk." - (interactive) - (let ((chunk (mumamo-find-chunks (point) "mumamo-mark-chunk"))) - (unless chunk (error "There is no MuMaMo chunk here")) - (goto-char (overlay-start chunk)) - (push-mark (overlay-end chunk) t t))) - -(defun mumamo-narrow-to-chunk-inner () - (interactive) - (let* ((chunk (mumamo-find-chunks (point) "mumamo-narrow-to-chunk-innner")) - (syntax-min-max (mumamo-chunk-syntax-min-max chunk t)) - (syntax-min (car syntax-min-max)) - (syntax-max (cdr syntax-min-max))) - (narrow-to-region syntax-min syntax-max))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Font lock functions - -(defadvice hi-lock-set-pattern (around use-overlays activate) - (if mumamo-multi-major-mode - (let ((font-lock-fontified nil)) - ad-do-it) - ad-do-it)) - -;;;###autoload -(defun mumamo-mark-for-refontification (min max) - "Mark region between MIN and MAX for refontification." - ;;(msgtrc "mark-for-refontification A min,max=%s,%s point-min,max=%s,%s modified=%s" min max (point-min) (point-max) (buffer-modified-p) ) - ;;(mumamo-backtrace "mark-for-refontification") - (mumamo-msgfntfy "mumamo-mark-for-refontification A min,max=%s,%s point-min,max=%s,%s modified=%s" min max (point-min) (point-max) (buffer-modified-p) ) - (assert (<= min max)) - (when (< min max) - (save-restriction - (widen) - (mumamo-msgfntfy "mumamo-mark-for-refontification B min,max=%s,%s point-min,max=%s,%s modified=%s" min max (point-min) (point-max) (buffer-modified-p) ) - ;;(mumamo-with-buffer-prepared-for-jit-lock - (mumamo-save-buffer-state nil - (put-text-property min max 'fontified nil) - )))) - - -;; Fix me: The functions in this list must be replaced by variables -;; pointing to anonymous functions for buffer local values of -;; fontification keywords to be supported. And that is of course -;; necessary for things like hi-lock etc. (Or..., perhaps some kind of -;; with-variable-values... as RMS suggested once... but that will not -;; help here...) -;; -;; Seems like font-lock-add-keywords must be advised... -(defvar mumamo-internal-major-modes-alist nil - "Alist with info for different major modes. -Internal use only. This is automatically set up by -`mumamo-get-major-mode-setup'.") -(setq mumamo-internal-major-modes-alist nil) -(put 'mumamo-internal-major-modes-alist 'permanent-local t) - -(defvar mumamo-ppss-last-chunk nil - "Internal variable used to avoid unnecessary flushing.") -(defvar mumamo-ppss-last-major nil - "Internal variable used to avoid unnecessary flushing.") - -;;(mumamo-get-major-mode-substitute 'nxhtml-mode 'fontification) -;;(mumamo-get-major-mode-substitute 'nxhtml-mode 'indentation) -;;(mumamo-get-major-mode-substitute 'css-mode 'fontification) -;;(mumamo-get-major-mode-substitute 'css-mode 'indentation) -;; (assq 'nxml-mode mumamo-major-mode-substitute) -(defconst mumamo-major-mode-substitute - '( - (nxhtml-mode (html-mode nxhtml-mode)) - ;;(nxhtml-mode (html-mode)) - (nxhtml-genshi-mode (html-mode nxhtml-mode)) - (nxhtml-mjt-mode (html-mode nxhtml-mode)) - (nxml-mode (sgml-mode)) - ) - "Major modes substitute to use for fontification and indentation. -The entries in this list has either of the formats - - \(MAJOR (FONT-MODE INDENT-MODE)) - \(MAJOR (FONT-MODE)) - -where major is the major mode in a mumamo chunk and FONT-MODE is -the major mode for fontification of that chunk and INDENT-MODE is -dito for indentation. In the second form the same mode is used -for indentation as for fontification.") - -;;(mumamo-get-major-mode-substitute 'nxhtml-mode 'indentation) -;;(mumamo-get-major-mode-substitute 'nxhtml-mode 'fontification) -(defun mumamo-get-major-mode-substitute (major for-what) - "For major mode MAJOR return major mode to use for FOR-WHAT. -FOR-WHAT can be either 'fontification or indentation. - -mumamo must handle fontification and indentation for `major-mode' -by using other major mode if the functions for this in -`major-mode' are not compatible with mumamo. This functions -looks in the table `mumamo-major-mode-substitute' for get major -mode to use." - ;;(when (eq for-what 'indentation) (message "subst.major=%s" major)) - (let ((m (assq major mumamo-major-mode-substitute)) - ret-major) - (if (not m) - (setq ret-major major) - (setq m (nth 1 m)) - (setq ret-major - (cond - ((eq for-what 'fontification) - (nth 0 m)) - ((eq for-what 'indentation) - (nth 1 m)) - (t - (mumamo-display-error 'mumamo-get-major-mode-substitute - "Bad parameter, for-what=%s" for-what)))) - (unless ret-major (setq ret-major major))) - (unless (commandp ret-major) (setq ret-major 'mumamo-bad-mode)) - ;;(when (eq for-what 'indentation) (message "ret.ind=%s, major=%s, m=%s" ret major m)) - ret-major)) - -(defun mumamo-assert-fontified-t (start end) - "Assert that the region START to END has 'fontified t." - (let ((start-ok (get-text-property start 'fontified)) - (first-not-ok - (next-single-property-change (1+ start) 'fontified nil end))) - (when (not start-ok) - (message "==== mumamo-assert-fontified-t %s-%s start not ok" start end)) - (when (not (= first-not-ok end)) - (message "==== mumamo-assert-fontified-t %s-%s first not ok=%s" start end first-not-ok)))) - -;; Keep this separate for easier debugging. -(defun mumamo-do-fontify (start end verbose chunk-syntax-min chunk-syntax-max chunk-major) - "Fontify region between START and END. -If VERBOSE is non-nil then print status messages during -fontification. - -CHUNK-SYNTAX-MIN, CHUNK-SYNTAX-MAX and CHUNK-MAJOR are the -chunk's min point, max point and major mode. - -During fontification narrow the buffer to the chunk to make -syntactic fontification work. If chunks starts or end with \" -then the first respective last char then exclude those chars from -from the narrowed part, since otherwise the syntactic -fontification can't find out where strings start and stop. - -Note that this function is run under -`mumamo-with-major-mode-fontification'. - -This function takes care of `font-lock-dont-widen' and -`font-lock-extend-region-functions'. Normally -`font-lock-default-fontify-region' does this, but that function -is not called when mumamo is used! - -PS: `font-lock-fontify-syntactically-region' is the main function -that does syntactic fontification." - ;;(msgtrc "mumamo-do-fontify enter: font-lock-keywords-only def=%s" (default-value 'font-lock-keywords-only)) - ;;(msgtrc "mumamo-do-fontify <<<<<<< %s %s %s %s %s %s" start end verbose chunk-syntax-min chunk-syntax-max chunk-major) - ;;(msgtrc "font-lock-keywords=%S" font-lock-keywords) - ;;(mumamo-assert-fontified-t start end) - (mumamo-condition-case err - (let* ((font-lock-dont-widen t) - (font-lock-extend-region-functions - ;; nil - font-lock-extend-region-functions - ) - ;; Extend like in `font-lock-default-fontify-region': - (funs font-lock-extend-region-functions) - (font-lock-beg (max chunk-syntax-min start)) - (font-lock-end (min chunk-syntax-max end)) - (while-n1 0)) - ;;(while (and (> 500 (setq while-n1 (1+ while-n1))) - (while (and (mumamo-while 500 'while-n1 "funs") - funs) - (setq funs (if (or (not (funcall (car funs))) - (eq funs font-lock-extend-region-functions)) - (cdr funs) - ;; If there's been a change, we should go through - ;; the list again since this new position may - ;; warrant a different answer from one of the fun - ;; we've already seen. - font-lock-extend-region-functions))) - ;; But we must restrict to the chunk here: - (let ((new-start (max chunk-syntax-min font-lock-beg)) - (new-end (min chunk-syntax-max font-lock-end))) - ;;(msgtrc "do-fontify %s %s, chunk-syntax-min,max=%s,%s, new: %s %s" start end chunk-syntax-min chunk-syntax-max new-start new-end) - ;; A new condition-case just to catch errors easier: - (when (< new-start new-end) - (mumamo-condition-case err - (save-restriction - ;;(when (and (>= 625 (point-min)) (<= 625 (point-max))) (msgtrc "multi at 625=%s" (get-text-property 625 'font-lock-multiline))) - ;;(msgtrc "(narrow-to-region %s %s)" chunk-syntax-min chunk-syntax-max) - (when (< chunk-syntax-min chunk-syntax-max) - (narrow-to-region chunk-syntax-min chunk-syntax-max) - ;; Now call font-lock-fontify-region again but now - ;; with the chunk font lock parameters: - (setq font-lock-syntactically-fontified (1- new-start)) - (mumamo-msgfntfy "ENTER font-lock-fontify-region %s %s %s" new-start new-end verbose) - ;;(msgtrc "mumamo-do-fontify: font-lock-keywords-only =%s in buffer %s, def=%s" font-lock-keywords-only (current-buffer) (default-value 'font-lock-keywords-only)) - (let (font-lock-extend-region-functions) - (font-lock-fontify-region new-start new-end verbose)) - (mumamo-msgfntfy "END font-lock-fontify-region %s %s %s" new-start new-end verbose) - ) - ) - (error - (mumamo-display-error 'mumamo-do-fontify-2 - "mumamo-do-fontify m=%s, s/e=%s/%s syn-min/max=%s/%s: %s" - chunk-major - start end - chunk-syntax-min chunk-syntax-max - (error-message-string err))))))) - (error - (mumamo-display-error 'mumamo-do-fontify - "mumamo-do-fontify m=%s, s=%s, e=%s: %s" - chunk-major start end (error-message-string err))) - ) - (mumamo-msgfntfy "mumamo-do-fontify exit >>>>>>> %s %s %s %s %s %s" start end verbose chunk-syntax-min chunk-syntax-max chunk-major) - ;;(msgtrc "mumamo-do-fontify exit: font-lock-keywords-only def=%s" (default-value 'font-lock-keywords-only)) - ) - -(defun mumamo-do-unfontify (start end) - "Unfontify region between START and END." - (mumamo-condition-case err - (font-lock-unfontify-region start end) - (error - (mumamo-display-error 'mumamo-do-unfontify "%s" - (error-message-string err))))) - -(defun mumamo-fontify-region-with (start end verbose major chunk-syntax-min chunk-syntax-max) - "Fontify from START to END. -If VERBOSE is non-nil then print status messages during -fontification. - -Do the fontification as in major mode MAJOR. - -Narrow to region CHUNK-SYNTAX-MIN and CHUNK-SYNTAX-MAX during -fontification." - ;; The text property 'fontified is always t here due to the way - ;; jit-lock works! - - ;;(msgtrc "fontify-region-with %s %s %s %s, ff=%s" start end verbose major (get-text-property start 'fontified)) - ;;(mumamo-assert-fontified-t start end) - ;;(msgtrc "mumamo-fontify-region-with enter: font-lock-keywords-only def=%s" (default-value 'font-lock-keywords-only)) - (mumamo-condition-case err - (progn - ;;(msgtrc "mumamo-fontify-region-with: font-lock-keywords-only =%s in buffer %s, def=%s" font-lock-keywords-only (current-buffer) (default-value 'font-lock-keywords-only)) - (mumamo-with-major-mode-fontification major - `(mumamo-do-fontify ,start ,end ,verbose ,chunk-syntax-min ,chunk-syntax-max major)) - ) - (error - (mumamo-display-error 'mumamo-fontify-region-with "%s" - (error-message-string err)))) - ;;(msgtrc "mumamo-fontify-region-with exit: font-lock-keywords-only def=%s" (default-value 'font-lock-keywords-only)) - ) - -(defun mumamo-unfontify-region-with (start end major) - "Unfontify from START to END as in major mode MAJOR." - (mumamo-msgfntfy "mumamo-unfontify-region-with %s %s %s, ff=%s" - start - end - major - (when start - (save-restriction - (widen) - (get-text-property start 'fontified)))) - (mumamo-with-major-mode-fontification major - `(mumamo-do-unfontify ,start ,end))) - - - -(defun mumamo-backtrace (label) - (msgtrc "%s:backtrace in START buffer %s <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n%s" - label (current-buffer) (with-output-to-string (backtrace))) - (msgtrc "%s:backtrace in END buffer %s >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>" label (current-buffer))) - -(defun mumamo-unfontify-buffer () - "Unfontify buffer. -This function is called when the minor mode function -`font-lock-mode' is turned off. \(It is the value of -`font-lock-unfontify-uffer-function')." - (when (and mumamo-multi-major-mode - (not (and (boundp 'mumamo-find-chunks-1-active) - mumamo-find-chunks-1-active))) - ;;(mumamo-backtrace "unfontify-buffer") - ;;(msgtrc "mumamo-unfontify-buffer:\n%s" (with-output-to-string (backtrace))) - (save-excursion - (save-restriction - (widen) - (let ((ovls (overlays-in (point-min) (point-max))) - (main-major (mumamo-main-major-mode))) - (dolist (o ovls) - (when (overlay-get o 'mumamo-is-new) - (let ((major (mumamo-chunk-major-mode o))) - (when major - (unless (mumamo-fun-eq major main-major) - (mumamo-unfontify-chunk o)) - ;;(msgtrc "delete-overlay 1") - (delete-overlay o) - )))) - (mumamo-unfontify-region-with (point-min) (point-max) - (mumamo-main-major-mode))))))) - - -(defun mumamo-fontify-buffer () - "For `font-lock-fontify-buffer-function' call. -Not sure when this normally is done. However some functions call -this to ensure that the whole buffer is fontified." - (mumamo-msgfntfy "===> mumamo-fontify-buffer-function called") - ;;(font-lock-default-fontify-buffer) - (unless mumamo-set-major-running - ;; This function is normally not called, but when new patterns - ;; have been added by hi-lock it will be called. In this case we - ;; need to make buffer local fontification variables: - (set (make-local-variable 'mumamo-internal-major-modes-alist) nil) - (jit-lock-refontify))) - - -(defun mumamo-unfontify-chunk (chunk) ; &optional start end) - "Unfontify mumamo chunk CHUNK." - (let* ((major (mumamo-chunk-major-mode chunk)) - ;;(start (overlay-start chunk)) - ;;(end (overlay-end chunk)) - (syntax-min-max (mumamo-chunk-syntax-min-max chunk t)) - (syntax-min (car syntax-min-max)) - (syntax-max (cdr syntax-min-max)) - (font-lock-dont-widen t)) - (when (< syntax-min syntax-max) - (save-restriction - (narrow-to-region syntax-min syntax-max) - (mumamo-unfontify-region-with syntax-min syntax-max major))))) - -(defun mumamo-fontify-region (start end &optional verbose) - "Fontify between START and END. -Take the major mode chunks into account while doing this. - -If VERBOSE do the verbously. - -The value of `font-lock-fontify-region-function' when -mumamo is used is this function." - (mumamo-msgfntfy "++++++ mumamo-fontify-regionX %s %s %s, skip=%s" start end verbose mumamo-just-changed-major) - ;;(msgtrc "mumamo-fontify-region: font-lock-keywords-only =%s in buffer %s, def=%s" font-lock-keywords-only (current-buffer) (default-value 'font-lock-keywords-only)) - ;;(mumamo-assert-fontified-t start end) - ;; If someone else tries to fontify the buffer ... - (if (and mumamo-just-changed-major - ;; The above variable is reset in `post-command-hook' so - ;; check if we are in a recursive search. (Note: There are - ;; other situation when this can occur. It might be best to - ;; remove this test later, or make it optional.) - ;; - ;; skip the test for now: - nil - (= 0 (recursion-depth))) - (mumamo-display-error 'mumamo-fontify-region - "Just changed major, should not happen") - (mumamo-condition-case err - (mumamo-fontify-region-1 start end verbose) - (error - (mumamo-display-error 'mumamo-fontify-region "%s" - (error-message-string err)))))) - -(defconst mumamo-dbg-pretend-fontified nil - "Set this to t to be able to debug more easily. -This is for debugging `mumamo-fontify-region-1' more easily by -just calling it. It will make that function believe that the text -has a non-nil 'fontified property.") - -(defun mumamo-exc-mode (chunk) - "Return sub major mode for CHUNK. -If chunk is a main major mode chunk return nil, otherwise return -the major mode for the chunk." - (let ((major (mumamo-chunk-major-mode chunk))) - (unless (mumamo-fun-eq major (mumamo-main-major-mode)) - major))) - -;;; Chunk in chunk needs push/pop relative prev chunk -(defun mumamo-chunk-push (chunk prop val) - (let* ((prev-chunk (overlay-get chunk 'mumamo-prev-chunk)) - (prev-val (when prev-chunk (overlay-get prev-chunk prop)))) - (overlay-put chunk prop (cons val prev-val)))) -(defun mumamo-chunk-pop (chunk prop) - (overlay-put chunk prop (cdr (overlay-get (overlay-get chunk 'mumamo-prev-chunk) - prop)))) - -;; (defvar mumamo-chunks-to-remove nil -;; "Internal. Chunk overlays marked for removal.") -;; (make-variable-buffer-local 'mumamo-chunks-to-remove) - -(defun mumamo-flush-chunk-syntax (chunk chunk-min chunk-max) - "Flush syntax cache for chunk CHUNK. -This includes removing text property 'syntax-table between -CHUNK-MIN and CHUNK-MAX." - ;; syntax-ppss-flush-cache - (overlay-put chunk 'syntax-ppss-last nil) - (overlay-put chunk 'syntax-ppss-cache nil) - (overlay-put chunk 'syntax-ppss-stats nil) - (mumamo-save-buffer-state nil - (remove-list-of-text-properties chunk-min chunk-max '(syntax-table)))) - -;; Fix-me: If I open nxhtml-changes.html and then go to the bottom of -;; the file at once syntax-ppss seems to be upset. It is however cured -;; by doing some change above the region that is badly fontified. -(defun mumamo-fontify-region-1 (start end verbose) - "Fontify region between START and END. -If VERBOSE is non-nil then print status messages during -fontification. - -This is called from `mumamo-fontify-region' which is the value of -`font-lock-fontify-region-function' when mumamo is used. \(This -means that it ties into the normal font lock framework in Emacs.) - -Note: The purpose of extracting this function from -`mumamo-fontify-region' \(which is the only place where it is -called) is to make debugging easier. Edebug will without this -function just step over the `condition-case' in -`mumamo-fontify-region'. - -The fontification is done in steps: - -- First a mumamo chunk is found or created at the start of the - region with `mumamo-get-chunk-at'. -- Then this chunk is fontified according to the major mode for - that chunk. -- If the chunk did not encompass the whole region then this - procedure is repeated with the rest of the region. - -If some mumamo chunk in the region between START and END has been -marked for removal \(for example by `mumamo-jit-lock-after-change') then -they are removed by this function. - -For some main major modes \(see `define-mumamo-multi-major-mode') the -main major modes is first used to fontify the whole region. This -is because otherwise the fontification routines for that mode may -have trouble finding the correct starting state in a chunk. - -Special care has been taken for chunks that are strings, ie -surrounded by \"...\" since they are fontified a bit special in -most major modes." - ;; Fix-me: unfontifying should be done using the correct syntax table etc. - ;; Fix-me: refontify when new chunk - ;;(msgtrc "fontify-region-1: font-lock-keywords-only =%s in buffer %s, def=%s" font-lock-keywords-only (current-buffer) (default-value 'font-lock-keywords-only)) - (save-match-data - (let* ((old-point (point)) - (here start) - (main-major (mumamo-main-major-mode)) - (fontified-t ;;(or mumamo-dbg-pretend-fontified - ;; (get-text-property here 'fontified)) - t) - after-change-functions ;; Fix-me: tested adding this to avoid looping - (first-new-ovl nil) - (last-new-ovl nil) - (chunk-at-start-1 (mumamo-find-chunks start "mumamo-fontify-region-1")) - (while-n1 0) - ) - (when chunk-at-start-1 - (unless (= start (1- (overlay-end chunk-at-start-1))) - (setq chunk-at-start-1 nil))) - ;;(while (and (> 500 (setq while-n1 (1+ while-n1))) - (while (and (mumamo-while 9000 'while-n1 "fontified-t") - fontified-t - (< here end)) - ;;(msgtrc "mumamo-fontify-region-1 heree 1, here=%s, end=%s" here end) - ;;(mumamo-assert-fontified-t here end) - ;;(mumamo-assert-fontified-t start end) - ;; Check where new chunks should be, adjust old chunks as - ;; necessary. Refontify inside end-start and outside of - ;; start-end mark for refontification when major-mode has - ;; changed or there was no old chunk. - ;; - ;; Fix-me: Join chunks! - (let* ((chunk (mumamo-find-chunks here "mumamo-fontify-region-1 2")) - (chunk-min (when chunk (overlay-start chunk))) - (chunk-max (when chunk (overlay-end chunk))) - (chunk-min-1 (when chunk (if (> chunk-min (point-min)) (1- chunk-min) (point-min)))) - (chunk-max-1 (when chunk (if (< chunk-max (point-max)) (1+ chunk-max) (point-max)))) - (chunk-min-face (when chunk (get-text-property chunk-min-1 'face))) - (chunk-max-face (when chunk (get-text-property chunk-max-1 'face))) - (chunk-major (when chunk (mumamo-chunk-major-mode chunk))) - max ; (min chunk-max end)) - ) - (assert chunk) - - (setq chunk-min (when chunk (overlay-start chunk))) - (setq chunk-max (when chunk (overlay-end chunk))) - (setq chunk-min-1 - (when chunk - (if (> chunk-min (point-min)) (1- chunk-min) (point-min)))) ;chunk-min - (setq chunk-max-1 - (when chunk - (if (< chunk-max (point-max)) (1+ chunk-max) (point-max)))) ;chunk-max - (setq chunk-min-face - (when chunk (get-text-property chunk-min-1 'face))) - (setq chunk-max-face - (when chunk (get-text-property chunk-max-1 'face))) - (setq chunk-major (when chunk (mumamo-chunk-major-mode chunk))) - - (if (and first-new-ovl (overlay-buffer first-new-ovl)) - (setq last-new-ovl chunk) - (setq last-new-ovl chunk) - (setq first-new-ovl chunk)) - ;;(mumamo-assert-fontified-t chunk-min chunk-max) - - (setq max (min chunk-max end)) - - (assert chunk) (assert (overlay-buffer chunk)) (assert chunk-min) - (assert chunk-max) (assert chunk-major) - ;; Fix-me: The next assertion sometimes fails. Could it be - ;; that this loop is continuing even after a change in the - ;; buffer? How do I stop that? When?: - ;;(assert (or (= here start) (= here chunk-min)) nil "h=%s, s=%s, cm=%s-%s, e=%s, chunk-major=%s" here start chunk-min chunk-max end chunk-major) - ;;(assert (not (mumamo-fun-eq prev-major chunk-major))) - ;;(when prev-chunk - ;; (assert (= (overlay-end prev-chunk) (overlay-start chunk)))) - - ;; Fontify - ;;(msgtrc "\nmumamo-fontify-region-1 before chunk=%s" chunk) - (mumamo-update-obscure chunk here) - (let* ((syntax-min-max (mumamo-chunk-syntax-min-max chunk nil)) - (syntax-min (car syntax-min-max)) - (syntax-max (cdr syntax-min-max)) - (chunk-min (overlay-start chunk)) - (chunk-max (overlay-end chunk)) - (border-min-max (mumamo-chunk-syntax-min-max chunk t)) - (border-min (car border-min-max)) - (border-max (cdr border-min-max)) - ) - ;;(msgtrc "fontify-region-1:syntax-min-max=%S, chunk=%S" syntax-min-max chunk) - ;;(msgtrc "chunk mumamo-border-face: %s" chunk) - (mumamo-msgfntfy "mumamo-fontify-region-1, here=%s chunk-min=%s syn-mn/mx=%s/%s" here chunk-min syntax-min syntax-max) - (when (<= here syntax-min) - (mumamo-flush-chunk-syntax chunk syntax-min syntax-max)) - (when (and (<= here syntax-min) - (< chunk-min border-min)) - ;;(msgtrc "face-in: %s-%s" chunk-min border-min) - (put-text-property chunk-min border-min 'face 'mumamo-border-face-in) - ) - (when (and (<= chunk-max max) - ;;(< (1+ border-max) chunk-max)) - (< border-max chunk-max)) - ;;(put-text-property (1+ border-max) chunk-max - (put-text-property border-max chunk-max - 'face 'mumamo-border-face-out)) - (mumamo-fontify-region-with here max verbose chunk-major - syntax-min syntax-max)) - - ;;(setq prev-major chunk-major) - ;;(setq prev-chunk chunk) - (setq here (if (= max here) (1+ max) max)) - ;;(setq fontified-t (or mumamo-dbg-pretend-fontified (get-text-property (1- here) 'fontified))) - ) - ;;(msgtrc "ft here end=%s %s %s" fontified-t here end) - ) - (goto-char old-point) - ;;(msgtrc "b first-new-ovl=%s last-new-ovl=%s" first-new-ovl last-new-ovl) - (unless fontified-t - ;; Fix-me: I am not sure what to do here. Probably just - ;; refontify the rest between start and end. But does not - ;; this lead to unnecessary refontification? - ;;(msgtrc "not sure, here=%s, end=%s" here end) - (unless (= here (point-max)) - (mumamo-mark-for-refontification here end))) - )) - ;;(msgtrc "EXIT mumamo-fontify-region-1") - ) - - -(defvar mumamo-known-buffer-local-fontifications - '( - font-lock-mode-hook - ;; - css-color-mode - hi-lock-mode - hi-lock-file-patterns - hi-lock-interactive-patterns - wrap-to-fill-column-mode - )) - -(defconst mumamo-irrelevant-buffer-local-vars - '( - ;; This list was fetched with - ;; emacs-Q, fundamental-mode - after-change-functions - ;;auto-composition-function - ;;auto-composition-mode - ;;auto-composition-mode-major-mode - buffer-auto-save-file-format - buffer-auto-save-file-name - buffer-backed-up - buffer-display-count - buffer-display-time - buffer-file-format - buffer-file-name - buffer-file-truename - buffer-invisibility-spec - buffer-read-only - buffer-saved-size - buffer-undo-list - change-major-mode-hook - ;;char-property-alias-alist - cursor-type - default-directory - delay-mode-hooks - enable-multibyte-characters - ;;font-lock-mode - ;;font-lock-mode-major-mode - ;;major-mode - mark-active - mark-ring - mode-name - point-before-scroll - ;; Handled by font lock etc - font-lock-defaults - font-lock-fontified - font-lock-keywords - ;;font-lock-keywords-only - font-lock-keywords-case-fold-search - font-lock-mode - ;;font-lock-mode-major-mode - font-lock-set-defaults - font-lock-syntax-table - ;;font-lock-beginning-of-syntax-function - syntax-begin-function - fontification-functions - jit-lock-context-unfontify-pos - jit-lock-mode - ;; Mumamo - font-lock-fontify-buffer-function - jit-lock-contextually - jit-lock-functions - ;; More symbols from visual inspection - before-change-functions - delayed-mode-hooks - isearch-mode - line-move-ignore-invisible - local-abbrev-table - ;;syntax-ppss-last - ;;syntax-ppss-cache - - ;; Cua - cua--explicit-region-start - ;; Viper - viper--intercept-key-maps - viper--key-maps - viper-ALPHA-char-class - viper-current-state - viper-emacs-global-user-minor-mode - viper-emacs-intercept-minor-mode - viper-emacs-kbd-minor-mode - viper-emacs-local-user-minor-mode - viper-emacs-state-modifier-minor-mode - viper-insert-basic-minor-mode - viper-insert-diehard-minor-mode - viper-insert-global-user-minor-mode - viper-insert-intercept-minor-mode - viper-insert-kbd-minor-mode - viper-insert-local-user-minor-mode - viper-insert-minibuffer-minor-mode - viper-insert-point - viper-insert-state-modifier-minor-mode - viper-intermediate-command - viper-last-posn-while-in-insert-state - viper-minibuffer-current-face - viper-mode-string - viper-non-word-characters - viper-replace-minor-mode - viper-replace-overlay - viper-undo-functions - viper-undo-needs-adjustment - viper-vi-basic-minor-mode - viper-vi-diehard-minor-mode - viper-vi-global-user-minor-mode - viper-vi-intercept-minor-mode - viper-vi-kbd-minor-mode - viper-vi-local-user-minor-mode - viper-vi-minibuffer-minor-mode - viper-vi-state-modifier-minor-mode - ;; hs minor mode - hs-adjust-block-beginning - hs-block-start-mdata-select - hs-block-start-regexp - hs-c-start-regexp - hs-forward-sexp-func - hs-minor-mode - ;; Imenu - imenu-case-fold-search - imenu-generic-expression - ;; Fix-me: add more here - )) - -(defun mumamo-get-relevant-buffer-local-vars () - "Get list of buffer local variables to save. -Like `buffer-local-variables', but remove variables that are -known to not be necessary to save for fontification, indentation -or filling \(or that can even disturb things)." - (let (var-vals) - (dolist (vv (buffer-local-variables)) - (unless (or (not (listp vv)) - (memq (car vv) mumamo-irrelevant-buffer-local-vars) - (let* ((sym (car vv)) - (val (symbol-value sym))) - (or (markerp val) - (overlayp val)))) - (let ((ent (list (car vv) (custom-quote (cdr vv))))) - (setq var-vals (cons ent var-vals))))) - ;; Sorting is for debugging/testing - (setq var-vals (sort var-vals - (lambda (a b) - (string< (symbol-name (car a)) - (symbol-name (car b)))))) - var-vals)) - -(defvar mumamo-major-modes-local-maps nil - "An alist with major mode and local map. -An entry in the list looks like - - \(MAJOR-MODE LOCAL-KEYMAP)") - -;; (defun mumamo-font-lock-keyword-hook-symbol (major) -;; "Return hook symbol for adding font-lock keywords to MAJOR." -;; (intern (concat "mumamo-" (symbol-name major) "-font-lock-keyword-hook"))) - -;; (defun mumamo-remove-font-lock-hook (major setup-fun) -;; "For mode MAJOR remove function SETUP-FUN. -;; See `mumamo-add-font-lock-hook' for more information." -;; (remove-hook (mumamo-font-lock-keyword-hook-symbol major) setup-fun)) - -(defun mumamo-refresh-multi-font-lock (major) - "Refresh font lock information for mode MAJOR in chunks. -If multi fontification functions for major mode MAJOR is already -setup up they will be refreshed. - -If MAJOR is nil then all font lock information for major modes -used in chunks will be refreshed. - -After calling font-lock-add-keywords or changing the -fontification in other ways you must call this function for the -changes to take effect. However already fontified buffers will -not be refontified. You can use `normal-mode' to refontify -them. - -Fix-me: Does not work yet." - - (setq mumamo-internal-major-modes-alist - (if (not major) - nil - (assq-delete-all major mumamo-internal-major-modes-alist)))) - -;; RMS had the following idea: -;; -;; Suppose we add a Lisp primitive to bind a set of variables under -;; the control of an alist. Would it be possible to eliminate these -;; helper functions and use that primitive instead? -;; -;;; But wouldn't it be better to test this version first? There is -;;; no hurry, this version works and someone might find that there -;;; is a better way to do this than with helper functions. -;; -;; OK with me, as long as this point doesn't get forgotten. -(defun mumamo-fetch-major-mode-setup (major keywords mode-keywords add-keywords how) - "Return a helper function to do fontification etc like in major mode MAJOR. -Fetch the variables affecting font locking, indentation and -filling by calling the major mode MAJOR in a temporary buffer. - -Make a function with one parameter BODY which is elisp code to -eval. The function should let bind the variables above, sets the -syntax table temporarily to the one used by the major mode -\(using the mode symbol name to find it) and then evaluates body. - -Name this function mumamo-eval-in-MAJOR. Put the code for this -function in the property `mumamo-defun' on this function symbol. - - -** Some notes about background etc. - -The function made here is used in `mumamo-with-major-mode-setup'. -The code in the function parameter BODY is typically involved in -fontification, indentation or filling. - -The main reasons for doing it this way is: - -- It is faster and than setting the major mode directly. -- It does not affect buffer local variables." - ;; (info "(elisp) Other Font Lock Variables") - ;; (info "(elisp) Syntactic Font Lock) - ;;(msgtrc "fetch-major 1: font-lock-keywords-only =%s" font-lock-keywords-only) - (let ((func-sym (intern (concat "mumamo-eval-in-" (symbol-name major)))) - (func-def-sym (intern (concat "mumamo-def-eval-in-" (symbol-name major)))) - ;;(add-keywords-hook (mumamo-font-lock-keyword-hook-symbol major)) - byte-compiled-fun - (fetch-func-definition `(lambda (body))) ;;`(defun ,func-sym (body))) - temp-buf-name - temp-buf) - ;; font-lock-mode can't be turned on in buffers whose names start - ;; with a char with white space syntax. Temp buffer names are - ;; such and it is not possible to change name of a temp buffer. - (setq temp-buf-name (concat "mumamo-fetch-major-mode-setup-" (symbol-name major))) - (setq temp-buf (get-buffer temp-buf-name)) - (when temp-buf (kill-buffer temp-buf)) - (setq temp-buf (get-buffer-create temp-buf-name)) - ;;(msgtrc "fetch-major-mode-setup in buffer %s, after-chunk=%s, before with-current-buffer" (current-buffer) (when (boundp 'after-chunk) after-chunk)) - (with-current-buffer temp-buf - - (mumamo-msgfntfy "mumamo-fetch-major-mode-setup %s" major) - (let ((mumamo-fetching-major t) - mumamo-multi-major-mode) - ;;(msgtrc "fetch-major-mode-setup in buffer %s, before (funcall %s)" (current-buffer) major) - (funcall major) - ) - - (mumamo-msgfntfy ">>> mumamo-fetch-major-mode-setup A font-lock-mode=%s" font-lock-mode) - (font-lock-mode 1) - (mumamo-msgfntfy "<<< mumamo-fetch-major-mode-setup B font-lock-mode=%s" font-lock-mode) - (mumamo-msgfntfy "mumamo-fetch-major-mode-setup: fetching jit-lock-after-change-extend-region-functions A=%s" jit-lock-after-change-extend-region-functions) - - ;; Note: font-lock-set-defaults must be called before adding - ;; keywords. Otherwise Emacs loops. I have no idea why. Hm, - ;; probably wrong, it is likely to be nxhtml-mumamo that is the - ;; problem. Does not loop in html-mumamo. - ;;(msgtrc "\n--------------------") - (font-lock-set-defaults) - ;; Fix-me: but hi-lock still does not work... what have I - ;; forgotten??? font-lock-keywords looks ok... - (when keywords - (if add-keywords - (progn - ;;(msgtrc "fetch:font-lock-add-keywords %S %S %S" (if mode-keywords major nil) keywords how) - (font-lock-add-keywords (if mode-keywords major nil) keywords how) - ;;(font-lock-add-keywords major keywords how) - ;;(msgtrc "fetch:font-lock-keywords=%S" font-lock-keywords) - ) - (font-lock-remove-keywords (if mode-keywords major nil) keywords) - ;;(font-lock-remove-keywords major keywords) - ) - (unless mode-keywords (font-lock-mode -1) (font-lock-mode 1)) - ;;(msgtrc "fetch-major-mode-setup:font-lock-keywords=%S" font-lock-keywords) - ) - ;;(run-hooks add-keywords-hook) - - (add-to-list 'mumamo-major-modes-local-maps - (let ((local-map (current-local-map))) - (cons major-mode (if local-map - (copy-keymap local-map) - 'no-local-map)))) - - (mumamo-msgfntfy "mumamo-fetch-major-mode-setup: fetching jit-lock-after-change-extend-region-functions B=%s" jit-lock-after-change-extend-region-functions) - (let* ((syntax-sym (intern-soft (concat (symbol-name major) "-syntax-table"))) - (fetch-func-definition-let - ;; Be XML compliant: - (list - (list 'sgml-xml-mode - ;;(when (mumamo-derived-from-mode ',major 'sgml-mode) t)) - (when (mumamo-derived-from-mode major 'sgml-mode) t)) - - ;; We need to copy the variables that we need and - ;; that are not automatically buffer local, but - ;; could be it. Arguably it is a bug if they are not - ;; buffer local though we have to adapt. - - ;; From cc-mode.el: - (list 'indent-line-function (custom-quote indent-line-function)) - (list 'indent-region-function (custom-quote indent-region-function)) - (list 'normal-auto-fill-function (custom-quote normal-auto-fill-function)) - (list 'comment-start (custom-quote comment-start)) - (list 'comment-end (custom-quote comment-end)) - (list 'comment-start-skip (custom-quote comment-start-skip)) - (list 'comment-end-skip (custom-quote comment-end-skip)) - (list 'comment-multi-line (custom-quote comment-multi-line)) - (list 'comment-line-break-function (custom-quote comment-line-break-function)) - (list 'paragraph-start (custom-quote paragraph-start)) - (list 'paragraph-separate (custom-quote paragraph-separate)) - (list 'paragraph-ignore-fill-prefix (custom-quote paragraph-ignore-fill-prefix)) - (list 'adaptive-fill-mode (custom-quote adaptive-fill-mode)) - (list 'adaptive-fill-regexp (custom-quote adaptive-fill-regexp)) - - ;;; Try doing the font lock things last, keywords really last - (list 'font-lock-multiline (custom-quote font-lock-multiline)) - (list 'font-lock-extend-after-change-region-function (custom-quote font-lock-extend-after-change-region-function)) - (list 'font-lock-extend-region-functions (custom-quote font-lock-extend-region-functions)) - (list 'font-lock-comment-start-skip (custom-quote font-lock-comment-start-skip)) - (list 'font-lock-comment-end-skip (custom-quote font-lock-comment-end-skip)) - (list 'font-lock-syntactic-keywords (custom-quote font-lock-syntactic-keywords)) - - (list 'font-lock-keywords (custom-quote font-lock-keywords)) - ;;(list 'font-lock-keywords-alist (custom-quote font-lock-keywords-alist)) - ;;(list 'font-lock-removed-keywords-alist (custom-quote font-lock-removed-keywords-alist)) - - ;; Fix-me: uncommenting this line (as it should be) - ;; sets font-lock-keywords-only to t globally...: bug 3467 - (list 'font-lock-keywords-only (custom-quote font-lock-keywords-only)) - - (list 'font-lock-keywords-case-fold-search (custom-quote font-lock-keywords-case-fold-search)) - - (list 'font-lock-set-defaults t) ; whether we have set up defaults. - - ;; Set from font-lock-defaults normally: - (list 'font-lock-defaults (custom-quote (copy-tree font-lock-defaults))) - ;; Syntactic Font Lock - (list 'font-lock-syntax-table (custom-quote font-lock-syntax-table)) ;; See nXhtml bug 400415 - (list 'syntax-begin-function (custom-quote syntax-begin-function)) - (list 'font-lock-syntactic-face-function (custom-quote font-lock-syntactic-face-function)) - - ;; Other Font Lock Variables - (list 'font-lock-mark-block-function (custom-quote font-lock-mark-block-function)) - (list 'font-lock-extra-managed-props (custom-quote font-lock-extra-managed-props)) - ;; This value is fetched from font-lock: - (list 'font-lock-fontify-buffer-function (custom-quote font-lock-fontify-buffer-function)) - (list 'font-lock-unfontify-buffer-function (custom-quote font-lock-unfontify-buffer-function)) - (list 'font-lock-fontify-region-function (custom-quote font-lock-fontify-region-function)) - (list 'font-lock-unfontify-region-function (custom-quote font-lock-unfontify-region-function)) - - ;; Jit Lock Variables - (list 'jit-lock-after-change-extend-region-functions (custom-quote jit-lock-after-change-extend-region-functions)) - - ;;(list 'syntax-table (custom-quote (copy-syntax-table (syntax-table)))) - ;;(list 'mumamo-original-syntax-begin-function (custom-quote syntax-begin-function)) - (list 'syntax-begin-function (custom-quote syntax-begin-function)) - (list 'fill-paragraph-function (custom-quote fill-paragraph-function)) - (list 'fill-forward-paragraph-function - (when (boundp 'fill-forward-paragraph-function) - (custom-quote fill-forward-paragraph-function))) - - ;; newcomment - (list 'comment-use-global-state (custom-quote (when (boundp 'comment-use-global-state) comment-use-global-state))) - - ;; parsing sexps - (list 'multibyte-syntax-as-symbol (custom-quote multibyte-syntax-as-symbol)) - (list 'parse-sexp-ignore-comments (custom-quote parse-sexp-ignore-comments)) - (list 'parse-sexp-lookup-properties (custom-quote parse-sexp-lookup-properties)) - ;; fix-me: does not the next line work? - (list 'forward-sexp-function (custom-quote forward-sexp-function)) - )) - (relevant-buffer-locals (mumamo-get-relevant-buffer-local-vars)) - ) - ;;(append '(1 2) '(3 4) '((eval body))) - (mumamo-msgfntfy "===========> before setq fetch-func-definition %s" func-sym) - ;; Avoid doublets - (dolist (fetched fetch-func-definition-let) - (let ((fvar (car fetched))) - (setq relevant-buffer-locals (assq-delete-all fvar relevant-buffer-locals)))) - (setq fetch-func-definition - (append fetch-func-definition - `((let ,(append fetch-func-definition-let - relevant-buffer-locals) - (with-syntax-table ,(if syntax-sym - syntax-sym - '(standard-syntax-table));;'syntax-table - ;; fix-me: Protect against font-lock-keywords-only to t globally...: bug 3467 - ;;(msgtrc "%s enter 1: font-lock-keywords-only def=%s, body=%S" ',major (default-value 'font-lock-keywords-only) body) - (let (;(font-lock-keywords-only font-lock-keywords-only) - ret) - ;;(msgtrc "%s enter 2: font-lock-keywords-only def=%s" ',major (default-value 'font-lock-keywords-only)) - (setq ret (eval body)) - ;;(msgtrc "%s exit 1: font-lock-keywords-only def=%s" ',major (default-value 'font-lock-keywords-only)) - ret)) - ;;(msgtrc "in %s 1: font-lock-keywords-only =%s in buffer %s, def=%s" ',func-sym font-lock-keywords-only (current-buffer) (default-value 'font-lock-keywords-only)) - ) - ;;(msgtrc "in %s 2: font-lock-keywords-only =%s in buffer %s, def=%s" ',func-sym font-lock-keywords-only (current-buffer) (default-value 'font-lock-keywords-only)) - ;;(message "backtrace there:\n%s" (with-output-to-string (backtrace))) - ))) - - (setq byte-compiled-fun (let ((major-syntax-table)) - (byte-compile fetch-func-definition))) - (assert (functionp byte-compiled-fun)) - (unless keywords - (eval `(defvar ,func-sym nil)) - (eval `(defvar ,func-def-sym ,fetch-func-definition)) - (set func-sym byte-compiled-fun) ;; Will be used as default - (assert (functionp (symbol-value func-sym)) t) - (funcall (symbol-value func-sym) nil) - (put func-sym 'permanent-local t) - (put func-def-sym 'permanent-local t)))) - (kill-buffer temp-buf) - ;; Use the new value in current buffer. - (when keywords - ;;(set (make-local-variable func-sym) (symbol-value func-sym)) - ;;(msgtrc "fetch: major=%s func-def-sym=%s cb=%s fetch-func-definition=%s" major func-def-sym (current-buffer) fetch-func-definition) - ;;(msgtrc "fetch: major=%s func-def-sym=%s cb=%s fetch-func-definition" major func-def-sym (current-buffer)) - (set (make-local-variable func-sym) byte-compiled-fun) - (set (make-local-variable func-def-sym) fetch-func-definition) - (put func-sym 'permanent-local t) - (put func-def-sym 'permanent-local t)) - (assert (functionp (symbol-value func-sym)) t) - ;; return a list def + fun - (cons func-sym func-def-sym))) - -;; Fix-me: maybe a hook in font-lock-add-keywords?? -(defun mumamo-ad-font-lock-keywords-helper (major keywords how add-keywords) - ;;(msgtrc "ad-font-lock-keywords-helper %s %s %s %s" major keywords how add-keywords) - (if major - (mumamo-fetch-major-mode-setup major keywords t t how) - ;; Fix-me: Can't do that, need a list of all - ;; mumamo-current-chunk-family chunk functions major - ;; modes. But this is impossible since the major modes might - ;; be determined dynamically. As a work around look in current - ;; chunks. - (let ((majors (list (mumamo-main-major-mode)))) - (dolist (entry mumamo-internal-major-modes-alist) - (let ((major (car entry)) - (fun-var-sym (caadr entry))) - (when (local-variable-p fun-var-sym) - (setq majors (cons (car entry) majors))))) - (dolist (major majors) - (setq major (mumamo-get-major-mode-substitute major 'fontification)) - ;;(msgtrc "(fetch-major-mode-setup %s %s %s %s %s)" major keywords nil t how) - (mumamo-fetch-major-mode-setup major keywords nil add-keywords how)) - ;;(font-lock-mode -1) (font-lock-mode 1) - ))) - -;; Fix-me: This has stopped working again 2009-11-04, but I do not know when it began... -(defadvice font-lock-add-keywords (around - mumamo-ad-font-lock-add-keywords - activate - compile) - (if (or (boundp 'mumamo-fetching-major) (boundp 'mumamo-add-font-lock-called) (not mumamo-multi-major-mode)) - ad-do-it - (let (mumamo-multi-major-mode - mumamo-add-font-lock-called - (major (ad-get-arg 0)) - (keywords (ad-get-arg 1)) - (how (ad-get-arg 2))) - (mumamo-ad-font-lock-keywords-helper major keywords how t)))) - -(defadvice font-lock-remove-keywords (around - mumamo-ad-font-lock-remove-keywords - activate - compile) - (if (or (boundp 'mumamo-fetching-major) (boundp 'mumamo-add-font-lock-called) (not mumamo-multi-major-mode)) - ad-do-it - (let (mumamo-multi-major-mode - mumamo-add-font-lock-called - (major (ad-get-arg 0)) - (keywords (ad-get-arg 1))) - (mumamo-ad-font-lock-keywords-helper major keywords nil nil)))) - -(defun mumamo-bad-mode () - "MuMaMo replacement for a major mode that could not be loaded." - (interactive) - (kill-all-local-variables) - (setq major-mode 'mumamo-bad-mode) - (setq mode-name - (propertize "Mumamo Bad Mode" - 'face 'font-lock-warning-face))) - -;;(mumamo-get-major-mode-setup 'css-mode) -;;(mumamo-get-major-mode-setup 'fundamental-mode) -(defun mumamo-get-major-mode-setup (use-major) - "Return function for evaluating code in major mode USE-MAJOR. -Fix-me: This doc string is wrong, old: - -Get local variable values for major mode USE-MAJOR. These -variables are used for indentation and fontification. The -variables are returned in a list with the same format as -`mumamo-fetch-major-mode-setup'. - -The list of local variable values which is returned by this -function is cached in `mumamo-internal-major-modes-alist'. This -avoids calling the major mode USE-MAJOR for each chunk during -fontification and speeds up fontification significantly." - ;; Fix-me: Problems here can cause mumamo to loop badly when this - ;; function is called over and over again. To avoid this add a - ;; temporary entry using mumamo-bad-mode while trying to fetch the - ;; correct mode. - - ;;(assq 'mumamo-bad-mode mumamo-internal-major-modes-alist) - (let ((use-major-entry (assq use-major mumamo-internal-major-modes-alist)) - bad-mode-entry - dummy-entry - fun-var-sym - fun-var-def-sym) - (unless use-major-entry - ;; Get mumamo-bad-mode entry and add a dummy entry based on - ;; this to avoid looping. - (setq bad-mode-entry - (assq 'mumamo-bad-mode mumamo-internal-major-modes-alist)) - (unless bad-mode-entry - ;; Assume it is safe to get the mumamo-bad-mode entry ;-) - (add-to-list 'mumamo-internal-major-modes-alist - (list 'mumamo-bad-mode - (mumamo-fetch-major-mode-setup 'mumamo-bad-mode nil nil nil nil))) - (setq bad-mode-entry - (assq 'mumamo-bad-mode mumamo-internal-major-modes-alist))) - (setq dummy-entry (list use-major (cadr bad-mode-entry))) - ;; Before fetching setup add the dummy entry and then - ;; immediately remove it. - (add-to-list 'mumamo-internal-major-modes-alist dummy-entry) - (setq use-major-entry (list use-major - (mumamo-fetch-major-mode-setup use-major nil nil nil nil))) - (setq mumamo-internal-major-modes-alist - (delete dummy-entry - mumamo-internal-major-modes-alist)) - (add-to-list 'mumamo-internal-major-modes-alist use-major-entry)) - (setq fun-var-sym (caadr use-major-entry)) - (setq fun-var-def-sym (cdadr use-major-entry)) - (assert (functionp (symbol-value fun-var-sym)) t) - (assert (eq 'lambda (car (symbol-value fun-var-def-sym))) t) - ;; Always make a buffer local value for keywords. - (unless (local-variable-p fun-var-sym) - (set (make-local-variable fun-var-sym) (symbol-value fun-var-sym)) - (set (make-local-variable fun-var-def-sym) (symbol-value fun-var-def-sym))) - (caadr (or (assq use-major mumamo-internal-major-modes-alist) - )))) -;; (assq use-major -;; (add-to-list 'mumamo-internal-major-modes-alist -;; (list use-major -;; (mumamo-fetch-major-mode-setup -;; use-major nil nil nil)))))))) - -(defun mumamo-remove-all-chunk-overlays () - "Remove all CHUNK overlays from the current buffer." - (save-restriction - (widen) - (mumamo-delete-new-chunks))) - - - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Creating and accessing chunks - -(defun mumamo-define-no-mode (mode-sym) - "Fallback major mode when no major mode for MODE-SYM is found." - (let ((mumamo-repl4 (intern (format "mumamo-4-%s" mode-sym))) - (lighter (format "No %s" mode-sym)) - (doc (format "MuMaMo replacement for %s which was not found." - mode-sym))) - (if (commandp mumamo-repl4) - mumamo-repl4 - (eval `(defun ,mumamo-repl4 () - ,doc - (interactive) - (kill-all-local-variables) - (setq major-mode ',mumamo-repl4) - (setq mode-name - (propertize ,lighter - 'face 'font-lock-warning-face))))))) -;;(mumamo-define-no-mode 'my-ownB-mode) - -;;(mumamo-major-mode-from-modespec 'javascript-mode) -(defun mumamo-major-mode-from-modespec (major-spec) - "Translate MAJOR-SPEC to a major mode. -Translate MAJOR-SPEC used in chunk definitions of multi major -modes to a major mode. - -See `mumamo-major-modes' for an explanation." - (mumamo-major-mode-from-spec major-spec mumamo-major-modes)) - -(defun mumamo-major-mode-from-spec (major-spec table) - (unless major-spec - (mumamo-backtrace "mode-from-modespec, major-spec is nil")) - (let ((modes (cdr (assq major-spec table))) - (mode 'mumamo-bad-mode)) - (setq mode - (catch 'mode - (dolist (m modes) - (when (functionp m) - (let ((def (symbol-function m))) - (when (and (listp def) - (eq 'autoload (car def))) - (mumamo-condition-case err - (load (nth 1 def)) - (error (setq m nil))))) - (when m (throw 'mode m)))) - nil)) - (unless mode - (if (functionp major-spec) - ;; As a last resort allow spec to be a major mode too: - (setq mode major-spec) - (if modes - (mumamo-warn-once '(mumamo-major-mode-from-modespec) - "Couldn't find an available major mode for specification %s,\n alternatives are:\n %s" - major-spec modes) - (mumamo-warn-once '(mumamo-major-mode-from-modespec) - "Couldn't find an available major mode for spec %s" - major-spec)) - ;;(setq mode 'fundamental-mode) - (setq mode (mumamo-define-no-mode major-spec)) - )) - (mumamo-msgfntfy " mumamo-major-mode-from-modespec %s => %s" major-spec mode) - mode)) - -(defun mumamo-get-existing-new-chunk-at (pos &optional first) - "Return last existing chunk at POS if any. -However if FIRST get first existing chunk at POS instead." - ;;(msgtrc "(mumamo-get-existing-new-chunk-at %s)" pos) - (let ((chunk-ovl) - (orig-pos pos)) - (when (= pos (point-max)) - (setq pos (1- pos))) - (when (= pos 0) (setq pos 1)) - (dolist (o (overlays-in pos (1+ pos))) - (when (and (overlay-get o 'mumamo-is-new) - ;; Because overlays-in need to have a range of length - ;; > 0 we might have got overlays that is after our - ;; orig-pos: - (<= (overlay-start o) orig-pos)) - ;; There can be two, choose the last or first depending on - ;; FIRST. - (if chunk-ovl - ;; (when (or (> (overlay-end o) (overlay-start o)) - ;; (overlay-get o 'mumamo-prev-chunk)) - (when (if first - (< (overlay-end o) (overlay-end chunk-ovl)) - (> (overlay-end o) (overlay-end chunk-ovl)) - ) - (setq chunk-ovl o)) - (setq chunk-ovl o)))) - chunk-ovl)) - -(defun mumamo-get-chunk-save-buffer-state (pos) - "Return chunk overlay at POS. Preserve state." - (let (chunk) - ;;(mumamo-save-buffer-state nil - ;;(setq chunk (mumamo-get-chunk-at pos))) - (setq chunk (mumamo-find-chunks pos "mumamo-get-chunk-save-buffer-state")) - ;;) - chunk)) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Chunk and chunk family properties - -(defun mumamo-syntax-maybe-completable (pnt) - "Return non-nil if at point PNT non-printable characters may occur. -This just considers existing chunks." - (let* ((chunk (mumamo-find-chunks pnt "mumamo-syntax-maybe-completable")) - syn-min-max) - (if (not chunk) - t - (mumamo-update-obscure chunk pnt) - (setq syn-min-max (mumamo-chunk-syntax-min-max chunk nil)) - ;;(and (> pnt (1+ (mumamo-chunk-syntax-min chunk))) - (and (> pnt (1+ (car syn-min-max))) - ;;(< pnt (1- (mumamo-chunk-syntax-max chunk))))))) - (< pnt (1- (cdr syn-min-max))))))) - -(defvar mumamo-current-chunk-family nil - "The currently used chunk family.") -(make-variable-buffer-local 'mumamo-current-chunk-family) -(put 'mumamo-current-chunk-family 'permanent-local t) - -;; (defvar mumamo-main-major-mode nil) -;; (make-variable-buffer-local 'mumamo-main-major-mode) -;; (put 'mumamo-main-major-mode 'permanent-local t) - -(defun mumamo-main-major-mode () - "Return major mode used when there are no chunks." - (let ((mm (cadr mumamo-current-chunk-family))) - (if mm mm - (msgtrc "main-major-mode => nil, mumamo-current-chunk-family=%s" mumamo-current-chunk-family)))) -;;; (let ((main (cadr mumamo-current-chunk-family))) -;;; (if main -;;; main -;;; mumamo-main-major-mode))) - -;; (defun mumamo-unset-chunk-family () -;; "Set chunk family to nil, ie undecided." -;; (interactive) -;; (setq mumamo-current-chunk-family nil)) - -;; (defun mumamo-define-chunks (chunk-family) -;; "Set the CHUNK-FAMILY used to divide the buffer." -;; (setq mumamo-current-chunk-family chunk-family)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; General chunk search routines - -;; search start forward - -;;(defun mumamo-search-fw-exc-start-str (pos max marker) -(defun mumamo-chunk-start-fw-str (pos max marker) - "General chunk function helper. -A chunk function helper like this can be used in -`mumamo-find-possible-chunk' to find the borders of a chunk. -There are several functions like this that comes with mumamo. -Their names tell what they do. Lets look at the parts of the -name of this function: - - mumamo-chunk: All this helper functions begins so - -start-: Search for the start of a chunk - -fw-: Search forward - -str: Search for a string - -Instead of '-start-' there could be '-end-', ie end. -Instead of '-fw-' there could be '-bw-', ie backward. -Instead of '-str' there could be '-re', ie regular expression. - -There could also be a '-inc' at the end of the name. If the name -ends with this then the markers should be included in the chunks, -otherwise not. - -The argument POS means where to start the search. MAX means how -far to search (when searching backwards the argument is called -'min' instead). MARKER is a string or regular expression (see -the name) to search for." - (assert (stringp marker)) - (let ((pm (point-min)) - (cb (current-buffer))) - (message "cb=%s" cb) - (goto-char (max pm (- pos (length marker))))) - (search-forward marker max t)) - -(defun mumamo-chunk-start-fw-re (pos max marker) - "General chunk function helper. -See `mumamo-chunk-start-fw-str' for more information and the -meaning of POS, MAX and MARKER." - (assert (stringp marker)) - (goto-char (- pos (length marker))) - (re-search-forward marker max t)) - -(defun mumamo-chunk-start-fw-str-inc (pos max marker) - "General chunk function helper. -See `mumamo-chunk-start-fw-str' for more information and the -meaning of POS, MAX and MARKER." - (assert (stringp marker)) - (goto-char pos) - (let ((start (search-forward marker max t))) - (when start (setq start (- start (length marker)))))) - -;; search start backward - -;; (defun mumamo-chunk-start-bw-str (pos min marker) -;; "General chunk function helper. -;; See `mumamo-chunk-start-fw-str' for more information and the -;; meaning of POS, MIN and MARKER." -;; ;;(assert (stringp marker)) -;; (let (start-in) -;; (goto-char pos) -;; (setq start-in (search-backward marker min t)) -;; (when start-in -;; ;; do not include the marker -;; (setq start-in (+ start-in (length marker)))) -;; start-in)) - -;; (defun mumamo-chunk-start-bw-re (pos min marker) -;; "General chunk function helper. -;; See `mumamo-chunk-start-fw-str' for more information and the -;; meaning of POS, MIN and MARKER." -;; (assert (stringp marker)) -;; (let (start-in) -;; (goto-char pos) -;; (setq start-in (re-search-backward marker min t)) -;; (when start-in -;; ;; do not include the marker -;; (setq start-in (match-end 0))) -;; start-in)) - -;; (defun mumamo-chunk-start-bw-str-inc (pos min marker) -;; "General chunk function helper. -;; See `mumamo-chunk-start-fw-str' for more information and the -;; meaning of POS, MIN and MARKER." -;; (assert (stringp marker)) -;; (goto-char (+ pos (length marker))) -;; (search-backward marker min t)) - -;; search end forward - -(defun mumamo-chunk-end-fw-str (pos max marker) - "General chunk function helper. -See `mumamo-chunk-start-fw-str' for more information and the -meaning of POS, MAX and MARKER." - (assert (stringp marker)) - ;;(goto-char (1+ pos)) ;; 1+ cause otherwise ?> is at point - (goto-char pos) - (let (end-in) - (setq end-in (search-forward marker max t)) - (when end-in - ;; do not include the marker - (setq end-in (- end-in (length marker)))) - end-in)) - -(defun mumamo-chunk-end-fw-re (pos max marker) - "General chunk function helper. -See `mumamo-chunk-start-fw-str' for more information and the -meaning of POS, MAX and MARKER." - (assert (stringp marker)) - (goto-char (1+ pos)) ;; 1+ cause otherwise ?> is at point - (let (end-in) - (setq end-in (re-search-forward marker max t)) - (when end-in - ;; do not include the marker - (setq end-in (match-beginning 0))) - end-in)) - -(defun mumamo-chunk-end-fw-str-inc (pos max marker) - "General chunk function helper. -See `mumamo-chunk-start-fw-str' for more information and the -meaning of POS, MAX and MARKER." - (assert (stringp marker)) - ;;(goto-char (1+ pos)) ;; 1+ cause otherwise ?> is at point - (goto-char (1+ (- pos (length marker)))) - ;;(msgtrc "mumamo-chunk-end-fw-str-inc %s %s %s, point=%s point-max=%s" pos max marker (point) (point-max)) - (search-forward marker max t)) - -;; search end backward - -;; (defun mumamo-chunk-end-bw-str (pos min marker) -;; "General chunk function helper. -;; See `mumamo-chunk-start-fw-str' for more information and the -;; meaning of POS, MIN and MARKER." -;; (assert (stringp marker)) -;; (goto-char (+ pos (length marker))) -;; (search-backward marker min t)) - -;; (defun mumamo-chunk-end-bw-re (pos min marker) -;; "General chunk function helper. -;; See `mumamo-chunk-start-fw-str' for more information and the -;; meaning of POS, MIN and MARKER." -;; (assert (stringp marker)) -;; (goto-char (+ pos (length marker))) -;; (re-search-backward marker min t)) - -(defun mumamo-chunk-end-bw-str-inc (pos min marker) - "General chunk function helper. -See `mumamo-chunk-start-fw-str' for more information and the -meaning of POS, MIN and MARKER." - (assert (stringp marker)) - (goto-char pos) - (let ((end (search-backward marker min t))) - (when end (setq end (+ end (length marker)))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; General chunk routines - -;; (defvar mumamo-known-chunk-start nil "Internal use only!.") - -(defconst mumamo-string-syntax-table - (let ((tbl (copy-syntax-table))) - (modify-syntax-entry ?\" "\"" tbl) - (modify-syntax-entry ?\' "\"" tbl) - tbl) - "Just for \"..\" and '...'.") - -;; "..." '...' "..'.." '.."..' -(defun mumamo-guess-in-string (pos) - "If POS is in a string then return string start position. -Otherwise return nil." - (when (and (>= pos (point-min))) - (let ((here (point)) - (inhibit-field-text-motion t) - line-beg - parsed - str-char - str-pos) - (goto-char pos) - (setq line-beg (line-beginning-position)) - (setq parsed (with-syntax-table mumamo-string-syntax-table - (parse-partial-sexp line-beg pos))) - (setq str-char (nth 3 parsed)) - (when str-char - (skip-chars-backward (string ?^ str-char)) - (setq str-pos (point))) - (goto-char here) - str-pos))) - -;;; The main generic chunk routine - -;; Fix-me: new routine that really search forward only. Rewrite -;; `mumamo-quick-static-chunk' first with this. -(defun mumamo-possible-chunk-forward (pos - max - chunk-start-fun - chunk-end-fun - &optional borders-fun) - "Search forward from POS to MAX for possible chunk. -Return as a list with values - - \(START END CHUNK-MAJOR BORDERS PARSEABLE-BY CHUNK-END-FUN BORDERS-FUN) - -START and END are start and end of the possible chunk. -CHUNK-MAJOR is the major mode specifier for this chunk. \(Note -that this specifier is translated to a major mode through -`mumamo-major-modes'.) - -START-BORDER and END-BORDER may be nil. Otherwise they should be -the position where the border ends respectively start at the -corresponding end of the chunk. - -BORDERS is the return value of the optional BORDERS-FUN which -takes three parameters, START, END and EXCEPTION-MODE in the -return values above. BORDERS may be nil and otherwise has this -format: - - \(START-BORDER END-BORDER CHUNK-MAJOR CHUNK-END-FUN) - -PARSEABLE-BY is a list of major modes with parsers that can parse -the chunk. - -CHUNK-START-FUN and CHUNK-END-FUN should be functions that -searches forward from point for start and end of chunk. They -both take two parameters, POS and MAX above. If no possible -chunk is found both these functions should return nil, otherwise -see below. - -CHUNK-START-FUN should return a list of the form below if a -possible chunk is found: - - (START CHUNK-MAJOR PARSEABLE-BY) - -CHUNK-END-FUN should return the end of the chunk. - -" - ;;(msgtrc "possible-chunk-forward %s %s" pos max) - (let ((here (point)) - start-rec - start - end - chunk-major - parseable-by - borders - ret - ) - (goto-char pos) - ;; Fix-me: check valid. Should this perhaps be done in the - ;; function calling this instead? - ;;(mumamo-end-in-code syntax-min syntax-max curr-major) - (setq start-rec (funcall chunk-start-fun (point) max)) - (when start-rec - (setq start (nth 0 start-rec)) - (setq chunk-major (nth 1 start-rec)) - (setq parseable-by (nth 2 start-rec)) - (goto-char start) - ;; Fix-me: check valid - ;;(setq end (funcall chunk-end-fun (point) max)) - (when borders-fun - (let ((start-border (when start (unless (and (= 1 start) - (not chunk-major)) - start))) - (end-border (when end (unless (and (= (point-max) end) - (not chunk-major)) - end)))) - (setq borders (funcall borders-fun start-border end-border chunk-major)))) - (setq ret (list start end chunk-major borders parseable-by chunk-end-fun borders-fun))) - (goto-char here) - ret)) - -;; Fix-me: This routine has some difficulties. One of the more -;; problematic things is that chunk borders may depend on the -;; surrounding chunks syntax. Patterns that possibly could be chunk -;; borders might instead be parts of comments or strings in cases -;; where they should not be valid borders there. -(defun mumamo-find-possible-chunk (pos - min max - bw-exc-start-fun ;; obsolete - bw-exc-end-fun - fw-exc-start-fun - fw-exc-end-fun - &optional find-borders-fun) - (mumamo-find-possible-chunk-new pos - ;;min - max - bw-exc-start-fun - ;;bw-exc-end-fun - fw-exc-start-fun - fw-exc-end-fun - find-borders-fun)) - -(defun mumamo-find-possible-chunk-new (pos - ;;min - max - bw-exc-start-fun - ;;bw-exc-end-fun - fw-exc-start-fun - fw-exc-end-fun - &optional find-borders-fun) - ;; This should return no end value! - "Return list describing a possible chunk that starts after POS. -No notice is taken about existing chunks and no chunks are -created. The description returned is for the smallest possible -chunk which is delimited by the function parameters. - -POS must be less than MAX. - -The function BW-EXC-START-FUN takes two parameters, POS and -MIN. It should search backward from POS, bound by MIN, for -exception start and return a cons or a list: - - \(FOUND-POS . EXCEPTION-MODE) - \(FOUND-POS EXCEPTION-MODE PARSEABLE-BY) - -Here FOUND-POS is the start of the chunk. EXCEPTION-MODE is the -major mode specifier for this chunk. \(Note that this specifier -is translated to a major mode through `mumamo-major-modes'.) - -PARSEABLE-BY is a list of parsers that can handle the chunk -beside the one that may be used by the chunks major mode. -Currently only the XML parser in `nxml-mode' is recognized. In -this list it should be the symbol `nxml-mode'. - -The functions FW-EXC-START-FUN and FW-EXC-END-FUN should search -for exception start or end, forward resp backward. Those two -takes two parameters, start position POS and max position MAX, -and should return just the start respectively the end of the -chunk. - -For all three functions the position returned should be nil if -search fails. - - -Return as a list with values - - \(START END EXCEPTION-MODE BORDERS PARSEABLE-BY FR-EXC-FUN FIND-BORDERS-FUN) - -**Fix-me: FIND-BORDERS-FUN must be split for chunks-in-chunks! - -The bounds START and END are where the exception starts or stop. -Either of them may be nil, in which case this is equivalent to -`point-min' respectively `point-max'. - -If EXCEPTION-MODE is non-nil that is the submode for this -range. Otherwise the main major mode should be used for this -chunk. - -BORDERS is the return value of the optional FIND-BORDERS-FUN -which takes three parameters, START, END and EXCEPTION-MODE in -the return values above. BORDERS may be nil and otherwise has -this format: - - \(START-BORDER END-BORDER EXCEPTION-MODE FW-EXC-FUN) - -START-BORDER and END-BORDER may be nil. Otherwise they should be -the position where the border ends respectively start at the -corresponding end of the chunk. - -PARSEABLE-BY is a list of major modes with parsers that can parse -the chunk. - -FW-EXC-FUN is the function that finds the end of the chunk. This -is either FW-EXC-START-FUN or FW-EXC-END-FUN. - ----- * Note: This routine is used by to create new members for -chunk families. If you want to add a new chunk family you could -most often do that by writing functions for this routine. Please -see the many examples in mumamo-fun.el for how this can be done. -See also `mumamo-quick-static-chunk'." - ;;(msgtrc "====") - ;;(msgtrc "find-poss-new %s %s %s %s %s %s" pos max bw-exc-start-fun fw-exc-start-fun fw-exc-end-fun find-borders-fun) - - ;;(mumamo-condition-case err - (progn - (assert (and (<= pos max)) nil - "mumamo-chunk: pos=%s, max=%s, bt=%S" - pos max (with-output-to-string (backtrace))) - ;; "in" refers to "in exception" and "out" is then in main - ;; major mode. - (let (start-in-cons - exc-mode - fw-exc-mode - fw-exc-fun - parseable-by - start-in start-out - end-in end-out - start end - ;;end-of-exception - wants-end-type - found-valid-end - (main-major (mumamo-main-major-mode)) - borders - border-beg - border-end) - ;;;; find start of range - ;; - ;; start normal - ;; - ;;(setq start-out (funcall bw-exc-end-fun pos min)) - ;; Do not check end here! - ;;(setq start-out (funcall fw-exc-end-fun pos max)) - ;;(msgtrc "find-poss-new.start-out=%s" start-out) - ;; start exception - (setq start-in (funcall fw-exc-start-fun pos max)) - ;;(msgtrc "find-poss-new.start-in=%s" start-in) - (when (listp start-in) - (setq fw-exc-mode (nth 1 start-in)) - (setq start-in (car start-in))) - ;; compare - (when (and start-in start-out) - (if (> start-in start-out) - (setq start-in nil) - (setq start-out nil))) - (cond - (start-in - (setq start-in-cons (funcall bw-exc-start-fun start-in pos)) - ;;(msgtrc "find-poss-new.start-in=%s start-in-cons=%s" start-in start-in-cons) - (when start-in-cons - (assert (= start-in (car start-in-cons))) - (setq exc-mode (cdr start-in-cons))) - (setq start start-in)) - (start-out - (setq start start-out)) - ) - (when (and exc-mode - (listp exc-mode)) - (setq parseable-by (cadr exc-mode)) - (setq exc-mode (car exc-mode))) - ;; borders - (when find-borders-fun - (let ((start-border (when start (unless (and (= 1 start) - (not exc-mode)) - start))) - (end-border (when end (unless (and (= (point-max) end) - (not exc-mode)) - end)))) - (setq borders (funcall find-borders-fun start-border end-border exc-mode)))) - ;; check - (setq border-beg (nth 0 borders)) - (setq border-end (nth 1 borders)) - ;;(when start (assert (<= start pos))) - ;;(assert (or (not start) (= start pos))) - (when border-beg - (assert (<= start border-beg))) - ;; Fix-me: This is just totally wrong in some pieces and a - ;; desperate try after seeing the problems with wp-app.php - ;; around line 1120. Maybe this can be used when cutting chunks - ;; from top to bottom however. - (when nil ;end - (let ((here (point)) - end-line-beg - end-in-string - start-in-string - (start-border (or (nth 0 borders) start)) - (end-border (or (nth 1 borders) end))) - ;; Check if in string - ;; Fix-me: add comments about why and examples + tests - ;; Fix-me: must loop to find good borders .... - (when end - ;; Fix-me: more careful positions for guess - (setq end-in-string - (mumamo-guess-in-string - ;;(+ end 2) - (1+ end-border) - )) - (when end-in-string - (when start - (setq start-in-string - (mumamo-guess-in-string - ;;(- start 2) - (1- start-border) - ))) - (if (not start-in-string) - (setq end nil) - (if exc-mode - (if (and start-in-string end-in-string) - ;; If both are in a string and on the same line then - ;; guess this is actually borders, otherwise not. - (unless (= start-in-string end-in-string) - (setq start nil) - (setq end nil)) - (when start-in-string (setq start nil)) - (when end-in-string (setq end nil))) - ;; Fix-me: ??? - (when start-in-string (setq start nil)) - )) - (unless (or start end) - (setq exc-mode nil) - (setq borders nil) - (setq parseable-by nil)))))) - - (when (or start end exc-mode borders parseable-by) - (setq fw-exc-fun (if exc-mode - ;; Fix-me: this is currently correct, - ;; but will change if exc mode in exc - ;; mode is allowed. - fw-exc-end-fun - ;; Fix-me: these should be collected later - ;;fw-exc-start-fun - nil - )) - (mumamo-msgfntfy "--- mumamo-find-possible-chunk-new %s" (list start end exc-mode borders parseable-by fw-exc-fun)) - ;;(message "--- mumamo-find-possible-chunk-new %s" (list start end exc-mode borders parseable-by fw-exc-fun)) - (when fw-exc-mode - (unless (eq fw-exc-mode exc-mode) - ;;(message "fw-exc-mode=%s NEQ exc-mode=%s" fw-exc-mode exc-mode) - )) - ;;(msgtrc "find-poss-new returns %s" (list start end exc-mode borders parseable-by fw-exc-fun find-borders-fun)) - (when fw-exc-fun - (list start end exc-mode borders parseable-by fw-exc-fun find-borders-fun))))) - ;;(error (mumamo-display-error 'mumamo-chunk "%s" (error-message-string err))) - - ;;) - ) - -;; (defun temp-overlays-here () -;; (interactive) -;; (let* ((here (point)) -;; (ovl-at (overlays-at here)) -;; (ovl-in (overlays-in here (1+ here))) -;; (ovl-in0 (overlays-in here here)) -;; ) -;; (with-output-to-temp-buffer (help-buffer) -;; (help-setup-xref (list #'temp-overlays-at) (interactive-p)) -;; (with-current-buffer (help-buffer) -;; (insert (format "overlays-at %s:\n%S\n\n" here ovl-at)) -;; (insert (format "overlays-in %s-%s:\n%S\n\n" here (1+ here) ovl-in)) -;; (insert (format "overlays-in %s-%s:\n%S\n\n" here here ovl-in0)) -;; )))) -;; (defun temp-cursor-pos () -;; (interactive) -;; (what-cursor-position t)) -;; ;;(global-set-key [f9] 'temp-cursor-pos) -;; (defun temp-test-new-create-chunk () -;; (interactive) -;; (mumamo-delete-new-chunks) -;; ;;(setq x1 nil) -;; (let (x1 -;; (first t)) -;; (while (or first x1) -;; (setq first nil) -;; (setq x1 (mumamo-new-create-chunk (mumamo-find-next-chunk-values x1 nil nil nil))))) -;; ) - -;; (defun temp-create-last-chunk () -;; (interactive) -;; (mumamo-new-create-chunk (mumamo-find-next-chunk-values mumamo-last-chunk nil nil nil))) - -(defun mumamo-delete-new-chunks () - (setq mumamo-last-chunk nil) - (save-restriction - (widen) - (let ((ovls (overlays-in (point-min) (point-max)))) - (dolist (ovl ovls) - (when (overlay-get ovl 'mumamo-is-new) - ;;(msgtrc "delete-overlay %s delete-new-chunks" ovl) - (delete-overlay ovl)))))) - -(defun mumamo-new-create-chunk (new-chunk-values) - "Create and return a chunk from NEW-CHUNK-VALUES. -When doing this store the functions for creating the next chunk -after this in the properties below of the now created chunk: - -- 'mumamo-next-major: is nil or the next chunk's major mode. -- 'mumamo-next-end-fun: function that searches for end of AFTER-CHUNK -- 'mumamo-next-border-fun: functions that finds borders" - ;;((1 696 nxhtml-mode nil nil nil nil) (696 nil php-mode nil nil nil nil)) - ;;(current (list curr-min curr-max curr-major curr-border-min curr-border-max curr-parseable curr-fw-exc-fun)) - ;;(msgtrc "######new-create.chunk.new-chunk-values=%s" new-chunk-values) - (when new-chunk-values - (let* ((this-values (nth 0 new-chunk-values)) - (next-values (nth 1 new-chunk-values)) - (next-major (nth 0 next-values)) - (next-end-fun (nth 1 next-values)) - (next-border-fun (nth 2 next-values)) - (next-depth-diff (nth 3 next-values)) - (next-indent (nth 4 next-values)) - (this-beg (nth 0 this-values)) - (this-end (nth 1 this-values)) - (this-maj (nth 2 this-values)) - (this-bmin (nth 3 this-values)) - (this-bmax (nth 4 this-values)) - (this-pable (nth 5 this-values)) - (this-after-chunk (nth 7 this-values)) - ;;(this-is-closed (nth 8 this-values)) - (this-insertion-type-beg (nth 8 this-values)) - (this-insertion-type-end (nth 9 this-values)) - ;;(this-is-closed (and this-end (< 1 this-end))) - (this-after-chunk-depth (when this-after-chunk - (overlay-get this-after-chunk 'mumamo-depth))) - (depth-diff (if this-after-chunk - (overlay-get this-after-chunk 'mumamo-next-depth-diff) - 1)) - (depth (if this-after-chunk-depth - (+ this-after-chunk-depth depth-diff) - 0)) - ;;(fw-funs (nth 6 this-values)) - ;;(borders-fun (nth 7 this-values)) - ;;(this-is-closed (when (or this-end (mumamo-fun-eq this-maj (mumamo-main-major-mode))) t)) - (use-this-end (if this-end this-end (1+ (buffer-size)))) ;(save-restriction (widen) (point-max)))) - (this-chunk (when (and (<= this-beg use-this-end) - ;; Avoid creating two empty overlays - ;; at the this-end - but what if we are - ;; not creating, just changing the - ;; last overlay ... - ;; - ;; (not (and (= this-beg use-this-end) - ;; (= use-this-end (1+ (buffer-size))) - ;; this-after-chunk - ;; (= 0 (- (overlay-end this-after-chunk) (overlay-start this-after-chunk))) - ;; )) - ) - (when (= this-beg 1) - (if (= use-this-end 1) - (assert (mumamo-fun-eq (mumamo-main-major-mode) this-maj) t) - (if this-after-chunk ;; not first - (assert (not (mumamo-fun-eq (mumamo-main-major-mode) this-maj)) t) - (assert (mumamo-fun-eq (mumamo-main-major-mode) this-maj) t)))) - ;;(message "Create chunk %s - %s" this-beg use-this-end) - ;;(make-overlay this-beg use-this-end nil nil (not this-is-closed)) - (make-overlay this-beg use-this-end nil this-insertion-type-beg this-insertion-type-end) - )) - ;; Fix-me: move to mumamo-find-next-chunk-values - (this-border-fun (when (and this-chunk this-after-chunk) - ;;(overlay-get this-after-chunk 'mumamo-next-border-fun) - (mumamo-chunk-car this-after-chunk 'mumamo-next-border-fun) - )) - (this-borders (when this-border-fun - ;;(msgtrc "(funcall %s %s %s %s)" this-border-fun this-beg this-end this-maj) - (funcall this-border-fun this-beg this-end this-maj))) - ;; Fix-me, check: there is no first border when moving out. - (this-borders-min (when (= 1 depth-diff) - (nth 0 this-borders))) - ;; Fix-me, check: there is no bottom border when we move - ;; further "in" since borders are now always inside - ;; sub-chunks (if I remember correctly...). - ;;(this-borders-max (when (and this-is-closed - (this-borders-max (when (and (not this-insertion-type-end) - (/= 1 next-depth-diff)) - (nth 1 this-borders))) - ) - ;;(msgtrc "created %s, major=%s" this-chunk this-maj) - (when (> depth 4) (error "Chunk depth > 4")) - (setq this-bmin nil) - (setq this-bmax nil) - (when this-borders-min (setq this-bmin (- this-borders-min this-beg))) - (when this-borders-max (setq this-bmax (- this-end this-borders-max))) - ;;(when this-after-chunk (message "this-after-chunk.this-end=%s, this-beg=%s, this-end=%s" (overlay-end this-after-chunk) this-beg this-end)) - ;;(message "fw-funs=%s" fw-funs) - (when this-chunk - (overlay-put this-chunk 'mumamo-is-new t) - (overlay-put this-chunk 'face (mumamo-background-color depth)) - (overlay-put this-chunk 'mumamo-depth depth) - ;; Values for next chunk - (overlay-put this-chunk 'mumamo-next-depth-diff next-depth-diff) - (assert (symbolp next-major) t) - (overlay-put this-chunk 'mumamo-next-major next-major) - ;; Values for this chunk - ;;(overlay-put this-chunk 'mumamo-is-closed this-is-closed) - (overlay-put this-chunk 'mumamo-insertion-type-end this-insertion-type-end) - (overlay-put this-chunk 'mumamo-syntax-min-d this-bmin) - (overlay-put this-chunk 'mumamo-syntax-max-d this-bmax) - (overlay-put this-chunk 'mumamo-prev-chunk this-after-chunk) - (overlay-put this-chunk 'mumamo-next-indent next-indent) - (when this-after-chunk (overlay-put this-after-chunk 'mumamo-next-chunk this-chunk)) - - ;;(msgtrc "\n<<<<<<<<<<<<<<<<< next-depth-diff/depth-diff=%s/%s, this-maj=%s, this-after-chunk=%s" next-depth-diff depth-diff this-maj this-after-chunk) - ;;(overlay-put this-chunk 'mumamo-next-end-fun next-end-fun) - (cond - ((= 1 next-depth-diff) - (mumamo-chunk-push this-chunk 'mumamo-next-border-fun next-border-fun) - (mumamo-chunk-push this-chunk 'mumamo-next-end-fun next-end-fun)) - ((= -1 next-depth-diff) - (mumamo-chunk-pop this-chunk 'mumamo-next-border-fun) - (mumamo-chunk-pop this-chunk 'mumamo-next-end-fun)) - ((= 0 next-depth-diff) - nil) - (t (error "next-depth-diff=%s" next-depth-diff))) - ;;(msgtrc "mumamo-next-end-fun=%S" (overlay-get this-chunk 'mumamo-next-end-fun)) - - ;; Fix-me: replace 'mumamo-major-mode with multi major mode to make it more flexible. - (cond - ((= 1 depth-diff) - (mumamo-chunk-push this-chunk 'mumamo-major-mode this-maj)) - ((= -1 depth-diff) - (mumamo-chunk-pop this-chunk 'mumamo-major-mode) - ) - (t (error "depth-diff=%s" depth-diff))) - - (overlay-put this-chunk 'mumamo-parseable-by this-pable) - (overlay-put this-chunk 'created (current-time-string)) - (mumamo-update-chunk-margin-display this-chunk) - (setq mumamo-last-chunk this-chunk) ;; Use this chunk!!!! - ;; Get syntax-begin-function for syntax-ppss: - (let* ((syntax-begin-function - (mumamo-with-major-mode-fontification this-maj - ;; Do like in syntax.el: - '(if syntax-begin-function - (progn - syntax-begin-function) - (when (and (not syntax-begin-function) - ;; fix-me: How to handle boundp here? - (boundp 'syntax-begin-function) - syntax-begin-function) - syntax-begin-function))))) - (mumamo-msgfntfy "Got syntax-begin-function, modified=%s" (buffer-modified-p)) - (overlay-put this-chunk 'syntax-begin-function syntax-begin-function)) - ) - ;;(msgtrc "Created %s, this=%s, next=%s" this-chunk this-values next-values) - this-chunk - ) - )) - -(defun mumamo-update-chunk-margin-display (chunk) - "Set before-string of CHUNK as spec by `mumamo-margin-use'." - ;; Fix-me: This is not displayed. Emacs bug? - ;;(overlay-put this-chunk 'before-string `((margin left-margin) ,(format "%d %s" depth maj))) - (if (not mumamo-margin-info-mode) - (overlay-put chunk 'before-string nil) - (let* ((depth (overlay-get chunk 'mumamo-depth)) - (maj (mumamo-chunk-car chunk 'mumamo-major-mode)) - (strn (propertize (format "%d" depth) - 'face (list :inherit (or (mumamo-background-color depth) - 'default) - :foreground "#505050" - :underline t - :slant 'normal - :weight 'normal - ))) - (maj-name (substring (symbol-name maj) 0 -5)) - (strm (propertize maj-name 'face - (list :foreground "#a0a0a0" :underline nil - :background (frame-parameter nil 'background-color) - :weight 'normal - :slant 'normal))) - str - (margin (mumamo-margin-used))) - (when (> (length strm) 5) (setq strm (substring strm 0 5))) - (setq str (concat strn - strm - (propertize " " 'face 'default) - )) - (overlay-put chunk 'before-string - (propertize " " 'display - `((margin ,margin) ,str)))))) - -(defun mumamo-update-chunks-margin-display (buffer) - "Apply `update-chunk-margin-display' to all chunks in BUFFER." - (with-current-buffer buffer - (save-restriction - (widen) - (let ((chunk (mumamo-find-chunks 1 "margin-disp")) - (while-n0 0)) - (while (and (mumamo-while 1500 'while-n0 "chunk") - chunk) - (mumamo-update-chunk-margin-display chunk) - (setq chunk (overlay-get chunk 'mumamo-next-chunk))))))) - -(defvar mumamo-margin-used nil) -(make-variable-buffer-local 'mumamo-margin-used) -(put 'mumamo-margin-used 'permanent-local t) - -(defun mumamo-margin-used () - (setq mumamo-margin-used - (if (and (boundp 'linum-mode) linum-mode) 'right-margin (nth 0 mumamo-margin-use)))) - -;; (defun mumamo-set-window-margins-used (win) -;; "Set window margin according to `mumamo-margin-use'." -;; ;; Fix-me: old-margin does not work, break it up -;; (let* ((old-margin-used mumamo-margin-used) -;; (margin-used (mumamo-margin-used)) -;; (width (nth 1 mumamo-margin-use)) -;; (both-widths (window-margins win)) -;; (old-left (eq old-margin-used 'left-margin)) -;; (left (eq margin 'left-margin))) -;; ;; Change only the margin we used! -;; (if (not mumamo-margin-info-mode) -;; (progn -;; (set-window-margins win -;; (if left nil (car both-widths)) -;; (if (not left) nil (cdr both-widths))) -;; ) -;; ;;(msgtrc "set-window-margins-used margin-info-mode=t") -;; (case margin-used -;; ('left-margin (set-window-margins win width (when old-left (cdr both-widths)))) -;; ('right-margin (set-window-margins win (car both-widths) width)))))) - -(defun mumamo-update-buffer-margin-use (buffer) - ;;(msgtrc "update-buffer-margin-use %s" buffer) - (when (fboundp 'mumamo-update-chunks-margin-display) - (with-current-buffer buffer - (when mumamo-multi-major-mode - (let* ((old-margin-used mumamo-margin-used) - (margin-used (mumamo-margin-used)) - (old-is-left (eq old-margin-used 'left-margin)) - (is-left (eq margin-used 'left-margin)) - (width (nth 1 mumamo-margin-use)) - (need-update nil)) - (if (not mumamo-margin-info-mode) - (when old-margin-used - (setq need-update t) - (setq old-margin-used nil) - (if old-is-left - (setq left-margin-width 0) - (setq right-margin-width 0))) - (unless (and (eq old-margin-used margin-used) - (= width (if old-is-left left-margin-width right-margin-width))) - (setq need-update t) - (if is-left - (setq left-margin-width width) - (setq right-margin-width width)) - (unless (eq old-margin-used margin-used) - (if old-is-left - (setq left-margin-width 0) - (setq right-margin-width 0))))) - (when need-update - (mumamo-update-chunks-margin-display buffer) - (dolist (win (get-buffer-window-list buffer)) - (set-window-buffer win buffer))) - ) - ;; Note: window update must be before buffer update because it - ;; uses old-margin from the call to function margin-used. - ;; (dolist (win (get-buffer-window-list buffer)) - ;; (mumamo-set-window-margins-used win)) - ;; (mumamo-update-chunks-margin-display buffer) - )))) - -(defun mumamo-new-chunk-value-min (values) - (let ((this-values (nth 0 values))) - (nth 0 this-values))) - -(defun mumamo-new-chunk-value-max (values) - (let ((this-values (nth 0 values))) - (nth 1 this-values))) - -(defun mumamo-new-chunk-equal-chunk-values (chunk values) - ;;(msgtrc "eq? chunk=%S, values=%S" chunk values) - (let* (;; Chunk - (chunk-is-new (overlay-get chunk 'mumamo-is-new)) - ;;(chunk-is-closed (overlay-get chunk 'mumamo-is-closed)) - (chunk-insertion-type-end (overlay-get chunk 'mumamo-insertion-type-end)) - (chunk-next-major (overlay-get chunk 'mumamo-next-major)) - (chunk-next-end-fun (mumamo-chunk-car chunk 'mumamo-next-end-fun)) - (chunk-next-border-fun (mumamo-chunk-car chunk 'mumamo-next-border-fun)) - (chunk-next-chunk-diff (overlay-get chunk 'mumamo-next-depth-diff)) - (chunk-beg (overlay-start chunk)) - (chunk-end (overlay-end chunk)) - (chunk-bmin (overlay-get chunk 'mumamo-syntax-min-d)) - (chunk-bmax (overlay-get chunk 'mumamo-syntax-max-d)) - (chunk-prev-chunk (overlay-get chunk 'mumamo-prev-chunk)) - (chunk-major-mode (mumamo-chunk-car chunk 'mumamo-major-mode)) - (chunk-pable (overlay-get chunk 'mumamo-parseable-by)) - (chunk-depth-diff (if chunk-prev-chunk - (overlay-get chunk-prev-chunk 'mumamo-next-depth-diff) - 0)) - ;; Values - (this-values (nth 0 values)) - (next-values (nth 1 values)) - (values-next-major (nth 0 next-values)) - (values-next-end-fun (nth 1 next-values)) - (values-next-border-fun (nth 2 next-values)) - (values-next-depth-diff (nth 3 next-values)) - (values-beg (nth 0 this-values)) - (values-end (nth 1 this-values)) - (values-major-mode (nth 2 this-values)) - (values-bmin (nth 3 this-values)) - (values-bmax (nth 4 this-values)) - (values-pable (nth 5 this-values)) - (values-prev-chunk (nth 7 this-values)) - (values-insertion-type-beg (nth 8 this-values)) - (values-insertion-type-end (nth 9 this-values)) - ;;(values-is-closed (when values-end t)) - ) - ;;(msgtrc "values=%S" values) - (and t ;chunk-is-new - (eq chunk-next-major values-next-major) - - ;; Can't check chunk-next-end-fun or chunk-next-border-fun - ;; here since they are fetched from prev chunk: - ;;(progn (message "eq-c-v: here b: %s /= %s" chunk-next-end-fun values-next-end-fun) t) - ;;(eq chunk-next-end-fun values-next-end-fun) - ;;(progn (message "eq-c-v: here c, %s /= %s" chunk-next-border-fun values-next-border-fun) t) - ;;(eq chunk-next-border-fun values-next-border-fun) - - (= chunk-next-chunk-diff values-next-depth-diff) - (= chunk-beg values-beg) - ;;(progn (message "eq-c-v: here b") t) - ;; (and (equal chunk-is-closed values-is-closed) - ;; (or (not chunk-is-closed) - (and (equal chunk-insertion-type-end values-insertion-type-end) - (or ;;chunk-insertion-type-end - (= chunk-end values-end))) - ;;(progn (message "eq-c-v: here c, %s /= %s" chunk-major-mode values-major-mode) t) - (or (= -1 chunk-depth-diff) - (eq chunk-major-mode values-major-mode)) - ;;(progn (message "eq-c-v: here d") t) - (equal chunk-pable values-pable) - ;;(progn (message "eq-c-v: here e") t) - (eq chunk-prev-chunk values-prev-chunk) - ;;(progn (message "eq-c-v: here f") t) - ;;(eq chunk-is-closed values-is-closed) - (eq chunk-insertion-type-end values-insertion-type-end) - ;; fix-me: bmin bmax - ;;(and chunk-bmin values-bmin (= chunk-bmin values-bmin)) - ;;(and chunk-bmax values-bmax (= chunk-bmax values-bmax)) - ) - )) - -(defvar mumamo-sub-chunk-families nil - "Chunk dividing routines for sub chunks. -A major mode in a sub chunk can inherit chunk dividing routines -from multi major modes. This is the way chunks in chunks is -implemented. - -This variable is an association list with entries of the form - - \(CHUNK-MAJOR CHUNK-FAMILY) - -where CHUNK-MAJOR is the major mode in a chunk and CHUNK-FAMILY -is a chunk family \(ie the third argument to -`define-mumamo-multi-major-mode'. - -You can use the function `mumamo-inherit-sub-chunk-family' to add -to this list.") - -(defvar mumamo-multi-local-sub-chunk-families nil - "Multi major mode local chunk dividing rourines for sub chunks. -Like `mumamo-sub-chunk-families' specific additions for multi -major modes. The entries have the form - - \((CHUNK-MAJOR . MULTI-MAJOR) CHUNK-FAMILY) - -Use the function `mumamo-inherit-sub-chunk-family-locally' to add -to this list.") - -;;(mumamo-get-sub-chunk-funs 'html-mode) -(defun mumamo-get-sub-chunk-funs (major) - "Get chunk family sub chunk with major mode MAJOR." - (let ((rec (or - (assoc (cons major mumamo-multi-major-mode) mumamo-multi-local-sub-chunk-families) - (assoc major mumamo-sub-chunk-families)))) - (caddr (cadr rec)))) - -(defun mumamo-inherit-sub-chunk-family-locally (multi-major multi-using) - "Add chunk dividing routines from MULTI-MAJOR locally. -The dividing routines from multi major mode MULTI-MAJOR can then -be used in sub chunks in buffers using multi major mode -MULTI-USING." - (let* ((chunk-family (get multi-major 'mumamo-chunk-family)) - (major (nth 1 chunk-family))) - (let ((major-mode major)) - (when (derived-mode-p 'nxml-mode) - (error "Major mode %s major can't be used in sub chunks" major))) - (add-to-list 'mumamo-multi-local-sub-chunk-families - (list (cons major multi-using) chunk-family)))) - -(defun mumamo-inherit-sub-chunk-family (multi-major) - "Inherit chunk dividing routines from multi major modes. -Add chunk family from multi major mode MULTI-MAJOR to -`mumamo-sub-chunk-families'. - -Sub chunks with major mode the same as MULTI-MAJOR mode will use -this chunk familyu to find subchunks." - (let* ((chunk-family (get multi-major 'mumamo-chunk-family)) - (major (nth 1 chunk-family))) - (let ((major-mode major)) - (when (derived-mode-p 'nxml-mode) - (error "Major mode %s major can't be used in sub chunks" major))) - (add-to-list 'mumamo-sub-chunk-families (list major chunk-family)))) - -(defun mumamo-find-next-chunk-values (after-chunk from after-change-max chunk-at-after-change) - "Search forward for start of next chunk. -Return a list with chunk values for next chunk after AFTER-CHUNK -and some values for the chunk after it. - -For the first chunk AFTER-CHUNK is nil. Otherwise the values in stored in AFTER-CHUNK -is used to find the new chunk, its border etc. - - -See also `mumamo-new-create-chunk' for more information." - ;;(msgtrc "(find-next-chunk-values %s %s %s %s)" after-chunk from after-change-max chunk-at-after-change) - ;;(mumamo-backtrace "find-next") - (when after-chunk - (unless (eq (overlay-buffer after-chunk) - (current-buffer)) - (error "mumamo-find-next-chunk-values: after-chunk=%S, cb=%S" after-chunk (current-buffer)))) - (let* ((here (point)) - (max (point-max)) - ;;(after-chunk-is-closed (when after-chunk-valid (overlay-get after-chunk 'mumamo-is-closed))) - (after-chunk-insertion-type-end (when after-chunk (overlay-get after-chunk 'mumamo-insertion-type-end))) - ;; Note that "curr-*" values are fetched from "mumamo-next-*" values in after-chunk - (curr-min (if after-chunk (overlay-end after-chunk) 1)) - (curr-end-fun (when after-chunk - (mumamo-chunk-car after-chunk 'mumamo-next-end-fun))) - (curr-border-fun (when curr-end-fun (mumamo-chunk-car after-chunk 'mumamo-next-border-fun))) - (curr-syntax-min-max (when curr-border-fun (funcall curr-border-fun - (overlay-end after-chunk) - nil nil))) - (curr-syntax-min (or (car curr-syntax-min-max) - (when after-chunk (overlay-end after-chunk)) - 1)) - (search-from (or nil ;from - curr-syntax-min)) - ;;(dummy (msgtrc "search-from=%s" search-from)) - (main-chunk-funs (let ((chunk-info (cdr mumamo-current-chunk-family))) - (cadr chunk-info))) - (curr-major (if after-chunk - (or - ;; 'mumamo-next-major is used when we are going into a sub chunk. - (overlay-get after-chunk 'mumamo-next-major) - ;; We are going out of a sub chunk. - (mumamo-chunk-cadr after-chunk 'mumamo-major-mode)) - (mumamo-main-major-mode))) - ;;(dummy (msgtrc "curr-major=%s" curr-major)) - (curr-chunk-funs - (if (or (not after-chunk) - (= 0 (+ (overlay-get after-chunk 'mumamo-depth) - (overlay-get after-chunk 'mumamo-next-depth-diff)))) - main-chunk-funs - (mumamo-get-sub-chunk-funs curr-major))) - curr-max - next-max - curr-max-found - next-min - curr-border-min - curr-border-max - curr-parseable - next-fw-exc-fun - next-indent - next-major - curr-end-fun-end - next-border-fun - ;; The insertion types for the new chunk - (curr-insertion-type-beg (when after-chunk after-chunk-insertion-type-end)) - curr-insertion-type-end - next-depth-diff - r-point - ) - (unless (and after-chunk-insertion-type-end - (= (1+ (buffer-size)) ;; ie point-max - (overlay-end after-chunk))) - (when (>= max search-from) - (when curr-end-fun - ;; If after-change-max is non-nil here then this function has - ;; been called after changes that are all in one chunk. We - ;; need to check if the chunk right border have been changed, - ;; but we do not have to look much longer than the max point - ;; of the change. - ;;(message "set after-change-max nil") (setq after-change-max nil) - (let* ((use-max (if nil ;;after-change-max - (+ after-change-max 100) - max)) - (chunk-end (and chunk-at-after-change - (overlay-end chunk-at-after-change))) - ;;(use-min (max (- search-from 2) (point-min))) - (use-min curr-syntax-min) - (possible-end-fun-end t) - (end-search-pos use-min)) - ;; The code below takes care of the case when to subsequent - ;; chunks have the same ending delimiter. (Maybe a while - ;; loop is bit overkill here.) - (while (and possible-end-fun-end - (not curr-end-fun-end) - (< end-search-pos use-max)) - (setq curr-end-fun-end (funcall curr-end-fun end-search-pos use-max)) - (if (not curr-end-fun-end) - (setq possible-end-fun-end nil) - (cond ((and t ;after-chunk-is-closed - (< curr-end-fun-end (overlay-end after-chunk))) - (setq curr-end-fun-end nil) - (setq end-search-pos (1+ end-search-pos))) - ;; See if the end is in code - ((let* ((syn2-min-max (when curr-border-fun - (funcall curr-border-fun - (overlay-end after-chunk) - curr-end-fun-end - nil))) - (syn2-max (or (cadr syn2-min-max) - curr-end-fun-end))) - (not (mumamo-end-in-code use-min syn2-max curr-major))) - (setq end-search-pos (1+ curr-end-fun-end)) - (setq curr-end-fun-end nil) - )))) - (unless curr-end-fun-end - ;; Use old end if valid - (and after-change-max - chunk-end - (= -1 (overlay-get chunk-at-after-change 'mumamo-next-depth-diff)) - (< after-change-max chunk-end) - chunk-end)) - ;; Fix-me: Check if old chunk is valid. It is not valid if - ;; depth-diff = -1 and curr-end-fun-end is not the same as - ;; before. - - ;; Fix-me: this test should also be made for other chunks - ;; searches, but this catches most problems I think. - ;; (or (not curr-end-fun-end) - ;; ;; Fix-me: The bug in wiki-090804-js.html indicates that - ;; ;; we should not subtract 1 here. The subchunk there - ;; ;; ends with </script> and this can't be in column 1 - ;; ;; when the line before ends with a // style js comment - ;; ;; unless we don't subtract 1. - ;; ;; - ;; ;; However wiki-strange-hili-080629.html does not work - ;; ;; then because then the final " in style="..." is - ;; ;; included in the scan done in mumamo-end-in-code. - ;; ;; - ;; ;; The solution is to check for the syntax borders here. - ;; (let* ((syn2-min-max (when curr-border-fun - ;; (funcall curr-border-fun - ;; (overlay-end after-chunk) - ;; curr-end-fun-end - ;; nil))) - ;; (syntax-max (or (cadr syn2-min-max) - ;; curr-end-fun-end))) - ;; ;;(mumamo-end-in-code syntax-min (- curr-end-fun-end 1) curr-major) - ;; ;; - ;; ;; fix-me: This should be really in the individual - ;; ;; routines that finds possible chunks. Mabye this is - ;; ;; possible to fix now when just looking forward for - ;; ;; chunks? - ;; (mumamo-end-in-code curr-syntax-min syntax-max curr-major) - ;; ) - ;; (setq curr-end-fun-end nil)) - ;; Use old result if valid - ;; (and nil ;(not curr-end-fun-end) - ;; chunk-at-after-change - ;; (= -1 (overlay-get chunk-at-after-change 'mumamo-next-depth-diff)) - ;; (setq curr-end-fun-end (overlay-end chunk-at-after-change))) - ;;(msgtrc "find-next-chunk-values:curr-end-fun-end after end-in-code=%s" curr-end-fun-end) - )) - ;;(msgtrc "find-next-chunk-values:here d, curr-min=%s, after-chunk=%s" curr-min after-chunk) - (when (listp curr-chunk-funs) - ;;(msgtrc "find-next-chunk-values:curr-chunk-funs=%s" curr-chunk-funs) - (setq r-point (point)) - (dolist (fn curr-chunk-funs) - ;;(msgtrc "find-next-chunk-values:before (r (funcall fn search-from search-from max)), fn=%s search-from=%s, max=%s" fn search-from max) - (assert (= r-point (point)) t) - (let* ((r (funcall fn search-from search-from max)) - (rmin (nth 0 r)) - (rmax (nth 1 r)) - (rmajor-sub (nth 2 r)) - (rborder (nth 3 r)) - (rparseable (nth 4 r)) - (rfw-exc-fun (nth 5 r)) - (rborder-fun (nth 6 r)) - (rindent (nth 7 r)) - (rborder-min (when rborder (nth 0 rborder))) - (rborder-max (when rborder (nth 1 rborder))) - ;;(rmin-found rmin) - ) - ;;(msgtrc "find-next-chunk-values:fn=%s, r=%s" fn r) - (goto-char r-point) - (when r - (when rmax (message "mumamo warning: Bad r=%s, nth 1 should be nil" r)) - (unless (or rmin rmax) - (error "Bad r=%s, fn=%s" r fn)) - (unless rfw-exc-fun - (error "No fw-exc-fun returned from fn=%s, r=%s" fn r)) - (unless rmajor-sub - (error "No major mode for sub chunk, fn=%s, r=%s" fn r))) - (when r - (mumamo-msgfntfy " fn=%s, r=%s" fn r) - (unless rmin (setq rmin (point-max))) - ;;(unless rmax (setq rmax (point-min))) - ;; Do not allow zero length chunks - (unless rmax (setq rmax (point-max))) - (unless (and (> rmin 1) - rmax - (= rmin rmax)) - ;; comparision have to be done differently if we are in an - ;; exception part or not. since we are doing this from top to - ;; bottom the rules are: - ;; - ;; - exception parts always outrules non-exception part. when - ;; in exception part the min start point should be used. - ;; - when in non-exception part the max start point and the - ;; min end point should be used. - ;; - ;; check if first run: - - ;; Fix-me: there is some bug here when borders are not - ;; included and are not 0 width. - (if (not next-min) - (progn - (setq next-min rmin) - (setq curr-border-min rborder-min) - (setq next-max rmax) - (setq curr-border-max rborder-max) - ;;(setq curr-max-found rmin-found) - (setq curr-parseable rparseable) - (setq next-fw-exc-fun rfw-exc-fun) - (setq next-border-fun rborder-fun) - (setq next-indent rindent) - (setq next-major rmajor-sub)) - (if rmajor-sub - (if next-major - (when (or (not next-min) - (< rmin next-min)) - (setq next-min rmin) - (setq curr-border-min rborder-min) - (when rmax (setq max rmax)) - (setq curr-border-max rborder-max) - ;;(when rmin-found (setq curr-max-found t)) - (setq curr-parseable rparseable) - (setq next-fw-exc-fun rfw-exc-fun) - (setq next-border-fun rborder-fun) - (setq next-indent rindent) - (setq next-major rmajor-sub)) - (setq next-min rmin) - (setq curr-border-min rborder-min) - (when rmax (setq max rmax)) - (setq curr-border-max rborder-max) - ;;(when rmin-found (setq curr-max-found t)) - (setq curr-parseable rparseable) - (setq next-fw-exc-fun rfw-exc-fun) - (setq next-border-fun rborder-fun) - (setq next-indent rindent) - (setq next-major rmajor-sub)) - (unless next-major - (when (> next-min rmin) - (setq next-min rmin) - (setq curr-border-min rborder-min)) - (when (and rmax max - (> rmax max)) - ;;(setq max-found rmin-found) - ;;(when rmin-found (setq curr-max-found t)) - (when rmax (setq max rmax)) - (setq curr-border-max rborder-max)) - )))) - (mumamo-msgfntfy "next-min/max=%s/%s border=%s/%s search-from=%s" next-min max curr-border-min curr-border-max search-from) - ;; check! - (when (and next-min max) - ;;(assert (>= next-min search-from) t) - (assert (<= search-from max) t) - (when curr-border-min - (assert (<= next-min curr-border-min) t) - (assert (<= curr-border-min max) t)) - (when curr-border-max - (assert (<= next-min curr-border-max) t) - (assert (<= curr-border-max max) t)))) - ))) - (goto-char here) - (setq curr-max-found (or curr-max-found curr-end-fun-end)) - (when t ;curr-max-found - (setq curr-max (if max max (point-max))) - (setq curr-max (min (if next-min next-min curr-max) - (if curr-end-fun-end curr-end-fun-end curr-max)))) - ;;(setq curr-max nil) - (setq next-depth-diff (cond - ( (and curr-max curr-end-fun-end - (= curr-max curr-end-fun-end)) - -1) - ( (= curr-max (1+ (buffer-size))) - 0) - ( t 1))) - (when (= -1 next-depth-diff) ;; We will pop it from 'mumamo-major-mode - (setq next-major nil)) - (when curr-max - (unless (>= curr-max curr-min) - (error "curr-max is not >= curr-min"))) - ;;(setq curr-is-closed (and curr-max (< 1 curr-max))) - (when (and curr-max (= 1 curr-max)) - (assert (mumamo-fun-eq curr-major (mumamo-main-major-mode)) t) - ) - (assert (symbolp next-major) t) - ;; Fix-me: see for example rr-min8.php - (when (or ;;(not after-chunk) - (= curr-max (1+ (buffer-size))) - (cond - ((= next-depth-diff 1) - next-border-fun) - ((= next-depth-diff -1) - next-border-fun) - ((= next-depth-diff 0) - t) - (t (error "next-depth-diff=%s" next-depth-diff)))) - (setq curr-insertion-type-end t)) - (let ((current (list curr-min curr-max curr-major curr-border-min curr-border-max curr-parseable - curr-chunk-funs after-chunk - ;;curr-is-closed - curr-insertion-type-beg - curr-insertion-type-end - )) - (next (list next-major next-fw-exc-fun next-border-fun next-depth-diff next-indent))) - ;;(msgtrc "find-next-chunk-values=> current=%s, next=%s" current next) - (list current next)))))) - -;; Fix-me: This should check if the new chunk should be -;; parsed or not -;; (defsubst mumamo-chunk-nxml-parseable (chunk) -;; (mumamo-fun-eq (mumamo-main-major-mode) -;; (mumamo-chunk-major-mode xml-chunk))) - -(defun mumamo-valid-nxml-point (pos) - "Return non-nil if position POS is in an XML chunk." - (memq 'nxml-mode (get-text-property pos 'mumamo-parseable-by))) - -(defun mumamo-valid-nxml-chunk (chunk) - "Return t if chunk CHUNK should be valid XML." - (when chunk - (let ((major-mode (mumamo-chunk-major-mode chunk)) - (region (overlay-get chunk 'mumamo-region)) - (parseable-by (overlay-get chunk 'mumamo-parseable-by))) - ;;(message "mumamo-valid-nxml-chunk: major-mode=%s, parseble-by=%s" major-mode parseable-by) - (or region - (derived-mode-p 'nxml-mode) - (memq 'nxml-mode parseable-by))))) - -;; A good test case for the use of this is the troublesome code in the -;; first line of xml-as-string.php in nxml/nxhtml/bug-tests. Currently -;; this test code is however splitted and it looks like the code below -;; can't handle the line above if the line looks like below. The ?> is -;; still thought to be a border. Does this mean that ' is not treated -;; as a string separator? -;; -;; <?php header("Content-type:application/xml; charset=utf-8"); echo '<?xml version="1.0" encoding="utf-8"?>'; ?> -;; -;; However there are the reverse cases also, in lines like -;; -;; href="<?php $this->url($url); ?>" -;; <!-- <td><?php insert_a_lot_of_html(); ?> -;; -;; These are supposedly handled by using this test at the right -;; place... However it is not very clear in all cases whether chunk -;; dividers in comments and strings should be valid or not... -;; -;; For example in the first case above the php divider should be -;; valid. Probably it should be that in the second case too, but how -;; should mumamo know that? -;; -;; Fix-me: I think a per "chunk divider function + context" flag is -;; needed to handle this. Probably this will work the same for all web -;; dev things, ie the opening sub chunk divider is ALWAYS -;; valid. However that is not true for things like CSS, Javascript etc -;; in (X)HTML. - -(defun mumamo-end-in-code (syntax-start syntax-end major) - "Return t if possible syntax end is not in a string or comment. -Assume that the sexp syntax is nil at SYNTAX-START return t if -position SYNTAX-END is not in a string or comment according to -the sexp syntax using major mode MAJOR." - ;; Fix-me: This can't always detect html comments: <!-- - ;; ... -->. Could this be solved by RMS suggestion with a - ;; function/defmacro that binds variables to their global values? - (mumamo-msgfntfy "point-min,max=%s,%s syntax-start,end=%s,%s, major=%s" (point-min) (point-max) syntax-start syntax-end major) - ;;(msgtrc "end-in-code:here a after-chunk=%s" (when (boundp 'after-chunk) after-chunk)) - (assert (and syntax-start syntax-end) t) - (let ((doesnt-here (point)) - doesnt-ret) - (save-restriction - (widen) - ;;(msgtrc "end-in-code:here a2 after-chunk=%s" (when (boundp 'after-chunk) after-chunk)) - (mumamo-with-major-mode-fontification major - `(let (ppss) - ;; fix-me: Use main major mode, and `syntax-ppss'. Change the - ;; defadvice of this to make that possible. - ;;(msgtrc "end-in-code:here b after-chunk=%s" (when (boundp 'after-chunk) after-chunk)) - (setq ppss (parse-partial-sexp ,syntax-start (+ ,syntax-end 0))) - ;;(msgtrc "end-in-code %s %s %s:ppss=%S" ,syntax-start ,syntax-end ',major ppss) - ;;(msgtrc "end-in-code:here c after-chunk=%s" (when (boundp 'after-chunk) after-chunk)) - ;; If inside a string or comment then the end marker is - ;; invalid: - ;;(msgtrc "mumamo-end-in-code:ppss=%s" ppss) - (if (or (nth 3 ppss) - (nth 4 ppss)) - (progn - ;;(msgtrc "invalid end, syntax-end =%s" syntax-end) - (setq doesnt-ret nil) - (if (nth 4 ppss) ;; in comment, check if single line comment - (let ((here (point)) - eol-pos) - ;;(msgtrc "end-in-code, was in comment, ppss=%S" ppss) - (goto-char ,syntax-end) - (setq eol-pos (line-end-position)) - (goto-char here) - (setq ppss (parse-partial-sexp ,syntax-start (+ eol-pos 1))) - ;;(msgtrc "end-in-code, in comment, new ppss %s %s=%S" ,syntax-start (+ eol-pos 1) ppss) - (unless (nth 4 ppss) - (setq doesnt-ret t))))) - (setq doesnt-ret t) - ;;(msgtrc "valid end, syntax-end =%s" syntax-end) - )))) - (goto-char doesnt-here) - ;;(msgtrc "end-in-code:ret=%s" doesnt-ret) - doesnt-ret)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Easy chunk defining - -(defun mumamo-quick-chunk-forward (pos - min max - begin-mark end-mark inc mode - mark-is-border) - ;;(msgtrc "quick-chunk-forward %s %s %s" pos min max) - (let ((search-fw-exc-start - `(lambda (pos max) - (let ((exc-start - (if ,inc - (mumamo-chunk-start-fw-str-inc pos max ,begin-mark) - (mumamo-chunk-start-fw-str pos max ,begin-mark)))) - (when exc-start - (list exc-start mode nil))))) - (search-fw-exc-end - `(lambda (pos max) - ;;(msgtrc "search-fw-exc-end %s %s, inc=%s, end-mark=%s" pos max ,inc ,end-mark) - (save-match-data - (let ((ret (if ,inc - (mumamo-chunk-end-fw-str-inc pos max ,end-mark) - (mumamo-chunk-end-fw-str pos max ,end-mark)))) - ;;(msgtrc "search-fw-exc-end ret=%s" ret) - ret)))) - (find-borders - (when mark-is-border - `(lambda (start end exc-mode) - (let ((start-border) - (end-border)) - (if (and ,inc);; exc-mode) - (progn - (when start - (setq start-border - (+ start (length ,begin-mark)))) - (when end - (setq end-border - (- end (length ,end-mark))))) - (if (and (not ,inc) (not exc-mode)) - (progn - (when start - (setq start-border - (+ start (length ,end-mark)))) - (when end - (setq end-border - (- end (length ,begin-mark))))))) - (when (or start-border end-border) - (mumamo-msgfntfy "quick.start-border/end=%s/%s, start/end=%s/%s exc-mode=%s" start-border end-border start end exc-mode) - (list start-border end-border))))))) - (mumamo-possible-chunk-forward pos max - search-fw-exc-start - search-fw-exc-end - find-borders))) - -(defun mumamo-quick-static-chunk (pos - min max - begin-mark end-mark inc mode - mark-is-border) - (if t - (mumamo-quick-chunk-forward pos min max begin-mark end-mark inc mode mark-is-border) - ;; (let ((old (mumamo-quick-static-chunk-old pos min max begin-mark end-mark inc mode mark-is-border)) - ;; (new (mumamo-quick-chunk-forward pos min max begin-mark end-mark inc mode mark-is-border))) - ;; (unless (equal old new) (msgtrc "equal=%s\n\told=%S\n\tnew=%S" (equal old new) old new)) - ;; (if nil old new)) - )) - -;; (defun mumamo-quick-static-chunk-old (pos -;; min max -;; begin-mark end-mark inc mode -;; mark-is-border) -;; "Quick way to make a chunk function with static dividers. -;; Here is an example of how to use it: - -;; (defun mumamo-chunk-embperl-<- (pos min max) -;; \"Find [- ... -], return range and perl-mode.\" -;; (mumamo-quick-static-chunk pos min max \"[-\" \"-]\" nil 'perl-mode)) - -;; As you can see POS, MIN and MAX comes from argument of the -;; function you define. - -;; BEGIN-MARK should be a string that begins the chunk. -;; END-MARK should be a string that ends the chunk. - -;; If INC is non-nil then the dividers are included in the chunk. -;; Otherwise they are instead made parts of the surrounding chunks. - -;; MODE should be the major mode for the chunk. - -;; If MARK-IS-BORDER is non-nil then the marks are just borders and -;; not supposed to have the same syntax as the inner part of the - -;; Fix-me: This can only be useful if the marks are included in the -;; chunk, ie INC is non-nil. Should not these two arguments be -;; mixed then? -;; " -;; (mumamo-msgfntfy "quick.pos=%s min,max=%s,%s begin-mark/end=%s/%s mark-is-border=%s" pos min max begin-mark end-mark mark-is-border) -;; (let ((search-bw-exc-start -;; `(lambda (pos min) -;; (let ((exc-start -;; (if ,inc -;; (mumamo-chunk-start-bw-str-inc pos min begin-mark) -;; (mumamo-chunk-start-bw-str pos min begin-mark)))) -;; (when (and exc-start -;; (<= exc-start pos)) -;; (cons exc-start mode))))) -;; (search-bw-exc-end -;; `(lambda (pos min) -;; (if ,inc -;; (mumamo-chunk-end-bw-str-inc pos min ,end-mark) -;; (mumamo-chunk-end-bw-str pos min ,end-mark)))) -;; (search-fw-exc-start -;; `(lambda (pos max) -;; (if ,inc -;; (mumamo-chunk-start-fw-str-inc pos max ,begin-mark) -;; (mumamo-chunk-start-fw-str pos max ,begin-mark)))) -;; (search-fw-exc-end -;; `(lambda (pos max) -;; (save-match-data -;; (if ,inc -;; (mumamo-chunk-end-fw-str-inc pos max ,end-mark) -;; (mumamo-chunk-end-fw-str pos max ,end-mark))))) -;; (find-borders -;; (when mark-is-border -;; `(lambda (start end exc-mode) -;; (let ((start-border) -;; (end-border)) -;; (if (and ,inc exc-mode) -;; (progn -;; (when start -;; (setq start-border -;; (+ start (length ,begin-mark)))) -;; (when end -;; (setq end-border -;; (- end (length ,end-mark))))) -;; (if (and (not ,inc) (not exc-mode)) -;; (progn -;; (when start -;; (setq start-border -;; (+ start (length ,end-mark)))) -;; (when end -;; (setq end-border -;; (- end (length ,begin-mark))))))) -;; (when (or start-border end-border) -;; (mumamo-msgfntfy "quick.start-border/end=%s/%s, start/end=%s/%s exc-mode=%s" start-border end-border start end exc-mode) -;; (list start-border end-border))))))) -;; (mumamo-find-possible-chunk pos min max -;; search-bw-exc-start -;; search-bw-exc-end -;; search-fw-exc-start -;; search-fw-exc-end -;; find-borders))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Changing the major mode that the user sees - -(defvar mumamo-unread-command-events-timer nil) -(make-variable-buffer-local 'mumamo-unread-command-events-timer) - -(defun mumamo-unread-command-events (command-keys new-major old-last-command) - "Sync new keymaps after changing major mode in a timer. -Also tell new major mode. - -COMMAND-KEYS is the keys entered after last command and the call -to `mumamo-idle-set-major-mode' \(which is done in an idle -timer). Those keys are added to `unread-command-events' so they -can be used in the new keymaps. They should be in the format -returned by - - \(listify-key-sequence (this-command-keys-vector)) - -NEW-MAJOR mode is the new major mode. - -OLD-LAST-COMMAND is the value of `last-command' after switching -major mode. \(This is cleared by the function `top-level' so -this function will not see it since it is run in a timer.)" - (mumamo-condition-case err - (progn - ;; last-command seems to be cleared by top-level so set it - ;; back here. - (unless last-command - (setq last-command old-last-command)) - (when (< 0 (length command-keys)) - ;;(setq last-command-char nil) ;; For `viper-command-argument' - (setq unread-command-events (append command-keys nil))) - (message "Switched to %s" new-major)) - (error - (let ((mumamo-display-error-lwarn t)) - (mumamo-display-error 'mumamo-unread-command-events "err=%s" err))))) - -(defvar mumamo-idle-set-major-mode-timer nil) -(make-variable-buffer-local 'mumamo-idle-set-major-mode-timer) -(put 'mumamo-idle-set-major-mode-timer 'permanent-local t) - -(defun mumamotemp-pre-command () - "Temporary command for debugging." - (message "mumamotemp-pre 1: modified=%s %s" (buffer-modified-p) (current-buffer))) -(defun mumamotemp-post-command () - "Temporary command for debugging." - (message "mumamotemp-post 1: modified=%s %s" (buffer-modified-p) (current-buffer))) -(put 'mumamotemp-pre-command 'permanent-local-hook t) -(put 'mumamotemp-post-command 'permanent-local-hook t) -(defun mumamotemp-start () - "Temporary command for debugging." - (add-hook 'post-command-hook 'mumamotemp-post-command nil t) - (add-hook 'pre-command-hook 'mumamotemp-pre-command nil t)) - -(defsubst mumamo-cancel-idle-set-major-mode () - (when (timerp mumamo-idle-set-major-mode-timer) - (cancel-timer mumamo-idle-set-major-mode-timer)) - (setq mumamo-idle-set-major-mode-timer nil)) - -(defun mumamo-request-idle-set-major-mode () - "Setup to change major mode from chunk when Emacs is idle." - (mumamo-cancel-idle-set-major-mode) - (setq mumamo-idle-set-major-mode-timer - (run-with-idle-timer - mumamo-set-major-mode-delay - nil - 'mumamo-idle-set-major-mode (current-buffer) (selected-window)))) - -(defvar mumamo-done-first-set-major nil) -(make-variable-buffer-local 'mumamo-done-first-set-major) -(put 'mumamo-done-first-set-major 'permanent-local t) - -;; Fix-me: Add a property to the symbol instead (like in CUA). -(defvar mumamo-safe-commands-in-wrong-major - '(self-insert-command - fill-paragraph ;; It changes major mode - forward-char - viper-forward-char - backward-char - viper-backward-char - next-line - viper-next-line - previous-line - viper-previous-line - scroll-down - cua-scroll-down - scroll-up - cua-scroll-up - move-beginning-of-line - move-end-of-line - nonincremental-search-forward - nonincremental-search-backward - mumamo-backward-chunk - mumamo-forward-chunk - ;; Fix-me: add more - ) - ) - -(defun mumamo-fetch-local-map (major) - "Fetch local keymap for major mode MAJOR. -Do that by turning on the major mode in a new buffer. Add the -keymap to `mumamo-major-modes-local-maps'. - -Return the fetched local map." - (let (temp-buf-name - temp-buf - local-map) - (setq temp-buf-name (concat "mumamo-fetch-major-mode-local-" - (symbol-name major))) - (setq temp-buf (get-buffer temp-buf-name)) - (when temp-buf (kill-buffer temp-buf)) - (setq temp-buf (get-buffer-create temp-buf-name)) - (with-current-buffer temp-buf - (let ((mumamo-fetching-major t)) - (funcall major)) - (setq local-map (current-local-map)) - (when local-map (setq local-map (copy-keymap (current-local-map)))) - (add-to-list 'mumamo-major-modes-local-maps - (cons major-mode local-map))) - (kill-buffer temp-buf) - local-map)) - -(defvar mumamo-post-command-chunk nil) -(make-variable-buffer-local 'mumamo-post-command-chunk) - -(defun mumamo-post-command-get-chunk (pos) - "Get chunk at POS fast." - (let ((have-regions (and (boundp 'mumamo-regions) - mumamo-regions))) - (when have-regions (setq mumamo-post-command-chunk nil)) - (if (and mumamo-post-command-chunk - (overlayp mumamo-post-command-chunk) - ;;(progn (message "here a=%s" mumamo-post-command-chunk) t) - (overlay-buffer mumamo-post-command-chunk) - ;;(progn (message "here b=%s" mumamo-post-command-chunk) t) - (< pos (overlay-end mumamo-post-command-chunk)) - ;;(progn (message "here c=%s" mumamo-post-command-chunk) t) - (>= pos (overlay-start mumamo-post-command-chunk)) - ;;(progn (message "here d=%s" mumamo-post-command-chunk) t) - (mumamo-chunk-major-mode mumamo-post-command-chunk) - ;;(progn (msgtrc "here e=%s" mumamo-post-command-chunk) t) - ) - mumamo-post-command-chunk - ;;(msgtrc "--------------- new post-command-chunk") - (setq mumamo-post-command-chunk - (or (unless have-regions (mumamo-get-existing-new-chunk-at (point) nil)) - (mumamo-find-chunks (point) "post-command-get-chunk")))))) - -;; (setq mumamo-set-major-mode-delay 10) -(defun mumamo-set-major-post-command () - "Change major mode if necessary after a command. -If the major mode for chunk at `window-point' differ from current -major mode then change major mode to that for the chunk. If -however `mumamo-set-major-mode-delay' is greater than 0 just -request a change of major mode when Emacs is idle that long. - -See the variable above for an explanation why a delay might be -needed \(and is the default)." - ;;(msgtrc "set-major-post-command here") - (let* ((in-pre-hook (memq 'mumamo-set-major-pre-command pre-command-hook)) - (ovl (unless in-pre-hook (mumamo-post-command-get-chunk (point)))) - (major (when ovl (mumamo-chunk-major-mode ovl))) - (set-it-now (not (or in-pre-hook (mumamo-fun-eq major major-mode))))) - ;;(msgtrc "set-major-post-command ovl=%s, in-pre-hook=%s" ovl in-pre-hook) - (if (not set-it-now) - (unless (mumamo-fun-eq major major-mode) - (when mumamo-idle-set-major-mode-timer - (mumamo-request-idle-set-major-mode))) - (if mumamo-done-first-set-major - (if (<= 0 mumamo-set-major-mode-delay) - ;; Window point has been moved to a new chunk with a new - ;; major mode. Major mode will not be changed directly, - ;; but in an idle timer or in pre-command-hook. To avoid - ;; that the user get the wrong key bindings for the new - ;; chunk fetch the local map directly and apply that. - (let* ((map-rec (assoc major mumamo-major-modes-local-maps)) - (map (cdr map-rec))) - (unless map - (setq map (mumamo-fetch-local-map major))) - (unless (eq map 'no-local-map) - (use-local-map map)) - (add-hook 'pre-command-hook 'mumamo-set-major-pre-command nil t) - (mumamo-request-idle-set-major-mode)) - (mumamo-set-major major ovl) - (message "Switched to %s" major-mode)) - (mumamo-set-major major ovl))))) - -(defun mumamo-set-major-pre-command () - "Change major mode if necessary before a command. -When the key sequence that invoked the command is in current -local map and major mode is not the major mode for the current -mumamo chunk then set major mode to that for the chunk." - (mumamo-condition-case err - ;; First see if we can avoid changing major mode - (if (memq this-command mumamo-safe-commands-in-wrong-major) - (mumamo-request-idle-set-major-mode) - ;;(message "pre point=%s" (point)) - (let* ((ovl (mumamo-find-chunks (point) "mumamo-set-major-pre-command")) - (major (mumamo-chunk-major-mode ovl))) - ;;(message "pre point=%s" (point)) - (if (not major) - (lwarn '(mumamo-set-major-pre-command) :error "major=%s" major) - (when (or (not (mumamo-fun-eq major-mode major)) - (not (mumamo-set-major-check-keymap))) - (setq major-mode nil) - (mumamo-set-major major ovl) - ;; Unread the last command key sequence - (setq unread-command-events - (append (listify-key-sequence (this-command-keys-vector)) - unread-command-events)) - ;; Some commands, like `viper-command-argument' need to - ;; know the last command, so tell them. - (setq this-command (lambda () - (interactive) - (setq this-command last-command))))))) - (error - (mumamo-display-error 'mumamo-set-major-pre-command - "cb:%s, %s" (current-buffer) (error-message-string err))))) - -(defun mumamo-idle-set-major-mode (buffer window) - "Set major mode from mumamo chunk when Emacs is idle. -Do this only if current buffer is BUFFER and then do it in window -WINDOW. - -See the variable `mumamo-set-major-mode-delay' for an -explanation." - (save-match-data ;; runs in idle timer - (mumamo-msgfntfy "mumamo-idle-set-major-mode b=%s, window=%s" buffer window) - (with-selected-window window - ;; According to Stefan Monnier we need to set the buffer too. - (with-current-buffer (window-buffer window) - (when (eq buffer (current-buffer)) - (mumamo-condition-case err - ;;(let* ((ovl (mumamo-get-chunk-at (point))) - ;;(message "idle point=%s" (point)) - (let* ((ovl (mumamo-find-chunks (point) "mumamo-idle-set-major-mode")) - (major (mumamo-chunk-major-mode ovl)) - (modified (buffer-modified-p))) - ;;(message "idle point=%s" (point)) - (unless (mumamo-fun-eq major major-mode) - ;;(message "mumamo-set-major at A") - (mumamo-set-major major ovl) - ;; Fix-me: This is a bug workaround. Possibly in Emacs. - (when (and (buffer-modified-p) - (not modified)) - (set-buffer-modified-p nil)) - ;; sync keymap - (when (timerp mumamo-unread-command-events-timer) - (cancel-timer mumamo-unread-command-events-timer)) - (when unread-command-events - ;; Save unread keys before calling `top-level' which - ;; will clear them. - (setq mumamo-unread-command-events-timer - (run-with-idle-timer - 0 nil - 'mumamo-unread-command-events - unread-command-events - major last-command)) - (top-level) - ))) - (error - (mumamo-display-error 'mumamo-idle-set-major-mode - "cb=%s, err=%s" (current-buffer) err)))))))) - -(defun mumamo-post-command-1 (&optional no-debug) - "See `mumamo-post-command'. -Turn on `debug-on-error' unless NO-DEBUG is nil." - (unless no-debug (setq debug-on-error t)) - (setq mumamo-find-chunks-level 0) - (mumamo-msgfntfy "mumamo-post-command-1 ENTER: font-lock-mode=%s" font-lock-mode) - (if font-lock-mode - (mumamo-set-major-post-command) - ;;(mumamo-on-font-lock-off) - ) - ;;(msgtrc "mumamo-post-command-1 EXIT: font-lock-keywords-only =%s" (default-value 'font-lock-keywords-only)) - ) - - - - -(defvar mumamo-bug-3467-w14 41) -(defvar mumamo-bug-3467-w15 51) -;;(mumamo-check-has-bug3467 t) -;;(kill-local-variable 'mumamo-bug-3467-w14) -(defun mumamo-check-has-bug3467 (verbose) - (let ((has-bug nil)) - (with-temp-buffer - (let ((mumamo-bug-3467-w14 42) - (mumamo-bug-3467-w15 52)) - (when verbose (message "mumamo-bug-3467-w14 maybe let: in buffer %s=%S, global=%S" (current-buffer) mumamo-bug-3467-w14 (default-value 'mumamo-bug-3467-w14))) - (when verbose (message "mumamo-bug-3467-w15 maybe let: in buffer %s=%S, global=%S" (current-buffer) mumamo-bug-3467-w15 (default-value 'mumamo-bug-3467-w15))) - (set (make-local-variable 'mumamo-bug-3467-w14) 43) - (set-default 'mumamo-bug-3467-w14 44) - (set-default 'mumamo-bug-3467-w15 54) - (when verbose (message "mumamo-bug-3467-w14 maybe let: in buffer %s=%S, global=%S" (current-buffer) mumamo-bug-3467-w14 (default-value 'mumamo-bug-3467-w14))) - (when verbose (message "mumamo-bug-3467-w15 maybe let: in buffer %s=%S, global=%S" (current-buffer) mumamo-bug-3467-w15 (default-value 'mumamo-bug-3467-w15)))) - (when verbose (message "mumamo-bug-3467-w14 top level: in buffer %s=%S, global=%S" (current-buffer) mumamo-bug-3467-w14 (default-value 'mumamo-bug-3467-w14))) - (when (/= mumamo-bug-3467-w14 43) (setq has-bug t)) - (when (/= (default-value 'mumamo-bug-3467-w14) 41) (setq has-bug t)) - (when verbose (message "mumamo-bug-3467-w15 top level: in buffer %s=%S, global=%S" (current-buffer) mumamo-bug-3467-w15 (default-value 'mumamo-bug-3467-w15))) - ) - (when verbose (message "mumamo-bug-3467-w14 top level: in buffer %s=%S, global=%S" (current-buffer) mumamo-bug-3467-w14 (default-value 'mumamo-bug-3467-w14))) - (when verbose (message "mumamo-bug-3467-w15 top level: in buffer %s=%S, global=%S" (current-buffer) mumamo-bug-3467-w15 (default-value 'mumamo-bug-3467-w15))) - (or has-bug - (local-variable-p 'mumamo-bug-3467-w14) - (/= (default-value 'mumamo-bug-3467-w14) 41) - ) - )) - -(defvar mumamo-has-bug3467 (mumamo-check-has-bug3467 nil)) - -(defun mumamo-emacs-start-bug3467-timer-if-needed () - "Work around for Emacs bug 3467. The only one I have found." - (when mumamo-has-bug3467 - (run-with-idle-timer 0 nil 'mumamo-emacs-bug3467-workaround))) - -(defun mumamo-emacs-bug3467-workaround () - "Work around for Emacs bug 3467. The only one I have found." - (set-default 'font-lock-keywords-only nil)) - - - - -(defun mumamo-post-command () - "Run this in `post-command-hook'. -Change major mode if necessary." - ;;(msgtrc "mumamo-post-command") - (when mumamo-multi-major-mode - (mumamo-condition-case err - (mumamo-post-command-1 t) - (error - (mumamo-msgfntfy "mumamo-post-command %S" err) - ;; Warnings are to disturbing when run in post-command-hook, - ;; but this message is important so show it with an highlight. - (message - (propertize - "%s\n- Please try M-: (mumamo-post-command-1) to see what happened." - 'face 'highlight) - (error-message-string err)))))) - -(defun mumamo-change-major-function () - "Function added to `change-major-mode-hook'. -Remove mumamo when changing to a new major mode if the change is -not done because point was to a new chunk." - (unless mumamo-set-major-running - (mumamo-turn-off-actions))) - -(defun mumamo-derived-from-mode (major from-mode) - "Return t if major mode MAJOR is derived from FROM-MODE." - (let ((major-mode major)) - (derived-mode-p from-mode))) - -;; This is the new version of add-hook. For its origin see -;; http://lists.gnu.org/archive/html/emacs-devel/2007-12/msg00169.html -;; -;;(unless (> emacs-major-version 22) -(defvar mumamo-test-add-hook nil - "Internal use.") -(unless (and t - (let ((has-it nil)) - ;;(add-hook 'mumamo-test-add-hook 'mumamo-jit-lock-after-change nil t) - (add-hook 'mumamo-test-add-hook 'mumamo-after-change nil t) - (setq has-it (eq 'permanent-local-hook - (get 'mumamo-test-add-hook 'permanent-local))) - has-it)) - (defun add-hook (hook function &optional append local) - "Add to the value of HOOK the function FUNCTION. -FUNCTION is not added if already present. -FUNCTION is added (if necessary) at the beginning of the hook list -unless the optional argument APPEND is non-nil, in which case -FUNCTION is added at the end. - -The optional fourth argument, LOCAL, if non-nil, says to modify -the hook's buffer-local value rather than its default value. -This makes the hook buffer-local if needed, and it makes t a member -of the buffer-local value. That acts as a flag to run the hook -functions in the default value as well as in the local value. - -HOOK should be a symbol, and FUNCTION may be any valid function. If -HOOK is void, it is first set to nil. If HOOK's value is a single -function, it is changed to a list of functions." - (or (boundp hook) (set hook nil)) - (or (default-boundp hook) (set-default hook nil)) - (if local (unless (local-variable-if-set-p hook) - (set (make-local-variable hook) (list t))) - ;; Detect the case where make-local-variable was used on a hook - ;; and do what we used to do. - (unless (and (consp (symbol-value hook)) (memq t (symbol-value hook))) - (setq local t))) - (let ((hook-value (if local (symbol-value hook) (default-value hook)))) - ;; If the hook value is a single function, turn it into a list. - (when (or (not (listp hook-value)) (eq (car hook-value) 'lambda)) - (setq hook-value (list hook-value))) - ;; Do the actual addition if necessary - (unless (member function hook-value) - (setq hook-value - (if append - (append hook-value (list function)) - (cons function hook-value)))) - ;; Set the actual variable - (if local - (progn - ;; If HOOK isn't a permanent local, - ;; but FUNCTION wants to survive a change of modes, - ;; mark HOOK as partially permanent. - (and (symbolp function) - (get function 'permanent-local-hook) - (not (get hook 'permanent-local)) - (put hook 'permanent-local 'permanent-local-hook)) - (set hook hook-value)) - (set-default hook hook-value)))) - ) - - -(defvar mumamo-survive-hooks - '( - ;; activate-mark-hook after-change-functions after-save-hook - ;; before-save-functions auto-save-hook before-revert-hook - ;; buffer-access-fontify-functions calendar-load-hook - ;; command-line-functions compilation-finish-function - ;; deactivate-mark-hook find-file-hook - ;; find-file-not-found-functions first-change-hook - ;; kbd-macro-termination-hook kill-buffer-hook - ;; kill-buffer-query-functions menu-bar-update-hook - ;; post-command-hook pre-abbrev-expand-hook pre-command-hook - ;; write-contents-functions write-file-functions - ;; write-region-annotate-functions - ;; c-special-indent-hook - )) - -;; -;; Emulation modes -;; -;; These variables should have 'permanant-local t set in their -;; packages IMO, but now they do not have that. -(eval-after-load 'viper-cmd - (progn - (put 'viper-after-change-functions 'permanent-local t) - (put 'viper-before-change-functions 'permanent-local t) - )) -(eval-after-load 'viper - (progn - (put 'viper-post-command-hooks 'permanent-local t) - (put 'viper-pre-command-hooks 'permanent-local t) - ;;minor-mode-map-alist - ;; viper-mode-string -- is already buffer local, globally void - (put 'viper-mode-string 'permanent-local t) - )) -;;viper-tut--part -(eval-after-load 'viper-init - (progn - (put 'viper-d-com 'permanent-local t) - (put 'viper-last-insertion 'permanent-local t) - (put 'viper-command-ring 'permanent-local t) - (put 'viper-vi-intercept-minor-mode 'permanent-local t) - (put 'viper-vi-basic-minor-mode 'permanent-local t) - (put 'viper-vi-local-user-minor-mode 'permanent-local t) - (put 'viper-vi-global-user-minor-mode 'permanent-local t) - (put 'viper-vi-state-modifier-minor-mode 'permanent-local t) - (put 'viper-vi-diehard-minor-mode 'permanent-local t) - (put 'viper-vi-kbd-minor-mode 'permanent-local t) - (put 'viper-insert-intercept-minor-mode 'permanent-local t) - (put 'viper-insert-basic-minor-mode 'permanent-local t) - (put 'viper-insert-local-user-minor-mode 'permanent-local t) - (put 'viper-insert-global-user-minor-mode 'permanent-local t) - (put 'viper-insert-state-modifier-minor-mode 'permanent-local t) - (put 'viper-insert-diehard-minor-mode 'permanent-local t) - (put 'viper-insert-kbd-minor-mode 'permanent-local t) - (put 'viper-replace-minor-mode 'permanent-local t) - (put 'viper-emacs-intercept-minor-mode 'permanent-local t) - (put 'viper-emacs-local-user-minor-mode 'permanent-local t) - (put 'viper-emacs-global-user-minor-mode 'permanent-local t) - (put 'viper-emacs-kbd-minor-mode 'permanent-local t) - (put 'viper-emacs-state-modifier-minor-mode 'permanent-local t) - (put 'viper-vi-minibuffer-minor-mode 'permanent-local t) - (put 'viper-insert-minibuffer-minor-mode 'permanent-local t) - (put 'viper-automatic-iso-accents 'permanent-local t) - (put 'viper-special-input-method 'permanent-local t) - (put 'viper-intermediate-command 'permanent-local t) - ;; already local: viper-undo-needs-adjustment - (put 'viper-began-as-replace 'permanent-local t) - ;; already local: viper-replace-overlay - ;; already local: viper-last-posn-in-replace-region - ;; already local: viper-last-posn-while-in-insert-state - ;; already local: viper-sitting-in-replace - (put 'viper-replace-chars-to-delete 'permanent-local t) - (put 'viper-replace-region-chars-deleted 'permanent-local t) - (put 'viper-current-state 'permanent-local t) - (put 'viper-cted 'permanent-local t) - (put 'viper-current-indent 'permanent-local t) - (put 'viper-preserve-indent 'permanent-local t) - (put 'viper-auto-indent 'permanent-local t) - (put 'viper-electric-mode 'permanent-local t) - ;; already local: viper-insert-point - ;; already local: viper-pre-command-point - (put 'viper-com-point 'permanent-local t) - (put 'viper-ex-style-motion 'permanent-local t) - (put 'viper-ex-style-editing 'permanent-local t) - (put 'viper-ESC-moves-cursor-back 'permanent-local t) - (put 'viper-delete-backwards-in-replace 'permanent-local t) - ;; already local: viper-related-files-and-buffers-ring - (put 'viper-local-search-start-marker 'permanent-local t) - (put 'viper-search-overlay 'permanent-local t) - (put 'viper-last-jump 'permanent-local t) - (put 'viper-last-jump-ignore 'permanent-local t) - (put 'viper-minibuffer-current-face 'permanent-local t) - ;; already local: viper-minibuffer-overlay - (put 'viper-command-ring 'permanent-local t) - (put 'viper-last-insertion 'permanent-local t) - )) -(eval-after-load 'viper-keym - (progn - ;; already local: viper-vi-local-user-map - ;; already local: viper-insert-local-user-map - ;; already local: viper-emacs-local-user-map - (put 'viper--key-maps 'permanent-local t) - (put 'viper--intercept-key-maps 'permanent-local t) - ;; already local: viper-need-new-vi-local-map - ;; already local: viper-need-new-insert-local-map - ;; already local: viper-need-new-emacs-local-map - )) -(eval-after-load 'viper-mous - (progn - (put 'viper-mouse-click-search-noerror 'permanent-local t) - (put 'viper-mouse-click-search-limit 'permanent-local t) - )) -(eval-after-load 'viper-util - (progn - (put 'viper-syntax-preference 'permanent-local t) - (put 'viper-non-word-characters 'permanent-local t) - (put 'viper-ALPHA-char-class 'permanent-local t) - )) - -(eval-after-load 'cua-base - (progn - (put 'cua-inhibit-cua-keys 'permanent-local t) - (put 'cua--explicit-region-start 'permanent-local t) - (put 'cua--status-string 'permanent-local t) - )) -;; This is for the defvar in ido.el: -(eval-after-load 'ido - (progn - (put 'cua-inhibit-cua-keys 'permanent-local t) - )) -(eval-after-load 'cua-rect - (progn - (put 'cua--rectangle 'permanent-local t) - (put 'cua--rectangle-overlays 'permanent-local t) - )) -(eval-after-load 'edt - (progn - (put 'edt-select-mode 'permanent-local t) - )) -(eval-after-load 'tpu-edt - (progn - (put 'tpu-newline-and-indent-p 'permanent-local t) - (put 'tpu-newline-and-indent-string 'permanent-local t) - (put 'tpu-saved-delete-func 'permanent-local t) - (put 'tpu-buffer-local-map 'permanent-local t) - (put 'tpu-mark-flag 'permanent-local t) - )) -(eval-after-load 'vi - (progn - (put 'vi-add-to-mode-line 'permanent-local t) - ;;Warning (mumamo-per-buffer-local-vars): Not a local variable: vi-scroll-amount - ;;Warning (mumamo-per-buffer-local-vars): Not a local variable: vi-shift-width - ;;Warning (mumamo-per-buffer-local-vars): Not a local variable: vi-ins-point - ;;Warning (mumamo-per-buffer-local-vars): Not a local variable: vi-ins-length - ;;Warning (mumamo-per-buffer-local-vars): Not a local variable: vi-ins-repetition - ;;Warning (mumamo-per-buffer-local-vars): Not a local variable: vi-ins-overwrt-p - ;;Warning (mumamo-per-buffer-local-vars): Not a local variable: vi-ins-prefix-code - ;;Warning (mumamo-per-buffer-local-vars): Not a local variable: vi-last-change-command - ;;Warning (mumamo-per-buffer-local-vars): Not a local variable: vi-last-shell-command - ;;Warning (mumamo-per-buffer-local-vars): Not a local variable: vi-last-find-char - ;;Warning (mumamo-per-buffer-local-vars): Not a local variable: vi-mark-alist - ;;Warning (mumamo-per-buffer-local-vars): Not a local variable: vi-insert-state - ;;Warning (mumamo-per-buffer-local-vars): Not a local variable: vi-mode-old-local-map - ;;Warning (mumamo-per-buffer-local-vars): Not a local variable: vi-mode-old-mode-name - ;;Warning (mumamo-per-buffer-local-vars): Not a local variable: vi-mode-old-major-mode - ;;Warning (mumamo-per-buffer-local-vars): Not a local variable: vi-mode-old-case-fold - ;; - )) -(eval-after-load 'vi - (progn - (put 'vip-emacs-local-map 'permanent-local t) - (put 'vip-insert-local-map 'permanent-local t) - (put 'vip-insert-point 'permanent-local t) - (put 'vip-com-point 'permanent-local t) - (put 'vip-current-mode 'permanent-local t) - (put 'vip-emacs-mode-line-buffer-identification 'permanent-local t) - (put 'vip-current-major-mode 'permanent-local t) - )) - -(eval-after-load 'hi-lock - (progn - (put 'hi-lock-mode 'permanent-local t) - )) - -;; -;; Minor modes that are not major mode specific -;; - -(put 'visual-line-mode 'permanent-local t) - -(eval-after-load 'flymake - (progn - ;; hook functions: - (put 'flymake-after-change-function 'permanent-local-hook t) - (put 'flymake-after-save-hook 'permanent-local-hook t) - (put 'flymake-kill-buffer-hook 'permanent-local-hook t) - ;; hooks: -;;; (put 'after-change-functions 'permanent-local 'permanent-local-hook) -;;; (put 'after-save-hook 'permanent-local 'permanent-local-hook) -;;; (put 'kill-buffer-hook 'permanent-local 'permanent-local-hook) - ;; vars: - (put 'flymake-mode 'permanent-local t) - (put 'flymake-is-running 'permanent-local t) - (put 'flymake-timer 'permanent-local t) - (put 'flymake-last-change-time 'permanent-local t) - (put 'flymake-check-start-time 'permanent-local t) - (put 'flymake-check-was-interrupted 'permanent-local t) - (put 'flymake-err-info 'permanent-local t) - (put 'flymake-new-err-info 'permanent-local t) - (put 'flymake-output-residual 'permanent-local t) - (put 'flymake-mode-line 'permanent-local t) - (put 'flymake-mode-line-e-w 'permanent-local t) - (put 'flymake-mode-line-status 'permanent-local t) - (put 'flymake-temp-source-file-name 'permanent-local t) - (put 'flymake-master-file-name 'permanent-local t) - (put 'flymake-temp-master-file-name 'permanent-local t) - (put 'flymake-base-dir 'permanent-local t))) - -;; (eval-after-load 'imenu -;; (progn -;; ;; Fix-me: imenu is only useful for main major mode. The menu -;; ;; disappears in sub chunks because it is tighed to -;; ;; local-map. Don't know what to do about that. I do not -;; ;; understand the reason for binding it to local-map, but I -;; ;; suspect the intent is to have different menu items for -;; ;; different modes. Could not that be achieved by deleting the -;; ;; menu and creating it again when changing major mode? (That must -;; ;; be implemented in imenu.el of course.) -;; ;; -;; ;; hook functions: -;; ;;; (put 'imenu-update-menubar 'permanent-local-hook t) -;; ;; hooks: -;; (put 'menu-bar-update-hook 'permanent-local 'permanent-local-hook) -;; ;; vars: -;; (put 'imenu-generic-expression 'permanent-local t) -;; (put 'imenu-create-index-function 'permanent-local t) -;; (put 'imenu-prev-index-position-function 'permanent-local t) -;; (put 'imenu-extract-index-name-function 'permanent-local t) -;; (put 'imenu-name-lookup-function 'permanent-local t) -;; (put 'imenu-default-goto-function 'permanent-local t) -;; (put 'imenu--index-alist 'permanent-local t) -;; (put 'imenu--last-menubar-index-alist 'permanent-local t) -;; (put 'imenu-syntax-alist 'permanent-local t) -;; (put 'imenu-case-fold-search 'permanent-local t) -;; (put 'imenu-menubar-modified-tick 'permanent-local t) -;; )) - -(eval-after-load 'longlines - (progn - ;; Fix-me: take care of longlines-mode-off - (put 'longlines-mode 'permanent-local t) - (put 'longlines-wrap-beg 'permanent-local t) - (put 'longlines-wrap-end 'permanent-local t) - (put 'longlines-wrap-point 'permanent-local t) - (put 'longlines-showing 'permanent-local t) - (put 'longlines-decoded 'permanent-local t) - ;; - (put 'longlines-after-change-function 'permanent-local-hook t) - (put 'longlines-after-revert-hook 'permanent-local-hook t) - (put 'longlines-before-revert-hook 'permanent-local-hook t) - (put 'longlines-decode-buffer 'permanent-local-hook t) - (put 'longlines-decode-region 'permanent-local-hook t) - (put 'longlines-mode-off 'permanent-local-hook t) - (put 'longlines-post-command-function 'permanent-local-hook t) - (put 'longlines-window-change-function 'permanent-local-hook t) - ;;(put 'mail-indent-citation 'permanent-local-hook t) - )) - - -;; Fix-me: Rails, many problematic things: - -;;; Fix-me: No idea about these, where are they used?? Add them to -;;; mumamo-per-buffer-local-vars?: -;; predictive-main-dict -;; predictive-prog-mode-main-dict -;; predictive-use-auto-learn-cache -;; predictive-dict-autosave-on-kill-buffer -(eval-after-load 'inf-ruby - (progn - (put 'inferior-ruby-first-prompt-pattern 'permanent-local t) - (put 'inferior-ruby-prompt-pattern 'permanent-local t) - )) - -;;; These are for the output buffer (no problems): -;; font-lock-keywords-only -;; font-lock-defaults -- always buffer local -;; scroll-margin -;; scroll-preserve-screen-position - -(eval-after-load 'rails-script - (progn - (put 'rails-script:run-after-stop-hook 'permanent-local t) - (put 'rails-script:show-buffer-hook 'permanent-local t) - (put 'rails-script:output-mode-ret-value 'permanent-local t) - )) - -;;; No problems I believe (it is in output buffer): -;; compilation-error-regexp-alist-alist -;; compilation-error-regexp-alist - -;;; Fix-me: This is in the minor mode, what to do? Looks like it -;;; should have 'permanent-local t - in this case. I have added it to -;;; mumamo-per-buffer-local-vars for now. -;; tags-file-name - -(eval-after-load 'rails - (progn - (put 'rails-primary-switch-func 'permanent-local t) - (put 'rails-secondary-switch-func 'permanent-local t) - )) - -;; (defun test-js-perm () -;; (put 'js--quick-match-re 'permanent-local t) -;; (put 'js--quick-match-re-func 'permanent-local t) -;; (put 'js--cache-end 'permanent-local t) -;; (put 'js--last-parse-pos 'permanent-local t) -;; (put 'js--state-at-last-parse-pos 'permanent-local t) -;; (put 'js--tmp-location 'permanent-local t)) -;; (test-js-perm) - -(defvar mumamo-per-buffer-local-vars - '( - buffer-file-name - left-margin-width - right-margin-width - ;; Fix-me: This is to prevent font-lock-mode turning off/on, but - ;; is it necessary? - ;;font-lock-mode-major-mode - tags-file-name - nxhtml-menu-mode - ;; Fix-me: adding rng timers here stops Emacs from looping after - ;; indenting in ind-0-error.php, but I have no clue why. Hm. This - ;; problem is gone, but I forgot why. - rng-c-current-token ;;rng-cmpct.el:132:(make-variable-buffer-local 'rng-c-current-token) - rng-c-escape-positions ;;rng-cmpct.el:341:(make-variable-buffer-local 'rng-c-escape-positions) - rng-c-file-name ;;rng-cmpct.el:344:(make-variable-buffer-local 'rng-c-file-name) - rng-current-schema-file-name ;;rng-loc.el:37:(make-variable-buffer-local 'rng-current-schema-file-name) - rng-current-schema ;;rng-pttrn.el:71:(make-variable-buffer-local 'rng-current-schema) - ;;rng-validate-timer is permanent-local t - ;;rng-validate-timer ;;rng-valid.el:141:(make-variable-buffer-local 'rng-validate-timer) - ;;rng-validate-quick-timer is permanent-local t - ;;rng-validate-quick-timer ;;rng-valid.el:146:(make-variable-buffer-local 'rng-validate-quick-timer) - rng-error-count ;;rng-valid.el:153:(make-variable-buffer-local 'rng-error-count) - rng-message-overlay ;;rng-valid.el:158:(make-variable-buffer-local 'rng-message-overlay) - rng-message-overlay-inhibit-point ;;rng-valid.el:165:(make-variable-buffer-local 'rng-message-overlay-inhibit-point) - rng-message-overlay-current ;;rng-valid.el:169:(make-variable-buffer-local 'rng-message-overlay-current) - rng-validate-up-to-date-end ;;rng-valid.el:188:(make-variable-buffer-local 'rng-validate-up-to-date-end) - rng-conditional-up-to-date-start ;;rng-valid.el:199:(make-variable-buffer-local 'rng-conditional-up-to-date-start) - rng-conditional-up-to-date-end ;;rng-valid.el:205:(make-variable-buffer-local 'rng-conditional-up-to-date-end) - rng-validate-mode ;;rng-valid.el:212:(make-variable-buffer-local 'rng-validate-mode) - rng-dtd ;;rng-valid.el:215:(make-variable-buffer-local 'rng-dtd) - - nxml-syntax-highlight-flag ;; For pre-Emacs nxml - ;;nxml-ns-state - not buffer local currently - nxml-prolog-regions ;;snxml-mode.el:362:(make-variable-buffer-local 'nxml-prolog-regions) - nxml-last-fontify-end ;;dnxml-mode.el:367:(make-variable-buffer-local 'nxml-last-fontify-end) - nxml-degraded ;;dnxml-mode.el:373:(make-variable-buffer-local 'nxml-degraded) - nxml-char-ref-extra-display ;;ynxml-mode.el:397:(make-variable-buffer-local 'nxml-char-ref-extra-display) - nxml-prolog-end ;;dnxml-rap.el:92:(make-variable-buffer-local 'nxml-prolog-end) - nxml-scan-end ;;dnxml-rap.el:107:(make-variable-buffer-local 'nxml-scan-end) - - ;;buffer-invisibility-spec - ;;header-line-format - - ;; Fix-me: These must be handled with 'permanent-local since they may be changed: - line-move-visual ;;simple.el:4537: (kill-local-variable 'line-move-visual) - word-wrap ;;simple.el:4538: (kill-local-variable 'word-wrap) - truncate-lines ;;simple.el:4539: (kill-local-variable 'truncate-lines) - truncate-partial-width-windows ;;simple.el:4540: (kill-local-variable 'truncate-partial-width-windows) - fringe-indicator-alist ;;simple.el:4541: (kill-local-variable 'fringe-indicator-alist) - visual-line--saved-state ;;simple.el:4544: (kill-local-variable 'visual-line--saved-state))) - vis-mode-saved-buffer-invisibility-spec ;;simple.el:6237: (kill-local-variable 'vis-mode-saved-buffer-invisibility-spec)) - - ) - "Per buffer local variables. -See also `mumamo-per-main-major-local-vars'.") - -;; Fix-me: use this, but how exactly? I think the var values must be -;; picked up at every change from main major mode. And restored after -;; changing to the new major mode - but maybe a bit differently if -;; this is the main major mode. -(defvar mumamo-per-main-major-local-vars - '( - buffer-invisibility-spec - header-line-format - ) - "Per main major local variables. -Like `mumamo-per-buffer-local-vars', but this is fetched from the -main major mode.") - -;; (when nil -;; (make-variable-buffer-local 'mumamo-survive-minor-modes) -;; (put 'mumamo-survive-minor-modes 'permanent-local t) -;; (defvar mumamo-survive-minor-modes nil -;; "Hold local minor mode variables specific major modes. -;; Those values are saved when leaving a chunk with a certain -;; major mode and restored when entering a chunk with the same -;; major mode again. - -;; The value of this variable is an associative list where the key -;; is a list with - -;; \(MAJOR-MODE MINOR-MODE) - -;; and the value is a stored value for the minor mode.") -;; ) - -(defun mumamo-make-variable-buffer-permanent (var) - "Make buffer local value of VAR survive when moving point to a new chunk. -When point is moved between chunks in a multi major mode the -major mode will be changed. This will by default kill all local -variables unless they have a non-nil `permanent-local' property -\(see info node `(elisp)Creating Buffer-Local'). - -If you do not want to put a `permanent-local' property on a -variable you can instead use this function to make variable VAR -survive chunk switches in all mumamo multi major mode buffers." - ;; If you want it to survive chunk switches only in the current - ;; buffer then use `mumamo-make-local-permanent' instead." - (pushnew var (default-value 'mumamo-per-buffer-local-vars))) - -;; ;; Fix-me: use local value -;; ;; Fix-me: delelete local value when exiting mumamo -;; (defun mumamo-make-local-permanent (var) -;; "Make buffer local value of VAR survive when moving point to a new chunk. -;; This is for the current buffer only. -;; In most cases you almost certainly want to use -;; `mumamo-make-variable-buffer-permanent' instead." -;; (pushnew var mumamo-per-buffer-local-vars)) - -(defvar mumamo-per-buffer-local-vars-done-by-me nil - "Variables set by mumamo already. -Used to avoid unnecessary warnings if setting major mode fails.") - -;; (mumamo-hook-p 'viper-pre-command-hooks) -;; (mumamo-hook-p 'viper-before-change-functions) -;; (mumamo-hook-p 'c-special-indent-hook) -(defun mumamo-hook-p (sym) - "Try to detect if SYM is a hook variable. -Just check the name." - (let ((name (symbol-name sym))) - (or (string= "-hook" (substring name -5)) - (string= "-hooks" (substring name -6)) - (string= "-functions" (substring name -10))))) - -(defvar mumamo-major-mode nil) -(make-variable-buffer-local 'mumamo-major-mode) -(put 'mumamo-major-mode 'permanent-local t) - -(defvar mumamo-change-major-mode-no-nos - '((font-lock-change-mode t) - (longlines-mode-off t) - global-font-lock-mode-cmhh - (nxml-cleanup t) - (turn-off-hideshow t)) - "Avoid running these in `change-major-mode-hook'.") - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Remove things from hooks temporarily - -;; Fix-me: This is a bit disorganized, could not decide which level I -;; wanted this on. - -(defvar mumamo-after-change-major-mode-no-nos - '(;;nxhtml-global-minor-mode-enable-in-buffers - global-font-lock-mode-enable-in-buffers) - "Avoid running these in `after-change-major-mode-hook'.") - -(defvar mumamo-removed-from-hook nil) - -(defun mumamo-remove-from-hook (hook remove) - "From hook HOOK remove functions in list REMOVE. -Save HOOK and the list of functions removed to -`mumamo-removed-from-hook'." - (let (did-remove - removed) - (dolist (rem remove) - ;;(message "rem.rem=%s" rem) - (setq did-remove nil) - (if (listp rem) - (when (memq (car rem) (symbol-value hook)) - (setq did-remove t) - (remove-hook hook (car rem) t)) - (when (memq rem (symbol-value hook)) - (setq did-remove t) - (remove-hook hook rem))) - (when did-remove - (setq removed (cons rem removed)))) - (setq mumamo-removed-from-hook - (cons (cons hook removed) - mumamo-removed-from-hook)))) - -(defun mumamo-addback-to-hooks () - "Add back what was removed by `mumamo-remove-from-hook'." - ;;(message "mumamo-removed-from-hook=%s" mumamo-removed-from-hook) - (dolist (rem-rec mumamo-removed-from-hook) - (mumamo-addback-to-hook (car rem-rec) (cdr rem-rec)))) - -(defun mumamo-addback-to-hook (hook removed) - "Add to hook HOOK the list of functions in REMOVED." - ;;(message "addback: hook=%s, removed=%s" hook removed) - (dolist (rem removed) - ;;(message "add.rem=%s" rem) - (if (listp rem) - (add-hook hook (car rem) nil t) - (add-hook hook rem)))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Compare mumamo-irrelevant-buffer-local-vars -(defvar mumamo-buffer-locals-dont-set - '( - adaptive-fill-mode - adaptive-fill-first-line-regexp - adaptive-fill-regexp - add-log-current-defun-header-regexp - auto-composition-function - auto-composition-mode - auto-composition-mode-major-mode - auto-fill-chars - - beginning-of-defun-function - buffer-auto-save-file-format - buffer-auto-save-file-name - buffer-backed-up - buffer-display-count - buffer-display-time - buffer-file-coding-system - buffer-file-format - buffer-file-name - buffer-file-truename - buffer-invisibility-spec - buffer-read-only - buffer-saved-size - buffer-undo-list - - c++-template-syntax-table - c-<-op-cont-regexp - c-<>-multichar-token-regexp - c->-op-cont-regexp - c-after-suffixed-type-decl-key - c-after-suffixed-type-maybe-decl-key - c-anchored-cpp-prefix - c-assignment-op-regexp - c-at-vsemi-p-fn - c-backslash-column - c-backslash-max-column - ;;c-basic-offset - c-before-font-lock-function - c-block-comment-prefix - c-block-comment-start-regexp - c-block-prefix-charset - c-block-stmt-1-key - c-block-stmt-2-key - c-brace-list-key - c-cast-parens - c-class-key - c-cleanup-list - c-colon-type-list-re - c-comment-only-line-offset - c-comment-prefix-regexp - c-comment-start-regexp - c-current-comment-prefix - c-decl-block-key - c-decl-hangon-key - c-decl-prefix-or-start-re - c-decl-prefix-re - c-decl-start-re - c-doc-comment-start-regexp - c-doc-comment-style - c-found-types - c-get-state-before-change-function - c-hanging-braces-alist - c-hanging-colons-alist - c-hanging-semi&comma-criteria - c-identifier-key - c-identifier-start - c-identifier-syntax-modifications - c-identifier-syntax-table - ;;c-indent-comment-alist - ;;c-indent-comments-syntactically-p - ;;c-indentation-style - c-keywords-obarray - c-keywords-regexp - c-known-type-key - c-label-kwds-regexp - c-label-minimum-indentation - c-label-prefix-re - c-line-comment-starter - c-literal-start-regexp - c-multiline-string-start-char - c-nonlabel-token-key - c-nonsymbol-chars - c-nonsymbol-token-regexp - c-not-decl-init-keywords - ;;c-offsets-alist - c-old-BOM - c-old-EOM - c-opt-<>-arglist-start - c-opt-<>-arglist-start-in-paren - c-opt-<>-sexp-key - c-opt-asm-stmt-key - c-opt-bitfield-key - c-opt-block-decls-with-vars-key - c-opt-block-stmt-key - c-opt-cpp-macro-define-id - c-opt-cpp-macro-define-start - c-opt-cpp-prefix - c-opt-cpp-start - c-opt-extra-label-key - c-opt-friend-key - c-opt-identifier-concat-key - c-opt-inexpr-brace-list-key - c-opt-method-key - c-opt-op-identifier-prefix - c-opt-postfix-decl-spec-key - c-opt-type-component-key - c-opt-type-concat-key - c-opt-type-modifier-key - c-opt-type-suffix-key - c-other-decl-block-key - c-other-decl-block-key-in-symbols-alist - c-overloadable-operators-regexp - c-paragraph-separate - c-paragraph-start - c-paren-stmt-key - c-prefix-spec-kwds-re - c-primary-expr-regexp - c-primitive-type-key - c-recognize-<>-arglists - c-recognize-colon-labels - c-recognize-knr-p - c-recognize-paren-inexpr-blocks - c-recognize-paren-inits - c-recognize-typeless-decls - c-regular-keywords-regexp - c-simple-stmt-key - c-special-brace-lists - c-special-indent-hook - c-specifier-key - c-stmt-delim-chars - c-stmt-delim-chars-with-comma - c-string-escaped-newlines - c-symbol-key - c-symbol-start - c-syntactic-eol - c-syntactic-ws-end - c-syntactic-ws-start - c-type-decl-end-used - c-type-decl-prefix-key - c-type-decl-suffix-key - c-type-prefix-key - c-vsemi-status-unknown-p-fn - - case-fold-search - comment-end - comment-end-skip - comment-indent-function - comment-line-break-function - comment-multi-line - comment-start - comment-start-skip - cursor-type - - default-directory - defun-prompt-regexp - delay-mode-hooks - - enable-multibyte-characters - end-of-defun-function - - fill-paragraph-function - font-lock-beginning-of-syntax-function - font-lock-defaults - font-lock-extend-after-change-region-function - font-lock-extend-region-functions - font-lock-fontified - font-lock-fontify-buffer-function - font-lock-fontify-region-function - font-lock-keywords - ;;font-lock-keywords-only - font-lock-keywords-case-fold-search - font-lock-mode - font-lock-mode-hook - font-lock-mode-major-mode - font-lock-multiline - font-lock-set-defaults - font-lock-syntactic-keywords - font-lock-syntactically-fontified - font-lock-syntax-table - font-lock-unfontify-buffer-function - font-lock-unfontify-region-function - fontification-functions - forward-sexp-function - - indent-line-function - indent-region-function - imenu--index-alist - imenu--last-menubar-index-alist - imenu-create-index-function - imenu-menubar-modified-tick - isearch-mode - - jit-lock-after-change-extend-region-functions - jit-lock-context-unfontify-pos - jit-lock-contextually - jit-lock-functions - jit-lock-mode - - line-move-ignore-invisible - local-abbrev-table - - major-mode - mark-active - ;;mark-ring - mode-line-process - mode-name - - normal-auto-fill-function - ;;nxhtml-menu-mode-major-mode - - open-paren-in-column-0-is-defun-start - outline-level - outline-regexp - - paragraph-ignore-fill-prefix - paragraph-separate - paragraph-start - parse-sexp-ignore-comments - parse-sexp-lookup-properties - php-mode-pear-hook - point-before-scroll - - ;; More symbols from visual inspection - ;;before-change-functions - ;;delayed-mode-hooks - ;;imenu-case-fold-search - ;;imenu-generic-expression - rngalt-completing-read-tag - rngalt-completing-read-attribute-name - rngalt-completing-read-attribute-value - rngalt-complete-first-try - rngalt-complete-last-try - rngalt-complete-tag-hooks - - syntax-begin-function - ) - "Buffer local variables that is not saved/set per chunk. -This is supposed to contain mostly buffer local variables -specific to major modes and that are not meant to be customized -by the user. -") - -(when (< emacs-major-version 23) - (defadvice c-after-change (around - mumamo-ad-c-after-change - activate - compile - ) - ;;(msgtrc "c-after-change: major-mode=%s c-nonsymbol-token-regexp=%s" major-mode c-nonsymbol-token-regexp) - (when (or (not mumamo-multi-major-mode) - (derived-mode-p 'c-mode)) - ad-do-it)) - ) - -(defun mumamo-save-per-major-local-vars (major) - "Save some per major local variables for major mode MAJOR. -This should be called before switching to a new chunks major -mode." - ;;(message "mumamo-save-per-major-local-vars %s %s" major (current-buffer)) - (let ((locals (buffer-local-variables))) - (setq locals (mapcar (lambda (local) - (unless - (or (memq (car local) mumamo-buffer-locals-dont-set) - (memq (car local) mumamo-per-buffer-local-vars) - (memq (car local) mumamo-per-main-major-local-vars) - (get (car local) 'permanent-local)) - local)) - locals)) - (setq locals (delq nil locals)) - (setq locals (sort locals (lambda (sym-a sym-b) - (string< (symbol-name (car sym-a)) - (symbol-name (car sym-b)))))) - (setq mumamo-buffer-locals-per-major - (assq-delete-all major mumamo-buffer-locals-per-major)) - (setq mumamo-buffer-locals-per-major - (cons (cons major-mode locals) - mumamo-buffer-locals-per-major)))) - -;; (benchmark 1000 '(mumamo-save-per-major-local-vars major-mode)) -;; (benchmark 1000 '(mumamo-restore-per-major-local-vars major-mode)) -(defvar mumamo-restore-per-major-local-vars-in-hook-major nil) -(defun mumamo-restore-per-major-local-vars-in-hook () - "Restore some per major mode local variables. -Call `mumamo-restore-per-major-local-vars'. -Use `mumamo-restore-per-major-local-vars-in-hook-major' as the -major mode. - -This should be called in the major mode setup hook." - (mumamo-restore-per-major-local-vars - mumamo-restore-per-major-local-vars-in-hook-major) - (setq mumamo-restore-per-major-local-vars-in-hook-major nil)) -(put 'mumamo-restore-per-major-local-vars-in-hook 'permanent-local-hook t) - -(defun mumamo-restore-per-major-local-vars (major) - "Restore some per major local variables for major mode MAJOR. -This should be called after switching to a new chunks major -mode." - (let ((locals (cdr (assq major mumamo-buffer-locals-per-major))) - var - perm) - (dolist (rec locals) - (setq var (car rec)) - (setq perm (get var 'permanent-local)) - (unless (or perm - (memq var mumamo-buffer-locals-dont-set)) - (set (make-local-variable var) (cdr rec)))))) - -;; (defun mumamo-testing-new () -;; (let ((locals (buffer-local-variables)) -;; var -;; perm -;; ) -;; (dolist (rec locals) -;; (setq var (car rec)) -;; (setq perm (get var 'permanent-local)) -;; (unless (or perm -;; (memq var mumamo-buffer-locals-dont-set)) -;; (setq var (cdr rec)))) -;; )) -;; ;;(benchmark 1000 '(mumamo-testing-new)) - -(defun mumamo-get-hook-value (hook remove) - "Return hook HOOK value with entries in REMOVE removed. -Remove also t. The value returned is a list of both local and -default values." - (let ((value (append (symbol-value hook) (default-value hook) nil))) - (dolist (rem remove) - (setq value (delq rem value))) - (delq t value))) - -;; FIX-ME: Clean up the different ways of surviving variables during -;; change of major mode. -(defvar mumamo-set-major-keymap-checked nil) -(make-variable-buffer-local 'mumamo-set-major-keymap-checked) - -(defvar mumamo-org-startup-done nil) -(make-variable-buffer-local 'mumamo-org-startup-done) -(put 'mumamo-org-startup-done 'permanent-local t) - - -(defun mumamo-font-lock-fontify-chunk () - "Like `font-lock-default-fontify-buffer' but for a chunk. -Buffer must be narrowed to inner part of chunk when this function -is called." - (let ((verbose (if (numberp font-lock-verbose) - (and (> font-lock-verbose 0) - (> (- (point-max) (point-min)) font-lock-verbose)) - font-lock-verbose)) - font-lock-extend-region-functions ;; accept narrowing - (font-lock-unfontify-region-function 'ignore)) - ;;(setq verbose t) - (with-temp-message - (when verbose - (format "Fontifying %s part %s-%s (%s)..." (buffer-name) (point-min) (point-max) font-lock-verbose)) - (condition-case err - (save-excursion - (save-match-data - (font-lock-fontify-region (point-min) (point-max) verbose) - (font-lock-after-fontify-buffer) - (setq font-lock-fontified t))) - (msgtrc "font-lock-fontify-chunk: %s" (error-message-string err)) - ;; We don't restore the old fontification, so it's best to unfontify. - (quit (mumamo-font-lock-unfontify-chunk)))))) - - -(defun mumamo-font-lock-unfontify-chunk () - "Like `font-lock-default-unfontify-buffer' for . -Buffer must be narrowed to chunk when this function is called." - ;; Make sure we unfontify etc. in the whole buffer. - (save-restriction - ;;(widen) - (font-lock-unfontify-region (point-min) (point-max)) - (font-lock-after-unfontify-buffer) - (setq font-lock-fontified nil))) - -(defun mumamo-set-major (major chunk) - "Set major mode to MAJOR for mumamo." - (mumamo-msgfntfy "mumamo-set-major %s, %s" major (current-buffer)) - (mumamo-cancel-idle-set-major-mode) - (remove-hook 'pre-command-hook 'mumamo-set-major-pre-command t) - ;;(mumamo-backtrace "mumamo-set-major") - (remove-hook 'text-mode-hook 'viper-mode) ;; Fix-me: maybe add it back... - (let ((start-time (get-internal-run-time)) - end-time - used-time - ;; Viper - viper-vi-state-mode-list - viper-emacs-state-mode-list - viper-insert-state-mode-list - ;; Org-Mode - (org-inhibit-startup mumamo-org-startup-done) - ;; Tell `mumamo-change-major-function': - (mumamo-set-major-running major) - ;; Fix-me: Take care of the new values added to these hooks! - ;; That looks difficult. We may after this have changes to - ;; both buffer local value and global value. The global - ;; changes are in this variable, but the buffer local values - ;; have been set once again. - (change-major-mode-hook (mumamo-get-hook-value - 'change-major-mode-hook - mumamo-change-major-mode-no-nos)) - (after-change-major-mode-hook (mumamo-get-hook-value - 'after-change-major-mode-hook - mumamo-after-change-major-mode-no-nos)) - ;; Some major modes deactivates the mark, we do not want that: - deactivate-mark - ;; Font lock - (font-lock-mode font-lock-mode) - ;; We have to save and reset the cursor type, at least when - ;; Viper is used - (old-cursor-type cursor-type) - ;; Protect last-command: fix-me: probably remove - (last-command last-command) - ;; Fix-me: remove this - (old-rng-schema-file (when (boundp 'rng-current-schema-file-name) rng-current-schema-file-name)) - ;; Local vars, per buffer and per major mode - per-buffer-local-vars-state - per-main-major-local-vars-state - ) - ;; We are not changing mode from font-lock's point of view, so do - ;; not tell font-lock (let binding these hooks is probably not a - ;; good choice since they may contain other stuff too): - (setq mumamo-removed-from-hook nil) - (mumamo-remove-from-hook 'change-major-mode-hook mumamo-change-major-mode-no-nos) - - ;;;;;;;;;;;;;;;; - ;; Save per buffer local variables - (dolist (sym (reverse mumamo-per-buffer-local-vars)) - (when (boundp sym) - (when (and (get sym 'permanent-local) - (not (memq sym mumamo-per-buffer-local-vars-done-by-me)) - (not (mumamo-hook-p sym))) - (delq sym mumamo-per-buffer-local-vars) - (lwarn 'mumamo-per-buffer-local-vars :warning - "Already 'permanent-local t: %s" sym)))) - (dolist (var mumamo-per-buffer-local-vars) - (if (local-variable-p var) - (push (cons var (symbol-value var)) - per-buffer-local-vars-state))) - - ;;;;;;;;;;;;;;;; - ;; Save per main major local variables - (when (mumamo-fun-eq major-mode (mumamo-main-major-mode)) - (dolist (var mumamo-per-main-major-local-vars) - (if (local-variable-p var) - (push (cons var (symbol-value var)) - per-main-major-local-vars-state)))) - - ;; For all hooks that probably can have buffer local values, go - ;; through the buffer local values and look for a permanent-local - ;; property on each function. Remove those functions that does not - ;; have it. Then make the buffer local value of the hook survive - ;; by putting a permanent-local property on it. - (unless (> emacs-major-version 22) - (dolist (hk mumamo-survive-hooks) - (put hk 'permanent-local t) - (when (local-variable-p hk) - (let ((hkv (copy-sequence (symbol-value hk)))) - (dolist (v hkv) - (unless (or (eq v t) - (get v 'permanent-local-hook)) - (remove-hook hk v t) - )))))) - - (run-hooks 'mumamo-change-major-mode-hook) - - (setq mumamo-major-mode major) - - ;;;;;;;;;;;;;;;; - ;; Save per major mode local variables before switching major - (mumamo-save-per-major-local-vars major-mode) - ;; Prepare to restore per major mode local variables after - ;; switching back to major-mode, but do it in the greatest - ;; ancestor's mode hook (see `run-mode-hooks'): - (let (ancestor-hook-sym - parent-hook-sym - (parent major)) - ;; We want the greatest ancestor's mode hook: - (setq parent-hook-sym (intern-soft (concat (symbol-name parent) "-hook"))) - (when parent-hook-sym (setq ancestor-hook-sym parent-hook-sym)) - (while (get parent 'derived-mode-parent) - (setq parent (get parent 'derived-mode-parent)) - (setq parent-hook-sym (intern-soft (concat (symbol-name parent) "-hook"))) - (when parent-hook-sym (setq ancestor-hook-sym parent-hook-sym))) - (when ancestor-hook-sym - ;; Put first in local hook to run it first: - (setq mumamo-restore-per-major-local-vars-in-hook-major major) - (add-hook ancestor-hook-sym - 'mumamo-restore-per-major-local-vars-in-hook - nil t)) - - ;;(msgtrc "set-major A: buffer-invisibility-spec=%S" buffer-invisibility-spec) - ;;(msgtrc "set-major A: word-wrap=%S, cb=%s" word-wrap (current-buffer)) - ;;(mumamo-backtrace "set-major") - (let ((here (point))) - (unwind-protect - (save-restriction - (let* ((minmax (mumamo-chunk-syntax-min-max chunk t)) - (min (car minmax)) - (max (cdr minmax)) - (here (point)) - ;; Fix-me: For some reason let binding did not help. Is this a bug or? - ;; - ;;(font-lock-fontify-buffer-function 'mumamo-font-lock-fontify-chunk) - (old-bf (buffer-local-value 'font-lock-fontify-buffer-function (current-buffer))) - (inhibit-redisplay t) ;; Fix-me: said to be for internal purposes only - ) - (narrow-to-region min max) - (set (make-local-variable 'font-lock-fontify-buffer-function) 'mumamo-font-lock-fontify-chunk) - ;;(message "funcall major=%s, %s" major font-lock-fontify-buffer-function) - ;;(message "before funcall: function=%s" font-lock-fontify-buffer-function) - (put 'font-lock-fontify-buffer-function 'permanent-local t) - (funcall major) ;; <----------------------------------------------- - (put 'font-lock-fontify-buffer-function 'permanent-local nil) - (when old-bf - (set (make-local-variable 'font-lock-fontify-buffer-function) old-bf)) - )) - (goto-char here))) - ;;(msgtrc "set-major B: buffer-invisibility-spec=%S" buffer-invisibility-spec) - ;;(msgtrc "set-major B: word-wrap=%S, cb=%s" word-wrap (current-buffer)) - - (setq font-lock-mode-major-mode major) ;; Tell font-lock it is ok - (set (make-local-variable 'font-lock-function) 'mumamo-font-lock-function) - (if (not ancestor-hook-sym) - (mumamo-restore-per-major-local-vars major) - (remove-hook ancestor-hook-sym - 'mumamo-restore-per-major-local-vars-in-hook - t))) - ;;(msgtrc "set-major c: buffer-invisibility-spec=%S" buffer-invisibility-spec) - - (when (mumamo-fun-eq major 'org-mode) (setq mumamo-org-startup-done t)) - - (setq mumamo-major-mode-indent-line-function (cons major-mode indent-line-function)) - (make-local-variable 'indent-line-function) - - (setq mode-name (concat (format-mode-line mode-name) - (save-match-data - (replace-regexp-in-string - "-mumamo-mode$" "" - (format "/%s" mumamo-multi-major-mode))))) - - (dolist (hk mumamo-survive-hooks) (put hk 'permanent-local nil)) - - ;; (when (and (featurep 'flymake) - ;; flymake-mode) - ;; (add-hook 'after-change-functions 'flymake-after-change-function nil t) - ;; (add-hook 'after-save-hook 'flymake-after-save-hook nil t) - ;; (add-hook 'kill-buffer-hook 'flymake-kill-buffer-hook nil t)) - - ;;;;;;;;;;;;;;;; - ;; Restore per buffer local variables - - ;; (dolist (sym mumamo-per-buffer-local-vars) - ;; (when (boundp sym) - ;; (put sym 'permanent-local nil))) - ;;(msgtrc "per-buffer-local-vars-state=%S" per-buffer-local-vars-state) - (dolist (saved per-buffer-local-vars-state) - ;;(msgtrc "restore p buffer: %s, local=%s" (car saved) (local-variable-p (car saved))) - (unless (local-variable-p (car saved)) - (set (make-local-variable (car saved)) (cdr saved)))) - - ;;;;;;;;;;;;;;;; - ;; Restore per main major local variables - (unless (mumamo-fun-eq major-mode (mumamo-main-major-mode)) - (dolist (saved per-main-major-local-vars-state) - (set (make-local-variable (car saved)) (cdr saved)))) - - (mumamo-addback-to-hooks) - - (setq cursor-type old-cursor-type) - (run-hooks 'mumamo-after-change-major-mode-hook) - - (when (derived-mode-p 'nxml-mode) - (when (and old-rng-schema-file - (not (string= old-rng-schema-file rng-current-schema-file-name))) - (let ((rng-schema-change-hook nil)) ;(list 'rng-alidate-clear))) - (condition-case err - (progn - (rng-set-schema-file-1 old-rng-schema-file) - (rng-what-schema)) - (nxml-file-parse-error - (nxml-display-file-parse-error err))) - (when rng-validate-mode - ;; Fix-me: Change rng-validate variables so that this is - ;; not necessary any more. - (rng-validate-mode 0) - (rng-validate-mode 1)) - ))) - ;; The nxml-parser should not die: - (when (mumamo-derived-from-mode (mumamo-main-major-mode) 'nxml-mode) - (add-hook 'after-change-functions 'rng-after-change-function nil t) - (add-hook 'after-change-functions 'nxml-after-change nil t) - ;; Added these for Emacs 22: - (unless nxml-prolog-end (setq nxml-prolog-end 1)) - (unless nxml-scan-end (setq nxml-scan-end (copy-marker 1)))) - -;;; (when (and global-font-lock-mode -;;; font-lock-global-modes -;;; font-lock-mode) -;;; (when global-font-lock-mode -;;; (add-hook 'change-major-mode-hook 'global-font-lock-mode-cmhh)) -;;; (add-hook 'change-major-mode-hook 'font-lock-change-mode nil t) - - (mumamo-set-fontification-functions) - - ;; If user has used M-x flyspell-mode then we need to correct it: - ;; Fix-me: This is inflexible. Need flyspell to cooperate. - (when (featurep 'flyspell) - (setq flyspell-generic-check-word-predicate 'mumamo-flyspell-verify)) - - (if mumamo-done-first-set-major - (setq mumamo-just-changed-major t) - (mumamo-msgfntfy "mumamo-set-major: ----- removing 'fontified") - ;; Set up to fontify buffer - (mumamo-save-buffer-state nil - (remove-list-of-text-properties (point-min) (point-max) '(fontified))) - (setq mumamo-done-first-set-major t)) - - ;; Timing, on a 3ghz cpu: - ;; - ;; used-time=(0 0 0), major-mode=css-mode - ;; used-time=(0 0 0), major-mode=ecmascript-mode - ;; used-time=(0 0 0), major-mode=html-mode - ;; used-time=(0 0 203000), major-mode=nxhtml-mode - ;; - ;; After some changes 2007-04-25: - ;; - ;; used-time=(0 0 15000), major-mode=nxhtml-mode - ;; - ;; which is 15 ms. That seems acceptable though I am not sure - ;; everything is correct when switching to nxhtml-mode yet. I - ;; will have to wait for bug reports ;-) - ;; - ;; The delay is clearly noticeable and disturbing IMO unless you - ;; change major mode in an idle timer. - ;; - ;;(setq end-time (get-internal-run-time)) - ;;(setq used-time (time-subtract end-time start-time)) - ) - (setq mumamo-set-major-keymap-checked nil) - ;; Fix-me: Seems like setting/checking the keymap in a timer is - ;; problematc. This is an Emacs bug. - ;;(run-with-idle-timer 1 nil 'mumamo-set-major-check-keymap) - ;;(force-mode-line-update) (message "force-mode-line-update called") - ) - -(defun mumamo-set-major-check-keymap () - "Helper to work around an Emacs bug when setting local map in a timer." - (or mumamo-set-major-keymap-checked - (setq mumamo-set-major-keymap-checked - (let ((map-sym (intern-soft (concat (symbol-name major-mode) "-map")))) - (if (not map-sym) - t ;; Don't know what to do - (equal (current-local-map) - (symbol-value map-sym))))))) - -(defvar mumamo-original-fill-paragraph-function nil) -(make-variable-buffer-local 'mumamo-original-fill-paragraph-function) - -(defun mumamo-setup-local-fontification-vars () - "Set up buffer local variables for mumamo style fontification." - (make-local-variable 'font-lock-fontify-region-function) - (setq font-lock-fontify-region-function 'mumamo-fontify-region) - - ;; Like font-lock-turn-on-thing-lock: - (make-local-variable 'font-lock-fontify-buffer-function) - (setq font-lock-fontify-buffer-function 'jit-lock-refontify) - (setq font-lock-fontify-buffer-function 'mumamo-fontify-buffer) - ;; Don't fontify eagerly (and don't abort if the buffer is large). - (set (make-local-variable 'font-lock-fontified) t) - - (make-local-variable 'font-lock-unfontify-buffer-function) - (setq font-lock-unfontify-buffer-function 'mumamo-unfontify-buffer) - - (set (make-local-variable 'indent-line-function) 'mumamo-indent-line-function) - - ;;(setq mumamo-original-fill-paragraph-function fill-paragraph-function) - ;;(set (make-local-variable 'fill-paragraph-function) 'mumamo-fill-paragraph-function) - ;;(set (make-local-variable 'fill-forward-paragraph-function 'forward-paragraph) - - (make-local-variable 'indent-region-function) - (setq indent-region-function 'mumamo-indent-region-function) - - ;;(set (make-local-variable 'syntax-begin-function) 'mumamo-beginning-of-syntax) - - ;;(put 'font-lock-function 'permanent-local t) - - ;; FIX-ME: Not sure about this one, but it looks like it must be - ;; set: - (make-local-variable 'jit-lock-contextually) - (setq jit-lock-contextually t) - ) - -(defun mumamo-font-lock-function (mode) - ;;(mumamo-backtrace "font-lock-function") - (font-lock-default-function mode)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Turning on/off multi major modes - -(defun mumamo-set-fontification-functions () - "Let mumamo take over fontification. -This is run after changing major mode so that jit-lock will get -the major mode specific values. \(There are currently no such -values.)" - ;; Give the jit machinery a starting point: - (mumamo-jit-lock-register 'font-lock-fontify-region t) - ;; Set the functions that font-lock should use: - (mumamo-setup-local-fontification-vars) - ;; Need some hook modifications to keep things together too: - (add-hook 'change-major-mode-hook 'mumamo-change-major-function nil t) - (add-hook 'post-command-hook 'mumamo-post-command nil t) - (remove-hook 'change-major-mode-hook 'nxml-change-mode t) - (remove-hook 'change-major-mode-hook 'nxhtml-change-mode t) - ) - -(defun mumamo-initialize-state () - "Initialize some mumamo state variables." - (setq mumamo-done-first-set-major nil) - (setq mumamo-just-changed-major nil)) - -(defun mumamo-turn-on-actions (old-major-mode) - "Do what is necessary to turn on mumamo. -Turn on minor mode function `font-lock-mode'. -Set up for mumamo style fontification. -Create a mumamo chunk at point. -Run `mumamo-turn-on-hook'. - -OLD-MAJOR-MODE is used for the main major mode if the main major -mode in the chunk family is nil." - ;;(unless font-lock-mode (font-lock-mode 1)) - (mumamo-msgfntfy "mumamo-turn-on-actions") - (unless mumamo-current-chunk-family (error "Internal error: Chunk family is not set")) - (if (not mumamo-current-chunk-family) - (progn - (lwarn '(mumamo) :warning - "Could not turn on mumamo because chunk family was not set\n\tin buffer %s." - (current-buffer)) - (with-current-buffer "*Warnings*" - (insert "\tFor more information see `") - (mumamo-insert-describe-button 'define-mumamo-multi-major-mode 'describe-function) - (insert "'.\n"))) - ;; Load major mode: - (setq mumamo-org-startup-done nil) - (let ((main-major-mode (mumamo-major-mode-from-modespec (mumamo-main-major-mode)))) - (unless main-major-mode - (setcar (cdr mumamo-current-chunk-family) old-major-mode) - (setq main-major-mode (mumamo-main-major-mode))) - ;;(with-temp-buffer (funcall main-major-mode)) - (setq mumamo-major-mode main-major-mode) - (when (boundp 'nxml-syntax-highlight-flag) - (when (mumamo-derived-from-mode main-major-mode 'nxml-mode) - (set (make-local-variable 'nxml-syntax-highlight-flag) nil))) - ;; Init fontification - (mumamo-initialize-state) - (mumamo-set-fontification-functions) - (mumamo-save-buffer-state nil - (remove-list-of-text-properties (point-min) (point-max) - (list 'fontified))) - ;; For validation header etc: - (when (mumamo-derived-from-mode main-major-mode 'nxhtml-mode) - (require 'rngalt nil t) - (when (featurep 'rngalt) - (setq rngalt-major-mode (mumamo-main-major-mode)) - (rngalt-update-validation-header-overlay)) - (when (featurep 'rng-valid) - (setq rng-get-major-mode-chunk-function 'mumamo-find-chunks) - (setq rng-valid-nxml-major-mode-chunk-function 'mumamo-valid-nxml-chunk) - (setq rng-end-major-mode-chunk-function 'overlay-end)))) - ;;(mumamo-set-major-post-command) - ;;(add-hook 'change-major-mode-hook 'mumamo-change-major-function nil t) - (when (boundp 'flyspell-generic-check-word-predicate) - (setq flyspell-generic-check-word-predicate 'mumamo-flyspell-verify)) - (run-hooks 'mumamo-turn-on-hook) - ;;(mumamo-get-chunk-save-buffer-state (point)) - (let ((buffer-windows (get-buffer-window-list (current-buffer)))) - (if (not buffer-windows) - (let* ((ovl (mumamo-find-chunks (point) "mumamo-turn-on-actions")) - (major (when ovl (mumamo-chunk-major-mode ovl)))) - (when major - (mumamo-set-major major ovl))) - (dolist (win (get-buffer-window-list (current-buffer) nil t)) - (let ((wp (or (window-end win) - (window-point win) - (window-start win)))) - (mumamo-get-chunk-save-buffer-state wp) - (when (eq win (selected-window)) - (let* ((ovl (mumamo-find-chunks wp "mumamo-turn-on-actions")) - (major (when ovl (mumamo-chunk-major-mode ovl)))) - (when major - (mumamo-set-major major ovl)))))))) - ;;(msgtrc "mumamo-turn-on-action exit: font-lock-keywords-only =%s in buffer %s, def=%s" font-lock-keywords-only (current-buffer) (default-value 'font-lock-keywords-only)) - ;; This did not help for Emacs bug 3467: - ;;(set-default 'font-lock-keywords-only nil) - ;;(setq font-lock-keywords-only nil) - ) - (set (make-local-variable 'font-lock-function) 'mumamo-font-lock-function) - (mumamo-emacs-start-bug3467-timer-if-needed) - ) - -;; (defun mumamo-on-font-lock-off () -;; "The reverse of `mumamo-turn-on-actions'." -;; (let ((mumamo-main-major-mode (mumamo-main-major-mode))) -;; (mumamo-turn-off-actions) -;; ;; Turning off `font-lock-mode' also turns off `mumamo-mode'. It is -;; ;; quite tricky to not turn on `font-lock-mode' again in case we got -;; ;; here because it was turned off. We must first remove the cmhh -;; ;; function and then also run the internal font lock turn off. -;; (let* ((flm font-lock-mode) -;; (flgm global-font-lock-mode) -;; (remove-cmhh (and (not flm) flgm))) -;; ;; If remove-cmhh is non-nil then we got here because -;; ;; `font-lock-mode' was beeing turned off in the buffer, but -;; ;; `global-font-lock-mode' is still on. -;; (when remove-cmhh -;; (remove-hook 'change-major-mode-hook 'global-font-lock-mode-cmhh)) - -;; (if mumamo-main-major-mode -;; (funcall mumamo-main-major-mode) -;; (fundamental-mode)) - -;; (unless flm -;; (setq font-lock-mode nil) -;; (font-lock-mode-internal nil)) -;; (when remove-cmhh -;; (add-hook 'change-major-mode-hook 'global-font-lock-mode-cmhh))))) - -(defun mumamo-turn-off-actions () - "The reverse of `mumamo-turn-on-actions'." - (mumamo-msgfntfy "mumamo-turn-off-actions") - (when (fboundp 'nxhtml-validation-header-mode) - (nxhtml-validation-header-mode -1)) - (when (mumamo-derived-from-mode - (nth 1 mumamo-current-chunk-family) 'nxml-mode) - (when (fboundp 'nxml-change-mode) - (nxml-change-mode))) - (when (and (boundp 'rng-validate-mode) - rng-validate-mode) - (rng-validate-mode 0)) - (when (featurep 'rng-valid) - (setq rng-get-major-mode-chunk-function nil) - (setq rng-valid-nxml-major-mode-chunk-function nil) - (setq rng-end-major-mode-chunk-function nil) - ) - ;; Remove nxml for Emacs 22 - (remove-hook 'after-change-functions 'rng-after-change-function t) - (remove-hook 'after-change-functions 'nxml-after-change t) - (when (boundp 'rngalt-major-mode) - (setq rngalt-major-mode nil)) - (remove-hook 'change-major-mode-hook 'mumamo-change-major-function t) - ;;(mumamo-unfontify-chunks) - ;;(remove-hook 'after-change-functions 'mumamo-jit-lock-after-change t) - (remove-hook 'after-change-functions 'mumamo-after-change t) - (remove-hook 'post-command-hook 'mumamo-post-command t) - ;;(remove-hook 'c-special-indent-hook 'mumamo-c-special-indent t) - (mumamo-margin-info-mode -1) - (when (fboundp 'mumamo-clear-all-regions) (mumamo-clear-all-regions)) - (save-restriction - (widen) - (mumamo-save-buffer-state nil - (set-text-properties (point-min) (point-max) nil))) - (setq mumamo-current-chunk-family nil) - (setq mumamo-major-mode nil) - (setq mumamo-multi-major-mode nil) ;; for minor-mode-map-alist - (setq mumamo-multi-major-mode nil) - (mumamo-remove-all-chunk-overlays) - (when (fboundp 'rng-cancel-timers) (rng-cancel-timers)) - ) - -(defvar mumamo-turn-on-hook nil - "Normal hook run after turning on `mumamo-mode'.") -(put 'mumamo-turn-on-hook 'permanent-local t) - -(defvar mumamo-change-major-mode-hook nil - "Normal hook run before internal change of major mode.") -(put 'mumamo-change-major-mode-hook 'permanent-local t) - -(defvar mumamo-after-change-major-mode-hook nil - "Normal hook run after internal change of major mode.") -(put 'mumamo-after-change-major-mode-hook 'permanent-local t) - - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Defining multi major modes - -(defvar mumamo-defined-multi-major-modes nil - "List of functions defined for turning on mumamo. -Those functions should be called instead of calling a major mode -function when you want to use multiple major modes in a buffer. -They may be added to for example `auto-mode-alist' to -automatically have the major mode support turned on when opening -a file. - -Each of these functions defines how to mix certain major modes in -a buffer. - -All functions defined by `define-mumamo-multi-major-mode' are -added to this list. See this function for a general description -of how the functions work. - -If you want to quickly define a new mix of major modes you can -use `mumamo-quick-static-chunk'.") - -;;;###autoload -(defun mumamo-list-defined-multi-major-modes (show-doc show-chunks match) - "List currently defined multi major modes. -If SHOW-DOC is non-nil show the doc strings added when defining -them. \(This is not the full doc string. To show the full doc -string you can click on the multi major mode in the list.) - -If SHOW-CHUNKS is non-nil show the names of the chunk dividing -functions each multi major mode uses. - -If MATCH then show only multi major modes whos names matches." - (interactive (list (y-or-n-p "Include short doc string? ") - (y-or-n-p "Include chunk function names? ") - (read-string "List only multi major mode matching regexp (emtpy for all): "))) - (with-output-to-temp-buffer (help-buffer) - (help-setup-xref (list #'mumamo-list-defined-multi-major-modes) (interactive-p)) - (with-current-buffer (help-buffer) - (insert "The currently defined multi major modes in your Emacs are:\n\n") - (let ((mmms (reverse mumamo-defined-multi-major-modes)) - (here (point))) - (setq mmms (sort mmms (lambda (a b) - (string< (symbol-name (cdr a)) - (symbol-name (cdr b)))))) - (when (string= match "") (setq match nil)) - (while mmms - (let* ((mmm (car mmms)) - (sym (cdr mmm)) - (desc (car mmm)) - (auto (get sym 'autoload)) - (auto-desc (when auto (nth 1 auto))) - (family (get sym 'mumamo-chunk-family)) - (chunks (nth 2 family))) - (when (or (not match) - (string-match-p match (symbol-name sym))) - (insert " `" (symbol-name sym) "'" - " (" desc ")\n" - (if (and show-doc auto-desc) - (concat " " auto-desc "\n") - "") - (if show-chunks - (format " Chunks:%s\n" - (let ((str "") - (nn 0)) - (mapc (lambda (c) - (if (< nn 2) - (setq str (concat str " ")) - (setq nn 0) - (setq str (concat str "\n "))) - (setq nn (1+ nn)) - (setq str (concat str (format "%-30s" (format "`%s'" c)))) - ) - chunks) - str)) - "") - (if (or show-doc show-chunks) "\n\n" "") - )) - (setq mmms (cdr mmms)))) - )))) - -(defun mumamo-describe-chunks (chunks) - "Return text describing CHUNKS." - (let* ((desc - (concat "* Main major mode: `" (symbol-name (nth 1 chunks)) "'\n" - "\n* Functions for dividing into submodes:\n"))) - (dolist (divider (nth 2 chunks)) - (setq desc - (concat - desc - "\n`" (symbol-name divider) - "'\n " - (let ((doc (if (functionp divider) - (documentation divider t) - "(Function not compiled when building doc)"))) - (if (not doc) - "(Not documented)" - (substring doc 0 (string-match "\n" doc))))))) - (setq desc - (concat - desc - "\n\n(Note that the functions for dividing into chunks returns\n" - "a major mode specifier which may be translated into a major mode\n" - "by `mumamo-main-major-mode'.)\n")) - desc)) - -(defun mumamo-add-multi-keymap (toggle keymap) - "Add TOGGLE and KEYMAP to `minor-mode-map-alist'. -This is used to add a keymap to multi major modes since the local -keymap is occupied by the major modes. - -It is also used to add the `mumamo-map' keymap to every buffer -with a multi major mode." - ;; Copied from add-minor-mode - ;; Add the map to the minor-mode-map-alist. - (when keymap - (let ((existing (assq toggle minor-mode-map-alist)) - (after t)) - (if existing - (setcdr existing keymap) - (let ((tail minor-mode-map-alist) found) - (while (and tail (not found)) - (if (eq after (caar tail)) - (setq found tail) - (setq tail (cdr tail)))) - (if found - (let ((rest (cdr found))) - (setcdr found nil) - (nconc found (list (cons toggle keymap)) rest)) - (setq minor-mode-map-alist (cons (cons toggle keymap) - minor-mode-map-alist)))))))) - -(defvar mumamo-map - (let ((map (make-sparse-keymap))) - (define-key map [(control meta prior)] 'mumamo-backward-chunk) - (define-key map [(control meta next)] 'mumamo-forward-chunk) - ;; Use mumamo-indent-line-function: - ;;(define-key map [tab] 'indent-for-tab-command) - (define-key map [(meta ?q)] 'fill-paragraph) - map) - "Keymap that is active in all mumamo buffers. -It has the some priority as minor mode maps.") -;;(make-variable-buffer-local 'mumamo-map) -(put 'mumamo-map 'permanent-local t) - -(mumamo-add-multi-keymap 'mumamo-multi-major-mode mumamo-map) - -;;;###autoload -(defun mumamo-multi-major-modep (value) - "Return t if VALUE is a multi major mode function." - (and (fboundp value) - (rassq value mumamo-defined-multi-major-modes))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Indenting, filling, moving etc - -;; FIX-ME: Indentation in perl here doc indents the ending mark which -;; corrupts the perl here doc. - -(defun mumamo-indent-line-function () - "Function to indent the current line. -This is the buffer local value of `indent-line-function' when -mumamo is used." - (let ((here (point-marker)) - fontification-functions - rng-nxml-auto-validate-flag - (before-text (<= (current-column) (current-indentation)))) - (mumamo-indent-line-function-1 nil nil nil) - ;; If the marker was in the indentation part strange things happen - ;; if we try to go back to the marker, at least in php-mode parts. - (if before-text - (back-to-indentation) - (goto-char here)))) - -(defun mumamo-indent-current-line-chunks (last-chunk-prev-line) - "Return a list of chunks to consider when indenting current line. -This list consists of four chunks at these positions: -- Beginning of line - 1 -- Beginning of line -- End of line -- End of line + 1" - ;; Fix-me: must take markers into account too when a submode - ;; includes the markers. - (setq last-chunk-prev-line nil) - ;;(msgtrc "indent-current-line-chunks: last-chunk-prev-line=%S" last-chunk-prev-line) - (save-restriction - (widen) - (let* ((lb-pos (line-beginning-position)) - (le-pos (line-end-position)) - (pos0 (if (> lb-pos (point-min)) - (1- lb-pos) - (point-min))) - (pos1 lb-pos) - (pos2 le-pos) - (pos3 (if (< le-pos (point-max)) - (+ 1 le-pos) - (point-max))) - ;; Create all chunks on this line first, then grab them - (ovl3 (mumamo-find-chunks pos3 "mumamo-indent-current-line-chunks")) - (ovl2 (if (>= pos2 (overlay-start ovl3)) - ovl3 - (mumamo-get-existing-new-chunk-at pos2))) - (ovl1 (if (>= pos1 (overlay-start ovl2)) - ovl2 - (mumamo-get-existing-new-chunk-at pos1))) - (ovl0 (if (> pos0 (overlay-start ovl1)) - ovl1 - (mumamo-get-existing-new-chunk-at pos0 t)))) - (list ovl0 ovl1 ovl2 ovl3)))) - -;; Fix-me: need to back up past comments in for example <style> /* comment */ -;; fix-me: clean up -(put 'mumamo-error-ind-0 'error-conditions '(error mumamo-error-ind-0)) -(put 'mumamo-error-ind-0 'error-message "indentation 0 in sub chunk") - - - -;;;;;;;;;;;;;;;;;;;;;;;; -;; Template indentation -;;; Contact Marc Bowes when I've finished this. - -(defvar mumamo-template-indent-buffer nil) -(make-variable-buffer-local 'mumamo-template-indent-buffer) -(put 'mumamo-template-indent-buffer 'permanent-local t) - -(defvar mumamo-template-indent-change-min nil) -(make-variable-buffer-local 'mumamo-template-indent-change-min) -(put 'mumamo-template-indent-hange-min 'permanent-local t) - -(defun mumamo-template-indent-after-change (beg end len) - (setq mumamo-template-indent-change-min - (if mumamo-template-indent-change-min - (min mumamo-template-indent-change-min beg) - beg))) - -;; (defun mumamo-get-indentor-create (indentor-chunk prev-indentor) -;; (let ((indentor (overlay-get indentor-chunk 'mumamo-indentor)) -;; (indentor-buffer (when indentor (overlay-buffer indentor))) -;; (chunk-str (with-current-buffer (overlay-buffer indentor-chunk) -;; (buffer-substring-no-properties (overlay-start indentor-chunk) -;; (overlay-end indentor-chunk)))) -;; ) -;; (unless (and indentor -;; (eq indentor-buffer mumamo-template-indent-buffer) -;; (string= chunk-str (overlay-get indentor 'indentor-chunk-string))) -;; (when indentor -;; (when (buffer-live-p -;; indentor -;; )) -(defun mumamo-indentor-valid (indentor chunk chunk-string) - (and indentor - chunk - (buffer-live-p (overlay-buffer chunk)) - (string= chunk-string (overlay-get indentor 'indentor-chunk-string)) - )) - -(defun mumamo-template-indent-get-chunk-shift (indentor-chunk) - "Return indentation shift for INDENTOR-CHUNK row and line after. -;; Fix-me: Handle changes better. - -Indentation shift has two parts: shift for current line and for next line. -This function returns a cons with these two parts. -" - (assert (overlayp indentor-chunk) t) - (assert (buffer-live-p (overlay-buffer indentor-chunk)) t) - (let ((indentor (overlay-get indentor-chunk 'mumamo-indentor)) - (prev-chunk (overlay-get indentor-chunk 'mumamo-prev-chunk)) - prev-indentor prev-indentor-chunk) - (when indentor (assert (eq indentor-chunk (overlay-get indentor 'indentor-chunk)) t)) - (unless (and mumamo-template-indent-buffer - (buffer-live-p mumamo-template-indent-buffer)) - (setq indentor nil) - (setq mumamo-template-indent-buffer - (get-buffer-create (concat (buffer-name) - "-template-indent-buffer"))) - (with-current-buffer mumamo-template-indent-buffer - (setq buffer-undo-list t) - (let ((major (car (overlay-get indentor-chunk 'mumamo-major-mode)))) - (funcall major)))) - (when indentor - (unless (eq (overlay-buffer indentor) mumamo-template-indent-buffer) - (setq indentor nil))) - ;; We need the prev indentor to indent relative to. - (while (and prev-chunk (not prev-indentor-chunk)) - (setq prev-chunk (overlay-get prev-chunk 'mumamo-prev-chunk)) - (when prev-chunk - (when (eq (overlay-get prev-chunk 'mumamo-next-indent) - 'mumamo-template-indentor) - (setq prev-indentor-chunk (overlay-get prev-chunk 'mumamo-next-chunk))))) - (when prev-indentor-chunk - (setq prev-indentor (overlay-get prev-indentor-chunk 'mumamo-indentor))) - (when prev-indentor - (unless (buffer-live-p (overlay-buffer prev-indentor)) - (setq prev-indentor nil))) - (when prev-indentor (assert (eq (overlay-buffer prev-indentor) mumamo-template-indent-buffer) t)) - (with-current-buffer mumamo-template-indent-buffer - (save-restriction - (widen) - ;; Insert a blank line to be able to go to start of first - ;; overlay -1. Do it here in case the user erases the buffer. - (when (= 0 (buffer-size)) (insert "\n")) - (let ((i-str (when indentor - (buffer-substring-no-properties (overlay-start indentor) (overlay-end indentor)))) - (i-beg (when indentor (overlay-start indentor))) - (c-str (with-current-buffer (overlay-buffer indentor-chunk) - (buffer-substring-no-properties (overlay-start indentor-chunk) - (overlay-end indentor-chunk)))) - (p-str (when prev-indentor-chunk - (with-current-buffer (overlay-buffer prev-indentor-chunk) - (buffer-substring-no-properties (overlay-start prev-indentor-chunk) - (overlay-end prev-indentor-chunk))))) - (c-beg (overlay-start indentor-chunk)) - (p-beg (when prev-indentor-chunk (overlay-start prev-indentor-chunk)))) - ;; Check if `indentor' and `prev-indentor' are valid - (when indentor - ;;(unless (string= c-str (overlay-get indentor 'indentor-chunk-string)) - (unless (mumamo-indentor-valid indentor indentor-chunk c-str) - (mumamo-remove-indentor indentor))) - (when prev-indentor - ;;(unless (string= p-str (overlay-get prev-indentor 'indentor-chunk-string)) - (unless (mumamo-indentor-valid prev-indentor prev-indentor-chunk p-str) - (mumamo-remove-indentor prev-indentor))) - (unless indentor - (setq i-beg - (or i-beg - (when prev-indentor - ;; We just put `indentor' after this, but we - ;; must also remove old stuff. - (goto-char (overlay-end prev-indentor)) - (forward-char 1) - (let* ((next-indentor (mumamo-indentor-at (point))) - (next-indentor-chunk (when next-indentor - (overlay-get next-indentor 'indentor-chunk))) - n-beg - (new-i-beg (unless next-indentor-chunk (point)))) - (while (not new-i-beg) - (setq n-beg (when (buffer-live-p (overlay-buffer next-indentor-chunk)) - (overlay-start next-indentor-chunk))) - (if (or (not n-beg) (< n-beg c-beg)) - (progn - (mumamo-remove-indentor next-indentor) - (goto-char (overlay-end prev-indentor)) - (forward-char 1) - (setq next-indentor (mumamo-indentor-at (point))) - (if next-indentor - (setq next-indentor-chunk (overlay-get next-indentor 'indentor-chunk)) - (setq new-i-beg (point)))) - (setq new-i-beg (point)))) - new-i-beg)) - ;; Fix-me: Find out where to insert indentor: - (let* ((ll 1) - (rr (point-max)) - mm new-i-beg m-ovl m-ovl-old m-chunk m-beg) - (while (< ll rr) - (setq mm (+ ll (/ (- rr ll) 2))) - (setq m-ovl-old m-ovl) - (setq m-ovl (mumamo-indentor-at mm)) - (if (or (not m-ovl) (eq m-ovl m-ovl-old)) - (setq rr ll) - (setq m-chunk (overlay-get m-ovl 'indentor-chunk)) - (setq m-beg (when (buffer-live-p (overlay-buffer m-chunk)) - (overlay-start m-chunk))) - (cond ((not m-beg) - (mumamo-remove-indentor m-ovl) - (setq rr (min rr (point-max)))) - ((> m-beg c-beg) - (setq ll (1+ mm))) - ((< m-beg c-beg) - (setq rr (1- mm))) - (t (error "Found old indentor at %s belonging to %S" mm m-chunk))))) - ;;(1+ (if m-ovl (overlay-end m-ovl) 0)) - (if m-ovl (1+ (overlay-end m-ovl)) 2) - ))) - (goto-char i-beg) - (setq indentor (mumamo-make-indentor indentor-chunk c-str))) - (unless prev-indentor - (when prev-indentor-chunk - (goto-char (overlay-start indentor)) - (goto-char (point-at-bol)) - (setq prev-indentor (mumamo-make-indentor prev-indentor-chunk p-str)))) - (when prev-indentor (mumamo-indent-indentor prev-indentor)) - (mumamo-indent-indentor indentor) - (let (prev-ind this-ind next-ind shift-in shift-out) - (when prev-indentor - (goto-char (overlay-end prev-indentor)) - (setq prev-ind (current-indentation))) - (goto-char (overlay-start indentor)) - (setq this-ind (current-indentation)) - (goto-char (overlay-end indentor)) - (setq next-ind (current-indentation)) - (when prev-ind (setq shift-in (- this-ind prev-ind))) - (setq shift-out (- next-ind this-ind)) - (msgtrc "template-indent-get-shunk-shift => (%s . %s)" shift-in shift-out) - (cons shift-in shift-out))))))) - - -(defun mumamo-ruby-beginning-of-indent () - "TODO: document" - ;; I don't understand this function. - ;; It seems like it should move to the line where indentation should deepen, - ;; but ruby-indent-beg-re only accounts for whitespace before class, module and def, - ;; so this will only match other block beginners at the beginning of the line. - (and - (prog1 - (re-search-backward (concat "^\\(" ruby-indent-beg-re "\\)\\b") nil 'move) - (skip-chars-forward " \t\n\r")) - (beginning-of-line))) - -(defadvice ruby-beginning-of-indent (around - mumamo-ad-ruby-beginning-of-indent - activate - compile - ) - (if t - (mumamo-ruby-beginning-of-indent) - ad-do-it) - ) - -(defun mumamo-indentor-at (pos) - "Return indentor overlay at POS." - (let ((here (point)) - eol-pos) - (goto-char pos) - (setq eol-pos (line-end-position)) - (goto-char here) - (catch 'ind - (dolist (ovl (or (overlays-at eol-pos) - (when (> eol-pos 1) - (overlays-at (1- eol-pos))))) - (when (overlay-get ovl 'indentor-chunk) - (throw 'ind ovl)))))) - -(defun mumamo-remove-indentor (indentor) - (let (beg end) - (goto-char (overlay-start indentor)) - (setq beg (point-at-bol)) - (goto-char (overlay-end indentor)) - (setq end (1+ (point-at-eol))) - (delete-region beg end) - (delete-overlay indentor) - (setq indentor nil))) - -(defun mumamo-indent-indentor (indentor) - (goto-char (overlay-start indentor)) - (if (= 2 (point-at-bol)) - (progn - (back-to-indentation) - (delete-region 2 (point)) - (insert " ")) - (indent-according-to-mode)) - (goto-char (overlay-end indentor)) - (indent-according-to-mode)) - -(defun mumamo-make-indentor (indentor-chunk chunk-string) - (let* ((beg (point)) - (syntax-min-max (mumamo-chunk-syntax-min-max indentor-chunk t)) - (inner (with-current-buffer (overlay-buffer indentor-chunk) - (buffer-substring-no-properties (cdr syntax-min-max) - (car syntax-min-max)))) - indentor) - (insert inner) - (insert "\n\n") - (setq indentor (make-overlay beg (1- (point)) nil t t)) - (overlay-put indentor 'indentor-chunk indentor-chunk) - (overlay-put indentor 'face 'secondary-selection) - (overlay-put indentor 'indentor-chunk-string chunk-string) - (overlay-put indentor-chunk 'mumamo-indentor indentor) - indentor)) - -;;(mumamo-fun-eq 'js-mode 'javascript-mode) -(defun mumamo-fun-eq (fun1 fun2) - "Return non-nil if same functions or aliases." - (or (eq fun1 fun2) - (progn - (while (and (fboundp fun1) - (symbolp (symbol-function fun1))) - (setq fun1 (symbol-function fun1))) - (while (and (fboundp fun2) - (symbolp (symbol-function fun2))) - (setq fun2 (symbol-function fun2))) - (eq fun1 fun2)))) - -(defun mumamo-indent-line-function-1 (prev-line-chunks - last-parent-major-indent - entering-submode-arg) - ;; Fix-me: error indenting in xml-as-string at <?\n?> - ;; Fix-me: clean up, use depth diff. go back to sibling not to main etc. - ;; Fix-me: Add indentation hints to chunks, for example heredocs and rhtml. - ;; Fix-me: maybe use special indentation functions for certain multi major modes? rhtml? - "Indent current line. -When doing that care must be taken if this line's major modes at -the start and end are different from previous line major modes. -The latter may be known through the parameter PREV-LINE-CHUNKS. - -Also the indentation of the last previous main major line may be -necessary to know. This may be known through the parameter -LAST-PARENT-MAJOR-INDENT. - -If the two parameters above are nil then this function will -search backwards in the buffer to try to determine their values. - -The following rules are used when indenting: - -- If the major modes are the same in this and the previous line - then indentation is done using that major mode. - -- Exception: If the chunks are not the same AND there is - precisely one chunk between them which have the property value - of 'mumamo-next-indent equal to 'mumamo-template-indentor then - a special indent using the content of the middle chunk is - done. An example of this is eRuby where a middle chunk could - look like: - - <% 3.times do %> - - This example will increase indentation for the next line the - same way as the chunk content would do in single major mode - ruby-mode. - - FIXE-ME: IMPLEMENT THE ABOVE! - -- Otherwise if going into a submode indentation is increased by - `mumamo-submode-indent-offset' (if this is nil then indentation - will instead be 0). - -- However first non-empty line indentation in a chunk when going - in is special if prev-prev chunk is on same mumamo-depth and - have the same major mode. Then indent relative last non-empty - line in prev-prev chunk. - -- When going out of a submode indentation is reset to - LAST-PARENT-MAJOR-INDENT. - -- At the border the 'dividers' should be indented as the parent - chunk. There are the following typical situations regarding - inner/outer major modes: - - 1) <style type='text/css'> - Going in next line; first char outer; line end inner; - - 2) </style> - Going out this line; First char inner or outer; line end outer; - - 3) <?php - Going in next line; first char outer or inner; line end inner; - - 4) ?> - Going out this line; first char inner; line end outer; - - From this we deduce the following way to compute if we are - going in or out: - - - Odd above (going in): Compare prev line end's mumamo-depth - with current line end's dito. Set flag for first line in - chunk. - - - Even above (going out): Same test as for going in, but going - out happens on current line. -" - ;;(msgtrc "indent-line-function-1 blp=%s" (line-beginning-position)) - (setq prev-line-chunks nil) - ;;(setq last-parent-major-indent nil) - ;;(setq entering-submode-arg nil) - (unless prev-line-chunks - (save-excursion - (goto-char (line-beginning-position 1)) - (unless (= (point) 1) - (skip-chars-backward "\n\t ") - (goto-char (line-beginning-position 1)) - (setq prev-line-chunks (mumamo-indent-current-line-chunks nil)) - ;;(msgtrc "%d:prev-line-chunks=%S" (save-restriction (widen) (line-number-at-pos)) prev-line-chunks ) - ))) - (let* ((prev-line-chunk0 (nth 0 prev-line-chunks)) - (prev-line-chunk2 (nth 2 prev-line-chunks)) - (prev-line-chunk3 (nth 3 prev-line-chunks)) - (prev-line-major0 (mumamo-chunk-major-mode (nth 0 prev-line-chunks))) - (prev-line-major1 (mumamo-chunk-major-mode (nth 1 prev-line-chunks))) - (prev-line-major2 (mumamo-chunk-major-mode (nth 2 prev-line-chunks))) - (prev-line-major3 (mumamo-chunk-major-mode (nth 3 prev-line-chunks))) - (prev-depth2 (if prev-line-chunk2 - (overlay-get prev-line-chunk2 'mumamo-depth) - 0)) - (prev-depth3 (if prev-line-chunk3 - (overlay-get prev-line-chunk3 'mumamo-depth) - 0)) - - (this-line-chunks (mumamo-indent-current-line-chunks (nth 3 prev-line-chunks))) - ;;(dummy (msgtrc "%d:this-line-chunks=%S" (save-restriction (widen) (line-number-at-pos)) this-line-chunks)) - (this-line-chunk0 (nth 0 this-line-chunks)) - (this-line-chunk2 (nth 2 this-line-chunks)) - (this-line-chunk3 (nth 3 this-line-chunks)) - (this-line-major0 (mumamo-chunk-major-mode (nth 0 this-line-chunks))) - (this-line-major1 (mumamo-chunk-major-mode (nth 1 this-line-chunks))) - (this-line-major2 (mumamo-chunk-major-mode (nth 2 this-line-chunks))) - (this-line-major3 (mumamo-chunk-major-mode (nth 3 this-line-chunks))) - (this-depth2 (overlay-get this-line-chunk2 'mumamo-depth)) - (this-depth3 (overlay-get this-line-chunk3 'mumamo-depth)) - - ;;(dummy (msgtrc "a\t this=%S" this-line-chunks)) - this-line-indent-major - major-indent-line-function - (main-major (mumamo-main-major-mode)) - (old-indent (current-indentation)) - (next-entering-submode (if (< prev-depth3 this-depth3) 'yes 'no)) - (entering-submode - ;; Fix-me - (progn - (unless nil ;entering-submode-arg - (let* ((prev-prev-line-chunks - (save-excursion - (goto-char (line-beginning-position 0)) - (unless (bobp) - (skip-chars-backward "\n\t ") - (goto-char (line-beginning-position 1)) - (let ((chunks (mumamo-indent-current-line-chunks nil))) - ;;(msgtrc "%d:prev-prev-line-chunks=%S" (save-restriction (widen) (line-number-at-pos)) chunks) - chunks)))) - (prev-prev-line-chunk2 (nth 2 prev-prev-line-chunks)) - (prev-prev-line-chunk3 (nth 3 prev-prev-line-chunks)) - (prev-prev-depth2 (when prev-prev-line-chunk2 - (overlay-get prev-prev-line-chunk2 'mumamo-depth))) - (prev-prev-depth3 (when prev-prev-line-chunk3 - (overlay-get prev-prev-line-chunk3 'mumamo-depth)))) - ;;(msgtrc "depths 2=%s/%s/%s 3=%s/%s/%s" prev-prev-depth2 prev-depth2 this-depth2 prev-prev-depth3 prev-depth3 this-depth3) - (setq entering-submode-arg - (if prev-prev-depth2 - (if (and (eq prev-prev-line-chunk2 - (overlay-get prev-line-chunk2 'mumamo-prev-chunk)) - (< prev-prev-depth2 prev-depth2)) - 'yes - 'no) - (if (> this-depth2 0) 'yes 'no) - )) - )) - (eq 'yes entering-submode-arg) - )) ;; fix-me - ;; Fix-me - (leaving-submode (> prev-depth2 this-depth2)) - want-indent ;; The indentation we desire - got-indent - (here-on-line (point-marker)) - this-pending-undo-list - (while-n1 0) - (while-n2 0) - (while-n3 0) - ;; Is there a possible indentor chunk on this line?: - (this-line-indentor-chunk (when (> (overlay-start this-line-chunk2) - (point-at-bol)) - (overlay-get this-line-chunk2 'mumamo-prev-chunk))) - ;;(dummy (msgtrc "this-line-indentor-chunk=%S" this-line-indentor-chunk)) - ;; Check if this really is an indentor chunk: - ;; Fix-me: 'mumamo-indentor is not put on the chunk yet since - ;; it is done in mumamo-template-indent-get-chunk-shift ... - - ;; and now it is calle too often ... - (this-line-indentor-prev (when this-line-indentor-chunk - (overlay-get this-line-indentor-chunk 'mumamo-prev-chunk))) - (this-line-is-indentor (and this-line-indentor-prev - (eq (overlay-get this-line-indentor-prev 'mumamo-next-indent) - 'mumamo-template-indentor) - (progn - (goto-char (overlay-start this-line-indentor-chunk)) - (back-to-indentation) - (= (point) (overlay-start this-line-indentor-chunk))))) - ;; Fix-me: rewrite and reorder. We do not need both shift-in and shift-out - (this-template-shift (when this-line-is-indentor - (mumamo-template-indent-get-chunk-shift this-line-indentor-chunk))) - ;;(dummy (msgtrc "this-line-indentor=%s, %S" this-template-shift this-line-is-indentor)) - ;; Fix-me: skip over blank lines backward here: - (prev-template-indentor (when prev-line-chunk0 - (unless (eq this-line-chunk0 prev-line-chunk0) - (let* ((prev (overlay-get this-line-chunk0 'mumamo-prev-chunk)) - (prev-prev (overlay-get prev 'mumamo-prev-chunk))) - (when (and (eq prev-prev prev-line-chunk0) - (eq (overlay-get prev-prev 'mumamo-next-indent) - 'mumamo-template-indentor)) - prev))))) - (prev-template-shift-rec (when prev-template-indentor - (mumamo-template-indent-get-chunk-shift prev-template-indentor) - )) - (template-shift (if (and (car this-template-shift) (/= 0 (car this-template-shift))) - (car this-template-shift) - (when prev-template-shift-rec - (cdr prev-template-shift-rec)))) - (template-indent-abs (when (and template-shift - (/= 0 template-shift)) - (+ template-shift - (let ((here (point))) - (if prev-template-indentor - (goto-char (overlay-start prev-template-indentor)) - (goto-char (overlay-start this-line-indentor-chunk)) - (skip-chars-backward " \t\r\n\f")) - (prog1 - (current-indentation) - (goto-char here)))))) - ) - (when (and leaving-submode entering-submode) - (message "Do not know how to indent here (both leaving and entering sub chunks)") - ) - ;; Fix-me: indentation - ;;(error "Leaving=%s, entering=%s this0,1,2,3=%s,%s,%s,%s" leaving-submode entering-submode this-line-major0 this-line-major1 this-line-major2 this-line-major3) - (when (or leaving-submode entering-submode) - (unless last-parent-major-indent - (save-excursion - ;;(while (and (> 500 (setq while-n1 (1+ while-n1))) - (while (and (mumamo-while 500 'while-n1 "last-parent-major-indent") - (not last-parent-major-indent)) - (if (bobp) - (setq last-parent-major-indent 0) - (goto-char (line-beginning-position 0)) - (when (mumamo-fun-eq main-major - (mumamo-chunk-major-mode - (car - (mumamo-indent-current-line-chunks nil))) - ) - (skip-chars-forward " \t") - (if (eolp) - (setq last-parent-major-indent 0) - (setq last-parent-major-indent (current-column))))))))) - (mumamo-msgindent " leaving-submode=%s, entering-submode=%s" leaving-submode entering-submode) - ;;(msgtrc " leaving-submode=%s, entering-submode=%s, template-indentor=%s" leaving-submode entering-submode template-indentor) - - ;; Fix-me: use this. - ;; - clean up after chunk deletion - ;; - next line after a template-indentor, what happens? - ;;(setq template-indentor nil) ;; fix-me - (cond - ( template-indent-abs - (setq want-indent (max 0 template-indent-abs))) - ( leaving-submode - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;; First line after submode - (mumamo-msgindent " leaving last-parent-major-indent=%s" last-parent-major-indent) - (if (eq (overlay-get (overlay-get this-line-chunk0 'mumamo-prev-chunk) - 'mumamo-next-indent) - 'heredoc) - (setq want-indent 0) - (setq want-indent last-parent-major-indent))) - - ( entering-submode - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;; First line in submode - ;;(setq this-line-indent-major this-line-major0) - (setq this-line-indent-major (mumamo-indent-get-major-to-use this-line-major0 this-depth3)) - ;;(when (and prev-line-major0 (not (mumamo-fun-eq this-line-major0 prev-line-major0))) (setq this-line-indent-major prev-line-major0)) - (mumamo-msgindent " this-line-indent-major=%s, major-mode=%s this0=%s" this-line-indent-major major-mode this-line-major0) - (mumamo-msgindent " mumamo-submode-indent-offset=%s" mumamo-submode-indent-offset) - (unless (mumamo-fun-eq this-line-indent-major major-mode) - (mumamo-set-major this-line-indent-major this-line-chunk0)) - (setq want-indent (+ last-parent-major-indent - (if (= 0 last-parent-major-indent) - (if mumamo-submode-indent-offset-0 - mumamo-submode-indent-offset-0 - -1000) - (if mumamo-submode-indent-offset - mumamo-submode-indent-offset - -1000)))) - (unless (< 0 want-indent) (setq want-indent nil)) - (when (and want-indent (mumamo-indent-use-widen major-mode)) - ;; In this case only use want-indent if it is bigger than the - ;; indentation calling indent-line-function would give. - (condition-case nil - (atomic-change-group - (mumamo-call-indent-line (nth 0 this-line-chunks)) - (when (> want-indent (current-indentation)) - (signal 'mumamo-error-ind-0 nil)) - (setq want-indent nil)) - (mumamo-error-ind-0))) - (unless want-indent - (mumamo-call-indent-line (nth 0 this-line-chunks))) - (mumamo-msgindent " enter sub.want-indent=%s, curr=%s, last-main=%s" want-indent (current-indentation) - last-parent-major-indent) - ;;(unless (> want-indent (current-indentation)) (setq want-indent nil)) - ) - - ( t - ;; We have to change major mode, because we know nothing - ;; about the requirements of the indent-line-function: - ;; Fix-me: This may be cured by RMS suggestion to - ;; temporarily set all variables back to global values? - (setq this-line-indent-major (mumamo-indent-get-major-to-use this-line-major0 this-depth3)) - (mumamo-msgindent " this-line-indent-major=%s" this-line-indent-major) - (unless (mumamo-fun-eq this-line-indent-major major-mode) (mumamo-set-major this-line-indent-major this-line-chunk0)) - ;; Use the major mode at the beginning of since a sub chunk may - ;; start at start of line. - (if (mumamo-fun-eq this-line-major1 main-major) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;; In main major mode - ;; - ;; Take care of the case when all the text is in a - ;; sub chunk. In that case use the same indentation as if - ;; the code all belongs to the surrounding major mode. - (let ((here (point)) - (use-widen (mumamo-indent-use-widen main-major))) - ;; If we can't indent indent using the main major mode - ;; because it is only blanks and we should not widen, - ;; then use the indentation on the line where it starts. - (mumamo-msgindent " In main major mode") - (forward-line 0) - (skip-chars-backward " \t\n\r\f") - (forward-line 0) - (if (or use-widen (>= (point) (overlay-start this-line-chunk0))) - (progn - (goto-char here) - (mumamo-call-indent-line this-line-chunk0)) - (setq want-indent (current-indentation)) - (goto-char here)) - (mumamo-msgindent " In main major mode B") - (setq last-parent-major-indent (current-indentation))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;; In sub major mode - ;; - ;; Get the indentation the major mode alone would use: - ;;(setq got-indent (mumamo-get-major-mode-indent-column)) - ;; Since this line has another major mode than the - ;; previous line we instead want to indent relative to - ;; that line in a way decided in mumamo: - (mumamo-msgindent " In sub major mode") - (let ((chunk (mumamo-get-chunk-save-buffer-state (point))) - (font-lock-dont-widen t) - ind-zero - (here (point)) - ind-on-first-sub-line) - (save-restriction - (mumamo-update-obscure chunk here) - (let ((syn-min-max (mumamo-chunk-syntax-min-max chunk nil))) - (narrow-to-region (car syn-min-max) - (cdr syn-min-max))) - (condition-case nil - (atomic-change-group - (mumamo-call-indent-line (nth 0 this-line-chunks)) - (when (= 0 (current-indentation)) - (setq ind-zero t) - ;; It is maybe ok if indentation on first sub - ;; line is 0 so check that: - (goto-char (point-min)) - (widen) - (setq ind-on-first-sub-line (current-indentation)) - (goto-char here) - (signal 'mumamo-error-ind-0 nil))) - (mumamo-error-ind-0)) - ;; Unfortunately the indentation can sometimes get 0 - ;; here even though it is clear it should not be 0. This - ;; happens when there are only comments or empty lines - ;; above. - ;; - ;; See c:/test/erik-lilja-index.php for an example. - (when ind-zero ;(and t (= 0 (current-indentation))) - (save-excursion - (setq want-indent 0) - (unless (= 0 ind-on-first-sub-line) - ;;(while (and (> 500 (setq while-n2 (1+ while-n2))) - (while (and (mumamo-while 500 'while-n2 "want-indent") - (= 0 want-indent) - (/= (point) (point-min))) - (beginning-of-line 0) - (setq want-indent (current-indentation))) - ;; Now if want-indent is still 0 we need to look further above - (when (= 0 want-indent) - (widen) - ;;(while (and (> 500 (setq while-n3 (1+ while-n3))) - (while (and (mumamo-while 500 'while-n3 "want-indent 2") - (= 0 want-indent) - (/= (point) (point-min))) - (beginning-of-line 0) - (setq want-indent (current-indentation))) - ;; If we got to the main major mode we need to add - ;; the special submode offset: - (let* ((ovl (mumamo-get-chunk-save-buffer-state (point))) - (major (mumamo-chunk-major-mode ovl))) - (when (mumamo-fun-eq major main-major) - (setq want-indent (+ want-indent - (if (= 0 want-indent) - mumamo-submode-indent-offset-0 - mumamo-submode-indent-offset))))))))) - ))))) - (when want-indent - ;;(msgtrc "indent-line-to %s at line-beginning=%s" want-indent (line-beginning-position)) - (indent-line-to want-indent)) - ;; (when (and template-shift (/= 0 template-shift)) - ;; (let ((ind (+ (current-indentation) template-shift))) - ;; (indent-line-to ind))) - ;; (when template-indent-abs - ;; (indent-line-to template-indent-abs)) - (goto-char here-on-line) - ;;(msgtrc "exit: %s" (list this-line-chunks last-parent-major-indent)) - (list this-line-chunks last-parent-major-indent next-entering-submode))) - -;; Fix-me: use this for first line in a submode -;; Fix-me: check more carefully for widen since it may lead to bad results. -(defun mumamo-indent-use-widen (major-mode) - "Return non-nil if widen before indentation in MAJOR-MODE." - (let* ((specials (cadr (assoc major-mode mumamo-indent-widen-per-major))) - (use-widen (memq 'use-widen specials)) - (use-widen-maybe (assq 'use-widen specials))) - (or use-widen - (memq mumamo-multi-major-mode (cadr use-widen-maybe))))) -;;(mumamo-indent-use-widen 'php-mode) -;;(mumamo-indent-use-widen 'nxhtml-mode) -;;(mumamo-indent-use-widen 'html-mode) - -;; Fix-me: remove -;; (defun mumamo-indent-special-or-default (default-indent) -;; "Indent to DEFAULT-INDENT unless a special indent can be done." -;; (mumamo-with-major-mode-indentation major-mode -;; `(progn -;; (if (mumamo-indent-use-widen major-mode) -;; (save-restriction -;; (widen) -;; (mumamo-msgindent "=> special-or-default did widen, %s" major-mode) -;; (funcall indent-line-function)) -;; (indent-to-column default-indent))))) - -(defun mumamo-call-indent-line (chunk) - "Call the relevant `indent-line-function'." - ;;(msgtrc "call-indent-line %s, lbp=%s" chunk (line-beginning-position)) - (if nil - (mumamo-with-major-mode-indentation major-mode - `(save-restriction - (when (mumamo-indent-use-widen major-mode) - (mumamo-msgindent "=> indent-line did widen") - (widen)) - (funcall indent-line-function))) - (let ((maj (car mumamo-major-mode-indent-line-function)) - (fun (cdr mumamo-major-mode-indent-line-function))) - (assert (mumamo-fun-eq maj major-mode)) - (save-restriction - ;; (unless (mumamo-indent-use-widen major-mode) - ;; (let ((syn-min-max (mumamo-chunk-syntax-min-max chunk nil))) - ;; (narrow-to-region (car syn-min-max) (cdr syn-min-max)))) - (let ((mumamo-stop-widen (not (mumamo-indent-use-widen major-mode)))) - (if (not mumamo-stop-widen) - (widen) - (let ((syn-min-max (mumamo-chunk-syntax-min-max chunk nil))) - (narrow-to-region (car syn-min-max) (cdr syn-min-max)))) - ;;(msgtrc "call-indent-line fun=%s" fun) - ;;(funcall fun) - ;; Fix-me: Use mumamo-funcall-evaled to avoid (widen): - (mumamo-funcall-evaled fun) - ))))) - -(defvar mumamo-stop-widen nil) -(when nil - (let* ((fun 'describe-variable) - (lib (symbol-file fun 'defun))) - (find-function-search-for-symbol fun nil lib))) - -(defun mumamo-funcall-evaled (fun &rest args) - "Make sure FUN is evaled, then call it. -This make sure (currently) that defadvice for primitives are -called. They are not called in byte compiled code. - -See URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=5863' since -this may change." - (when mumamo-stop-widen - (unless (get fun 'mumamo-evaled) - (let* ((lib (symbol-file fun 'defun)) - (where (find-function-search-for-symbol fun nil lib)) - (buf (car where)) - (pos (cdr where))) - (with-current-buffer buf - (let ((close (and (not (buffer-modified-p)) - (= 1 (point))))) - ;;(goto-char pos) (eval-defun nil) - (msgtrc "mumamo-funcall-evaled %s" (current-buffer)) - (eval-buffer) - (when close (kill-buffer)))) - (put fun 'mumamo-evaled t)))) - (apply 'funcall fun args)) - -;;(require 'advice) -(defun mumamo-defadvice-widen () - (defadvice widen (around - mumamo-ad-widen - activate - compile - ) - (unless (and mumamo-multi-major-mode - mumamo-stop-widen) - ad-do-it))) -(eval-after-load 'mumamo - '(mumamo-defadvice-widen)) - -;; (defadvice font-lock-fontify-buffer (around -;; mumam-ad-font-lock-fontify-buffer -;; activate -;; compile -;; ) -;; (if mumamo-multi-major-mode -;; (save-restriction -;; (let* ((chunk (mumamo-find-chunks (point) "font-lock-fontify-buffer advice")) -;; (syn-min-max (mumamo-chunk-syntax-min-max chunk nil)) -;; (syn-min (car syn-min-max)) -;; (syn-max (cdr syn-min-max)) -;; (mumamo-stop-widen t)) -;; (narrow-to-region syn-min syn-max) -;; (font-lock-fontify-region syn-min syn-max))) -;; ad-do-it)) - -(defun mumamo-indent-region-function (start end) - "Indent the region between START and END." - (save-excursion - (setq end (copy-marker end)) - (goto-char start) - (let ((old-point -1) - prev-line-chunks - last-parent-major-indent - entering-submode-arg - ;; Turn off validation during indentation - (old-rng-validate-mode (when (boundp 'rng-validate-mode) rng-validate-mode)) - (rng-nxml-auto-validate-flag nil) - (nxhtml-use-imenu nil) - fontification-functions - rng-nxml-auto-validate-flag - (nxhtml-mode-hook (mumamo-get-hook-value - 'nxhtml-mode-hook - '(html-imenu-setup))) - ;; - (while-n1 0)) - (when old-rng-validate-mode (rng-validate-mode -1)) - ;;(while (and (> 3000 (setq while-n1 (1+ while-n1))) - (while (and (mumamo-while 3000 'while-n1 "indent-region") - (< (point) end) - (/= old-point (point))) - ;;(message "mumamo-indent-region-function, point=%s" (point)) - (or (and (bolp) (eolp)) - (let ((ret (mumamo-indent-line-function-1 - prev-line-chunks - last-parent-major-indent - entering-submode-arg))) - (setq prev-line-chunks (nth 0 ret)) - (setq last-parent-major-indent (nth 1 ret)) - (setq entering-submode-arg (nth 2 ret)))) - (setq old-point (point)) - (forward-line 1)) - (when old-rng-validate-mode (rng-validate-mode 1))) - (message "Ready indenting region"))) - - -(defun mumamo-fill-forward-paragraph-function(&optional arg) - "Function to move over paragraphs used by filling code. -This is the buffer local value of -`fill-forward-paragraph-function' when mumamo is used." - ;; fix-me: Do this chunk by chunk - ;; Fix-me: use this (but only in v 23) - (let* ((ovl (mumamo-get-chunk-save-buffer-state (point))) - (major (mumamo-chunk-major-mode ovl))) - (mumamo-with-major-mode-fontification major - fill-forward-paragraph-function))) - -(defun mumamo-fill-chunk (&optional justify) - "Fill each of the paragraphs in the current chunk. -Narrow to chunk region trimmed white space at the ends. Then -call `fill-region'. - -The argument JUSTIFY is the same as in `fill-region' and a prefix -behaves the same way as there." - (interactive (progn - (barf-if-buffer-read-only) - (list (if current-prefix-arg 'full)))) - (let* ((ovl (mumamo-get-chunk-save-buffer-state (point))) - (major (mumamo-chunk-major-mode ovl))) - ;; Fix-me: There must be some bug that makes it necessary to - ;; always change mode when fill-paragraph-function is - ;; c-fill-paragraph. - - ;;(unless (mumamo-fun-eq major major-mode) (mumamo-set-major major ovl)) - (mumamo-set-major major ovl) - - (save-restriction - (mumamo-update-obscure ovl (point)) - (let* ((syn-min-max (mumamo-chunk-syntax-min-max ovl nil)) - (syn-min (car syn-min-max)) - (syn-max (cdr syn-min-max)) - use-min - (here (point-marker))) - (goto-char syn-min) - (skip-syntax-forward " ") - ;; Move back over chars that have whitespace syntax but have the p flag. - (backward-prefix-chars) - (setq use-min (point)) - (goto-char syn-max) - (skip-syntax-backward " ") - (fill-region use-min (point) justify))))) - -;; (defvar mumamo-dont-widen) -;; (defadvice widen (around -;; mumamo-ad-widen -;; activate -;; disable -;; compile -;; ) -;; "Make `widen' do nothing. -;; This is for `mumamo-fill-paragraph-function' and is necessary -;; when `c-fill-paragraph' is the real function used." -;; (unless (and (boundp 'mumamo-dont-widen) -;; mumamo-dont-widen) -;; ad-do-it)) - -(defadvice flymake-display-warning (around - mumamo-ad-flymake-display-warning - activate - compile) - "Display flymake warnings in the usual Emacs way." - (let ((msg (ad-get-arg 0))) - ;; Fix-me: Can't get backtrace here. Report it. - ;;(setq msg (format (concat msg "\n%S" (with-output-to-string (backtrace))))) - (lwarn '(flymake) :error msg))) -;;(lwarn '(flymake) :error "the warning") - -(defun mumamo-forward-chunk () - "Move forward to next chunk." - (interactive) - (let* ((chunk (mumamo-get-chunk-save-buffer-state (point))) - (end-pos (overlay-end chunk))) - (goto-char (min end-pos - (point-max))))) - -(defun mumamo-backward-chunk () - "Move backward to previous chunk." - (interactive) - (let* ((chunk (mumamo-get-chunk-save-buffer-state (point))) - (start-pos (overlay-start chunk))) - (goto-char (max (1- start-pos) - (point-min))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Spell checking - -(defun mumamo-flyspell-verify () - "Function used for `flyspell-generic-check-word-predicate'." - (let* ((chunk (when mumamo-multi-major-mode - (mumamo-find-chunks (point) "mumamo-lyspell-verify"))) - (chunk-major (when chunk (mumamo-chunk-major-mode chunk))) - (mode-predicate (when chunk-major - (let ((predicate (get chunk-major - 'flyspell-mode-predicate))) - (if predicate - predicate - (if (mumamo-derived-from-mode chunk-major - 'text-mode) - nil - 'flyspell-generic-progmode-verify))))) - ) - (if mode-predicate - ;; Fix-me: (run-hooks 'flyspell-prog-mode-hook) - (funcall mode-predicate) - t))) - -;; (featurep 'cc-engine) -(eval-after-load 'cc-engine - (progn - ;; From Alan's mail 2009-12-03: C Mode: acceleration in brace - ;; deserts. - ;; Fix-me: Should they be here, or...? - (put 'c-state-cache 'permanent-local t) - (put 'c-state-cache-good-pos 'permanent-local t) - (put 'c-state-nonlit-pos-cache 'permanent-local t) - (put 'c-state-nonlit-pos-cache-limit 'permanent-local t) - (put 'c-state-brace-pair-desert 'permanent-local t) - (put 'c-state-point-min 'permanent-local t) - (put 'c-state-point-min-lit-type 'permanent-local t) - (put 'c-state-point-min-lit-start 'permanent-local t) - (put 'c-state-min-scan-pos 'permanent-local t) - (put 'c-state-old-cpp-beg 'permanent-local t) - (put 'c-state-old-cpp-end 'permanent-local t) - - )) - -;; Fix-me: Seems perhaps like c-state-point-min-lit-start is reset in -;; c-state-mark-point-min-literal because c-state-literal-at returns -;; nil. (Or is (car lit) nil?) - -(defvar mumamo-c-state-cache-init nil) -(make-variable-buffer-local 'mumamo-c-state-cache-init) -(put 'mumamo-c-state-cache-init 'permanent-local t) - -(defun mumamo-c-state-cache-init () - (unless mumamo-c-state-cache-init - ;;(msgtrc "c-state-cache-init running") - (setq mumamo-c-state-cache-init t) - (setq c-state-cache (or c-state-cache nil)) - (put 'c-state-cache 'permanent-local t) - (setq c-state-cache-good-pos (or c-state-cache-good-pos 1)) - (put 'c-state-cache-good-pos 'permanent-local t) - (setq c-state-nonlit-pos-cache (or c-state-nonlit-pos-cache nil)) - (put 'c-state-nonlit-pos-cache 'permanent-local t) - (setq c-state-nonlit-pos-cache-limit (or c-state-nonlit-pos-cache-limit 1)) - (put 'c-state-nonlit-pos-cache-limit 'permanent-local t) - (setq c-state-brace-pair-desert (or c-state-brace-pair-desert nil)) - (put 'c-state-brace-pair-desert 'permanent-local t) - (setq c-state-point-min (or c-state-point-min 1)) - (put 'c-state-point-min 'permanent-local t) - (setq c-state-point-min-lit-type (or c-state-point-min-lit-type nil)) - (put 'c-state-point-min-lit-type 'permanent-local t) - (setq c-state-point-min-lit-start (or c-state-point-min-lit-start nil)) - (put 'c-state-point-min-lit-start 'permanent-local t) - (setq c-state-min-scan-pos (or c-state-min-scan-pos 1)) - (put 'c-state-min-scan-pos 'permanent-local t) - (setq c-state-old-cpp-beg (or c-state-old-cpp-beg nil)) - (put 'c-state-old-cpp-beg 'permanent-local t) - (setq c-state-old-cpp-end (or c-state-old-cpp-end nil)) - (put 'c-state-old-cpp-end 'permanent-local t) - (c-state-mark-point-min-literal))) - -(defadvice c-state-cache-init (around - mumamo-ad-c-state-cache-init - activate - compile - ) - (if (not mumamo-multi-major-mode) - ad-do-it - (mumamo-c-state-cache-init))) - -;; Fix-me: Have to add per chunk local majors for this one. -(defun mumamo-c-state-literal-at (here) - ;; If position HERE is inside a literal, return (START . END), the - ;; boundaries of the literal (which may be outside the accessible bit of the - ;; buffer). Otherwise, return nil. - ;; - ;; This function is almost the same as `c-literal-limits'. It differs in - ;; that it is a lower level function, and that it rigourously follows the - ;; syntax from BOB, whereas `c-literal-limits' uses a "local" safe position. - (let* ((is-here (point)) - (s (syntax-ppss here)) - (ret (when (or (nth 3 s) (nth 4 s)) ; in a string or comment - (parse-partial-sexp (point) (point-max) - nil ; TARGETDEPTH - nil ; STOPBEFORE - s ; OLDSTATE - 'syntax-table) ; stop at end of literal - (cons (nth 8 s) (point))))) - (goto-char is-here) - ret)) - -;; (save-restriction -;; (widen) -;; (let* ((chunk (mumamo-find-chunks (point) "mumamo-c-state-literal-at")) -;; (syntax-min-max (mumamo-chunk-syntax-min-max chunk t))) -;; (narrow-to-region (car syntax-min-max) (cdr syntax-min-max))) -;; (save-excursion -;; (let ((c c-state-nonlit-pos-cache) -;; pos npos lit) -;; ;; Trim the cache to take account of buffer changes. -;; (while (and c (> (car c) c-state-nonlit-pos-cache-limit)) -;; (setq c (cdr c))) -;; (setq c-state-nonlit-pos-cache c) - -;; (while (and c (> (car c) here)) -;; (setq c (cdr c))) -;; (setq pos (or (car c) (point-min))) - -;; (while (<= (setq npos (+ pos c-state-nonlit-pos-interval)) -;; here) -;; (setq lit (c-state-pp-to-literal pos npos)) -;; (setq pos (or (cdr lit) npos)) ; end of literal containing npos. -;; (setq c-state-nonlit-pos-cache (cons pos c-state-nonlit-pos-cache))) - -;; (if (> pos c-state-nonlit-pos-cache-limit) -;; (setq c-state-nonlit-pos-cache-limit pos)) -;; (if (< pos here) -;; (setq lit (c-state-pp-to-literal pos here))) -;; lit)))) - - -(defadvice c-state-literal-at (around - mumamo-ad-c-state-state-literal-at - activate - compile - ) - (if (not mumamo-multi-major-mode) - ad-do-it - (mumamo-c-state-literal-at (ad-get-arg 0)))) - - -(defun mumamo-c-state-get-min-scan-pos () - ;; Return the lowest valid scanning pos. This will be the end of the - ;; literal enclosing point-min, or point-min itself. - (save-restriction - (save-excursion - (widen) - (mumamo-narrow-to-chunk-inner) - (or (and c-state-min-scan-pos - (>= c-state-min-scan-pos (point-min)) - c-state-min-scan-pos) - (if (not c-state-point-min-lit-start) - (goto-char (point-min)) - (goto-char c-state-point-min-lit-start) - (if (eq c-state-point-min-lit-type 'string) - (forward-sexp) - (forward-comment 1))) - (setq c-state-min-scan-pos (point)))))) - -(defadvice c-state-get-min-scan-pos (around - mumamo-ad-c-state-get-min-scan-pos-at - activate - compile - ) - (if (not mumamo-multi-major-mode) - ad-do-it - (setq ad-return-value (mumamo-c-state-get-min-scan-pos)))) - -(eval-after-load 'rng-match -;;; (defun rng-match-init-buffer () -;;; (make-local-variable 'rng-compile-table) -;;; (make-local-variable 'rng-ipattern-table) -;;; (make-local-variable 'rng-last-ipattern-index)) - (progn - (put 'rng-compile-table 'permanent-local t) - (put 'rng-ipattern-table 'permanent-local t) - (put 'rng-last-ipattern-index 'permanent-local t) - )) - -(eval-after-load 'flyspell - (progn - (put 'flyspell-mode 'permanent-local t) - - (put 'flyspell-generic-check-word-predicate 'permanent-local t) - - (put 'flyspell-casechars-cache 'permanent-local t) - (put 'flyspell-ispell-casechars-cache 'permanent-local t) - - (put 'flyspell-not-casechars-cache 'permanent-local t) - (put 'flyspell-ispell-not-casechars-cache 'permanent-local t) - - (put 'flyspell-auto-correct-pos 'permanent-local t) - (put 'flyspell-auto-correct-region 'permanent-local t) - (put 'flyspell-auto-correct-ring 'permanent-local t) - (put 'flyspell-auto-correct-word 'permanent-local t) - - (put 'flyspell-consider-dash-as-word-delimiter-flag 'permanent-local t) - - (put 'flyspell-dash-dictionary 'permanent-local t) - - (put 'flyspell-dash-local-dictionary 'permanent-local t) - - (put 'flyspell-word-cache-start 'permanent-local t) - (put 'flyspell-word-cache-end 'permanent-local t) - (put 'flyspell-word-cache-word 'permanent-local t) - (put 'flyspell-word-cache-result 'permanent-local t) - - (put 'flyspell-word-cache-start 'permanent-local t) - - - (put 'flyspell-kill-ispell-hook 'permanent-local-hook t) - (put 'flyspell-post-command-hook 'permanent-local-hook t) - (put 'flyspell-pre-command-hook 'permanent-local-hook t) - (put 'flyspell-after-change-function 'permanent-local-hook t) - (put 'flyspell-hack-local-variables-hook 'permanent-local-hook t) - (put 'flyspell-auto-correct-previous-hook 'permanent-local-hook t) - - (when mumamo-multi-major-mode - (when (featurep 'flyspell) - (setq flyspell-generic-check-word-predicate 'mumamo-flyspell-verify))) - )) - -(defun flyspell-mumamo-mode () - "Turn on function `flyspell-mode' for multi major modes." - (interactive) - (require 'flyspell) - (setq flyspell-generic-check-word-predicate 'mumamo-flyspell-verify) - (flyspell-mode 1) - ;;(run-hooks 'flyspell-prog-mode-hook) - ) - -(eval-after-load 'sgml-mode - (progn - (put 'sgml-tag-face-alist 'permanent-local t) - (put 'sgml-display-text 'permanent-local t) - (put 'sgml-tag-alist 'permanent-local t) - (put 'sgml-face-tag-alist 'permanent-local t) - (put 'sgml-tag-help 'permanent-local t) - )) - -(eval-after-load 'hl-line - (progn - (put 'hl-line-overlay 'permanent-local t) - )) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; New versions of syntax-ppss functions, temporary written as defadvice. - -(defadvice syntax-ppss-flush-cache (around - mumamo-ad-syntax-ppss-flush-cache - activate - compile - ) - "Support for mumamo. -See the defadvice for `syntax-ppss' for an explanation." - (if (not mumamo-multi-major-mode) - ad-do-it - (let ((pos (ad-get-arg 0))) - (let* ((chunk-at-pos (when (and (boundp 'mumamo-multi-major-mode) - mumamo-multi-major-mode) - (mumamo-find-chunks-1 pos "syntax-ppss-flush-cache")))) - (if chunk-at-pos - (let* ((syntax-ppss-last (overlay-get chunk-at-pos 'syntax-ppss-last)) - (syntax-ppss-cache (overlay-get chunk-at-pos 'syntax-ppss-cache))) - ;;(setq ad-return-value ad-do-it) - ad-do-it - (overlay-put chunk-at-pos 'syntax-ppss-last syntax-ppss-last) - (overlay-put chunk-at-pos 'syntax-ppss-cache syntax-ppss-cache)) - ;;(setq ad-return-value ad-do-it) - ad-do-it - ))))) - -(defvar mumamo-syntax-chunk-at-pos nil - "Internal use.") -(make-variable-buffer-local 'mumamo-syntax-chunk-at-pos) - -;; Fix-me: Is this really needed? -;; See http://lists.gnu.org/archive/html/emacs-devel/2008-04/msg00374.html -(defadvice syntax-ppss-stats (around - mumamo-ad-syntax-ppss-stats - activate - compile - ) - "Support for mumamo. -See the defadvice for `syntax-ppss' for an explanation." - (if mumamo-syntax-chunk-at-pos - (let* ((syntax-ppss-stats - (overlay-get mumamo-syntax-chunk-at-pos 'syntax-ppss-stats))) - ad-do-it - (overlay-put mumamo-syntax-chunk-at-pos 'syntax-ppss-stats syntax-ppss-stats)) - ad-do-it)) - -(defvar mumamo-syntax-ppss-major nil) - -;; FIX-ME: There is a problem with " in xhtml files, especially after -;; syntax="...". Looks like it is the " entry in -;; `sgml-font-lock-syntactic-keywords' that is jumping in! Dumping -;; things in `font-lock-apply-syntactic-highlight' seems to show that. -;; -;; (I have put in some dump code in my patched version of -;; Emacs+EmacsW32 there for that. This is commented out by default -;; and it will only work for the file nxhtml-changes.html which is big -;; enough for the problem to occur. It happens at point 1109.) -;; -;; It is this piece of code where the problem arise: -;; -;; (if (prog1 -;; (zerop (car (syntax-ppss (match-beginning 0)))) -;; (goto-char (match-end 0))) -;; .) -;; -;; -;; It comes from `sgml-font-lock-syntactic-keywords' in sgml-mode.el -;; and is supposed to protect from " that is not inside a tag. -;; However in this case for the second " in syntax="..." `syntax-ppss' -;; returns 0 as the first element in its return value. That happen -;; even though `major-mode' is correctly `html-mode'. It leads to -;; that the property 'syntax with the value (1) is added to the " -;; after the css-mode chunk in syntax="...". The problem persists -;; even if the chunk has `fundamental-mode' instead of `css-mode'. -;; -;; Bypassing the cache for `syntax-pss' by calling -;; `parse-partial-sexp' directly instead of doing ad-do-it (see -;; by-pass-chache in the code below) solves the problem for now. It -;; does not feel like the right solution however. -;; -;; One way of temporary solving the problem is perhaps to modify -;; `mumamo-chunk-attr=' to make "" borders, but I am not sure that it -;; works and it is the wrong solution. -(defadvice syntax-ppss (around - mumamo-ad-syntax-ppss - activate - compile - ) - "Support for mumamo chunks. -For each chunk store as properties of the chunk the parse state -that is normally hold in `syntax-ppss-last' and -`syntax-ppss-cache'. - -Compute the beginning parse state for a chunk this way: - -- If the chunk major mode is the same as the main major mode for - the multi major mode then parse from the beginning of the file - to the beginning of the chunk using the main major mode. While - doing that jump over chunks that do not belong to the main - major mode and cache the state at the end and beginning of the - the main major mode chunks. - -FIX-ME: implement above. Solution?: - (parse-partial-sexp syntax-min (1+ syntax-max) nil nil state-at-syntax-min) -Put this at next chunk's beginning. - -- Otherwise set the state at the beginning of the chunk to nil. - -Do here also other necessary adjustments for this." - (if (not mumamo-multi-major-mode) - ad-do-it - (let ((pos (ad-get-arg 0))) - (unless pos (setq pos (point))) - (let* ((chunk-at-pos (when (and (boundp 'mumamo-multi-major-mode) mumamo-multi-major-mode) - (mumamo-find-chunks-1 pos "syntax-ppss"))) - (dump2 (and (boundp 'dump-quote-hunt) - dump-quote-hunt - (boundp 'start) - ;;(= 1109 start) - ))) - ;;(setq dump2 t) - (setq mumamo-syntax-chunk-at-pos chunk-at-pos) - (when dump2 (msgtrc "\npos=%s point-min=%s mumamo-syntax-ppss.chunk-at-pos=%s" pos (point-min) chunk-at-pos)) - (if chunk-at-pos - (let* ((chunk-syntax-min-max (mumamo-chunk-syntax-min-max chunk-at-pos t)) - (chunk-syntax-min (car chunk-syntax-min-max)) - (chunk-major (mumamo-chunk-major-mode chunk-at-pos)) - (syntax-ppss-last (overlay-get chunk-at-pos 'syntax-ppss-last)) - (syntax-ppss-cache (overlay-get chunk-at-pos 'syntax-ppss-cache)) - (syntax-ppss-last-min (overlay-get chunk-at-pos 'syntax-ppss-last-min)) - (syntax-ppss-cache-min (list syntax-ppss-last-min)) - ;; This must be fetch the same way as in syntax-ppss: - (syntax-begin-function (overlay-get chunk-at-pos 'syntax-begin-function)) - (syntax-ppss-max-span (if chunk-syntax-min - (/ (- pos chunk-syntax-min -2) 2) - syntax-ppss-max-span)) - (syntax-ppss-stats (let ((stats (overlay-get chunk-at-pos 'syntax-ppss-stats))) - (if stats - stats - (default-value 'syntax-ppss-stats)))) - (last-min-pos (or (car syntax-ppss-last-min) - 1)) - ) - ;; If chunk has moved the cached values are invalid. - (unless (= chunk-syntax-min last-min-pos) - (setq syntax-ppss-last nil) - (setq syntax-ppss-last-min nil) - (setq syntax-ppss-cache nil) - (setq syntax-ppss-cache-min nil) - (setq syntax-ppss-stats (default-value 'syntax-ppss-stats))) - (when dump2 - (msgtrc " get syntax-ppss-last-min=%s len=%s chunk=%s" syntax-ppss-last-min (length syntax-ppss-last-min) chunk-at-pos) - (msgtrc " prop syntax-ppss-last-min=%s" (overlay-properties chunk-at-pos)) - (msgtrc " chunk-major=%s, %s, syntax-min=%s\n last-min=%s" chunk-major major-mode chunk-syntax-min syntax-ppss-last-min)) - ;;(setq dump2 nil) - (when syntax-ppss-last-min - (unless (car syntax-ppss-last-min) - ;;(msgtrc "fix-me: emacs bug workaround, setting car of syntax-ppss-last-min") - ;;(setcar syntax-ppss-last-min (1- chunk-syntax-min)) - ;;(msgtrc "fix-me: emacs bug workaround, need new syntax-ppss-last-min because car is nil") - (setq syntax-ppss-last-min nil) - )) - (unless syntax-ppss-last-min - (setq syntax-ppss-last nil) - (save-restriction - (widen) - (let* ((min-pos chunk-syntax-min) - (chunk-sub-major (mumamo-chunk-major-mode chunk-at-pos)) - (main-major (mumamo-main-major-mode)) - (is-main-mode-chunk (mumamo-fun-eq chunk-sub-major main-major))) - (when dump2 (msgtrc " min-pos=%s, is-main-mode-chunk=%s" min-pos is-main-mode-chunk)) - ;; Looks like assert can not be used here for some reason??? - ;;(assert (and min-pos) t) - (unless (and min-pos) (error "defadvice syntax-ppss: (and min-pos=%s)" min-pos)) - (setq syntax-ppss-last-min - (cons min-pos ;;(1- min-pos) - (if nil ;is-main-mode-chunk - ;; Fix-me: previous chunks as a - ;; cache? The problem is updating - ;; this. Perhaps it is possible to - ;; prune how far back to go by - ;; going to the first chunk - ;; backwards where - ;; (pars-partial-sexp min max) is - ;; "nil"? - (mumamo-with-major-mode-fontification main-major - `(parse-partial-sexp 1 ,min-pos nil nil nil nil)) - (parse-partial-sexp 1 1)))) - (setq syntax-ppss-cache-min (list syntax-ppss-last-min)) - (when dump2 (msgtrc " put syntax-ppss-last-min=%s len=%s chunk=%s" syntax-ppss-last-min (length syntax-ppss-last-min) chunk-at-pos)) - (when dump2 (msgtrc " prop syntax-ppss-last-min=%s" (overlay-properties chunk-at-pos))) - (overlay-put chunk-at-pos 'syntax-ppss-last-min syntax-ppss-last-min) - (let ((test-syntax-ppss-last-min - (overlay-get chunk-at-pos 'syntax-ppss-last-min))) - (when dump2 (msgtrc " test syntax-ppss-last-min=%s len=%s" test-syntax-ppss-last-min (length test-syntax-ppss-last-min))) - (when dump2 (msgtrc " propt syntax-ppss-last-min=%s" (overlay-properties chunk-at-pos))) - )))) - (when dump2 (msgtrc " here 0, syntax-ppss-last=%s" syntax-ppss-last)) - (unless syntax-ppss-last - (setq syntax-ppss-last syntax-ppss-last-min) - (setq syntax-ppss-cache syntax-ppss-cache-min)) - ;;(syntax-ppss pos) - (when dump2 (msgtrc " at 1, syntax-ppss-last=%s" syntax-ppss-last)) - (when dump2 (msgtrc " at 1, syntax-ppss-cache=%s" syntax-ppss-cache)) - (let (ret-val - (by-pass-cache t) - (dump2 dump2)) - (if (not by-pass-cache) - (progn - (when dump2 - (let ((old-ppss (cdr syntax-ppss-last)) - (old-pos (car syntax-ppss-last))) - ;;(assert (and old-pos pos) t) - (unless (and old-pos pos) (error "defadvice syntax-ppss: (and old-pos=%s pos=%s)" old-pos pos)) - (msgtrc "parse-partial-sexp=>%s" (parse-partial-sexp old-pos pos nil nil old-ppss)))) - (let (dump2) - (setq ret-val ad-do-it))) - (let ((old-ppss (cdr syntax-ppss-last)) - (old-pos (car syntax-ppss-last))) - (when dump2 - (msgtrc "Xparse-partial-sexp %s %s nil nil %s" old-pos pos old-ppss) - (let (dump2) - (msgtrc "ad-do-it=>%s" ad-do-it))) - (save-restriction - (widen) - ;;(assert (and old-pos pos) t) - (unless (and old-pos pos) (error "defadvice syntax-ppss 2 (and old-pos=%s pos=%s)" old-pos pos)) - (when dump2 - (msgtrc "parse-partial-sexp %s %s nil nil %s" old-pos pos old-ppss)) - (setq ret-val (parse-partial-sexp old-pos pos nil nil old-ppss))))) - (when dump2 (msgtrc " ==>ret-val=%s" ret-val)) - ;;(mumamo-backtrace "syntax-ppss") - (setq ad-return-value ret-val)) - (overlay-put chunk-at-pos 'syntax-ppss-last syntax-ppss-last) - (overlay-put chunk-at-pos 'syntax-ppss-cache syntax-ppss-cache) - (overlay-put chunk-at-pos 'syntax-ppss-stats syntax-ppss-stats) - ) - ad-do-it))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; rng-valid.el support - -;; Fix-me: The solution in this defadvice is temporary. The defadvice -;; for rng-do-some-validation should be fixed instead. -;; (ad-disable-advice 'rng-mark-error 'around 'mumamo-ad-rng-mark-error) -;; (ad-ensable-advice 'rng-mark-error 'around 'mumamo-ad-rng-mark-error) -(defadvice rng-mark-error (around - mumamo-ad-rng-mark-error - activate - compile) - "Adjust range for error to chunks." - (if (not mumamo-multi-major-mode) - ad-do-it - (let* ((beg (ad-get-arg 1)) - (end (ad-get-arg 2)) - (xml-parts nil) - (chunk (mumamo-find-chunks beg "rng-mark-error"))) - (if (not chunk) - ad-do-it - (when (and (not (overlay-get chunk 'mumamo-region)) - (mumamo-valid-nxml-chunk chunk)) - ;; rng-error - (let ((part-beg (max (overlay-start chunk) - beg)) - (part-end (min (overlay-end chunk) - end))) - (when (< part-beg part-end) - (ad-set-arg 1 part-beg) - (ad-set-arg 2 part-end) - ad-do-it))))))) - -(defadvice rng-do-some-validation-1 (around - mumamo-ad-rng-do-some-validation-1 - activate - compile) - "Adjust validation to chunks." - (if (not mumamo-multi-major-mode) - ad-do-it - (let (major-mode-chunk - (point-max (1+ (buffer-size))) ;(save-restriction (widen) (point-max))) - end-major-mode-chunk - (limit (+ rng-validate-up-to-date-end - rng-validate-chunk-size)) - (remove-start rng-validate-up-to-date-end) - (next-cache-point (+ (point) rng-state-cache-distance)) - (continue t) - (xmltok-dtd rng-dtd) - have-remaining-chars - xmltok-type - xmltok-start - xmltok-name-colon - xmltok-name-end - xmltok-replacement - xmltok-attributes - xmltok-namespace-attributes - xmltok-dependent-regions - xmltok-errors - (while-n1 0) - (while-n2 0) - (old-point -1) - ) - ;;(msgtrc "> > > > > enter rng-do-some-validation-1, continue-p-function=%s" continue-p-function) - (setq have-remaining-chars (< (point) point-max)) - (when (and continue (= (point) 1)) - (let ((regions (xmltok-forward-prolog))) - (rng-clear-overlays 1 (point)) - (while regions - (when (eq (aref (car regions) 0) 'encoding-name) - (rng-process-encoding-name (aref (car regions) 1) - (aref (car regions) 2))) - (setq regions (cdr regions)))) - (unless (equal rng-dtd xmltok-dtd) - (rng-clear-conditional-region)) - (setq rng-dtd xmltok-dtd)) - (setq while-n1 0) - (while (and (mumamo-while 2000 'while-n1 "continue") - (/= old-point (point)) - continue) - (setq old-point (point)) - ;; If mumamo (or something similar) is used then jump over parts - ;; that can not be parsed by nxml-mode. - (when (and rng-get-major-mode-chunk-function - rng-valid-nxml-major-mode-chunk-function - rng-end-major-mode-chunk-function) - (let ((here (point)) - next-non-space-pos) - (skip-chars-forward " \t\r\n") - (setq next-non-space-pos (point)) - (goto-char here) - (unless (and end-major-mode-chunk - ;; Remaining chars in this chunk? - (< next-non-space-pos end-major-mode-chunk)) - (setq end-major-mode-chunk nil) - (setq major-mode-chunk (funcall rng-get-major-mode-chunk-function next-non-space-pos "rng-do-some-validation-1 A")) - (setq while-n2 0) - (while (and (mumamo-while 500 'while-n2 "major-mode-chunk") - major-mode-chunk - (not (funcall rng-valid-nxml-major-mode-chunk-function major-mode-chunk)) - (< next-non-space-pos (point-max))) - ;;(msgtrc "next-non-space-pos=%s, cb=%s" next-non-space-pos (current-buffer)) - (let ((end-pos (funcall rng-end-major-mode-chunk-function major-mode-chunk))) - ;; fix-me: The problem here is that - ;; mumamo-find-chunks can return a 0-length chunk. - ;;(goto-char (+ end-pos 0)) - (goto-char (+ end-pos (if (= end-pos (point)) 1 0))) - (setq major-mode-chunk (funcall rng-get-major-mode-chunk-function (point) "rng-do-some-validation-1 B")) - ;;(message "---> here 3, point=%s, ep=%s, mm-chunk=%s" (point) end-pos major-mode-chunk) - ) - (setq next-non-space-pos (point)))) - ;; Stop parsing if we do not have a chunk here yet. - ;;(message "major-mode-chunk=%s" major-mode-chunk) - ;;(message "rng-valid-nxml-major-mode-chunk-function=%s" rng-valid-nxml-major-mode-chunk-function) - (setq continue (and major-mode-chunk - (funcall rng-valid-nxml-major-mode-chunk-function major-mode-chunk))) - ;;(unless continue (message "continue=nil, no major-mode-chunk")) - (when continue - ;;(message " continue=t") - (setq end-major-mode-chunk (funcall rng-end-major-mode-chunk-function major-mode-chunk))))) - - (when continue - ;; Narrow since rng-forward will continue into next chunk - ;; even if limit is at chunk end. - (if t - (progn - ;;(message "before rng-forward, point=%s" (point)) - (setq have-remaining-chars (rng-forward end-major-mode-chunk)) - ;;(message "after rng-forward, point=%s" (point)) - ) - ;; Fix-me: Validation does not work when narrowing because - ;; some state variables values seems to be lost. Probably - ;; looking at `rng-validate-prepare' will tell what to do. - (save-restriction - (when (and end-major-mode-chunk - (< (point-min) end-major-mode-chunk)) - (narrow-to-region (point-min) end-major-mode-chunk)) - (setq have-remaining-chars (rng-forward end-major-mode-chunk))) - (unless (> end-major-mode-chunk (point)) - ;;(setq have-remaining-chars t) - (goto-char end-major-mode-chunk)) - ) - ;;(message "end-major-mode-chunk=%s, rng-validate-up-to-date-end=%s" end-major-mode-chunk rng-validate-up-to-date-end) - (setq have-remaining-chars (< (point) point-max)) - ;;(unless have-remaining-chars (message "*** here have-remaining-chars=%s, p=%s/%s" have-remaining-chars (point) point-max)) - (let ((pos (point))) - (when end-major-mode-chunk - ;; Fix-me: Seems like we need a new initialization (or why - ;; do we otherwise hang without this?) - (and (> limit end-major-mode-chunk) (setq limit end-major-mode-chunk))) - (setq continue - (and have-remaining-chars - continue - (or (< pos limit) - (and continue-p-function - (funcall continue-p-function) - (setq limit (+ limit rng-validate-chunk-size)) - t)))) - ;;(unless continue (message "continue=nil, why?: %s<%s, %s" pos limit (when continue-p-function (funcall continue-p-function)))) - (cond ((and rng-conditional-up-to-date-start - ;; > because we are getting the state from (1- pos) - (> pos rng-conditional-up-to-date-start) - (< pos rng-conditional-up-to-date-end) - (rng-state-matches-current (get-text-property (1- pos) - 'rng-state))) - (when (< remove-start (1- pos)) - (rng-clear-cached-state remove-start (1- pos))) - ;; sync up with cached validation state - (setq continue nil) - ;; do this before settting rng-validate-up-to-date-end - ;; in case we get a quit - (rng-mark-xmltok-errors) - (rng-mark-xmltok-dependent-regions) - (setq rng-validate-up-to-date-end - (marker-position rng-conditional-up-to-date-end)) - (rng-clear-conditional-region) - (setq have-remaining-chars - (< rng-validate-up-to-date-end point-max)) - ;;(unless have-remaining-chars (message "have-remaining-chars=%s rng-validate-up-to-date-end=%s, point-max=%s" have-remaining-chars rng-validate-up-to-date-end point-max)) - ) - ((or (>= pos next-cache-point) - (not continue)) - (setq next-cache-point (+ pos rng-state-cache-distance)) - (rng-clear-cached-state remove-start pos) - (when have-remaining-chars - ;;(message "rng-cach-state (1- %s)" pos) - (rng-cache-state (1- pos))) - (setq remove-start pos) - (unless continue - ;; if we have just blank chars skip to the end - (when have-remaining-chars - (skip-chars-forward " \t\r\n") - (when (= (point) point-max) - (rng-clear-overlays pos (point)) - (rng-clear-cached-state pos (point)) - (setq have-remaining-chars nil) - ;;(message "have-remaining-chars => nil, cause (point) = point-max") - (setq pos (point)))) - (when (not have-remaining-chars) - (rng-process-end-document)) - (rng-mark-xmltok-errors) - (rng-mark-xmltok-dependent-regions) - (setq rng-validate-up-to-date-end pos) - (when rng-conditional-up-to-date-end - (cond ((<= rng-conditional-up-to-date-end pos) - (rng-clear-conditional-region)) - ((< rng-conditional-up-to-date-start pos) - (set-marker rng-conditional-up-to-date-start - pos)))))))))) - ;;(message "--- exit rng-do-some-validation-1, have-remaining-chars=%s" have-remaining-chars) - (setq have-remaining-chars (< (point) point-max)) - (setq ad-return-value have-remaining-chars)))) - -(defadvice rng-after-change-function (around - mumamo-ad-rng-after-change-function - activate - compile) - (when rng-validate-up-to-date-end - ad-do-it)) - -(defadvice rng-validate-while-idle (around - mumamo-ad-rng-validate-while-idle - activate - compile) - (if (not (buffer-live-p buffer)) - (rng-kill-timers) - ad-do-it)) - -(defadvice rng-validate-quick-while-idle (around - mumamo-ad-rng-validate-quick-while-idle - activate - compile) - (if (not (buffer-live-p buffer)) - (rng-kill-timers) - ad-do-it)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; xmltok.el - -;; (ad-disable-advice 'xmltok-add-error 'around 'mumamo-ad-xmltok-add-error) -;; (ad-ensable-advice 'xmltok-add-error 'around 'mumamo-ad-xmltok-add-error) -(defadvice xmltok-add-error (around - mumamo-ad-xmltok-add-error - activate - compile - ) - "Prevent rng validation errors in non-xml chunks. -This advice only prevents adding nxml/rng-valid errors in non-xml -chunks. Doing more seems like a very big job - unless Emacs gets -a narrow-to-multiple-regions function!" - (if (not mumamo-multi-major-mode) - ad-do-it - ;;(error "xmltok-add-error: %S" (with-output-to-string (backtrace))) - (when (let* ((start (or start xmltok-start)) - (end (or end (point))) - (chunk (mumamo-find-chunks (if start start end) "xmltok-add-error")) - ) - (or (not chunk) - (and (not (overlay-get chunk 'mumamo-region)) - (mumamo-valid-nxml-chunk chunk)))) - (setq xmltok-errors - (cons (xmltok-make-error message - (or start xmltok-start) - (or end (point))) - xmltok-errors))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Maybe activate advices - -;; Fix-me: This assumes there are no other advices on these functions. -(if t - (progn - ;; (ad-activate 'syntax-ppss) - ;; (ad-activate 'syntax-ppss-flush-cache) - ;; (ad-activate 'syntax-ppss-stats) - ;; (ad-activate 'rng-do-some-validation-1) - ;; (ad-activate 'rng-mark-error) - ;; (ad-activate 'xmltok-add-error) - (ad-enable-advice 'syntax-ppss 'around 'mumamo-ad-syntax-ppss) - (ad-enable-advice 'syntax-ppss-flush-cache 'around 'mumamo-ad-syntax-ppss-flush-cache) - (ad-enable-advice 'syntax-ppss-stats 'around 'mumamo-ad-syntax-ppss-stats) - (ad-enable-advice 'rng-do-some-validation-1 'around 'mumamo-ad-rng-do-some-validation-1) - (ad-enable-advice 'rng-mark-error 'around 'mumamo-ad-rng-mark-error) - (ad-enable-advice 'rng-after-change-function 'around 'mumamo-ad-rng-after-change-function) - (ad-enable-advice 'rng-validate-while-idle 'around 'mumamo-ad-rng-validate-while-idle) - (ad-enable-advice 'rng-validate-quick-while-idle 'around 'mumamo-ad-rng-validate-quick-while-idle) - (ad-enable-advice 'xmltok-add-error 'around 'mumamo-ad-xmltok-add-error) - ) - ;; (ad-deactivate 'syntax-ppss) - ;; (ad-deactivate 'syntax-ppss-flush-cache) - ;; (ad-deactivate 'syntax-ppss-stats) - ;; (ad-deactivate 'rng-do-some-validation-1) - ;; (ad-deactivate 'rng-mark-error) - ;; (ad-deactivate 'xmltok-add-error) - (ad-disable-advice 'syntax-ppss 'around 'mumamo-ad-syntax-ppss) - (ad-disable-advice 'syntax-ppss-flush-cache 'around 'mumamo-ad-syntax-ppss-flush-cache) - (ad-disable-advice 'syntax-ppss-stats 'around 'mumamo-ad-syntax-ppss-stats) - (ad-disable-advice 'rng-do-some-validation-1 'around 'mumamo-ad-rng-do-some-validation-1) - (ad-disable-advice 'rng-mark-error 'around 'mumamo-ad-rng-mark-error) - (ad-disable-advice 'rng-after-change-function 'around 'mumamo-ad-rng-after-change-function) - (ad-disable-advice 'rng-validate-while-idle 'around 'mumamo-ad-rng-validate-while-idle) - (ad-disable-advice 'rng-validate-quick-while-idle 'around 'mumamo-ad-rng-validate-quick-while-idle) - (ad-disable-advice 'xmltok-add-error 'around 'mumamo-ad-xmltok-add-error) - ) - -(font-lock-add-keywords - 'emacs-lisp-mode - '(("\\<define-mumamo-multi-major-mode\\>" . font-lock-keyword-face))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Simple defadvice to move into Emacs later - -(defun mumamo-ad-desktop-buffer-info (buffer) - (set-buffer buffer) - (list - ;; base name of the buffer; replaces the buffer name if managed by uniquify - (and (fboundp 'uniquify-buffer-base-name) (uniquify-buffer-base-name)) - ;; basic information - (desktop-file-name (buffer-file-name) desktop-dirname) - (buffer-name) - (if mumamo-multi-major-mode mumamo-multi-major-mode major-mode) - ;; minor modes - (let (ret) - (mapc - #'(lambda (minor-mode) - (and (boundp minor-mode) - (symbol-value minor-mode) - (let* ((special (assq minor-mode desktop-minor-mode-table)) - (value (cond (special (cadr special)) - ((functionp minor-mode) minor-mode)))) - (when value (add-to-list 'ret value))))) - (mapcar #'car minor-mode-alist)) - ret) - ;; point and mark, and read-only status - (point) - (list (mark t) mark-active) - buffer-read-only - ;; auxiliary information - (when (functionp desktop-save-buffer) - (funcall desktop-save-buffer desktop-dirname)) - ;; local variables - (let ((locals desktop-locals-to-save) - (loclist (buffer-local-variables)) - (ll)) - (while locals - (let ((here (assq (car locals) loclist))) - (if here - (setq ll (cons here ll)) - (when (member (car locals) loclist) - (setq ll (cons (car locals) ll))))) - (setq locals (cdr locals))) - ll))) - -(defadvice desktop-buffer-info (around - mumamo-ad-desktop-buffer-info - activate - compile) - (setq ad-return-value (mumamo-ad-desktop-buffer-info (ad-get-arg 0)))) - -(defun mumamo-ad-set-auto-mode-0 (mode &optional keep-mode-if-same) - "Apply MODE and return it. -If optional arg KEEP-MODE-IF-SAME is non-nil, MODE is chased of -any aliases and compared to current major mode. If they are the -same, do nothing and return nil." - (unless (and keep-mode-if-same - (eq (indirect-function mode) - (if mumamo-multi-major-mode - (indirect-function mumamo-multi-major-mode) - (indirect-function major-mode)))) - (when mode - (funcall mode) - mode))) - -(defadvice set-auto-mode-0 (around - mumamo-ad-set-auto-mode-0 - activate - compile) - (setq ad-return-value (mumamo-ad-set-auto-mode-0 (ad-get-arg 0) - (ad-get-arg 1) - ))) - - - -(defvar mumamo-sgml-get-context-last-close nil - "Last close tag start. -Only used for outermost level.") - -(defun mumamo-sgml-get-context (&optional until) - "Determine the context of the current position. -By default, parse until we find a start-tag as the first thing on a line. -If UNTIL is `empty', return even if the context is empty (i.e. -we just skipped over some element and got to a beginning of line). - -The context is a list of tag-info structures. The last one is the tag -immediately enclosing the current position. - -Point is assumed to be outside of any tag. If we discover that it's -not the case, the first tag returned is the one inside which we are." - (let ((here (point)) - (stack nil) - (ignore nil) - (context nil) - tag-info - last-close) - ;; CONTEXT keeps track of the tag-stack - ;; STACK keeps track of the end tags we've seen (and thus the start-tags - ;; we'll have to ignore) when skipping over matching open..close pairs. - ;; IGNORE is a list of tags that can be ignored because they have been - ;; closed implicitly. - ;; LAST-CLOSE is last close tag that can be useful for indentation - ;; when on outermost level. - (skip-chars-backward " \t\n") ; Make sure we're not at indentation. - (while - (and (not (eq until 'now)) - (or stack - (not (if until (eq until 'empty) context)) - (not (sgml-at-indentation-p)) - (and context - (/= (point) (sgml-tag-start (car context))) - (sgml-unclosed-tag-p (sgml-tag-name (car context))))) - (setq tag-info (ignore-errors (sgml-parse-tag-backward)))) - - ;; This tag may enclose things we thought were tags. If so, - ;; discard them. - (while (and context - (> (sgml-tag-end tag-info) - (sgml-tag-end (car context)))) - (setq context (cdr context))) - - (cond - ((> (sgml-tag-end tag-info) here) - ;; Oops!! Looks like we were not outside of any tag, after all. - (push tag-info context) - (setq until 'now)) - - ;; start-tag - ((eq (sgml-tag-type tag-info) 'open) - (when (and (null stack) - last-close) - (setq last-close 'no-use)) - (cond - ((null stack) - (if (assoc-string (sgml-tag-name tag-info) ignore t) - ;; There was an implicit end-tag. - nil - (push tag-info context) - ;; We're changing context so the tags implicitly closed inside - ;; the previous context aren't implicitly closed here any more. - ;; [ Well, actually it depends, but we don't have the info about - ;; when it doesn't and when it does. --Stef ] - (setq ignore nil))) - ((eq t (compare-strings (sgml-tag-name tag-info) nil nil - (car stack) nil nil t)) - (setq stack (cdr stack))) - (t - ;; The open and close tags don't match. - (if (not sgml-xml-mode) - (unless (sgml-unclosed-tag-p (sgml-tag-name tag-info)) - (message "Unclosed tag <%s>" (sgml-tag-name tag-info)) - (let ((tmp stack)) - ;; We could just assume that the tag is simply not closed - ;; but it's a bad assumption when tags *are* closed but - ;; not properly nested. - (while (and (cdr tmp) - (not (eq t (compare-strings - (sgml-tag-name tag-info) nil nil - (cadr tmp) nil nil t)))) - (setq tmp (cdr tmp))) - (if (cdr tmp) (setcdr tmp (cddr tmp))))) - (message "Unmatched tags <%s> and </%s>" - (sgml-tag-name tag-info) (pop stack))))) - - (if (and (null stack) (sgml-unclosed-tag-p (sgml-tag-name tag-info))) - ;; This is a top-level open of an implicitly closed tag, so any - ;; occurrence of such an open tag at the same level can be ignored - ;; because it's been implicitly closed. - (push (sgml-tag-name tag-info) ignore))) - - ;; end-tag - ((eq (sgml-tag-type tag-info) 'close) - (if (sgml-empty-tag-p (sgml-tag-name tag-info)) - (message "Spurious </%s>: empty tag" (sgml-tag-name tag-info)) - ;; Keep track of last close if context will return nil - (when (and (not last-close) - (null stack) - (> here (point-at-eol)) - (let ((here (point))) - (goto-char (sgml-tag-start tag-info)) - (skip-chars-backward " \t") - (prog1 - (bolp) - (goto-char here)))) - (setq last-close tag-info)) - - (push (sgml-tag-name tag-info) stack))) - )) - - ;; return context - (setq mumamo-sgml-get-context-last-close - (when (and last-close - (not (eq last-close 'no-use))) - (sgml-tag-start last-close))) - context)) - -(defadvice sgml-get-context (around - mumamo-ad-sgml-get-context - activate - compile) - (setq ad-return-value (mumamo-sgml-get-context (ad-get-arg 0)))) - -(defun mumamo-sgml-calculate-indent (&optional lcon) - "Calculate the column to which this line should be indented. -LCON is the lexical context, if any." - (unless lcon (setq lcon (sgml-lexical-context))) - - ;; Indent comment-start markers inside <!-- just like comment-end markers. - (if (and (eq (car lcon) 'tag) - (looking-at "--") - (save-excursion (goto-char (cdr lcon)) (looking-at "<!--"))) - (setq lcon (cons 'comment (+ (cdr lcon) 2)))) - - (case (car lcon) - - (string - ;; Go back to previous non-empty line. - (while (and (> (point) (cdr lcon)) - (zerop (forward-line -1)) - (looking-at "[ \t]*$"))) - (if (> (point) (cdr lcon)) - ;; Previous line is inside the string. - (current-indentation) - (goto-char (cdr lcon)) - (1+ (current-column)))) - - (comment - (let ((mark (looking-at "--"))) - ;; Go back to previous non-empty line. - (while (and (> (point) (cdr lcon)) - (zerop (forward-line -1)) - (or (looking-at "[ \t]*$") - (if mark (not (looking-at "[ \t]*--")))))) - (if (> (point) (cdr lcon)) - ;; Previous line is inside the comment. - (skip-chars-forward " \t") - (goto-char (cdr lcon)) - ;; Skip `<!' to get to the `--' with which we want to align. - (search-forward "--") - (goto-char (match-beginning 0))) - (when (and (not mark) (looking-at "--")) - (forward-char 2) (skip-chars-forward " \t")) - (current-column))) - - ;; We don't know how to indent it. Let's be honest about it. - (cdata nil) - ;; We don't know how to indent it. Let's be honest about it. - (pi nil) - - (tag - (goto-char (1+ (cdr lcon))) - (skip-chars-forward "^ \t\n") ;Skip tag name. - (skip-chars-forward " \t") - (if (not (eolp)) - (current-column) - ;; This is the first attribute: indent. - (goto-char (1+ (cdr lcon))) - (+ (current-column) sgml-basic-offset))) - - (text - (while (looking-at "</") - (forward-sexp 1) - (skip-chars-forward " \t")) - (let* ((here (point)) - (unclosed (and ;; (not sgml-xml-mode) - (looking-at sgml-tag-name-re) - (assoc-string (match-string 1) - sgml-unclosed-tags 'ignore-case) - (match-string 1))) - (context - ;; If possible, align on the previous non-empty text line. - ;; Otherwise, do a more serious parsing to find the - ;; tag(s) relative to which we should be indenting. - (if (and (not unclosed) (skip-chars-backward " \t") - (< (skip-chars-backward " \t\n") 0) - (back-to-indentation) - (> (point) (cdr lcon))) - nil - (goto-char here) - (nreverse (sgml-get-context (if unclosed nil 'empty))))) - (there (point))) - ;; Ignore previous unclosed start-tag in context. - (while (and context unclosed - (eq t (compare-strings - (sgml-tag-name (car context)) nil nil - unclosed nil nil t))) - (setq context (cdr context))) - ;; Indent to reflect nesting. - (cond - ;; If we were not in a text context after all, let's try again. - ((and context (> (sgml-tag-end (car context)) here)) - (goto-char here) - (sgml-calculate-indent - (cons (if (memq (sgml-tag-type (car context)) '(comment cdata)) - (sgml-tag-type (car context)) 'tag) - (sgml-tag-start (car context))))) - ;; Align on the first element after the nearest open-tag, if any. - ((and context - (goto-char (sgml-tag-end (car context))) - (skip-chars-forward " \t\n") - (< (point) here) (sgml-at-indentation-p)) - (current-column)) - (t - (goto-char (or (and (null context) - mumamo-sgml-get-context-last-close) - there)) - (+ (current-column) - (* sgml-basic-offset (length context))))))) - - (otherwise - (error "Unrecognized context %s" (car lcon))) - - )) - -(defadvice sgml-calculate-indent (around - mumamo-ad-sgml-calculate-indent - activate - compile) - (setq ad-return-value (mumamo-sgml-calculate-indent (ad-get-arg 0)))) - -(defadvice python-eldoc-function (around - mumamo-ad-python-eldoc-function - activate - compile) - (if (not mumamo-multi-major-mode) - ad-do-it - (let ((here (point))) - (unwind-protect - (save-restriction - (mumamo-narrow-to-chunk-inner) - ad-do-it) - (goto-char here))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; The END -;;(when buffer-file-name (message "Finished evaluating %s" buffer-file-name)) -;;(when load-file-name (message "Finished loading %s" load-file-name)) - -(provide 'mumamo) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; mumamo.el ends bere diff --git a/emacs.d/nxhtml/util/n-back.el b/emacs.d/nxhtml/util/n-back.el deleted file mode 100644 index 024b8e6..0000000 --- a/emacs.d/nxhtml/util/n-back.el +++ /dev/null @@ -1,1296 +0,0 @@ -;;; n-back.el --- n-back game -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2009-05-23 Sat -(defconst n-back:version "0.5");; Version: -;; Last-Updated: 2009-08-04 Tue -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; `winsize'. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; n-back game for brain training. See `n-back-game' for more -;; information. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -;;(eval-when-compile (require 'viper)) - -;; (setq n-back-trials 2) -(eval-when-compile (require 'cl)) -(eval-when-compile (require 'nxhtml-base nil t)) -(eval-when-compile (require 'nxhtml-web-vcs nil t)) -(require 'winsize nil t) ;; Ehum... - -(defvar n-back-game-window nil) -(defvar n-back-game-buffer nil) - -(defvar n-back-ctrl-window nil) -(defvar n-back-ctrl-buffer nil) - -(defvar n-back-info-window nil) -(defvar n-back-info-buffer nil) - -(defvar n-back-trials-left nil) -(defvar n-back-timer nil) -(defvar n-back-clear-timer nil) - -(defvar n-back-result nil) -(defvar n-back-this-result nil) - -(defvar n-back-ring nil) - -(defvar n-back-num-active nil) - - -;;;###autoload -(defgroup n-back nil - "Customizations for `n-back-game' game." - :group 'games) - -(defgroup n-back-feel nil - "Customizations for `n-back-game' game keys, faces etc." - :group 'n-back) - -(defface n-back-ok - '((t (:foreground "black" :background "green"))) - "Face for OK answer." - :group 'n-back-feel) - -(defface n-back-bad - '((t (:foreground "black" :background "OrangeRed1"))) - "Face for bad answer." - :group 'n-back-feel) - -(defface n-back-hint - '((t (:foreground "black" :background "gold"))) - "Face for bad answer." - :group 'n-back-feel) - -(defface n-back-do-now - '((((background dark)) (:foreground "yellow")) - (t (:foreground "blue"))) - "Face for start and stop hints." - :group 'n-back-feel) - -(defface n-back-game-word - '((t (:foreground "black"))) - "Face for word displayed in game." - :group 'n-back-feel) - -(defface n-back-header - '((((background dark)) (:background "OrangeRed4")) - (t (:background "gold"))) - "Face for headers." - :group 'n-back-feel) - -(defface n-back-keybinding - '((((background dark)) (:background "purple4")) - (t (:background "OliveDrab1"))) - "Face for key bindings." - :group 'n-back-feel) - -(defface n-back-last-result - '((((background dark)) (:background "OliveDrab4")) - (t (:background "yellow"))) - "Face for last game result header." - :group 'n-back-feel) - -(defface n-back-welcome - '((((background dark)) (:foreground "OliveDrab3")) - (t (:foreground "OliveDrab4"))) - "Face for welcome string" - :group 'n-back-feel) - -(defface n-back-welcome-header - '((t (:height 2.0))) - "Face for welcome header." - :group 'n-back-feel) - -(defcustom n-back-level 1 - "The n-Back level." - :type '(radio (const 1) - (const 2) - (const 3) - (const 4)) - :set (lambda (sym val) - (set-default sym val) - (when (featurep 'n-back) - (n-back-update-control-buffer) - (n-back-update-info))) - :group 'n-back) - -(defcustom n-back-active-match-types '(position color sound) - "Active match types." - :type '(set (const position) - (const color) - (const sound) - (const word)) - :set (lambda (sym val) - (set-default sym val) - (setq n-back-num-active (length val)) - (when (featurep 'n-back) - (n-back-init-control-status) - (n-back-update-control-buffer) - (n-back-update-info))) - :group 'n-back) - -(defcustom n-back-allowed-match-types '(position color sound word) - "Match types allowed in auto challenging." - :type '(set (const position) - (const color) - (const sound) - (const word)) - :set (lambda (sym val) - (set-default sym val) - (when (featurep 'n-back) - (n-back-set-random-match-types (length n-back-active-match-types) nil) - (n-back-init-control-status) - (n-back-update-control-buffer) - (n-back-update-info))) - :group 'n-back) - -(defcustom n-back-auto-challenge t - "Automatic challenge decrease/increase." - :type 'boolean - :group 'n-back) - -(defun n-back-toggle-auto-challenge () - "Toggle `n-back-auto-challenge'." - (interactive) - (let ((val (not n-back-auto-challenge))) - (customize-set-variable 'n-back-auto-challenge val) - (customize-set-value 'n-back-auto-challenge val))) - -(defcustom n-back-colors - '("gold" "orange red" "lawn green" "peru" "pink" "gray" "light blue") - "Random colors to display." - :type '(repeat color) - :group 'n-back) - -(defcustom n-back-words "you cat going me forest crying brown" - "Random words to display." - :type 'string - :group 'n-back) - -(defcustom n-back-sound-volume 0.2 - "Sound volume 0-1." - :type 'float - :group 'n-back-feel) - -(defcustom n-back-sounds '("c:/program files/brain workshop/res" "piano-") - "Random sounds location." - :type '(list (directory :tag "Directory") - (regexp :tag "File name regexp")) - :group 'n-back) - -(defcustom n-back-keys - '( - [?p] - [?c] - [?s] - [?w] - ) - "Key bindings for answering." - :type '(list - (key-sequence :tag "position key") - (key-sequence :tag "color key") - (key-sequence :tag "sound key") - (key-sequence :tag "word key") - ) - ;; :set (lambda (sym val) - ;; (set-default sym val) - ;; (n-back-make-keymap)) - :group 'n-back-feel) - -(defvar n-back-control-mode-map nil) - -(defun n-back-key-binding (what) - "Return key binding used for WHAT match answers." - (nth - (case what - (position 0) - (color 1) - (sound 2) - (word 3)) - n-back-keys)) - -(defun n-back-make-keymap () - "Make keymap for the game." - (let ((map (make-sparse-keymap))) - (define-key map [?1] 'n-back-change-level) - (define-key map [?2] 'n-back-change-level) - (define-key map [?3] 'n-back-change-level) - (define-key map [?4] 'n-back-change-level) - (define-key map [?5] 'n-back-change-level) - (define-key map [?6] 'n-back-change-level) - (define-key map [??] 'n-back-help) - (define-key map [?\ ] 'n-back-play) - (define-key map [(control ?g)] 'n-back-stop) - (define-key map [?-] 'n-back-decrease-speed) - (define-key map [?+] 'n-back-increase-speed) - - (define-key map [(control ?r)] 'n-back-reset-game-to-saved) - (define-key map [(control ?s)] 'n-back-save-game-settings) - - (define-key map [?t ?p] 'n-back-toggle-position) - (define-key map [?t ?c] 'n-back-toggle-color) - (define-key map [?t ?s] 'n-back-toggle-sound) - (define-key map [?t ?w] 'n-back-toggle-word) - - (define-key map [?T ?a] 'n-back-toggle-auto-challenge) - (define-key map [up] 'n-back-challenge-up) - (define-key map [down] 'n-back-challenge-down) - - (define-key map [?T ?p] 'n-back-toggle-allowed-position) - (define-key map [?T ?c] 'n-back-toggle-allowed-color) - (define-key map [?T ?s] 'n-back-toggle-allowed-sound) - (define-key map [?T ?w] 'n-back-toggle-allowed-word) - - (define-key map (n-back-key-binding 'position) 'n-back-position-answer) - (define-key map (n-back-key-binding 'color) 'n-back-color-answer) - (define-key map (n-back-key-binding 'sound) 'n-back-sound-answer) - (define-key map (n-back-key-binding 'word) 'n-back-word-answer) - ;;(define-key map [t] 'ignore) - (setq n-back-control-mode-map map))) - -(defvar n-back-display-hint nil) -(defcustom n-back-hint t - "Display hints - learning mode." - :type 'boolean - :group 'n-back) - - - -(defvar n-back-sound-files nil) -;;(n-back-get-sound-files) -(defun n-back-get-sound-files () - "Get sound file names." - (let ((dir (nth 0 n-back-sounds)) - (regexp (nth 1 n-back-sounds))) - (when (file-directory-p dir) - (setq n-back-sound-files (directory-files dir nil regexp))))) - -(defun n-back-toggle-position () - "Toggle use of position in `n-back-active-match-types'." - (interactive) - (n-back-toggle 'position)) - -(defun n-back-toggle-color () - "Toggle use of color in `n-back-active-match-types'." - (interactive) - (n-back-toggle 'color)) - -(defun n-back-toggle-sound () - "Toggle use of sound in `n-back-active-match-types'." - (interactive) - (n-back-toggle 'sound)) - -(defun n-back-toggle-word () - "Toggle use of word in `n-back-active-match-types'." - (interactive) - (n-back-toggle 'word)) - -(defun n-back-toggle (match-type) - "Toggle use of MATCH-TYPE in `n-back-active-match-types'." - (n-back-toggle-1 match-type 'n-back-active-match-types)) - -(defun n-back-toggle-allowed-position () - "Toggle use of position in `n-back-allowed-match-types'." - (interactive) - (n-back-toggle-allowed 'position)) - -(defun n-back-toggle-allowed-color () - "Toggle use of color in `n-back-allowed-match-types'." - (interactive) - (n-back-toggle-allowed 'color)) - -(defun n-back-toggle-allowed-sound () - "Toggle use of sound in `n-back-allowed-match-types'." - (interactive) - (n-back-toggle-allowed 'sound)) - -(defun n-back-toggle-allowed-word () - "Toggle use of word in `n-back-allowed-match-types'." - (interactive) - (n-back-toggle-allowed 'word)) - -(defun n-back-toggle-allowed (match-type) - "Toggle use of MATCH-TYPE in `n-back-allowed-match-types'." - (n-back-toggle-1 match-type 'n-back-allowed-match-types)) - -(defun n-back-sort-types (types) - "Sort TYPES to order used in defcustoms here." - (sort types - (lambda (a b) - (let ((all '(position color sound word))) - (< (length (memq a all)) - (length (memq b all))))))) - -(defun n-back-toggle-1 (match-type active-list-sym) - "Toggle use of MATCH-TYPE in list ACTIVE-LIST-SYM." - (let (active-types) - (if (memq match-type (symbol-value active-list-sym)) - (setq active-types (delq match-type (symbol-value active-list-sym))) - (setq active-types (cons match-type (symbol-value active-list-sym)))) - (setq active-types (n-back-sort-types active-types)) - (customize-set-variable active-list-sym active-types) - (customize-set-value active-list-sym active-types))) - -(defcustom n-back-sec-per-trial 3.0 - "Seconds per trial." - :type 'float - :set (lambda (sym val) - (set-default sym val) - (when (featurep 'n-back) - (n-back-update-info))) - :group 'n-back) - -(defun n-back-decrease-speed () - "Decrease speed of trials." - (interactive) - (setq n-back-sec-per-trial (+ n-back-sec-per-trial 0.25)) - (when (> n-back-sec-per-trial 5.0) - (setq n-back-sec-per-trial 5.0)) - (n-back-update-info)) - -(defun n-back-increase-speed () - "Increase speed of trials." - (interactive) - (let ((sec (- n-back-sec-per-trial 0.25))) - (when (< sec 1.0) - (setq sec 1.0)) - (customize-set-variable 'n-back-sec-per-trial sec) - (customize-set-value 'n-back-sec-per-trial sec))) - -(defun n-back-help () - "Show help for `n-back-game' game." - (interactive) - (save-selected-window - (describe-function 'n-back-game))) - -(defun n-back-change-level (level) - "Change n-Back level to LEVEL." - (interactive (progn - (if (and (numberp last-input-event) - (>= last-input-event ?1) - (<= last-input-event ?9)) - (list (- last-input-event ?0)) - (list (string-to-number (read-string "n Back: ")))))) - (customize-set-variable 'n-back-level level) - (customize-set-value 'n-back-level level)) - -(defvar n-back-frame nil) - -;;;###autoload -(defun n-back-game () - "Emacs n-Back game. -This game is supposed to increase your working memory and fluid -intelligence. - -In this game something is shown for half a second on the screen -and maybe a sound is played. You should then answer if parts of -it is the same as you have seen or heard before. This is -repeated for about 20 trials. - -You answer with the keys shown in the bottom window. - -In the easiest version of the game you should answer if you have -just seen or heard what is shown now. By default the game gets -harder as you play it with success. Then first the number of -items presented in a trial grows. After that it gets harder by -that you have to somehow remember not the last item, but the item -before that \(or even earlier). That is what \"n-Back\" stands -for. - -Note that remember does not really mean remember clearly. The -game is for training your brain getting used to keep those things -in the working memory, maybe as a cross-modal unit. You are -supposed to just nearly be able to do what you do in the game. -And you are supposed to have fun, that is what your brain like. - -You should probably not overdue this. Half an hour a day playing -might be an optimal time according to some people. - -The game is shamelessly modeled after Brain Workshop, see URL -`http://brainworkshop.sourceforge.net/' just for the fun of -getting it into Emacs. The game resembles but it not the same as -that used in the report by Jaeggi mentioned at the above URL. - -Not all features in Brain Workshop are implemented here, but some -new are maybe ... - and you have it available here in Emacs." - ;; ----- - ;; Below is a short excerpt from the report by Jaeggi et al which - ;; gave the idea to the game: - - ;; Training task. For the training task, we used the same material - ;; as described by Jaeggi et al. (33), which was a dual n-Back task - ;; where squares at eight different locations were presented - ;; sequentially on a computer screen at a rate of 3 s (stimulus - ;; length, 500 ms; interstimulus interval, 2,500 ms). - ;; Simultaneously with the presentation of the squares, one of eight - ;; consonants was presented sequentially through headphones. A - ;; response was required whenever one of the presented stimuli - ;; matched the one presented n positions back in the sequence. The - ;; value of n was the same for both streams of stimuli. There were - ;; six auditory and six visual targets per block (four appearing in - ;; only one modality, and two appearing in both modalities - ;; simultaneously), and their positions were determined randomly. - ;; Participants made responses manually by pressing on the letter - ;; ‘‘A’’ of a standard keyboard with their left index finger for - ;; visual targets, and on the letter ‘‘L’’ with their right index - ;; finger for auditory targets. No responses were required for - ;; non-targets. - (interactive) - (n-back-make-keymap) - (when window-system - (unless (frame-live-p n-back-frame) - (setq n-back-frame (make-frame - (list '(name . "n-back game") - '(tool-bar-lines . 0) - '(menu-bar-lines . 0) - (case (frame-parameter nil 'background-mode) - (light '(background-color . "cornsilk")) - (dark '(background-color . "MidnightBlue")) - (otherwise nil)) - '(height . 45) - '(width . 150))))) - (select-frame n-back-frame) - (raise-frame n-back-frame)) - (n-back-cancel-timers) - (n-back-get-sound-files) - (unless n-back-sound-files - (when (memq 'sound n-back-allowed-match-types) - (n-back-toggle-allowed-sound)) - (when (memq 'sound n-back-active-match-types) - (n-back-toggle-sound))) - (n-back-init-control-status) - (n-back-setup-windows) - ) - -(defconst n-back-match-types - '((position ": position match" nil) - (color ": color match" nil) - (sound ": sound match" nil) - (word ": word match" nil) - )) - -(defvar n-back-control-status nil - "For showing status in control window.") -(setq n-back-control-status nil) - -;;(n-back-set-match-status 'position 'bad) -(defun n-back-set-match-status (match-type status) - "Set MATCH-TYPE status to STATUS for control window." - (unless (memq status '(ok bad miss nil)) (error "n-back: Bad status=%s" status)) - (let ((entry (assoc match-type n-back-control-status))) - (setcar (cddr entry) status) - )) - -;;(n-back-clear-match-status) -(defun n-back-clear-match-status () - "Clear match status for control window." - ;;(dolist (entry n-back-control-status) - (dolist (entry n-back-match-types) - (setcar (cddr entry) nil) - )) - -;; (n-back-init-control-status) -(defun n-back-init-control-status () - "Init match status for control window." - (setq n-back-control-status nil) - (dolist (what n-back-active-match-types) - (setq n-back-control-status - (cons (assoc what n-back-match-types) - n-back-control-status)))) - -(defsubst n-back-is-playing () - "Return non-nil when game is active." - (timerp n-back-timer)) - -;;(n-back-update-control-buffer) -(defun n-back-update-control-buffer () - "Update content of control buffer." - (save-match-data ;; runs in timer - (when (buffer-live-p n-back-ctrl-buffer) - (with-current-buffer n-back-ctrl-buffer - (setq buffer-read-only nil) - (erase-buffer) - (insert (propertize (format "%s %s-back" - (let ((n (length n-back-active-match-types))) - (cond - ((= 1 n) "Single") - ((= 2 n) "Dual") - ((= 3 n) "Triple") - )) - n-back-level - ) 'face 'n-back-header) - (propertize - (if (n-back-is-playing) " Press C-g to stop" " Press SPACE to play") - 'face 'n-back-do-now) - (if (n-back-is-playing) (format " Left %s" n-back-trials-left) "") - "\n") - ;;(unless n-back-control-status (n-back-init-control-status)) - (dolist (entry n-back-control-status) - (let* ((what (nth 0 entry)) - (msg (nth 1 entry)) - (sts (nth 2 entry)) - (key (key-description (n-back-key-binding what)))) - ;;(setq msg (concat (key-description (n-back-key-binding what)) msg)) - (cond - ((eq sts 'bad) - (setq msg (propertize (concat key msg) 'face 'n-back-bad))) - ((eq sts 'ok) - (setq msg (propertize (concat key msg) 'face 'n-back-ok))) - ((eq sts 'miss) - (setq msg (concat - (if n-back-display-hint - (propertize key 'face 'n-back-header) - key) - msg))) - ((not sts) - (setq msg (concat key msg))) - (t - (error "n-back:Unknown sts=%s" sts) - )) - (insert msg " ")) - ) - (when n-back-display-hint - (setq n-back-display-hint nil) - (run-with-timer 0.1 nil 'n-back-update-control-buffer)) - (setq buffer-read-only t) - (if (window-live-p n-back-ctrl-window) - (with-selected-window n-back-ctrl-window - (goto-char 1)) - (goto-char 1)))))) - -(defcustom n-back-trials 20 - "Number of trials per session." - :type 'integer - :group 'n-back) - -;;(n-back-compute-result-values n-back-result) -(defvar n-back-result-values nil) -(defun n-back-compute-single-result-value (entry) - "Compute result stored in ENTRY." - (let* ((what (nth 0 entry)) - (good (nth 1 entry)) - (bad (nth 2 entry)) - (miss (nth 3 entry)) - (err (+ bad miss)) - ;;(tot (+ good bad miss 0.0)) - ;;(gnum 6) - ;;(weighted-err (* err (/ gnum tot))) - ) - (cons what (if (= 0 good) - 0 - (/ (- n-back-trials err 0.0) - n-back-trials))))) - -(defun n-back-compute-result-values (result) - "Compute result values from game result RESULT." - (let ((results nil)) - (dolist (entry result) - (let ((res (n-back-compute-single-result-value entry))) - (setq results (cons res results)))) - (setq n-back-result-values (reverse results)))) - -;; Thresholds -(defun n-back-view-threshold-discussion-page () - "View some discussion of threshold." - (interactive) - (browse-url "http://groups.google.com/group/brain-training/browse_thread/thread/f4bfa452943c2a2d/ba31adfd0b97771c?lnk=gst&q=threshold#ba31adfd0b97771c")) - -;;(n-back-set-next-challenge) -(defvar n-back-worst nil) - -(defvar n-back-challenge-change nil) - -(defun n-back-set-next-challenge () - "Set next game difficulty level from last game result." - (let ((r 2.8)) ;; stay as default - (setq n-back-worst nil) - (dolist (res n-back-result-values) - (when (< (cdr res) r) - (setq r (cdr res)) - (setq n-back-worst res))) - (setq n-back-challenge-change (if (< r 0.74) - 'down - (if (> r 0.91) - 'up - 'stay))) - (n-back-change-challenge n-back-challenge-change))) - -(defun n-back-challenge-up () - "Make the game harder." - (interactive) - (n-back-change-challenge 'up)) - -(defun n-back-challenge-down () - "Make the game easier." - (interactive) - (n-back-change-challenge 'down)) - -(defun n-back-change-challenge (challenge-change) - "Change game difficulty level by CHALLENGE-CHANGE." - (let ((new-level n-back-level) - (new-num-active n-back-num-active) - (num-allowed (length n-back-allowed-match-types))) - (case challenge-change - (down - (if (= 1 n-back-num-active) - (unless (= 1 n-back-level) - (setq new-num-active (min 3 num-allowed)) - (setq new-level (1- n-back-level))) - (setq new-num-active (1- n-back-num-active)))) - (up - (if (or (<= 3 n-back-num-active) - (<= num-allowed n-back-num-active)) - (progn - (setq new-level (1+ n-back-level)) - (setq new-num-active 1)) - (setq new-num-active (min 3 (1+ n-back-num-active)))))) - ;;(when (= new-level 0) (setq new-level 1)) - ;;(when (= new-num-active 0) (setq new-num-active 1)) - (when (and (= new-level n-back-level) - (= new-num-active n-back-num-active)) - (setq n-back-challenge-change 'stay)) - (unless (= new-level n-back-level) - (customize-set-variable 'n-back-level new-level) - (customize-set-value 'n-back-level new-level)) - (n-back-set-random-match-types new-num-active (car n-back-worst)))) - -(defun n-back-set-random-match-types (num worst) - "Select NUM random match types. -If type WORST is non-nil try to include that." - (let ((alen (length n-back-allowed-match-types)) - (old-types n-back-active-match-types) - types) - (unless (<= num alen) - (error "n-back: Too many match types required = %s" num)) - (when (and worst - (< 1 num) - (memq worst n-back-allowed-match-types)) - (add-to-list 'types worst)) - (while (< (length types) num) - (add-to-list 'types (nth (random alen) n-back-allowed-match-types))) - (setq types (n-back-sort-types types)) - (unless (equal old-types types) - (customize-set-variable 'n-back-active-match-types types) - (customize-set-value 'n-back-active-match-types types)))) - -;; (defcustom n-back-keybinding-color "OliveDrab1" -;; "Background color for key binding hints." -;; :type 'color -;; :group 'n-back) - -(defun n-back-update-info () - "Update info buffer." - (when (buffer-live-p n-back-info-buffer) - (when (window-live-p n-back-info-window) - (set-window-buffer n-back-info-window n-back-info-buffer)) - (with-current-buffer n-back-info-buffer - (setq buffer-read-only nil) - (erase-buffer) - - (insert (propertize "n-back" 'face 'n-back-header) - " " - (propertize "Help: ?" 'face 'n-back-keybinding)) - - ;; Auto challenging - (insert "\n\nAuto challenging: " - (if n-back-auto-challenge "on " "off ") - (propertize "toggle: Ta" 'face 'n-back-keybinding)) - - (insert "\n Manually change challenging: " - (propertize "up-arrow/down-arrow" 'face 'n-back-keybinding)) - - (insert "\n Allowed match types: ") - (dolist (type n-back-allowed-match-types) - (insert (format "%s " type))) - (insert (propertize "toggle: T" 'face 'n-back-keybinding)) - - ;; Current game - (insert "\n\nCurrent game:") - - (insert (format "\n n Back: %s " n-back-level) - (propertize "change: number 1-9" 'face 'n-back-keybinding)) - (insert "\n Match types: ") - (dolist (type n-back-active-match-types) - (insert (format "%s " type))) - (insert (propertize "toggle: t" 'face 'n-back-keybinding)) - - (insert (format "\n %.2f seconds per trial " n-back-sec-per-trial) - (propertize "change: +/-" 'face 'n-back-keybinding)) - - ;; Save and restore - (insert "\n\n") - (insert "Game settings: " - (propertize "reset: C-r" 'face 'n-back-keybinding) - " " - (propertize "save: C-s" 'face 'n-back-keybinding)) - - (insert "\n\n") - (unless (or (n-back-is-playing) - (not n-back-result)) - (insert (propertize (format "Last result, %s" n-back-challenge-change) - 'face 'n-back-last-result) - "\n Good-Bad-Miss:") - (dolist (entry n-back-result) - (let* ((what (nth 0 entry)) - (good (nth 1 entry)) - (bad (nth 2 entry)) - (miss (nth 3 entry)) - (tot (+ good bad miss 0.0)) - (res (n-back-compute-single-result-value entry))) - (insert (format " %s: %s-%s-%s (%d%%)" - (key-description (n-back-key-binding what)) - good - bad - miss - (floor (* 100 (cdr res)))))))) - - (setq buffer-read-only t)))) - -(defun n-back-show-welcome (msg) - "Show welcome startup info and message MSG." - (when (and n-back-game-buffer - (buffer-live-p n-back-game-buffer)) - (with-current-buffer n-back-game-buffer - (let ((src (or (when (boundp 'nxhtml-install-dir) - (expand-file-name "nxhtml/doc/img/fun-brain-2.png" nxhtml-install-dir)) - "c:/program files/brain workshop/res/brain_graphic.png")) - img - buffer-read-only) - (erase-buffer) - ;;(insert (propertize "\nEmacs n-back game (after Brain Workshop)\n\n" 'face '(:height 2.0))) - (insert (propertize "\nEmacs n-back game (after Brain Workshop)\n\n" 'face 'n-back-welcome-header)) - (unless (file-exists-p src) - (n-back-maybe-download-files (file-name-directory src) (list (file-name-nondirectory src)))) - (if (file-exists-p src) - (condition-case err - (setq img (create-image src nil nil - :relief 0 - ;;:margin inlimg-margins - )) - (error (setq img (error-message-string err)))) - (setq img (concat "Image not found: " src))) - (if (stringp img) - (insert img) - (insert-image img)) - (insert (propertize "\n\nPlay for fun and maybe a somewhat happier brain" - 'face 'n-back-welcome)) - (when msg (insert "\n\n" msg)) - )))) - -(defun n-back-setup-windows () - "Setup game frame and windows." - (delete-other-windows) - ;; Info - (split-window-horizontally) - (setq n-back-info-window (next-window (frame-first-window))) - (setq n-back-info-buffer (get-buffer-create "* n-back info *")) - (when (< 75 (window-width n-back-info-window)) - (with-selected-window n-back-info-window - (enlarge-window (- 75 (window-width n-back-info-window)) t))) - (with-current-buffer n-back-info-buffer - (n-back-control-mode) - (setq wrap-prefix " ")) - (n-back-update-info) - ;; Control - (split-window-vertically) - (setq n-back-ctrl-window (next-window (frame-first-window))) - (setq n-back-ctrl-buffer (get-buffer-create "* n-back control *")) - (set-window-buffer n-back-ctrl-window n-back-ctrl-buffer) - (with-current-buffer n-back-ctrl-buffer (n-back-control-mode)) - (n-back-update-control-buffer) - (fit-window-to-buffer n-back-ctrl-window) - (set-window-dedicated-p n-back-ctrl-window t) - ;; Game - (setq n-back-game-window (frame-first-window)) - (setq n-back-game-buffer (get-buffer-create "*n-back game*")) - (set-window-buffer n-back-game-window n-back-game-buffer) - (set-window-dedicated-p n-back-game-window t) - (with-current-buffer n-back-game-buffer (n-back-control-mode)) - (n-back-show-welcome nil) - ;; Position in control window - (select-window n-back-ctrl-window) - ) - -;;(n-back-display "str" 1 0 3 3 6) -(defun n-back-display (str x y cols rows max-strlen color) - "Display a trial. -Display item with text STR at column X in row Y using COLS -columns and ROWS rows. Strings to display have max length -MAX-STRLEN. Display item with background color COLOR." - (unless (< x cols) (error "n-back: Not x=%s < cols=%s" x cols)) - (unless (< y rows) (error "Not y=%s < rows=%s" y rows)) - (unless str (setq str "")) - (with-current-buffer n-back-game-buffer - (let* (buffer-read-only - (tot-str "") - ;; Pad spaces left, two right, four between - (game-w (window-width n-back-game-window)) - (pad-x 0) - (scale (if (not window-system) - 1.0 - (/ (* 1.0 game-w) - (+ (* 2 pad-x) - (* (1- cols) 4) - (* cols max-strlen))))) - (str-diff (- max-strlen (length str))) - (str-l-len (/ str-diff 2)) - (str-r-len (- max-strlen (length str) str-l-len)) - (face-spec (if window-system - (list :inherit 'n-back-game-word :background color :height scale) - (list :inherit 'n-back-game-word :background color))) - (str-disp (propertize - (concat (make-string str-l-len 32) str (make-string str-r-len 32)) - 'face face-spec)) - (col-str (concat - (make-string pad-x ?p) - (make-string - (+ (* x (+ 4 max-strlen))) - 32 - ;;?x - ))) - ;; Pad lines above and below, two between - (pad-y 0) - (game-h (window-body-height n-back-game-window)) - (game-h-scaled (/ game-h scale)) - (lines-between (/ (- game-h-scaled rows (* 2 pad-y)) - (1- rows))) - (row-scaled (+ pad-y (* y (1+ lines-between)) (1- y))) - (row-num (if (= y 0) - pad-y - (round row-scaled))) - (row-str (make-string row-num ?\n))) - (setq show-trailing-whitespace nil) - ;;(setq cursor-type nil) - (erase-buffer) - (setq tot-str row-str) - (setq tot-str (concat tot-str col-str)) - (insert (propertize tot-str 'face (list :height scale))) - (insert str-disp) - ))) - -;; (setq timer-list nil) -;;(n-back-display-in-timer) -;; (setq n-back-trials-left 3) - -(defun n-back-clear-game-window () - "Erase game buffer." - (save-match-data ;; runs in timer - (with-current-buffer n-back-game-buffer - (let (buffer-read-only) - (erase-buffer))))) - -(defun n-back-play () - "Start playing." - (interactive) - (message " ") ;; For easier reading *Messages* - (n-back-update-info) - (if (not n-back-active-match-types) - (message (propertize "No active match types" - 'face 'secondary-selection)) - ;;(setq n-back-result nil) - (n-back-init-control-status) - (n-back-init-this-result) - (n-back-cancel-timers) - (winsize-set-mode-line-colors t) - (setq n-back-ring (make-ring (1+ n-back-level))) - (n-back-clear-game-window) - (setq n-back-trials-left (+ n-back-trials n-back-level)) - (random t) - (n-back-start-main-timer) - (n-back-update-control-buffer))) - -(defun n-back-start-main-timer () - "Start main game timer." - (setq n-back-timer - (run-with-timer - n-back-sec-per-trial - nil ;;n-back-sec-per-trial - 'n-back-display-in-timer))) - -(defun n-back-maybe-download-files (dir file-name-list) - (nxhtml-get-missing-files (file-relative-name dir nxhtml-install-dir) file-name-list)) - -(defun n-back-finish-game () - "Finish the game." - (n-back-cancel-timers) - (fit-window-to-buffer n-back-ctrl-window) - (setq n-back-result n-back-this-result) - (n-back-compute-result-values n-back-result) - (when n-back-auto-challenge (n-back-set-next-challenge)) - (n-back-update-info) - (n-back-init-control-status) - (n-back-clear-match-status) - (n-back-update-control-buffer) - (n-back-show-welcome "Game over") - (with-current-buffer n-back-game-buffer - ;;(setq n-back-challenge-change 'up) - (let (buffer-read-only) - (insert - "\n\n" - (case n-back-challenge-change - (up "Congratulations! I see you need more challenge, raising difficulty!") - (down "Making it a bit easier for now to make your playing more fun.") - (otherwise "This game challenges seems the right way for you now."))) - (let* ((dir (when (boundp 'nxhtml-install-dir) - (expand-file-name "nxhtml/doc/img/" nxhtml-install-dir))) - (up-imgs '("rembrandt-self-portrait.jpg" - "bacchante2.jpg" - "giraffe.jpg" - "Las_Medulas.jpg" - )) - (t-imgs '("continue-play.jpg" - "Toco_toucan.jpg" - "raindrops2.jpg" - "divine2.jpg" - ;;"butterflies.png" - "volga.jpg" - "healthy_feet2.jpg" - )) - ;; (setq n-back-trials 1) - (pic (when dir (case n-back-challenge-change - (up (nth (random (length up-imgs)) up-imgs)) - (otherwise (nth (random (length t-imgs)) t-imgs))))) - (src (when dir (expand-file-name pic dir))) - img) - (when (and src (not (file-exists-p src))) - ;; Time to download? - (n-back-maybe-download-files (file-name-directory src) (append up-imgs t-imgs nil))) - (when (and src (file-exists-p src)) - (condition-case err - (setq img (create-image src nil nil - :relief 0 - )) - (error (setq img (error-message-string err))))) - (if (stringp img) - img - (insert "\n\n") - (insert-image img))))) - (message "Game over")) - -(defun n-back-display-random () - "Display a random item." - (when (current-message) (message "")) - ;;(message "here start display") - (let* ((use-position (memq 'position n-back-active-match-types)) - (use-color (memq 'color n-back-active-match-types)) - (use-sound (memq 'sound n-back-active-match-types)) - (use-word (memq 'word n-back-active-match-types)) - (old-rec (when (n-back-match-possible) - (ring-ref n-back-ring (1- n-back-level)))) - (cols 3) - (rows 3) - (x (if use-position (random 3) 1)) - (y (if use-position (random 3) 1)) - (old-x (if use-position (nth 1 old-rec))) - (old-y (if use-position (nth 2 old-rec))) - (color (nth (if use-color (random (length n-back-colors)) 0) n-back-colors)) - (old-color (if use-color (nth 3 old-rec))) - (sound (when use-sound (expand-file-name (nth (random (length n-back-sound-files)) - n-back-sound-files) - (nth 0 n-back-sounds)))) - (old-sound (if use-sound (nth 4 old-rec))) - (words (when use-word (split-string n-back-words))) - (word (when use-word (nth (random (length words)) words))) - (old-word (when use-word (nth 5 old-rec))) - (str (if word word "")) ;(format "%s" n-back-trials-left)) - (max-strlen (if words - (+ 2 (apply 'max (mapcar (lambda (w) (length w)) words))) - 5)) - (compensate 24) - ) - ;; To get more targets make it more plausible that it is the same here. - ;; (/ (- 6 (/ 20.0 8)) 20) - (when old-rec - (when (and use-position - (not (and (= x old-x) - (= y old-y))) - (< (random 100) compensate)) - (setq x (nth 1 old-rec)) - (setq y (nth 2 old-rec))) - (when (and use-color - (not (equal color old-color)) - (< (random 100) compensate)) - (setq color (nth 3 old-rec))) - (when (and use-sound - (not (equal sound old-sound)) - (< (random 100) compensate)) - (setq sound (nth 4 old-rec))) - (when (and use-word - (not (equal word old-word)) - (< (random 100) compensate)) - (setq word (nth 5 old-rec)))) - (setq str word) ;; fix-me - (ring-insert n-back-ring (list str x y color sound word)) - ;;(message "here before display") - (n-back-display str x y cols rows max-strlen color) - ;;(when sound (play-sound (list 'sound :file sound))) - ;;(message "here before clear-m") - (n-back-clear-match-status) - ;;(message "here before position") - (when (and use-position (n-back-matches 'position)) (n-back-set-match-status 'position 'miss)) - ;;(message "here before color") - (when (and use-color (n-back-matches 'color)) (n-back-set-match-status 'color 'miss)) - ;;(message "here before sound") - (when (and use-sound (n-back-matches 'sound)) (n-back-set-match-status 'sound 'miss)) - ;;(message "here before word") - (when (and use-word (n-back-matches 'word)) (n-back-set-match-status 'word 'miss)) - (setq n-back-display-hint n-back-hint) - ;;(message "here before control") - (n-back-update-control-buffer) - ;;(message "here before clear timer") - (setq n-back-clear-timer (run-with-timer 0.5 nil 'n-back-clear-game-window)) - ;;(message "here before sound timer") - (when sound (run-with-timer 0.01 nil 'n-back-play-sound-in-timer sound)) - ;;(message "here exit display") - )) - -(defun n-back-display-in-timer () - "Display a trial in a timer." - (condition-case err - (save-match-data ;; runs in timer - (n-back-add-result) - (if (>= 0 (setq n-back-trials-left (1- n-back-trials-left))) - (n-back-finish-game) - (n-back-display-random) - (n-back-start-main-timer) - ;;(message "after start-main-timer") - )) - (error (message "n-back-display: %s" (error-message-string err)) - (n-back-cancel-timers)))) - -(defun n-back-play-sound-in-timer (sound-file) - "Play sound SOUND-FILE in a timer." - (condition-case err - (save-match-data ;; runs in timer - (play-sound (list 'sound :file sound-file :volume n-back-sound-volume))) - (error (message "n-back-sound: %s" (error-message-string err)) - (n-back-cancel-timers)))) - - -;;; Answers - -;;(defvar n-back-answers nil) - -(defun n-back-init-this-result () - "Init `n-back-this-result'." - (setq n-back-this-result nil) - (dolist (sts-entry n-back-control-status) - (let* ((what (nth 0 sts-entry)) - (res-entry (list what 0 0 0))) - (setq n-back-this-result (cons res-entry n-back-this-result))))) - -(defun n-back-match-possible () - "Return t if enouch entries have been shown to match." - (= (ring-length n-back-ring) (1+ n-back-level))) - -(defun n-back-add-result () - "Add result of last trial." - (when (n-back-match-possible) - (dolist (sts-entry n-back-control-status) - (let* ((what (nth 0 sts-entry)) - (sts (nth 2 sts-entry)) - (matches (n-back-matches what)) - (num (cond - ((eq sts 'ok) 1) - ((eq sts 'bad) 2) - ;;((eq sts nil) (when matches 3)) - ((eq sts 'miss) 3) - ((not sts) nil) - (t (error "n-back: Bad status=%s" sts)))) - (res-entry (when num (assoc what n-back-this-result))) - (lst (when num (nthcdr num res-entry)))) - (when num - (if res-entry - (setcar lst (1+ (car lst))) - (setq res-entry (list what 0 0 0)) - ;;(setq lst (nthcdr num res-entry)) - (setq n-back-this-result (cons res-entry n-back-this-result)))))))) - -(defun n-back-matches-position () - "Return non-nil iff last trial position match." - (when (n-back-match-possible) - (let* ((comp-item (ring-ref n-back-ring n-back-level)) - (curr-item (ring-ref n-back-ring 0)) - (comp-x (nth 1 comp-item)) - (curr-x (nth 1 curr-item)) - (comp-y (nth 2 comp-item)) - (curr-y (nth 2 curr-item))) - (and (= comp-y curr-y) - (= comp-x curr-x))))) - -(defun n-back-matches-color () - "Return non-nil iff last trial color match." - (when (n-back-match-possible) - (let* ((comp-item (ring-ref n-back-ring n-back-level)) - (curr-item (ring-ref n-back-ring 0)) - (comp-color (nth 3 comp-item)) - (curr-color (nth 3 curr-item))) - (equal comp-color curr-color)))) - -(defun n-back-matches-sound () - "Return non-nil iff last trial sound match." - (when (n-back-match-possible) - (let* ((comp-item (ring-ref n-back-ring n-back-level)) - (curr-item (ring-ref n-back-ring 0)) - (comp-sound (nth 4 comp-item)) - (curr-sound (nth 4 curr-item))) - (equal comp-sound curr-sound)))) - -(defun n-back-matches-word () - "Return non-nil iff last trial word match." - (when (n-back-match-possible) - (let* ((comp-item (ring-ref n-back-ring n-back-level)) - (curr-item (ring-ref n-back-ring 0)) - (comp-word (nth 5 comp-item)) - (curr-word (nth 5 curr-item))) - (equal comp-word curr-word)))) - -(defun n-back-matches (what) - "Return non-nil iff last trial part WHAT match." - (cond - ((eq what 'position) (n-back-matches-position)) - ((eq what 'color) (n-back-matches-color)) - ((eq what 'sound) (n-back-matches-sound)) - ((eq what 'word) (n-back-matches-word)) - (t (error "n-back: Unknown match type: %s" what)))) - -(defun n-back-answer (what) - "Tell that you think WHAT matched." - (when (n-back-is-playing) - (if (memq what n-back-active-match-types) - (if (n-back-match-possible) - (let ((sts (if (n-back-matches what) 'ok 'bad))) - (n-back-set-match-status what sts) - (n-back-update-control-buffer)) - (message "%s n-back items must be displayed before anything can match" - n-back-level)) - (message "%s match is not active" what) - (ding t)))) - -(defun n-back-position-answer () - "Tell that you think position matched." - (interactive) - (n-back-answer 'position)) - -(defun n-back-color-answer () - "Tell that you think color matched." - (interactive) - (n-back-answer 'color)) - -(defun n-back-sound-answer () - "Tell that you think sound matched." - (interactive) - (n-back-answer 'sound)) - -(defun n-back-word-answer () - "Tell that you think word matched." - (interactive) - (n-back-answer 'word)) - -(defun n-back-stop () - "Stop playing." - (interactive) - (n-back-cancel-timers) - (n-back-update-control-buffer) - (message "Stopped n-back game") - (n-back-show-welcome "Stopped")) - -(defvar viper-emacs-state-mode-list) ;; silence compiler -(defvar viper-emacs-state-hook) ;; silence compiler - -(define-derived-mode n-back-control-mode nil "N-back" - "Mode for controlling n-back game." - (setq cursor-type nil) - (setq buffer-read-only t) - (set (make-local-variable 'viper-emacs-state-mode-list) '(n-back-control-mode)) - (set (make-local-variable 'viper-emacs-state-hook) nil) ;; in vis cursor - (abbrev-mode -1) - (setq show-trailing-whitespace nil) - (when (fboundp 'visual-line-mode) (visual-line-mode 1)) - (n-back-make-keymap)) - -(defun n-back-cancel-timers () - "Cancel game timers." - (when (timerp n-back-timer) - (cancel-timer n-back-timer)) - (setq n-back-timer nil) - (when (timerp n-back-clear-timer) - (cancel-timer n-back-clear-timer)) - (setq n-back-clear-timer nil) - (winsize-set-mode-line-colors nil)) - -(defvar n-back-game-settings-symbols - '( - ;;n-back-keys - n-back-level - n-back-active-match-types - n-back-allowed-match-types - n-back-auto-challenge - ;;n-back-colors - ;;n-back-words - ;;n-back-sound-volume - ;;n-back-sounds - n-back-sec-per-trial - ;;n-back-keybinding-color - ;;n-back-trials - )) - -(defun n-back-save-game-settings () - "Save game settings." - (interactive) - (dolist (var n-back-game-settings-symbols) - ) - (custom-save-all)) - -(defun n-back-reset-game-to-saved () - "Reset game playing options to saved values." - (interactive) - (dolist (pass '(1 2)) - (dolist (var n-back-game-settings-symbols) - (if (= pass 1) - ;; pass 1 is for my lousy programming: - (condition-case err - (custom-reevaluate-setting var) - (error nil)) - (custom-reevaluate-setting var))))) - -(provide 'n-back) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; n-back.el ends here diff --git a/emacs.d/nxhtml/util/new-key-seq-widget.el b/emacs.d/nxhtml/util/new-key-seq-widget.el deleted file mode 100644 index 7ace679..0000000 --- a/emacs.d/nxhtml/util/new-key-seq-widget.el +++ /dev/null @@ -1,312 +0,0 @@ -;;; new-key-seq-widget.el --- New key-sequence widget for Emacs -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: Tue Dec 25 23:00:43 2007 -;; Version: -;; Last-Updated: -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; New version of Kim's Emacs key-sequence widget. For inclusion in -;; Emacs I hope. -;; -;; Fix-me: check what was included. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; I do not know how much I have changed, but I keep it together here -;; for simplicity. -;; -;; Note: I have named made `widget-key-sequence-map' a constant for -;; the moment. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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: - -(require 'wid-edit) -(require 'edmacro) - -;;; I'm not sure about what this is good for? KFS. -;; -;;; This should probably be for customize-set-value etc, but it is not -;;; used. Or for the widget editing, but it is not used there -;;; either. /Lennart -(defvar widget-key-sequence-prompt-value-history nil - "History of input to `widget-key-sequence-prompt-value'.") - -(defvar widget-key-sequence-default-value [ignore] - "Default value for an empty key sequence.") - -(defconst widget-key-sequence-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map widget-field-keymap) - (define-key map [(control ?q)] 'widget-key-sequence-read-event) - (define-key map [(control ?t)] 'widget-key-sequence-toggle-input-format) - map)) - -(defvar widget-key-sequence-input-formats '(key-description vector)) - -(defcustom widget-key-sequence-default-input-format 'key-description - "Format used to edit key sequences. -This is the format shown and edited in a key-sequence widget." - :type '(choice (const :tag "Key description" 'key-description) - (const :tag "Vector" 'vector)) - :group 'widgets) - -(define-widget 'key-sequence 'restricted-sexp - "A key sequence." - :prompt-value 'widget-field-prompt-value - :prompt-internal 'widget-symbol-prompt-internal -; :prompt-match 'fboundp ;; What was this good for? KFS - :prompt-history 'widget-key-sequence-prompt-value-history - :action 'widget-field-action - :match-alternatives '(stringp vectorp) - :format "%{%t%}: %v" - :validate 'widget-key-sequence-validate - :value-to-internal 'widget-key-sequence-value-to-internal - :value-to-external 'widget-key-sequence-value-to-external - :value widget-key-sequence-default-value - :keymap widget-key-sequence-map - :help-echo "C-q: insert KEY, EVENT, or CODE; C-t: toggle format" - :tag "Key sequence") - - -;;; Leave these here for testing: -;; (edmacro-parse-keys "C-x h" t) => [24 104] -;; (key-description-to-vector "C-x h" ) => [(control 120) 104] -;; (key-description (key-description-to-vector "C-x h")) => "C-x h" -;; (key-description (edmacro-parse-keys "C-x h")) => "C-x h" -;; (key-description [M-mouse-1]) => <M-mouse-1> -;; (edmacro-parse-keys "<M-mouse-1>") => [M-mouse-1] - -;; (event-modifiers 'mouse-1) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1) -;; (event-modifiers 'M-mouse-1) => -;; (event-modifiers '(mouse-1)) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1) -;; (event-modifiers '(down-mouse-1)) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1) -;; (event-modifiers '(S-down-mouse-1)) => (shift down) -;; (event-modifiers 'S-down-mouse-1) => (shift down) -;; (event-modifiers 'down-mouse-1) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1) -;; (event-modifiers '(down-mouse-1)) => (click mouse-1 mouse-1 mouse-1 mouse-1 mouse-1) -;; (let ((m (make-sparse-keymap))) (define-key m [(down mouse-1)] 'hej)) -(defun key-description-to-vector (kd) - "Convert human readable key description KD to vector format. -KD should be in the format returned by `key-description'." - (let ((v - (vconcat - (mapcar (lambda (k) - ;; Fix-me: temporarily clean the event here: - (when (symbolp k) - (let ((esem (get k 'event-symbol-element-mask))) (when esem (lwarn t :warning "kd=%s, k=%s, esem=%s" kd k esem))) - (put k 'event-symbol-element-mask nil)) - (let ((m (event-modifiers k)) - (b (event-basic-type k))) - (setq m (delq 'click m)) - (if m - (nconc m (list b)) - b))) - ;; fix-me: does not always work for menu and tool - ;; bar event because they may contains spaces. - (edmacro-parse-keys kd t)))) - (m (make-sparse-keymap)) - ) - ;; Test before returning it: - (define-key m v 'test) - v)) - -(defun widget-key-sequence-current-input-format () - (let ((fmt (or (widget-get (widget-at (point)) :key-sequence-format) - widget-key-sequence-default-input-format))) - fmt)) - -(defun widget-key-sequence-toggle-input-format () - "Toggle key sequence input format." - (interactive) - (let* ((widget (widget-at (point))) - (value (widget-apply widget :value-get)) - (first (string-to-char value)) - (old-fmt - (let ((fmt (or (widget-get widget :key-sequence-format) - widget-key-sequence-default-input-format))) - fmt)) - (new-fmt - (let ((m (cdr (memq old-fmt widget-key-sequence-input-formats)))) - (if m (car m) (car widget-key-sequence-input-formats)))) - (new-value - (cond - ((eq new-fmt 'key-description) - (setq value (replace-regexp-in-string "\\` *\\(.*?\\) *\\'" "\\1" value)) - (if (string= value "") - "" - (key-description (read value)))) - ((eq new-fmt 'vector) - (format "%S" (key-description-to-vector value))) - (t - (error "Bad key seq format spec: %s" new-fmt)))) - (state (widget-get (widget-get widget :parent) :custom-state)) - ) - (widget-put widget :key-sequence-format new-fmt) - (setq new-value (propertize new-value 'face 'highlight)) - (widget-apply widget :value-set new-value) - (widget-setup) - (widget-put (widget-get widget :parent) :custom-state state) - (cond - ((eq new-fmt 'key-description) - (message "Switched to human readable format")) - ((eq new-fmt 'vector) - (message "Switched to vector format")) - (t - (error "Uh? format=%s" new-fmt))))) - - -(defun widget-key-sequence-read-event (ev) - "Read event or char code and put description in widget. -The events may come from keyboard, mouse, menu or tool bar. - -If the event is a mouse event then multiple entries will be -entered. It is not possible to know which one is wanted. Please -remove those not wanted! - -If 0-7 is pressed then code for an event is prompted for." - (interactive (list - (let ((inhibit-quit t) quit-flag) - (unless (eq 'key-description - (widget-key-sequence-current-input-format)) - (error "Wrong input format, please do C-t first")) - (read-event "Insert KEY, EVENT, or CODE: ")))) - (lwarn t :warning "=====> ev=%s" ev) - (let ((tr (and (keymapp function-key-map) - (lookup-key function-key-map (vector ev))))) - (insert (if (= (char-before) ?\s) "" " ")) - ;; Fix-me: change to check for ? instead of 0-7 to allow char - ;; literal input format - (when (and (integerp ev) - (or (and (<= ?0 ev) (< ev (+ ?0 (min 10 read-quoted-char-radix)))) - (and (<= ?a (downcase ev)) - (< (downcase ev) (+ ?a -10 (min 36 read-quoted-char-radix)))))) - (setq unread-command-events (cons ev unread-command-events) - ev (read-quoted-char (format "Enter code (radix %d)" read-quoted-char-radix)) - tr nil) - (if (and (integerp ev) (not (characterp ev))) - (insert (char-to-string ev)))) ;; throw invalid char error - (setq ev (key-description (list ev))) - (when (arrayp tr) - (setq tr (key-description (list (aref tr 0)))) - (when (y-or-n-p (format "Key %s is translated to %s -- use %s? " ev tr tr)) - (setq ev tr) - ;;(setq ev2 nil) - )) - (insert ev " ") - (when (or (string-match "mouse-" ev) - (string-match "menu-bar" ev) - (string-match "tool-bar" ev)) - (let ((ev2 (read-event nil nil (* 0.001 double-click-time)))) - (while ev2 - (lwarn t :warning "(stringp ev2)=%s, (sequencp ev2)=%s, (symbolp ev2)=%s, ev2=%S" (stringp ev2) (sequencep ev2) (symbolp ev2) ev2) - (if nil ;(memq 32 (append (symbol-name ev2) nil)) ;; Fix-me: contains space - (insert ?\" (symbol-name ev2) ?\") - (insert (key-description (list ev2)))) - (insert " ") - (setq ev2 (read-event nil nil (* 0.001 double-click-time)))))))) - -(defun widget-key-sequence-validate (widget) - "Validate the internal value of the widget. -Actually there is nothing to validate here. The internal value -is always valid, but it is however maybe not what the user -expects. Because of this the internal format is rewritten when -the user gives the value in a way that is not the normal -representation of it. A warning is also shown then." - (condition-case err - (let* ((int-val (widget-apply widget :value-get)) - (def-desc (key-description (edmacro-parse-keys int-val))) - (fmt (or (widget-get widget :key-sequence-format) - widget-key-sequence-default-input-format))) - ;; Normalize and compare with default description - (setq int-val - (replace-regexp-in-string " *" " " int-val t)) - (setq int-val - (replace-regexp-in-string "\\` *\\(.*?\\) *\\'" "\\1" int-val t)) - (unless (or - (eq fmt 'vector) - (string= int-val def-desc)) - ;; Replace with the default description if it is different - ;; so the user sees what the value actually means: - (widget-apply widget :value-set def-desc) - (lwarn t :warning - (concat "Key description %s means the same as %s\n" - "\tTip: You can type C-q to insert a key or event") - int-val def-desc) - ) - ;; Return nil if there a no problem validating - nil) - (error (widget-put widget :error (error-message-string err)) - (lwarn t :warning "invalid %S: %s" widget (error-message-string err)) - ;; Return widget if there was an error - widget))) - -(defun widget-key-sequence-value-to-internal (widget value) - (if (widget-apply widget :match value) - (if (equal value widget-key-sequence-default-value) - "" - (let ((fmt (or (widget-get widget :key-sequence-format) - widget-key-sequence-default-input-format))) - (if (eq fmt 'vector) - (format "%S" value) - (key-description value)))) - value)) - -(defun widget-key-sequence-value-to-external (widget value) - (if (stringp value) - (if (string-match "\\`[[:space:]]*\\'" value) - widget-key-sequence-default-value - ;; Give a better error message and a trace back on debug: - (condition-case err - (let* ((fmt (or (widget-get widget :key-sequence-format) - widget-key-sequence-default-input-format)) - (first (string-to-char value))) - (cond - ((eq fmt 'vector) - (read value) - ) - (t - (key-description-to-vector value)))) - (error (error "Bad value: %s" (error-message-string err))))) - value)) - -;; (customize-option 'new-key-seq-widget-test) -(defcustom new-key-seq-widget-test [] - "Testing only!" - :type 'key-sequence - :group 'widgets) - - (provide 'new-key-seq-widget) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; new-key-seq-widget.el ends here diff --git a/emacs.d/nxhtml/util/nxml-mode-os-additions.el b/emacs.d/nxhtml/util/nxml-mode-os-additions.el deleted file mode 100644 index 0765acf..0000000 --- a/emacs.d/nxhtml/util/nxml-mode-os-additions.el +++ /dev/null @@ -1,99 +0,0 @@ -;;; nxml-mode-os-additions.el --- additional functions for nxml-mode - -;; Copyright (C) 2004 by Oliver Steele - -;; Author: Oliver Steele <steele@osteele.com> -;; Version: 1.0 (2004-08-08) -;; Homepage: http://osteele.com/sources/nxml-mode-os-additions.el -;; Keywords: XML - -;; 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 - -;;; Description: - -;; nxml-mode-os-additions defines additional functions for using -;; James Clark's nxml-mode: -;; - reload the current buffer's schema -;; - edit the current buffer's schema - -;;; Installation: -;; -;; To use nxml-mode-os-additions.el, put it in your load-path and add -;; the following to your .emacs: -;; -;; (load-library "nxml-mode-os-additions") - -;; Configuration: -;; -;; To make it easier to use, assign the commands to some keys. -;; Once nxml-mode has been loaded, you can define keys on nxml-mode-map. -;; The function rng-mode-os-additions-set-key-bindings illustrates -;; this. -;; -;; Alternatively, you can place the following in your .emacs: -;; (add-hook 'nxml-mode-hook 'rng-mode-os-additions-set-key-bindings) - -;;; ChangeLog: -;; -;; 2004-08-08 (version 1.0): -;; * Initial public release - -;; Added require rng-valid (Lennart Borgman) - -;;; Code: - -(require 'nxml-mode) -(eval-and-compile (require 'rng-valid)) - -(defun rng-mode-os-additions-set-key-bindings () - (define-key nxml-mode-map "\C-c\C-s\C-r" 'rng-reload-schema-file) - ; move the rng-set-schema-file-and-validate to another key binding - ;(define-key nxml-mode-map "\C-c\C-s\C-s" 'rng-set-schema-file-and-validate) - (define-key nxml-mode-map "\C-c\C-sf" 'rng-find-schema-file) - ) - -(defun rng-reload-schema-file () - "Reloads the current schema file." - (interactive) - (let ((schema-filename rng-current-schema-file-name)) - (when schema-filename - (setq rng-current-schema (rng-load-schema schema-filename)) - (run-hooks 'rng-schema-change-hook) - (message "Reloaded schema %s" schema-filename)) - (unless schema-filename - (rng-set-schema-and-validate)))) - -;; Helper function for rng-find-schema-file* -(defun rng-apply-find-schema-file (fn) - (let ((schema-filename rng-current-schema-file-name)) - (unless schema-filename - (error "This file is not associated with a schema file.")) - (funcall fn schema-filename))) - -(defun rng-find-schema-file () - "Edit the current schema file." - (interactive) - (rng-apply-find-schema-file 'find-file)) - -(defun rng-find-schema-file-other-frame () - "Edit the current schema in another frame." - (interactive) - (rng-apply-find-schema-file 'find-file-other-frame)) - -(defun rng-find-schema-file-other-window () - "Edit the current schema in another window." - (interactive) - (rng-apply-find-schema-file 'find-file-other-window)) diff --git a/emacs.d/nxhtml/util/ocr-user.el b/emacs.d/nxhtml/util/ocr-user.el deleted file mode 100644 index 0bcd1d9..0000000 --- a/emacs.d/nxhtml/util/ocr-user.el +++ /dev/null @@ -1,86 +0,0 @@ -;;; ocr-user.el --- Input looong OCR number more safely -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-06-18T23:00:25+0200 Wed -;; Version: -;; Last-Updated: -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; I just get mad at entering OCR numbers more than twenty digits long -;; so I wrote this litte minor mode that colors up the digits three by -;; tree. -;; -;; To use it do -;; -;; M-x ocr-user-mode -;; -;; Crazy? Yeah, I get crazy by entering these digits. You would not -;; like to meet me when I have done that! -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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: - -(defconst ocr-keywords - `(( - ,(concat - ;;"\\<\\(?:" - "\\(?1:[0-9]\\{3\\}\\)" - "\\(?2:[0-9]\\{3\\}\\)?" - ;;"\\)+" - ) - (0 (progn - (put-text-property (match-beginning 1) (match-end 1) - 'face '(:background "LightBlue1")) - (when (match-beginning 2) - (put-text-property (match-beginning 2) (match-end 2) - 'face '(:background "PaleGreen1")))))))) - -;; 23456 -;; 1234567890 -;; 346789238 -;;;###autoload -(define-minor-mode ocr-user-mode - "Color up digits three by three." - :group 'convenience - (if ocr-user-mode - (font-lock-add-keywords nil ocr-keywords) - (font-lock-remove-keywords nil ocr-keywords)) - (font-lock-fontify-buffer)) - - -(provide 'ocr-user) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ocr-user.el ends here diff --git a/emacs.d/nxhtml/util/org-panel.el b/emacs.d/nxhtml/util/org-panel.el deleted file mode 100644 index a8dfec0..0000000 --- a/emacs.d/nxhtml/util/org-panel.el +++ /dev/null @@ -1,745 +0,0 @@ -;;; org-panel.el --- Simple routines for us with bad memory -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: Thu Nov 15 15:35:03 2007 -;; Version: 0.21 -;; Lxast-Updated: Wed Nov 21 03:06:03 2007 (3600 +0100) -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Fxeatures that might be required by this library: -;; -;; `easymenu', `font-lock', `noutline', `org', `outline', `syntax', -;; `time-date'. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; This defines a kind of control panel for `org-mode'. This control -;; panel should make it fast to move around and edit structure etc. -;; -;; To bring up the control panel type -;; -;; M-x orgpan-panel -;; -;; Type ? there for help. -;; -;; I suggest you add the following to your .emacs for quick access of -;; the panel: -;; -;; (eval-after-load 'org-mode -;; (define-key org-mode-map [(control ?c) ?p] 'orgpan-panel)) -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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: - -(require 'org) -(require 'outline) - -;; Fix-me: this is for testing. A minor mode version interferes badly -;; with emulation minor modes. -(defconst orgpan-minor-mode-version nil) - -(defface orgpan-field - '((t (:inherit widget-field))) - "Face for fields." - :group 'orgpan) -(defvar orgpan-field-face 'orgpan-field) - -(defface orgpan-active-field - '((t (:inherit highlight))) - "Face for fields." - :group 'orgpan) -(defvar orgpan-active-field-face 'orgpan-active-field) - -(defface orgpan-spaceline - '((t (:height 0.2))) - "Face for spacing lines." - :group 'orgpan) - -(defcustom orgpan-panel-at-top nil - "Put org panel at top if non-nil." - :type 'boolean - :group 'orgpan) - -(defcustom orgpan-panel-buttons nil - "Panel style, if non-nil use buttons. -If there are buttons in the panel they are used to change the way -the arrow keys work. The panel looks something like this, with -the first button chosen: - - [Navigate] [Restructure] [TODO/Priority] - ---------- - up/down, left: Go to, right: Visibility - -The line below the buttons try to give a short hint about what -the arrow keys does. \(Personally I prefer the version without -buttons since I then do not have to remember which button is -active.)" - :type 'boolean - :group 'orgpan) - -;; Fix-me: add org-mode-map -;; (memq 'org-self-insert-command orgpan-org-mode-commands) -;; (memq 'org-self-insert-command orgpan-org-commands) -(defvar orgpan-org-mode-commands nil) -(setq orgpan-org-mode-commands nil) - -(defconst orgpan-org-commands - '( - orgpan-copy-subtree - orgpan-cut-subtree - orgpan-paste-subtree - undo - save-buffer - ;; - ;orgpan-occur - orgpan-find-org-file - ;; - org-cycle - org-global-cycle - outline-up-heading - outline-next-visible-heading - outline-previous-visible-heading - outline-forward-same-level - outline-backward-same-level - org-todo - org-show-todo-tree - org-priority-up - org-priority-down - org-move-subtree-up - org-move-subtree-down - org-do-promote - org-do-demote - org-promote-subtree - org-demote-subtree)) - - -(defvar orgpan-panel-window nil - "The window showing `orgpan-panel-buffer'.") - -(defvar orgpan-panel-buffer nil - "The panel buffer. -There can be only one such buffer at any time.") - -(defvar orgpan-org-window nil) -;;(make-variable-buffer-local 'orgpan-org-window) - -;; Fix-me: used? -(defvar orgpan-org-buffer nil) -;;(make-variable-buffer-local 'orgpan-org-buffer) - -(defvar orgpan-last-org-buffer nil) -;;(make-variable-buffer-local 'orgpan-last-org-buffer) - -(defvar orgpan-point nil) -;;(make-variable-buffer-local 'orgpan-point) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Hook functions etc - -(defun orgpan-delete-panel () - "Remove the panel." - (interactive) - (let ((was-in-panel (and (window-live-p orgpan-panel-window) - (eq (selected-window) orgpan-panel-window)))) - (when (buffer-live-p orgpan-panel-buffer) - (delete-windows-on orgpan-panel-buffer) - (kill-buffer orgpan-panel-buffer)) - (when was-in-panel - (select-window orgpan-org-window))) - (setq orgpan-panel-buffer nil) - (setq orgpan-panel-window nil) - (orgpan-panel-minor-mode 0) - (remove-hook 'post-command-hook 'orgpan-minor-post-command) - (remove-hook 'post-command-hook 'orgpan-mode-post-command) - ;;(remove-hook 'window-configuration-change-hook 'orgpan-window-config-change) - ) - -(defvar orgpan-from-panel 0) -(defun orgpan-mode-pre-command () - ;;(setq orgpan-from-panel nil) - (condition-case err - (if (not (and (windowp orgpan-org-window) - (window-live-p orgpan-org-window))) - (progn - (setq this-command 'ignore) - (orgpan-delete-panel) - (message "The window belonging to the panel had disappeared, removed panel.")) - (let ((buf (window-buffer orgpan-org-window))) - (when (with-current-buffer buf - (derived-mode-p 'org-mode)) - (setq orgpan-last-org-buffer buf)) - ;; Fix me: add a list of those commands that are not - ;; meaningful from the panel (for example org-time-stamp) - (when (or (memq this-command orgpan-org-commands) - (memq this-command orgpan-org-mode-commands) - ;; For some reason not all org commands are found above: - (unless (eq this-command 'org-self-insert-command) - (let ((this-name (format "%s" this-command))) - (when (< 4 (length this-name)) - (string= "org-" (substring this-name 0 4)))))) - (if (not (with-current-buffer buf - (derived-mode-p 'org-mode))) - (progn - (if (buffer-live-p orgpan-org-buffer) - (set-window-buffer orgpan-org-window orgpan-org-buffer) - (message "Please use `l' or `b' to choose an org-mode buffer")) - (setq this-command 'ignore)) - (setq orgpan-org-buffer (window-buffer orgpan-org-window)) - (setq orgpan-from-panel 1) - (select-window orgpan-org-window) - )))) - (error (lwarn 't :warning "orgpan-pre: %S" err)))) - -(defun orgpan-mode-post-command () - (condition-case err - (progn - ;;(message "post %s" (current-time-string))(sit-for 1) - (unless (and (windowp orgpan-panel-window) - (window-live-p orgpan-panel-window) - (bufferp orgpan-panel-buffer) - (buffer-live-p orgpan-panel-buffer)) - (orgpan-delete-panel)) - (unless (active-minibuffer-window) - (when (and (= 1 orgpan-from-panel) - (windowp orgpan-panel-window) - (window-live-p orgpan-panel-window)) - (select-window orgpan-panel-window) - (when (derived-mode-p 'orgpan-mode) - (setq deactivate-mark t) - (when orgpan-panel-buttons - (unless (and orgpan-point - (= (point) orgpan-point)) - ;; Go backward so it is possible to click on a "button": - (orgpan-backward-field))))) - (when (< 0 orgpan-from-panel) - (setq orgpan-from-panel (1- orgpan-from-panel))) - (unless (eq (selected-window) orgpan-panel-window) - (orgpan-delete-panel)))) - (error (lwarn 't :warning "orgpan-post: %S" err)))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Commands - -(defun orgpan-last-buffer () - "Open last org-mode buffer in panels org window." - (interactive) - (let ((buf (window-buffer orgpan-org-window)) - (last-buf orgpan-last-org-buffer)) -;; (when (with-current-buffer buf -;; (derived-mode-p 'org-mode)) -;; (setq orgpan-last-org-buffer buf)) - (when (eq last-buf buf) - (setq last-buf nil)) - (if (not last-buf) - (orgpan-switch-buffer) - (set-window-buffer orgpan-org-window last-buf)))) - -(defun orgpan-switch-buffer () - "Switch to next org-mode buffer in panels org window." - (interactive) - (let ((buf (window-buffer orgpan-org-window)) - (org-buffers nil)) - (with-current-buffer buf - (when (derived-mode-p 'org-mode) - (bury-buffer buf) - ;;(setq orgpan-last-org-buffer buf) - )) - (setq org-buffers (delq nil (mapcar (lambda (buf) - (when (with-current-buffer buf - (derived-mode-p 'org-mode)) - buf)) - (buffer-list)))) - (setq org-buffers (delq buf org-buffers)) - (if (not org-buffers) - (message "No other org-mode buffers") - (set-window-buffer orgpan-org-window (car org-buffers)) - (setq orgpan-org-buffer (car org-buffers))))) - -(defcustom orgpan-cautious-cut-copy-paste nil - "Ask the user about panel cut, paste and copy before doing them. -This refers to the functions `orgpan-paste-subtree', -`orgpan-cut-subtree' and `orgpan-copy-subtree'." - :type 'boolean - :group 'orgpan) - -(defun orgpan-paste-subtree () - (interactive) - (if orgpan-cautious-cut-copy-paste - (if (y-or-n-p "Paste subtree here? ") - (org-paste-subtree) - (message "Nothing was pasted")) - (org-paste-subtree))) - -(defun orgpan-cut-subtree () - (interactive) - (let ((heading (progn - (org-back-to-heading) - (buffer-substring (point) (line-end-position)) - ))) - (if orgpan-cautious-cut-copy-paste - (if (y-or-n-p (format "Do you want to cut the subtree\n%s\n? " heading)) - (org-cut-subtree) - (message "Nothing was cut")) - (org-cut-subtree)))) - -(defun orgpan-copy-subtree () - (interactive) - (let ((heading (progn - (org-back-to-heading) - (buffer-substring (point) (line-end-position)) - ))) - (if orgpan-cautious-cut-copy-paste - (if (y-or-n-p (format "Do you want to copy the subtree\n%s\n? " heading)) - (org-copy-subtree) - (message "Nothing was copied")) - (org-copy-subtree)))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Buttons - -(defvar orgpan-ovl-help nil) - -(defun orgpan-check-panel-mode () - (unless (derived-mode-p 'orgpan-mode) - (error "Not orgpan-mode in buffer: %s" major-mode))) - -(defun orgpan-display-bindings-help () - ;;(orgpan-check-panel-mode) - (setq orgpan-point (point-marker)) - (let* ((ovls (overlays-at orgpan-point)) - (ovl (car ovls)) - (help (when ovl (overlay-get ovl 'orgpan-explain)))) - (dolist (o (overlays-in (point-min) (point-max))) - (unless ovl (setq ovl o)) - (overlay-put o 'face orgpan-field-face)) - (overlay-put ovl 'face orgpan-active-field-face) - (unless orgpan-ovl-help - (setq orgpan-ovl-help (make-overlay orgpan-point orgpan-point))) - (overlay-put orgpan-ovl-help 'before-string help))) - -(defun orgpan-forward-field () - (interactive) - (orgpan-check-panel-mode) - (let ((pos (next-overlay-change (point)))) - (unless (overlays-at pos) - (setq pos (next-overlay-change pos))) - (when (= pos (point-max)) - (setq pos (point-min)) - (unless (overlays-at pos) - (setq pos (next-overlay-change pos)))) - (goto-char pos)) - (orgpan-display-bindings-help)) - -(defun orgpan-backward-field () - (interactive) - (orgpan-check-panel-mode) - (when (= (point) (point-min)) - (goto-char (point-max))) - (let ((pos (previous-overlay-change (point)))) - (unless (overlays-at pos) - (setq pos (previous-overlay-change pos))) - (goto-char pos)) - (orgpan-display-bindings-help)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Mode -(defun orgpan-agenda () - "Start agenda" - (interactive) - (orgpan-delete-panel) - (call-interactively 'org-agenda)) - -(defun orgpan-outline-up-heading (arg &optional invisible-ok) - (interactive "p") - (outline-back-to-heading invisible-ok) - (let ((start-level (funcall outline-level))) - (if (<= start-level 1) - (message "Already at top level of the outline") - (outline-up-heading arg invisible-ok)))) - -(defvar orgpan-mode-map - ;; Fix-me: clean up here! - ;; Fix-me: viper support - (let ((map (make-sparse-keymap))) - (define-key map [?q] 'orgpan-delete-panel) - (define-key map [??] 'orgpan-help) - (define-key map [?a] 'orgpan-agenda) - ;; Copying etc - (define-key map [?c] 'orgpan-copy-subtree) - (define-key map [?x] 'orgpan-cut-subtree) - (define-key map [?v] 'orgpan-paste-subtree) - (define-key map [?z] 'undo) - (define-key map [(control ?c)] 'orgpan-copy-subtree) - (define-key map [(control ?x)] 'orgpan-cut-subtree) - (define-key map [(control ?v)] 'orgpan-paste-subtree) - (define-key map [(control ?z)] 'undo) - ;; Buffers: - (define-key map [?b] 'orgpan-switch-buffer) - (define-key map [?l] 'orgpan-last-buffer) - (define-key map [?o] 'orgpan-find-org-file) - (define-key map [?w] 'save-buffer) - ;; Some keys for moving between headings. Emacs keys for next/prev - ;; line seems ok: - (define-key map [(control ?p)] 'outline-previous-visible-heading) - (define-key map [(control ?n)] 'outline-next-visible-heading) - (define-key map [(shift control ?p)] 'outline-backward-same-level) - (define-key map [(shift control ?n)] 'outline-forward-same-level) - ;; A mnemunic for up: - (define-key map [(control ?u)] 'orgpan-outline-up-heading) - ;; Search sparse tree: - (define-key map [?s] 'org-sparse-tree) - ;;(define-key map [?s] 'orgpan-occur) - ;;(define-key map [?s] 'org-occur) - ;; Same as in org-mode: - ;;(define-key map [(control ?c)(control ?v)] 'org-show-todo-tree) - ;; Fix-me: This leads to strange problems: - ;;(define-key map [t] 'ignore) - map)) - -(defun orgpan-find-org-file () - "Prompt for an .org file and open it." - (interactive) - (let ((file-name - (read-file-name - "Find .org file: " nil nil t nil - (lambda (fn) - (unless (backup-file-name-p fn) - (let ((ext (file-name-extension fn))) - (when ext - (string= "org" ext)))))))) - (find-file file-name))) - -(defun orgpan-occur () - "Replacement for `org-occur'. -Technical reasons." - (interactive) - (let ((rgx (read-from-minibuffer "(panel) Regexp: "))) - (setq orgpan-from-panel 1) - (select-window orgpan-org-window) - (org-occur rgx))) - -(defun orgpan-sparse-tree (&optional arg) - "Create a sparse tree, prompt for the details. -This command can create sparse trees. You first need to select the type -of match used to create the tree: - -t Show entries with a specific TODO keyword. -T Show entries selected by a tags match. -p Enter a property name and its value (both with completion on existing - names/values) and show entries with that property. -r Show entries matching a regular expression" - (interactive "P") - (let (ans kwd value) - (message "Sparse tree: [r]egexp [t]odo-kwd [T]ag [p]roperty") - (setq ans (read-char-exclusive)) - (cond - ((equal ans ?t) - (org-show-todo-tree '(4))) - ((equal ans ?T) - (call-interactively 'org-tags-sparse-tree)) - ((member ans '(?p ?P)) - (setq kwd (completing-read "Property: " - (mapcar 'list (org-buffer-property-keys)))) - (setq value (completing-read "Value: " - (mapcar 'list (org-property-values kwd)))) - (unless (string-match "\\`{.*}\\'" value) - (setq value (concat "\"" value "\""))) - (org-tags-sparse-tree arg (concat kwd "=" value))) - ((member ans '(?r ?R)) - (call-interactively 'org-occur)) - (t (error "No such sparse tree command \"%c\"" ans))))) - -;; (defun orgpan-avoid-viper-in-buffer () -;; ;; Fix-me: This is ugly. However see `this-major-mode-requires-vi-state': -;; (set (make-local-variable 'viper-emacs-state-mode-list) '(orgpan-mode)) -;; (set (make-local-variable 'viper-new-major-mode-buffer-list) nil) -;; (local-set-key [?\ ] 'ignore)) - -(define-derived-mode orgpan-mode nil "Org-Panel" - "Mode for org-simple.el control panel." - (set (make-local-variable 'buffer-read-only) t) - (unless orgpan-minor-mode-version - (add-hook 'pre-command-hook 'orgpan-mode-pre-command nil t) - (add-hook 'post-command-hook 'orgpan-mode-post-command t)) - (set (make-local-variable 'cursor-type) nil) - (when (boundp 'yas/dont-activate) (setq yas/dont-activate t)) - ;; Avoid emulation modes here (cua, viper): - (set (make-local-variable 'emulation-mode-map-alists) nil)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Panel layout - -(defun orgpan-insert-field (text keymap explain) - (insert text) - (let* ((end (point)) - (len (length text)) - (beg (- end len)) - (ovl (make-overlay beg end))) - (overlay-put ovl 'face orgpan-field-face) - (overlay-put ovl 'keymap keymap) - (overlay-put ovl 'orgpan-explain explain))) - -(defconst orgpan-with-keymap - (let ((map (make-sparse-keymap))) - (set-keymap-parent map org-mode-map) - ;; Users are used to tabbing between fields: - (define-key map [(tab)] 'orgpan-forward-field) - (define-key map [(shift tab)] 'orgpan-backward-field) - (define-key map [backtab] 'orgpan-backward-field) - ;; Now we must use something else for visibility (first does not - ;; work if Viper): - (define-key map [(meta tab)] 'org-cycle) - (define-key map [(control meta tab)] 'org-global-cycle) - map)) - -(defconst orgpan-without-keymap - (let ((map (make-sparse-keymap))) - (set-keymap-parent map org-mode-map) - ;; Visibility (those are in org-mode-map): - ;;(define-key map [tab] 'org-cycle) - ;;(define-key map [(shift tab)] 'org-global-cycle) - ;; Navigate: - (define-key map [left] 'orgpan-outline-up-heading) - (define-key map [right] 'org-cycle) - (define-key map [up] 'outline-previous-visible-heading) - (define-key map [down] 'outline-next-visible-heading) - (define-key map [(shift down)] 'outline-forward-same-level) - (define-key map [(shift up)] 'outline-backward-same-level) - ;; Restructure: - (define-key map [(control up)] 'org-move-subtree-up) - (define-key map [(control down)] 'org-move-subtree-down) - (define-key map [(control left)] 'org-do-promote) - (define-key map [(control right)] 'org-do-demote) - (define-key map [(control shift left)] 'org-promote-subtree) - (define-key map [(control shift right)] 'org-demote-subtree) - ;; Todo etc - (define-key map [?+] 'org-priority-up) - (define-key map [?-] 'org-priority-down) - (define-key map [?t] 'org-todo) - map)) - -(defun orgpan-make-panel-without-buttons (buf) - (with-current-buffer buf - (insert (propertize "*Org Panel*" 'face 'orgpan-active-field)) - (let ((ovl (make-overlay (point-min) (point-max)))) - (overlay-put ovl 'priority 10) - (overlay-put ovl 'face 'orgpan-active-field)) - (insert " ? for help, q quit\n") - (insert (propertize "arrows" 'face 'font-lock-keyword-face) - ": Go to, " - (propertize "C-arrows" 'face 'font-lock-keyword-face) - ": Edit tree\n" - (propertize "C-cxvz" 'face 'font-lock-keyword-face) - ": copy cut paste undo, " - (propertize "tT+-" 'face 'font-lock-keyword-face) - ": todo priority, " - (propertize "s" 'face 'font-lock-keyword-face) - ": search, " - (propertize "o" 'face 'font-lock-keyword-face) - ": open file\n" - (propertize "w" 'face 'font-lock-keyword-face) - ": write, " - (propertize "a" 'face 'font-lock-keyword-face) - ": agenda" - "\n" - ) - (set-keymap-parent orgpan-mode-map orgpan-without-keymap) - (let ((ovl (make-overlay (point-min) (point-max)))) - (overlay-put ovl 'face 'secondary-selection)) - )) - -(defun orgpan-make-panel-with-buttons (buf) - (with-current-buffer buf - (let* ((base-map (make-sparse-keymap)) - (space-line (propertize "\n\n" 'face 'orgpan-spaceline)) - (arrow-face 'font-lock-keyword-face) - (L (propertize "left" 'face arrow-face)) - (R (propertize "right" 'face arrow-face)) - (U (propertize "up" 'face arrow-face)) - (D (propertize "down" 'face arrow-face))) - ;;(message D)(sit-for 2) - (define-key base-map [left] 'ignore) - (define-key base-map [right] 'ignore) - (define-key base-map [up] 'ignore) - (define-key base-map [down] 'ignore) - (define-key base-map [?q] 'delete-window) - (define-key base-map [??] 'orgpan-help) - ;; Navigating - (let ((map (copy-keymap base-map))) - (define-key map [left] 'outline-up-heading) - (define-key map [right] 'org-cycle) - (define-key map [up] 'outline-previous-visible-heading) - (define-key map [down] 'outline-next-visible-heading) - (define-key map [(shift down)] 'outline-forward-same-level) - (define-key map [(shift up)] 'outline-backward-same-level) - (orgpan-insert-field "Navigate" map (concat U "/" D ", " L ": Go to, " R ": Visibility"))) - (insert " ") - (let ((map (copy-keymap base-map))) - (define-key map [up] 'org-move-subtree-up) - (define-key map [down] 'org-move-subtree-down) - (define-key map [left] 'org-do-promote) - (define-key map [right] 'org-do-demote) - (define-key map [(shift left)] 'org-promote-subtree) - (define-key map [(shift right)] 'org-demote-subtree) - (orgpan-insert-field - "Restructure" map - (concat U "/" D ": " - (propertize "Move" 'face 'font-lock-warning-face) - ", " L "/" R ": " - (propertize "Level (w S: Subtree Level)" 'face 'font-lock-warning-face)))) - (insert " ") - (let ((map (copy-keymap base-map))) - (define-key map [up] 'org-priority-up) - (define-key map [down] 'org-priority-down) - (define-key map [right] 'org-todo) - (orgpan-insert-field "TODO/priority" map - (concat R ": TODO, " U "/" D ": Priority"))) - ) - (insert " ? for help, q quit\n") - (orgpan-display-bindings-help) - (set-keymap-parent orgpan-mode-map orgpan-with-keymap) - )) - -(defun orgpan-make-panel-buffer () - "Make the panel buffer." - (let* ((buf-name "*Org Panel*")) - (when orgpan-panel-buffer (kill-buffer orgpan-panel-buffer)) - ;;(with-current-buffer orgpan-panel-buffer (orgpan-mode)) - (setq orgpan-panel-buffer (get-buffer-create buf-name)) - (if orgpan-panel-buttons - (orgpan-make-panel-with-buttons orgpan-panel-buffer) - (orgpan-make-panel-without-buttons orgpan-panel-buffer)) - (with-current-buffer orgpan-panel-buffer - (orgpan-mode) - (goto-char (point-min))) - orgpan-panel-buffer)) - -(defun orgpan-help () - (interactive) - (set-keymap-parent orgpan-with-keymap nil) - (set-keymap-parent orgpan-without-keymap nil) - (describe-function 'orgpan-panel) - (set-keymap-parent orgpan-with-keymap org-mode-map) - (set-keymap-parent orgpan-without-keymap org-mode-map) - (message "Use 'l' to get back to last viewed org file")) - -(defcustom orgpan-panel-height 5 - "Panel height" - :type '(choice (integer :tag "One line" 2) - (integer :tag "All lines" 5)) - :group 'orgpan) - -(defun orgpan-panel () - "Create a control panel for current `org-mode' buffer. -The control panel may be used to quickly move around and change -the headings. The idea is that when you want to to a lot of this -kind of editing you should be able to do that with few -keystrokes (and without having to remember the complicated -keystrokes). A typical situation when this perhaps can be useful -is when you are looking at your notes file \(usually ~/.notes, -see `remember-data-file') where you have saved quick notes with -`remember'. - -The keys below are defined in the panel. Note that the commands -are carried out in the `org-mode' buffer that belongs to the -panel. - -\\{orgpan-mode-map} - -In addition to the keys above most of the keys in `org-mode' can -also be used from the panel. - -Note: There are two forms of the control panel, one with buttons -and one without. The default is without, see -`orgpan-panel-buttons'. If buttons are used choosing a different -button changes the binding of the arrow keys." - (interactive) - (unless (derived-mode-p 'org-mode) - (error "Buffer is not in org-mode")) - (orgpan-delete-panel) - (unless orgpan-org-mode-commands - (map-keymap (lambda (ev def) - (when (and def - (symbolp def) - (fboundp def)) - (setq orgpan-org-mode-commands - (cons def orgpan-org-mode-commands)))) - org-mode-map)) - (remq 'org-self-insert-command orgpan-org-mode-commands) - ;;(org-back-to-heading) - ;;(remove-hook 'window-configuration-change-hook 'orgpan-window-config-change) - (split-window) - (if orgpan-panel-at-top - (setq orgpan-org-window (next-window)) - (setq orgpan-org-window (selected-window)) - (select-window (next-window))) - (set-window-buffer (selected-window) (orgpan-make-panel-buffer)) - (setq orgpan-panel-window (selected-window)) - (set-window-dedicated-p orgpan-panel-window t) - (adjust-window-trailing-edge orgpan-org-window - (- (window-height) orgpan-panel-height) nil) - ;; The minor mode version starts here: - (when orgpan-minor-mode-version - (select-window orgpan-org-window) - (orgpan-panel-minor-mode 1) - (add-hook 'post-command-hook 'orgpan-minor-post-command t))) - -(define-minor-mode orgpan-panel-minor-mode - "Minor mode used in `org-mode' buffer when showing panel." - :keymap orgpan-mode-map - :lighter " PANEL" - :group 'orgpan - ) - -(defun orgpan-minor-post-command () - ;; Check org window and buffer - (if (and (windowp orgpan-org-window) - (window-live-p orgpan-org-window) - (eq orgpan-org-window (selected-window)) - (derived-mode-p 'org-mode) - ;; Check panel window and buffer - (windowp orgpan-panel-window) - (window-live-p orgpan-panel-window) - (bufferp orgpan-panel-buffer) - (buffer-live-p orgpan-panel-buffer) - (eq (window-buffer orgpan-panel-window) orgpan-panel-buffer) - ;; Check minor mode - orgpan-panel-minor-mode) - (setq cursor-type nil) - (orgpan-delete-panel))) - - -(provide 'org-panel) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; org-panel.el ends here diff --git a/emacs.d/nxhtml/util/ourcomments-util.el b/emacs.d/nxhtml/util/ourcomments-util.el deleted file mode 100644 index 5e9c2e6..0000000 --- a/emacs.d/nxhtml/util/ourcomments-util.el +++ /dev/null @@ -1,2427 +0,0 @@ -;;; ourcomments-util.el --- Utility routines -;; -;; Author: Lennart Borgman <lennart dot borgman at gmail dot com> -;; Created: Wed Feb 21 2007 -(defconst ourcomments-util:version "0.25") ;;Version: -;; Last-Updated: 2009-08-04 Tue -;; Keywords: -;; Compatibility: Emacs 22 -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; The functionality given by these small routines should in my -;; opinion be part of Emacs (but they are not that currently). -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'apropos)) -(eval-when-compile (require 'bookmark)) -(eval-when-compile (require 'cl)) -(eval-when-compile (require 'grep)) -(eval-when-compile (require 'ido)) -(eval-when-compile (require 'org)) -(eval-when-compile (require 'recentf)) -(eval-when-compile (require 'uniquify)) - -(require 'cus-edit) - -;; (ourcomments-indirect-fun 'html-mumamo) -;; (ourcomments-indirect-fun 'html-mumamo-mode) -;;;###autoload -(defun ourcomments-indirect-fun (fun) - "Get the alias symbol for function FUN if any." - ;; This code is from `describe-function-1'. - (when (and (symbolp fun) - (functionp fun)) - (let ((def (symbol-function fun))) - (when (symbolp def) - (while (and (fboundp def) - (symbolp (symbol-function def))) - (setq def (symbol-function def))) - def)))) - -(defun ourcomments-goto-line (line) - "A version of `goto-line' for use in elisp code." - (save-restriction - (widen) - (goto-char (point-min)) - (forward-line (1- line)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Popups etc. - -(defun point-to-coord (point) - "Return coordinates of POINT in selected window. -The coordinates are in the form \(\(XOFFSET YOFFSET) WINDOW). -This form is suitable for `popup-menu'." - ;; Fix-me: showtip.el adds (window-inside-pixel-edges - ;; (selected-window)). Why? - (let* ((pn (posn-at-point point)) - (x-y (posn-x-y pn)) - (x (car x-y)) - (y (cdr x-y)) - (pos (list (list x (+ y 20)) (selected-window)))) - pos)) - -;;;###autoload -(defun popup-menu-at-point (menu &optional prefix) - "Popup the given menu at point. -This is similar to `popup-menu' and MENU and PREFIX has the same -meaning as there. The position for the popup is however where -the window point is." - (let ((where (point-to-coord (point)))) - (popup-menu menu where prefix))) - - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Toggles in menus - -;;;###autoload -(defmacro define-toggle (symbol value doc &rest args) - "Declare SYMBOL as a customizable variable with a toggle function. -The purpose of this macro is to define a defcustom and a toggle -function suitable for use in a menu. - -The arguments have the same meaning as for `defcustom' with these -restrictions: - -- The :type keyword cannot be used. Type is always 'boolean. -- VALUE must be t or nil. - -DOC and ARGS are just passed to `defcustom'. - -A `defcustom' named SYMBOL with doc-string DOC and a function -named SYMBOL-toggle is defined. The function toggles the value -of SYMBOL. It takes no parameters. - -To create a menu item something similar to this can be used: - - \(define-key map [SYMBOL] - \(list 'menu-item \"Toggle nice SYMBOL\" - 'SYMBOL-toggle - :button '(:toggle . SYMBOL)))" - (declare - (doc-string 3) - (debug t)) - (let* ((SYMBOL-toggle (intern (concat (symbol-name symbol) "-toggle"))) - (SYMBOL-name (symbol-name symbol)) - (var-doc doc) - (fun-doc (concat "Toggles the \(boolean) value of `" - SYMBOL-name - "'.\n" - "For how to set it permanently see this variable.\n" - ))) - (let ((var (append `(defcustom ,symbol ,value ,var-doc) - args - nil)) - (fun `(defun ,SYMBOL-toggle () - ,fun-doc - (interactive) - (customize-set-variable (quote ,symbol) (not ,symbol))))) - ;;(message "\nvar=%S\nfun=%S\n" var fun) - ;; Fix-me: I am having problems with this one, see - ;; http://lists.gnu.org/archive/html/help-gnu-emacs/2009-12/msg00608.html - `(progn ,var ,fun) - ))) - -;;(macroexpand '(define-toggle my-toggle t "doc" :tag "Short help" :group 'popcmp)) -;;(macroexpand-all (define-toggle my-toggle t "doc" :tag "Short help" :group 'popcmp)) - -;;;###autoload -(defmacro define-toggle-old (symbol value doc &rest args) - (declare (doc-string 3)) - (list - 'progn - (let ((var-decl (list 'custom-declare-variable - (list 'quote symbol) - (list 'quote value) - doc))) - (while args - (let ((arg (car args))) - (setq args (cdr args)) - (unless (symbolp arg) - (error "Junk in args %S" args)) - (let ((keyword arg) - (value (car args))) - (unless args - (error "Keyword %s is missing an argument" keyword)) - (setq args (cdr args)) - (cond - ((not (memq keyword '(:type))) - (setq var-decl (append var-decl (list keyword value)))) - (t - (lwarn '(define-toggle) :error "Keyword %s can't be used here" - keyword)))))) - (when (assoc :type var-decl) (error ":type is set. Should not happen!")) - (setq var-decl (append var-decl (list :type '(quote boolean)))) - var-decl) - (let* ((SYMBOL-toggle (intern (concat (symbol-name symbol) "-toggle"))) - (SYMBOL-name (symbol-name symbol)) - (fun-doc (concat "Toggles the \(boolean) value of `" - SYMBOL-name - "'.\n" - "For how to set it permanently see this variable.\n" - ;;"\nDescription of `" SYMBOL-name "':\n" doc - ))) - `(defun ,SYMBOL-toggle () - ,fun-doc - (interactive) - (customize-set-variable (quote ,symbol) (not ,symbol))) - ))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Indentation of regions - -;; From an idea by weber <hugows@gmail.com> -;; (defun indent-line-or-region () -;; "Indent line or region. -;; Only do this if indentation seems bound to \\t. - -;; Call `indent-region' if region is active, otherwise -;; `indent-according-to-mode'." -;; (interactive) -;; ;; Do a wild guess if we should indent or not ... -;; (let* ((indent-region-mode) -;; ;; The above hides the `indent-line-or-region' binding -;; (t-bound (key-binding [?\t]))) -;; (if (not -;; (save-match-data -;; (string-match "indent" (symbol-name t-bound)))) -;; (call-interactively t-bound t) -;; (if (and mark-active ;; there is a visible region selected -;; transient-mark-mode) -;; (indent-region (region-beginning) (region-end)) -;; (indent-according-to-mode))))) ;; indent line - -;; (define-minor-mode indent-region-mode -;; "Use \\t to indent line or region. -;; The key \\t is bound to `indent-line-or-region' if this mode is -;; on." -;; :global t -;; :keymap '(([?\t] . indent-line-or-region))) -;; (when indent-region-mode (indent-region-mode 1)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Minor modes - -;; (defmacro define-globalized-minor-mode-with-on-off (global-mode mode -;; turn-on turn-off -;; &rest keys) -;; "Make a global mode GLOBAL-MODE corresponding to buffer-local minor MODE. -;; This is a special variant of `define-globalized-minor-mode' for -;; mumamo. It let bounds the variable GLOBAL-MODE-checking before -;; calling TURN-ON or TURN-OFF. - -;; TURN-ON is a function that will be called with no args in every buffer -;; and that should try to turn MODE on if applicable for that buffer. -;; TURN-OFF is a function that turns off MODE in a buffer. -;; KEYS is a list of CL-style keyword arguments. As the minor mode -;; defined by this function is always global, any :global keyword is -;; ignored. Other keywords have the same meaning as in `define-minor-mode', -;; which see. In particular, :group specifies the custom group. -;; The most useful keywords are those that are passed on to the -;; `defcustom'. It normally makes no sense to pass the :lighter -;; or :keymap keywords to `define-globalized-minor-mode', since these -;; are usually passed to the buffer-local version of the minor mode. - -;; If MODE's set-up depends on the major mode in effect when it was -;; enabled, then disabling and reenabling MODE should make MODE work -;; correctly with the current major mode. This is important to -;; prevent problems with derived modes, that is, major modes that -;; call another major mode in their body." - -;; (let* ((global-mode-name (symbol-name global-mode)) -;; (pretty-name (easy-mmode-pretty-mode-name mode)) -;; (pretty-global-name (easy-mmode-pretty-mode-name global-mode)) -;; (group nil) -;; (extra-keywords nil) -;; (MODE-buffers (intern (concat global-mode-name "-buffers"))) -;; (MODE-enable-in-buffers -;; (intern (concat global-mode-name "-enable-in-buffers"))) -;; (MODE-check-buffers -;; (intern (concat global-mode-name "-check-buffers"))) -;; (MODE-cmhh (intern (concat global-mode-name "-cmhh"))) -;; (MODE-major-mode (intern (concat (symbol-name mode) -;; "-major-mode"))) -;; (MODE-checking (intern (concat global-mode-name "-checking"))) -;; keyw) - -;; ;; Check keys. -;; (while (keywordp (setq keyw (car keys))) -;; (setq keys (cdr keys)) -;; (case keyw -;; (:group (setq group (nconc group (list :group (pop keys))))) -;; (:global (setq keys (cdr keys))) -;; (t (push keyw extra-keywords) (push (pop keys) extra-keywords)))) - -;; (unless group -;; ;; We might as well provide a best-guess default group. -;; (setq group -;; `(:group ',(intern (replace-regexp-in-string -;; "-mode\\'" "" (symbol-name mode)))))) - -;; `(progn - -;; ;; Define functions for the global mode first so that it can be -;; ;; turned on during load: - -;; ;; List of buffers left to process. -;; (defvar ,MODE-buffers nil) - -;; ;; The function that calls TURN-ON in each buffer. -;; (defun ,MODE-enable-in-buffers () -;; (let ((,MODE-checking nil)) -;; (dolist (buf ,MODE-buffers) -;; (when (buffer-live-p buf) -;; (with-current-buffer buf -;; (if ,mode -;; (unless (eq ,MODE-major-mode major-mode) -;; (setq ,MODE-checking t) -;; (,mode -1) -;; (,turn-on) -;; (setq ,MODE-checking nil) -;; (setq ,MODE-major-mode major-mode)) -;; (setq ,MODE-checking t) -;; (,turn-on) -;; (setq ,MODE-checking nil) -;; (setq ,MODE-major-mode major-mode))))))) -;; (put ',MODE-enable-in-buffers 'definition-name ',global-mode) - -;; (defun ,MODE-check-buffers () -;; (,MODE-enable-in-buffers) -;; (setq ,MODE-buffers nil) -;; (remove-hook 'post-command-hook ',MODE-check-buffers)) -;; (put ',MODE-check-buffers 'definition-name ',global-mode) - -;; ;; The function that catches kill-all-local-variables. -;; (defun ,MODE-cmhh () -;; (add-to-list ',MODE-buffers (current-buffer)) -;; (add-hook 'post-command-hook ',MODE-check-buffers)) -;; (put ',MODE-cmhh 'definition-name ',global-mode) - - -;; (defvar ,MODE-major-mode nil) -;; (make-variable-buffer-local ',MODE-major-mode) - -;; ;; The actual global minor-mode -;; (define-minor-mode ,global-mode -;; ,(format "Toggle %s in every possible buffer. -;; With prefix ARG, turn %s on if and only if ARG is positive. -;; %s is enabled in all buffers where `%s' would do it. -;; See `%s' for more information on %s." -;; pretty-name pretty-global-name pretty-name turn-on -;; mode pretty-name) -;; :global t ,@group ,@(nreverse extra-keywords) - -;; ;; Setup hook to handle future mode changes and new buffers. -;; (if ,global-mode -;; (progn -;; (add-hook 'after-change-major-mode-hook -;; ',MODE-enable-in-buffers) -;; ;;(add-hook 'find-file-hook ',MODE-check-buffers) -;; (add-hook 'find-file-hook ',MODE-cmhh) -;; (add-hook 'change-major-mode-hook ',MODE-cmhh)) -;; (remove-hook 'after-change-major-mode-hook ',MODE-enable-in-buffers) -;; ;;(remove-hook 'find-file-hook ',MODE-check-buffers) -;; (remove-hook 'find-file-hook ',MODE-cmhh) -;; (remove-hook 'change-major-mode-hook ',MODE-cmhh)) - -;; ;; Go through existing buffers. -;; (let ((,MODE-checking t)) -;; (dolist (buf (buffer-list)) -;; (with-current-buffer buf -;; ;;(if ,global-mode (,turn-on) (when ,mode (,mode -1))) -;; (if ,global-mode (,turn-on) (,turn-off)) -;; )))) - -;; ))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Unfilling -;; -;; The idea is from -;; http://interglacial.com/~sburke/pub/emacs/sburke_dot_emacs.config - -;;;###autoload -(defun unfill-paragraph () - "Unfill the current paragraph." - (interactive) (with-unfilling 'fill-paragraph)) -;;(defalias 'unwrap-paragraph 'unfill-paragraph) - -;;;###autoload -(defun unfill-region () - "Unfill the current region." - (interactive) (with-unfilling 'fill-region)) -;;(defalias 'unwrap-region 'unfill-region) - -;;;###autoload -(defun unfill-individual-paragraphs () - "Unfill individual paragraphs in the current region." - (interactive) (with-unfilling 'fill-individual-paragraphs)) -;;(defalias 'unwrap-individual-paragraphs 'unfill-individual-paragraphs) - -(defun with-unfilling (fn) - "Unfill using the fill function FN." - (let ((fill-column (1+ (point-max)))) (call-interactively fn))) - -(defvar fill-dwim-state nil) -(defvar fill-dwim-mark nil) - -;;;###autoload -(defun fill-dwim (arg) - "Fill or unfill paragraph or region. -With prefix ARG fill only current line." - (interactive "P") - (or arg - (not fill-dwim-mark) - (equal (point-marker) fill-dwim-mark) - (setq fill-dwim-state nil)) - (if mark-active - ;; This avoids deactivating the mark - (progn - (if fill-dwim-state - (call-interactively 'unfill-region) - (call-interactively 'fill-region)) - (setq deactivate-mark nil)) - (if arg - (fill-region (line-beginning-position) (line-end-position)) - (if fill-dwim-state - (call-interactively 'unfill-paragraph) - (call-interactively 'fill-paragraph)))) - (setq fill-dwim-mark (copy-marker (point))) - (unless arg - (setq fill-dwim-state (not fill-dwim-state)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Widgets - -;;;###autoload -(defun ourcomments-mark-whole-buffer-or-field () - "Mark whole buffer or editable field at point." - (interactive) - (let* ((field (widget-field-at (point))) - (from (when field (widget-field-start field))) - (to (when field (widget-field-end field))) - (size (when field (widget-get field :size)))) - (if (not field) - (mark-whole-buffer) - (while (and size - (not (zerop size)) - (> to from) - (eq (char-after (1- to)) ?\s)) - (setq to (1- to))) - (push-mark (point)) - (push-mark from nil t) - (goto-char to)))) - -;; (rassq 'genshi-nxhtml-mumamo-mode mumamo-defined-turn-on-functions) -;; (major-modep 'nxhtml-mode) -;; (major-modep 'nxhtml-mumamo-mode) -;; (major-modep 'jsp-nxhtml-mumamo-mode) -;; (major-modep 'gsp-nxhtml-mumamo-mode) -;; (major-modep 'asp-nxhtml-mumamo-mode) -;; (major-modep 'django-nxhtml-mumamo-mode) -;; (major-modep 'eruby-nxhtml-mumamo-mode) -;; (major-modep 'eruby-nxhtml-mumamo-mode) -;; (major-modep 'smarty-nxhtml-mumamo-mode) -;; (major-modep 'embperl-nxhtml-mumamo-mode) -;; (major-modep 'laszlo-nxml-mumamo-mode) -;; (major-modep 'genshi-nxhtml-mumamo-mode) -;; (major-modep 'javascript-mode) -;; (major-modep 'espresso-mode) -;; (major-modep 'css-mode) -;; (major-modep 'js-mode) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Lines - -;; Changed from move-beginning-of-line to beginning-of-line to support -;; physical-line-mode. -;; Fix-me: use end-of-visual-line etc. -;;;###autoload -(defun ourcomments-move-beginning-of-line(arg) - "Move point to beginning of line or indentation. -See `beginning-of-line' for ARG. - -If `line-move-visual' is non-nil then the visual line beginning -is first tried. - -If in a widget field stay in that." - (interactive "p") - (let ((pos (point)) - vis-pos - (field (widget-field-at (point)))) - (when line-move-visual - (line-move-visual -1 t) - (beginning-of-line) - (setq vis-pos (point)) - (goto-char pos)) - (call-interactively 'beginning-of-line arg) - (when (and vis-pos - (= vis-pos (point))) - (while (and (> pos (point)) - (not (eobp))) - (let (last-command) - (line-move-visual 1 t))) - (line-move-visual -1 t)) - (when (= pos (point)) - (if (= 0 (current-column)) - (skip-chars-forward " \t") - (backward-char) - (beginning-of-line))) - (when (and field - (< (point) (widget-field-start field))) - (goto-char (widget-field-start field))))) -(put 'ourcomments-move-beginning-of-line 'CUA 'move) - -;;;###autoload -(defun ourcomments-move-end-of-line(arg) - "Move point to end of line or after last non blank char. -See `end-of-line' for ARG. - -Similar to `ourcomments-move-beginning-of-line' but for end of -line." - (interactive "p") - (or arg (setq arg 1)) - (let ((pos (point)) - vis-pos - eol-pos) - (when line-move-visual - (let (last-command) (line-move-visual 1 t)) - (end-of-line) - (setq vis-pos (point)) - (goto-char pos)) - (call-interactively 'end-of-line arg) - (when (and vis-pos - (= vis-pos (point))) - (setq eol-pos (point)) - (beginning-of-line) - (let (last-command) (line-move-visual 1 t)) - ;; move backwards if we moved to a new line - (unless (= (point) eol-pos) - (backward-char))) - (when (= pos (point)) - (if (= (line-end-position) (point)) - (skip-chars-backward " \t") - (forward-char) - (end-of-line))))) -(put 'ourcomments-move-end-of-line 'CUA 'move) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Keymaps - -(defun ourcomments-find-keymap-variables (key--- binding--- keymap---) - "Return a list of matching keymap variables. -They should have key KEY--- bound to BINDING--- and have value -KEYMAP---. - -Ignore `special-event-map', `global-map', `overriding-local-map' -and `overriding-terminal-local-map'." - (let ((vars--- nil) - (ancestors--- nil)) - (let ((parent (keymap-parent keymap---))) - (while parent - (setq ancestors--- (cons parent ancestors---)) - (setq parent (keymap-parent parent)))) - (mapatoms (lambda (symbol) - (unless (memq symbol '(keymap--- - ancestors--- - vars--- - special-event-map - global-map - overriding-local-map - overriding-terminal-local-map - )) - (let (val) - (if (boundp symbol) - (setq val (symbol-value symbol)) - (when (keymapp symbol) - (setq val (symbol-function symbol)))) - (when (and val - (keymapp val) - (eq binding--- (lookup-key val key--- t))) - (if (equal val keymap---) - (push symbol vars---) - (when ancestors--- - (catch 'found - (dolist (ancestor ancestors---) - (when (equal val ancestor) - (push symbol vars---) - (throw 'found nil))))))))))) -;;; (let ((childs nil)) -;;; (dolist (var vars---) -;;; (dolist (ancestor ancestors---) -;;; (when (equal (keymap-parent var) -;;; ( - vars---)) - -;; This is modelled after `current-active-maps'. -(defun key-bindings (key &optional olp position) - "Return list of bindings for key sequence KEY in current keymaps. -The first binding is the active binding and the others are -bindings shadowed by this in the order of their priority level -\(see Info node `(elisp) Searching Keymaps'). - -The entries in the list have the form - - \(BINDING (MAPS) MORE-INFO) - -where BINDING is the command bound to and MAPS are matching maps -\(according to `ourcomments-find-keymap-variables'). - -MORE-INFO is a list with more information - - \(PRIORITY-LEVEL \[ACTIVE-WHEN]) - -where PRIORITY-LEVEL is a symbol matching the level where the -keymap is found and ACTIVE-WHEN is a symbol which must be non-nil -for the keymap to be active \(minor mode levels only)." - ;;(message "\nkey-bindings %s %s %s" key olp position) - (let* ((bindings nil) - (maps (current-active-maps)) - map - map-sym - map-rec - binding - keymaps - minor-maps - where - map-where - where-map - (local-map (current-local-map)) - (pt (or position (point))) - (point-keymap (get-char-property pt 'keymap)) - (point-local-map (get-char-property pt 'local-map)) - ) - (setq keymaps - (cons (list global-map 'global-map) - keymaps)) - (when overriding-terminal-local-map - (setq keymaps - (cons (list overriding-terminal-local-map 'overriding-terminal-local-map) - keymaps))) - (when overriding-local-map - (setq keymaps - (cons (list overriding-local-map 'overriding-local-map) - keymaps))) - (unless (cdr keymaps) - (when point-local-map - (setq keymaps - (cons (list point-local-map 'point-local-map) - keymaps))) - ;; Fix-me: - ;;/* If on a mode line string with a local keymap, - - (when local-map - (setq keymaps - (cons (list local-map 'local-map) - keymaps))) - - ;; Minor-modes - ;;(message "================ Minor-modes") - (dolist (list '(emulation-mode-map-alists - minor-mode-overriding-map-alist - minor-mode-map-alist)) - ;;(message "------- %s" list) - (let ((alists (if (eq list 'emulation-mode-map-alists) - (symbol-value list) - (list (symbol-value list))))) - (dolist (alist alists) - ;;(message "\n(symbolp alist)=%s alist= %s (symbol-value alist)=%s" (symbolp alist) "dum" "dum2") ;alist "dummy");(when (symbolp alist) (symbol-value alist))) - (when (symbolp alist) - (setq alist (symbol-value alist))) - (dolist (assoc alist) - (let* (;(assoc (car alist-rec)) - (var (when (consp assoc) (car assoc))) - (val (when (and (symbolp var) - (boundp var)) - (symbol-value var)))) - ;;(message "var= %s, val= %s" var val) - (when (and - val - (or (not (eq list 'minor-mode-map-alist)) - (not (assq var minor-mode-overriding-map-alist)))) - ;;(message "** Adding this") - (setq minor-maps - (cons (list (cdr assoc) list var) - minor-maps))) - ))))) - (dolist (map minor-maps) - ;;(message "cdr map= %s" (cdr map)) - (setq keymaps - (cons map - keymaps))) - (when point-keymap - (setq keymaps - (cons (list point-keymap 'point-keymap) - keymaps)))) - - ;; Fix-me: compare with current-active-maps - (let ((ca-maps (current-active-maps)) - (wh-maps keymaps) - ca - wh) - (while (or ca-maps wh-maps) - (setq ca (car ca-maps)) - (setq wh (car wh-maps)) - (setq ca-maps (cdr ca-maps)) - (setq wh-maps (cdr wh-maps)) - ;;(message "\nca= %s" ca) - ;;(message "cdr wh= %s" (cdr wh)) - (unless (equal ca (car wh)) - (error "Did not match: %s" (cdr wh))))) - - (while keymaps - (setq map-rec (car keymaps)) - (setq map (car map-rec)) - (when (setq binding (lookup-key map key t)) - (setq map-sym (ourcomments-find-keymap-variables key binding map)) - (setq map-sym (delq 'map map-sym)) - (setq map-sym (delq 'local-map map-sym)) - (setq map-sym (delq 'point-keymap map-sym)) - (setq map-sym (delq 'point-local-map map-sym)) - (setq bindings (cons (list binding map-sym (cdr map-rec)) bindings))) - (setq keymaps (cdr keymaps))) - - (nreverse bindings))) - -(defun describe-keymap-placement (keymap-sym) - "Find minor mode keymap KEYMAP-SYM in the keymaps searched for key lookup. -See Info node `Searching Keymaps'." - ;;(info "(elisp) Searching Keymaps") - (interactive (list (ourcomments-read-symbol "Describe minor mode keymap symbol" - (lambda (sym) - (and (boundp sym) - (keymapp (symbol-value sym))))))) - (unless (symbolp keymap-sym) - (error "Argument KEYMAP-SYM must be a symbol")) - (unless (keymapp (symbol-value keymap-sym)) - (error "The value of argument KEYMAP-SYM must be a keymap")) - (with-output-to-temp-buffer (help-buffer) - (help-setup-xref (list #'describe-keymap-placement keymap-sym) (interactive-p)) - (with-current-buffer (help-buffer) - (insert "Placement of keymap `") - (insert-text-button (symbol-name keymap-sym) - 'action - (lambda (btn) - (describe-variable keymap-sym))) - (insert "'\nin minor modes activation maps:\n") - (let (found) - (dolist (map-root '(emulation-mode-map-alists - minor-mode-overriding-map-alist - minor-mode-map-alist - )) - (dolist (emul-alist (symbol-value map-root)) - ;;(message "emul-alist=%s" emul-alist) - (dolist (keymap-alist - (if (memq map-root '(emulation-mode-map-alists)) - (symbol-value emul-alist) - (list emul-alist))) - (let* ((map (cdr keymap-alist)) - (first (catch 'first - (map-keymap (lambda (key def) - (throw 'first (cons key def))) - map))) - (key (car first)) - (def (cdr first)) - (keymap-variables (when (and key def) - (ourcomments-find-keymap-variables - (vector key) def map))) - (active-var (car keymap-alist)) - ) - (assert (keymapp map)) - ;;(message "keymap-alist=%s, %s" keymap-alist first) - ;;(message "active-var=%s, %s" active-var keymap-variables) - (when (memq keymap-sym keymap-variables) - (setq found t) - (insert (format "\n`%s' " map-root)) - (insert (propertize "<= Minor mode keymap list holding this map" - 'face 'font-lock-doc-face)) - (insert "\n") - (when (symbolp emul-alist) - (insert (format " `%s' " emul-alist)) - (insert (propertize "<= Keymap alist variable" 'face 'font-lock-doc-face)) - (insert "\n")) - ;;(insert (format " `%s'\n" keymap-alist)) - (insert (format " `%s' " active-var)) - (insert (propertize "<= Activation variable" 'face 'font-lock-doc-face)) - (insert "\n") - ))))) - (unless found - (insert (propertize "Not found." 'face 'font-lock-warning-face))) - )))) - -;; This is a replacement for describe-key-briefly. -;;(global-set-key [f1 ?c] 'describe-key-and-map-briefly) -;;;###autoload -(defun describe-key-and-map-briefly (&optional key insert untranslated) - "Try to print names of keymap from which KEY fetch its definition. -Look in current active keymaps and find keymap variables with the -same value as the keymap where KEY is bound. Print a message -with those keymap variable names. Return a list with the keymap -variable symbols. - -When called interactively prompt for KEY. - -INSERT and UNTRANSLATED should normall be nil (and I am not sure -what they will do ;-)." - ;; >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> - ;; From describe-key-briefly. Keep this as it is for easier update. - (interactive - (let ((enable-disabled-menus-and-buttons t) - (cursor-in-echo-area t) - saved-yank-menu) - (unwind-protect - (let (key) - ;; If yank-menu is empty, populate it temporarily, so that - ;; "Select and Paste" menu can generate a complete event. - (when (null (cdr yank-menu)) - (setq saved-yank-menu (copy-sequence yank-menu)) - (menu-bar-update-yank-menu "(any string)" nil)) - (setq key (read-key-sequence "Describe key (or click or menu item): ")) - ;; If KEY is a down-event, read and discard the - ;; corresponding up-event. Note that there are also - ;; down-events on scroll bars and mode lines: the actual - ;; event then is in the second element of the vector. - (and (vectorp key) - (let ((last-idx (1- (length key)))) - (and (eventp (aref key last-idx)) - (memq 'down (event-modifiers (aref key last-idx))))) - (read-event)) - (list - key - (if current-prefix-arg (prefix-numeric-value current-prefix-arg)) - 1 - )) - ;; Put yank-menu back as it was, if we changed it. - (when saved-yank-menu - (setq yank-menu (copy-sequence saved-yank-menu)) - (fset 'yank-menu (cons 'keymap yank-menu)))))) - (if (numberp untranslated) - (setq untranslated (this-single-command-raw-keys))) - (let* ((event (if (and (symbolp (aref key 0)) - (> (length key) 1) - (consp (aref key 1))) - (aref key 1) - (aref key 0))) - (modifiers (event-modifiers event)) - (standard-output (if insert (current-buffer) t)) - (mouse-msg (if (or (memq 'click modifiers) (memq 'down modifiers) - (memq 'drag modifiers)) " at that spot" "")) - (defn (key-binding key t)) - key-desc) - ;; Handle the case where we faked an entry in "Select and Paste" menu. - (if (and (eq defn nil) - (stringp (aref key (1- (length key)))) - (eq (key-binding (substring key 0 -1)) 'yank-menu)) - (setq defn 'menu-bar-select-yank)) - ;; Don't bother user with strings from (e.g.) the select-paste menu. - (if (stringp (aref key (1- (length key)))) - (aset key (1- (length key)) "(any string)")) - (if (and (> (length untranslated) 0) - (stringp (aref untranslated (1- (length untranslated))))) - (aset untranslated (1- (length untranslated)) "(any string)")) - ;; Now describe the key, perhaps as changed. - (setq key-desc (help-key-description key untranslated)) - ;; - ;; End of part from describe-key-briefly. - ;; <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< - - ;;(message "bindings=%s" (key-bindings key)) (sit-for 2) - ;; Find the keymap: - (let* ((maps (current-active-maps)) - ret - lk) - (if (or (null defn) (integerp defn) (equal defn 'undefined)) - (setq ret 'not-defined) - (catch 'mapped - (while (< 1 (length maps)) - (setq lk (lookup-key (car maps) key t)) - (when (and lk (not (numberp lk))) - (setq ret (ourcomments-find-keymap-variables key lk (car maps))) - (when ret - (throw 'mapped (car maps)))) - (setq maps (cdr maps)))) - (unless ret - (setq lk (lookup-key global-map key t)) - (when (and lk (not (numberp lk))) - (setq ret '(global-map))))) - (cond - ((eq ret 'not-defined) - (message "%s%s not defined in any keymap" key-desc mouse-msg)) - ((listp ret) - (if (not ret) - (message "%s%s is bound to `%s', but don't know where" - key-desc mouse-msg defn) - (if (= 1 (length ret)) - (message "%s%s is bound to `%s' in `%s'" - key-desc mouse-msg defn (car ret)) - (message "%s%s is bound to `%s' in keymap variables `%s'" - key-desc mouse-msg defn ret)))) - (t - (error "ret=%s" ret))) - ret))) - -;; (ourcomments-find-keymap-variables (current-local-map)) -;; (keymapp 'ctl-x-4-prefix) -;; (equal 'ctl-x-4-prefix (current-local-map)) -;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Fringes. - -(defvar better-bottom-angles-defaults nil) -(defun better-fringes-bottom-angles (on) - ;;(bottom bottom-left-angle bottom-right-angle top-right-angle top-left-angle) - (if (not on) - (when better-bottom-angles-defaults - (set-default 'fringe-indicator-alist better-bottom-angles-defaults)) - (unless better-bottom-angles-defaults - (setq better-bottom-angles-defaults fringe-indicator-alist)) - (let ((better - '(bottom - bottom-right-angle bottom-right-angle - bottom-left-angle bottom-left-angle - )) - ;;(indicators (copy-list fringe-indicator-alist))) - (indicators (copy-sequence fringe-indicator-alist))) - (setq indicators (assq-delete-all 'bottom indicators)) - (set-default 'fringe-indicator-alist (cons better indicators))))) - -(defun better-fringes-faces (face face-important) - (dolist (bitmap '(bottom-left-angle - bottom-right-angle - top-left-angle - top-right-angle - - right-curly-arrow - left-arrow right-arrow - left-curly-arrow right-curly-arrow - up-arrow - down-arrow - left-bracket right-bracket - empty-line)) - (set-fringe-bitmap-face bitmap face)) - (dolist (bitmap '(right-triangle - question-mark)) - (set-fringe-bitmap-face bitmap face-important))) - -(defface better-fringes-bitmap - '((t (:foreground "dark khaki"))) - "Face for bitmap fringes." - :group 'better-fringes - :group 'nxhtml) - -(defface better-fringes-important-bitmap - '((t (:foreground "red"))) - "Face for bitmap fringes." - :group 'better-fringes - :group 'nxhtml) - -;;;###autoload -(define-minor-mode better-fringes-mode - "Choose another fringe bitmap color and bottom angle." - :global t - :group 'better-fringes - (if better-fringes-mode - (progn - (better-fringes-faces 'better-fringes-bitmap - 'better-fringes-important-bitmap) - (better-fringes-bottom-angles t)) - (better-fringes-faces nil nil) - (better-fringes-bottom-angles nil))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Copy+paste - -;; After an idea from andrea on help-gnu-emacs - -(defvar ourcomments-copy+paste-point nil) - -;;(global-set-key [(control ?c) ?y] 'ourcomments-copy+paste-set-point) -;;;###autoload -(defun ourcomments-copy+paste-set-point () - "Set point for copy+paste here. -Enable temporary minor mode `ourcomments-copy+paste-mode'. -However if point for copy+paste already is set then cancel it and -disable the minor mode. - -The purpose of this command is to make it easy to grab a piece of -text and paste it at current position. After this command you -should select a piece of text to copy and then call the command -`ourcomments-copy+paste'." - (interactive) - (if ourcomments-copy+paste-point - (ourcomments-copy+paste-mode -1) - (setq ourcomments-copy+paste-point (list (copy-marker (point)) - (selected-window) - (current-frame-configuration) - )) - (ourcomments-copy+paste-mode 1) - (let ((key (where-is-internal 'ourcomments-copy+paste)) - (ckeys (key-description (this-command-keys)))) - (setq key (if key (key-description (car key)) - "M-x ourcomments-copy+paste")) - (when (> (length ckeys) 12) - (setq ckeys "this command")) - (message "Paste point set; select region and do %s to copy+paste (or cancel with %s)" key ckeys)))) - -(defvar ourcomments-copy+paste-mode-map - (let ((map (make-sparse-keymap))) - ;; Bind the copy+paste command to C-S-v which reminds of cua-paste - ;; binding and is hopefully not bound. - (define-key map [(control shift ?v)] 'ourcomments-copy+paste) - map)) - -(define-minor-mode ourcomments-copy+paste-mode - "Temporary mode for copy+paste. -This minor mode is enabled by `ourcomments-copy+paste-set-point'. - -When this mode is active there is a key binding for -`ourcomments-copy+paste': -\\<ourcomments-copy+paste-mode-map> -\\[ourcomments-copy+paste] - -You should not turn on this minor mode yourself. It is turned on -by `ourcomments-copy+paste-set-point'. For more information see -that command." - :lighter " COPY+PASTE" - :global t - :group 'ourcomments-util - (if ourcomments-copy+paste-mode - (unless ourcomments-copy+paste-point - (message "Do not call this minor mode, use `ourcomments-copy+paste-set-point'.") - (setq ourcomments-copy+paste-mode nil)) - (when ourcomments-copy+paste-point - (setq ourcomments-copy+paste-point nil) - (message "Canceled copy+paste mode")))) - -(defvar ourcomments-copy+paste-ovl nil) - -(defun ourcomments-copy+paste-cancel-highlight () - (when (overlayp ourcomments-copy+paste-ovl) - (delete-overlay ourcomments-copy+paste-ovl)) - (setq ourcomments-copy+paste-ovl nil)) - -(defun ourcomments-copy+paste (restore-frames) - "Copy region to copy+paste point set by `ourcomments-copy+paste-set-point'. -Also if prefix argument is given then restore frame configuration -at the time that command was called. Otherwise look for the -buffer for copy+paste point in current frame. If found select -that window. If not then use `switch-to-buffer-other-window' to -display it." - (interactive "P") - (cond - ((not ourcomments-copy+paste-point) - (let ((key (where-is-internal 'ourcomments-copy+paste-set-point))) - (setq key (if key (key-description (car key)) - "M-x ourcomments-copy+paste-set-point")) - (message "Please select destination of copy+paste first with %s" key))) - ((not mark-active) - (message "Please select a region to copy+paste first")) - (t - ;;(copy-region-as-kill (region-beginning) (region-end)) - (clipboard-kill-ring-save (region-beginning) (region-end)) - (let* ((marker (nth 0 ourcomments-copy+paste-point)) - (orig-win (nth 1 ourcomments-copy+paste-point)) - (orig-fcfg (nth 2 ourcomments-copy+paste-point)) - (buf (marker-buffer marker)) - (win (or (when (window-live-p orig-win) orig-win) - (get-buffer-window buf)))) - (message "win=%s, buf=%s" win buf) - (cond (restore-frames - (set-frame-configuration orig-fcfg)) - ((and win (eq (window-buffer win) buf)) - (select-window win)) - (t - (switch-to-buffer-other-window buf))) - (goto-char marker)) - (let ((here (point)) - ovl) - (yank) - (setq ovl (make-overlay here (point))) - (overlay-put ovl 'face 'highlight) - (run-with-idle-timer 2 nil 'ourcomments-copy+paste-cancel-highlight) - (setq ourcomments-copy+paste-ovl ovl)) - (setq ourcomments-copy+paste-point nil) - (ourcomments-copy+paste-mode -1)))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Misc. - -;;(describe-timers) -;;;###autoload -(defun describe-timers () - "Show timers with readable time format." - (interactive) - (with-output-to-temp-buffer (help-buffer) - (help-setup-xref (list #'ourcommenst-show-timers) (interactive-p)) - (with-current-buffer (help-buffer) - (insert (format-time-string "Timers at %Y-%m-%d %H:%M:%S\n\n" (current-time))) - (if (not timer-list) - (insert " None\n") - (insert (propertize - " When Rpt What\n" - 'face 'font-lock-doc-face)) - (dolist (tmr timer-list) - (let* ((hi-sec (timer--high-seconds tmr)) - (lo-sec (timer--low-seconds tmr)) - (mi-sec (timer--usecs tmr)) - (fun (timer--function tmr)) - (args (timer--args tmr)) - (idle-d (timer--idle-delay tmr)) - (rpt-d (timer--repeat-delay tmr)) - (time (concat (format-time-string " %Y-%m-%d %H:%M:%S" (list hi-sec lo-sec 0)) - (substring - (format "%.1f" (/ mi-sec 1000000.0)) - 1)))) - (assert (not idle-d) t) - (insert (format "%s %4s (`%-3s' %S)\n" time rpt-d fun args))))) - (insert "\nIdle timers:\n\n") - (if (not timer-idle-list) - (insert " None\n") - (insert (propertize - " After Rpt What\n" - 'face 'font-lock-doc-face)) - (dolist (tmr timer-idle-list) - (let* ((hi-sec (timer--high-seconds tmr)) - (lo-sec (timer--low-seconds tmr)) - (mi-sec (timer--usecs tmr)) - (fun (timer--function tmr)) - (args (timer--args tmr)) - (idle-d (timer--idle-delay tmr)) - (rpt-d (timer--repeat-delay tmr)) - (time (+ (* hi-sec 256 256) lo-sec (/ mi-sec 1000000.0))) - ) - (assert (not (not idle-d)) t) - (insert (format " %.2f sec %3s (`%s' %S)\n" time rpt-d fun args)))))))) - -(defcustom ourcomments-insert-date-and-time "%Y-%m-%d %R" - "Time format for command `ourcomments-insert-date-and-time'. -See `format-time-string'." - :type 'string - :group 'ourcomments-util) - -;;;###autoload -(defun ourcomments-insert-date-and-time () - "Insert date and time. -See option `ourcomments-insert-date-and-time' for how to -customize it." - (interactive) - (insert (format-time-string ourcomments-insert-date-and-time))) - -;;;###autoload -(defun find-emacs-other-file (display-file) - "Find corresponding file to source or installed elisp file. -If you have checked out and compiled Emacs yourself you may have -Emacs lisp files in two places, the checked out source tree and -the installed Emacs tree. If buffer contains an Emacs elisp file -in one of these places then find the corresponding elisp file in -the other place. Return the file name of this file. - -Rename current buffer using your `uniquify-buffer-name-style' if -it is set. - -When DISPLAY-FILE is non-nil display this file in other window -and go to the same line number as in the current buffer." - (interactive (list t)) - (unless (buffer-file-name) - (error "This buffer is not visiting a file")) - (unless source-directory - (error "Can't find the checked out Emacs sources")) - (let* ((installed-directory (file-name-as-directory - (expand-file-name ".." exec-directory))) - (relative-installed (file-relative-name - (buffer-file-name) installed-directory)) - (relative-source (file-relative-name - (buffer-file-name) source-directory)) - (name-nondir (file-name-nondirectory (buffer-file-name))) - source-file - installed-file - other-file - (line-num (save-restriction - (widen) - (line-number-at-pos)))) - (cond - ((and relative-installed - (not (string= name-nondir relative-installed)) - (not (file-name-absolute-p relative-installed)) - (not (string= ".." (substring relative-installed 0 2)))) - (setq source-file (expand-file-name relative-installed source-directory))) - ((and relative-source - (not (string= name-nondir relative-source)) - (not (file-name-absolute-p relative-source)) - (not (string= ".." (substring relative-source 0 2)))) - (setq installed-file (expand-file-name relative-source installed-directory)))) - (setq other-file (or source-file installed-file)) - (unless other-file - (error "This file is not in Emacs source or installed lisp tree")) - (unless (file-exists-p other-file) - (error "Can't find the corresponding file %s" other-file)) - (when display-file - (when uniquify-buffer-name-style - (rename-buffer (file-name-nondirectory buffer-file-name) t)) - (find-file-other-window other-file) - (ourcomments-goto-line line-num)) - other-file)) - -;;;###autoload -(defun ourcomments-ediff-files (def-dir file-a file-b) - "In directory DEF-DIR run `ediff-files' on files FILE-A and FILE-B. -The purpose of this function is to make it eaiser to start -`ediff-files' from a shell through Emacs Client. - -This is used in EmacsW32 in the file ediff.cmd where Emacs Client -is called like this: - - @%emacs_client% -e \"(setq default-directory \\\"%emacs_cd%\\\")\" - @%emacs_client% -n -e \"(ediff-files \\\"%f1%\\\" \\\"%f2%\\\")\" - -It can of course be done in a similar way with other shells." - (let ((default-directory def-dir)) - (ediff-files file-a file-b))) - - -(defun ourcomments-latest-changelog () - "not ready" - (let ((changelogs - '("ChangeLog" - "admin/ChangeLog" - "doc/emacs/ChangeLog" - "doc/lispintro/ChangeLog" - "doc/lispref/ChangeLog" - "doc/man/ChangeLog" - "doc/misc/ChangeLog" - "etc/ChangeLog" - "leim/ChangeLog" - "lib-src/ChangeLog" - "lisp/ChangeLog" - "lisp/erc/ChangeLog" - "lisp/gnus/ChangeLog" - "lisp/mh-e/ChangeLog" - "lisp/org/ChangeLog" - "lisp/url/ChangeLog" - "lwlib/ChangeLog" - "msdos/ChangeLog" - "nextstep/ChangeLog" - "nt/ChangeLog" - "oldXMenu/ChangeLog" - "src/ChangeLog" - "test/ChangeLog")) - (emacs-root (expand-file-name ".." exec-directory) - )))) - -(defun ourcomments-read-symbol (prompt predicate) - "Basic function for reading a symbol for describe-* functions. -Prompt with PROMPT and show only symbols satisfying function -PREDICATE. PREDICATE takes one argument, the symbol." - (let* ((symbol (symbol-at-point)) - (enable-recursive-minibuffers t) - val) - (when predicate - (unless (and symbol - (symbolp symbol) - (funcall predicate symbol)) - (setq symbol nil))) - (setq val (completing-read (if symbol - (format - "%s (default %s): " prompt symbol) - (format "%s: " prompt)) - obarray - predicate - t nil nil - (if symbol (symbol-name symbol)))) - (if (equal val "") symbol (intern val)))) - -(defun ourcomments-command-at-point () - (let ((fun (function-called-at-point))) - (when (commandp fun) - fun))) - -;;;###autoload -(defun describe-command (command) - "Like `describe-function', but prompts only for interactive commands." - (interactive - (let* ((fn (ourcomments-command-at-point)) - (prompt (if fn - (format "Describe command (default %s): " fn) - "Describe command: ")) - (enable-recursive-minibuffers t) - val) - (setq val (completing-read prompt - obarray 'commandp t nil nil - (and fn (symbol-name fn)))) - (list (if (equal val "") fn (intern val))))) - (describe-function command)) - - -;;;###autoload -(defun buffer-narrowed-p () - "Return non-nil if the current buffer is narrowed." - (/= (buffer-size) - (- (point-max) - (point-min)))) - -;;;###autoload -(defun narrow-to-comment () - (interactive) - (let* ((here (point-marker)) - (size 1000) - (beg (progn (forward-comment (- size)) - ;; It looks like the wrong syntax-table is used here: - ;;(message "skipped %s " (skip-chars-forward "[:space:]")) - ;; See Emacs bug 3823, http://debbugs.gnu.org/cgi/bugreport.cgi?bug=3823 - (message "skipped %s " (skip-chars-forward " \t\r\n")) - (point))) - (end (progn (forward-comment size) - ;;(message "skipped %s " (skip-chars-backward "[:space:]")) - (message "skipped %s " (skip-chars-backward " \t\r\n")) - (point)))) - (goto-char here) - (if (not (and (>= here beg) - (<= here end))) - (error "Not in a comment") - (narrow-to-region beg end)))) - -(defvar describe-symbol-alist nil) - -(defun describe-symbol-add-known(property description) - (when (assq property describe-symbol-alist) - (error "Already known property")) - (setq describe-symbol-alist - (cons (list property description) - describe-symbol-alist))) - -;;(describe-symbol-add-known 'variable-documentation "Doc for variable") -;;(describe-symbol-add-known 'cl-struct-slots "defstruct slots") - -(defun property-list-keys (plist) - "Return list of key names in property list PLIST." - (let ((keys)) - (while plist - (setq keys (cons (car plist) keys)) - (setq plist (cddr plist))) - keys)) - -(defun ourcomments-symbol-type (symbol) - "Return a list of types where symbol SYMBOL is used. -The can include 'variable, 'function and variaus 'cl-*." - (symbol-file symbol) - ) - -(defun ourcomments-defstruct-p (symbol) - "Return non-nil if symbol SYMBOL is a CL defstruct." - (let ((plist (symbol-plist symbol))) - (and (plist-member plist 'cl-struct-slots) - (plist-member plist 'cl-struct-type) - (plist-member plist 'cl-struct-include) - (plist-member plist 'cl-struct-print)))) - -(defun ourcomments-defstruct-slots (symbol) - (unless (ourcomments-defstruct-p symbol) - (error "Not a CL defstruct symbol: %s" symbol)) - (let ((cl-struct-slots (get symbol 'cl-struct-slots))) - (delq 'cl-tag-slot - (loop for rec in cl-struct-slots - collect (nth 0 rec))))) - -;; (ourcomments-defstruct-slots 'ert-test) - -(defun ourcomments-defstruct-file (symbol) - (unless (ourcomments-defstruct-p symbol) - (error "Not a CL defstruct symbol: %s" symbol)) - ) - -(defun ourcomments-member-defstruct (symbol) - "Return defstruct name if member." - (when (and (functionp symbol) - (plist-member (symbol-plist symbol) 'cl-compiler-macro)) - (let* (in-defstruct - (symbol-file (symbol-file symbol)) - buf - was-here) - (unless symbol-file - (error "Can't check if defstruct member since don't know symbol file")) - (setq buf (find-buffer-visiting symbol-file)) - (setq was-here (with-current-buffer buf (point))) - (unless buf - (setq buf (find-file-noselect symbol-file))) - (with-current-buffer buf - (save-restriction - (widen) - (let* ((buf-point (find-definition-noselect symbol nil))) - (goto-char (cdr buf-point)) - (save-match-data - (when (looking-at "(defstruct (?\\(\\(?:\\sw\\|\\s_\\)+\\)") - (setq in-defstruct (match-string-no-properties 1)))))) - (if was-here - (goto-char was-here) - (kill-buffer (current-buffer)))) - in-defstruct))) -;; (ourcomments-member-defstruct 'ert-test-name) -;; (ourcomments-member-defstruct 'ert-test-error-condition) - -(defun ourcomments-custom-group-p (symbol) - (and (intern-soft symbol) - (or (and (get symbol 'custom-loads) - (not (get symbol 'custom-autoload))) - (get symbol 'custom-group)))) - -;;;###autoload -(defun describe-custom-group (symbol) - "Describe customization group SYMBOL." - (interactive - (list - (ourcomments-read-symbol "Customization group" - 'ourcomments-custom-group-p))) - ;; Fix-me: - (message "g=%s" symbol)) -;; nxhtml - -;; Added this to current-load-list in cl-macs.el -;; (describe-defstruct 'ert-stats) -;;;###autoload -(defun describe-defstruct (symbol) - (interactive (list (ourcomments-read-symbol "Describe defstruct" - 'ourcomments-defstruct-p))) - (if (not (ourcomments-defstruct-p symbol)) - (message "%s is not a CL defstruct." symbol) - (with-output-to-temp-buffer (help-buffer) - (help-setup-xref (list #'describe-defstruct symbol) (interactive-p)) - (with-current-buffer (help-buffer) - (insert "This is a description of a CL thing.") - (insert "\n\n") - (insert (format "%s is a CL `defstruct'" symbol)) - (let ((file (symbol-file symbol))) - (if file - ;; Fix-me: .elc => .el - (let ((name (file-name-nondirectory file))) - (insert "defined in file %s.\n" (file-name-nondirectory file))) - (insert ".\n"))) - (insert "\n\nIt has the following slot functions:\n") - (let ((num-slot-funs 0) - (slots (ourcomments-defstruct-slots symbol))) - (dolist (slot slots) - (if (not (fboundp (intern-soft (format "%s-%s" symbol slot)))) - (insert (format " Do not know function for slot %s\n" slot)) - (setq num-slot-funs (1+ num-slot-funs)) - (insert (format " `%s-%s'\n" symbol slot)))) - (unless (= num-slot-funs (length slots)) - (insert " No information about some slots, maybe :conc-name was used\n"))))))) - -;;(defun describe-deftype (type) -;;;###autoload -(defun describe-symbol(symbol) - "Show information about SYMBOL. -Show SYMBOL plist and whether is is a variable or/and a -function." - (interactive (list (ourcomments-read-symbol "Describe symbol" nil))) -;;; (let* ((s (symbol-at-point)) -;;; (val (completing-read (if (and (symbolp s) -;;; (not (eq s nil))) -;;; (format -;;; "Describe symbol (default %s): " s) -;;; "Describe symbol: ") -;;; obarray -;;; nil -;;; t nil nil -;;; (if (symbolp s) (symbol-name s))))) -;;; (list (if (equal val "") s (intern val))))) - (require 'apropos) - (with-output-to-temp-buffer (help-buffer) - (help-setup-xref (list #'describe-symbol symbol) (interactive-p)) - (with-current-buffer (help-buffer) - (insert (format "Description of symbol %s\n\n" symbol)) - (when (plist-get (symbol-plist symbol) 'cl-compiler-macro) - (insert "(Looks like a CL thing.)\n")) - (if (boundp symbol) - (insert (format "- There is a variable `%s'.\n" symbol)) - (insert "- This symbol is not a variable.\n")) - (if (fboundp symbol) - (progn - (insert (format "- There is a function `%s'" symbol)) - (when (ourcomments-member-defstruct symbol) - (let ((ds-name (ourcomments-member-defstruct symbol))) - (insert "\n which is a member of defstruct ") - (insert-text-button (format "%s" ds-name) - 'symbol (intern-soft ds-name) - 'action (lambda (button) - (describe-symbol - (button-get button 'symbol)))))) - (insert ".\n")) - (insert "- This symbol is not a function.\n")) - (if (facep symbol) - (insert (format "- There is a face `%s'.\n" symbol)) - (insert "- This symbol is not a face.\n")) - (if (ourcomments-custom-group-p symbol) - (progn - (insert "- There is a customization group ") - (insert-text-button (format "%s" symbol) - 'symbol symbol - 'action (lambda (button) - (describe-custom-group - (button-get button 'symbol)))) - (insert ".\n")) - (insert "- This symbol is not a customization group.\n")) - (if (ourcomments-defstruct-p symbol) - (progn - (insert (format "- There is a CL defstruct %s with setf-able slots:\n" symbol)) - (let ((num-slot-funs 0) - (slots (ourcomments-defstruct-slots symbol))) - (dolist (slot slots) - (if (not (fboundp (intern-soft (format "%s-%s" symbol slot)))) - (insert (format " Do not know function for slot %s\n" slot)) - (setq num-slot-funs (1+ num-slot-funs)) - (insert (format " `%s-%s'\n" symbol slot)))) - (unless (= num-slot-funs (length slots)) - (insert " No information about some slots, maybe :conc-name was used\n")))) - (insert "- This symbol is not a CL defstruct.\n")) - (insert "\n") - (let* ((pl (symbol-plist symbol)) - (pl-not-known (property-list-keys pl)) - any-known) - (if (not pl) - (insert (format "Symbol %s has no property list\n\n" symbol)) - ;; Known properties - (dolist (rec describe-symbol-alist) - (let ((prop (nth 0 rec)) - (desc (nth 1 rec))) - (when (plist-member pl prop) - (setq any-known (cons prop any-known)) - (setq pl-not-known (delq prop pl-not-known)) - (insert - "The following keys in the property list are known:\n\n") - (insert (format "* %s: %s\n" prop desc)) - ))) - (unless any-known - (insert "The are no known keys in the property list.\n")) - (let ((pl (ourcomments-format-plist pl "\n "))) - ;;(insert (format "plist=%s\n" (symbol-plist symbol))) - ;;(insert (format "pl-not-known=%s\n" pl-not-known)) - (insert "\nFull property list:\n\n (") - (insert (propertize pl 'face 'default)) - (insert ")\n\n"))))))) - -(defun ourcomments-format-plist (pl sep &optional compare) - (when (symbolp pl) - (setq pl (symbol-plist pl))) - (let (p desc p-out) - (while pl - (setq p (format "%s" (car pl))) - (if (or (not compare) (string-match apropos-regexp p)) - (if apropos-property-face - (put-text-property 0 (length (symbol-name (car pl))) - 'face apropos-property-face p)) - (setq p nil)) - (if p - (progn - (and compare apropos-match-face - (put-text-property (match-beginning 0) (match-end 0) - 'face apropos-match-face - p)) - (setq desc (pp-to-string (nth 1 pl))) - (setq desc (split-string desc "\n")) - (if (= 1 (length desc)) - (setq desc (concat " " (car desc))) - (let* ((indent " ") - (ind-nl (concat "\n" indent))) - (setq desc - (concat - ind-nl - (mapconcat 'identity desc ind-nl))))) - (setq p-out (concat p-out (if p-out sep) p desc)))) - (setq pl (nthcdr 2 pl))) - p-out)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; ido - -(defvar ourcomments-ido-visit-method nil) - -;;;###autoload -(defun ourcomments-ido-buffer-other-window () - "Show buffer in other window." - (interactive) - (setq ourcomments-ido-visit-method 'other-window) - (call-interactively 'ido-exit-minibuffer)) - -;;;###autoload -(defun ourcomments-ido-buffer-other-frame () - "Show buffer in other frame." - (interactive) - (setq ourcomments-ido-visit-method 'other-frame) - (call-interactively 'ido-exit-minibuffer)) - -;;;###autoload -(defun ourcomments-ido-buffer-raise-frame () - "Raise frame showing buffer." - (interactive) - (setq ourcomments-ido-visit-method 'raise-frame) - (call-interactively 'ido-exit-minibuffer)) - -(defun ourcomments-ido-switch-buffer-or-next-entry () - (interactive) - (if (active-minibuffer-window) - (ido-next-match) - (ido-switch-buffer))) - -(defun ourcomments-ido-mode-advice() - (when (memq ido-mode '(both buffer)) - (let ((the-ido-minor-map (cdr ido-minor-mode-map-entry))) - ;;(define-key the-ido-minor-map [(control tab)] 'ido-switch-buffer)) - (define-key the-ido-minor-map [(control tab)] 'ourcomments-ido-switch-buffer-or-next-entry)) - (dolist (the-map (list ido-buffer-completion-map ido-completion-map ido-common-completion-map)) - (when the-map - (let ((map the-map)) - (define-key map [(control tab)] 'ido-next-match) - (define-key map [(control shift tab)] 'ido-prev-match) - (define-key map [(control backtab)] 'ido-prev-match) - (define-key map [(shift return)] 'ourcomments-ido-buffer-other-window) - (define-key map [(control return)] 'ourcomments-ido-buffer-other-frame) - (define-key map [(meta return)] 'ourcomments-ido-buffer-raise-frame)))))) - -;; (defun ourcomments-ido-setup-completion-map () -;; "Set up the keymap for `ido'." - -;; (ourcomments-ido-mode-advice) - -;; ;; generated every time so that it can inherit new functions. -;; (let ((map (make-sparse-keymap)) -;; (viper-p (if (boundp 'viper-mode) viper-mode))) - -;; (when viper-p -;; (define-key map [remap viper-intercept-ESC-key] 'ignore)) - -;; (cond -;; ((memq ido-cur-item '(file dir)) -;; (when ido-context-switch-command -;; (define-key map "\C-x\C-b" ido-context-switch-command) -;; (define-key map "\C-x\C-d" 'ignore)) -;; (when viper-p -;; (define-key map [remap viper-backward-char] 'ido-delete-backward-updir) -;; (define-key map [remap viper-del-backward-char-in-insert] 'ido-delete-backward-updir) -;; (define-key map [remap viper-delete-backward-word] 'ido-delete-backward-word-updir)) -;; (set-keymap-parent map -;; (if (eq ido-cur-item 'file) -;; ido-file-completion-map -;; ido-file-dir-completion-map))) - -;; ((eq ido-cur-item 'buffer) -;; (when ido-context-switch-command -;; (define-key map "\C-x\C-f" ido-context-switch-command)) -;; (set-keymap-parent map ido-buffer-completion-map)) - -;; (t -;; (set-keymap-parent map ido-common-completion-map))) - -;; ;; ctrl-tab etc -;; (define-key map [(control tab)] 'ido-next-match) -;; (define-key map [(control shift tab)] 'ido-prev-match) -;; (define-key map [(control backtab)] 'ido-prev-match) -;; (define-key map [(shift return)] 'ourcomments-ido-buffer-other-window) -;; (define-key map [(control return)] 'ourcomments-ido-buffer-other-frame) -;; (define-key map [(meta return)] 'ourcomments-ido-buffer-raise-frame) - -;; (setq ido-completion-map map))) - -;; (defadvice ido-setup-completion-map (around -;; ourcomments-advice-ido-setup-completion-map -;; disable) -;; (setq ad-return-value (ourcomments-ido-setup-completion-map)) -;; ) - -;;(add-hook 'ido-setup-hook 'ourcomments-ido-mode-advice) -;;(remove-hook 'ido-setup-hook 'ourcomments-ido-mode-advice) -(defvar ourcomments-ido-adviced nil) -(unless ourcomments-ido-adviced -(defadvice ido-mode (after - ourcomments-advice-ido-mode - ;;activate - ;;compile - disable) - "Add C-tab to ido buffer completion." - (ourcomments-ido-mode-advice) - ;;ad-return-value - ) -;; (ad-activate 'ido-mode) -;; (ad-deactivate 'ido-mode) - -(defadvice ido-visit-buffer (before - ourcomments-advice-ido-visit-buffer - ;;activate - ;;compile - disable) - "Advice to show buffers in other window, frame etc." - (when ourcomments-ido-visit-method - (ad-set-arg 1 ourcomments-ido-visit-method) - (setq ourcomments-ido-visit-method nil) - )) -(setq ourcomments-ido-adviced t) -) - -;;(message "after advising ido") -;;(ad-deactivate 'ido-visit-buffer) -;;(ad-activate 'ido-visit-buffer) - -(defvar ourcomments-ido-old-state ido-mode) - -(defun ourcomments-ido-ctrl-tab-activate () - ;;(message "ourcomments-ido-ctrl-tab-activate running") - ;;(ad-update 'ido-visit-buffer) - ;;(unless (ad-get-advice-info 'ido-visit-buffer) - ;; Fix-me: The advice must be enabled before activation. Send bug report. - (ad-enable-advice 'ido-visit-buffer 'before 'ourcomments-advice-ido-visit-buffer) - (unless (cdr (assoc 'active (ad-get-advice-info 'ido-visit-buffer))) - (ad-activate 'ido-visit-buffer)) - ;; (ad-enable-advice 'ido-setup-completion-map 'around 'ourcomments-advice-ido-setup-completion-map) - ;; (unless (cdr (assoc 'active (ad-get-advice-info 'ido-setup-completion-map))) - ;; (ad-activate 'ido-setup-completion-map)) - ;;(ad-update 'ido-mode) - (ad-enable-advice 'ido-mode 'after 'ourcomments-advice-ido-mode) - (unless (cdr (assoc 'active (ad-get-advice-info 'ido-mode))) - (ad-activate 'ido-mode)) - (setq ourcomments-ido-old-state ido-mode) - (ido-mode (or ido-mode 'buffer))) - -;;;###autoload -(define-minor-mode ourcomments-ido-ctrl-tab - "Enable buffer switching using C-Tab with function `ido-mode'. -This changes buffer switching with function `ido-mode' the -following way: - -- You can use C-Tab. - -- You can show the selected buffer in three ways independent of - how you entered function `ido-mode' buffer switching: - - * S-return: other window - * C-return: other frame - * M-return: raise frame - -Those keys are selected to at least be a little bit reminiscent -of those in for example common web browsers." - :global t - :group 'emacsw32 - :group 'convenience - (if ourcomments-ido-ctrl-tab - (ourcomments-ido-ctrl-tab-activate) - (ad-disable-advice 'ido-visit-buffer 'before - 'ourcomments-advice-ido-visit-buffer) - (ad-disable-advice 'ido-mode 'after - 'ourcomments-advice-ido-mode) - ;; For some reason this little complicated construct is - ;; needed. If they are not there the defadvice - ;; disappears. Huh. - ;;(if ourcomments-ido-old-state - ;; (ido-mode ourcomments-ido-old-state) - ;; (when ido-mode (ido-mode -1))) - )) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; New Emacs instance - -(defun ourcomments-find-emacs () - (locate-file invocation-name - (list invocation-directory) - exec-suffixes - ;; 1 ;; Fix-me: This parameter is depreceated, but used - ;; in executable-find, why? - )) - -(defvar ourcomments-restart-server-mode nil) - -(defun emacs-restart-in-kill () - "Last step in restart Emacs and start `server-mode' if on before." - (let* ((restart-args (when ourcomments-restart-server-mode - ;; Delay 3+2 sec to be sure the old server has stopped. - (list "--eval=(run-with-idle-timer 5 nil 'server-mode 1)"))) - ;; Fix-me: There is an Emacs bug here, default-directory shows - ;; up in load-path in the new Eamcs if restart-args is like - ;; this, but not otherwise. And it has w32 file syntax. The - ;; work around below is the best I can find at the moment. - (first-path (catch 'first - (dolist (p load-path) - (when (file-directory-p p) - (throw 'first p))))) - (default-directory (file-name-as-directory (expand-file-name first-path)))) - ;; Fix-me: Adding -nw to restart in console does not work. Any way to fix it? - (unless window-system (setq restart-args (cons "-nw" restart-args))) - ;;(apply 'call-process (ourcomments-find-emacs) nil 0 nil restart-args) - (apply 'emacs restart-args) - ;; Wait to give focus to new Emacs instance: - (sleep-for 3))) - -;;;###autoload -(defun emacs-restart () - "Restart Emacs and start `server-mode' if on before." - (interactive) - (if (not window-system) - (message "Can't restart emacs if window-system is nil") - (let ((wait 4)) - (while (> (setq wait (1- wait)) 0) - (message (propertize (format "Will restart Emacs in %d seconds..." wait) - 'face 'secondary-selection)) - (sit-for 1))) - (setq ourcomments-restart-server-mode server-mode) - (add-hook 'kill-emacs-hook 'emacs-restart-in-kill t) - (save-buffers-kill-emacs))) - -(defvar ourcomments-started-emacs-use-output-buffer nil - "If non-nil then save output form `emacs'. -Set this to `t' to debug problems with starting a new Emacs. - -If non-nil save output to buffer 'call-process emacs output'. -Note that this will lock the Emacs calling `emacs' until the new -Emacs has finished.") -;;(setq ourcomments-started-emacs-use-output-buffer t) -;;(defun my-test () (interactive) (emacs-Q "-bad-arg")) - -;;;###autoload -(defun emacs (&rest args) - "Start a new Emacs with default parameters. -Additional ARGS are passed to the new Emacs. - -See also `ourcomments-started-emacs-use-output-buffer'." - (interactive) - (recentf-save-list) - (let* ((out-buf (when ourcomments-started-emacs-use-output-buffer - (get-buffer-create "call-process emacs output"))) - (buf-arg (or out-buf 0)) - (args-text (mapconcat 'identity (cons "" args) " ")) - ret - (fin-msg "")) - (when out-buf - (display-buffer out-buf) - (setq fin-msg ". Finished.") - (message "Started 'emacs%s' => %s. Locked until this is finished." args-text ret fin-msg) - (redisplay)) - (setq ret (apply 'call-process (ourcomments-find-emacs) nil buf-arg nil args)) - (message "Started 'emacs%s' => %s%s" args-text ret fin-msg) - ret)) - -;;;###autoload -(defun emacs-buffer-file() - "Start a new Emacs showing current buffer file. -Go to the current line and column in that file. -If there is no buffer file then instead start with `dired'. - -This calls the function `emacs' with argument --no-desktop and -the file or a call to dired." - (interactive) - (recentf-save-list) - (let ((file (buffer-file-name)) - (lin (line-number-at-pos)) - (col (current-column))) - (if file - (apply 'emacs "--no-desktop" (format "+%d:%d" lin col) file nil) - (applay 'emacs "--no-desktop" "--eval" (format "(dired \"%s\")" default-directory nil))))) - -;;;###autoload -(defun emacs--debug-init(&rest args) - "Start a new Emacs with --debug-init parameter. -This calls the function `emacs' with added arguments ARGS." - (interactive) - (apply 'emacs "--debug-init" args)) - -;;;###autoload -(defun emacs--no-desktop (&rest args) - "Start a new Emacs with --no-desktop parameter. -This calls the function `emacs' with added arguments ARGS." - (interactive) - (apply 'emacs "--no-desktop" args)) - -;;;###autoload -(defun emacs-Q (&rest args) - "Start a new Emacs with -Q parameter. -Start new Emacs without any customization whatsoever. -This calls the function `emacs' with added arguments ARGS." - (interactive) - (apply 'emacs "-Q" args)) - -;;;###autoload -(defun emacs-Q-nxhtml(&rest args) - "Start new Emacs with -Q and load nXhtml. -This calls the function `emacs' with added arguments ARGS." - (interactive) - (let ((autostart (if (boundp 'nxhtml-install-dir) - (expand-file-name "autostart.el" nxhtml-install-dir) - (expand-file-name "../../EmacsW32/nxhtml/autostart.el" - exec-directory)))) - (apply 'emacs-Q "--debug-init" "--load" autostart args))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Searching - -(defun grep-get-buffer-files () - "Return list of files in a `grep-mode' buffer." - (or (and (compilation-buffer-p (current-buffer)) - (derived-mode-p 'grep-mode)) - (error "Not in a grep buffer")) - (let ((here (point)) - files - loc) - (font-lock-fontify-buffer) - (goto-char (point-min)) - (while (setq loc - (condition-case err - (compilation-next-error 1) - (error - ;; This should be the end, but give a message for - ;; easier debugging. - (message "%s" err) - nil))) - ;;(message "here =%s, loc=%s" (point) loc) - (let ((file (caar (nth 2 (car loc))))) - (setq file (expand-file-name file)) - (add-to-list 'files file))) - (goto-char here) - ;;(message "files=%s" files) - files)) - -(defvar grep-query-replace-defaults nil - "Default values of FROM-STRING and TO-STRING for `grep-query-replace'. -This is a cons cell (FROM-STRING . TO-STRING), or nil if there is -no default value.") - -;; Mostly copied from `dired-do-query-replace-regexp'. Fix-me: finish, test -;;;###autoload -(defun grep-query-replace(from to &optional delimited) - "Do `query-replace-regexp' of FROM with TO, on all files in *grep*. -Third arg DELIMITED (prefix arg) means replace only word-delimited matches. -If you exit (\\[keyboard-quit], RET or q), you can resume the query replace -with the command \\[tags-loop-continue]." - (interactive - (let ((common - ;; Use the regexps that have been used in grep - (let ((query-replace-from-history-variable 'grep-regexp-history) - (query-replace-defaults (or grep-query-replace-defaults - query-replace-defaults))) - (query-replace-read-args - "Query replace regexp in files in *grep*" t t)))) - (setq grep-query-replace-defaults (cons (nth 0 common) - (nth 1 common))) - (list (nth 0 common) (nth 1 common) (nth 2 common)))) - (dolist (file (grep-get-buffer-files)) - (let ((buffer (get-file-buffer file))) - (if (and buffer (with-current-buffer buffer - buffer-read-only)) - (error "File `%s' is visited read-only" file)))) - (tags-query-replace from to delimited - '(grep-get-buffer-files))) - -;;;###autoload -(defun ldir-query-replace (from to files dir &optional delimited) - "Replace FROM with TO in FILES in directory DIR. -This runs `query-replace-regexp' in files matching FILES in -directory DIR. - -See `tags-query-replace' for DELIMETED and more information." - (interactive (dir-replace-read-parameters nil nil)) - (message "%s" (list from to files dir delimited)) - ;;(let ((files (directory-files root nil file-regexp))) (message "files=%s" files)) - (tags-query-replace from to delimited - `(directory-files ,dir t ,files))) - -;;;###autoload -(defun rdir-query-replace (from to file-regexp root &optional delimited) - "Replace FROM with TO in FILES in directory tree ROOT. -This runs `query-replace-regexp' in files matching FILES in -directory tree ROOT. - -See `tags-query-replace' for DELIMETED and more information." - (interactive (dir-replace-read-parameters nil t)) - (message "%s" (list from to file-regexp root delimited)) - ;;(let ((files (directory-files root nil file-regexp))) (message "files=%s" files)) - (tags-query-replace from to delimited - `(rdir-get-files ,root ,file-regexp))) - -;; (rdir-get-files ".." "^a.*\.el$") -(defun rdir-get-files (root file-regexp) - (let ((files (directory-files root t file-regexp)) - (subdirs (directory-files root t))) - (dolist (subdir subdirs) - (when (and (file-directory-p subdir) - (not (or (string= "/." (substring subdir -2)) - (string= "/.." (substring subdir -3))))) - (setq files (append files (rdir-get-files subdir file-regexp) nil)))) - files)) - -(defun dir-replace-read-parameters (has-dir recursive) - (let* ((common - (let (;;(query-replace-from-history-variable 'grep-regexp-history) - ;;(query-replace-defaults (or grep-query-replace-defaults - ;; query-replace-defaults)) - ) - (query-replace-read-args - "Query replace regexp in files" t t))) - (from (nth 0 common)) - (to (nth 1 common)) - (delimited (nth 2 common)) - (files (replace-read-files from to)) - (root (unless has-dir (read-directory-name (if recursive "Root directory: " - "In single directory: "))))) - (list from to files root delimited))) - -;; Mostly copied from `grep-read-files'. Could possible be merged with -;; that. -(defvar replace-read-files-history nil) -;;;###autoload -(defun replace-read-files (regexp &optional replace) - "Read files arg for replace." - (let* ((bn (or (buffer-file-name) (buffer-name))) - (fn (and bn - (stringp bn) - (file-name-nondirectory bn))) - (default - (let ((pre-default - (or (and fn - (let ((aliases grep-files-aliases) - alias) - (while aliases - (setq alias (car aliases) - aliases (cdr aliases)) - (if (string-match (wildcard-to-regexp - (cdr alias)) fn) - (setq aliases nil) - (setq alias nil))) - (cdr alias))) - (and fn - (let ((ext (file-name-extension fn))) - (and ext (concat "^.*\." ext)))) - (car replace-read-files-history) - (car (car grep-files-aliases))))) - (if (string-match-p "^\\*\\.[a-zA-Z0-9]*$" pre-default) - (concat "\\." (substring pre-default 2) "$") - pre-default))) - (files (read-string - (if replace - (concat "Replace \"" regexp - "\" with \"" replace "\" in files" - (if default (concat " (default " default - ", regexp or *.EXT)")) - ": ") - (concat "Search for \"" regexp - "\" in files" - (if default (concat " (default " default ")")) - ": ")) - nil 'replace-read-files-history default))) - (let ((pattern (and files - (or (cdr (assoc files grep-files-aliases)) - files)))) - (if (and pattern - (string-match-p "^\\*\\.[a-zA-Z0-9]*$" pattern)) - (concat "\\." (substring pattern 2) "$") - pattern)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Info - -;;;###autoload -(defun info-open-file (info-file) - "Open an info file in `Info-mode'." - (interactive - (let ((name (read-file-name "Info file: " - nil ;; dir - nil ;; default-filename - t ;; mustmatch - nil ;; initial - ;; predicate: - (lambda (file) - (or (file-directory-p file) - (string-match ".*\\.info\\'" file)))))) - (list name))) - (info info-file)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Exec path etc - -(defun ourcomments-which (prog) - "Look for first program PROG in `exec-path' using `exec-suffixes'. -Return full path if found." - (interactive "sProgram: ") - (let ((path (executable-find prog))) - (when (with-no-warnings (called-interactively-p)) - (message "%s found in %s" prog path)) - path)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Custom faces and keys - -;;;###autoload -(defun use-custom-style () - "Setup like in `Custom-mode', but without things specific to Custom." - (make-local-variable 'widget-documentation-face) - (setq widget-documentation-face 'custom-documentation) - (make-local-variable 'widget-button-face) - (setq widget-button-face custom-button) - (setq show-trailing-whitespace nil) - - ;; We need this because of the "More" button on docstrings. - ;; Otherwise clicking on "More" can push point offscreen, which - ;; causes the window to recenter on point, which pushes the - ;; newly-revealed docstring offscreen; which is annoying. -- cyd. - (set (make-local-variable 'widget-button-click-moves-point) t) - - (set (make-local-variable 'widget-button-pressed-face) custom-button-pressed) - (set (make-local-variable 'widget-mouse-face) custom-button-mouse) - - ;; When possible, use relief for buttons, not bracketing. This test - ;; may not be optimal. - (when custom-raised-buttons - (set (make-local-variable 'widget-push-button-prefix) "") - (set (make-local-variable 'widget-push-button-suffix) "") - (set (make-local-variable 'widget-link-prefix) "") - (set (make-local-variable 'widget-link-suffix) "")) - - ;; From widget-keymap - (local-set-key "\t" 'widget-forward) - (local-set-key "\e\t" 'widget-backward) - (local-set-key [(shift tab)] 'advertised-widget-backward) - (local-set-key [backtab] 'widget-backward) - (local-set-key [down-mouse-2] 'widget-button-click) - (local-set-key [down-mouse-1] 'widget-button-click) - (local-set-key [(control ?m)] 'widget-button-press) - ;; From custom-mode-map - (local-set-key " " 'scroll-up) - (local-set-key "\177" 'scroll-down) - (local-set-key "n" 'widget-forward) - (local-set-key "p" 'widget-backward)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Bookmarks - -(defun bookmark-next-marked () - (interactive) - (let ((bb (get-buffer "*Bookmark List*")) - pos) - (when bb - (with-current-buffer bb - (setq pos (re-search-forward "^>" nil t)) - (unless pos - (goto-char (point-min)) - (setq pos (re-search-forward "^>" nil t))))) - (if pos - (with-current-buffer bb - ;; Defined in bookmark.el, should be loaded now. - (bookmark-bmenu-this-window)) - (call-interactively 'bookmark-bmenu-list) - (message "Please select bookmark for bookmark next command, then press n")))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Org Mode - -(defun ourcomments-org-complete-and-replace-file-link () - "If on a org file link complete file name and replace it." - (interactive) - (require 'org) - (let* ((here (point-marker)) - (on-link (eq 'org-link (get-text-property (point) 'face))) - (link-beg (when on-link - (previous-single-property-change (1+ here) 'face))) - (link-end (when on-link - (next-single-property-change here 'face))) - (link (when on-link (buffer-substring-no-properties link-beg link-end))) - type+link - link-link - link-link-beg - link-link-end - new-link - dir - ovl) - (when (and on-link - (string-match (rx string-start "[[" - (group (0+ (not (any "]"))))) link)) - (setq type+link (match-string 1 link)) - (when (string-match "^file:\\(.*\\)" type+link) - (setq link-link (match-string 1 type+link)) - (setq link-link-beg (+ 2 link-beg (match-beginning 1))) - (setq link-link-end (+ 2 link-beg (match-end 1))) - (unwind-protect - (progn - (setq ovl (make-overlay link-link-beg link-link-end)) - (overlay-put ovl 'face 'highlight) - (when link-link - (setq link-link (org-link-unescape link-link)) - (setq dir (when (and link-link (> (length link-link) 0)) - (file-name-directory link-link))) - (setq new-link (read-file-name "Org file:" dir nil nil (file-name-nondirectory link-link))) - (delete-overlay ovl) - (setq new-link (expand-file-name new-link)) - (setq new-link (file-relative-name new-link)) - (delete-region link-link-beg link-link-end) - (goto-char link-link-beg) - (insert (org-link-escape new-link)) - t)) - (delete-overlay ovl) - (goto-char here)))))) - -;; (defun ourcomments-org-paste-html-link (html-link) -;; "If there is an html link on clipboard paste it as an org link. -;; If you have this on the clipboard -;; <a href=\"http://my.site.org/\">My Site</a> -;; It will paste this -;; [[http://my.site.org/][My Site]] -;; If the URL is to a local file it will create an org link to the -;; file. -;; Tip: You can use the Firefox plugin Copy as HTML Link, see URL -;; `https://addons.mozilla.org/en-US/firefox/addon/2617'. -;; " -;; (interactive (list (current-kill 0))) -;; (let ((conv-link (ourcomments-org-convert-html-link html-link))) -;; (if (not conv-link) -;; (message (propertize "No html link on clipboard" 'face 'font-lock-warning-face)) -;; (insert conv-link)))) - -;; (defun ourcomments-org-convert-html-link (html-link) -;; (let (converted url str) -;; (save-match-data -;; (while (string-match ourcomments-org-paste-html-link-regexp html-link) -;; (setq converted t) -;; (setq url (match-string 1 html-link)) -;; (setq str (match-string 2 html-link)) -;; ;;(setq str (concat str (format "%s" (setq temp-n (1+ temp-n))))) -;; (setq html-link (replace-match (concat "[[" url "][" str "]]") nil nil html-link 0)))) -;; (when converted -;; html-link))) - -(defconst ourcomments-org-paste-html-link-regexp - "\\`\\(?:<a [^>]*?href=\"\\(.*?\\)\"[^>]*?>\\([^<]*\\)</a>\\)\\'") - -;;(string-match-p ourcomments-org-paste-html-link-regexp "<a href=\"link\">text</a>") - -;;(defvar temp-n 0) -(defun ourcomments-org-convert-html-links-in-buffer (beg end) - "Convert html link between BEG and END to org mode links. -If there is an html link in the buffer - - <a href=\"http://my.site.org/\">My Site</a> - -that starts at BEG and ends at END then convert it to this - - [[http://my.site.org/][My Site]] - -If the URL is to a local file and the buffer is visiting a file -make the link relative. - -However, if the html link is inside an #+BEGIN - #+END block or a -variant of such blocks then leave the link as it is." - (when (derived-mode-p 'org-mode) - (save-match-data - (let ((here (copy-marker (point))) - url str converted - lit-beg lit-end) - (goto-char beg) - (save-restriction - (widen) - (setq lit-beg (search-backward "#+BEGIN" nil t)) - (when lit-beg - (goto-char lit-beg) - (setq lit-end (or (search-forward "#+END" nil t) - (point-max))))) - (when (or (not lit-beg) - (> beg lit-end)) - (goto-char beg) - (when (save-restriction - (narrow-to-region beg end) - (looking-at ourcomments-org-paste-html-link-regexp)) - (setq converted t) - (setq url (match-string-no-properties 1)) - (setq str (match-string-no-properties 2)) - ;; Check if the URL is to a local file and absolute. And we - ;; have a buffer. - (when (and (buffer-file-name) - (> (length url) 5) - (string= (substring url 0 6) "file:/")) - (let ((abs-file-url - (if (not (memq system-type '(windows-nt ms-dos))) - (substring url 8) - (if (string= (substring url 0 8) "file:///") - (substring url 8) - ;; file://c:/some/where.txt - (substring url 7))))) - (setq url (concat "file:" - (file-relative-name abs-file-url - (file-name-directory - (buffer-file-name))))))) - (replace-match (concat "[[" url "][" str "]]") nil nil nil 0))) - (goto-char here) - nil)))) - -(defvar ourcomments-paste-with-convert-hook nil - "Normal hook run after certain paste commands. -These paste commands are in the list -`ourcomments-paste-with-convert-commands'. - -Each function in this hook is called with two parameters, the -start and end of the pasted text, until a function returns -non-nil.") -(add-hook 'ourcomments-paste-with-convert-hook 'ourcomments-org-convert-html-links-in-buffer) - -(defvar ourcomments-paste-beg) ;; dyn var -(defvar ourcomments-paste-end) ;; dyn var -(defun ourcomments-grab-paste-bounds (beg end len) - (setq ourcomments-paste-beg (min beg ourcomments-paste-beg)) - (setq ourcomments-paste-end (max end ourcomments-paste-end))) - -(defmacro ourcomments-advice-paste-command (paste-command) - (let ((adv-name (make-symbol (concat "ourcomments-org-ad-" - (symbol-name paste-command))))) - `(defadvice ,paste-command (around - ,adv-name) - (let ((ourcomments-paste-beg (point-max)) ;; dyn var - (ourcomments-paste-end (point-min))) ;; dyn var - (add-hook 'after-change-functions `ourcomments-grab-paste-bounds nil t) - ad-do-it ;;;;;;;;;;;;;;;;;;;;;;;;;; - (remove-hook 'after-change-functions `ourcomments-grab-paste-bounds t) - (run-hook-with-args-until-success 'ourcomments-paste-with-convert-hook - ourcomments-paste-beg - ourcomments-paste-end))))) - -(defcustom ourcomments-paste-with-convert-commands '(yank cua-paste viper-put-back viper-Put-back) - "Commands for which past converting is done. -See `ourcomments-paste-with-convert-mode' for more information." - :type '(repeat function) - :group 'ourcomments-util) - -;;;###autoload -(define-minor-mode ourcomments-paste-with-convert-mode - "Pasted text may be automatically converted in this mode. -The functions in `ourcomments-paste-with-convert-hook' are run -after commands in `ourcomments-paste-with-convert-commands' if any -of the functions returns non-nil that text is inserted instead of -the original text. - -For exampel when this mode is on and you paste an html link in an -`org-mode' buffer it will be directly converted to an org style -link. \(This is the default behaviour.) - -Tip: The Firefox plugin Copy as HTML Link is handy, see URL - `https://addons.mozilla.org/en-US/firefox/addon/2617'. - -Note: This minor mode will defadvice the paste commands." - :global t - :group 'cua - :group 'viper - :group 'ourcomments-util - (if ourcomments-paste-with-convert-mode - (progn - (dolist (command ourcomments-paste-with-convert-commands) - (eval `(ourcomments-advice-paste-command ,command)) - (ad-activate command))) - (dolist (command ourcomments-paste-with-convert-commands) - (ad-unadvise command)))) - -;; (ourcomments-advice-paste-command cua-paste) -;; (ad-activate 'cua-paste) -;; (ad-deactivate 'cua-paste) -;; (ad-update 'cua-paste) -;; (ad-unadvise 'cua-paste) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Menu commands to M-x history - -;; (where-is-internal 'mumamo-mark-chunk nil nil) -;; (where-is-internal 'mark-whole-buffer nil nil) -;; (where-is-internal 'save-buffer nil nil) -;; (where-is-internal 'revert-buffer nil nil) -;; (setq extended-command-history nil) -(defun ourcomments-M-x-menu-pre () - "Add menu command to M-x history." - (let ((is-menu-command (equal '(menu-bar) - (when (< 0 (length (this-command-keys-vector))) - (elt (this-command-keys-vector) 0)))) - (pre-len (length extended-command-history))) - (when (and is-menu-command - (not (memq this-command '(ourcomments-M-x-menu-mode)))) - (pushnew (symbol-name this-command) extended-command-history) - (when (< pre-len (length extended-command-history)) - ;; This message is given pre-command and is therefore likely - ;; to be overwritten, but that is ok in this case. If the user - ;; has seen one of these messages s?he knows. - (message (propertize "(Added %s to M-x history so you can run it from there)" - 'face 'file-name-shadow) - this-command))))) - -;;;###autoload -(define-minor-mode ourcomments-M-x-menu-mode - "Add commands started from Emacs menus to M-x history. -The purpose of this is to make it easier to redo them and easier -to learn how to do them from the command line \(which is often -faster if you know how to do it). - -Only commands that are not already in M-x history are added." - :global t - (if ourcomments-M-x-menu-mode - (add-hook 'pre-command-hook 'ourcomments-M-x-menu-pre) - (remove-hook 'pre-command-hook 'ourcomments-M-x-menu-pre))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Warnings etc - -(defvar ourcomments-warnings nil) - -(defun ourcomments-display-warnings () - (condition-case err - (let ((msg (mapconcat 'identity (reverse ourcomments-warnings) "\n"))) - (setq ourcomments-warnings nil) - (message "%s" (propertize msg 'face 'secondary-selection))) - (error (message "ourcomments-display-warnings: %s" err)))) - -(defun ourcomments-warning-post () - (condition-case err - (run-with-idle-timer 0.5 nil 'ourcomments-display-warnings) - (error (message "ourcomments-warning-post: %s" err)))) - -;;;###autoload -(defun ourcomments-warning (format-string &rest args) - (setq ourcomments-warnings (cons (apply 'format format-string args) - ourcomments-warnings)) - (add-hook 'post-command-hook 'ourcomments-warning-post)) - - - -(provide 'ourcomments-util) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ourcomments-util.el ends here diff --git a/emacs.d/nxhtml/util/ourcomments-widgets.el b/emacs.d/nxhtml/util/ourcomments-widgets.el deleted file mode 100644 index 359a0b1..0000000 --- a/emacs.d/nxhtml/util/ourcomments-widgets.el +++ /dev/null @@ -1,141 +0,0 @@ -;;; ourcomments-widgets.el --- widgets for custom etc -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2009-10-13 Tue -;; Version: -;; Last-Updated: -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'mumamo nil t)) - -;;;###autoload (autoload 'command "ourcomments-widgets") -(define-widget 'command 'restricted-sexp - "A command function." - :complete-function (lambda () - (interactive) - (lisp-complete-symbol 'commandp)) - :prompt-value 'widget-field-prompt-value - :prompt-internal 'widget-symbol-prompt-internal - :prompt-match 'commandp - :prompt-history 'widget-command-prompt-value-history - :action 'widget-field-action - :match-alternatives '(commandp) - :validate (lambda (widget) - (unless (commandp (widget-value widget)) - (widget-put widget :error (format "Invalid command: %S" - (widget-value widget))) - widget)) - :value 'ignore - :tag "Command") - - -;;;###autoload -(defun major-or-multi-majorp (value) - "Return t if VALUE is a major or multi major mode function." - (or (and (fboundp 'mumamo-multi-major-modep) - (fboundp (mumamo-multi-major-modep value))) - (major-modep value))) - -;; Fix-me: This might in the future be defined in Emacs. -;;;###autoload -(defun major-modep (value) - "Return t if VALUE is a major mode function." - (let ((sym-name (symbol-name value))) - ;; Do some reasonable test to find out if it is a major mode. - ;; Load autoloaded mode functions. - ;; - ;; Fix-me: Maybe test for minor modes? How was that done? - (when (and (fboundp value) - (commandp value) - (not (memq value '(flyspell-mode - isearch-mode - savehist-mode - ))) - (< 5 (length sym-name)) - (string= "-mode" (substring sym-name (- (length sym-name) 5))) - (if (and (listp (symbol-function value)) - (eq 'autoload (car (symbol-function value)))) - (progn - (message "loading ") - (load (cadr (symbol-function value)) t t)) - t) - (or (memq value - ;; Fix-me: Complement this table of known major modes: - '(fundamental-mode - xml-mode - nxml-mode - nxhtml-mode - css-mode - javascript-mode - espresso-mode - php-mode - )) - (and (intern-soft (concat sym-name "-hook")) - ;; This fits `define-derived-mode' - (get (intern-soft (concat sym-name "-hook")) 'variable-documentation)) - (progn (message "Not a major mode: %s" value) - ;;(sit-for 4) - nil) - )) - t))) - -;;;###autoload (autoload 'major-mode-function "ourcomments-widgets") -(define-widget 'major-mode-function 'function - "A major mode lisp function." - :complete-function (lambda () - (interactive) - (lisp-complete-symbol 'major-or-multi-majorp)) - :prompt-match 'major-or-multi-majorp - :prompt-history 'widget-function-prompt-value-history - :match-alternatives '(major-or-multi-majorp) - :validate (lambda (widget) - (unless (major-or-multi-majorp (widget-value widget)) - (widget-put widget :error (format "Invalid function: %S" - (widget-value widget))) - widget)) - :value 'fundamental-mode - :tag "Major mode function") - - - -(provide 'ourcomments-widgets) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ourcomments-widgets.el ends here diff --git a/emacs.d/nxhtml/util/pause.el b/emacs.d/nxhtml/util/pause.el deleted file mode 100644 index 2e98d36..0000000 --- a/emacs.d/nxhtml/util/pause.el +++ /dev/null @@ -1,794 +0,0 @@ -;;; pause.el --- Take a break! -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-01-19 Sat -(defconst pause:version "0.70");; Version: -;; Last-Updated: 2010-01-18 Mon -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; If you are using Emacs then don't you need a little reminder to -;; take a pause? This library makes Emacs remind you of that. And -;; gives you a link to a yoga exercise to try in the pause. -;; -;; There are essentially two different ways to use this library. -;; Either you run a separate Emacs process that just reminds you of -;; pauses. To use it that way see `pause-start-in-new-emacs'. -;; -;; Or run it in the current Emacs. To do that add to your .emacs -;; -;; (require 'pause) -;; -;; and do -;; -;; M-x customize-group RET pause RET -;; -;; and set `pause-mode' to t. -;; -;; -;; Note: I am unsure if it works on all systems to use a separate -;; Emacs process. It does work on w32 though. Please tell me -;; about other systems. -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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: - -;;;###autoload -(defgroup pause nil - "Customize your health personal Emacs health saver!" - :group 'convenience) - -(defcustom pause-after-minutes 15 - "Pause after this number of minutes." - :type 'number - :group 'pause) - -(defcustom pause-1-minute-delay 60 - "Number of seconds to wait in 1 minutes delay." - :type 'number - :group 'pause) - -(defcustom pause-idle-delay 5 - "Seconds to wait for user to be idle before pause." - :type 'number - :group 'pause) - -(defcustom pause-even-if-not-in-emacs t - "Jump up pause even if not in Emacs." - :type 'boolean - :group 'pause) - -(defcustom pause-restart-anyway-after 2 - "If user does not use Emacs restart timer after this minutes. -This is used when a user has clicked a link." - :type 'number - :group 'pause) - -(defcustom pause-tell-again-after 2 - "If user does not exit pause tell again after this minutes." - :type 'number - :group 'pause) - -(defcustom pause-extra-fun 'pause-start-get-yoga-poses - "Function to call for extra fun when pausing. -Default is to show a link to a yoga exercise (recommended!). - -Set this variable to nil if you do not want any extra fun. - -If this variable's value is a function it will be called when the -pause frame has just been shown." - :type '(choice (function :tag "Extra function") - (const :tag "No extra function" nil)) - :group 'pause) - -(defvar pause-exited-from-button nil) - -(defcustom pause-background-color "orange" - "Background color during pause." - :type 'color - :group 'pause) - -(defcustom pause-mode-line-color "sienna" - "Mode line color during pause." - :type 'color - :group 'pause) - -(defcustom pause-1-minute-mode-line-color "yellow" - "Mode line color during 1 minute phase of pause." - :type 'color - :group 'pause) - -(defface pause-text-face - '((t (:foreground "sienna" :height 1.5 :bold t))) - "Face main text in pause buffer." - :group 'pause) - -(defface pause-info-text-face - '((t (:foreground "yellow"))) - "Face info text in pause buffer." - :group 'pause) - -(defface pause-message-face - '((t (:inherit secondary-selection))) - "Face for pause messages." - :group 'pause) - -(defface pause-1-minute-message-face - '((t (:inherit mode-line-inactive))) - "Face for pause messages." - :group 'pause) - -(defcustom pause-break-text - (concat "\n\tHi there," - "\n\tYou are worth a PAUSE!" - "\n\nTry some mindfulness:" - "\n\t- Look around and observe." - "\n\t- Listen." - "\n\t- Feel your body.") - "Text to show during pause." - :type 'integer - :group 'pause) - -(defvar pause-el-file (or load-file-name - (when (boundp 'bytecomp-filename) bytecomp-filename) - buffer-file-name)) - -(defvar pause-default-img-dir - (let ((this-dir (file-name-directory pause-el-file))) - (expand-file-name "../etc/img/pause/" this-dir))) - -(defcustom pause-img-dir pause-default-img-dir - "Image directory for pause. -A random image is choosen from this directory for pauses." - :type 'directory - :group 'pause) - - - -(defvar pause-timer nil) - -;;(defvar pause-break-exit-calls nil) - -(defun pause-start-timer () - (pause-start-timer-1 (* 60 pause-after-minutes))) - -(defun pause-start-timer-1 (sec) - (pause-cancel-timer) - (setq pause-timer (run-with-timer sec nil 'pause-pre-break))) - -(defun pause-one-minute () - "Give you another minute ..." - (pause-start-timer-1 pause-1-minute-delay) - (message (propertize " OK, I will come back in a minute! -- greatings from pause" - 'face 'pause-message-face))) - -(defun pause-save-me () - (pause-start-timer) - (message (propertize " OK, I will save you again in %d minutes! -- greatings from pause " - 'face 'pause-message-face) - pause-after-minutes)) - -(defun pause-pre-break () - (condition-case err - (save-match-data ;; runs in timer - (pause-cancel-timer) - (setq pause-timer (run-with-idle-timer pause-idle-delay nil 'pause-break-in-timer))) - (error - (lwarn 'pause-pre-break - :error "%s" (error-message-string err))))) - -(defvar pause-break-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control meta shift ?p)] 'pause-break-exit) - (define-key map [tab] 'forward-button) - (define-key map [(meta tab)] 'backward-button) - (define-key map [(shift tab)] 'backward-button) - (define-key map [backtab] 'backward-button) - map)) - -(defvar pause-buffer nil) -(defvar pause-frame nil) - -(define-derived-mode pause-break-mode nil "Pause" - "Mode used during pause in pause buffer. - -It defines the following key bindings: - -\\{pause-break-mode-map}" - (set (make-local-variable 'buffer-read-only) t) - (setq show-trailing-whitespace nil) - ;;(set (make-local-variable 'cursor-type) nil) - ;; Fix-me: workaround for emacs bug - ;;(run-with-idle-timer 0 nil 'pause-hide-cursor) - ) - -;; Fix-me: make one state var -(defvar pause-break-exit-active nil) -(defvar pause-break-1-minute-state nil) - - -(defun pause-break () - (pause-cancel-timer) - (let ((wcfg (current-frame-configuration)) - (old-mode-line-bg (face-attribute 'mode-line :background)) - old-frame-bg-color - old-frame-left-fringe - old-frame-right-fringe - old-frame-tool-bar-lines - old-frame-menu-bar-lines - old-frame-vertical-scroll-bars) - (dolist (f (frame-list)) - (add-to-list 'old-frame-bg-color (cons f (frame-parameter f 'background-color))) - (add-to-list 'old-frame-left-fringe (cons f (frame-parameter f 'left-fringe))) - (add-to-list 'old-frame-right-fringe (cons f (frame-parameter f 'right-fringe))) - (add-to-list 'old-frame-tool-bar-lines (cons f (frame-parameter f 'tool-bar-lines))) - (add-to-list 'old-frame-menu-bar-lines (cons f (frame-parameter f 'menu-bar-lines))) - (add-to-list 'old-frame-vertical-scroll-bars (cons f (frame-parameter f 'vertical-scroll-bars)))) - - ;; Fix-me: Something goes wrong with the window configuration, try a short pause - (remove-hook 'window-configuration-change-hook 'pause-break-exit) - (run-with-idle-timer 0.2 nil 'pause-break-show) - (setq pause-break-exit-active nil) - (setq pause-break-1-minute-state nil) ;; set in `pause-break-show' - (setq pause-exited-from-button nil) - (unwind-protect - (let ((n 0) - (debug-on-error nil)) - (while (and (> 3 (setq n (1+ n))) - (not pause-break-exit-active) - (not pause-break-1-minute-state)) - (condition-case err - (recursive-edit) - (error (message "%s" (error-message-string err)))) - (unless (or pause-break-exit-active - pause-break-1-minute-state) - (when (> 2 n) (message "Too early to pause (%s < 2)" n)) - (add-hook 'window-configuration-change-hook 'pause-break-exit)))) - - (remove-hook 'window-configuration-change-hook 'pause-break-exit) - (pause-tell-again-cancel-timer) - ;;(set-frame-parameter nil 'background-color "white") - (dolist (f (frame-list)) - (set-frame-parameter f 'background-color (cdr (assq f old-frame-bg-color))) - (set-frame-parameter f 'left-fringe (cdr (assq f old-frame-left-fringe))) - (set-frame-parameter f 'right-fringe (cdr (assq f old-frame-right-fringe))) - (set-frame-parameter f 'tool-bar-lines (cdr (assq f old-frame-tool-bar-lines))) - (set-frame-parameter f 'menu-bar-lines (cdr (assq f old-frame-menu-bar-lines))) - (set-frame-parameter f 'vertical-scroll-bars (cdr (assq f old-frame-vertical-scroll-bars)))) - ;; Fix-me: The frame grows unless we do redisplay here: - (redisplay t) - (set-frame-configuration wcfg t) - (when pause-frame(lower-frame pause-frame)) - (set-face-attribute 'mode-line nil :background old-mode-line-bg) - (run-with-idle-timer 2.0 nil 'run-hooks 'pause-break-exit-hook) - (kill-buffer pause-buffer) - (cond (pause-exited-from-button - ;; Do not start timer until we start working again. - (run-with-idle-timer 1 nil 'add-hook 'post-command-hook 'pause-save-me-post-command) - ;; But if we do not do that within some minutes then start timer anyway. - (run-with-idle-timer (* 60 pause-restart-anyway-after) nil 'pause-save-me)) - (pause-break-1-minute-state - (run-with-idle-timer 0 nil 'pause-one-minute)) - (t - (run-with-idle-timer 0 nil 'pause-save-me)))))) - -(defun pause-save-me-post-command () - (pause-start-timer)) - -(defvar pause-break-exit-hook nil - "Hook run after break exit. -Frame configuration has been restored when this is run. -Please note that it is run in a timer.") - -(defun pause-break-show () - ;; In timer - (save-match-data - (condition-case err - (pause-break-show-1) - (error - ;;(remove-hook 'window-configuration-change-hook 'pause-break-exit) - (pause-break-exit) - (message "pause-break-show error: %s" (error-message-string err)))))) - -(defvar pause-break-last-wcfg-change (float-time)) - -(defun pause-break-show-1 () - ;; Do these first if something goes wrong. - (setq pause-break-last-wcfg-change (float-time)) - ;;(run-with-idle-timer (* 1.5 (length (frame-list))) nil 'add-hook 'window-configuration-change-hook 'pause-break-exit) - - ;; fix-me: temporary: - ;;(add-hook 'window-configuration-change-hook 'pause-break-exit) - (unless pause-extra-fun (run-with-idle-timer 1 nil 'pause-break-message)) - (run-with-idle-timer 10 nil 'pause-break-exit-activate) - (setq pause-break-1-minute-state t) - (set-face-attribute 'mode-line nil :background pause-1-minute-mode-line-color) - (with-current-buffer (setq pause-buffer - (get-buffer-create "* P A U S E *")) - (let ((inhibit-read-only t)) - (erase-buffer) - (pause-break-mode) - (setq left-margin-width 25) - (pause-insert-img) - (insert (propertize pause-break-text 'face 'pause-text-face)) - (goto-char (point-min)) - (when (search-forward "mindfulness" nil t) - (make-text-button (- (point) 11) (point) - 'face '(:inherit pause-text-face :underline t) - 'action (lambda (btn) - (browse-url "http://www.jimhopper.com/mindfulness/")))) - (goto-char (point-max)) - (insert (propertize "\n\nClick on a link below to exit pause\n" 'face 'pause-info-text-face)) - ;;(add-text-properties (point-min) (point-max) (list 'keymap (make-sparse-keymap))) - (insert-text-button "Exit pause" - 'action `(lambda (button) - (condition-case err - (pause-break-exit-from-button) - (error (message "%s" (error-message-string err)))))) - (insert "\n") - (dolist (m '(hl-needed-mode)) - (when (and (boundp m) (symbol-value m)) - (funcall m -1))))) - (dolist (f (frame-list)) - (pause-max-frame f)) - (pause-tell-again) - (when pause-extra-fun (funcall pause-extra-fun)) - ;;(setq pause-break-exit-calls 0) - (setq pause-break-last-wcfg-change (float-time)) - (pause-tell-again-start-timer)) - -(defun pause-max-frame (f) - (let* ((avail-width (- (display-pixel-width) - (* 2 (frame-parameter f 'border-width)) - (* 2 (frame-parameter f 'internal-border-width)))) - (avail-height (- (display-pixel-height) - (* 2 (frame-parameter f 'border-width)) - (* 2 (frame-parameter f 'internal-border-width)))) - (cols (/ avail-width (frame-char-width))) - (rows (- (/ avail-height (frame-char-height)) 2))) - ;;(set-frame-parameter (selected-frame) 'fullscreen 'fullboth) - ;;(set-frame-parameter (selected-frame) 'fullscreen 'maximized) - (setq pause-break-last-wcfg-change (float-time)) - (with-selected-frame f - (delete-other-windows (frame-first-window f)) - (with-selected-window (frame-first-window) - (switch-to-buffer pause-buffer) - (goto-char (point-max)))) - (modify-frame-parameters f - `((background-color . ,pause-background-color) - (left-fringe . 0) - (right-fringe . 0) - (tool-bar-lines . 0) - (menu-bar-lines . 0) - (vertical-scroll-bars . nil) - (left . 0) - (top . 0) - (width . ,cols) - (height . ,rows) - )))) - -(defvar pause-tell-again-timer nil) - -(defun pause-tell-again-start-timer () - (pause-tell-again-cancel-timer) - (setq pause-tell-again-timer - (run-with-idle-timer (* 60 pause-tell-again-after) t 'pause-tell-again))) - -(defun pause-tell-again-cancel-timer () - (when (timerp pause-tell-again-timer) - (cancel-timer pause-tell-again-timer)) - (setq pause-tell-again-timer nil)) - -(defun pause-tell-again () - (when (and window-system pause-even-if-not-in-emacs) - (pause-max-frame pause-frame) - (raise-frame pause-frame))) - - -(defun pause-break-message () - (when (/= 0 (recursion-depth)) - (message "%s" (propertize "Please take a pause! (Or exit now to take it in 1 minute.)" - 'face 'pause-1-minute-message-face)))) - -(defun pause-break-exit-activate () - (when (/= 0 (recursion-depth)) - (setq pause-break-exit-active t) - (setq pause-break-1-minute-state nil) - (set-face-attribute 'mode-line nil :background pause-mode-line-color) - (message nil) - (with-current-buffer pause-buffer - (let ((inhibit-read-only t)) - ;; Fix-me: This interfere with text buttons. - ;;(add-text-properties (point-min) (point-max) (list 'keymap nil)) - )))) - -(defun pause-break-exit () - (interactive) - (let ((elapsed (- (float-time) pause-break-last-wcfg-change))) - ;;(message "elapsed=%s pause-break-last-wcfg-change=%s" elapsed pause-break-last-wcfg-change) - (setq pause-break-last-wcfg-change (float-time)) - (when (> elapsed 1.0) - (setq pause-break-exit-active t) - (remove-hook 'window-configuration-change-hook 'pause-break-exit) - ;;(pause-tell-again-cancel-timer) - (when (/= 0 (recursion-depth)) - (exit-recursive-edit))))) - -(defun pause-break-exit-from-button () - (setq pause-break-1-minute-state nil) - (setq pause-exited-from-button t) - (pause-break-exit)) - -(defun pause-insert-img () - (let* ((inhibit-read-only t) - img - src - (slice '(0 0 200 300)) - (imgs (directory-files pause-img-dir nil nil t)) - skip - ) - (setq imgs (delete nil - (mapcar (lambda (d) - (unless (file-directory-p d) d)) - imgs))) - (if (not imgs) - (setq img "No images found") - (setq skip (random (length imgs))) - (while (> skip 0) - (setq skip (1- skip)) - (setq imgs (cdr imgs))) - (setq src (expand-file-name (car imgs) pause-img-dir)) - (if (file-exists-p src) - (condition-case err - (setq img (create-image src nil nil - :relief 1 - ;;:margin inlimg-margins - )) - (error (setq img (error-message-string err)))) - (setq img (concat "Image not found: " src)))) - (if (stringp img) - (insert img) - (insert-image img nil 'left-margin slice) - ) - )) - -(defun pause-hide-cursor () - ;; runs in timer, save-match-data - (with-current-buffer pause-buffer - (set (make-local-variable 'cursor-type) nil))) - -(defun pause-cancel-timer () - (remove-hook 'post-command-hook 'pause-save-me-post-command) - (when (timerp pause-timer) (cancel-timer pause-timer)) - (setq pause-timer nil)) - -(defun pause-break-in-timer () - (save-match-data ;; runs in timer - (pause-cancel-timer) - (if (or (active-minibuffer-window) - (and (boundp 'edebug-active) - edebug-active)) - (let ((pause-idle-delay 5)) - (pause-pre-break)) - (let ((there-was-an-error nil)) - (condition-case err - (pause-break) - (error - (setq there-was-an-error t))) - (when there-was-an-error - (condition-case err - (progn - (select-frame last-event-frame) - (let ((pause-idle-delay nil)) - (pause-pre-break))) - (error - (lwarn 'pause-break-in-timer2 :error "%s" (error-message-string err)) - ))))))) - -(defcustom pause-only-when-server-mode t - "Allow `pause-mode' inly in the Emacs that has server-mode enabled. -This is to prevent multiple Emacs with `pause-mode'." - :type 'boolean - :group 'pause) - -;;;###autoload -(define-minor-mode pause-mode - "This minor mode tries to make you take a break. -It will jump up and temporary stop your work - even if you are -not in Emacs. If you are in Emacs it will however try to be -gentle and wait until you have been idle with the keyboard for a -short while. \(If you are not in Emacs it can't be gentle. How -could it?) - -Then it will show you a special screen with a link to a yoga -exercise you can do when you pause. - -After the pause you continue your work where you were -interrupted." - :global t - :group 'pause - :set-after '(server-mode) - (if pause-mode - (if (and pause-only-when-server-mode - (not server-mode) - (not (with-no-warnings (called-interactively-p)))) - (progn - (setq pause-mode nil) - (message "Pause mode canceled because not server-mode")) - (pause-start-timer)) - (pause-cancel-timer))) - -;; (emacs-Q "-l" buffer-file-name "--eval" "(pause-temp-err)") -;; (emacs-Q "-l" buffer-file-name "--eval" "(run-with-timer 1 nil 'pause-temp-err)") -;; (pause-temp-err) -(defun pause-temp-err () - (switch-to-buffer (get-buffer-create "pause-temp-err buffer")) - (setq buffer-read-only t) - (let ((inhibit-read-only t)) - (add-text-properties (point-min) (point-max) (list 'keymap nil)) - (insert-text-button "click to test" - 'action (lambda (btn) - (message "Click worked"))) - ;;(add-text-properties (point-min) (point-max) (list 'keymap nil)) - )) - -;; (customize-group-other-window 'pause) -;; (apply 'custom-set-variables (pause-get-group-saved-customizations 'pause custom-file)) -;; (pause-get-group-saved-customizations 'w32shell custom-file) -(defun pause-get-group-saved-customizations (group cus-file) - "Return customizations saved for GROUP in CUS-FILE." - (let* ((cus-buf (find-buffer-visiting cus-file)) - (cus-old cus-buf) - (cus-point (when cus-old (with-current-buffer cus-old (point)))) - (cusg-all (get group 'custom-group)) - (cusg-vars (delq nil (mapcar (lambda (elt) - (when (eq (nth 1 elt) 'custom-variable) - (car elt))) - cusg-all))) - cus-vars-form - cus-face-form - cus-saved-vars - cus-saved-face) - (unless cus-buf (setq cus-buf (find-file-noselect cus-file))) - (with-current-buffer cus-buf - (save-restriction - (widen) - (goto-char (point-min)) - (while (progn - (while (progn (skip-chars-forward " \t\n\^l") - (looking-at ";")) - (forward-line 1)) - (not (eobp))) - (let ((form (read (current-buffer)))) - (cond - ((eq (car form) 'custom-set-variables) - (setq cus-vars-form form)) - ((eq (car form) 'custom-set-faces) - (setq cus-face-form form)) - ))))) - (dolist (vl (cdr cus-vars-form)) - (when (memq (car (cadr vl)) cusg-vars) - (setq cus-saved-vars (cons (cadr vl) cus-saved-vars)))) - cus-saved-vars)) - -;; (emacs-Q "-l" buffer-file-name "--eval" "(pause-start 0.1 nil)") -(defun pause-start (after-minutes cus-file) - "Start `pause-mode' with interval AFTER-MINUTES. -This bypasses `pause-only-when-server-mode'. - -You can use this funciton to start a separate Emacs process that -handles pause, for example like this if you want a pause every 15 -minutes: - - emacs -Q -l pause --eval \"(pause-start 15 nil)\" - -Note: Another easier alternative might be to use - `pause-start-in-new-emacs'." - (interactive "nPause after how many minutes: ") - (pause-start-1 after-minutes cus-file)) - -(defun pause-start-1 (after-minutes cus-file) - (setq debug-on-error t) - (pause-cancel-timer) - (when (and cus-file (file-exists-p cus-file)) - (let ((args (pause-get-group-saved-customizations 'pause cus-file))) - ;;(message "cus-file=%S" cus-file) - ;;(message "args=%S" args) - (apply 'custom-set-variables args))) - (setq pause-after-minutes after-minutes) - (let ((pause-only-when-server-mode nil)) - (pause-mode 1)) - (switch-to-buffer (get-buffer-create "Pause information")) - (insert (propertize "Emacs pause\n" - 'face '(:inherit variable-pitch :height 1.5))) - (insert (format "Pausing every %d minute.\n" after-minutes)) - (insert "Or, ") - (insert-text-button "pause now" - 'action `(lambda (button) - (condition-case err - (pause-break) - (error (message "%s" (error-message-string err)))))) - (insert "!\n") - ;;(setq buffer-read-only t) - (pause-break-mode) - (delete-other-windows) - (setq mode-line-format nil) - (setq pause-frame (selected-frame)) - (message nil) - (set-frame-parameter nil 'background-color pause-background-color)) - -;; (pause-start-in-new-emacs 0.3) -;; (pause-start-in-new-emacs 15) -;;;###autoload -(defun pause-start-in-new-emacs (after-minutes) - "Start pause with interval AFTER-MINUTES in a new Emacs instance. -The new Emacs instance will be started with -Q. However if -`custom-file' is non-nil it will be loaded so you can still -customize pause. - -One way of using this function may be to put in your .emacs -something like - - ;; for just one Emacs running pause - (when server-mode (pause-start-in-new-emacs 15)) - -See `pause-start' for more info. - -" - (interactive (list pause-after-minutes)) - (let* ((this-emacs (locate-file invocation-name - (list invocation-directory) - exec-suffixes)) - (cus-file (if custom-file custom-file "~/.emacs")) - (args `("-l" ,pause-el-file - "--geometry=40x3" - "-D" - "--eval" ,(format "(pause-start %s %S)" after-minutes cus-file)))) - (setq args (cons "-Q" args)) - (apply 'call-process this-emacs nil 0 nil args))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Link to yoga poses - -;; (defun w3-download-callback (fname) -;; (let ((coding-system-for-write 'binary)) -;; (goto-char (point-min)) -;; (search-forward "\n\n" nil t) -;; (write-region (point) (point-max) fname)) -;; (url-mark-buffer-as-dead (current-buffer)) -;; (message "Download of %s complete." (url-view-url t)) -;; (sit-for 3)) - -;;(run-with-idle-timer 0 nil 'pause-get-yoga-poses) -(defvar pause-yoga-poses-host-url "http://www.abc-of-yoga.com/") - -;;(pause-start-get-yoga-poses) -(defun pause-start-get-yoga-poses () - (require 'url-vars) - (let ((url-show-status nil)) ;; do not show download messages - (url-retrieve (concat pause-yoga-poses-host-url "yogapractice/mountain.asp") - 'pause-callback-get-yoga-poses))) - -(defun pause-callback-get-yoga-poses (status) - (let ((pose (pause-random-yoga-pose (pause-get-yoga-poses-1 (current-buffer))))) - (message nil) - (when (and pose (buffer-live-p pause-buffer)) - (pause-insert-yoga-link pose)))) - -(defun pause-insert-yoga-link (pose) - (with-current-buffer pause-buffer - (let ((here (point)) - (inhibit-read-only t) - (pose-url (concat pause-yoga-poses-host-url (car pose)))) - (goto-char (point-max)) - (insert "Link to yoga posture for you: ") - (insert-text-button (cdr pose) - 'action `(lambda (button) - (condition-case err - (progn - (browse-url ,pose-url) - (run-with-idle-timer 1 nil 'pause-break-exit-from-button)) - (error (message "%s" (error-message-string err)))))) - (insert "\n") - (pause-break-message)))) - -(defun pause-get-yoga-poses () - (let* ((url-show-status nil) ;; do not show download messages - (buf (url-retrieve-synchronously "http://www.abc-of-yoga.com/yogapractice/mountain.asp"))) - (pause-get-yoga-poses-1 buf))) - -;; (setq x (url-retrieve-synchronously "http://www.abc-of-yoga.com/yogapractice/mountain.asp")) -;; (setq x (url-retrieve-synchronously "http://www.emacswiki.org/emacs/EmacsFromBazaar")) - -;; (defun temp-y () -;; (message "before y") -;; ;;(setq y (url-retrieve-synchronously "http://www.emacswiki.org/emacs/EmacsFromBazaar")) -;; (setq x (url-retrieve-synchronously "http://www.abc-of-yoga.com/yogapractice/mountain.asp")) -;; (message "after x") -;; ) -;; (run-with-idle-timer 0 nil 'temp-y) - -(defun pause-get-yoga-poses-1 (buf) - (require 'url) - (setq url-debug t) - ;; url-insert-file-contents - (let* ((first-marker "<p>These are all the Yoga Poses covered in this section:</p>") - (table-patt "<table\\(?:.\\|\n\\)*?</table>") - table-beg - table-end - (pose-patt "<A HREF=\"\\([^\"]*?\\)\" class=\"LinkBold\">\\([^<]*?\\)</A>") - poses - (trouble-msg - (catch 'trouble - ;;(switch-to-buffer-other-window buf) - (with-current-buffer buf - (goto-char 1) - (rename-buffer "YOGA" t) - (unless (search-forward first-marker nil t) - (throw 'trouble "Can't find marker for the poses on the page")) - (backward-char 10) - (unless (re-search-forward table-patt nil t) - (throw 'trouble "Can't find table with poses on the page")) - (setq table-beg (match-beginning 0)) - (setq table-end (match-end 0)) - (goto-char table-beg) - (while (re-search-forward pose-patt table-end t) - (setq poses (cons (cons (match-string 1) (match-string 2)) - poses))) - (unless poses - (throw 'trouble "Can't find poses in table on the page")) - (kill-buffer) - nil)))) - (if trouble-msg - (progn - (message "%s" trouble-msg) - nil) - (message "Number of yoga poses found=%s" (length poses)) - poses))) - -(defun pause-random-yoga-pose (poses) - (when poses - (random t) - (let* ((n-poses (length poses)) - (pose-num (random (1- n-poses))) - (the-pose (nth pose-num poses))) - the-pose))) - -;;(pause-random-yoga-pose (pause-get-yoga-poses)) - -(provide 'pause) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; pause.el ends here diff --git a/emacs.d/nxhtml/util/pointback.el b/emacs.d/nxhtml/util/pointback.el deleted file mode 100644 index 7a17943..0000000 --- a/emacs.d/nxhtml/util/pointback.el +++ /dev/null @@ -1,93 +0,0 @@ -;;; pointback.el --- Restore window points when returning to buffers - -;; Copyright (C) 2009 Markus Triska - -;; Author: Markus Triska <markus.triska@gmx.at> -;; Keywords: convenience - -;; 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: - -;; When you have two windows X and Y showing different sections of the -;; same buffer B, then switch to a different buffer in X, and then -;; show B in X again, the new point in X will be the same as in Y. -;; With pointback-mode, window points are preserved instead, and point -;; will be where it originally was in X for B when you return to B. - -;; Use M-x pointback-mode RET to enable pointback-mode for a buffer. -;; Use M-x global-pointback-mode RET to enable it for all buffers. - -;;; Code: - -(require 'assoc) - -(defconst pointback-version "0.2") - -(defvar pointback-windows nil - "Association list of windows to buffers and window points.") - -(defun pointback-store-point () - "Save window point and start for the current buffer of the -selected window." - (sit-for 0) ; redisplay to update window-start - (let* ((buffers (cdr (assq (selected-window) pointback-windows))) - (b (assq (current-buffer) buffers)) - (p (cons (point) (window-start)))) - (if b - (setcdr b p) - (let ((current (cons (current-buffer) p))) - (aput 'pointback-windows (selected-window) (cons current buffers)))))) - -(defun pointback-restore () - "Restore previously stored window point for the selected window." - (let* ((buffers (cdr (assq (selected-window) pointback-windows))) - (b (assq (current-buffer) buffers)) - (p (cdr b))) - (when b - (goto-char (car p)) - (set-window-start (selected-window) (cdr p) t))) - ;; delete dead windows from pointback-windows - (dolist (w pointback-windows) - (unless (window-live-p (car w)) - (adelete 'pointback-windows (car w)))) - ;; delete window points of dead buffers - (dolist (w pointback-windows) - (let (buffers) - (dolist (b (cdr w)) - (when (buffer-live-p (car b)) - (push b buffers))) - (aput 'pointback-windows (car w) buffers)))) - -;;;###autoload -(define-minor-mode pointback-mode - "Restore previous window point when switching back to a buffer." - :lighter "" - (if pointback-mode - (progn - (add-hook 'post-command-hook 'pointback-store-point nil t) - (add-hook 'window-configuration-change-hook - 'pointback-restore nil t)) - (remove-hook 'post-command-hook 'pointback-store-point t) - (remove-hook 'window-configuration-change-hook 'pointback-restore t) - (setq pointback-windows nil))) - -;;;###autoload -(define-globalized-minor-mode global-pointback-mode pointback-mode pointback-on) - -(defun pointback-on () - (pointback-mode 1)) - -(provide 'pointback) -;;; pointback.el ends here diff --git a/emacs.d/nxhtml/util/popcmp.el b/emacs.d/nxhtml/util/popcmp.el deleted file mode 100644 index 319145d..0000000 --- a/emacs.d/nxhtml/util/popcmp.el +++ /dev/null @@ -1,472 +0,0 @@ -;;; popcmp.el --- Completion enhancements, popup etc -;; -;; Author: Lennart Borgman -;; Created: Tue Jan 09 12:00:29 2007 -;; Version: 1.00 -;; Last-Updated: 2008-03-08T03:30:15+0100 Sat -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; `ourcomments-util'. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'cl)) -(eval-when-compile (require 'ourcomments-util nil t)) - -;;;###autoload -(defgroup popcmp nil - "Customization group for popup completion." - :tag "Completion Style \(popup etc)" - :group 'nxhtml - :group 'convenience) - -;; (define-toggle popcmp-popup-completion t -;; "Use a popup menu for some completions if non-nil. - -;; ***** Obsolete: Use `popcmp-completion-style' instead. - -;; When completion is used for alternatives tighed to text at the -;; point in buffer it may make sense to use a popup menu for -;; completion. This variable let you decide whether normal style -;; completion or popup style completion should be used then. - -;; This style of completion is not implemented for all completions. -;; It is implemented for specific cases but the choice of completion -;; style is managed generally by this variable for all these cases. - -;; See also the options `popcmp-short-help-beside-alts' and -;; `popcmp-group-alternatives' which are also availabe when popup -;; completion is available." -;; :tag "Popup style completion" -;; :group 'popcmp) - -(defun popcmp-cant-use-style (style) - (save-match-data ;; runs in timer - (describe-variable 'popcmp-completion-style) - (message (propertize "popcmp-completion-style: style `%s' is not available" - 'face 'secondary-selection) - style))) - - - -(defun popcmp-set-completion-style (val) - "Internal use, set `popcmp-completion-style' to VAL." - (assert (memq val '(popcmp-popup emacs-default company-mode anything)) t) - (case val - ('company-mode (unless (fboundp 'company-mode) - (require 'company-mode nil t)) - (unless (fboundp 'company-mode) - (run-with-idle-timer 1 nil 'popcmp-cant-use-style val) - (setq val 'popcmp-popup))) - ('anything (unless (fboundp 'anything) - (require 'anything nil t)) - (unless (fboundp 'anything) - (run-with-idle-timer 1 nil 'popcmp-cant-use-style val) - (setq val 'popcmp-popup)))) - (set-default 'popcmp-completion-style val) - (unless (eq val 'company-mode) - (when (and (boundp 'global-company-mode) - global-company-mode) - (global-company-mode -1)) - (remove-hook 'after-change-major-mode-hook 'company-set-major-mode-backend) - (remove-hook 'mumamo-after-change-major-mode-hook 'mumamo-turn-on-company-mode)) - (when (eq val 'company-mode) - (unless (and (boundp 'global-company-mode) - global-company-mode) - (global-company-mode 1)) - (add-hook 'after-change-major-mode-hook 'company-set-major-mode-backend) - (add-hook 'mumamo-after-change-major-mode-hook 'mumamo-turn-on-company-mode))) - -;; fix-me: move to mumamo.el -(defun mumamo-turn-on-company-mode () - (when (and (boundp 'company-mode) - company-mode) - (company-mode 1) - (company-set-major-mode-backend))) - -;;;###autoload -(defcustom popcmp-completion-style (cond - ;;((and (fboundp 'global-company-mode) 'company-mode) 'company-mode) - (t 'popcmp-popup)) - "Completion style. -The currently available completion styles are: - -- popcmp-popup: Use OS popup menus (default). -- emacs-default: Emacs default completion. -- Company Mode completion. -- anything: The Anything elisp lib completion style. - -The style of completion set here is not implemented for all -completions. The scope varies however with which completion -style you have choosen. - -For information about Company Mode and how to use it see URL -`http://www.emacswiki.org/emacs/CompanyMode'. - -For information about Anything and how to use it see URL -`http://www.emacswiki.org/emacs/Anything'. - -See also the options `popcmp-short-help-beside-alts' and -`popcmp-group-alternatives' which are also availabe when popup -completion is available." - :type '(choice (const company-mode) - (const popcmp-popup) - (const emacs-default) - (const anything)) - :set (lambda (sym val) - (popcmp-set-completion-style val)) - :group 'popcmp) - -;;(define-toggle popcmp-short-help-beside-alts t -(define-minor-mode popcmp-short-help-beside-alts - "Show a short help text beside each alternative. -If this is non-nil a short help text is shown beside each -alternative for which such a help text is available. - -This works in the same circumstances as -`popcmp-completion-style'." - :tag "Short help beside alternatives" - :global t - :init-value t - :group 'popcmp) - -(defun popcmp-short-help-beside-alts-toggle () - "Toggle `popcmp-short-help-beside-alts'." - (popcmp-short-help-beside-alts (if popcmp-short-help-beside-alts -1 1))) - -;;(define-toggle popcmp-group-alternatives t -(define-minor-mode popcmp-group-alternatives - "Do completion in two steps. -For some completions the alternatives may have been grouped in -sets. If this option is non-nil then you will first choose a set -and then an alternative within this set. - -This works in the same circumstances as -`popcmp-completion-style'." - :tag "Group alternatives" - :global t - :init-value t - :group 'popcmp) - -(defun popcmp-group-alternatives-toggle () - "Toggle `popcmp-group-alternatives-toggle'." - (interactive) - (popcmp-group-alternatives (if popcmp-group-alternatives -1 1))) - -(defun popcmp-getsets (alts available-sets) - (let ((sets nil)) - (dolist (tg alts) - (let (found) - (dolist (s available-sets) - (when (member tg (cdr s)) - (setq found t) - (let ((sets-entry (assq (car s) sets))) - (unless sets-entry - (setq sets (cons (list (car s)) sets)) - (setq sets-entry (assq (car s) sets))) - (setcdr sets-entry (cons tg (cdr sets-entry)))))) - (unless found - (let ((sets-entry (assq 'unsorted sets))) - (unless sets-entry - (setq sets (cons (list 'unsorted) sets)) - (setq sets-entry (assq 'unsorted sets))) - (setcdr sets-entry (cons tg (cdr sets-entry))))))) - (setq sets (sort sets (lambda (a b) - (string< (format "%s" b) - (format "%s" a))))) - ;;(dolist (s sets) (setcdr s (reverse (cdr s)))) - sets)) - -(defun popcmp-getset-alts (set-name sets) - ;; Allow both strings and symbols as keys: - (let ((set (or (assoc (downcase set-name) sets) - (assoc (read (downcase set-name)) sets)))) - (cdr set))) - -(defvar popcmp-completing-with-help nil) - -(defun popcmp-add-help (alt alt-help-hash) - (if alt-help-hash - (let ((h (if (hash-table-p alt-help-hash) - (gethash alt alt-help-hash) - (let ((hh (assoc alt alt-help-hash))) - (cadr hh))) - )) - (if h - (concat alt " -- " h) - alt)) - alt)) - -(defun popcmp-remove-help (alt-with-help) - (when alt-with-help - (replace-regexp-in-string " -- .*" "" alt-with-help))) - -(defun popcmp-anything (prompt collection - predicate require-match - initial-input hist def inherit-input-method - alt-help alt-sets) - (let* ((table collection) - (alt-sets2 (apply 'append (mapcar 'cdr alt-sets))) - (cands (cond ((not (listp table)) alt-sets2) - (t table))) - ret-val - (source `((name . "Completion candidates") - (candidates . ,cands) - (action . (("Select current alternative (press TAB to see it again)" . (lambda (candidate) - (setq ret-val candidate)))))))) - (anything (list source) initial-input prompt) - ret-val)) - -(defun popcmp-completing-read-1 (prompt collection - predicate require-match - initial-input hist2 def inherit-input-method alt-help alt-sets) - ;; Fix-me: must rename hist to hist2 in par list. Emacs bug? - (cond - ((eq popcmp-completion-style 'emacs-default) - (completing-read prompt collection predicate require-match initial-input hist2 def inherit-input-method)) - ((eq popcmp-completion-style 'anything) - (popcmp-anything prompt collection predicate require-match initial-input hist2 def inherit-input-method - alt-help alt-sets)) - ((eq popcmp-completion-style 'company-mode) - ;; No way to read this from company-mode, use emacs-default - (completing-read prompt collection predicate require-match initial-input hist2 def inherit-input-method)) - (t (error "Do not know popcmp-completion-style %S" popcmp-completion-style)))) - -(defun popcmp-completing-read-other (prompt - table - &optional predicate require-match - initial-input pop-hist def inherit-input-method - alt-help - alt-sets) - (let ((alts - (if (and popcmp-group-alternatives alt-sets) - (all-completions initial-input table predicate) - (if popcmp-short-help-beside-alts - (all-completions "" table predicate) - table)))) - (when (and popcmp-group-alternatives alt-sets) - (let* ((sets (popcmp-getsets alts alt-sets)) - (set-names (mapcar (lambda (elt) - (capitalize (format "%s" (car elt)))) - sets)) - set) - (setq set - (popcmp-completing-read-1 (concat - (substring prompt 0 (- (length prompt) 2)) - ", select group: ") - set-names - nil t - nil nil nil inherit-input-method nil nil)) - (if (or (not set) (= 0 (length set))) - (setq alts nil) - (setq set (downcase set)) - (setq alts (popcmp-getset-alts set sets))))) - (if (not alts) - "" - (if (= 1 (length alts)) - (car alts) - (when popcmp-short-help-beside-alts - (setq alts (mapcar (lambda (a) - (popcmp-add-help a alt-help)) - alts))) - (popcmp-remove-help - ;;(completing-read prompt - (popcmp-completing-read-1 prompt - alts ;table - predicate require-match - initial-input pop-hist def inherit-input-method - ;;alt-help alt-sets - nil nil - )))))) - -(defun popcmp-completing-read-pop (prompt - table - &optional predicate require-match - initial-input hist def inherit-input-method - alt-help - alt-sets) - (unless initial-input - (setq initial-input "")) - (let ((matching-alts (all-completions initial-input table predicate)) - completion) - (if (not matching-alts) - (progn - (message "No alternative found") - nil) - (let ((pop-map (make-sparse-keymap prompt)) - (sets (when (and popcmp-group-alternatives alt-sets) - (popcmp-getsets matching-alts alt-sets))) - (add-alt (lambda (k tg) - (define-key k - (read (format "[popcmp-%s]" (replace-regexp-in-string " " "-" tg))) - (list 'menu-item - (popcmp-add-help tg alt-help) - `(lambda () - (interactive) - (setq completion ,tg))))))) - (if sets - (dolist (s sets) - (let ((k (make-sparse-keymap))) - (dolist (tg (cdr s)) - (funcall add-alt k tg)) - (define-key pop-map - (read (format "[popcmps-%s]" (car s))) - (list 'menu-item - (capitalize (format "%s" (car s))) - k)))) - (dolist (tg matching-alts) - (funcall add-alt pop-map tg))) - (popup-menu-at-point pop-map) - completion)))) - -(defvar popcmp-in-buffer-allowed nil) - -;;;###autoload -(defun popcmp-completing-read (prompt - table - &optional predicate require-match - initial-input pop-hist def inherit-input-method - alt-help - alt-sets) - "Read a string in the minubuffer with completion, or popup a menu. -This function can be used instead `completing-read'. The main -purpose is to provide a popup style menu for completion when -completion is tighed to text at point in a buffer. If a popup -menu is used it will be shown at window point. Whether a popup -menu or minibuffer completion is used is governed by -`popcmp-completion-style'. - -The variables PROMPT, TABLE, PREDICATE, REQUIRE-MATCH, -INITIAL-INPUT, POP-HIST, DEF and INHERIT-INPUT-METHOD all have the -same meaning is for `completing-read'. - -ALT-HELP should be nil or a hash variable or an association list -with the completion alternative as key and a short help text as -value. You do not need to supply help text for all alternatives. -The use of ALT-HELP is set by `popcmp-short-help-beside-alts'. - -ALT-SETS should be nil or an association list that has as keys -groups and as second element an alternative that should go into -this group. -" - (if (and popcmp-in-buffer-allowed - (eq popcmp-completion-style 'company-mode) - (boundp 'company-mode) - company-mode) - (progn - (add-hook 'company-completion-finished-hook 'nxhtml-complete-tag-do-also-for-state-completion t) - ;;(remove-hook 'company-completion-finished-hook 'nxhtml-complete-tag-do-also-for-state-completion) - (call-interactively 'company-nxml) - initial-input) - - (popcmp-mark-completing initial-input) - (let ((err-sym 'quit) - (err-val nil) - ret) - (unwind-protect - (if (eq popcmp-completion-style 'popcmp-popup) - (progn - (setq err-sym nil) - (popcmp-completing-read-pop - prompt - table - predicate require-match - initial-input pop-hist def inherit-input-method - alt-help - alt-sets)) - ;;(condition-case err - (prog1 - (setq ret (popcmp-completing-read-other - prompt - table - predicate require-match - initial-input pop-hist def inherit-input-method - alt-help - alt-sets)) - ;; Unless quit or error in Anything we come here: - ;;(message "ret=(%S)" ret) - (when (and ret (not (string= ret ""))) - (setq err-sym nil))) - ;; (error - ;; ;;(message "err=%S" err) - ;; (setq err-sym (car err)) - ;; (setq err-val (cdr err)))) - ) - (popcmp-unmark-completing) - (when err-sym (signal err-sym err-val)))))) - -(defvar popcmp-mark-completing-ovl nil) - -(defun popcmp-mark-completing (initial-input) - (let ((start (- (point) (length initial-input))) - (end (point))) - (if (overlayp popcmp-mark-completing-ovl) - (move-overlay popcmp-mark-completing-ovl start end) - (setq popcmp-mark-completing-ovl (make-overlay start end)) - (overlay-put popcmp-mark-completing-ovl 'face 'match))) - (sit-for 0)) - -(defun popcmp-unmark-completing () - (when popcmp-mark-completing-ovl - (delete-overlay popcmp-mark-completing-ovl))) - - -;; (defun popcmp-temp () -;; (interactive) -;; (let* ((coord (point-to-coord (point))) -;; (x (nth 0 (car coord))) -;; (y (nth 1 (car coord))) -;; (emacsw32-max-frames nil) -;; (f (make-frame -;; (list '(minibuffer . only) -;; '(title . "Input") -;; '(name . "Input frame") -;; (cons 'left x) -;; (cons 'top y) -;; '(height . 1) -;; '(width . 40) -;; '(border-width . 1) -;; '(internal-border-width . 2) -;; '(tool-bar-lines . nil) -;; '(menu-bar-lines . nil) -;; )))) -;; f)) - - -(provide 'popcmp) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; popcmp.el ends here diff --git a/emacs.d/nxhtml/util/readme.txt b/emacs.d/nxhtml/util/readme.txt deleted file mode 100644 index b9db030..0000000 --- a/emacs.d/nxhtml/util/readme.txt +++ /dev/null @@ -1,3 +0,0 @@ -This subdirectory contains files used by nXhtml that I have
-written. The files are placed here because they may be of use also
-outside of nXhtml.
diff --git a/emacs.d/nxhtml/util/rebind.el b/emacs.d/nxhtml/util/rebind.el deleted file mode 100644 index cf4700c..0000000 --- a/emacs.d/nxhtml/util/rebind.el +++ /dev/null @@ -1,240 +0,0 @@ -;;; rebind.el --- Rebind keys -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-01-20T12:04:37+0100 Sun -;; Version: -;; Last-Updated: -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; See `rebind-keys-mode' for information. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'new-key-seq-widget nil t)) -(eval-when-compile (require 'ourcomments-widgets nil t)) - - -(defun rebind-toggle-first-modifier (orig-key-seq mod) - (let* ((first (elt orig-key-seq 0)) - (new-key-seq (copy-sequence orig-key-seq))) - (setq first (if (memq mod first) - (delq mod first) - (cons mod first))) - (aset new-key-seq 0 first) - new-key-seq)) -;; (rebind-toggle-first-modifier (key-description-to-vector "C-c a") 'shift) -;; (rebind-toggle-first-modifier (key-description-to-vector "C-S-c a") 'shift) - -(defvar widget-commandp-prompt-value-history nil) - -;;;###autoload -(defgroup rebind nil - "Customizaton group for `rebind-keys-mode'." - :group 'convenience - :group 'emulations - :group 'editing-basics - :group 'emacsw32) - -;; (customize-option-other-window 'rebind-keys) -;; (Fetched key bindings from http://www.davidco.com/tips_tools/tip45.html) -(defcustom rebind-keys - '( - ("MS Windows - often used key bindings" t - ( - ( - [(control ?a)] - "C-a on w32 normally means 'select all'. In Emacs it is `beginning-of-line'." - t - shift - ourcomments-mark-whole-buffer-or-field) - ( - [(control ?o)] - "C-o on w32 normally means 'open file'. In Emacs it is `open-line'." - nil - shift - find-file) - ( - [(control ?f)] - "C-f is commonly search on w32. In Emacs it is `forward-char'." - nil - shift - isearch-forward) - ( - [(control ?s)] - "C-s is normally 'save file' on w32. In Emacs it is `isearch-forward'." - nil - nil - save-buffer) - ( - [(control ?w)] - "C-w is often something like kill-buffer on w32. In Emacs it is `kill-region'." - t - shift - kill-buffer) - ( - [(control ?p)] - "C-p is nearly always print on w32. In Emacs it is `previous-line'." - t - shift - hfyview-buffer) - ( - [(home)] - "HOME normally stays in a field. By default it does not do that in Emacs." - t - nil - ourcomments-move-beginning-of-line) - ( - [(control ?+)] - "C-+ often increases font size (in web browsers for example)." - t - shift - text-scale-adjust) - ( - [(control ?-)] - "C-- often decreases font size (in web browsers for example)." - t - shift - text-scale-adjust) - ( - [(control ?0)] - "C-0 often resets font size (in web browsers for example)." - t - shift - text-scale-adjust) - ))) - "Normal Emacs keys that are remapped to follow some other standard. -The purpose of this variable is to make it easy to switch between -Emacs key bindings and other standards. - -The new bindings are made in the global minor mode -`rebind-keys-mode' and will only have effect when this mode is -on. - -*Note:* You can only move functions bound in the global key map - this way. -*Note:* To get CUA keys you should turn on option `cua-mode'. -*Note:* To get vi key bindings call function `viper-mode'. -*Note:* `text-scale-adjust' already have default key bindings." - :type '(repeat - (list - (string :tag "For what") - (boolean :tag "Group on/off") - (repeat - (list - (key-sequence :tag "Emacs key binding") - (string :tag "Why rebind") - (boolean :tag "Rebinding on/off") - (choice :tag "Move original by" - (const :tag "Don't put it on any new binding" nil) - (choice :tag "Add key binding modifier" - (const meta) - (const control) - (const shift)) - (key-sequence :tag "New binding for original function")) - (command :tag "New command on above key")) - ))) - :set (lambda (sym val) - (set-default sym val) - (when (featurep 'rebind) - (rebind-update-keymap))) - :group 'rebind) - -(defvar rebind-keys-mode-map nil) - -(defvar rebind--emul-keymap-alist nil) - -;;(rebind-update-keymap) -(defun rebind-update-keymap () - (let ((m (make-sparse-keymap))) - (dolist (group rebind-keys) - (when (nth 1 group) - (dolist (v (nth 2 group)) - (let* ((orig-key (nth 0 v)) - (comment (nth 1 v)) - (enabled (nth 2 v)) - (new-choice (nth 3 v)) - (new-fun (nth 4 v)) - (orig-fun (lookup-key global-map orig-key)) - new-key) - (when enabled - (when new-choice - (if (memq new-choice '(meta control shift)) - (setq new-key (rebind-toggle-first-modifier orig-key new-choice)) - (setq new-key new-choice)) - (define-key m new-key orig-fun)) - (define-key m orig-key new-fun)))) - (setq rebind-keys-mode-map m)))) - (setq rebind--emul-keymap-alist (list (cons 'rebind-keys-mode rebind-keys-mode-map)))) - -;;;###autoload -(define-minor-mode rebind-keys-mode - "Rebind keys as defined in `rebind-keys'. -The key bindings will override almost all other key bindings -since it is put on emulation level, like for example ``cua-mode' -and `viper-mode'. - -This is for using for example C-a to mark the whole buffer \(or a -field). There are some predifined keybindings for this." - :keymap rebind-keys-mode-map - :global t - :group 'rebind - (if rebind-keys-mode - (progn - (rebind-update-keymap) - ;;(rebind-keys-post-command) - (add-hook 'post-command-hook 'rebind-keys-post-command t)) - (remove-hook 'post-command-hook 'rebind-keys-post-command) - (setq emulation-mode-map-alists (delq 'rebind--emul-keymap-alist emulation-mode-map-alists)))) - -(defun rebind-keys-post-command () - "Make sure we are first in the list when turned on. -This is reasonable since we are using this mode to really get the -key bindings we want!" - (unless (eq 'rebind--emul-keymap-alist (car emulation-mode-map-alists)) - (setq emulation-mode-map-alists (delq 'rebind--emul-keymap-alist emulation-mode-map-alists)) - (when rebind-keys-mode - (add-to-list 'emulation-mode-map-alists 'rebind--emul-keymap-alist)))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Interactive functions for the keymap - - - -(provide 'rebind) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; rebind.el ends here diff --git a/emacs.d/nxhtml/util/rnc-mode.el b/emacs.d/nxhtml/util/rnc-mode.el deleted file mode 100644 index 5829a50..0000000 --- a/emacs.d/nxhtml/util/rnc-mode.el +++ /dev/null @@ -1,265 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; A major mode for editing RELAX NG Compact syntax. -;; Version: 1.0b3 -;; Date: 2002-12-05 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Copyright (c) 2002, Pantor Engineering AB -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or -;; without modification, are permitted provided that the following -;; conditions are met: -;; -;; * Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; * Redistributions in binary form must reproduce the above -;; copyright notice, this list of conditions and the following -;; disclaimer in the documentation and/or other materials provided -;; with the distribution. -;; -;; * Neither the name of Pantor Engineering AB nor the names of its -;; contributors may be used to endorse or promote products derived -;; from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND -;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, -;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS -;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED -;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON -;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -;; POSSIBILITY OF SUCH DAMAGE. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Created by David.Rosenborg@pantor.com -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Example setup for your ~/.emacs file: -;; -;; (autoload 'rnc-mode "rnc-mode") -;; (setq auto-mode-alist -;; (cons '("\\.rnc\\'" . rnc-mode) auto-mode-alist)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Changes since 1.0b: -;; Added a couple of defvars for faces to handle differences -;; between GNU Emacs and XEmacs. -;; -;; 2008-12-28: Changed forward-char-command => forward-char -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'font-lock) - -(defvar rnc-indent-level 3 "The RNC indentation level.") - -(defvar rnc-keywords - (mapcar (lambda (kw) (concat "\\b" kw "\\b")) - '("attribute" "div" "element" - "empty" "external" "grammar" "include" "inherit" "list" - "mixed" "notAllowed" "parent" "start" "string" - "text" "token")) - "RNC keywords") - -(defvar rnc-atoms - (mapcar (lambda (kw) (concat "\\b" kw "\\b")) - '("empty" "notAllowed" "string" "text" "token")) - "RNC atomic pattern keywords") - -(defun rnc-make-regexp-choice (operands) - "(op1 op2 ...) -> \"\\(op1\\|op2\\|...\\)\"" - (let ((result "\\(")) - (mapc (lambda (op) (setq result (concat result op "\\|"))) operands) - (concat (substring result 0 -2) "\\)"))) - -;; Font lock treats face names differently in GNU Emacs and XEmacs -;; The following defvars is a workaround - -(defvar italic 'italic) -(defvar default 'default) -(defvar font-lock-preprocessor-face 'font-lock-preprocessor-face) - -(defvar rnc-font-lock-keywords - (list - '("\\b\\(attribute\\|element\\)\\b\\([^{]+\\){" 2 - font-lock-variable-name-face) - '("[a-zA-Z][-a-zA-Z0-9._]*:[a-zA-Z][-a-zA-Z0-9._]*" . italic) - '("\\b\\(default\\(\\s +namespace\\)?\\|namespace\\|datatypes\\)\\(\\s +[a-zA-Z][-a-zA-Z0-9._]*\\)?\\s *=" 1 font-lock-preprocessor-face) - '("\\([a-zA-Z][-a-zA-Z0-9._]*\\)\\(\\s \\|\n\\)*[|&]?=" 1 - font-lock-function-name-face) - '("[a-zA-Z][a-zA-Z0-9._]*\\(-[a-zA-Z][a-zA-Z0-9._]*\\)+" . default) - (cons (rnc-make-regexp-choice rnc-atoms) 'italic) - (cons (rnc-make-regexp-choice rnc-keywords) font-lock-keyword-face) - ) - "RNC Highlighting") - - -(defun rnc-find-column (first start) - "Find which column to indent to." - - ;; FIXME: backward-sexp doesn't work with unbalanced braces in comments - - (let* (column - pos - ;; Find start of enclosing block or assignment - (token - (if (member first '("]" "}" ")")) - (progn - (goto-char (+ start 1)) - (backward-sexp) - (beginning-of-line) - (re-search-forward "\\S ") - (setq pos (point)) - (setq column (- (current-column) 1)) - 'lpar) - (catch 'done - (while (setq pos (re-search-backward "[{}()=]\\|\\[\\|\\]" - (point-min) t)) - (let ((c (match-string 0))) - (beginning-of-line) - (re-search-forward "\\S ") - (setq column (- (current-column) 1)) - (beginning-of-line) - (cond - ;; Don't match inside comments - ;; FIXME: Should exclude matches inside string literals too - ((re-search-forward "#" pos t) (beginning-of-line)) - ;; Skip block - ((member c '("]" "}" ")")) - (goto-char (+ pos 1)) - (backward-sexp)) - - ((string= c "=") (throw 'done 'eq)) - (t (throw 'done 'lpar))))))))) - - (cond - ((not pos) 0) - ((member first '("]" "}" ")")) column) - ((member first '("{" "(")) (+ column rnc-indent-level)) - - ;; Give lines starting with an operator a small negative indent. - ;; This allows for the following indentation style: - ;; foo = - ;; bar - ;; | baz - ;; | oof - ((member first '("," "&" "|")) (+ column (- rnc-indent-level 2))) - - ;; Check if first preceding non-whitespace character was an operator - ;; If not, this is most likely a new assignment. - ;; FIXME: This doesn't play well with name classes starting on a new - ;; line - ((eq token 'eq) - (goto-char start) - (if (and (re-search-backward "[^ \t\n]" (point-min) t) - (member (match-string 0) '("&" "|" "," "=" "~"))) - (+ column rnc-indent-level) - column)) - - (t (+ column rnc-indent-level))))) - -(defun rnc-indent-line () - "Indents the current line." - (interactive) - (let ((orig-point (point))) - (beginning-of-line) - (let* ((beg-of-line (point)) - (pos (re-search-forward "\\(\\S \\|\n\\)" (point-max) t)) - (first (match-string 0)) - (start (match-beginning 0)) - (col (- (current-column) 1))) - - (goto-char beg-of-line) - - (let ((indent-column (rnc-find-column first start))) - (goto-char beg-of-line) - - (cond - ;; Only modify buffer if the line must be reindented - ((not (= col indent-column)) - (if (not (or (null pos) - (= beg-of-line start))) - (kill-region beg-of-line start)) - - (goto-char beg-of-line) - - (while (< 0 indent-column) - (insert " ") - (setq indent-column (- indent-column 1)))) - - ((< orig-point start) (goto-char start)) - (t (goto-char orig-point))))))) - - -(defun rnc-electric-brace (arg) - (interactive "*P") - (self-insert-command (prefix-numeric-value arg)) - (rnc-indent-line) - (let ((p (point))) - (when (save-excursion - (beginning-of-line) - (let ((pos (re-search-forward "\\S " (point-max) t))) - (and pos (= (- pos 1) p)))) - (forward-char)))) - -(defvar rnc-mode-map () "Keymap used in RNC mode.") -(when (not rnc-mode-map) - (setq rnc-mode-map (make-sparse-keymap)) - (define-key rnc-mode-map "\C-c\C-c" 'comment-region) - (define-key rnc-mode-map "}" 'rnc-electric-brace) - (define-key rnc-mode-map "{" 'rnc-electric-brace) - (define-key rnc-mode-map "]" 'rnc-electric-brace) - (define-key rnc-mode-map "[" 'rnc-electric-brace)) - -;;;###autoload -(defun rnc-mode () - "Major mode for editing RELAX NG Compact Syntax schemas. -\\{rnc-mode-map}" - (interactive) - - (kill-all-local-variables) - - (make-local-variable 'indent-line-function) - (setq indent-line-function 'rnc-indent-line) - - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(rnc-font-lock-keywords nil t nil nil)) - - (use-local-map rnc-mode-map) - - (make-local-variable 'comment-start) - (make-local-variable 'comment-end) - (make-local-variable 'comment-start-skip) - - (setq comment-start "#" - comment-end "" - comment-start-skip "\\([ \n\t]+\\)##?[ \n\t]+") - - (let ((rnc-syntax-table (copy-syntax-table))) - (modify-syntax-entry ?# "< " rnc-syntax-table) - (modify-syntax-entry ?\n "> " rnc-syntax-table) - (modify-syntax-entry ?\^m "> " rnc-syntax-table) - (modify-syntax-entry ?\\ "w " rnc-syntax-table) - (modify-syntax-entry ?' "\" " rnc-syntax-table) - (modify-syntax-entry ?. "w " rnc-syntax-table) - (modify-syntax-entry ?- "w " rnc-syntax-table) - (modify-syntax-entry ?_ "w " rnc-syntax-table) - (set-syntax-table rnc-syntax-table)) - - (setq mode-name "RNC" - major-mode 'rnc-mode) - (run-hooks 'rnc-mode-hook)) - -(provide 'rnc-mode) diff --git a/emacs.d/nxhtml/util/rxi.el b/emacs.d/nxhtml/util/rxi.el deleted file mode 100644 index 505d0b4..0000000 --- a/emacs.d/nxhtml/util/rxi.el +++ /dev/null @@ -1,148 +0,0 @@ -;;; rxi.el --- Interactive regexp reading using rx format -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-04-07T18:18:39+0200 Mon -;; Version: -;; Last-Updated: -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Read regexp as `rx' forms from minibuffer. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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: - -(defvar rxi-read-hist nil) - -(defun rxi-find-definition (rx-sym) - (let* ((rec (assoc rx-sym rx-constituents)) - ) - (while (symbolp (cdr rec)) - (setq rec (assoc (cdr rec) rx-constituents))) - (cdr rec))) - -(defun rxi-list-type-p (rx-sym) - (listp (rxi-find-definition rx-sym))) - -(defun rxi-complete () - "Complete `rx' constituents." - (interactive) - ;; Don't care about state for now, there will be an error instead - (let* ((partial (when (looking-back (rx (1+ (any "a-z01:|=>*?+\\-"))) nil t) - (match-string-no-properties 0))) - (candidates (let ((want-list - (= ?\( (char-before (match-beginning 0))))) - (delq nil - (mapcar (lambda (rec) - (let* ((sym (car rec)) - (lst (rxi-list-type-p sym))) - (when (or (and want-list lst) - (and (not want-list) - (not lst))) - (symbol-name sym)))) - rx-constituents)))) - (match-set (when partial - (all-completions - partial - candidates)))) - (cond - ((not match-set) - (message "No completions")) - ((= 1 (length match-set)) - (insert (substring (car match-set) (length partial)))) - (t - (with-output-to-temp-buffer "*Completions*" - (display-completion-list match-set partial)))))) - -(defvar rxi-read-keymap - (let ((map (make-sparse-keymap))) - (set-keymap-parent map minibuffer-local-completion-map) - (define-key map [tab] 'rxi-complete) - (define-key map [(meta tab)] 'rxi-complete) - (define-key map [?\ ] 'self-insert-command) - map)) - -(defvar rxi-trailing-overlay nil) - -(defun rxi-minibuf-setup () - (when rxi-trailing-overlay (delete-overlay rxi-trailing-overlay)) - (setq rxi-trailing-overlay - (make-overlay (point-max) (point-max) - (current-buffer) - t t)) - (overlay-put rxi-trailing-overlay 'after-string - (propertize ")" - 'face - (if (and - (fboundp 'noticeable-minibuffer-prompts-mode) - noticeable-minibuffer-prompts-mode) - 'minibuffer-noticeable-prompt - 'minibuffer-prompt))) - (remove-hook 'minibuffer-setup-hook 'rxi-minibuf-setup)) - -(defun rxi-minibuf-exit () - (when rxi-trailing-overlay - (delete-overlay rxi-trailing-overlay) - (setq rxi-trailing-overlay nil)) - (remove-hook 'minibuffer-exit-hook 'rxi-minibuf-exit)) - -(defun rxi-read (prompt) - "Read a `rx' regexp form from minibuffer. -Return cons of rx and regexp, both as strings." - (interactive (list "Test (rx ")) - (let (rx-str rx-full-str res-regexp) - (while (not res-regexp) - (condition-case err - (progn - (add-hook 'minibuffer-setup-hook 'rxi-minibuf-setup) - (add-hook 'minibuffer-exit-hook 'rxi-minibuf-exit) - (setq rx-str (read-from-minibuffer prompt - rx-str ;; initial-contents - rxi-read-keymap - nil ;; read - 'rxi-read-hist - nil ;; inherit-input-method - no idea... - )) - (setq rx-full-str (concat "(rx " rx-str ")")) - (setq res-regexp (eval (read rx-full-str)))) - (error (message "%s" (error-message-string err)) - (sit-for 2)))) - (when (with-no-warnings (called-interactively-p)) (message "%s => \"%s\"" rx-full-str res-regexp)) - (cons rx-full-str res-regexp))) - - -(provide 'rxi) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; rxi.el ends here diff --git a/emacs.d/nxhtml/util/search-form.el b/emacs.d/nxhtml/util/search-form.el deleted file mode 100644 index b7b6dd2..0000000 --- a/emacs.d/nxhtml/util/search-form.el +++ /dev/null @@ -1,473 +0,0 @@ -;;; search-form.el --- Search form -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-05-05T01:50:20+0200 Sun -;; Version: 0.11 -;; Last-Updated: -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; `cus-edit', `cus-face', `cus-load', `cus-start', `wid-edit'. -;; -;;;;;;;;;;seasfireplstring ;; -;; -;;; Commentary: -;; -;; After an idea by Eric Ludlam on Emacs Devel: -;; -;; http://lists.gnu.org/archive/html/emacs-devel/2008-05/msg00152.html -;; -;; NOT QUITE READY! Tagged files have not been tested. -;; -;; Fix-me: work on other windows buffer by default, not buffer from -;; where search form was created. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'ourcomments-util)) -(require 'cus-edit) -(require 'grep) - -(defvar search-form-sfield nil) -(make-variable-buffer-local 'search-form-sfield) -(defvar search-form-rfield nil) -(make-variable-buffer-local 'search-form-rfield) - -(defvar search-form-win-config nil) -(make-variable-buffer-local 'search-form-win-config) -(put 'search-form-win-config 'permanent-local t) - -(defvar search-form-current-buffer nil) - -(defun search-form-multi-occur-get-buffers () - (let* ((bufs (list (read-buffer "First buffer to search: " - (current-buffer) t))) - (buf nil) - (ido-ignore-item-temp-list bufs)) - (while (not (string-equal - (setq buf (read-buffer - (if (eq read-buffer-function 'ido-read-buffer) - "Next buffer to search (C-j to end): " - "Next buffer to search (RET to end): ") - nil t)) - "")) - (add-to-list 'bufs buf) - (setq ido-ignore-item-temp-list bufs)) - (nreverse (mapcar #'get-buffer bufs)))) - -(defvar search-form-buffer) ;; dyn var, silence compiler -(defvar search-form-search-string) ;; dyn var, silence compiler -(defvar search-form-replace-string) ;; dyn var, silence compiler - -(defun search-form-notify-1 (use-search-field - use-replace-field - w - hide-form - display-orig-buf) - (let ((search-form-search-string (when use-search-field (widget-value search-form-sfield))) - (search-form-replace-string (when use-replace-field (widget-value search-form-rfield))) - (search-form-buffer (current-buffer)) - (this-search (widget-get w :do-search)) - (do-it t)) - (if (and use-search-field - (= 0 (length search-form-search-string))) - (progn - (setq do-it nil) - (message "Please specify a search string")) - (when (and use-replace-field - (= 0 (length search-form-replace-string))) - (setq do-it nil) - (message "Please specify a replace string"))) - (when do-it - (if hide-form - (progn - (set-window-configuration search-form-win-config) - (funcall this-search search-form-search-string) - ;;(kill-buffer search-form-buffer) - ) - (when display-orig-buf - (let ((win (display-buffer search-form-current-buffer t))) - (select-window win t))) - ;;(funcall this-search search-form-search-string)) - (funcall this-search w) - )))) - -(defun search-form-notify-no-field (w &rest ignore) - (search-form-notify-1 nil nil w nil t)) - -(defun search-form-notify-sfield (w &rest ignore) - (search-form-notify-1 t nil w nil t)) - -(defun search-form-notify-sfield-nobuf (w &rest ignore) - (search-form-notify-1 t nil w nil nil)) - -(defun search-form-notify-both-fields (w &rest ignore) - (search-form-notify-1 t t w nil t)) - -(defun search-form-insert-button (title function descr do-search-fun) - (widget-insert " ") - (let ((button-title (format " %-15s " title))) - (widget-create 'push-button - :do-search do-search-fun - :notify 'search-form-notify-no-field - :current-buffer search-form-current-buffer - button-title)) - (widget-insert " " descr) - (widget-insert "\n")) - -(defun search-form-insert-search (title search-fun descr do-search-fun no-buf) - (widget-insert " ") - (let ((button-title (format " %-15s " title))) - (if no-buf - (widget-create 'push-button - :do-search do-search-fun - :notify 'search-form-notify-sfield-nobuf - :current-buffer search-form-current-buffer - button-title) - (widget-create 'push-button - :do-search do-search-fun - :notify 'search-form-notify-sfield - :current-buffer search-form-current-buffer - button-title) - )) - (widget-insert " " descr " ") - (search-form-insert-help search-fun) - (widget-insert "\n")) - -(defun search-form-insert-fb (descr - use-sfield - forward-fun - do-forward-fun - backward-fun - do-backward-fun) - (widget-insert (format " %s: " descr)) - (widget-create 'push-button - :do-search do-forward-fun - :use-sfield use-sfield - :notify '(lambda (widget &rest event) - (if (widget-get widget :use-sfield) - (search-form-notify-sfield widget) - (search-form-notify-no-field widget))) - :current-buffer search-form-current-buffer - " Forward ") - (widget-insert " ") - (search-form-insert-help forward-fun) - (widget-insert " ") - (widget-create 'push-button - :do-search do-backward-fun - :use-sfield use-sfield - :notify '(lambda (widget &rest event) - (if (widget-get widget :use-sfield) - (search-form-notify-sfield widget) - (search-form-notify-no-field widget))) - :current-buffer search-form-current-buffer - " Backward ") - (widget-insert " ") - (search-form-insert-help backward-fun) - (widget-insert "\n")) - -(defun search-form-insert-replace (title replace-fun descr do-replace-fun) - (widget-insert " ") - (let ((button-title (format " %-15s " title))) - (widget-create 'push-button - :do-search do-replace-fun - :notify 'search-form-notify-both-fields - :current-buffer search-form-current-buffer - button-title)) - (widget-insert " " descr " ") - (search-form-insert-help replace-fun) - (widget-insert "\n")) - -(defun search-form-insert-help (fun) - (widget-insert "(") - (widget-create 'function-link - :value fun - :tag "help" - :button-face 'link) - (widget-insert ")")) - -(defun sf-widget-field-value-set (widget value) - "Set current text in editing field." - (let ((from (widget-field-start widget)) - (to (widget-field-end widget)) - (buffer (widget-field-buffer widget)) - (size (widget-get widget :size)) - (secret (widget-get widget :secret)) - (old (current-buffer))) - (if (and from to) - (progn - (set-buffer buffer) - (while (and size - (not (zerop size)) - (> to from) - (eq (char-after (1- to)) ?\s)) - (setq to (1- to))) - (goto-char to) - (delete-region from to) - (insert value) - (let ((result (buffer-substring-no-properties from to))) - (when secret - (let ((index 0)) - (while (< (+ from index) to) - (aset result index - (get-char-property (+ from index) 'secret)) - (setq index (1+ index))))) - (set-buffer old) - result)) - (widget-get widget :value)))) - -(defvar search-form-form nil) - -(defun search-form-isearch-end () - (condition-case err - (progn - (message "sfie: search-form-form=%s" (widget-value (cdr search-form-form))) - (remove-hook 'isearch-mode-end-hook 'search-form-isearch-end) - ;; enter isearch-string in field - (with-current-buffer (car search-form-form) - ;; Fix-me: trashes the widget, it disappears... - there seem - ;; to be know default set function. - ;;(widget-value-set (cdr search-form-form) isearch-string) - )) - (error (message "search-form-isearch-end: %S" err)))) - -(defun search-form-isearch-forward (w) - (interactive) - (add-hook 'isearch-mode-end-hook 'search-form-isearch-end) - (with-current-buffer search-form-buffer - (setq search-form-form (cons search-form-buffer search-form-sfield)) - (message "sfif: cb=%s field=%S" (current-buffer) (widget-value (cdr search-form-form))) - ) - (call-interactively 'isearch-forward)) - -(defun search-form-isearch-backward (w) - (interactive) - (add-hook 'isearch-mode-end-hook 'search-form-isearch-end) - (setq search-form-form search-form-sfield) - (call-interactively 'isearch-backward)) - -;;;###autoload -(defun search-form () - "Display a form for search and replace." - (interactive) - (let* ((buf-name "*Search Form*") - (cur-buf (current-buffer)) - (buffer (get-buffer-create buf-name)) - (win-config (current-window-configuration))) - (setq search-form-current-buffer (current-buffer)) - (with-current-buffer buffer - (set (make-local-variable 'search-form-win-config) win-config)) - (switch-to-buffer-other-window buffer) - - (kill-all-local-variables) ;; why??? - (let ((inhibit-read-only t)) - (erase-buffer)) - ;;(Custom-mode) - (remove-overlays) - - (make-local-variable 'widget-button-face) - (setq widget-button-face custom-button) - (setq show-trailing-whitespace nil) - (when custom-raised-buttons - (set (make-local-variable 'widget-push-button-prefix) "") - (set (make-local-variable 'widget-push-button-suffix) "") - (set (make-local-variable 'widget-link-prefix) "") - (set (make-local-variable 'widget-link-suffix) "")) - - (widget-insert (propertize "Search/Replace, buffer: " 'face 'font-lock-comment-face)) - (widget-insert (format "%s" (buffer-name search-form-current-buffer))) - (let ((file (buffer-file-name search-form-current-buffer))) - (when file - (insert " (" file ")"))) - (widget-insert "\n\n") - (search-form-insert-fb - "Incremental String Search" nil - 'isearch-forward - 'search-form-isearch-forward - 'isearch-backward - 'search-form-isearch-backward) - - (search-form-insert-fb - "Incremental Regexp Search" nil - 'isearch-forward-regexp - (lambda (w) (call-interactively 'isearch-forward-regexp)) - 'isearch-backward-regexp - (lambda (w) (call-interactively 'isearch-backward-regexp))) - - ;; Fix-me: in multiple buffers, from buffer-list - - (widget-insert (make-string (window-width) ?-) "\n") - - (widget-insert "Search: ") - (setq search-form-sfield - (widget-create 'editable-field - :size 58)) - (widget-insert "\n\n") - (widget-insert (propertize "* Buffers:" 'face 'font-lock-comment-face) "\n") - (search-form-insert-fb "String Search" t - 'search-forward - (lambda (w) (search-forward search-form-search-string)) - 'search-backward - (lambda (w) (search-backward search-form-search-string))) - - (search-form-insert-fb "Regexp Search" t - 're-search-forward - (lambda (w) (re-search-forward search-form-search-string)) - 're-search-backward - (lambda (w) (re-search-backward search-form-search-string))) - - ;; occur - (search-form-insert-search "Occur" 'occur - "Lines in buffer" - (lambda (w) - (with-current-buffer (widget-get w :current-buffer) - (occur search-form-search-string))) - t) - - ;; multi-occur - ;; Fix-me: This should be done from buffer-list. Have juri finished that? - (search-form-insert-search "Multi-Occur" 'multi-occur - "Lines in specified buffers" - (lambda (w) - (let ((bufs (search-form-multi-occur-get-buffers))) - (multi-occur bufs search-form-search-string))) - t) - ;; - (widget-insert "\n") - (widget-insert (propertize "* Files:" 'face 'font-lock-comment-face) - "\n") - - (search-form-insert-search "Search in Dir" 'lgrep - "Grep in directory" - 'search-form-lgrep - t) - (search-form-insert-search "Search in Tree" 'rgrep - "Grep in directory tree" - 'search-form-rgrep - t) - - (widget-insert "\n") - - (search-form-insert-search "Tagged Files" 'tags-search - "Search files in tags table" - (lambda (w) - (with-current-buffer (widget-get w :current-buffer) - (tags-search search-form-search-string))) - t) - - (widget-insert (make-string (window-width) ?-) "\n") - - (widget-insert "Replace: ") - (setq search-form-rfield - (widget-create 'editable-field - :size 58)) - (widget-insert "\n\n") - - (widget-insert (propertize "* Buffers:" 'face 'font-lock-comment-face) "\n") - (search-form-insert-replace "Replace String" - 'query-replace - "In buffer from point" - (lambda (w) - (query-replace search-form-search-string search-form-replace-string))) - - (search-form-insert-replace "Replace Regexp" - 'query-replace-regexp - "In buffer from point" - (lambda (w) - (query-replace-regexp search-form-search-string search-form-replace-string))) - - (widget-insert "\n" (propertize "* Files:" 'face 'font-lock-comment-face) "\n") - - ;; fix-me: rdir-query-replace (from to file-regexp root &optional delimited) - (search-form-insert-replace "Replace in Dir" - 'ldir-query-replace - "Replace in files in directory" - 'search-form-ldir-replace) - (search-form-insert-replace "Replace in Tree" - 'rdir-query-replace - "Replace in files in directory tree" - 'search-form-rdir-replace) - - (widget-insert "\n") - - (search-form-insert-replace "Tagged Files" - 'tags-query-replace - "Replace in files in tags tables" - (lambda (w) - (tags-query-replace search-form-search-string search-form-replace-string))) - - (buffer-disable-undo) - (widget-setup) - (buffer-enable-undo) - (use-local-map widget-keymap) - (fit-window-to-buffer) - (widget-forward 1) - )) - -(defun search-form-lgrep (w) - (search-form-r-or-lgrep w t)) - -(defun search-form-rgrep (w) - (search-form-r-or-lgrep w nil)) - -(defun search-form-r-or-lgrep (w l) - (with-current-buffer (widget-get w :current-buffer) - (let* ((regexp search-form-search-string) - (files (grep-read-files regexp)) - (dir (read-directory-name (if l "In directory: " - "Base directory: ") - nil default-directory t))) - (if l - (lgrep regexp files dir) - (rgrep regexp files dir) - )))) - -(defun search-form-ldir-replace (w) - (search-form-l-or-r-dir-replace w t)) - -(defun search-form-rdir-replace (w) - (search-form-l-or-r-dir-replace w nil)) - -(defun search-form-l-or-r-dir-replace (w l) - (let ((files (replace-read-files search-form-search-string search-form-replace-string)) - (dir (read-directory-name (if l - "In directory: " - "In directory tree: ") - nil - (file-name-directory - (buffer-file-name search-form-current-buffer)) - t))) - (if l - (ldir-query-replace search-form-search-string search-form-replace-string files dir) - (rdir-query-replace search-form-search-string search-form-replace-string files dir)))) - -(provide 'search-form) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; search-form.el ends here diff --git a/emacs.d/nxhtml/util/sex-mode.el b/emacs.d/nxhtml/util/sex-mode.el deleted file mode 100644 index 290a1a0..0000000 --- a/emacs.d/nxhtml/util/sex-mode.el +++ /dev/null @@ -1,463 +0,0 @@ -;;; sex-mode.el --- Shell EXecute mode / Send to EXternal program -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-06-01T18:41:50+0200 Sun -(defconst sex-mode:version "0.71") -;; Last-Updated: 2009-01-06 Tue -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Open urls belonging to other programs with those programs. To -;; enable this turn on the global minor mode `sex-mode'. -;; -;; If you for example open a .pdf file with C-x C-f it can be opened -;; by the .pdf application you have set your computer to use. (Or, if -;; that such settings are not possible on your OS, with the -;; application you have choosen here.) -;; -;; There is also a defmacro `sex-with-temporary-apps' that you can use -;; for example with `find-file' to open files in external -;; applications. -;; -;; The functions used to open files in external applications are -;; borrowed from `org-mode'. There is some small differences: -;; -;; - There is an extra variable here `sex-file-apps' that is checked -;; before the corresponding lists in `org-mode'. -;; -;; - In `org-mode' any file that is not found in the lists (and is not -;; remote or a directory) is sent to an external application. This -;; would create trouble when used here in a file handler so the -;; logic is the reverse here: Any file that is not found in the -;; lists is opened inside Emacs. (Actually I think that might be a -;; good default in `org-mode' too, but I am not sure.) -;; -;; - Because of the above I have to guess which function is the one -;; that sends a file to an external application. -;; -;; (Currently the integration with org.el is not the best code wise. -;; We hope to improve that soon.) -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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: - -;;(org-open-file "c:/EmacsW32/nxhtml/nxhtml/doc/nxhtml-changes.html") -(eval-when-compile (require 'cl)) -(eval-when-compile (require 'org)) -(eval-when-compile (require 'mailcap)) - -(defcustom sex-file-apps - '( - ("html" . emacs) - ("pdf" . default) - ("wnk" . default) - ) - "Application for opening a file. -See `sex-get-file-open-cmd'." - :group 'sex - :type '(repeat - (cons (choice :value "" - (string :tag "Extension") - (const :tag "Default for unrecognized files" t) - (const :tag "Remote file" remote) - (const :tag "Links to a directory" directory)) - (choice :value "" - (const :tag "Visit with Emacs" emacs) - (const :tag "Use system default" default) - (string :tag "Command") - (sexp :tag "Lisp form"))))) - -;;(sex-get-apps) - -(defvar sex-with-temporary-file-apps nil) - -(defun sex-get-apps () - (or sex-with-temporary-file-apps - (append sex-file-apps org-file-apps (org-default-apps)))) - -;; (sex-get-file-open-cmd "temp.el") -;; (sex-get-file-open-cmd "http://some.where/temp.el") -;; (sex-get-file-open-cmd "temp.c") -;; (sex-get-file-open-cmd "temp.pdf") -;; (sex-get-file-open-cmd "temp.doc") -;; (sex-get-file-open-cmd "/ftp:temp.doc") -;; (sex-get-file-open-cmd "http://some.host/temp.doc") -;; (sex-get-file-open-cmd "http://some.host/temp.html") - -(defun sex-get-file-open-cmd (path) - "Get action for opening file. -Construct a key from PATH: -- If PATH specifies a location on a remote system then set key to - 'remote. -- If PATH is a directory set key to 'directory. -- Otherwise use the file extension of PATH as key. - -Search with this key against the combined association list of -`sex-file-apps', `org-file-apps' and `org-default-apps'. The -first matching entry is used. - -If cdr of this entry is 'default then search again with key equal -to t for the default action for the operating system you are on -\(or your own default action if you have defined one in the -variables above). - -Return the cdr of the found entry. - -If no entry was found return `emacs' for opening inside Emacs." - (let* ((apps (sex-get-apps)) - (key (if (org-file-remote-p path) - 'remote - (if (file-directory-p path) - 'directory - (let ((ext (file-name-extension path))) - (if (and t ext) - ;; t should be a check for case insensitive - ;; file names ... - how do you do that? - (downcase ext) - ext))))) - (cmd (or (cdr (assoc key apps)) - 'emacs))) - (when (eq cmd 'default) - (setq cmd (or (cdr (assoc t apps)) - 'emacs))) - (when (eq cmd 'mailcap) - (require 'mailcap) - (mailcap-parse-mailcaps) - (let* ((mime-type (mailcap-extension-to-mime (or key ""))) - (command (mailcap-mime-info mime-type))) - (if (stringp command) - (setq cmd command) - (setq cmd 'emacs)))) - ;;(message "cmd=%s" cmd) - cmd)) - -;;;###autoload -(defgroup sex nil - "Customization group for `sex-mode'." - :group 'external) - -;;(setq sex-handle-urls t) -(defcustom sex-handle-urls nil - "When non-nil `sex-mode' also handles urls. -Turn on `url-handler-mode' when turning on `sex-mode' if this is -non-nil. Open urls in a web browser." - :type 'boolean - :group 'sex) - -;; (setq sex-keep-dummy-buffer nil) -;; (setq sex-keep-dummy-buffer 'visible) -;; (setq sex-keep-dummy-buffer 'burried) -(defcustom sex-keep-dummy-buffer 'visible - "Keep dummy buffer after opening file. -When opening a file with the shell a dummy buffer is created in -Emacs in `sex-file-mode' and an external program is called to -handle the file. How this dummy buffer is handled is governed by -this variable." - :type '(choice (const :tag "Visible" visible) - (const :tag "Burried" burried) - (const :tag "Do not keep it" nil)) - :group 'sex) - -(defcustom sex-reopen-on-buffer-entry nil - "If non-nil send file to shell again on buffer entry." - :type 'boolean - :group 'sex) - -(defun sex-post-command () - "Run post command in `sex-file-mode' buffers. -If `sex-reopen-on-buffer-entry' is non-nil then send the buffer -file to system again." - (when sex-reopen-on-buffer-entry - (if (and (boundp 'url-handler-regexp) - (string-match url-handler-regexp buffer-file-name)) - (sex-browse-url buffer-file-name) - (sex-handle-by-external buffer-file-name)) - (bury-buffer))) - -(defun sex-browse-url (url) - "Ask a web browser to open URL." - (condition-case err - (list (browse-url url) "Opened URL in web browser") - (error (list nil (error-message-string err))))) - -(defun sex-url-insert-file-contents (url &optional visit beg end replace) - (sex-generic-insert-file-contents - 'sex-browse-url - (concat "This dummy buffer is used just for opening a URL.\n" - "To open the URL again click here:\n\n ") - (concat "Tried to open URL in web browser, " - "but it failed with message\n\n ") - url visit beg end replace)) - -(defun sex-file-insert-file-contents (url &optional visit beg end replace) - ;;(message "sex-file-insert-file-contents %s %s %s %s %s" url visit beg end replace) - (sex-generic-insert-file-contents - 'sex-handle-by-external - (concat "This dummy buffer is used just for opening a file.\n" - "The file itself was sent to system for opening.\n\n" - "To open the file again click here:\n\n ") - (concat "Tried to send file" - " to system but it failed with message\n\n ") - url visit beg end replace)) - -(defun sex-write-file-function () - (set-buffer-modified-p nil) - (error "Can't write this to file, it is just a dummy buffer")) - -(defun sex-generic-insert-file-contents (insert-fun - success-header - fail-header - url &optional visit beg end replace) - (let ((window-config (current-window-configuration))) - (unless (= 0 (buffer-size)) - (error "Buffer must be empty")) - (set (make-local-variable 'write-file-functions) - '(sex-write-file-function)) - (let* ((name url) - ;;(result (sex-browse-url name)) - (result (funcall insert-fun name)) - (success (nth 0 result)) - (msg (nth 1 result))) - (setq buffer-file-name name) - (if success - (progn - (insert success-header) - (sex-setup-restore-window-config window-config) - (message "%s" msg)) - (insert (propertize "Error: " 'face 'font-lock-warning-face) - fail-header msg - "\n\nTo try again click here:\n\n ")) - (save-excursion - (insert-text-button - buffer-file-name - 'insert-fun insert-fun - 'action (lambda (button) - ;;(sex-browse-url buffer-file-name) - (funcall (button-get button 'insert-fun) buffer-file-name) - )))))) - -(defun sex-file-handler (operation &rest args) - "Handler for `insert-file-contents'." - ;;(message "\noperation=%s, args=%s" operation args) - (let ((done nil) - (ftype 'emacs)) - ;; Always open files inside Emacs if the file opening request came - ;; through Emacs client. Here is a primitive test if we are called - ;; from outside, client-record is bound in `server-visit-files' - ;; ... - (when (not (boundp 'client-record)) - (let* ((filename (car args)) - (insert-handling (sex-get-file-open-cmd filename))) - ;;(message "insert-handling=%s" insert-handling) - (when insert-handling - (setq ftype insert-handling)) - ;;(message "ftype=%s, filename=%s" ftype filename) - )) - (unless (eq ftype 'emacs) - ;;(message "using sex-file-insert-file-contents for %s" args) - (apply 'sex-file-insert-file-contents args) - (setq done t)) - ;; Handle any operation we don't know about. - (unless done - ;;(message "fallback for operation=%s, args=%s" operation args) - (let ((inhibit-file-name-handlers - (cons 'sex-file-handler - (and (eq inhibit-file-name-operation operation) - inhibit-file-name-handlers))) - (inhibit-file-name-operation operation)) - (apply operation args))))) -;; Note: Because of a bug in Emacs we must restrict the use of this -;; file handler to only 'insert-file-contents. (We should of course -;; anyway do that.) -(put 'sex-file-handler 'operations '(insert-file-contents)) - -(defun sex-setup-restore-window-config (window-config) - (when (not (eq sex-keep-dummy-buffer 'visible)) - (run-with-idle-timer 0 nil - 'sex-restore-window-config - (selected-frame) - window-config - (unless sex-keep-dummy-buffer - (current-buffer))))) - -(defun sex-restore-window-config (frame win-config buffer) - (save-match-data ;; runs in timer - (with-selected-frame frame - (set-window-configuration win-config)) - (when buffer (kill-buffer buffer)))) - -(defun sex-handle-by-external (&optional file) - "Give file FILE to external program. -Return a list: - - (SUCCESS MESSAGE) - -where SUCCESS is non-nil if operation succeeded and MESSAGE is an -informational message." - (unless file (setq file buffer-file-name)) - (let ((cmd (sex-get-file-open-cmd file))) - (assert (not (eq cmd 'emacs))) - (cond - ((and (stringp cmd) (not (string-match "^\\s-*$" cmd))) - ;; Remove quotes around the file name - we'll use shell-quote-argument. - (while (string-match "['\"]%s['\"]" cmd) - (setq cmd (replace-match "%s" t t cmd))) - (while (string-match "%s" cmd) - (setq cmd (replace-match - (save-match-data - (shell-quote-argument - (convert-standard-filename file))) - t t cmd))) - (save-window-excursion - (start-process-shell-command cmd nil cmd) - ;;(and (boundp 'org-wait) (numberp org-wait) (sit-for org-wait)) - ) - (list t (format "Opened %s in external application" file))) - ((consp cmd) - (let ((file (convert-standard-filename file))) - (eval cmd)) - (list t (format "Opened %s in external application" file))) - (t (list nil (format "Don't know how to handle %s" file)))) - )) - - -(define-derived-mode sex-file-mode nil - "External" - "Mode for files opened in external programs." - (add-hook 'post-command-hook 'sex-post-command nil t) - (set-keymap-parent (current-local-map) button-buffer-map) - (set-buffer-modified-p nil) - (setq buffer-read-only t)) - - -(defvar sex-old-url-insert-file-contents nil) -(defvar sex-old-url-handler-mode nil) - -;;;###autoload -(define-minor-mode sex-mode - "Open certain files in external programs. -See `sex-get-file-open-cmd' for how to determine which files to -open by external applications. Note that this selection is -nearly the same as in `org-mode'. The main difference is that -the fallback always is to open a file in Emacs. \(This is -necessary to avoid to disturb many of Emacs operations.) - -This affects all functions that opens files, like `find-file', -`find-file-noselect' etc. - -However it does not affect files opened through Emacs client. - -Urls can also be handled, see `sex-handle-urls'. - -When opening a file with the shell a \(temporary) dummy buffer is -created in Emacs with major mode `sex-file-mode' and an external -program is called to handle the file. How this dummy buffer is -handled is governed by `sex-keep-dummy-buffer'." - - ;; On MS Windows `w32-shell-execute' is called to open files in an - ;; external application. Be aware that this may run scripts if the - ;; script file extension is not blocked in `sex-open-alist'. - nil - :group 'sex - :global t - ;; fix-me: better list handling - (if sex-mode - (progn - (require 'org) - (dolist (rec (sex-get-apps)) - (let* ((ext (car rec)) - (app (cdr rec)) - (patt (when (and (stringp ext) - (not (eq app 'emacs))) - (concat "\\." ext "\\'")))) - (unless patt - (when (eq ext t) - (setq patt (concat ".*\\'")))) - (when patt - (unless (eq ext t) - (add-to-list 'auto-mode-alist (cons patt 'sex-file-mode))) - (add-to-list 'file-name-handler-alist - (cons patt 'sex-file-handler) t)))) - (setq sex-old-url-insert-file-contents - (get 'insert-file-contents 'url-file-handlers)) - (setq sex-old-url-handler-mode url-handler-mode) - (when sex-handle-urls - ;;(message "req url, before") - (require 'url-handlers) - ;;(message "req url, after") - (put 'insert-file-contents 'url-file-handlers - 'sex-url-insert-file-contents) - (unless url-handler-mode - (url-handler-mode 1) - ;;(message "after url-handler-mode 1") - ))) - ;; Remove from the lists: - ;;(let ((handler-list (copy-list file-name-handler-alist))) - (let ((handler-list (copy-sequence file-name-handler-alist))) - (dolist (handler handler-list) - (when (eq 'sex-file-handler (cdr handler)) - (setq file-name-handler-alist - (delete handler file-name-handler-alist))))) - ;;(let ((mode-alist (copy-list auto-mode-alist))) - (let ((mode-alist (copy-sequence auto-mode-alist))) - (dolist (auto-mode mode-alist) - (when (eq 'sex-file-mode (cdr auto-mode)) - (setq auto-mode-alist - (delete auto-mode auto-mode-alist))))) - (put 'insert-file-contents 'url-file-handlers - sex-old-url-insert-file-contents) - (unless sex-old-url-handler-mode (url-handler-mode 0)))) - -(defmacro sex-with-temporary-apps (open-alist &rest body) - "Run BODY with `sex-mode' on. -If OPEN-ALIST is not t it replaces the list normally used by -`sex-get-file-open-cmd'." - (declare (indent 1) (debug t)) - `(let ((old-sex-mode sex-mode) - (sex-with-temporary-file-apps - (if (eq ,open-alist t) - nil - ,open-alist))) - (when sex-mode (sex-mode -1)) - (sex-mode 1) - ,@body - (setq sex-with-temporary-file-apps nil) - (unless old-sex-mode (sex-mode -1)))) - -;; (with-sex t (find-file "c:/emacs-lisp/gimp-mode-v1.40/gimpmode.pdf")) -;; (with-sex nil (find-file "c:/emacs-lisp/gimp-mode-v1.40/gimpmode.pdf")) - -(provide 'sex-mode) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; sex-mode.el ends here diff --git a/emacs.d/nxhtml/util/sml-modeline.el b/emacs.d/nxhtml/util/sml-modeline.el deleted file mode 100644 index 882d184..0000000 --- a/emacs.d/nxhtml/util/sml-modeline.el +++ /dev/null @@ -1,192 +0,0 @@ -;;; sml-modeline.el --- Show position in a scrollbar like way in mode-line -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2010-03-16 Tue -;; Version: 0.5 -;; Last-Updated: 2010-03-18 Thu -;; URL: http://bazaar.launchpad.net/~nxhtml/nxhtml/main/annotate/head%3A/util/sml-modeline.el -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Show scrollbar like position indicator in mode line. -;; See the global minor mode `sml-modeline-mode' for more information. -;; -;; Idea and part of this code is adapted from David Engster's and Drew -;; Adam's code in these mail messages: -;; -;; http://lists.gnu.org/archive/html/emacs-devel/2010-03/msg00523.html -;; http://permalink.gmane.org/gmane.emacs.devel/122038 -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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, 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: - -;;;###autoload -(defgroup sml-modeline nil - "Customization group for `sml-modeline-mode'." - :group 'frames) - -(defun sml-modeline-refresh () - "Refresh after option changes if loaded." - (when (featurep 'sml-modeline) - (when (and (boundp 'sml-modeline-mode) - sml-modeline-mode) - (sml-modeline-mode -1) - (sml-modeline-mode 1)))) - -(defcustom sml-modeline-len 12 - "Mode line indicator total length." - :type 'integer - :set (lambda (sym val) - (set-default sym val) - (sml-modeline-refresh)) - :group 'sml-modeline) - -(defcustom sml-modeline-borders nil - "Indicator borders. -This is a pair of indicators, like [] or nil." - :type '(choice (const :tag "None" nil) - (cons (string :tag "Left border") - (string :tag "Right border"))) - :set (lambda (sym val) - (set-default sym val) - (sml-modeline-refresh)) - :group 'sml-modeline) - -(defcustom sml-modeline-numbers 'percentage - "Position number style. -This can be 'percentage or 'line-number." - :type '(choice (const :tag "Line numbers" line-numbers) - (const :tag "Percentage" percentage)) - :set (lambda (sym val) - (set-default sym val) - (sml-modeline-refresh)) - :group 'sml-modeline) - -(defface sml-modeline-end-face - '((t (:inherit match))) - "Face for invisible buffer parts." - :group 'sml-modeline) -;; 'face `(:background ,(face-foreground 'mode-line-inactive) -;; :foreground ,(face-background 'mode-line)) - -(defface sml-modeline-vis-face - '((t (:inherit region))) - "Face for invisible buffer parts." - :group 'sml-modeline) -;; 'face `(:background ,(face-foreground 'mode-line) -;; :foreground ,(face-background 'mode-line)) - -;;(sml-modeline-create) -(defun sml-modeline-create () - (let* ((wstart (window-start)) - (wend (window-end)) - number-max number-beg number-end - (sml-begin (or (car sml-modeline-borders) "")) - (sml-end (or (cdr sml-modeline-borders) "")) - (inner-len (- sml-modeline-len (length sml-begin) (length sml-end))) - bpad-len epad-len - pos-% - start end - string) - (if (not (or (< wend (save-restriction (widen) (point-max))) - (> wstart 1))) - "" - (cond - ((eq sml-modeline-numbers 'percentage) - (setq number-max (save-restriction (widen) (point-max))) - (setq number-beg (/ (float wstart) (float number-max))) - (setq number-end (/ (float wend) (float number-max))) - (setq start (floor (* number-beg inner-len))) - (setq end (floor (* number-end inner-len))) - (setq string - (concat (format "%02d" (round (* number-beg 100))) - "-" - (format "%02d" (round (* number-end 100))) "%%"))) - ((eq sml-modeline-numbers 'line-numbers) - (save-restriction - (widen) - (setq number-max (line-number-at-pos (point-max))) - (setq number-beg (line-number-at-pos wstart)) - (setq number-end (line-number-at-pos wend))) - (setq start (floor (* (/ number-beg (float number-max)) inner-len))) - (setq end (floor (* (/ number-end (float number-max)) inner-len))) - (setq string - (concat "L" - (format "%02d" number-beg) - "-" - (format "%02d" number-end)))) - (t (error "Unknown sml-modeline-numbers=%S" sml-modeline-numbers))) - (setq inner-len (max inner-len (length string))) - (setq bpad-len (floor (/ (- inner-len (length string)) 2.0))) - (setq epad-len (- inner-len (length string) bpad-len)) - (setq pos-% (+ bpad-len (length string) -1)) - (setq string (concat sml-begin - (make-string bpad-len 32) - string - (make-string epad-len 32) - sml-end)) - ;;(assert (= (length string) sml-modeline-len) t) - (when (= start sml-modeline-len) (setq start (1- start))) - (setq start (+ start (length sml-begin))) - (when (= start end) (setq end (1+ end))) - (when (= end pos-%) (setq end (1+ end))) ;; If on % add 1 - (put-text-property start end 'face 'sml-modeline-vis-face string) - (when (and (= 0 (length sml-begin)) - (= 0 (length sml-end))) - (put-text-property 0 start 'face 'sml-modeline-end-face string) - (put-text-property end sml-modeline-len 'face 'sml-modeline-end-face string)) - string))) - -(defvar sml-modeline-old-car-mode-line-position nil) - -;;;###autoload -(define-minor-mode sml-modeline-mode - "Show buffer size and position like scrollbar in mode line. -You can customize this minor mode, see option `sml-modeline-mode'. - -Note: If you turn this mode on then you probably want to turn off -option `scroll-bar-mode'." - :global t - :group 'sml-modeline - (if sml-modeline-mode - (progn - (unless sml-modeline-old-car-mode-line-position - (setq sml-modeline-old-car-mode-line-position (car mode-line-position))) - (setcar mode-line-position '(:eval (list (sml-modeline-create))))) - (setcar mode-line-position sml-modeline-old-car-mode-line-position))) - - -(provide 'sml-modeline) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; sml-modeline.el ends here diff --git a/emacs.d/nxhtml/util/tabkey2.el b/emacs.d/nxhtml/util/tabkey2.el deleted file mode 100644 index d35e651..0000000 --- a/emacs.d/nxhtml/util/tabkey2.el +++ /dev/null @@ -1,1701 +0,0 @@ -;;; tabkey2.el --- Use second tab key pressed for what you want -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-03-15 -(defconst tabkey2:version "1.40") -;; Last-Updated: 2009-07-15 Wed -;; URL: http://www.emacswiki.org/cgi-bin/wiki/tabkey2.el -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; - ;; `appmenu', `cl'. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; The tab key is in Emacs often used for indentation. However if you -;; press the tab key a second time and Emacs tries to do indentation -;; again, then usually nothing exciting will happen. Then why not use -;; second tab key in a row for something else? -;; -;; Commonly used completion functions in Emacs is often bound to -;; something corresponding to Alt-Tab. Unfortunately this is unusable -;; if you have a window manager that have an apetite for it (like that -;; on MS Windows for example, and several on GNU/Linux). -;; -;; Then using the second tab key press for completion might be a good -;; choice and perhaps also easy to remember. -;; -;; This little library tries to make it easy to do use the second tab -;; press for completion. Or you can see this library as a swizz army -;; knife for the tab key ;-) -;; -;; See `tabkey2-mode' for more information. -;; -;; -;; This is a generalized of an idea Sebastien Rocca Serra once -;; presented on Emacs Wiki and called "Smart Tab". (It seems like -;; many others have also been using Tab for completion in one way or -;; another for years.) -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; Version 1.04: -;; - Add overlay to display state after first tab. -;; -;; Version 1.05: -;; - Fix remove overlay problem. -;; -;; Version 1.06: -;; - Add completion function choice. -;; - Add support for popcmp popup completion. -;; -;; Version 1.07: -;; - Add informational message after first tab. -;; -;; Version 1.08: -;; - Give better informational message after first tab. -;; -;; Version 1.09: -;; - Put flyspell first. -;; -;; Version 1.09: -;; - Give the overlay higher priority. -;; -;; Version 1.10: -;; - Correct tabkey2-completion-functions. -;; - Add double-tab for modes where tab can not be typed again. -;; - Use better condition for when completion can be done, so that it -;; can be done later while still on the same line. -;; - Add a better message handling for the "Tab completion state". -;; - Add C-g break out of the "Tab completion state". -;; - Add faces for highlight. -;; - Make it work in custom mode buffers. -;; - Fix documentation for `tabkey2-first' -;; -;; Version 1.11: -;; - Don't call chosen completion function directly. Instead make it -;; default for current buffer. -;; -;; Version 1.12: -;; - Simplify code. -;; - Add help to C-f1 during "Tab completion state". -;; - Fix documentation basics. -;; - Add customization of state message and line marking. -;; - Fix handling of double-Tab modes. -;; - Make user interaction better. -;; - Handle read-only in custom buffers better. -;; - Add more flexible check for if completion function is active. -;; - Support predictive mode. -;; - Reorder and simplify. -;; -;; Version 1.13: -;; - Add org-mode to the double-tab gang. -;; - Make it possible to use double-tab in normal buffers. -;; - Add cycling through completion functions to S-tab. -;; -;; Version 1.14: -;; - Fix bug in handling of read-only. -;; - Show completion binding in help message. -;; - Add binding to make current choice buffer local when cycling. -;; -;; Version 1.15: -;; - Fix problem at buffer end. -;; - Add S-tab to enter completion state without indentation. -;; - Add backtab bindings too for this. -;; - Remove double-tab, S-tab is better. -;; - Add list of modes that uses more tabs. -;; - Add list of modes that uses tab only for completion. -;; - Move first overlay when indentation changes. -;; - Make mark at line beginning 1 char long. -;; -;; Version 1.16: -;; - Don't call tab function when alternate key is pressed. -;; -;; Version 1.17: -;; - Let alternate key cycle completion functions instead of complete. -;; - Bind backtab. -;; - Fix bug when only one completion funciton was available. -;; - Fix bug when alt key and major without fix indent. -;; -;; Version 1.18: -;; - Add popup style messages. -;; - Add delay to first message. -;; - Use different face for indicator on line and message. -;; - Use different face for echo area and popup messages. -;; - Add anything to completion functions. -;; - Put help funciton on f1. -;; - Always bind alternate key to cycle. -;; - Change defcustoms to simplify (excuse me). -;; - Work around end of buffer problems. -;; - Work around start of buffer problems. -;; - Assure popup messages are visible. -;; - Reorder code in more logical order. -;; -;; Version 1.19: -;; - Make overlay keymap end advance. -;; - Remove overlay keymap parent. -;; -;; Version 1.20: -;; - Fix bug on emtpy line. -;; - Fix some text problems. -;; - Make f1 c/k work in tab completion state. -;; -;; Version 1.20: -;; - Fixed bug in overlay removal. -;; -;; Version 1.21: -;; - Fixed bug in minibuffer setup. -;; -;; Version 1.22: -;; - Honour widget-forward, button-forward. -;; -;; Version 1.23: -;; - Remove binding of shift tab. -;; - Check if use-region-p is defined. -;; -;; Version 1.24: -;; - Add option for completion state mode line marker. -;; - Fix bug in tabkey2-show-completion-functions. -;; - Move off completion point cancels completion state. -;; - Fix bugs in help. -;; - Try to fix some problems with invisible text, at least in -;; org-mode. -;; - Restore window config, completions often leaves without. -;; -;; Version 1.25: -;; - Fix bug in tabkey2-completion-state-p. -;; -;; Version 1.26: -;; - Make tabkey2-mode a buffer local mode. -;; - Add tabkey2-global-mode. -;; - Fix some bugs. -;; -;; Version 1.27: -;; - Fix some bugs in customization. -;; -;; Version 1.28: -;; - Use invisible-p. -;; -;; Version 1.29: -;; - Remove tabkey2-global-mode because of problem with minibuffers. -;; -;; Version 1.30: -;; - Add Semantic's smart completion to completion functions. -;; (Thanks Eric.) -;; -;; Version 1.31: -;; - Add yasnippet and pabbrev completion functions. (Thanks Eric.) -;; - Reorder completion functions. -;; -;; Version 1.32: -;; - Add support for pcomplete. -;; - Inform about other key bindings in completion functions list. -;; - Remove no longer used "preferred" from completion functions list. -;; -;; Version 1.33: -;; -- Automatically select next function on completion failure. -;; -- Add completion functions reset functions. -;; -;; Version 1.34: -;; - Set this-command on call-interactively. -;; - Avoid setting last-command. -;; -;; Version 1.35: -;; - Do not complete in or nearby mumamo chunk borders. -;; - Finish completion mode unless last command was a tabkey2 command. -;; - Finish when there are no more active completion functions. -;; -;; Version 1.36: -;; - Actually check if completion function is a defined command. -;; - Integrate better with YASnippet. -;; - Give YASnippet higher priority since that seems what is wanted. -;; -;; Version 1.37: -;; - Fix bug revealed by 1.36 changes. -;; -;; Version 1.38: -;; - Fix typo in completion function list. -;; - Fix corresponding part of check if function is active. -;; -;; Version 1.39: -;; - Try first [tab] and then [?\t] when looking for command. -;; -;; Version 1.40: -;; - Added Company Mode completion. -;; -;; Fix-me: maybe add \\_>> option to behave like smart-tab. But this -;; will only works for modes that does not do completion of empty -;; words (like in smart-tab). -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Known bugs -;; -;; - Maybe problems with comint shell. -;; - Does not check visibility very carefully. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'cl)) -(eval-when-compile (require 'appmenu nil t)) -(eval-when-compile (require 'mumamo nil t)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Custom - -;;;###autoload -(defgroup tabkey2 nil - "Customization of second tab key press." - :group 'nxhtml - :group 'convenience) - -(defface tabkey2-highlight-line - '((t :inherit highlight)) - "Face for marker on line when default function is active." - :group 'tabkey2) - -(defface tabkey2-highlight-line2 - '((t :inherit isearch-fail)) - "Face for marker on line when non-default function is active." - :group 'tabkey2) - -(defface tabkey2-highlight-message - '((t :inherit tabkey2-highlight-line)) - "Face for messages in echo area." - :group 'tabkey2) - -(defface tabkey2-highlight-popup - '((default :box t :inherit tabkey2-highlight-message) - (((class color) (background light)) :foreground "black") - (((class color) (background dark)) :foreground "yellow")) - "Face for popup messages." - :group 'tabkey2) - -(defcustom tabkey2-show-mark-on-active-line t - "Show mark on active line if non-nil. -This mark is shown during 'Tab completion state'." - :type 'boolean - :group 'tabkey2) - -(defvar tabkey2-completion-lighter nil) -(defcustom tabkey2-completion-lighter-on nil - "Mode line lighter for function `tabkey2-completion-state-mode'." - :type 'boolean - :set (lambda (symbol value) - (set-default symbol value) - (setq tabkey2-completion-lighter (if value " Tab2" nil)) - (setq minor-mode-alist - (assq-delete-all 'tabkey2-completion-state-mode - minor-mode-alist))) - :group 'tabkey2) - -(defcustom tabkey2-show-message-on-enter 2.0 - "If non-nil show message when entering 'Tab completion state'. -If value is a number then delay message that number of seconds." - :type '(choice (const :tag "Don't show" nil) - (const :tag "Show at once" t) - (float :tag "Show, but delayed (seconds)")) - :group 'tabkey2) - - -;; (setq tabkey2-message-style 'popup) -;; (setq tabkey2-message-style 'echo-area) -(defcustom tabkey2-message-style 'popup - "How to show messages." - :type '(choice (const :tag "Popup" popup) - (const :tag "Echo area" echo-area)) - :group 'tabkey2) - -(defcustom tabkey2-in-minibuffer nil - "If non-nil use command `tabkey2-mode' also in minibuffer." - :type 'boolean - :group 'tabkey2) - -(defcustom tabkey2-in-appmenu t - "Show a completion menu in command `appmenu-mode' if t." - :type 'boolean - :set (lambda (sym val) - (set-default sym val) - (when (fboundp 'appmenu-add) - (if val - (appmenu-add 'tabkey2 nil t "Completion" 'tabkey2-appmenu) - (appmenu-remove 'tabkey2)))) - :group 'tabkey2) - -(defun yas/expandable-at-point () - "Return non-nil if a snippet can be expanded here." - (when (and (fboundp 'yas/template-condition-predicate) - (boundp 'yas/buffer-local-condition)) - (yas/template-condition-predicate - yas/buffer-local-condition))) - -(defvar tabkey2-company-backends - "List of frontends and their backends." - '((company-mode (NONE company-abbrev . "Abbrev") - (NONE company-css . "CSS") - (dabbrev-expan company-dabbrev . "dabbrev for plain text") - (NONE company-dabbrev-code . "dabbrev for code") - (NONE company-eclim . "eclim (an Eclipse interace)") - (lisp-symbol-complete company-elisp . "Emacs Lisp") - (complete-tag company-etags . "etags") - (NONE company-files . "Files") - (NONE company-gtags . "GNU Global") - (ispell-complete-word company-ispell . "ispell") - (flyspell-correct-word-before-point company-ispell . "ispell") - (NONE company-keywords . "Programming language keywords") - (nxml-complete company-nxml . "nxml") - (NONE company-oddmuse . "Oddmuse") - (NONE company-pysmell . "PySmell") - (NONE company-ropemacs . "ropemacs") - (senator-complete-symbol company-semantic . "CEDET Semantic") - (NONE company-tempo . "Tempo templates") - (NONE company-xcode . "Xcode")))) - -(defun tabkey2-find-front-end (fun) - (let (( - )))) - -(defcustom tabkey2-completion-functions - '( - ;; Front ends (should take care of the rest, ie temporary things, - ;; snippets etc...) - ("Company Mode completion" company-complete company-mode) - ;; Temporary things - ("Spell check word" flyspell-correct-word-before-point) - ;; Snippets - ("Yasnippet" yas/expand (yas/expandable-at-point)) - ;; Main mode related, often used - ("Semantic Smart Completion" senator-complete-symbol senator-minor-mode) - ("Programmable completion" pcomplete) - ("nXML completion" nxml-complete) - ("Complete Emacs symbol" lisp-complete-symbol) - ("Widget complete" widget-complete) - ("Comint Dynamic Complete" comint-dynamic-complete) - ("PHP completion" php-complete-function) - ("Tags completion" complete-tag) - ;; General word completion - ("Predictive word" complete-word-at-point predictive-mode) - ("Predictive abbreviations" pabbrev-expand-maybe) - ("Dynamic word expansion" dabbrev-expand nil (setq dabbrev--last-abbrev-location nil)) - ("Ispell complete word" ispell-complete-word) - ;; The catch all - ("Anything" anything (commandp 'anything)) - ) - "List of completion functions. -The first 'active' entry in this list is normally used during the -'Tab completion state' by `tabkey2-complete'. An entry in the -list should have either of this forms - - \(TITLE COMPLETION-FUNCTION ACTIVE-FORM RESET-FORM) - -TITLE to show in menus etc. - -COMPLETION-FUNCTION is the completion function symbol. - -The entry is considered active if the symbol COMPLETION-FUNCTION -is bound to a command and - - - This function has a key binding at point. - -or - - - The elisp expression ACTIVE-FORM evaluates to non-nil. If it - is a single symbol then its variable value is used, otherwise - the elisp form is evaled. - -RESET-FORM is used to reset the completion function before -calling it. - -When choosing with `tabkey2-cycle-completion-functions' -only the currently active entry in this list are shown." - :type '(repeat (list string (choice (command :tag "Currently known command") - (symbol :tag "Command not known yet")) - (choice (const :tag "Active only if it has a key binding at point" nil) - (sexp :tag "Elisp, if evals to non-nil then active")) - (sexp :tag "Elisp, reset completion function"))) - :group 'tabkey2) - -;; Use emulation mode map for first Tab key -(defconst tabkey2-mode-emul-map (make-sparse-keymap) - "This keymap just binds tab and alternate key all the time. -By default this binds Tab to `tabkey2-first'. The actual keys -bound are in `tabkey2-first-key' and `tabkey2-alternate-key'.") - -(defvar tabkey2--emul-keymap-alist nil) - -;; (setq tabkey2-keymap-overlay nil) -(defconst tabkey2-completion-state-emul-map - (let ((map (make-sparse-keymap))) - (define-key map [(control ?c) tab] 'tabkey2-make-current-default) - - ;;(define-key map tabkey2-alternate-key 'tabkey2-cycle-completion-functions) - (define-key map [backtab] 'tabkey2-cycle-completion-functions) - - (define-key map [(control f1)] 'tabkey2-completion-function-help) - (define-key map [(meta f1)] 'tabkey2-show-completion-functions) - (define-key map [f1] 'tabkey2-completion-state-help) - - (define-key map [(control ?g)] 'tabkey2-completion-state-off) - (define-key map [tab] 'tabkey2-complete) - map) - "This keymap is for `tabkey2-keymap-overlay'.") - -(defun tabkey2-bind-keys (first-key alternate-key) - (let ((mode-map tabkey2-mode-emul-map) - (comp-map tabkey2-completion-state-emul-map)) - ;; First key - (when (and (boundp 'tabkey2-first-key) - tabkey2-first-key) - (define-key mode-map tabkey2-first-key nil)) - (when first-key - (define-key mode-map first-key 'tabkey2-first)) - ;; Alternate key - (when (and (boundp 'tabkey2-alternate-key) - tabkey2-alternate-key) - (define-key mode-map tabkey2-alternate-key nil) - (define-key comp-map tabkey2-alternate-key nil)) - (when alternate-key - (define-key mode-map alternate-key 'tabkey2-cycle-completion-functions) - (define-key comp-map alternate-key 'tabkey2-cycle-completion-functions)) - (when (and (boundp 'tabkey2-completion-state-mode) - tabkey2-completion-state-mode) - (tabkey2-completion-state-mode -1) - (tabkey2-completion-state-mode 1)))) - -(defcustom tabkey2-first-key [tab] - "First key, first time indents, more invocations completes. -This key is always bound to `tabkey2-first'." - :set (lambda (sym val) - (set-default sym val) - (tabkey2-bind-keys - val - (when (boundp 'tabkey2-alternate-key) - tabkey2-alternate-key))) - :type 'key-sequence - :group 'tabkey2) - -(defcustom tabkey2-alternate-key [f8] - "Alternate key, bound to cycle and show completion functions. -This key is always bound to `tabkey2-cycle-completion-functions'." - :set (lambda (sym val) - (set-default sym val) - (tabkey2-bind-keys (when (boundp 'tabkey2-first-key) tabkey2-first-key) val)) - :type 'key-sequence - :group 'tabkey2) - -(tabkey2-bind-keys tabkey2-first-key tabkey2-alternate-key) - -;;;###autoload -(define-minor-mode tabkey2-mode - "More fun with Tab key number two (completion etc). -This global minor mode by default binds Tab in a way that let you -do completion with Tab in all buffers \(where it is possible). - -The Tab key is easy to type on your keyboard. Then why not use -it for completion, something that is very useful? Shells usually -use Tab for completion so many are used to it. This was the idea -of Smart Tabs and this is a generalization of that idea. - -However in Emacs the Tab key is usually used for indentation. -The idea here is that if Tab has been pressed once for -indentation, then as long as point stays further Tab keys might -as well do completion. - -So you kind of do Tab-Tab for first completion \(and then just -Tab for further completions as long as point is not moved). - -And there is even kind of Tab-Tab-Tab completion: If completion -fails the next completion function will be the one you try with -next Tab. \(You get some notification of this, of course.) - -See `tabkey2-first' for more information about usage. - -Note: If you do not want the Tab-Tab behaviour above, but still -want an easy way to reach the available completion functions, -then you can instead of turning on tabkey2-mode enter this in -your .emacs: - - \(global-set-key [f8] 'tabkey2-cycle-completion-functions) - -After hitting f8 you will then be in the same state as after the -first in tabkey2-mode." - :keymap nil - :global t - :group 'tabkey2 - (if tabkey2-mode - (progn - (add-hook 'minibuffer-setup-hook 'tabkey2-minibuffer-setup) - (add-hook 'post-command-hook 'tabkey2-post-command) - ;; Update emul here if keymap have changed - (setq tabkey2--emul-keymap-alist - (list (cons 'tabkey2-mode - tabkey2-mode-emul-map))) - (add-to-list 'emulation-mode-map-alists 'tabkey2--emul-keymap-alist)) - (tabkey2-completion-state-mode -1) - (remove-hook 'post-command-hook 'tabkey2-post-command) - (remove-hook 'minibuffer-setup-hook 'tabkey2-minibuffer-setup) - (setq emulation-mode-map-alists (delq 'tabkey2--emul-keymap-alist - emulation-mode-map-alists)))) - -(defcustom tabkey2-modes-that-use-more-tabs - '(python-mode - haskell-mode - makefile-mode - org-mode - Custom-mode - custom-mode ;; For Emacs 22 - ;; other - cmd-mode - ) - "In those modes use must use S-Tab to start completion state. -In those modes pressing Tab several types may make sense so you -can not go into 'Tab completion state' just because one Tab has -been pressed. Instead you use S-Tab to go into that state. -After that Tab does completion. - -You can do use S-Tab in other modes too if you want too." - :type '(repeat (choice (command :tag "Currently known command") - (symbol :tag "Command not known yet"))) - :group 'tabkey2) - -(defcustom tabkey2-modes-that-just-complete - '(shell-mode - fundamental-mode - text-mode) - "Tab is only used for completion in these modes. -Therefore `tabkey2-first' just calls the function on Tab." - :type '(repeat (choice (command :tag "Currently known command") - (symbol :tag "Command not known yet"))) - :group 'tabkey2) - -;;(setq tabkey2-use-popup-menus nil) -;; (defcustom tabkey2-use-popup-menus (when (featurep 'popcmp) t) -;; "Use pop menus if available." -;; :type 'boolean -;; :group 'tabkey2) - -;; (defvar tabkey2-preferred nil -;; "Preferred function for second tab key press.") -;; (make-variable-buffer-local 'tabkey2-preferred) -;; (put 'tabkey2-preferred 'permanent-local t) - -(defvar tabkey2-fallback nil - "Fallback function for second tab key press.") -(make-variable-buffer-local 'tabkey2-fallback) -(put 'tabkey2-fallback 'permanent-local t) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; State - -(defvar tabkey2-overlay nil - "Show when tab key 2 action is to be done.") -(defvar tabkey2-keymap-overlay nil - "Hold the keymap for tab key 2.") - -(defvar tabkey2-current-tab-info nil - "Saved information message for Tab completion state.") -(defvar tabkey2-current-tab-function nil - "Tab completion state current completion function.") -(make-variable-buffer-local 'tabkey2-current-tab-function) - -(defun tabkey2-completion-state-p () - "Return t if Tab completion state should continue. -Otherwise return nil." - (when (and (eq (current-buffer) (overlay-buffer tabkey2-keymap-overlay)) - (eq (overlay-get tabkey2-keymap-overlay 'window) (selected-window))) - (let* ((start (overlay-start tabkey2-keymap-overlay)) - (end (overlay-end tabkey2-keymap-overlay)) - (chars (append (buffer-substring-no-properties start end) nil))) - (and (not (memq ?\n chars)) - (not (eq ?\ (car (last chars)))) - (not (eq ?\ last-input-event)) - (<= start (point)) - (<= (point) end) - tabkey2-current-tab-function - (or (memq this-original-command '(tabkey2-first tabkey2-complete)) - (let* ((last-name (symbol-name this-original-command)) - (name-prefix "tabkey2-") - (prefix-len (length name-prefix))) - (and (> (length last-name) prefix-len) - (string= name-prefix (substring last-name 0 prefix-len))))) - )))) - -(defun tabkey2-read-only-p () - "Return non-nil if buffer seems to be read-only at point." - (or buffer-read-only - (get-char-property (min (+ 0 (point)) (point-max)) 'read-only) - (let ((remap (command-remapping 'self-insert-command (point)))) - (memq remap '(Custom-no-edit))))) - -;;;; Minor mode active after first tab - -(defun tabkey2-get-highlight-face () - (if (eq tabkey2-current-tab-function - (tabkey2-first-active-from-completion-functions)) - 'tabkey2-highlight-line - 'tabkey2-highlight-line2)) - -(defun tabkey2-move-overlays () - "Move overlays that mark the state and carries the state keymap." - (let* ((beg (let ((inhibit-field-text-motion t)) - (line-beginning-position))) - (ind (current-indentation)) - (end (+ beg 1)) ;(if (> ind 0) ind 1))) - (inhibit-read-only t)) - (unless tabkey2-overlay - (setq tabkey2-overlay (make-overlay beg end))) - ;; Fix-me: gets some strange errors, try avoid moving: - (unless (and (eq (current-buffer) (overlay-buffer tabkey2-overlay)) - (= beg (overlay-start tabkey2-overlay)) - (= end (overlay-end tabkey2-overlay))) - (move-overlay tabkey2-overlay beg end (current-buffer))) - ;; Give it a high priority, it is very temporary - (overlay-put tabkey2-overlay 'priority 1000) - (if tabkey2-show-mark-on-active-line - (progn - (overlay-put tabkey2-overlay 'face - ;;'tabkey2-highlight-line - (tabkey2-get-highlight-face) - ) - (overlay-put tabkey2-overlay 'help-echo - "This highlight shows that Tab completion state is on")) - (overlay-put tabkey2-overlay 'face nil) - (overlay-put tabkey2-overlay 'help-echo nil))) - ;; The keymap overlay - (let ((beg (line-beginning-position)) - (end (line-end-position))) - ;;(when (= end (point-max)) (setq end (1+ end))) - (setq beg (point)) - (setq end (point)) - - (unless tabkey2-keymap-overlay - ;; Make the rear of the overlay advance so that the keymap works - ;; at the end of a line and the end of the buffer. - (setq tabkey2-keymap-overlay (make-overlay 0 0 nil nil t))) - (overlay-put tabkey2-keymap-overlay 'priority 1000) - ;;(overlay-put tabkey2-keymap-overlay 'face 'secondary-selection) - (overlay-put tabkey2-keymap-overlay 'keymap - tabkey2-completion-state-emul-map) - (overlay-put tabkey2-keymap-overlay 'window (selected-window)) - (move-overlay tabkey2-keymap-overlay beg end (current-buffer)))) - -(defun tabkey2-is-active (fun chk) - "Return t FUN is active. -Return t if CHK is a symbol with non-nil value or a form that -evals to non-nil. - -Otherwise return t if FUN has a key binding at point." - (when (and (fboundp fun) - (commandp fun)) - (or (if (symbolp chk) - (when (boundp chk) (symbol-value chk)) - (eval chk)) - (let* ((emulation-mode-map-alists - ;; Remove keymaps from tabkey2 in this copy: - (delq 'tabkey2--emul-keymap-alist - (copy-sequence emulation-mode-map-alists))) - (keys (tabkey2-symbol-keys fun)) - kb-bound) - (dolist (key keys) - (unless (memq (car (append key nil)) - '(menu-bar)) - (setq kb-bound t))) - kb-bound)))) - -(defun tabkey2-is-active-p (fun) - "Return FUN is active. -Look it up in `tabkey2-completion-functions' to find out what to -check and return the value from `tabkey2-is-active'." - (let ((chk (catch 'chk - (dolist (rec tabkey2-completion-functions) - (when (eq fun (nth 1 rec)) - (throw 'chk (nth 2 rec))))))) - (tabkey2-is-active fun chk))) - -(defvar tabkey2-chosen-completion-function nil) -(make-variable-buffer-local 'tabkey2-chosen-completion-function) -(put 'tabkey2-chosen-completion-function 'permanent-local t) - -(defun tabkey2-first-active-from-completion-functions () - "Return first active completion function. -Look in `tabkey2-completion-functions' for the first function -that has an active key binding." - (catch 'active-fun - (dolist (rec tabkey2-completion-functions) - (let ((fun (nth 1 rec)) - (chk (nth 2 rec))) - (when (tabkey2-is-active fun chk) - (throw 'active-fun fun)))))) - -(defun tabkey2-get-default-completion-fun () - "Return the default completion function. -See `tabkey2-first' for the list considered." - (or (when (and tabkey2-chosen-completion-function - (tabkey2-is-active-p - tabkey2-chosen-completion-function)) - tabkey2-chosen-completion-function) - ;;tabkey2-preferred - (tabkey2-first-active-from-completion-functions) - tabkey2-fallback)) - -(defvar tabkey2-overlay-message nil) - -(defvar tabkey2-completion-state-mode nil) -;;(make-variable-buffer-local 'tabkey2-completion-state-mode) -(defun tabkey2-completion-state-mode (arg) - "Tab completion state minor mode. -This pseudo-minor mode holds the 'Tab completion state'. When this -minor mode is on completion key bindings are available. - -With ARG a positive number turn on, otherwise turn off this minor -mode. - -See `tabkey2-first' for more information." - ;;(assq-delete-all 'tabkey2-completion-state-mode minor-mode-alist) - (unless (assoc 'tabkey2-completion-state-mode minor-mode-alist) - ;;(setq minor-mode-alist (cons '(tabkey2-completion-state-mode " Tab2") - (setq minor-mode-alist (cons (list 'tabkey2-completion-state-mode - tabkey2-completion-lighter) - minor-mode-alist))) - (let ((emul-map (cdr (car tabkey2--emul-keymap-alist))) - (old-wincfg tabkey2-completion-state-mode)) - (setq tabkey2-completion-state-mode (when (and (numberp arg) - (> arg 0)) - ;;t - (current-window-configuration) - )) - (if tabkey2-completion-state-mode - (progn - ;; Set default completion function - (tabkey2-make-message-and-set-fun - (tabkey2-get-default-completion-fun)) - ;; Message - ;;(setq tabkey2-message-is-shown nil) - (when tabkey2-show-message-on-enter - (tabkey2-show-current-message - (when (numberp tabkey2-show-message-on-enter) - tabkey2-show-message-on-enter))) - ;; Move overlays - (tabkey2-move-overlays) - ;; Work around eob keymap problem ... - ;;(set-keymap-parent emul-map (overlay-get tabkey2-keymap-overlay - ;; 'keymap)) - ;; Set up for pre/post-command-hook - (add-hook 'pre-command-hook 'tabkey2-completion-state-pre-command) - (add-hook 'post-command-hook 'tabkey2-completion-state-post-command)) - ;;(set-keymap-parent emul-map nil) - (setq tabkey2-current-tab-function nil) - (when (and old-wincfg - tabkey2-keymap-overlay - (eq (overlay-get tabkey2-keymap-overlay 'window) (selected-window)) - (not (active-minibuffer-window))) - (set-window-configuration old-wincfg)) - (let ((inhibit-read-only t)) - (when tabkey2-keymap-overlay - (delete-overlay tabkey2-keymap-overlay)) - (when tabkey2-overlay - (delete-overlay tabkey2-overlay))) - (remove-hook 'pre-command-hook 'tabkey2-completion-state-pre-command) - (remove-hook 'post-command-hook 'tabkey2-completion-state-post-command) - (tabkey2-overlay-message nil) - ;;(message "") - ))) - -(defun tabkey2-completion-state-off () - "Quit Tab completion state." - (interactive) - (tabkey2-completion-state-mode -1) - (let ((C-g-binding (or (key-binding [(control ?g)]) - (key-binding "\C-g"))) - did-more) - (when (and (boundp 'company-mode) - company-mode) - ;;(message "tabkey2:company-abort") - (company-abort) - (setq did-more t)) - (when (and C-g-binding - (not (eq C-g-binding this-command))) - ;;(message "tabkey2:c-g=%s" C-g-binding) - (call-interactively C-g-binding) - (setq did-more t)) - (message "Quit"))) - -(defvar tabkey2-message-is-shown nil) -(defun tabkey2-message-is-shown () - (case tabkey2-message-style - ('popup - (when tabkey2-overlay-message - (overlay-buffer tabkey2-overlay-message))) - ('echo-area - (get (current-message) 'tabkey2)))) - -(defun tabkey2-completion-state-pre-command () - "Run this in `pre-command-hook'. -Check if message is shown. -Remove overlay message. -Cancel delayed message." - ;;(message "=====> tabkey2-completion-state-pre-command") - (condition-case err - (progn - (setq tabkey2-message-is-shown (tabkey2-message-is-shown)) - ;;(message "tabkey2-overlay-message=%s, is-shown=%s" tabkey2-overlay-message tabkey2-message-is-shown) - (tabkey2-overlay-message nil) - (tabkey2-cancel-delayed-message) - ;;(message "here buffer=%s, this-command=%s" (current-buffer) this-command) - ) - (error (message "tabkey2 pre: %s" (error-message-string err))))) - -(defun tabkey2-completion-state-post-command () - "Turn off Tab completion state if not feasable any more. -This is run in `post-command-hook' after each command." - (condition-case err - ;;(save-match-data - ;; Delayed messages - (if (not (tabkey2-completion-state-p)) - (tabkey2-completion-state-mode -1) - ;;(message "tabkey2-current-tab-function=%s" tabkey2-current-tab-function) - (tabkey2-move-overlays)) - ;;) - (error (message "tabkey2 post: %s" (error-message-string err))))) - -(defun tabkey2-minibuffer-setup () - "Activate/deactivate function `tabkey2-mode' in minibuffer." - (set (make-local-variable 'tabkey2-mode) - (and tabkey2-mode - tabkey2-in-minibuffer)) - (unless tabkey2-mode - (set (make-local-variable 'emulation-mode-map-alists) - (delq 'tabkey2--emul-keymap-alist - (copy-sequence emulation-mode-map-alists))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Message functions - -;; Fix-me: Included in Emacs 23. -(unless (fboundp 'invisible-p) - (defun invisible-p (pos) - "Return non-nil if the character after POS is currently invisible." - (let ((prop - (get-char-property pos 'invisible))) - (if (eq buffer-invisibility-spec t) - prop - (if (listp prop) - (catch 'invis - (dolist (p prop) - (when (or (memq p buffer-invisibility-spec) - (assq p buffer-invisibility-spec)) - (throw 'invis t)))) - (or (memq prop buffer-invisibility-spec) - (assq prop buffer-invisibility-spec))))))) - -;; (defun test-scroll () -;; (interactive) -;; (setq debug-on-error t) -;; (let* ((buffer-name "test-scroll") -;; (buffer (get-buffer buffer-name))) -;; (when buffer (kill-buffer buffer)) -;; (setq buffer (get-buffer-create buffer-name)) -;; (switch-to-buffer buffer) -;; (message "here 1") (sit-for 1) -;; (condition-case err -;; (scroll-up 1) -;; (error (message "scroll-up error: %s" err) -;; (sit-for 1))) -;; (message "here 2") (sit-for 1) -;; (scroll-up 1) -;; (message "here 3") (sit-for 1) -;; )) - -(defun tabkey2-overlay-message (txt) - "Display TXT below or above current line using an overlay." - ;;(setq tabkey2-message-is-shown txt) - (if (not txt) - (when tabkey2-overlay-message - (delete-overlay tabkey2-overlay-message) - (setq tabkey2-overlay-message nil)) - (let ((ovl tabkey2-overlay-message) - (column (current-column)) - (txt-len (length txt)) - (here (point)) - beg end - (before "") - (after "") - ovl-str too-much - (is-eob (eobp)) - (direction 1)) - (unless ovl (setq ovl (make-overlay 0 0))) - (when tabkey2-overlay-message - (delete-overlay tabkey2-overlay-message)) - (setq tabkey2-overlay-message ovl) - - (when is-eob - (setq direction -1)) - (when (and (/= (point-min) (window-start)) - (not (pos-visible-in-window-p (min (point-max) (1+ (line-end-position)))))) - ;; Go back inside window to avoid aggressive scrolling: - (forward-line -1) - (scroll-up 1) - (forward-line 1)) - (forward-line direction) - ;; Fix-me: Emacs bug workaround - (if (when (< 1 (point)) - (invisible-p (1- (line-end-position)))) - (progn - (goto-char here) - (tabkey2-echo-area-message txt)) - ;; Fix-me: Does this really do anything now: - (when (invisible-p (point)) - (while (invisible-p (point)) - (forward-line direction))) - (setq beg (line-beginning-position)) - (setq end (line-end-position)) - - (if (or (invisible-p beg) (invisible-p end)) - ;; Give up, do not fight invisibility: - (progn - (tabkey2-overlay-message nil) - (tabkey2-echo-area-message txt)) - - ;; string before - (move-to-column column) - (setq before (buffer-substring beg (point))) - (when (< (current-column) column) - (setq before - (concat before - (make-string (- column (current-column)) ? )))) - (setq too-much (- (+ 1 txt-len (length before)) - (window-width))) - (when (> too-much 0) - (setq before (substring before 0 (- too-much)))) - - (unless (> too-much 0) - (move-to-column (+ txt-len (length before))) - (setq after (buffer-substring (point) end))) - - (setq ovl-str (concat before - (propertize txt 'face 'tabkey2-highlight-popup) - after - )) - - (overlay-put ovl 'after-string ovl-str) - (overlay-put ovl 'display "") - (overlay-put ovl 'window (selected-window)) - (move-overlay ovl beg end (current-buffer))) - - (goto-char here) - )))) - -;; Fix-me: This was not usable IMO. Too much flickering. -;; (defun tabkey2-tooltip (txt) -;; (let* ((params tooltip-frame-parameters) -;; (coord (car (point-to-coord (point)))) -;; (left (car coord)) -;; (top (cadr coord)) -;; tooltip-frame-parameters -;; ) -;; ;; Fix-me: how do you get char height?? -;; (setq top (+ top 50)) -;; (setq params (tooltip-set-param params 'left left)) -;; (setq params (tooltip-set-param params 'top top)) -;; (setq params (tooltip-set-param params 'top top)) -;; (setq tooltip-frame-parameters params) -;; (tooltip-hide) -;; (tooltip-show txt nil))) - -(defun tabkey2-echo-area-message (txt) - "Show TXT in the echo area with a special face. -Shown with the face `tabkey2-highlight-message'." - (message "%s" (propertize txt - 'face 'tabkey2-highlight-message - 'tabkey2 t))) - -(defun tabkey2-deliver-message (txt) - "Show message TXT to user." - (case tabkey2-message-style - (popup (tabkey2-overlay-message txt)) - (t (tabkey2-echo-area-message txt)))) - -(defun tabkey2-timer-deliver-message (txt where) - "Show message TXT to user. -Protect from errors cause this is run during a timer." - (save-match-data ;; runs in timer - (when (and tabkey2-completion-state-mode - (equal (point-marker) where)) - (condition-case err - (tabkey2-deliver-message txt) - (error (message "tabkey2-timer-deliver-message: %s" - (error-message-string err))))))) - -(defvar tabkey2-delayed-timer nil) - -(defun tabkey2-cancel-delayed-message () - "Cancel delayed message." - (when tabkey2-delayed-timer - (cancel-timer tabkey2-delayed-timer) - (setq tabkey2-delayed-timer))) - -(defun tabkey2-maybe-delayed-message (txt delay) - "Show message TXT, delay it if DELAY is non-nil." - (if delay - (setq tabkey2-delayed-timer - (run-with-idle-timer - delay nil - 'tabkey2-timer-deliver-message txt (point-marker))) - (tabkey2-deliver-message txt))) - -(defun tabkey2-message (delay format-string &rest args) - "Show, if DELAY delayed, otherwise immediately message. -FORMAT-STRING and ARGS are like for `message'." - (let ((txt (apply 'format format-string args))) - (tabkey2-maybe-delayed-message txt delay))) - -(defun tabkey2-show-current-message (&optional delay) - "Show current completion message, delayed if DELAY is non-nil." - (tabkey2-cancel-delayed-message) - (tabkey2-message delay "%s" tabkey2-current-tab-info)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Completion function selection etc - -(defun tabkey2-symbol-keys (comp-fun) - "Get a list of all key bindings for COMP-FUN." - (let* ((remapped (command-remapping comp-fun))) - (where-is-internal comp-fun - nil ;;overriding-local-map - nil nil remapped))) - -(defun tabkey2-get-active-completion-functions () - "Get a list of active completion functions. -Consider only those in `tabkey2-completion-functions'." - (delq nil - (mapcar (lambda (rec) - (let ((fun (nth 1 rec)) - (chk (nth 2 rec))) - (when (tabkey2-is-active fun chk) rec))) - tabkey2-completion-functions))) - -(defun tabkey2-make-current-default () - "Make current Tab completion function default. -Set the current Tab completion function at point as default for -the current buffer." - (interactive) - (let ((set-it - (y-or-n-p - (format - "Make %s default for Tab completion in current buffer? " - tabkey2-current-tab-function)))) - (when set-it - (setq tabkey2-chosen-completion-function - tabkey2-current-tab-function)) - (unless set-it - (when (local-variable-p 'tabkey2-chosen-completion-function) - (when (y-or-n-p "Use default Tab completion selection in buffer? ") - (setq set-it t)) - (kill-local-variable 'tabkey2-chosen-completion-function))) - (when (tabkey2-completion-state-p) - (tabkey2-message nil "%s%s" tabkey2-current-tab-info - (if set-it " - Done" ""))))) - -(defun tabkey2-activate-next-completion-function (wrap) - (let* ((active (mapcar (lambda (rec) - (nth 1 rec)) - (tabkey2-get-active-completion-functions))) - (first (car active)) - next) - ;;(message "is-shown=%s current=%s active=%s overlay=%s" tabkey2-message-is-shown tabkey2-current-tab-function active tabkey2-overlay) - (when tabkey2-current-tab-function - (while (and active (not next)) - (when (eq (car active) tabkey2-current-tab-function) - (setq next (cadr active))) - (setq active (cdr active)))) - (unless next - (when wrap (setq next first))) - ;;(if (eq first next) - (tabkey2-make-message-and-set-fun next))) - -(defun tabkey2-cycle-completion-functions (prefix) - "Cycle through cnd display ompletion functions. -If 'Tab completion state' is not on then turn it on. - -If PREFIX is given just show what this command will do." - (interactive "P") - (if (tabkey2-read-only-p) - (message "Buffer is read only at point") - (unless tabkey2-completion-state-mode (tabkey2-completion-state-mode 1)) - (save-match-data - (if prefix - ;; fix-me - (message "(TabKey2) %s: show/cycle completion function" - last-input-event) - (when tabkey2-message-is-shown - ;; Message is shown currently so change - (tabkey2-activate-next-completion-function 'wrap)) - (tabkey2-show-current-message))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Handling of Tab and alternate key - -;;;###autoload -(defun tabkey2-emma-without-tabkey2 () - ;; Remove keymaps from tabkey2 in this copy: - (delq 'tabkey2--emul-keymap-alist - (copy-sequence emulation-mode-map-alists))) - -(defvar tabkey2-step-out-of-the-way nil) -;;(remove-hook 'pre-command-hook 'tabkey2-pre-command) -;;(remove-hook 'post-command-hook 'tabkey2-pre-command) -;;(remove-hook 'post-command-hook 'tabkey2-post-command-2) -(defun tabkey2-post-command () - (setq tabkey2-step-out-of-the-way nil) - (condition-case err - (when tabkey2-mode - (when (and (boundp 'company-overriding-keymap-bound) company-overriding-keymap-bound) - (setq tabkey2-step-out-of-the-way - (let ((emulation-mode-map-alists (tabkey2-emma-without-tabkey2))) - (key-binding (this-command-keys)))) - ;;(message "tabkey2-step-out=%s, %s" (this-command-keys) tabkey2-step-out-of-the-way) - )) - (error "tabkey2-pre-command: %s" err))) - ;; (and (boundp 'company-preview-overlay) - ;; (or company-preview-overlay - ;; company-pseudo-tooltip-overlay))) -(defun tabkey2-first (prefix) - "Do something else after first Tab. -This function is bound to the Tab key \(or whatever key -`tabkey2-first-key' is) when minor mode command `tabkey2-mode' is -on. It works like this: - -1. The first time Tab is pressed do whatever Tab would have done - if minor mode command `tabkey2-mode' was off. - - Then before next command enter a new temporary 'Tab completion - state' for just the next command. Show this by a highlight on - the indentation and a marker \"Tab2\" in the mode line. - - However if either - - the minibuffer is active and `tabkey2-in-minibuffer' is nil - - `major-mode' is in `tabkey2-modes-that-use-more-tabs' then - do not enter this temporary 'Tab completion state'. - - For major modes where it make sense to press Tab several times - you can use `tabkey2-alternate-key' to enter 'Tab completion - state'. - - -2. As long as point is not move do completion when Tab is pressed - again. Show that this state is active with a highlighting at - the line beginning, a marker on the mode line (Tab2) and a - message in the echo area which tells what kind of completion - will be done. - - When deciding what kind of completion to do look in the table - below and do whatever it found first that is not nil: - - - `tabkey2-preferred' - - `tabkey2-completion-functions' - - `tabkey2-fallback' - -3. Of course, there must be some way for you to easily determine - what kind of completion because there are many in Emacs. If - you do not turn it off this function will show that to you. - And if you turn it off you can still display it, see the key - bindings below. - - If this function is used with a PREFIX argument then it just - shows what Tab will do. - - If the default kind of completion is not what you want then - you can choose completion function from any of the candidates - in `tabkey2-completion-functions'. During the 'Tab completion - state' the following extra key bindings are available: - -\\{tabkey2-completion-state-emul-map} - -Of course, some languages does not have a fixed indent as is -assumed above. You can put major modes for those in -`tabkey2-modes-that-just-complete'. - -Some major modes uses tab for something else already. Those are -in `tabkey2-modes-that-use-more-tabs'. There is an alternate -key, `tabkey2-alternate-key' if you want to do completion -there. Note that this key does not do completion. It however -enters 'Tab completion state' in which you have access to the -keys above for completion etc. \(This key also lets you cycle -through the completion functions too choose which one to use.) - ------ -NOTE: This uses `emulation-mode-map-alists' and it supposes that -nothing else is bound to Tab there." - (interactive "P") - ;;(message "first:tabkey2-step-out=%s, %s" (this-command-keys) tabkey2-step-out-of-the-way) - (if tabkey2-step-out-of-the-way - (progn - (message "step-out=%s" tabkey2-step-out-of-the-way) - (call-interactively tabkey2-step-out-of-the-way)) - (if (and tabkey2-keymap-overlay - (eq (overlay-buffer tabkey2-keymap-overlay) (current-buffer)) - (eq (overlay-get tabkey2-keymap-overlay 'window) (selected-window)) - (>= (point) (overlay-start tabkey2-keymap-overlay)) - (<= (point) (overlay-end tabkey2-keymap-overlay))) - ;; We should maybe not be here, but the keymap does not work at - ;; the end of the buffer so we call the second tab function from - ;; here: - (if (memq 'shift (event-modifiers last-input-event)) - (call-interactively 'tabkey2-cycle-completion-functions) - (call-interactively 'tabkey2-complete prefix)) - (let* ((emma-without-tabkey2 (tabkey2-emma-without-tabkey2)) - (at-word-end (looking-at "\\_>")) - (just-complete (or (memq major-mode tabkey2-modes-that-just-complete) - at-word-end)) - (what (if just-complete - 'complete - (if (or (unless tabkey2-in-minibuffer - (active-minibuffer-window)) - (when (fboundp 'use-region-p) (use-region-p)) - (not at-word-end) - (memq major-mode tabkey2-modes-that-use-more-tabs)) - 'indent - 'indent-complete - ))) - (to-do-1 (unless (or - ;; Skip action on tab if shift tab, - ;; backtab or a mode in the "just - ;; complete" list - (memq 'shift (event-modifiers last-input-event)) - (equal [backtab] (this-command-keys-vector)) - ) - (let ((emulation-mode-map-alists emma-without-tabkey2)) - ;; Fix-me: Is this the way to pick up "tab keys"? - (or (key-binding [tab] t) - (key-binding [?\t] t)) - ))) - (to-do-2 (unless (or ;;(memq what '(complete)) - (memq what '(indent)) - (memq to-do-1 '(widget-forward button-forward))) - (tabkey2-get-default-completion-fun)))) - ;;(message "step-out-of-the-way=%s to-do=%s/%s, emmaa-without-tabkey2=%s" step-out-of-the-way to-do-1 to-do-2 emma-without-tabkey2) - (if prefix - (if (memq 'shift (event-modifiers last-input-event)) - (message - "(TabKey2) First shift %s: turn on 'Tab completion state'" - last-input-event) - (message "(TabKey2) First %s: %s, next: maybe %s" - last-input-event to-do-1 - (if to-do-2 to-do-2 "(same)"))) - (when to-do-1 - (let (xmumamo-multi-major-mode) - (tabkey2-call-interactively to-do-1))) - (unless (tabkey2-read-only-p) - (when to-do-2 - (tabkey2-completion-state-mode 1)))))))) - -(defun tabkey2-call-interactively (function) - "Like `call-interactively, but handle `this-command'." - (setq this-command function) - (call-interactively function)) - -(defcustom tabkey2-choose-next-on-error t - "Choose next completion function on error." - :type 'boolean - :group 'tabkey2) - -(defun tabkey2-complete (prefix) - "Call current completion function. -If used with a PREFIX argument then just show what Tab will do." - (interactive "P") - (if (and (boundp 'mumamo-multi-major-mode) - mumamo-multi-major-mode - (not (mumamo-syntax-maybe-completable (point)))) - (message "Please move out of chunk border before trying to complete.") - (if prefix - (message "(TabKey2) %s: %s" - last-input-event tabkey2-current-tab-function) - (let ((here (point)) - (res (if tabkey2-choose-next-on-error - (condition-case err - (tabkey2-call-interactively tabkey2-current-tab-function) - (error (message "%s" (error-message-string err)) - nil)) - (tabkey2-call-interactively tabkey2-current-tab-function)))) - (when (and (not res) (= here (point))) - (tabkey2-activate-next-completion-function nil) - ;;(message "complete.tabkey2-current-tab-function=%s" tabkey2-current-tab-function) - (if tabkey2-current-tab-function - (tabkey2-show-current-message) - (message "No more active completion functions in this buffer"))))))) - -;; Fix-me: I am not sure that it really is useful with a globalized -;; minor mode here because there are so many other ways to control -;; what happens in a specific buffer. Maybe it would just be -;; confusing? -;; -;; If found another problem with making it globalized: tabkey2-mode -;; uses emulation-mode-map-alist. I decided to remove this therefore. -;; -;; (defun tabkey2-turn-on () -;; "Turn on `tabkey2-mode' in current buffer." -;; (tabkey2-mode 1)) - -;; (defvar tabkey2-turn-on-function 'tabkey2-turn-on -;; "Function used to mabye turn on `tabkey2-mode' in current-buffer. -;; This function is used by `tabkey2-global-mode' to turn on -;; `tabkey2-mode'.") - -;; (defun tabkey2-turn-on-in-buffer () -;; (funcall tabkey2-turn-on-function)) - -;; (define-globalized-minor-mode tabkey2-global-mode -;; tabkey2-mode tabkey2-turn-on-in-buffer) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Help functions - -(defun tabkey2-show-completion-state-help () - "Help for 'Tab completion state'. -To get out of this state you can move out of the current line. - -During this state the keymap below is active. This state stops -as soon as you leave the current row. - -\\{tabkey2-completion-state-emul-map} -See function `tabkey2-mode' for more information. - -If you want to use Emacs normal help function then press F1 -again.") - -(defun tabkey2-completion-state-help () - "Show help for 'Tab completion state'." - (interactive) - ;;(message "tckv=%s" (this-command-keys-vector)) ;;(sit-for 1) - ;; Fix-me: There seems to be an Emacs bug lurking here. Sometimes - ;; invoked-by-f1 is not [f1]. - (let ((invoked-by-f1 (equal (this-command-keys-vector) [f1])) - normal-help) - ;;(message "invoked-by-f1=%s" invoked-by-f1) ;; fix-me - (if (not invoked-by-f1) - (describe-function 'tabkey2-show-completion-state-help) - (setq normal-help - (read-event - (propertize - (concat "Type a key for Emacs help." - " Or, wait for Tab completion state help: ") - 'face 'highlight) - nil - 4)) - (case normal-help - ((nil) - ;;(message "Tab completion state help") - (describe-function 'tabkey2-show-completion-state-help)) - (?c - (call-interactively 'describe-key-briefly)) - (?k - (call-interactively 'describe-key)) - (t - (tabkey2-completion-state-mode -1) - (setq unread-command-events - (reverse - (cons - normal-help - (append (this-command-keys) nil))))))))) - -(defun tabkey2-completion-function-help () - "Show help for current completion function." - (interactive) - (describe-function tabkey2-current-tab-function)) - - - - -(defun tabkey2-get-key-binding (fun t2) - "Get key binding for FUN during 'Tab completion state'." - (let* ((remapped (command-remapping fun)) - (key (where-is-internal fun - (when t2 tabkey2-completion-state-emul-map) - t - nil - remapped))) - key)) - -;; (defun tabkey2-reset-completion-function (comp-fun) -;; "Reset states for functions in `tabkey2-completion-functions'." -;; ;; Fix-me: remove hard-coding -;; (setq dabbrev--last-abbrev-location nil)) - -(defun tabkey2-make-message-and-set-fun (comp-fun) - "Set current completion function to COMP-FUN. -Build message but don't show it." - ;;(tabkey2-reset-completion-functions) - (let* ((chs-fun 'tabkey2-cycle-completion-functions) - (key (tabkey2-get-key-binding chs-fun t)) - ;;(def-fun (tabkey2-get-default-completion-fun)) - what - (comp-fun-key (tabkey2-get-key-binding comp-fun nil)) - reset) - (setq tabkey2-current-tab-function comp-fun) - (dolist (rec tabkey2-completion-functions) - (let ((fun (nth 1 rec)) - (txt (nth 0 rec)) - (res (nth 3 rec))) - (when (eq fun comp-fun) - (eval res) - (setq what txt)))) - (let ((info (concat (format "Tab: %s" what) - (if comp-fun-key - (format " (%s)" (key-description comp-fun-key)) - "") - (if (cdr (tabkey2-get-active-completion-functions)) - (format ", other %s, help F1" - (key-description key)) - "")))) - (setq tabkey2-current-tab-info info)))) - -(defun tabkey2-get-active-string (bnd fun buf) - "Get string to show for state. -BND: means active -FUN: function -BUF: buffer" - (if bnd - (if (with-current-buffer buf (tabkey2-read-only-p)) - (propertize "active, but read-only" 'face '( :foreground "red")) - (propertize "active" 'face '( :foreground "green3"))) - (if (and (fboundp fun) - (commandp fun)) - (propertize "not active" 'face '( :foreground "red2")) - (propertize "not defined" 'face '( :foreground "gray"))))) - -(defun tabkey2-show-completion-functions () - "Show what currently may be used for completion." - (interactive) - (let ((orig-buf (current-buffer)) - (orig-mn mode-name) - (active-mark (concat " " - (propertize "<= default" - 'face '( :background "yellow")))) - (act-found nil) - (chosen-fun tabkey2-chosen-completion-function) - what - chosen) - (when chosen-fun - (dolist (rec tabkey2-completion-functions) - (let ((fun (nth 1 rec)) - (txt (nth 0 rec))) - (when (eq fun chosen-fun) (setq what txt)))) - (setq chosen (list what chosen-fun))) - (with-output-to-temp-buffer (help-buffer) - (help-setup-xref (list #'tabkey2-show-completion-functions) - (interactive-p)) - (with-current-buffer (help-buffer) - (insert (concat "The completion functions available for" - " 'Tab completion' in buffer\n'" - (buffer-name orig-buf) - "' at point with mode " orig-mn " are shown below.\n" - "The first active function is used by default.\n\n")) - (if (not chosen) - (insert " No completion function is set as default.") - (let* ((txt (nth 0 chosen)) - (fun (nth 1 chosen)) - (chk (nth 2 chosen)) - (bnd (with-current-buffer orig-buf - (tabkey2-is-active fun chk))) - (act (tabkey2-get-active-string bnd fun orig-buf))) - (insert (format " Default is set to\n %s (%s): %s" - txt fun act)) - (when bnd (insert active-mark) (setq act-found t)))) - (insert "\n\n") -;;; (if (not tabkey2-preferred) -;;; (insert " None is preferred") -;;; (let* ((txt (nth 0 tabkey2-preferred)) -;;; (fun (nth 1 tabkey2-preferred)) -;;; (chk (nth 2 chosen)) -;;; (bnd (with-current-buffer orig-buf -;;; (tabkey2-is-active fun chk))) -;;; (act (tabkey2-get-active-string bnd fun orig-buf))) -;;; (insert (format " Preferred is %s (`%s')': %s" -;;; txt fun act)) -;;; (when bnd (insert active-mark) (setq act-found t)))) -;;; (insert "\n\n") - (dolist (comp-fun tabkey2-completion-functions) - (let* ((txt (nth 0 comp-fun)) - (fun (nth 1 comp-fun)) - (chk (nth 2 comp-fun)) - (bnd (with-current-buffer orig-buf - (tabkey2-is-active fun chk))) - (act (tabkey2-get-active-string bnd fun orig-buf)) - (keys (where-is-internal fun))) - (if (not keys) - (setq keys "") - (setq keys (mapconcat 'key-description keys ", ")) - (when (and (< 9 (length keys)) - (string= "<menu-bar>" (substring keys 0 10))) - (setq keys "Menu")) - (setq keys (propertize keys 'face 'highlight)) - (setq keys (concat ", " keys)) - ) - (insert - (format - " %s (`%s'%s): %s" - txt fun keys act)) - (when (and (not act-found) bnd) - (insert active-mark) (setq act-found t)) - (insert "\n"))) - (insert "\n") - (if (not tabkey2-fallback) - (insert " There is no fallback") - (let* ((txt (nth 0 tabkey2-fallback)) - (fun (nth 1 tabkey2-fallback)) - (chk (nth 2 tabkey2-fallback)) - (bnd (with-current-buffer orig-buf - (tabkey2-is-active fun chk))) - (act (tabkey2-get-active-string bnd fun orig-buf))) - (insert (format " Fallback is %s (`%s'): %s" - txt fun act)) - (when (and (not act-found) bnd) - (insert active-mark) - (setq act-found t)))) - (insert "\n\nYou an ") - (insert-text-button "customize this list" - 'action (lambda (button) - (customize-option - 'tabkey2-completion-functions))) - (insert ".\nSee function `tabkey2-mode' for more information.") - (with-no-warnings (print-help-return-message)))))) - -(defvar tabkey2-completing-read 'completing-read) - -(defun tabkey2-set-fun (fun) - "Use function FUN for Tab in 'Tab completion state'." - (setq tabkey2-chosen-completion-function fun) - (unless fun - (setq fun (tabkey2-first-active-from-completion-functions))) - (tabkey2-make-message-and-set-fun fun) - (when (tabkey2-completion-state-p) - (message "%s" tabkey2-current-tab-info))) - -(defun tabkey2-appmenu () - "Make a menu for minor mode command `appmenu-mode'." - (unless (tabkey2-read-only-p) - (let* ((cf-r (reverse (tabkey2-get-active-completion-functions))) - (tit "Complete") - (map (make-sparse-keymap tit))) - (define-key map [tabkey2-usage] - (list 'menu-item "Show Available Completion Functions for TabKey2" - 'tabkey2-show-completion-functions)) - (define-key map [tabkey2-divider-1] (list 'menu-item "--")) - (let ((set-map (make-sparse-keymap "Set Completion"))) - (define-key map [tabkey2-choose] - (list 'menu-item "Set Primary TabKey2 Tab Completion in Buffer" set-map)) - (dolist (cf-rec cf-r) - (let ((dsc (nth 0 cf-rec)) - (fun (nth 1 cf-rec))) - (define-key set-map - (vector (intern (format "tabkey2-set-%s" fun))) - (list 'menu-item dsc - `(lambda () - (interactive) - (tabkey2-set-fun ',fun)) - :button - `(:radio - . (eq ',fun tabkey2-chosen-completion-function)))))) - (define-key set-map [tabkey2-set-div] (list 'menu-item "--")) - (define-key set-map [tabkey2-set-default] - (list 'menu-item "Default Tab completion" - (lambda () - (interactive) - (tabkey2-set-fun nil)) - :button - '(:radio . (null tabkey2-chosen-completion-function)))) - (define-key set-map [tabkey2-set-header-div] (list 'menu-item "--")) - (define-key set-map [tabkey2-set-header] - (list 'menu-item "Set Primary Tab Completion for Buffer")) - ) - (define-key map [tabkey2-divider] (list 'menu-item "--")) - (dolist (cf-rec cf-r) - (let ((dsc (nth 0 cf-rec)) - (fun (nth 1 cf-rec))) - (define-key map - (vector (intern (format "tabkey2-call-%s" fun))) - (list 'menu-item dsc fun - :button - `(:toggle - . (eq ',fun tabkey2-chosen-completion-function)) - )))) - map))) - -;; (defun tabkey2-completion-menu-popup () -;; "Pop up a menu with completion alternatives." -;; (interactive) -;; (let ((menu (tabkey2-appmenu))) -;; (popup-menu-at-point menu))) - -;; (defun tabkey2-choose-completion-function () -;; "Set current completion function. -;; Let user choose completion function from those in -;; `tabkey2-completion-functions' that have some key binding at -;; point. - -;; Let the chosen completion function be the default for subsequent -;; completions in the current buffer." -;; ;; Fix-me: adjust to mumamo. -;; (interactive) -;; (save-match-data -;; (if (and (featurep 'popcmp) -;; tabkey2-use-popup-menus) -;; (tabkey2-completion-menu-popup) -;; (when (eq 'completing-read tabkey2-completing-read) (isearch-unread 'tab)) -;; (let* ((cf-r (reverse (tabkey2-get-active-completion-functions))) -;; (cf (cons '("- Use default Tab completion" nil) cf-r)) -;; (hist (mapcar (lambda (rec) -;; (car rec)) -;; cf)) -;; (tit (funcall tabkey2-completing-read "Set current completion function: " cf -;; nil ;; predicate -;; t ;; require-match -;; nil ;; initial-input -;; 'hist ;; hist -;; )) -;; (fun-rec (assoc-string tit cf)) -;; (fun (cadr fun-rec))) -;; (setq tabkey2-chosen-completion-function fun) -;; (unless fun -;; (setq fun (tabkey2-first-active-from-completion-functions))) -;; (tabkey2-make-message-and-set-fun fun) -;; (when (tabkey2-completion-state-p) -;; (tabkey2-show-current-message)))))) - -;; (defun tabkey2-add-to-appmenu () -;; "Add a menu to function `appmenu-mode'." -;; (appmenu-add 'tabkey2 nil t "Completion" 'tabkey2-appmenu)) - - -(provide 'tabkey2) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; tabkey2.el ends here diff --git a/emacs.d/nxhtml/util/tyda.el b/emacs.d/nxhtml/util/tyda.el deleted file mode 100644 index d4f3ea6..0000000 --- a/emacs.d/nxhtml/util/tyda.el +++ /dev/null @@ -1,94 +0,0 @@ -;;; tyda.el --- Lookup words in swe/eng dictionary at tyda.se -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-08-26T02:51:27+0200 Tue -;; Version: 0.2 -;; Last-Updated: -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Lookup swedish or english words in the dictionary at -;; -;; http://www.tyda.se/ -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'appmenu)) - -(defun tyda-lookup-word (word) - "Look up word WORD at URL `http://tyda.se/'. -This site translates between English and Swedish. The site will -be opened in your webbrowser with WORD looked up." - (interactive (list (or (thing-at-point 'word) - (read-string "Lookup word: ")))) - ;; http://tyda.se/search?form=1&w=weird&w_lang=&x=0&y=0 - (browse-url - ;;(concat "http://www.tyda.se/?rid=651940&w=" word) - (format "http://tyda.se/search?form=1&w=%s&w_lang=&x=0&y=0" word) - )) - -(defvar tyda-appmenu-map - (let ((map (make-sparse-keymap))) - (define-key map [tyda-lookup] - (list 'menu-item "Lookup word at point in Tyda" - 'tyda-lookup-word)) - map)) - -(defvar tyda-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(alt mouse-1)] 'tyda-lookup-word) - (define-key map [(control ?c) ?=] 'tyda-lookup-word) - map)) - -;;;###autoload -(define-minor-mode tyda-mode - "Minor mode for key bindings for `tyda-lookup-word'. -It binds Alt-Mouse-1 just as the Tyda add-on does in Firefox. -Here are all key bindings - -\\{tyda-mode-map} -" - :global t - (if tyda-mode - (progn - (require 'appmenu nil t) - (when (featurep 'appmenu) - (appmenu-add 'tyda nil tyda-mode "Lookup word" tyda-appmenu-map))))) - - -(provide 'tyda) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; tyda.el ends here diff --git a/emacs.d/nxhtml/util/udev-ecb.el b/emacs.d/nxhtml/util/udev-ecb.el deleted file mode 100644 index be3b35f..0000000 --- a/emacs.d/nxhtml/util/udev-ecb.el +++ /dev/null @@ -1,229 +0,0 @@ -;;; udev-ecb.el --- Get ECB sources and set it up -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-08-25T04:02:37+0200 Mon -(defconst udev-ecb:version "0.2");; Version: -;; Last-Updated: -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - - -(eval-when-compile (require 'udev nil t)) - -(defgroup udev-ecb nil - "Customization group for udev-ecb." - :group 'nxhtml) - -(defcustom udev-ecb-dir "~/.emacs.d/udev/ecb-cvs/" - "Directory where to put CVS ECB sources." - :type 'directory - :group 'udev-ecb) - -(defun udev-ecb-cvs-dir () - "Return cvs root directory." - (file-name-as-directory (expand-file-name "ecb" udev-ecb-dir))) - -(defvar udev-ecb-miss-cedet nil) - -(defun udev-ecb-load-ecb () - "Load fetched ECB." - (setq udev-ecb-miss-cedet nil) - (unless (featurep 'ecb) - (add-to-list 'load-path (udev-ecb-cvs-dir)) - (let ((msg nil)) - (unless (or msg (featurep 'cedet)) (setq msg "CEDET is not loaded")) - (unless (or msg (locate-library "semantic")) (setq msg "can't find CEDET Semantic")) - (unless (or msg (locate-library "eieio")) (setq msg "can't find CEDET eieio")) - (if msg - (progn - (setq udev-ecb-miss-cedet (format "Can't load ECB because %s." msg)) - (ourcomments-warning udev-ecb-miss-cedet)) - (require 'ecb nil t))))) - -(defcustom udev-ecb-load-ecb nil - "To load or not to load ECB..." - :type 'boolean - :require 'udev-ecb - :set (lambda (sym val) - (set-default sym val) - (when val - (udev-ecb-load-ecb))) - ;; ecb-activate, ecb-customize-most-important to menu - :set-after '(udev-cedet-load-cedet) - :group 'udev-ecb) - -(defvar udev-ecb-steps - '(udev-ecb-fetch - udev-ecb-fix-bad-files - udev-ecb-fetch-diff - udev-ecb-check-diff - udev-ecb-install - )) - -(defun udev-ecb-buffer-name (mode) - "Return a name for current compilation buffer ignoring MODE." - (udev-buffer-name "*Updating ECB %s*" udev-ecb-update-buffer mode)) - -(defvar udev-ecb-update-buffer nil) - -(defun udev-ecb-has-cedet () - (cond - ((not (and (locate-library "semantic") - (locate-library "eieio"))) - (message (propertize "CEDET must be installed and loaded first" - 'face 'secondary-selection)) - nil) - ((not (featurep 'cedet)) - (message (propertize "CEDET must be loaded first" - 'face 'secondary-selection)) - nil) - (t t))) - -(defun udev-ecb-setup-when-finished (log-buffer) - (require 'cus-edit) - (let ((inhibit-read-only t)) - (with-current-buffer log-buffer - (widen) - (goto-char (point-max)) - (insert "\n\nYou must restart Emacs to load ECB properly.\n") - (let ((load-ecb-saved-value (get 'udev-ecb-load-ecb 'saved-value)) - (here (point)) - ) - (if load-ecb-saved-value - (insert "You have setup to load ECB the next time you start Emacs.\n\n") - (insert (propertize "Warning:" 'face 'compilation-warning) - " You have not setup to load ECB the next time you start Emacs.\n\n")) - (insert-button " Setup " - 'face 'custom-button - 'action (lambda (btn) - (interactive) - (customize-group-other-window 'udev-ecb))) - (insert " Setup to load ECB from fetched sources when starting Emacs."))))) - -;;;###autoload -(defun udev-ecb-update () - "Fetch and install ECB from the devel sources. -To determine where to store the sources see `udev-ecb-dir'. -For how to start ECB see `udev-ecb-load-ecb'." - (interactive) - (when (udev-ecb-has-cedet) - (let* ((has-it (file-exists-p (udev-ecb-cvs-dir))) - (prompt (if has-it - "Do you want to update ECB from devel sources? " - "Do you want to install ECB from devel sources? "))) - (when (y-or-n-p prompt) - (setq udev-ecb-update-buffer (get-buffer-create "*Update ECB*")) - (udev-call-first-step udev-ecb-update-buffer udev-ecb-steps - "Starting updating ECB from development sources" - 'udev-ecb-setup-when-finished))))) - -;;;###autoload -(defun udev-ecb-customize-startup () - "Customize ECB dev nXhtml startup group." - (interactive) - (if (file-exists-p (udev-ecb-cvs-dir)) - (customize-group-other-window 'udev-ecb) - (message (propertize "You must fetch ECB from nXhtml first" - 'face 'secondary-selection)))) - -(defun udev-ecb-fetch (log-buffer) - "Fetch ECB sources (asynchronously)." - (let ((default-directory (file-name-as-directory udev-ecb-dir))) - (unless (file-directory-p default-directory) - (make-directory default-directory)) - (with-current-buffer - (compilation-start - "cvs -z3 -d:pserver:anonymous@ecb.cvs.sourceforge.net:/cvsroot/ecb co -P ecb" - 'compilation-mode - 'udev-ecb-buffer-name) - (current-buffer)))) - -;;(udev-ecb-fix-bad-files nil) -(defun udev-ecb-fix-bad-files (log-buffer) - "Change files that can not be compiled." - (let* ((bad-file (expand-file-name "ecb/ecb-advice-test.el" udev-ecb-dir)) - (bad-file-buffer (find-buffer-visiting bad-file)) - (this-log-buf (get-buffer-create "*Fix bad ECB files*")) - (fixed-it nil)) - (when (file-exists-p bad-file) - (with-current-buffer (find-file-noselect bad-file) - (save-restriction - (widen) - (goto-char (point-min)) - (save-match-data - (while (re-search-forward "\r" nil t) - (setq fixed-it t) - (replace-match "")))) - (basic-save-buffer) - (with-current-buffer this-log-buf - (erase-buffer) - (if fixed-it - (insert "Fixed " bad-file "\n") - (insert "The file " bad-file " was already ok\n"))) - (unless bad-file-buffer (kill-buffer (current-buffer))))) - this-log-buf)) - -(defun udev-ecb-fetch-diff (log-buffer) - "Fetch diff between local ECB sources and repository." - (udev-fetch-cvs-diff (udev-ecb-cvs-dir) 'udev-ecb-buffer-name)) - -(defun udev-ecb-check-diff (log-buffer) - "Check cvs diff output for merge conflicts." - (udev-check-cvs-diff (expand-file-name "your-patches.diff" - (udev-ecb-cvs-dir)) - udev-ecb-update-buffer)) - -(defun udev-ecb-install (log-buffer) - "Install the ECB sources just fetched. -Note that they will not be installed in current Emacs session." - (udev-batch-compile "-l ecb-batch-compile.el" - udev-this-dir - 'udev-ecb-buffer-name)) - -;;(udev-ecb-install-help (get-buffer-create "*temp online-help*")) -(defun udev-ecb-install-help (log-buffer) - (let ((trc-buf (get-buffer-create "*temp online-help*"))) - (with-current-buffer trc-buf - (setq default-directory (udev-ecb-cvs-dir)) - (w32shell-with-shell "msys" (shell-command "make online-help&" trc-buf))))) - -(provide 'udev-ecb) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; udev-ecb.el ends here diff --git a/emacs.d/nxhtml/util/udev-rinari.el b/emacs.d/nxhtml/util/udev-rinari.el deleted file mode 100644 index ed70c6c..0000000 --- a/emacs.d/nxhtml/util/udev-rinari.el +++ /dev/null @@ -1,204 +0,0 @@ -;;; udev-rinari.el --- Get rinary sources and set it up -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-08-24T22:32:21+0200 Sun -(defconst udev-rinari:version "0.2");; Version: -;; Last-Updated: -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'udev nil t)) - -(defgroup udev-rinari nil - "Customization group for udev-rinari." - :group 'nxhtml) - -(defcustom udev-rinari-dir "~/rinari-svn/" - "Directory where to put SVN Rinari sources." - :type 'directory - :group 'udev-rinari) - -(defcustom udev-rinari-load-rinari nil - "To load or not to load Rinari..." - :type '(choice (const :tag "Don't load Rinari" nil) - (const :tag "Load Rinari" t)) - :set (lambda (sym val) - (set-default sym val) - (when val - (let* ((base-dir (expand-file-name "svn/trunk/" udev-rinari-dir)) - (rhtml-dir (expand-file-name "rhtml/" base-dir)) - (test-dir (expand-file-name "test/lisp/" base-dir))) - (unless (file-directory-p base-dir) (message "Can't find %s" base-dir)) - (unless (file-directory-p rhtml-dir) (message "Can't find %s" rhtml-dir)) - (unless (file-directory-p test-dir) (message "Can't find %s" test-dir)) - (add-to-list 'load-path base-dir) - (add-to-list 'load-path rhtml-dir) - (add-to-list 'load-path test-dir)) - (require 'rinari) - (require 'ruby-mode))) - :group 'udev-rinari) - -(defvar udev-rinari-steps - '(udev-rinari-fetch - udev-rinari-fetch-diff - udev-rinari-check-diff - ;;udev-rinari-install - )) - -(defvar udev-rinari-update-buffer nil) - -(defun udev-rinari-buffer-name (mode) - "Return a name for current compilation buffer ignoring MODE." - (udev-buffer-name "*Updating Rinari %s*" udev-rinari-update-buffer mode)) - -(defun udev-rinari-check-conflicts () - "Check if Rinari and ruby-mode already loaded and from where. -Give an error if they are loaded from somewhere else than -`udev-rinari-dir' tree." - (when (featurep 'rinari) - (let ((old-dir (file-name-directory (car (load-history-filename-element (load-history-regexp "rinari"))))) - (new-dir (expand-file-name "svn/trunk/" udev-rinari-dir))) - (unless (string= (file-truename old-dir) - (file-truename new-dir)) - (error "Rinari is already loaded from: %s" old-dir)))) - (when (featurep 'ruby-mode) - (let ((old-dir (file-name-directory (car (load-history-filename-element (load-history-regexp "ruby-mode"))))) - (new-dir (expand-file-name "svn/trunk/test/lisp/" udev-rinari-dir))) - (unless (string= (file-truename old-dir) - (file-truename new-dir)) - (error "Ruby-mode is already loaded from: %s" old-dir)))) - ) - -(defun udev-rinari-setup-when-finished (log-buffer) - (let ((inhibit-read-only t)) - (with-current-buffer log-buffer - (widen) - (goto-char (point-max)) - (insert "\n\nYou must restart Emacs to load Rinari properly.\n") - (let ((load-rinari-saved-value (get 'udev-rinari-load-rinari 'saved-value)) - (here (point)) - ) - (if load-rinari-saved-value - (insert "You have setup to load Rinari the next time you start Emacs.\n\n") - (insert (propertize "Warning:" 'face 'compilation-warning) - " You have not setup to load Rinari the next time you start Emacs.\n\n")) - (insert-button " Setup " - 'face 'custom-button - 'action (lambda (btn) - (interactive) - (customize-group-other-window 'udev-rinari))) - (insert " Setup to load Rinari from fetched sources when starting Emacs."))))) - -;;;###autoload -(defun udev-rinari-update () - "Fetch and install Rinari from the devel sources. -To determine where to store the sources and how to start rinari -see `udev-rinari-dir' and `udev-rinari-load-rinari'." - (interactive) - (udev-rinari-check-conflicts) - (setq udev-rinari-update-buffer (get-buffer-create "*Update Rinari*")) - (udev-call-first-step udev-rinari-update-buffer udev-rinari-steps - "Starting updating Rinari from development sources" - 'udev-rinari-setup-when-finished)) - -(defvar udev-rinari-fetch-buffer nil) - -(defun udev-rinari-fetch (log-buffer) - "Fetch Rinari from development sources." - (let* ((default-directory (file-name-as-directory udev-rinari-dir)) ;; fix-me: for emacs bug - ) - (unless (file-directory-p default-directory) - (make-directory default-directory)) - (with-current-buffer - (compilation-start - "svn checkout http://rinari.rubyforge.org/svn/" - 'compilation-mode - 'udev-rinari-buffer-name) - (setq udev-rinari-fetch-buffer (current-buffer))))) - -(defvar udev-rinari-diff-file nil) -(defvar udev-rinari-fetch-diff-buffer nil) - -(defun udev-rinari-fetch-diff (log-buffer) - "Fetch diff between local Rinari sources and dev repository." - (let ((must-fetch-diff t)) - (setq udev-rinari-fetch-diff-buffer - (when must-fetch-diff - (let* ((default-directory (file-name-as-directory - (expand-file-name "svn" - udev-rinari-dir)))) - (setq udev-rinari-diff-file (expand-file-name "../patches.diff")) - (with-current-buffer - (compilation-start - (concat "svn diff > " (shell-quote-argument udev-rinari-diff-file)) - 'compilation-mode - 'udev-rinari-buffer-name) - (setq udev-continue-on-error-function 'udev-cvs-diff-continue) - (current-buffer))))))) - -(defun udev-rinari-check-diff (log-buffer) - "Check output from svn diff command for merge conflicts." - ;; Fix-me: How can this be checked? - (when udev-rinari-fetch-diff-buffer - (let ((buf (find-buffer-visiting udev-rinari-diff-file))) - (if buf - (with-current-buffer buf (revert-buffer nil t)) - (setq buf (find-file-noselect udev-rinari-diff-file))) - (with-current-buffer buf - (widen) - (goto-char (point-min)) - (if (search-forward "<<<<<<<" nil t) - ;; Merge conflict - (udev-call-next-step udev-rinari-update-buffer 1 nil) - buf))))) - -;; (defun udev-rinari-install () -;; "Install Rinari and ruby-mode for use." -;; (if udev-rinari-load-rinari -;; (message "Rinari should be loaded now") -;; (when (y-or-n-p -;; "You need to set udev-rinari-load-rinari. Do that now? ") -;; (customize-group-other-window 'udev-rinari))) -;; nil) - - -(provide 'udev-rinari) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; udev-rinari.el ends here diff --git a/emacs.d/nxhtml/util/udev.el b/emacs.d/nxhtml/util/udev.el deleted file mode 100644 index ee9d86a..0000000 --- a/emacs.d/nxhtml/util/udev.el +++ /dev/null @@ -1,456 +0,0 @@ -;;; udev.el --- Helper functions for updating from dev sources -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-08-24 -(defconst udev:version "0.5");; Version: -;; Last-Updated: 2009-01-06 Tue -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; - ;; `cus-edit', `cus-face', `cus-load', `cus-start', `wid-edit'. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; When you want to fetch and install sources from a repository you -;; may have to call several async processes and wait for the answer -;; before calling the next function. These functions may help you with -;; this. -;; -;; See `udev-call-first-step' for more information. Or look in the -;; file udev-cedet.el for examples. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'cl)) - -(require 'cus-edit) - -;;; Control/log buffer - -(defvar udev-log-buffer nil - "Log buffer pointer for sentinel function.") -(make-variable-buffer-local 'udev-log-buffer) - -(defvar udev-is-log-buffer nil - "This is t if this is an udev log/control buffer.") -(make-variable-buffer-local 'udev-is-log-buffer) - -(defun udev-check-is-log-buffer (buffer) - "Check that BUFFER is an udev log/control buffer." - (with-current-buffer buffer - (unless udev-is-log-buffer - (error "Internal error, not a log buffer: %s" buffer)))) - -(defvar udev-this-chain nil) -(make-variable-buffer-local 'udev-this-chain) - -(defvar udev-last-error nil - "Error found during last step.") -(make-variable-buffer-local 'udev-last-error) - -(defun udev-set-last-error (log-buffer msg) - (with-current-buffer log-buffer - (setq udev-last-error msg))) - -;;; Chain utils - -(defun udev-chain (log-buffer) - "Return value of `udev-this-chain' in buffer LOG-BUFFER." - (udev-check-is-log-buffer log-buffer) - (with-current-buffer log-buffer - udev-this-chain)) - -(defun udev-this-step (log-buffer) - "Return current function to call from LOG-BUFFER." - (let ((this-chain (udev-chain log-buffer))) - (caar this-chain))) - -(defun udev-goto-next-step (log-buffer) - "Set next function as current in LOG-BUFFER." - (let* ((this-chain (udev-chain log-buffer)) - (this-step (car this-chain))) - (setcar this-chain (cdr this-step)))) - -(defun udev-num-steps (log-buffer) - "Return number of steps." - (length (nth 2 (udev-chain log-buffer)))) - -(defun udev-step-num (log-buffer) - "Return current step number." - (let ((this-chain (udev-chain log-buffer))) - (when this-chain - (1+ (- (udev-num-steps log-buffer) - (length (car this-chain))))))) - -(defun udev-finish-function (log-buffer) - "Return setup function to be called when finished." - (nth 3 (udev-chain log-buffer))) - - -(defvar udev-control-mode-map - (let ((map (make-sparse-keymap))) - (set-keymap-parent map button-buffer-map) - map)) - -(define-derived-mode udev-control-mode nil - "Udev-Src" - "Mode for udev control buffer." - (setq show-trailing-whitespace nil) - (setq buffer-read-only t) - (nxhtml-menu-mode 1)) - -;;; Calling steps - -;;;###autoload -(defun udev-call-first-step (log-buffer steps header finish-fun) - "Set up and call first step. -Set up buffer LOG-BUFFER to be used for log messages and -controling of the execution of the functions in list STEPS which -are executed one after another. - -Write HEADER at the end of LOG-BUFFER. - -Call first step. - -If FINISH-FUN non-nil it should be a function. This is called -after last step with LOG-BUFFER as parameter." - ;;(dolist (step steps) (unless (functionp step) (error "Not a known function: %s" step))) - (switch-to-buffer log-buffer) - (udev-control-mode) - (setq udev-is-log-buffer t) - (let ((this-chain - (cons nil - (cons log-buffer - (cons (copy-tree steps) - (cons finish-fun nil)))))) - (setcar this-chain (caddr this-chain)) - (setq udev-this-chain this-chain)) - (assert (eq (car steps) (udev-this-step log-buffer)) t) - (assert (eq finish-fun (udev-finish-function log-buffer)) t) - (widen) - (goto-char (point-max)) - (let ((inhibit-read-only t)) - (unless (= (point) (point-min)) (insert "\n\n")) - (insert header)) - (udev-call-this-step log-buffer nil) - (current-buffer)) - -(defvar udev-step-keymap - (let ((map (make-sparse-keymap))) - (define-key map [(control ?c) ?r] 'udev-rerun-this-step) - (define-key map [(control ?c) ?c] 'udev-continue-from-this-step) - (define-key map [(control ?c) ?s] 'udev-goto-this-step-source) - map)) - -(defun udev-step-at-point () - (get-text-property (point) 'udev-step)) - -(defun udev-rerun-this-step () - "Rerun this step." - (interactive) - (let ((this-step (udev-step-at-point))) - (udev-call-this-step (current-buffer) this-step))) - -(defun udev-continue-from-this-step () - "Continue from this step." - (interactive) - (let ((this-step (udev-step-at-point))) - (goto-char (point-max)) - (let ((inhibit-read-only t)) - (insert (format "\n\nContinuing from %s..." this-step))) - (udev-call-this-step (current-buffer) this-step))) - -(defun udev-goto-this-step-source () - "Find source function for this step." - (interactive) - (let ((this-step (udev-step-at-point))) - (find-function-other-window this-step))) - -(defun udev-call-this-step (log-buffer this-step) - "Call the current function in LOG-BUFFER. -If this function returns a buffer and the buffer has a process -then change the process sentinel to `udev-compilation-sentinel'. -Otherwise continue to call the next function. - -Also put a log message in in LOG-BUFFER with a link to the buffer -returned above if any." - (setq this-step (or this-step (udev-this-step log-buffer))) - (with-current-buffer log-buffer - (setq udev-last-error nil) - (widen) - (goto-char (point-max)) - (let* ((inhibit-read-only t) - here - buf - proc) - (if (not this-step) - (let ((finish-fun (udev-finish-function log-buffer))) - (insert (propertize "\nFinished\n" 'face 'compilation-info)) - (when finish-fun - (funcall finish-fun log-buffer))) - (insert (format "\nStep %s(%s): " - (udev-step-num log-buffer) - (udev-num-steps log-buffer))) - (setq here (point)) - (insert (pp-to-string this-step)) - (setq buf (funcall this-step log-buffer)) - (when (bufferp buf) - (make-text-button here (point) - 'udev-step this-step - 'keymap udev-step-keymap - 'buffer buf - 'help-echo "Push RET to see log buffer, <APPS> for other actions" - 'action (lambda (btn) - (display-buffer - (button-get btn 'buffer)))) - (setq proc (get-buffer-process buf))) - ;; Setup for next step - (if (and proc - (not udev-last-error)) - (progn - (with-current-buffer buf - ;; Make a copy here for the sentinel function. - (setq udev-log-buffer log-buffer) - (setq udev-orig-sentinel (process-sentinel proc)) - (set-process-sentinel proc 'udev-compilation-sentinel))) - ;;(message "proc is nil") - (if udev-last-error - (insert " " - (propertize udev-last-error 'face 'compilation-error)) - (udev-call-next-step log-buffer 0 nil))))))) - -(defun udev-call-next-step (log-buffer prev-exit-status exit-status-buffer) - "Go to next step in LOG-BUFFER and call `udev-call-this-step'. -However if PREV-EXIT-STATUS \(which is the exit status from the -previous step) is not 0 and there is in EXIT-STATUS-BUFFER no -`udev-continue-on-error-function' then stop and insert an error -message in LOG-BUFFER." - (with-current-buffer log-buffer - (let ((inhibit-read-only t)) - (widen) - (goto-char (point-max)) - (insert " ") - (if (or (= 0 prev-exit-status) - (with-current-buffer exit-status-buffer - (when udev-continue-on-error-function - (funcall udev-continue-on-error-function exit-status-buffer)))) - (progn - (insert - (if (= 0 prev-exit-status) - (propertize "Ok" 'face 'compilation-info) - (propertize "Warning, check next step" 'face 'compilation-warning))) - (udev-goto-next-step log-buffer) - (udev-call-this-step log-buffer nil)) - (insert (propertize "Error" 'face 'compilation-error)))))) - - -;;; Sentinel - -(defvar udev-orig-sentinel nil - "Old sentinel function remembered by `udev-call-this-step'.") -(make-variable-buffer-local 'udev-orig-sentinel) - -(defun udev-compilation-sentinel (proc msg) - "Sentinel to use for processes started by `udev-call-this-step'. -Check for error messages and call next step. PROC and MSG have -the same meaning as for `compilation-sentinel'." - ;;(message "udev-compilation-sentinel proc=%s msg=%s" proc msg) - (let ((buf (process-buffer proc)) - (exit-status (process-exit-status proc))) - (with-current-buffer buf - (when udev-orig-sentinel - (funcall udev-orig-sentinel proc msg)) - (when (and (eq 'exit (process-status proc)) - (= 0 exit-status)) - ;; Check for errors - (let ((here (point)) - (err-point 1) - (has-error nil)) - (widen) - (goto-char (point-min)) - (setq has-error - (catch 'found-error - (while err-point - (setq err-point - (next-single-property-change err-point 'face)) - (when err-point - (let ((face (get-text-property err-point 'face))) - (when (or (and (listp face) - (memq 'compilation-error face)) - (eq 'compilation-error face)) - (throw 'found-error t))))))) - (when has-error - (setq exit-status 1) - (goto-char (point-max)) - (let ((inhibit-read-only t)) - (insert (propertize "There were errors" 'font-lock-face 'compilation-error))) - (udev-set-compilation-end-message buf 'exit (cons "has errors" 1))) - (goto-char here) - )) - (unless (member proc compilation-in-progress) - (udev-call-next-step udev-log-buffer exit-status (current-buffer)))))) - -(defun udev-set-compilation-end-message (buffer process-status status) - "Change the message shown after compilation. -This is similar to `compilation-end-message' and BUFFER, -PROCESS-STATUS and STATUS have the same meaning as there." - (with-current-buffer buffer - (setq mode-line-process - (let ((out-string (format ":%s [%s]" process-status (cdr status))) - (msg (format "%s %s" mode-name - (replace-regexp-in-string "\n?$" "" (car status))))) - (message "%s" msg) - (propertize out-string - 'help-echo msg 'face (if (> (cdr status) 0) - 'compilation-error - 'compilation-info)))))) - -(defvar udev-continue-on-error-function nil - "One-time helper to resolve exit status error problem. -This can be used for example after calling `cvs diff' which -returns error exit status if there is a difference - even though -there does not have to be an error.") -(make-variable-buffer-local 'udev-continue-on-error-function) - - -;;; Convenience functions - -(defun udev-buffer-name (fmt log-buffer mode) - "Return a name for compilation buffer. -Use format string FMT and buffer LOG-BUFFER, but ignoring MODE." - (format fmt (when (buffer-live-p log-buffer) - (udev-this-step log-buffer)))) - -(defvar udev-this-dir - (let ((this-file (or load-file-name (buffer-file-name)))) - (file-name-directory this-file))) - -(defun udev-batch-compile (emacs-args defdir name-function) - "Compile elisp code in an inferior Emacs. -Start Emacs with - - emacs -Q -batch EMACS-ARGS - -in the default directory DEFDIR. - -Set the buffer name for the inferior process with NAME-FUNCTION -by giving this to `compilation-start'." - (let ((default-directory (file-name-as-directory defdir)) - (this-emacs (ourcomments-find-emacs))) - (compilation-start - (concat this-emacs " -Q -batch " emacs-args) - 'compilation-mode - name-function))) - -;;; Convenience functions for CVS - -(defun udev-fetch-cvs-diff (defdir name-function) - "Fetch cvs diff in directory DEFDIR. -Put the diff in file 'your-patches.diff' in DEFDIR. -Give inferior buffer name with NAME-FUNCTION." - (let ((default-directory (file-name-as-directory defdir))) - (with-current-buffer - (compilation-start - (concat "cvs diff -b -u > " (shell-quote-argument "your-patches.diff")) - 'compilation-mode - name-function) - (setq udev-continue-on-error-function 'udev-cvs-diff-continue) - (current-buffer)))) - -(defun udev-cvs-diff-continue (cvs-diff-buffer) - "Return non-nil if it is ok to continue. -Check the output from the `cvs diff' command in buffer -CVS-DIFF-BUFFER. - -The cvs command exits with a failure status if there is a -difference, which means that it is hard to know whether there was -an error or just a difference. This function tries to find out." - (with-current-buffer cvs-diff-buffer - (let ((here (point)) - (ret t)) - (goto-char (point-min)) - (when (search-forward "cvs [diff aborted]" nil t) (setq ret nil)) - (goto-char (point-min)) - (when (search-forward "merge conflict" nil t) (setq ret t)) - ;; From cvs co command: - ;; rcsmerge: warning: conflicts during merge - (goto-char (point-min)) - (when (search-forward "conflicts during merge" nil t) (setq ret t)) - ;; cvs checkout: conflicts found in emacs/lisp/startup.el - (goto-char (point-min)) - (when (search-forward "conflicts found in" nil t) (setq ret t)) - (goto-char here) - ret))) - -(defun udev-check-cvs-diff (diff-file log-buffer) - "Check cvs diff output in file DIFF-FILE for merge conflicts. -Return buffer containing DIFF-FILE." - (let ((buf (find-buffer-visiting diff-file))) - ;; Kill buffer to avoid question about revert. - (when buf (kill-buffer buf)) - (setq buf (find-file-noselect diff-file)) - (with-current-buffer buf - (widen) - (let ((here (point))) - (goto-char (point-min)) - ;; Fix-me: Better pattern: - (if (search-forward "<<<<<<<" nil t) - ;; Merge conflict - (with-current-buffer log-buffer - (let ((inhibit-read-only t)) - (setq udev-last-error "Error: merge conflict"))) - (goto-char here)))) - buf)) - -;;(setq compilation-scroll-output t) -;;(add-to-list 'compilation-error-regexp-alist 'cvs) -;;(setq compilation-error-regexp-alist (delq 'cvs compilation-error-regexp-alist)) - -;;; Misc - -(defun udev-send-buffer-process (str) - (interactive "sString to send to process: ") - (let* ((procs (process-list)) - (proc (catch 'found - (dolist (p procs) - (when (eq (process-buffer p) (current-buffer)) - (throw 'found p)))))) - (unless proc (error "Can't find process in buffer")) - ;;(message "str=%s" str) - ;;(message "proc=%s" proc) - (process-send-string proc (concat str "\n")) - )) - - -(provide 'udev) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; udev.el ends here diff --git a/emacs.d/nxhtml/util/useful-commands.el b/emacs.d/nxhtml/util/useful-commands.el deleted file mode 100644 index 414d2f7..0000000 --- a/emacs.d/nxhtml/util/useful-commands.el +++ /dev/null @@ -1,63 +0,0 @@ -;;; useful-commands.el --- Menu with useful Emacs commands -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2008-09-29T12:56:24+0200 Mon -;; Version: -;; Last-Updated: -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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: - -(defvar useful-commands-definitions nil - "Defines the menus using a org like syntax. -* Search and Replace -** Occur in multiple buffers `multi-occur' -** Grep in Directory `lgrep' -** Occur `occur' -** Grep in Directory Tree `rgrep' -* END -" -) - -(defun useful-commands-build-menu () - ) - -(provide 'useful-commands) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; useful-commands.el ends here diff --git a/emacs.d/nxhtml/util/viper-tut.el b/emacs.d/nxhtml/util/viper-tut.el deleted file mode 100644 index a941045..0000000 --- a/emacs.d/nxhtml/util/viper-tut.el +++ /dev/null @@ -1,1009 +0,0 @@ -;;; viper-tut.el --- Viper tutorial -;; -;; Author: Lennart Borgman -;; Created: Fri Sep 08 2006 -(defconst viper-tut:version "0.2") ;;Version: 0.2 -;; Last-Updated: -;; Keywords: -;; Compatibility: Emacs 22 -;; -;; Features that might be required by this library: -;; -;; `button', `cus-edit', `cus-face', `cus-load', `cus-start', -;; `help-mode', `tutorial', `view', `wid-edit'. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'mumamo)) -(eval-when-compile (require 'ourcomments-util)) -(require 'tutorial) -(require 'cus-edit) - -(defface viper-tut-header-top - '((t (:foreground "black" :background "goldenrod3"))) - "Face for headers." - :group 'web-vcs) - -(defface viper-tut-header - '((t (:foreground "black" :background "goldenrod2" :height 1.8))) - "Face for headers." - :group 'web-vcs) - -(defvar tutorial--tab-map - (let ((map (make-sparse-keymap))) - (define-key map [tab] 'forward-button) - (define-key map [(shift tab)] 'backward-button) - (define-key map [(meta tab)] 'backward-button) - map) - "Keymap that allows tabbing between buttons.") - -(defconst viper-tut--emacs-part 6) - -(defconst viper-tut--default-keys - `( -;;;;;;;;;;;;;; Part 1 - ;; ^D Move DOWN one half-screen - ;;(viper-scroll-up [(control ?d)]) - (viper-scroll-up [?\C-d]) - - ;; ^U Move UP one half-screen - ;;(viper-scroll-down [(control ?u)]) - (viper-scroll-down [?\C-u]) - - ;; h Move left one character - (viper-backward-char [?h]) - - ;; j Move down one line - (viper-next-line [?j]) - - ;; k Move up one line - (viper-previous-line [?k]) - - ;; l Move right one character - (viper-forward-char [?l]) - - ;; dd DELETE one line - (viper-command-argument [?d]) - - ;; x X-OUT one character - (viper-delete-char [?x]) - - ;; u UNDO last change - (viper-undo [?u]) - - ;; :q!<RETURN> QUIT without saving changes - (viper-ex [?:]) - - ;; ZZ Exit and save any changes - (viper-save-kill-buffer [?Z ?Z]) - - ;; o OPEN a line for inserting text - (viper-open-line [?o]) - - ;; i INSERT starting at the cursor - (viper-insert [?i]) - - ;; ESC ESCAPE from insert mode - ;;(viper-intercept-ESC-key [(escape)]) - ;(viper-intercept-ESC-key [27]) - (viper-intercept-ESC-key [escape]) - ;; chagned-keys= - ;; (([27] - ;; viper-intercept-ESC-key - ;; viper-intercept-ESC-key - ;; <escape> - ;; (more info current-binding (keymap (118 . cua-repeat-replace-region)) viper-intercept-ESC-key [27] <escape>))) - - -;;;;;;;;;;;;;; Part 2 - ;; w Move to the beginning of the next WORD - (viper-forward-word [?w]) - ;; e Move to the END of the next word - (viper-end-of-word [?e]) - ;; b Move BACK to the beginning to the previous word - (viper-backward-word [?b]) - - ;; $ Move to the end of the line - (viper-goto-eol [?$]) - - ;; ^ Move to the first non-white character on the line - (viper-bol-and-skip-white [?^]) - - ;; 0 Move to the first column on the line (column zero) - (viper-beginning-of-line [?0]) - ;; #| Move to an exact column on the line (column #) e.g. 5| 12| - (viper-goto-col [?|]) - - ;; f char FIND the next occurrence of char on the line - (viper-find-char-forward [?f]) - ;; t char Move 'TIL the next occurrence of char on the line - (viper-goto-char-forward [?t]) - - ;; F char FIND the previous occurrence of char on the line - (viper-find-char-backward [?F]) - ;; T char Move 'TIL the previous occurrence of char on the line - (viper-goto-char-backward [?T]) - - ;; ; Repeat the last f, t, F, or T - (viper-repeat-find [?\;]) - ;; , Reverse the last f, t, F, or T - (viper-repeat-find-opposite [?,]) - - ;; % Show matching () or {} or [] - (viper-exec-mapped-kbd-macro [?%]) - - ;; H Move to the HIGHEST position in the window - (viper-window-top [?H]) - ;; M Move to the MIDDLE position in the window - (viper-window-middle [?M]) - ;; L Move to the LOWEST position in the window - (viper-window-bottom [?L]) - - ;; m char MARK this location and name it char - (viper-mark-point [?m]) - ;; ' char (quote character) return to line named char - ;; '' (quote quote) return from last movement - (viper-goto-mark-and-skip-white [?']) - - ;; G GO to the last line in the file - ;; #G GO to line #. (e.g., 3G , 5G , 175G ) - (viper-goto-line [?G]) - - ;; { (left brace) Move to the beginning of a paragraph - ;; } (right brace) Move to the end of a paragraph - (viper-backward-paragraph [?{]) - (viper-forward-paragraph [?}]) - - ;; ( (left paren) Move to the beginning of a sentence - ;; ) (right paren) Move to the beginning of the next sentence - (viper-backward-sentence [?\(]) - (viper-forward-sentence [?\)]) - - ;; [[ Move to the beginning of a section - ;; ]] Move to the end of a section - (viper-brac-function [?\[]) - (viper-ket-function [?\]]) - - ;; /string Find string looking forward - (viper-exec-mapped-kbd-macro [?/]) - ;; ?string Find string looking backward - (viper-search-backward [??]) - - ;; n Repeat last / or ? command - ;; N Reverse last / or ? command - (viper-search-next [?n]) - (viper-search-Next [?N]) - - -;;;;;;;;;;;;;; Part 3 - - ;; #movement repeat movement # times - (viper-digit-argument [?1]) - (viper-digit-argument [?2]) - (viper-digit-argument [?3]) - (viper-digit-argument [?4]) - (viper-digit-argument [?5]) - (viper-digit-argument [?6]) - (viper-digit-argument [?7]) - (viper-digit-argument [?8]) - (viper-digit-argument [?9]) - - ;; dmovement DELETE to where "movement" command specifies - ;; d#movement DELETE to where the #movement command specifies - ;; d runs the command viper-command-argument - - ;; ymovement YANK to where "movement" command specifies - ;; y#movement YANK to where the #movement command specifies - (viper-command-argument [?y]) - - ;; P (upper p) PUT the contents of the buffer before the cursor - ;; p (lower p) PUT the contents of the buffer after the cursor - (viper-put-back [?p]) - (viper-Put-back [?P]) - - ;; "#P (upper p) PUT contents of buffer # before the cursor - ;; "#p (lower p) PUT contents of buffer # after the cursor - ;; - ;; "aDELETE DELETE text into buffer a - ;; "aYANK YANK text into buffer a - ;; "aPUT PUT text from named buffer a - (viper-command-argument [?\"]) - - ;; :w<RETURN> WRITE contents of the file (without quitting) - - ;; :e filename<RETURN> Begin EDITing the file called "filename" - - - -;;;;;;;;;;;;;; Part 4 - - - ;; o OPEN a line below the cursor - ;; O OPEN a line above the cursor - (viper-open-line [?o]) - (viper-Open-line [?O]) - - ;; i INSERT starting before the cursor - ;; I INSERT at the beginning of the line - (viper-insert [?i]) - (viper-Insert [?I]) - - ;; a APPEND starting after the cursor - ;; A APPEND at the end of the line - (viper-append [?a]) - (viper-Append [?A]) - - ;; ESC ESCAPE from insert mode - (viper-intercept-ESC-key [(escape)]) - - ;; J JOIN two lines - (viper-join-lines [?J]) - - ;; #s SUBSTITUTE for # characters - ;; #S SUBSTITUTE for # whole lines - (viper-substitute [?s]) - (viper-substitute-line [?S]) - - ;; r REPLACE character (NO need to press ESC) - ;; R enter over-type mode - (viper-replace-char [?r]) - (viper-overwrite [?R]) - - ;; cmovement CHANGE to where the movement commands specifies - (viper-command-argument [?c]) - - -;;;;;;;;;;;;;; Part 5 - - ;; ~ (tilde) Convert case of current character - (viper-toggle-case [?~]) - ;; U (upper u) UNDO all changes made to the current line - ;; not implemented - ;;(viper-undo [?U]) - - ;; . (dot) repeat last change - (viper-repeat [?.]) - - ;; ^F Move FORWARD one full-screen - ;; ^B Move BACKWARD one full-screen - ;;(viper-scroll-screen [(control ?f)]) - (viper-scroll-screen [?\C-f]) - ;;(viper-scroll-screen-back [(control ?b)]) - (viper-scroll-screen-back [?\C-b]) - - ;; ^E Move the window down one line without moving cursor - ;; ^Y Move the window up one line without moving cursor - ;;(viper-scroll-up-one [(control ?e)]) - (viper-scroll-up-one [?\C-e]) - ;;(viper-scroll-down-one [(control ?y)]) - (viper-scroll-down-one [?\C-y]) - - ;; z<RETURN> Position the current line to top of window - ;; z. Position the current line to middle of window - ;; z- Position the current line to bottom of window - (viper-line-to-top "z\C-m") - (viper-line-to-middle [?z ?.]) - (viper-line-to-bottom [?z ?-]) - - ;; ^G Show status of current file - ;;(viper-info-on-file [(control ?c)(control ?g)]) - (viper-info-on-file [?\C-c ?\C-g]) - ;; ^L Refresh screen - ;;(recenter [(control ?l)]) - (recenter-top-bottom [?\C-l]) - - ;; !}fmt Format the paragraph, joining and filling lines to - ;; !}sort Sort lines of a paragraph alphabetically - (viper-command-argument [?!]) - - ;; >movement Shift right to where the movement command specifies - ;; <movement Shift left to where the movement command specifies - (viper-command-argument [?>]) - (viper-command-argument [?<]) - - )) - -(defun viper-tut--detailed-help (button) - "Give detailed help about changed keys." - (with-output-to-temp-buffer (help-buffer) - (help-setup-xref (list #'viper-tut--detailed-help button) - (interactive-p)) - (with-current-buffer (help-buffer) - (let* ((tutorial-buffer (button-get button 'tutorial-buffer)) - ;;(tutorial-arg (button-get button 'tutorial-arg)) - (explain-key-desc (button-get button 'explain-key-desc)) - (part (button-get button 'part)) - (changed-keys (with-current-buffer tutorial-buffer - (let ((tutorial--lang "English")) - (tutorial--find-changed-keys - (if (= part viper-tut--emacs-part) - tutorial--default-keys - viper-tut--default-keys)))))) - (when changed-keys - (insert - "The following key bindings used in the tutorial had been changed\n" - (if (= part viper-tut--emacs-part) - "from Emacs default in the " - "from Viper default in the ") - (buffer-name tutorial-buffer) " buffer:\n\n" ) - (let ((frm " %-9s %-27s %-11s %s\n")) - (insert (format frm "Key" "Standard Binding" "Is Now On" "Remark"))) - (dolist (tk changed-keys) - (let* ((def-fun (nth 1 tk)) - (key (nth 0 tk)) - (def-fun-txt (nth 2 tk)) - (where (nth 3 tk)) - (remark (nth 4 tk)) - (rem-fun (command-remapping def-fun)) - (key-txt (key-description key)) - (key-fun (with-current-buffer tutorial-buffer (key-binding key))) - tot-len) - (unless (eq def-fun key-fun) - ;; Insert key binding description: - (when (string= key-txt explain-key-desc) - (put-text-property 0 (length key-txt) 'face '(:background "yellow") key-txt)) - (insert " " key-txt " ") - (setq tot-len (length key-txt)) - (when (> 9 tot-len) - (insert (make-string (- 9 tot-len) ? )) - (setq tot-len 9)) - ;; Insert a link describing the old binding: - (insert-button def-fun-txt - 'help-echo (format "Describe function '%s" def-fun-txt) - 'action `(lambda(button) (interactive) - (describe-function ',def-fun)) - 'follow-link t) - (setq tot-len (+ tot-len (length def-fun-txt))) - (when (> 36 tot-len) - (insert (make-string (- 36 tot-len) ? ))) - (when (listp where) - (setq where "list")) - ;; Tell where the old binding is now: - (insert (format " %-11s " where)) - ;; Insert a link with more information, for example - ;; current binding and keymap or information about - ;; cua-mode replacements: - (insert-button (car remark) - 'help-echo "Give more information about the changed key binding" - 'action `(lambda(b) (interactive) - (let ((value ,(cdr remark))) - ;; Fix-me: - (tutorial--describe-nonstandard-key value))) - 'follow-link t) - (insert "\n"))))) - - - - (insert " -It is legitimate to change key bindings, but changed bindings do not -correspond to what the tutorial says. -\(See also " ) - (insert-button "Key Binding Conventions" - 'action - (lambda(button) (interactive) - (info - "(elisp) Key Binding Conventions") - (message "Type C-x 0 to close the new window")) - 'follow-link t) - (insert ".)\n\n") - (with-no-warnings (print-help-return-message)))))) - - -(defvar viper-tut--part nil - "Viper tutorial part.") -(make-variable-buffer-local 'viper-tut--part) - -(defun viper-tut--saved-file () - "File name in which to save tutorials." - (let* ((file-name - (file-name-nondirectory (viper-tut--file viper-tut--part))) - (ext (file-name-extension file-name))) - (when (or (not ext) - (string= ext "")) - (setq file-name (concat file-name ".tut"))) - (expand-file-name file-name (tutorial--saved-dir)))) - -(defun viper-tut--save-tutorial () - "Save the tutorial buffer. -This saves the part of the tutorial before and after the area -showing changed keys. It also saves point position and the -position where the display of changed bindings was inserted. - -Do not save anything if not `viper-mode' is enabled in the -tutorial buffer." - ;; This runs in a hook so protect it: - (condition-case err - (when (boundp 'viper-mode-string) - (tutorial--save-tutorial-to (viper-tut--saved-file))) - (error (warn "Error saving tutorial state: %s" (error-message-string err))))) - - -(defvar viper-tut--parts - '( - (0 "0intro" "Introduction") - (1 "1basics" "Basic Editing") - (2 "2moving" "Moving Efficiently") - (3 "3cutpaste" "Cutting and Pasting") - (4 "4inserting" "Inserting Techniques") - (5 "5tricks" "Tricks and Timesavers") - (6 "(no file)" "Emacs tutorial for Viper Users") - )) - -(defcustom viper-tut-directory - (let* ((this-file (if load-file-name - load-file-name - (buffer-file-name))) - (this-dir (file-name-directory this-file))) - (file-name-as-directory - (expand-file-name "../etc/viper-tut" this-dir))) - "Directory where the Viper tutorial files lives." - :type 'directory - :group 'viper) - -(defun viper-tut--file(part) - "Get file name for part." - (let ((tut-file)) - (mapc (lambda(rec) - (when (= part (nth 0 rec)) - (setq tut-file - (if (= part viper-tut--emacs-part) - (let ((tf (expand-file-name (get-language-info "English" 'tutorial) tutorial-directory))) - (unless (file-exists-p tf) - (error "Can't find the English tutorial file for Emacs: %S" tf)) - tf) - (expand-file-name (nth 1 rec) viper-tut-directory))))) - viper-tut--parts) - tut-file)) - -(defun viper-tut-viper-is-on () - ;;(message "viper-tut-viper-is-on, vms=%s, cb=%s" (boundp 'viper-mode-string) (current-buffer)) - ;;(boundp 'viper-mode-string) - (boundp 'viper-current-state)) - -(defun viper-tut--display-changes (changed-keys part) - "Display changes to some default Viper key bindings. -If some of the default key bindings that the Viper tutorial -depends on have been changed then display the changes in the -tutorial buffer with some explanatory links. - -CHANGED-KEYS should be a list in the format returned by -`tutorial--find-changed-keys'." - (when (or changed-keys - (viper-tut-viper-is-on)) - ;; Need the custom button face for viper buttons: - ;;(when (and (boundp 'viper-mode) viper-mode) (require 'cus-edit)) - (goto-char tutorial--point-before-chkeys) - (let* ((start (point)) - end - (head - (if (viper-tut-viper-is-on) - (if (= part viper-tut--emacs-part) - " - NOTICE: This part of the Viper tutorial runs the Emacs tutorial. - Several keybindings are changed from Emacs default (either - because of Viper or some other customization) and doesn't - correspond to the tutorial. - - We have inserted colored notices where the altered commands have - been introduced. If you change Viper state (vi state, insert - state, etc) these notices will be changed to reflect the new - state. [" - " - NOTICE: The main purpose of the Viper tutorial is to teach you - the most important vi commands (key bindings). However, your - Emacs has been customized by changing some of these basic Viper - editing commands, so it doesn't correspond to the tutorial. We - have inserted colored notices where the altered commands have - been introduced. [") - " - NOTICE: You have currently not turned on Viper. Nothing in this - tutorial \(the Viper Tutorial\) will work unless you do that. [" - )) - (head2 (if (viper-tut-viper-is-on) - (get-lang-string tutorial--lang 'tut-chgdhead2) - "More information"))) - (when (and head head2) - (insert head) - (insert-button head2 - 'tutorial-buffer - (current-buffer) - ;;'tutorial-arg arg - 'part part - 'action - (if (viper-tut-viper-is-on) - 'viper-tut--detailed-help - 'go-home-blaha) - 'follow-link t - 'echo "Click for more information" - 'face '(:inherit link :background "yellow")) - (insert "]\n\n" ) - (when changed-keys - (dolist (tk changed-keys) - (let* ((def-fun (nth 1 tk)) - (key (nth 0 tk)) - (def-fun-txt (nth 2 tk)) - (where (nth 3 tk)) - (remark (nth 4 tk)) - (rem-fun (command-remapping def-fun)) - (key-txt (key-description key)) - (key-fun (key-binding key)) - tot-len) - (unless (eq def-fun key-fun) - ;; Mark the key in the tutorial text - (unless (string= "Same key" where) - (let* ((here (point)) - (key-desc (key-description key)) - (vi-char (= 1 (length key-desc))) - vi-char-pos - hit) - (when (string= "RET" key-desc) - (setq key-desc "Return")) - (when (string= "DEL" key-desc) - (setq key-desc "Delback")) - (while (if (not vi-char) - (unless hit ;; Only tell once - (setq hit t) - (re-search-forward - (concat "[^[:alpha:]]\\(" - (regexp-quote key-desc) - "\\)[^[:alpha:]]") nil t)) - (setq vi-char-pos - (next-single-property-change - (point) 'vi-char))) - (if (not vi-char) - (put-text-property (match-beginning 0) - (match-end 0) - 'tutorial-remark nil) ;;'only-colored) - (put-text-property (match-beginning 0) - (match-end 0) - 'face '(:background "yellow")) - (goto-char (1+ vi-char-pos)) - (setq hit (string= key-desc (char-to-string (char-before)))) - (when hit - (put-text-property vi-char-pos (1+ vi-char-pos) - 'face '(:background "yellow")))) - (when hit - (forward-line) - (let ((s (get-lang-string tutorial--lang 'tut-chgdkey)) - (s2 (get-lang-string tutorial--lang 'tut-chgdkey2)) - (start (point)) - end) - ;; key-desc " has been rebound, but you can use " where " instead [")) - (when (and s s2) - (when (or (not where) (= 0 (length where))) - (setq where (concat "`M-x " def-fun-txt "'"))) - (setq s (format s key-desc where s2)) - (insert s " [") - (insert-button s2 - 'tutorial-buffer - (current-buffer) - ;;'tutorial-arg arg - 'part part - 'action - 'viper-tut--detailed-help - 'explain-key-desc key-desc - 'follow-link t - 'face '(:inherit link :background "yellow")) - (insert "] **") - (insert "\n") - (setq end (point)) - (put-text-property start end 'local-map tutorial--tab-map) - (put-text-property start end 'tutorial-remark t) - (put-text-property start end - 'face '(:background "yellow" :foreground "#c00")) - (put-text-property start end 'read-only t))))) - (goto-char here))))))) - - - (setq end (point)) - ;; Make the area with information about change key - ;; bindings stand out: - (put-text-property start end - 'face - ;; The default warning face does not - ;;look good in this situation. Instead - ;;try something that could be - ;;recognized from warnings in normal - ;;life: - ;; 'font-lock-warning-face - (list :background "yellow" :foreground "#c00")) - ;; Make it possible to use Tab/S-Tab between fields in - ;; this area: - (put-text-property start end 'local-map tutorial--tab-map) - (put-text-property start end 'tutorial-remark t) - (setq tutorial--point-after-chkeys (point-marker)) - ;; Make this area read-only: - (put-text-property start end 'read-only t))))) - -(defun viper-tut--at-change-state() - (condition-case err - (progn - (let ((inhibit-read-only t) - (here (point))) - ;; Delete the remarks: - ;;(tutorial--remove-remarks) - ;; Add them again - ;;(viper-tut--add-remarks) - (goto-char here) - ) - ) - (error (message "error in viper-tut--at-change-state: %s" (error-message-string err))))) - - -;;;###autoload -(defun viper-tutorial(part &optional dont-ask-for-revert) - "Run a tutorial for Viper. - -A simple classic tutorial in 5 parts that have been used by many -people starting to learn vi keys. You may learn enough to start -using `viper-mode' in Emacs. - -Some people find that vi keys helps against repetetive strain -injury, see URL - - `http://www.emacswiki.org/emacs/RepeatedStrainInjury'. - -Note: There might be a few clashes between vi key binding and -Emacs standard key bindings. You will be notified about those in -the tutorial. Even more, if your own key bindings comes in -between you will be notified about that too." - (interactive (list - ;; (condition-case nil - ;; (widget-choose "The following viper tutorials are available" - ;; (mapcar (lambda(rec) - ;; (cons (nth 2 rec) (nth 0 rec))) - ;; viper-tut--parts)) - ;; (error nil)) - 0 - )) - (if (not (boundp 'viper-current-state)) - (let ((prompt - " - You can not run the Viper tutorial in this Emacs because you - have not enabled Viper. - - Do you want to run the Viper tutorial in a new Emacs? ")) - (if (y-or-n-p prompt) - (let ((ret (funcall 'emacs--no-desktop - "-eval" - (concat - "(progn" - " (setq viper-mode t)" - " (require 'viper)" - " (require 'viper-tut)" - " (call-interactively 'viper-tutorial))")))) - (message "Starting Viper tutorial in a new Emacs")) - (message "Viper tutorial aborted by user"))) - - (let* ((filename (viper-tut--file part)) - ;; Choose a buffer name including the language so that - ;; several languages can be tested simultaneously: - (tut-buf-name "Viper TUTORIAL") - (old-tut-buf (get-buffer tut-buf-name)) - (old-tut-part (when old-tut-buf - (with-current-buffer old-tut-buf - viper-tut--part))) - (old-tut-win (when old-tut-buf (get-buffer-window old-tut-buf t))) - (old-tut-is-ok (when old-tut-buf - (and - (= part old-tut-part) - (not (buffer-modified-p old-tut-buf))))) - old-tut-file - (old-tut-point 1)) - (unless (file-exists-p filename) (error "Can't fine %s" filename)) - (setq tutorial--point-after-chkeys (point-min)) - ;; Try to display the tutorial buffer before asking to revert it. - ;; If the tutorial buffer is shown in some window make sure it is - ;; selected and displayed: - (if old-tut-win - (raise-frame - (window-frame - (select-window (get-buffer-window old-tut-buf t)))) - ;; Else, is there an old tutorial buffer? Then display it: - (when old-tut-buf - (switch-to-buffer old-tut-buf))) - ;; Use whole frame for tutorial - ;;(delete-other-windows) - ;; If the tutorial buffer has been changed then ask if it should - ;; be reverted: - (when (and old-tut-buf - (not old-tut-is-ok) - (= part old-tut-part)) - (setq old-tut-is-ok - (if dont-ask-for-revert - nil - (not (y-or-n-p - "You have changed the Tutorial buffer. Revert it? "))))) - ;; (Re)build the tutorial buffer if it is not ok - (unless old-tut-is-ok - (switch-to-buffer (get-buffer-create tut-buf-name)) - (unless old-tut-buf (text-mode)) - (setq viper-tut--part part) - (setq old-tut-file (file-exists-p (viper-tut--saved-file))) - (when (= part 0) (setq old-tut-file nil)) ;; You do not edit in the intro - (setq buffer-read-only nil) - (let ((inhibit-read-only t)) ;; For the text property - (erase-buffer)) - (message "Preparing Viper tutorial ...") (sit-for 0) - - ;; Do not associate the tutorial buffer with a file. Instead use - ;; a hook to save it when the buffer is killed. - (setq buffer-auto-save-file-name nil) - (add-hook 'kill-buffer-hook 'viper-tut--save-tutorial nil t) - - ;; Insert the tutorial. First offer to resume last tutorial - ;; editing session. - (when dont-ask-for-revert - (setq old-tut-file nil)) - (when old-tut-file - (setq old-tut-file - (y-or-n-p - (format - "Resume your last saved Viper tutorial part %s? " - part)))) - (if old-tut-file - (progn - (insert-file-contents (viper-tut--saved-file)) - (goto-char (point-min)) - (setq old-tut-point - (string-to-number - (buffer-substring-no-properties - (line-beginning-position) (line-end-position)))) - (forward-line) - (setq tutorial--point-before-chkeys - (string-to-number - (buffer-substring-no-properties - (line-beginning-position) (line-end-position)))) - (forward-line) - (delete-region (point-min) (point)) - (goto-char tutorial--point-before-chkeys) - (setq tutorial--point-before-chkeys (point-marker))) - ;;(insert-file-contents (expand-file-name filename data-directory)) - (insert-file-contents filename) - (viper-tut--replace-links) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "'\\([][+a-zA-Z~<>!;,:.'\"%/?(){}$^0|-]\\)'" nil t) - (let ((matched-char (match-string 1)) - (inhibit-read-only t)) - (put-text-property 0 1 'vi-char t matched-char) - (put-text-property 0 1 'face '(:foreground "blue") matched-char) - (replace-match matched-char)))) - (forward-line) - (setq tutorial--point-before-chkeys (point-marker))) - - (viper-tut--add-remarks) - - (goto-char (point-min)) - (when old-tut-file - ;; Just move to old point in saved tutorial. - (let ((old-point - (if (> 0 old-tut-point) - (- old-tut-point) - (+ old-tut-point tutorial--point-after-chkeys)))) - (when (< old-point 1) - (setq old-point 1)) - (goto-char old-point))) - - (viper-tut-fix-header-and-footer) - - ;; Clear message: - (message "") (sit-for 0) - - (setq buffer-undo-list nil) - (set-buffer-modified-p nil)) - (setq buffer-read-only (= 0 part))))) - -;;(tutorial--find-changed-keys '((scroll-up [?\C-v]))) -(defun viper-tut--add-remarks() - ;; Check if there are key bindings that may disturb the - ;; tutorial. If so tell the user. - (let* ((tutorial--lang "English") - (changed-keys - (if (= viper-tut--part viper-tut--emacs-part) - (tutorial--find-changed-keys tutorial--default-keys) - (tutorial--find-changed-keys viper-tut--default-keys)))) - (viper-tut--display-changes changed-keys viper-tut--part)) - - (if (= viper-tut--part viper-tut--emacs-part) - (progn - (add-hook 'viper-vi-state-hook 'viper-tut--at-change-state nil t) - (add-hook 'viper-insert-state-hook 'viper-tut--at-change-state nil t) - (add-hook 'viper-replace-state-hook 'viper-tut--at-change-state nil t) - (add-hook 'viper-emacs-state-hook 'viper-tut--at-change-state nil t) - ) - (remove-hook 'viper-vi-state-hook 'viper-tut--at-change-state t) - (remove-hook 'viper-insert-statehook 'viper-tut--at-change-state t) - (remove-hook 'viper-replace-state-hook 'viper-tut--at-change-state t) - (remove-hook 'viper-emacs-state-hook 'viper-tut--at-change-state t) - )) - -(defun viper-tut-fix-header-and-footer () - (save-excursion - (goto-char (point-min)) - (add-text-properties (point) (1+ (line-end-position)) - '( read-only t face viper-tut-header)) - (goto-char (point-min)) - (viper-tut--insert-goto-row nil) - (goto-char (point-max)) - (viper-tut--insert-goto-row t))) - -(defun viper-tut--insert-goto-row(last) - (let ((start (point)) - end) - (insert " Go to part: ") - (dolist (rec viper-tut--parts) - (let ((n (nth 0 rec)) - (file (nth 1 rec)) - (title (nth 2 rec))) - (if (= n viper-tut--part) - (insert (format "%s" n)) - (insert-button (format "%s" n) - 'help-echo (concat "Go to part: " title) - 'follow-link t - 'action - `(lambda (button) - (viper-tutorial ,n t)))) - (insert " "))) - (insert " ") - (insert-button "Exit Tutorial" - 'help-echo "Exit tutorial and close tutorial buffer" - 'follow-link t - 'action - (lambda (button) - (kill-buffer (current-buffer)))) - (unless last (insert "\n")) - (setq end (point)) - (put-text-property start end 'local-map tutorial--tab-map) - (put-text-property start end 'tutorial-remark t) - (put-text-property start end - 'face 'viper-tut-header-top) - (put-text-property start end 'read-only t))) - -(defun viper-tut--replace-links() - "Replace markers for links with actual links." - (let ((re-links (regexp-opt '("VIPER-MANUAL" - "README-FILE" - "DIGIT-ARGUMENT" - "KILL-BUFFER" - "ISEARCH-FORWARD" - "UNIVERSAL-ARGUMENT" - "SEARCH-COMMANDS" - "R-AND-R" - "CUA-MODE" - "KEYBOARD-MACROS" - "VIPER-TOGGLE-KEY" - "* EMACS-NOTICE:"))) - (case-fold-search nil) - (inhibit-read-only t)) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward re-links nil t) - (let ((matched (match-string 0)) - start - end) - (replace-match "") - (setq start (point)) - (cond - ((string= matched "VIPER-TOGGLE-KEY") - (insert-button "viper-toggle-key" - 'action - (lambda(button) (interactive) - (describe-variable 'viper-toggle-key)) - 'follow-link t)) - ((string= matched "CUA-MODE") - (insert-button "cua-mode" - 'action - (lambda(button) (interactive) - (describe-function 'cua-mode)) - 'follow-link t)) - ((string= matched "ISEARCH-FORWARD") - (insert-button "isearch-forward" - 'action - (lambda(button) (interactive) - (describe-function 'isearch-forward)) - 'follow-link t)) - ((string= matched "KILL-BUFFER") - (insert-button "kill-buffer" - 'action - (lambda(button) (interactive) - (describe-function 'kill-buffer)) - 'follow-link t)) - ((string= matched "UNIVERSAL-ARGUMENT") - (insert-button "universal-argument" - 'action - (lambda(button) (interactive) - (describe-function 'universal-argument)) - 'follow-link t)) - ((string= matched "DIGIT-ARGUMENT") - (insert-button "digit-argument" - 'action - (lambda(button) (interactive) - (describe-function 'digit-argument)) - 'follow-link t)) - ((string= matched "* EMACS-NOTICE:") - (insert "* Emacs NOTICE:") - (while (progn - (forward-line 1) - (not (looking-at "^$")))) - (put-text-property start (point) - 'face '(:background - "#ffe4b5" - :foreground "#999999")) - (put-text-property start (point) 'read-only t) - ) - ((string= matched "SEARCH-COMMANDS") - (insert-button "search commands" - 'action - (lambda(button) (interactive) - (info-other-window "(emacs) Search") - (message "Type C-x 0 to close the new window")) - 'follow-link t)) - ((string= matched "KEYBOARD-MACROS") - (insert-button "keyboard macros" - 'action - (lambda(button) (interactive) - (info-other-window "(emacs) Keyboard Macros") - (message "Type C-x 0 to close the new window")) - 'follow-link t)) - ((string= matched "VIPER-MANUAL") - (insert-button "Viper manual" - 'action - (lambda(button) (interactive) - (info-other-window "(viper)") - (message "Type C-x 0 to close the new window")) - 'follow-link t)) - ((string= matched "R-AND-R") - (insert-button "r and R" - 'action - (lambda(button) (interactive) - (info-other-window "(viper) Basics") - (message "Type C-x 0 to close the new window")) - 'follow-link t)) - ((string= matched "README-FILE") - (insert-button "README file" - 'action - (lambda(button) (interactive) - (find-file-other-window (expand-file-name "README" viper-tut-directory)) - (message "Type C-x 0 to close the new window")) - 'follow-link t)) - (t - (error "Unmatched text: %s" matched))) - (put-text-property start (point) 'tutorial-remark t) - (put-text-property start (point) 'tutorial-orig matched) - (put-text-property start (point) 'local-map tutorial--tab-map) - (put-text-property start (point) 'read-only t)))))) - -(provide 'viper-tut) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; viper-tut.el ends here diff --git a/emacs.d/nxhtml/util/vline.el b/emacs.d/nxhtml/util/vline.el deleted file mode 100644 index 62bc8dd..0000000 --- a/emacs.d/nxhtml/util/vline.el +++ /dev/null @@ -1,350 +0,0 @@ -;;; vline.el --- show vertical line (column highlighting) mode. - -;; Copyright (C) 2002, 2008, 2009 by Taiki SUGAWARA <buzz.taiki@gmail.com> - -;; Author: Taiki SUGAWARA <buzz.taiki@gmail.com> -;; Keywords: faces, editing, emulating -;; Version: 1.09 -;; Time-stamp: <2009-10-12 16:55:13 UTC taiki> -;; URL: http://www.emacswiki.org/cgi-bin/wiki/vline.el - -;; This file is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. - -;;; Usage -;; put followings your .emacs -;; (require 'vline) -;; -;; if you display a vertical line, type M-x vline-mode. `vline-mode' doesn't -;; effect other buffers, because it is a buffer local minor mode. if you hide -;; a vertical line, type M-x vline-mode again. -;; -;; if you display a vertical line in all buffers, type M-x vline-global-mode. -;; -;; `vline-style' provides a display style of vertical line. see -;; `vline-style' docstring. -;; -;; if you don't want to visual line highlighting (ex. for performance issue), please to set `vline-visual' to nil. - -;;; Changes -;; 2009-08-26 taiki -;; support org-mode, outline-mode - -;; 2009-08-18 taiki -;; add autoload cookies. - -;; 2009-08-18 taiki -;; fix last line highlighting probrem. - -;; 2009-08-18 taiki -;; support visual line highlighting. -;; - Added face vline-visual. -;; - Added defcustom vline-visual-face. -;; - Added defcustom vline-visual. -;; -;; 2009-08-17 taiki -;; fix continuas line problem. -;; - Don't display vline when cursor into fringe -;; - Don't expand eol more than window width. -;; -;; 2008-10-22 taiki -;; fix coding-system problem. -;; - Added vline-multiwidth-space-list -;; - Use ucs code-point for japanese fullwidth space. -;; -;; 2008-01-22 taiki -;; applied patch from Lennart Borgman -;; - Added :group 'vline -;; - Added defcustom vline-current-window-only -;; - Added header items to simplify for users - -;;; TODO: -;; - track window-scroll-functions, window-size-change-functions. -;; - consider other minor modes (using {after,before}-string overlay). -;; - don't use {post,after}-command-hook for performance?? - -;;; Code: - -(defvar vline-overlay-table-size 200) -(defvar vline-overlay-table (make-vector vline-overlay-table-size nil)) -(defvar vline-line-char ?|) -(defvar vline-multiwidth-space-list - (list - ?\t - (decode-char 'ucs #x3000) ; japanese fullwidth space - )) - -(defcustom vline-style 'face - "*This variable holds vertical line display style. -Available values are followings: -`face' : use face. -`compose' : use composit char. -`mixed' : use face and composit char." - :type '(radio - (const face) - (const compose) - (const mixed)) - :group 'vline) - - -(defface vline - '((t (:background "light steel blue"))) - "*A default face for vertical line highlighting." - :group 'vline) - -(defface vline-visual - '((t (:background "gray90"))) - "*A default face for vertical line highlighting in visual lines." - :group 'vline) - -(defcustom vline-face 'vline - "*A face for vertical line highlighting." - :type 'face - :group 'vline) - -(defcustom vline-visual-face 'vline-visual - "*A face for vertical line highlighting in visual lines." - :type 'face - :group 'vline) - -(defcustom vline-current-window-only nil - "*If non-nil then show column in current window only. -If the buffer is shown in several windows then show column only -in the currently selected window." - :type 'boolean - :group 'vline) - -(defcustom vline-visual t - "*If non-nil then show column in visual lines. -If you specified `force' then use force visual line highlighting even -if `truncate-lines' is non-nil." - :type '(radio - (const nil) - (const t) - (const force)) - :group 'vline) - -;;;###autoload -(define-minor-mode vline-mode - "Display vertical line mode." - :global nil - :lighter " VL" - :group 'vline - (if vline-mode - (progn - (add-hook 'pre-command-hook 'vline-pre-command-hook nil t) - (add-hook 'post-command-hook 'vline-post-command-hook nil t)) - (vline-clear) - (remove-hook 'pre-command-hook 'vline-pre-command-hook t) - (remove-hook 'post-command-hook 'vline-post-command-hook t))) - -;;;###autoload -(define-minor-mode vline-global-mode - "Display vertical line mode as globally." - :global t - :lighter " VL" - :group 'vline - (if vline-global-mode - (progn - (add-hook 'pre-command-hook 'vline-global-pre-command-hook) - (add-hook 'post-command-hook 'vline-global-post-command-hook)) - (vline-clear) - (remove-hook 'pre-command-hook 'vline-global-pre-command-hook) - (remove-hook 'post-command-hook 'vline-global-post-command-hook))) - -(defun vline-pre-command-hook () - (when (and vline-mode (not (minibufferp))) - (vline-clear))) - -(defun vline-post-command-hook () - (when (and vline-mode (not (minibufferp))) - (vline-show))) - -(defun vline-global-pre-command-hook () - (when (and vline-global-mode (not (minibufferp))) - (vline-clear))) - -(defun vline-global-post-command-hook () - (when (and vline-global-mode (not (minibufferp))) - (vline-show))) - -(defun vline-clear () - (mapcar (lambda (ovr) - (and ovr (delete-overlay ovr))) - vline-overlay-table)) - -(defsubst vline-into-fringe-p () - (eq (nth 1 (posn-at-point)) 'right-fringe)) - -(defsubst vline-visual-p () - (or (eq vline-visual 'force) - (and (not truncate-lines) - vline-visual))) - -(defsubst vline-current-column () - (if (or (not (vline-visual-p)) - ;; margin for full-width char - (< (1+ (current-column)) (window-width))) - (current-column) - ;; hmm.. posn-at-point is not consider tab width. - (- (current-column) - (save-excursion - (vertical-motion 0) - (current-column))))) - -(defsubst vline-move-to-column (col &optional bol-p) - (if (or (not (vline-visual-p)) - ;; margin for full-width char - (< (1+ (current-column)) (window-width))) - (move-to-column col) - (unless bol-p - (vertical-motion 0)) - (let ((bol-col (current-column))) - (- (move-to-column (+ bol-col col)) - bol-col)))) - -(defsubst vline-forward (n) - (unless (memq n '(-1 0 1)) - (error "n(%s) must be 0 or 1" n)) - (if (not (vline-visual-p)) - (progn - (forward-line n) - ;; take care of org-mode, outline-mode - (when (and (not (bobp)) - (invisible-p (1- (point)))) - (goto-char (1- (point)))) - (when (invisible-p (point)) - (if (< n 0) - (while (and (not (bobp)) (invisible-p (point))) - (goto-char (previous-char-property-change (point)))) - (while (and (not (bobp)) (invisible-p (point))) - (goto-char (next-char-property-change (point)))) - (forward-line 1)))) - (vertical-motion n))) - -(defun vline-face (visual-p) - (if visual-p - vline-visual-face - vline-face)) - -(defun vline-show (&optional point) - (vline-clear) - (save-window-excursion - (save-excursion - (if point - (goto-char point) - (setq point (point))) - (let* ((column (vline-current-column)) - (lcolumn (current-column)) - (i 0) - (compose-p (memq vline-style '(compose mixed))) - (face-p (memq vline-style '(face mixed))) - (line-char (if compose-p vline-line-char ? )) - (line-str (make-string 1 line-char)) - (visual-line-str line-str) - (in-fringe-p (vline-into-fringe-p))) - (when face-p - (setq line-str (propertize line-str 'face (vline-face nil))) - (setq visual-line-str (propertize visual-line-str 'face (vline-face t)))) - (goto-char (window-end nil t)) - (vline-forward 0) - (while (and (not in-fringe-p) - (< i (window-height)) - (< i (length vline-overlay-table)) - (not (bobp))) - (let ((cur-column (vline-move-to-column column t)) - (cur-lcolumn (current-column))) - ;; non-cursor line only (workaround of eol probrem. - (unless (= (point) point) - ;; if column over the cursor's column (when tab or wide char is appered. - (when (> cur-column column) - (let ((lcol (current-column))) - (backward-char) - (setq cur-column (- cur-column (- lcol (current-column)))))) - (let* ((ovr (aref vline-overlay-table i)) - (visual-p (or (< lcolumn (current-column)) - (> lcolumn (+ (current-column) - (- column cur-column))))) - ;; consider a newline, tab and wide char. - (str (concat (make-string (- column cur-column) ? ) - (if visual-p visual-line-str line-str))) - (char (char-after))) - ;; create overlay if not found. - (unless ovr - (setq ovr (make-overlay 0 0)) - (overlay-put ovr 'rear-nonsticky t) - (aset vline-overlay-table i ovr)) - - ;; initialize overlay. - (overlay-put ovr 'face nil) - (overlay-put ovr 'before-string nil) - (overlay-put ovr 'after-string nil) - (overlay-put ovr 'invisible nil) - (overlay-put ovr 'window - (if vline-current-window-only - (selected-window) - nil)) - - (cond - ;; multiwidth space - ((memq char vline-multiwidth-space-list) - (setq str - (concat str - (make-string (- (save-excursion (forward-char) - (current-column)) - (current-column) - (string-width str)) - ? ))) - (move-overlay ovr (point) (1+ (point))) - (overlay-put ovr 'invisible t) - (overlay-put ovr 'after-string str)) - ;; eol - ((eolp) - (move-overlay ovr (point) (point)) - (overlay-put ovr 'after-string str) - ;; don't expand eol more than window width - (when (and (not truncate-lines) - (>= (1+ column) (window-width)) - (>= column (vline-current-column)) - (not (vline-into-fringe-p))) - (delete-overlay ovr))) - (t - (cond - (compose-p - (let (str) - (when char - (setq str (compose-chars - char - (cond ((= (char-width char) 1) - '(tc . tc)) - ((= cur-column column) - '(tc . tr)) - (t - '(tc . tl))) - line-char)) - (when face-p - (setq str (propertize str 'face (vline-face visual-p)))) - (move-overlay ovr (point) (1+ (point))) - (overlay-put ovr 'invisible t) - (overlay-put ovr 'after-string str)))) - (face-p - (move-overlay ovr (point) (1+ (point))) - (overlay-put ovr 'face (vline-face visual-p)))))))) - (setq i (1+ i)) - (vline-forward -1))))))) - -(provide 'vline) - -;;; vline.el ends here diff --git a/emacs.d/nxhtml/util/web-vcs-revision.txt b/emacs.d/nxhtml/util/web-vcs-revision.txt deleted file mode 100644 index 27943c8..0000000 --- a/emacs.d/nxhtml/util/web-vcs-revision.txt +++ /dev/null @@ -1 +0,0 @@ -321
diff --git a/emacs.d/nxhtml/util/whelp.el b/emacs.d/nxhtml/util/whelp.el deleted file mode 100644 index 77b8149..0000000 --- a/emacs.d/nxhtml/util/whelp.el +++ /dev/null @@ -1,988 +0,0 @@ -;; This is a test file for some enhancement to the possibilities to -;; find out about widgets or buttons at point in a buffer. -;; -;; To use this just load the file. Then put point on a widget or -;; button and do -;; -;; M-x describe-field -;; -;; You find a lot of widgets in a Custom buffer. You can find buttons -;; in for example a help buffer. (Please tell me more places so I can -;; test!) -;; -;; TODO: Add backtrace collecting to some more functions! - -;; For widget-get-backtrace-info -;;(require 'debug) -(eval-when-compile (require 'cl)) ;; gensym -(require 'help-mode) - -;; Last wins! -(require 'wid-browse) - -(intern ":created-in-function") - -(define-widget 'widget-browse-link 'item - "Button for creating a link style button. -The :value of the widget shuld be the widget to be browsed." - :format "%[%v%]" - ;;:value-create 'widget-browse-value-create - ;;:action 'widget-browse-action - ) - -(defun define-button-type (name &rest properties) - "Define a `button type' called NAME. -The remaining arguments form a sequence of PROPERTY VALUE pairs, -specifying properties to use as defaults for buttons with this type -\(a button's type may be set by giving it a `type' property when -creating the button, using the :type keyword argument). - -In addition, the keyword argument :supertype may be used to specify a -button-type from which NAME inherits its default property values -\(however, the inheritance happens only when NAME is defined; subsequent -changes to a supertype are not reflected in its subtypes)." - (let ((catsym (make-symbol (concat (symbol-name name) "-button"))) - (super-catsym - (button-category-symbol - (or (plist-get properties 'supertype) - (plist-get properties :supertype) - 'button)))) - ;; Provide a link so that it's easy to find the real symbol. - (put name 'button-category-symbol catsym) - ;; Initialize NAME's properties using the global defaults. - (let ((default-props (symbol-plist super-catsym)) - (where-fun (widget-get-backtrace-info 8))) - (setq default-props - (cons :created-in-function - (cons where-fun - default-props))) - (while default-props - (put catsym (pop default-props) (pop default-props)))) - ;; Add NAME as the `type' property, which will then be returned as - ;; the type property of individual buttons. - (put catsym 'type name) - ;; Add the properties in PROPERTIES to the real symbol. - (while properties - (let ((prop (pop properties))) - (when (eq prop :supertype) - (setq prop 'supertype)) - (put catsym prop (pop properties)))) - ;; Make sure there's a `supertype' property - (unless (get catsym 'supertype) - (put catsym 'supertype 'button)) - name)) - -(defun define-widget (name class doc &rest args) - "Define a new widget type named NAME from CLASS. - -NAME and CLASS should both be symbols, CLASS should be one of the -existing widget types, or nil to create the widget from scratch. - -After the new widget has been defined, the following two calls will -create identical widgets: - -* (widget-create NAME) - -* (apply 'widget-create CLASS ARGS) - -The third argument DOC is a documentation string for the widget." - (put name 'widget-type (cons class args)) - (put name 'widget-documentation doc) - (put name :created-in-function (widget-get-backtrace-info 8)) - name) - -(defvar describe-temp-help-buffer nil) -(defun describe-get-temp-help-buffer () - (setq describe-temp-help-buffer (get-buffer-create "*Copy of *Help* Buffer for Description*"))) - -(defun describe-field (pos) - "Describe field at marker POS." - (interactive (list (point))) - (unless (markerp pos) (setq pos (copy-marker pos))) - (when (eq (marker-buffer pos) (get-buffer (help-buffer))) - (with-current-buffer (describe-get-temp-help-buffer) - (erase-buffer) - (insert (with-current-buffer (help-buffer) - (buffer-string))) - (goto-char (marker-position pos)) - (setq pos (point-marker)))) - (let (field wbutton doc button widget) - (with-current-buffer (marker-buffer pos) - (setq field (get-char-property pos 'field)) - (setq wbutton (get-char-property pos 'button)) - (setq doc (get-char-property pos 'widget-doc)) - (setq button (button-at pos)) - (setq widget (or field wbutton doc))) - (cond ((and widget - (if (symbolp widget) - (get widget 'widget-type) - (and (consp widget) - (get (widget-type widget) 'widget-type)))) - (describe-widget pos)) - (button - (describe-button pos)) - ((and (eq major-mode 'Info-mode) - (memq (get-text-property pos 'font-lock-face) - '(info-xref info-xref-visited))) - (message "info link")) - (t - (message "No widget or button at point"))))) - -(defun describe-insert-header (pos) - (widget-insert - (add-string-property - (concat - (format "Description of the field at position %d in " - (marker-position pos)) - (format "\"%s\"" (marker-buffer pos)) - ":\n\n") - 'face '(italic)))) - -(defun describe-widget (pos) - ;;(interactive (list (point-marker))) - (unless (markerp pos) (setq pos (copy-marker pos))) - (with-output-to-temp-buffer (help-buffer) - (help-setup-xref (list #'describe-widget pos) (interactive-p)) - (with-current-buffer (help-buffer) - (let ((inhibit-read-only t)) - (describe-insert-header pos) - (insert-text-button "This field" - 'action (lambda (button) - (let* ((m (button-get button 'field-location)) - (p (marker-position m)) - (b (marker-buffer m))) - (if (not (buffer-live-p b)) - (message "Sorry the markers buffer is gone") - (switch-to-buffer b) - (goto-char p)))) - 'field-location pos) - (princ " is of type ") - (insert-text-button "widget" - 'action (lambda (button) - (info "(widget)"))) - (princ ". You can ") - (insert-text-button "browse the widget's properties" - 'action (lambda (button) - (widget-browse-at - (button-get button 'field-location))) - 'field-location pos)) - (princ " to find out more about it.") - (fill-region (point-min) (point-max)) - ) - (with-no-warnings (print-help-return-message)))) - -(defun describe-button (pos) - (let ((button (button-at pos))) - (with-output-to-temp-buffer (help-buffer) - (help-setup-xref (list #'describe-button pos) (interactive-p)) - (with-current-buffer (help-buffer) - (let ((inhibit-read-only t) - ;;(button-marker (gensym)) - ) - (describe-insert-header pos) - (insert-text-button "This field" - 'action (lambda (button) - (let* ((m (button-get button 'field-location)) - (p (marker-position m)) - (b (marker-buffer m))) - (switch-to-buffer b) - (goto-char p))) - 'field-location pos) - (princ " is of type ") - (insert-text-button "button" - 'action (lambda (button) - (info "(elisp) Buttons"))) - (princ ". You can ") - ;;(set button-marker pos) - (insert-text-button "browse the button's properties" - 'action `(lambda (button) - ;;(button-browse-at (symbol-value ',button-marker))))) - (button-browse-at ,pos)))) - (princ " to find out more about it.") - (fill-region (point-min) (point-max)) - ) - (with-no-warnings (print-help-return-message))))) - -;; Obsolete -;; (defun whelp-describe-symbol (sym) -;; (interactive "SSymbol: ") -;; (with-output-to-temp-buffer (help-buffer) -;; (help-setup-xref (list #'describe-symbol sym) (interactive-p)) -;; (with-current-buffer (help-buffer) -;; (let ((inhibit-read-only t)) -;; (if (not (symbolp sym)) -;; (progn -;; (princ "Argument does not look like it is a ") -;; (insert-text-button "symbol" -;; 'action (lambda (button) -;; (info "(elisp) Symbols"))) -;; (princ ".")) -;; (let ((n 0)) -;; (when (fboundp sym) (setq n (1+ n))) -;; (when (boundp sym) (setq n (1+ n))) -;; (when (facep sym) (setq n (1+ n))) -;; (when (custom-group-p sym) (setq n (1+ n))) -;; (if (= n 0) -;; (progn -;; (princ "Can't determine usage for the ") -;; (insert-text-button "symbol" -;; 'action (lambda (button) -;; (info "(elisp) Symbols"))) -;; (princ " '") -;; (princ (symbol-name sym)) -;; (princ ".")) -;; (princ "The ") -;; (insert-text-button "symbol" -;; 'action (lambda (button) -;; (info "(elisp) Symbols"))) -;; (princ " '") -;; (princ (symbol-name sym)) -;; (if (= n 1) -;; (progn -;; (princ " is a ") -;; (cond ((fboundp sym) -;; (princ "function (") -;; (insert-text-button -;; "describe it" -;; 'action (lambda (button) -;; (let ((value (button-get button 'value))) -;; (describe-function value))) -;; 'value sym) -;; (insert ")")) -;; ((boundp sym) -;; (insert "variable (") -;; (insert-text-button -;; "describe it" -;; 'action (lambda (button) -;; (let ((value (button-get button 'value))) -;; (describe-variable value))) -;; 'value sym) -;; (insert ")")) -;; ((facep sym) -;; (insert "face (") -;; (insert-text-button -;; "describe it" -;; 'action (lambda (button) -;; (let ((value (button-get button 'value))) -;; (describe-face value))) -;; 'value sym) -;; (insert ")")) -;; ((custom-group-p sym) -;; (insert "customize group (") -;; (insert-text-button -;; "customize it" -;; 'action (lambda (button) -;; (let ((value (button-get button 'value))) -;; (customize-group value))) -;; 'value sym) -;; (insert ")"))) -;; (princ ".")) -;; (princ " has several usages currently.") -;; (princ " It can be:\n\n") -;; (when (fboundp sym) -;; (princ " - A function (") -;; (insert-text-button "describe it" -;; 'action (lambda (button) -;; (let ((value (button-get button 'value))) -;; (describe-function value))) -;; 'value sym) -;; (princ ")\n")) -;; (when (boundp sym) -;; (princ " - A variable (") -;; (insert-text-button "describe it" -;; 'action (lambda (button) -;; (let ((value (button-get button 'value))) -;; (describe-variable value))) -;; 'value sym) -;; (princ ")\n")) -;; (when (facep sym) -;; (princ " - A face (") -;; (insert-text-button "describe it" -;; 'action (lambda (button) -;; (let ((value (button-get button 'value))) -;; (describe-face value))) -;; 'value sym) -;; (princ ")\n")) -;; (when (custom-group-p sym) -;; (princ " - A customization group (") -;; (insert-text-button "customize it" -;; 'action (lambda (button) -;; (let ((value (button-get button 'value))) -;; (customize-group value))) -;; 'value sym) -;; (princ ")\n")) -;; ))) -;; (princ "\n\nSymbol's property list:\n\n") -;; (let ((pl (symbol-plist sym)) -;; key -;; val) -;; (princ (format " %25s %s\n" "Key" "Value")) -;; (princ (format " %25s %s\n" "---" "-----")) -;; (while pl -;; (setq key (car pl)) -;; (setq pl (cdr pl)) -;; (setq val (car pl)) -;; (setq pl (cdr pl)) -;; (let ((first (point-marker)) -;; last) -;; (princ (format " %25s - %s" key val)) -;; (setq last (point-marker)) -;; (let ((adaptive-fill-function -;; (lambda () -;; (format " %25s - " key)))) -;; (fill-region first last) -;; )) -;; (princ "\n") -;; ))) -;; (with-no-warnings (print-help-return-message)))))) - - - -(defun widget-browse-sexp (widget key value) - "Insert description of WIDGET's KEY VALUE. -Nothing is assumed about value." - (let ((pp (condition-case signal - (pp-to-string value) - (error (prin1-to-string signal))))) - (when (string-match "\n\\'" pp) - (setq pp (substring pp 0 (1- (length pp))))) - (if (cond ((string-match "\n" pp) - nil) - ((> (length pp) (- (window-width) (current-column))) - nil) - (t t)) - (cond - ( (and value - (symbolp value) - (or (fboundp value) - (boundp value) - (facep value))) - (widget-create 'push-button - :tag pp - :value value - :action '(lambda (widget &optional event) - (let ((value (widget-get widget :value)) - (n 0)) - (when (fboundp value) (setq n (1+ n))) - (when (boundp value) (setq n (1+ n))) - (when (facep value) (setq n (1+ n))) - (if (= n 1) - (cond ((fboundp value) - (describe-function value)) - ((boundp value) - (describe-variable value)) - ((facep value) - (describe-face value))) - (describe-symbol value)))))) - ( (markerp value) - (widget-create 'push-button - :tag pp - :value (list (marker-position value) (marker-buffer value)) - :action '(lambda (widget &optional event) - (let ((value (widget-get widget :value))) - (let ((pos (car value)) - (buf (cadr value))) - (switch-to-buffer-other-window buf) - (goto-char pos)))))) - ( (overlayp value) - (widget-create 'push-button - :tag pp - :value (list (overlay-start value) (overlay-buffer value)) - :action '(lambda (widget &optional event) - (let ((value (widget-get widget :value))) - (let ((pos (car value)) - (buf (cadr value))) - (switch-to-buffer-other-window buf) - (goto-char pos)))))) - ( t - (widget-insert pp))) - - (widget-create 'push-button - :tag "show" - :action (lambda (widget &optional event) - (with-output-to-temp-buffer - "*Pp Eval Output*" - (princ (widget-get widget :value)))) - pp)))) - - -(defvar widget-get-backtrace-active t - "Whether to collect backtrace info for widgets and buttons. -Turn this on only for debugging purposes. - -Note: This must be t when Emacs is loading to collect the needed -information.") - -(defun widget-get-backtrace-info (n) - (if widget-get-backtrace-active - (let ((frame-n t) - fun) - (while (and frame-n - (not fun)) - (setq frame-n (backtrace-frame n)) - (when frame-n - ;;(message "**BT %s: %s" n (cadr frame-n)) - (when (car frame-n) - (setq fun (cadr frame-n)) - (when (or (listp fun) - (member fun - '( - backtrace-frame - widget-get-backtrace-info - - eval - eval-expression - call-interactively - apply - funcall - ;;lambda - - if - when - cond - condition - mapc - mapcar - while - - let - let* - set - setq - set-variable - set-default - - widget-create - widget-create-child-and-convert - widget-create-child - widget-create-child-value - define-button-type - define-widget - make-text-button - insert-text-button - make-button - insert-button - ))) - (setq fun))) - (setq n (1+ n)))) - ;;(message "---------- fun=%s" fun) - fun) - "Set widget-get-backtrace-info to show this")) - -(defun widget-create (type &rest args) - "Create widget of TYPE. -The optional ARGS are additional keyword arguments." - (unless (keywordp :created-in-function) (error ":wcw not interned")) - (let ((where-fun (widget-get-backtrace-info 8)) - yargs) - (setq args - (cons :created-in-function - (cons where-fun - args))) - (let ((widget (apply 'widget-convert type args))) - (widget-apply widget :create) - widget))) - - -(defun widget-create-child-and-convert (parent type &rest args) - "As part of the widget PARENT, create a child widget TYPE. -The child is converted, using the keyword arguments ARGS." - (let ((widget (apply 'widget-convert type args))) - (widget-put widget :parent parent) - (widget-put widget :created-in-function (widget-get-backtrace-info 15)) - (unless (widget-get widget :indent) - (widget-put widget :indent (+ (or (widget-get parent :indent) 0) - (or (widget-get widget :extra-offset) 0) - (widget-get parent :offset)))) - (widget-apply widget :create) - widget)) - -(defun widget-create-child (parent type) - "Create widget of TYPE." - (let ((widget (widget-copy type))) - (widget-put widget :parent parent) - (widget-put widget :created-in-function (widget-get-backtrace-info 15)) - (unless (widget-get widget :indent) - (widget-put widget :indent (+ (or (widget-get parent :indent) 0) - (or (widget-get widget :extra-offset) 0) - (widget-get parent :offset)))) - (widget-apply widget :create) - widget)) - -(defun widget-create-child-value (parent type value) - "Create widget of TYPE with value VALUE." - (let ((widget (widget-copy type))) - (widget-put widget :value (widget-apply widget :value-to-internal value)) - (widget-put widget :parent parent) - (widget-put widget :created-in-function (widget-get-backtrace-info 15)) - (unless (widget-get widget :indent) - (widget-put widget :indent (+ (or (widget-get parent :indent) 0) - (or (widget-get widget :extra-offset) 0) - (widget-get parent :offset)))) - (widget-apply widget :create) - widget)) - -(defvar widget-browse-fb-history nil - "Forward/backward history.") -(setq widget-browse-fb-history nil) - -(defun widget-fb-button-action (widget &ignore) - (let* ((num (widget-get widget :history-number)) - (rec (nth num widget-browse-fb-history)) - (fun (nth 0 rec)) - (val (nth 1 rec)) - (loc (nth 2 rec))) - ;;(message "fun=%s, val=%s, loc=%s" fun val loc)(sit-for 4) - (funcall fun num))) - -(defun widget-insert-fb-buttons (current-number) - ;;(message "current-number=%s" current-number)(sit-for 2) - (if (<= 0 (1- current-number)) - (widget-create 'push-button - :action 'widget-fb-button-action - :history-number (1- current-number) - :format "%[%v%]" - "back") - (widget-insert (add-string-property "[back]" - 'face 'shadow))) - (widget-insert " ") - (if (< (1+ current-number) (length widget-browse-fb-history)) - (widget-create 'push-button - :action 'widget-fb-button-action - :history-number (1+ current-number) - :format "%[%v%]" - "forward") - (widget-insert (add-string-property "[forward]" - 'face 'shadow))) - (widget-insert "\n")) - -(defun widget-add-fb-history (elt) - (let ((last (car widget-browse-fb-history))) - (unless (equal elt last) - (setq widget-browse-fb-history - (reverse (cons elt - (reverse widget-browse-fb-history))))))) - -(defun widget-browse (widget &optional location) - "Create a widget browser for WIDGET." - (interactive (list (completing-read "Widget: " - obarray - (lambda (symbol) - (get symbol 'widget-type)) - t nil 'widget-browse-history))) - (let (history-number) - (if (integerp widget) - (progn - ;;(message "was integer=%s" widget)(sit-for 2) - (setq history-number widget) - (setq widget (nth 1 (nth widget widget-browse-fb-history)))) - ;;(message "was NOT integer=%s" widget)(sit-for 2) - (widget-add-fb-history (list 'widget-browse widget location)) - (setq history-number (1- (length widget-browse-fb-history)))) - ;;(message "history-number=%s" history-number)(sit-for 2) - - (if (stringp widget) - (setq widget (intern widget))) - (unless (if (symbolp widget) - (get widget 'widget-type) - (and (consp widget) - (get (widget-type widget) 'widget-type))) - (error "Not a widget")) - - ;; Create the buffer. - (if (symbolp widget) - (let ((buffer (format "*Browse %s Widget*" widget))) - (kill-buffer (get-buffer-create buffer)) - (switch-to-buffer (get-buffer-create buffer))) - (kill-buffer (get-buffer-create "*Browse Widget*")) - (switch-to-buffer (get-buffer-create "*Browse Widget*"))) - (widget-browse-mode) - - (make-local-variable 'widget-button-face) - (setq widget-button-face 'link) - (set (make-local-variable 'widget-push-button-prefix) "") - (set (make-local-variable 'widget-push-button-suffix) "") - (set (make-local-variable 'widget-link-prefix) "") - (set (make-local-variable 'widget-link-suffix) "") - - ;; Top text indicating whether it is a class or object browser. - (widget-insert-fb-buttons history-number) - (widget-insert "----------------\n") - (if (listp widget) - (progn - (widget-insert (add-string-property - "Widget object browser" - 'face 'widget-browse-h1)) - (widget-insert "\n\n") - (when location - (let ((b (marker-buffer location)) - (p (marker-position location))) - (widget-insert (add-string-property "Location: " - 'face 'italic)) - (widget-create 'push-button - :tag (format "position %s in buffer %s" p b) - :value (list p b) - :action '(lambda (widget &optional event) - (let ((value (widget-get widget :value))) - (let ((pos (car value)) - (buf (cadr value))) - (switch-to-buffer-other-window buf) - (goto-char pos))))) - (widget-insert "\n\n"))) - (widget-insert (add-string-property "Class: " - 'face 'italic))) - (widget-insert (add-string-property "Widget class browser" - 'face 'widget-browse-h1)) - (widget-insert ".\n\n") - (widget-insert (add-string-property "Class: " 'face 'italic)) - (widget-insert (add-string-property (format "%s\n" widget) - 'face '(bold))) - (widget-insert (format "%s" (get widget 'widget-documentation))) - (unless (eq (preceding-char) ?\n) (widget-insert "\n")) - (widget-insert (add-string-property "\nSuper: " 'face 'italic)) - (setq widget (get widget 'widget-type)) - ) - - ;(widget-insert (format "%s\n" widget)) - - ;; Now show the attributes. - (let ((name (car widget)) - (items (cdr widget)) - key value printer) - (if (not name) - (widget-insert "none\n") - (let ((ancestors (list name)) - a - (i1 7) - i - ) - (setq i i1) - (while name - (setq a (intern-soft name)) - (if a - (progn - (setq a (get a 'widget-type)) - (setq name (car a)) - (when (intern-soft name) - (push name ancestors))) - (setq name))) - ;;(widget-insert (format "ancestors=%s\n" ancestors)) - (mapc (lambda (w) - (widget-insert (make-string (if (= i i1) 0 i) ? )) - (widget-create 'widget-browse - :format "%[%v%]" - w) - (widget-insert "\n") - (setq i (+ i 2))) - ancestors))) - (while items - (setq key (nth 0 items) - value (nth 1 items) - printer (or (get key 'widget-keyword-printer) - 'widget-browse-sexp) - items (cdr (cdr items))) - (widget-insert "\n" - (add-string-property (symbol-name key) - 'face 'italic)) - (when (widget-browse-explained key) - (widget-insert " (") - (widget-create - ;;'push-button - ;;:tag "explain" - ;;:format "%[%v%]" - ;;:button-prefix "" - ;;:button-suffix "" - 'widget-browse-link - :value key - :tag "explain" - :format "%[%t%]" - :action '(lambda (widget &optional event) - (widget-browse-explain - ;;(widget-get widget :value) - (widget-value widget) - )) - ) - (widget-insert ")")) - (widget-insert "\n\t") - (funcall printer widget key value) - (widget-insert "\n"))) - - (widget-insert "\n-----------\n") - (widget-insert-fb-buttons history-number) - - (widget-setup) - (goto-char (point-min)) -;; (when wid-to-history -;; (setq widget-browse-fb-history -;; (reverse (cons (list 'widget-browse wid-to-history location) -;; (reverse widget-browse-fb-history))))) - )) - -(defun widget-browse-at (pos) - "Browse the widget under point." - (interactive "d") - (let ((mp pos) - (b (if (markerp pos) (marker-buffer pos) - (current-buffer)))) - (if (not (buffer-live-p b)) - (message "Sorry the markers buffer is gone") - (with-current-buffer b - (when (markerp pos) - (setq pos (marker-position pos))) - (let* ((field (get-char-property pos 'field)) - (button (get-char-property pos 'button)) - (doc (get-char-property pos 'widget-doc)) - (text (cond (field "This is an editable text area.") - (button "This is an active area.") - (doc "This is documentation text.") - (t "This is unidentified text."))) - (widget (or field button doc))) - (when widget - (widget-browse widget mp)) - (message text)))))) - -(defun button-at (pos) - "Return the button at marker or position POS, or nil. -If not a marker use the current buffer." - (with-current-buffer (if (markerp pos) (marker-buffer pos) - (current-buffer)) - (when (markerp pos) - (setq pos (marker-position pos))) - (let ((button (get-char-property pos 'button))) - (if (or (overlayp button) (null button)) - button - ;; Must be a text-property button; return a marker pointing to it. - (copy-marker pos t))))) - -(defun button-browse-at (pos) - (interactive "d") - (let ((b (if (markerp pos) (marker-buffer pos) - (current-buffer)))) - (if (not (buffer-live-p b)) - (message "Sorry the button's buffer is gone") - (button-browse (button-at pos))))) - -(defun button-browse (button) - "Create a widget browser for WIDGET." - (interactive (list (completing-read "Button: " - obarray - (lambda (symbol) - (or (get symbol 'button-category-symbol) - (get symbol 'supertype))) - t nil 'button-browse-history))) - (let (history-number) - (if (integerp button) - (progn - (setq history-number button) - (setq button (nth 1 (nth button widget-browse-fb-history)))) - (widget-add-fb-history (list 'button-browse button)) - (setq history-number (1- (length widget-browse-fb-history)))) - - (when (stringp button) - (setq button (intern-soft button))) - (when (symbolp button) - (unless (and button - (or (eq button 'default-button) - (get button 'supertype) - (get button 'button-category-symbol) - (save-match-data - (string-match "-button$" (symbol-name button))))) - (error "Not a button"))) - ;; Create the buffer. - (kill-buffer (get-buffer-create "*Browse Button*")) - (switch-to-buffer (get-buffer-create "*Browse Button*")) - (widget-browse-mode) - - (make-local-variable 'widget-button-face) - (setq widget-button-face 'link) - - (widget-insert-fb-buttons history-number) - (widget-insert "----------------\n") - - ;; Top text indicating whether it is a class or object browser. - (if (or (overlayp button) - (markerp button)) - (progn - (widget-insert (add-string-property "Button object browser" - 'face 'widget-browse-h1)) - (widget-insert "\n\n") - (let ((b (if (markerp button) - (marker-buffer button) - (overlay-buffer button))) - (p (if (markerp button) - (marker-position button) - (overlay-start button)))) - (widget-insert (add-string-property "Location: " - 'face 'italic)) - (widget-create 'push-button - :tag (format "position %s in buffer %s" p b) - :value (list p b) - :action '(lambda (widget &optional event) - (let ((value (widget-get widget :value))) - (let ((pos (car value)) - (buf (cadr value))) - (switch-to-buffer-other-window buf) - (goto-char pos))))) - (widget-insert "\n\n"))) - (widget-insert (add-string-property "Button class browser" - 'face 'widget-browse-h1)) - (widget-insert "\n\n") - (widget-insert (add-string-property "Type: " - 'face 'italic)) - (widget-insert (add-string-property (symbol-name button) - 'face 'bold)) - (widget-insert "\n")) - - ;; Now show the attributes. - (let ( - (items - (if (symbolp button) - (if (get button 'button-category-symbol) - (symbol-plist (get button 'button-category-symbol)) - (symbol-plist button)) - (if (markerp button) - (let ((pos (marker-position button)) - (buf (marker-buffer button))) - (text-properties-at pos buf)) - (overlay-properties button)))) - rest-items - name - key value printer) - ;;(insert (format "\n%s\n\n" items)) - (let ((copied-items (copy-seq items))) - (while copied-items - (setq key (nth 0 copied-items) - value (nth 1 copied-items) - copied-items (cdr (cdr copied-items))) - (if (eq key 'category) - (setq name value) - (if (eq key 'supertype) - (setq name (make-symbol (concat (symbol-name value) "-button"))) - (push value rest-items) - (push key rest-items))))) - ;;(insert "\nname=" (symbol-name value) "\n\n") - (when name - (widget-insert (add-string-property - (if (symbolp button) - (if (get button 'supertype) - "Supertype: " - "") - "Category: ") - 'face 'italic)) - (let* (a - (ancestors - (list name)) - (i1 11) - (i i1)) - (while name - (setq a (or (get name 'supertype) - (get name :supertype))) - ;;(message "name=%s, a=%s\n name plist=%s" name a (symbol-plist name));(sit-for 4) - (if (or (not a) - (eq a 'default-button)) - (setq name) - (setq name (make-symbol (concat (symbol-name a) "-button"))) - (setq ancestors (cons name ancestors)))) - ;;(message "ancestors=%s" ancestors)(sit-for 2) - (mapc (lambda (w) - (widget-insert (make-string (if (= i i1) 0 i) ? )) - (widget-create 'button-browse - :format "%[%v%]" - w) - (widget-insert "\n") - (setq i (+ i 2))) - ancestors))) - (while rest-items - (setq key (nth 0 rest-items) - value (nth 1 rest-items) - printer (or (get key 'widget-keyword-printer) - 'widget-browse-sexp) - rest-items (cdr (cdr rest-items))) - (widget-insert "\n" - (add-string-property (symbol-name key) - 'face 'italic)) - (when (widget-browse-explained key) - (widget-insert " (") - (widget-create 'push-button - :tag "explain" - :value key - :action '(lambda (widget &optional event) - (widget-browse-explain - (widget-get widget :value)))) - (widget-insert ")")) - (widget-insert "\n\t") - (funcall printer button key value) - (widget-insert "\n"))) - (widget-setup) - (goto-char (point-min)) - -;; (when button-to-history -;; (setq widget-browse-fb-history -;; (reverse (cons (list 'button-browse button-to-history) -;; (reverse widget-browse-fb-history))))) - )) - - -;;;###autoload -(defgroup whelp nil - "Customization group for whelp." - :group 'emacs) - -(defface widget-browse-h1 - '((t (:weight bold :height 1.5))) - "Face for top header in widget/button browse buffers." - :group 'whelp) - -(defun add-string-property (str prop val) - (let ((s (copy-seq str))) - (put-text-property 0 (length s) - prop val - s) - s)) - -;;; The `button-browse' Widget. - -(define-widget 'button-browse 'push-button - "Widget button for creating a button browser. -The :value of the widget shuld be the button to be browsed." - :format "%[[%v]%]" - :value-create 'widget-browse-button-value-create - :action 'widget-browse-button-action) - -(defun widget-browse-button-action (widget &optional event) - ;; Create widget browser for WIDGET's :value. - (button-browse (widget-get widget :value))) - -(defun widget-browse-button-value-create (widget) - ;; Insert type name. - (let ((value (widget-get widget :value))) - (cond ((symbolp value) - (insert (symbol-name value))) - ((consp value) - (insert (symbol-name (widget-type value)))) - (t - (insert "strange"))))) - - -(defun widget-browse-explained (property) - (memq property - '( - :created-in-function - ))) - -(defun widget-browse-explain (property) - (with-output-to-temp-buffer (help-buffer) - (help-setup-xref (list #'widget-browse-explain property) (interactive-p)) - (with-current-buffer (help-buffer) - (let ((inhibit-read-only t)) - (cond - ( (eq property :created-in-function) - (princ "Property :created-in-function tells where a field object or class is created.") - ) - ( t - (princ (format "No explanation found for %s" property)) - ) - ) - (with-no-warnings (print-help-return-message)))))) - -(provide 'whelp) diff --git a/emacs.d/nxhtml/util/winsav.el b/emacs.d/nxhtml/util/winsav.el deleted file mode 100644 index 771f6ce..0000000 --- a/emacs.d/nxhtml/util/winsav.el +++ /dev/null @@ -1,1585 +0,0 @@ -;;; winsav.el --- Save and restore window structure -;; -;; Author: Lennart Borgman -;; Created: Sun Jan 14 2007 -(defconst winsav:version "0.77") ;;Version: 0.77 -;; Last-Updated: 2009-08-04 Tue -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; This library contains both user level commands and options and -;; functions for use in other elisp libraries. -;; -;;;; User level commands and options -;; -;; The user level commands and options are for saving frame, windows -;; and buffers between Emacs sessions. To do that you can customize -;; the options `desktop-save-mode' and `winsav-save-mode' or put this -;; at the end of your .emacs: -;; -;; (desktop-save-mode 1) -;; (winsav-save-mode 1) -;; -;; You can also save configurations that you later switch between. -;; For more information see the command `winsav-save-mode'. -;; -;; (There is also a command in this library for rotating window -;; borders in a frame, `winsav-rotate'. It is here just because the -;; needed support functions lives here.) -;; -;; -;; -;;;; Commands for other elisp libraries -;; -;; This library was orignally written to solve the problem of adding a -;; window to the left of some windows in a frame like the one below -;; -;; ___________ -;; | | | -;; | 1 | 2 | -;; |____|____| -;; | | -;; | 3 | -;; |_________| -;; -;; so that the window structure on the frame becomes -;; -;; ___________ -;; | | | | -;; | | 1| 2 | -;; | B|__|___| -;; | A| | -;; | R| 3 | -;; |__|______| -;; -;; -;; This problem can be solved by this library. However the solution in -;; this library is a bit more general: You first copy the window -;; structure and then restore that into another window. To do the -;; above you first copy the window structure in the first frame above -;; with `winsav-get-window-tree'. Then you create windows like this: -;; -;; ___________ -;; | | | -;; | | | -;; | B| | -;; | A| | -;; | R| | -;; |__|______| -;; -;; -;; Finally you use `winsav-put-window-tree' to put the window -;; structure into the right window. (Of course you could have put BAR -;; above, under etc.) -;; -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Bugs and limitations: -;; -;; Juanma Barranquero has pointed out there is a serious limitation in -;; this way of doing it when overlays with 'window properties are -;; used. The problem is that any pointers to windows are made invalid -;; since they are deleted. So in fact any code that relies on saved -;; pointers to windows will have problem if the window is one of those -;; that are involved here. -;; -;; To overcome this problem when doing something like inserting a BAR -;; window (see above) a new window has to be inserted in the existing -;; window tree on a frame in a way that is currently not supported in -;; Emacs. -;; -;; It would be nice to be have primitives to manipulate the window -;; tree more generally from elisp. That requires implementation of -;; them at the C level of course. -;; -;; However it is probably much easier to implement it quite a bit less -;; general. The concept of splitting is maybe then the right level to -;; search for primitives at. -;; -;; My conclusion is that it will take some time to find suitable -;; primitives for this. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; Version 0.72: -;; -;; - Format of window structure changed in Emacs 23. Adopted to that. -;; - Added save and restore of frame/window configurations between -;; Emacs sessions. -;; - Added named winsav configurations for save and restore of frames, -;; windows, buffers and files. -;; -;; Version 0.71: -;; -;; - Added rotation of window structure. -;; -;; Version 0.70: -;; -;; - Support for save and restore from file. -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - - -(eval-when-compile (require 'cl)) -(eval-and-compile (require 'desktop)) - -;; (defun winsav-upper-left-window(&optional frame w) -;; (let* ((tree (if w w (car (window-tree frame)))) -;; (is-split (not (windowp tree)))) -;; (if (not is-split) -;; tree -;; (winsav-upper-left-window frame (nth 2 tree))))) - - -(defcustom winsav-after-get-hook nil - "Hook to run after at the end of `winsav-get-window-tree'. -The functions in this hook are called with one parameter which is -the same as the return value from the function above." - :type 'hook - :group 'winsav) - -(defcustom winsav-after-put-hook nil - "Hook to run after at the end of `winsav-put-window-tree'. -The functions in this hook are called with one parameter which is -a list where each element is a list \(old-win new-win) where -OLD-WIN are the window from `winsav-get-window-tree' and NEW-WIN -is the newly created corresponding window. This list is the same -as the return value from the function above." - :type 'hook - :group 'winsav) - -(defun winsav-get-window-tree(&optional frame) - "Get window structure. -This returns an object with current windows with values, buffers, -points and the selected window. - -FRAME is the frame to save structure from. If nil use selected. - -At the very end of this function the hook `winsav-after-get' is -run." - ;;(let* ((upper-left (winsav-upper-left-window frame)) - (let* ((upper-left (frame-first-window frame)) - (num -1) - sel-num) - (dolist (w (window-list frame nil upper-left)) - (setq num (1+ num)) - (when (eq w (selected-window)) - (setq sel-num num))) - (let ((ret (list sel-num - (winsav-get-window-tree-1 frame nil)))) - (run-hook-with-args 'winsav-after-get-hook ret) - ret))) - -;; Fix-me: add window-hscroll -(defun winsav-get-window-tree-1(frame w) - (let ((tree (if w w (car (window-tree frame))))) - (if (windowp tree) - ;; Note: Desktop is used for saving buffers. - (with-current-buffer (window-buffer tree) - (list (window-buffer tree) - ;; buffer - (buffer-name) - (buffer-file-name) - ;;buffer-read-only - ;;(if mumamo-multi-major-mode mumamo-multi-major-mode major-mode) - ;;minor-modes - ;;buffer locals - ;;(cons (+ 0 (mark-marker)) (mark-active)) - ;; window - (window-point tree) - (window-edges tree) - (window-scroll-bars tree) - (window-fringes tree) - (window-margins tree) - (window-hscroll tree) - ;; misc - (window-dedicated-p tree) - (when (fboundp 'window-redisplay-end-trigger) - (window-redisplay-end-trigger tree)) - (window-start tree) - tree)) - (let* ((dir (nth 0 tree)) - (split (nth 1 tree)) - (wt (cddr tree)) - (wsubs (mapcar (lambda(wc) - (winsav-get-window-tree-1 nil wc)) - wt))) - (append (list dir split) wsubs))))) - -;;;###autoload -(defun winsav-put-window-tree (saved-tree window &optional copy-win-ovl win-ovl-all-bufs) - "Put window structure SAVED-TREE into WINDOW. -Restore a structure SAVED-TREE returned from -`winsav-get-window-tree' into window WINDOW. - -If COPY-WIN-OVL is non-nil then overlays having a 'window -property pointing to one of the windows in SAVED-TREE where this -window still is shown will be copied to a new overlay with -'window property pointing to the corresponding new window. - -If WIN-OVL-ALL-BUFS is non-nil then all buffers will be searched -for overlays with a 'window property of the kind above. - -At the very end of this function the hook `winsav-after-put' is -run." - (let* ((sel-num (nth 0 saved-tree)) - (tree (nth 1 saved-tree)) - nsiz - nh - nw - osiz - oh - ow - scale-w - scale-h - first-win - winsav-put-return) - (unless (or (bufferp (car tree)) - (eq 'buffer (car tree))) - (setq nsiz (window-edges window)) - (setq nh (- (nth 3 nsiz) (nth 1 nsiz))) - (setq nw (- (nth 2 nsiz) (nth 0 nsiz))) - (setq osiz (cadr tree)) - (setq oh (- (nth 3 osiz) (nth 1 osiz))) - (setq ow (- (nth 2 osiz) (nth 0 osiz))) - (setq scale-w (unless (= ow nw) (/ nw (float ow)))) - (setq scale-h (unless (= oh nh) (/ nh (float oh))))) - (setq first-win (winsav-put-window-tree-1 tree window scale-w scale-h t 1)) - (select-window first-win) - (when sel-num (other-window sel-num)) - (winsav-fix-win-ovl winsav-put-return copy-win-ovl win-ovl-all-bufs) - (run-hook-with-args 'winsav-after-put-hook winsav-put-return) - winsav-put-return)) - -(defun winsav-put-window-tree-1 (saved-tree window scale-w scale-h first-call level) - "Helper for `winsav-put-window-tree'. -For the arguments SAVED-TREE and WINDOW see that function. - -The arguments SCALE-W and SCALE-H are used to make the saved -window config fit into its new place. FIRST-CALL is a state -variable telling if this is the first round. LEVEL helps -debugging by tells how far down we are in the call chain." - (if (or (bufferp (car saved-tree)) - ;;(not (car saved-tree)) - (eq 'buffer (car saved-tree)) - ) - (let ((buffer (nth 0 saved-tree)) - ;; buffer - (bufnam (nth 1 saved-tree)) - (filnam (nth 2 saved-tree)) - ;;(mark (nth 3 saved-tree)) - ;; window - (point (nth 3 saved-tree)) - (edges (nth 4 saved-tree)) - (scroll (nth 5 saved-tree)) - (fringe (nth 6 saved-tree)) - (margs (nth 7 saved-tree)) - (hscroll (nth 8 saved-tree)) - (dedic (nth 9 saved-tree)) - (trigger (nth 10 saved-tree)) - (start (nth 11 saved-tree)) - (ovlwin (nth 12 saved-tree)) - scr2 - (misbuf " *Winsav information: Buffer is gone*")) - (or (windowp ovlwin) - (not ovlwin) - (error "Parameter mismatch, ovlwin not window: %s" ovlwin)) - (when first-call - (add-to-list 'winsav-put-return (list ovlwin window)) - (when (eq 'buffer buffer) - (when filnam - (setq buffer (winsav-find-file-noselect filnam))) - (if (buffer-live-p buffer) - (or (string= bufnam (buffer-name buffer)) - (eq (string-to-char bufnam) 32) ;; Avoid system buffer names - (rename-buffer bufnam)) - (when (eq (string-to-char bufnam) 32) - (setq bufnam " *Winsav dummy buffer*")) - ;; Fix-me, this might need some tweaking: Don't restore - ;; buffers without a file name and without - ;; content. (desktop-mode will make that when - ;; necessary.) Just show the scratch buffer instead. - (setq buffer (get-buffer bufnam)) - (unless (and buffer - (< 0 (buffer-size buffer))) - (setq buffer (get-buffer-create "*scratch*"))))) - (set-window-buffer window buffer) - (set-window-dedicated-p window dedic) - ;; Strange incompatibility in scroll args: - (setq scr2 (list (nth 0 scroll) (nth 2 scroll) (nth 3 scroll))) - (apply 'set-window-scroll-bars (append (list window) scr2)) - (apply 'set-window-fringes (append (list window) fringe)) - (set-window-margins window (car margs) (cdr margs)) - (set-window-hscroll window hscroll) - (unless (>= emacs-major-version 23) - (with-no-warnings - (set-window-redisplay-end-trigger window trigger)))) - (let* ((nsiz (window-edges window)) - (nh (- (nth 3 nsiz) (nth 1 nsiz))) - (nw (- (nth 2 nsiz) (nth 0 nsiz))) - (osiz edges) ;(nth 2 saved-tree)) - (oh (- (nth 3 osiz) (nth 1 osiz))) - (ow (- (nth 2 osiz) (nth 0 osiz))) - (diff-w (- (if scale-w - (round (* scale-w ow)) - ow) - nw)) - (diff-h (- (if scale-h - (round (* scale-h oh)) - oh) - nh))) - ;; Avoid rounding naggings: - (when (> (abs diff-h) 1) - (bw-adjust-window window diff-h nil)) - (when (> (abs diff-w) 1) - (bw-adjust-window window diff-w t))) - ;; Fix-me: there were some problems getting point correctly. Don't know why... - (with-selected-window window - (with-current-buffer (window-buffer window) - (goto-char point)) - (set-window-point window point) - ;;(unless (buffer-live-p buffer) (setq point 1) (setq start 1)) - (set-window-start window start) - ;; Maybe point got off screen? - (when (/= point (window-point window)) - (set-window-point window point))) - window) - (let* ((ver (car saved-tree)) - (wtree (list (cons window (caddr saved-tree)))) - (nwin window) - pwin - pdelta - (first-win nwin)) - ;; First split to get it in correct order - (when first-call - (dolist (subtree (cdddr saved-tree)) - (setq pwin nwin) - ;;(message "nwin edges=%s, ver=%s" (window-edges nwin) ver) - (let ((split-err nil) - (window-min-height 1) - (window-min-width 1)) - (setq nwin (split-window nwin nil (not ver)))) - ;; Make the previous window as small as permitted to allow - ;; splitting as many times as possible - (setq pdelta (- - (if ver - window-min-height - window-min-width) - (if ver - (window-width pwin) - (window-height pwin)))) - ;;(message "pwin=%s, edges=%s, pdelta=%s, ver=%s" pwin (window-edges pwin) pdelta ver) - ;; No reason to fail here: - (condition-case err - (adjust-window-trailing-edge pwin pdelta (not ver)) - (error - ;;(message "awt=>%s" (error-message-string err)) - nil - )) - ;; Add to traverse - (add-to-list 'wtree - (cons nwin subtree) - t))) - ;; Now traverse. Sizing is a bit tricky, multiple runs have to - ;; be done (as in balance-windows). - (let (tried-sizes - last-sizes - (windows (window-list (selected-frame)))) - (while (not (member last-sizes tried-sizes)) - (when last-sizes (setq tried-sizes (cons last-sizes tried-sizes))) - (setq last-sizes (mapcar (lambda (w) - (window-edges w)) - windows)) - (dolist (wsub (reverse wtree)) - (select-window (car wsub)) - (winsav-put-window-tree-1 (cdr wsub) (selected-window) - scale-w scale-h - first-call - (1+ level) - )) - (setq first-call nil) - )) - first-win))) - -(defun winsav-fix-win-ovl(win-list copy-win-ovl win-ovl-all-bufs) - (let ((oldwins (mapcar (lambda(elt) - (car elt)) - win-list)) - ovlwin - window) - (let (buffers) - (if win-ovl-all-bufs - (setq buffers (buffer-list)) - (mapc (lambda(w) - (when (window-live-p w) - (add-to-list 'buffers (window-buffer w)))) - oldwins)) - (dolist (buf buffers) - (with-current-buffer buf - (save-restriction - (widen) - (dolist (overlay (overlays-in (point-min) (point-max))) - (when (setq ovlwin (car (memq (overlay-get overlay 'window) oldwins))) - (setq window (cadr (assoc ovlwin win-list))) - ;; If the old window is still alive then maybe copy - ;; overlay, otherwise change the 'window prop. However - ;; copy only if COPY-WIN-OVL is non-nil. - (if (not (and (window-live-p ovlwin) - (window-frame ovlwin))) - (overlay-put overlay 'window window) - (when copy-win-ovl - (let* ((props (overlay-properties overlay)) - (start (overlay-start overlay)) - (end (overlay-end overlay)) - ;; Fix-me: start and end marker props - (newovl (make-overlay start end))) - (while props - (let ((key (car props)) - (val (cadr props))) - (setq props (cddr props)) - (when (eq key 'window) - (setq val window)) - (overlay-put newovl key val)))))))))))))) - - - -(defun winsav-transform-edges (edges) - "Just rotate the arguments in EDGES to make them fit next function." - (let ((le (nth 0 edges)) - (te (nth 1 edges)) - (re (nth 2 edges)) - (be (nth 3 edges))) - (list te le be re))) - -(defun winsav-transform-1 (tree mirror transpose) - "Mirroring of the window tree TREE. -MIRROR could be 'mirror-top-bottom or 'mirror-left-right which I -think explain what it does here. TRANSPOSE shifts the tree -between a horisontal and vertical tree." - (let* ((vertical (nth 0 tree)) - (edges (nth 1 tree)) - (subtrees (nthcdr 2 tree)) - ) - ;;(winsav-log "tree 1" tree) - (when transpose - (cond - ((eq vertical nil) - (setcar tree t)) - ((eq vertical t) - (setcar tree nil)) - (t - (error "Uh? vertical=%S" vertical)))) - (setcar (nthcdr 1 tree) (winsav-transform-edges edges)) - (dolist (subtree subtrees) - (if (bufferp (car subtree)) - (when transpose - (let ((edges (nth 4 subtree))) - ;;(winsav-log "subtree 1" subtree) - (setcar (nthcdr 4 subtree) (winsav-transform-edges edges)) - ;;(winsav-log "subtree 2" subtree) - )) - (winsav-transform-1 subtree mirror transpose))) - (when (case mirror - ('mirror-top-bottom vertical) - ('mirror-left-right (not vertical)) - (nil) ;; Don't mirror - (t - (error "Uh? mirror=%s" mirror))) - (setcdr (nthcdr 1 tree) (reverse subtrees)) - ) - )) - -(defun winsav-find-file-noselect (filename) - "Read file FILENAME into a buffer and return the buffer. -Like `find-file-noselect', but if file is not find then creates a -buffer with a message about that." - (let ((buf (find-file-noselect filename))) - (unless buf - (setq buf (generate-new-buffer filename)) - (with-current-buffer buf - (insert "Winsav could not find the file " filename) - (set-buffer-modified-p nil))) - buf)) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Session saving and restore etc - -;;;###autoload -(defgroup winsav nil - "Save frames and windows when you exit Emacs." - :group 'frames) - -;;;###autoload -(define-minor-mode winsav-save-mode - "Toggle winsav configuration saving mode. -With numeric ARG, turn winsav saving on if ARG is positive, off -otherwise. - -When this mode is turned on, winsav configurations are saved from -one session to another. A winsav configuration consists of -frames, windows and visible buffers configurations plus -optionally buffers and files managed by the functions used by -option `desktop-save-mode' - -By default this is integrated with `desktop-save-mode'. If -`desktop-save-mode' is on and `winsav-handle-also-desktop' is -non-nil then save and restore also desktop. - -See the command `winsav-switch-config' for more information and -other possibilities. - -Note: If you want to avoid saving when you exit just turn off -this minor mode. - -For information about what is saved and restored and how to save -and restore additional information see the function -`winsav-save-configuration'." - :global t - :group 'winsav) - -(defun winsav-save-mode-on () - "Ensable option `winsav-save-mode'. Provided for use in hooks." - (winsav-save-mode 1)) - -(defun winsav-save-mode-off () - "Disable option `winsav-save-mode'. Provided for use in hooks." - (winsav-save-mode -1)) - -(defcustom winsav-save 'ask-if-new - "Specifies whether the winsav config should be saved when it is killed. -A winsav config \(winsav frame configuration) is killed when the -user changes winsav directory or quits Emacs. - -Possible values are: - t -- always save. - ask -- always ask. - ask-if-new -- ask if no winsav file exists, otherwise just save. - ask-if-exists -- ask if winsav file exists, otherwise don't save. - if-exists -- save if winsav file exists, otherwise don't save. - nil -- never save. -The winsav config is never saved when the option `winsav-save-mode' is nil. -The variables `winsav-dirname' and `winsav-base-file-name' -determine where the winsav config is saved." - :type - '(choice - (const :tag "Always save" t) - (const :tag "Always ask" ask) - (const :tag "Ask if winsav file is new, else do save" ask-if-new) - (const :tag "Ask if winsav file exists, else don't save" ask-if-exists) - (const :tag "Save if winsav file exists, else don't" if-exists) - (const :tag "Never save" nil)) - :group 'winsav) - -(defcustom winsav-handle-also-desktop t - "If this is non-nil then desktop is also saved and restored. -See option `winsav-save-mode' for more information." - :type 'boolean - :group 'winsav) - -(defcustom winsav-base-file-name - (convert-standard-filename ".emacs.winsav") - "Base name of file for Emacs winsav, excluding directory part. -The actual file name will have a system identifier added too." - :type 'file - :group 'winsav) - -(defvar winsav-dirname nil - "The directory in which the winsav file should be saved.") - -(defun winsav-current-default-dir () - "Current winsav configuration directory." - (or winsav-dirname "~/")) - -;;(find-file (winsav-full-file-name)) -(defun winsav-default-file-name () - "Default winsav save file name. -The file name consist of `winsav-base-file-name' with a system -identifier added. This will be '-nw' for a terminal and '-' + -the value of `window-system' otherwise." - (let ((sys-id (if (not window-system) - "nw" - (format "%s" window-system)))) - (concat winsav-base-file-name "-" sys-id))) - -(defun winsav-full-file-name (&optional dirname) - "Return the full name of the winsav session file in DIRNAME. -DIRNAME omitted or nil means use `~'. - -The file name part is given by `winsav-default-file-name'." - ;; Fix-me: Different frames in different files? Can multi-tty be handled?? - (expand-file-name (winsav-default-file-name) (or dirname - (winsav-current-default-dir)))) - - - -(defun winsav-serialize (obj) - "Return a string with the printed representation of OBJ. -This should be possible to eval and get a similar object like OBJ -again." - ;;(message "winsav-serialize a") - (prin1-to-string obj) - ;;(message "winsav-serialize b") - ) - -(defcustom winsav-before-save-configuration-hook nil - "Hook called before saving frames. -Hook for writing elisp code at the beginning of a winsav -configuration file. When this hook is called the current buffer -and point is where the code should be written. - -This is a normal hook. For more information see -`winsav-save-configuration'." - :type 'hook - :group 'winsav) - -(defcustom winsav-after-save-configuration-hook nil - "Hook called after saving frames. -Hook for writing elisp code at the end of a winsav configuration -file. When this hook is called the current buffer and point is -where the code should be written. - -This is a normal hook. For more information see -`winsav-save-configuration'." - :type 'hook - :group 'winsav) - -(defcustom winsav-after-save-frame-hook nil - "Hook called when saving a frame after saving frame data. -Hook for writing elisp code in a winsav configuration file after -each frame creation. When this hook is called code for restoring -a frame has been written and code that sets -`winsav-last-loaded-frame' to point to it. Point is in the -configuration file buffer right after this. - -This is a normal hook. For more information see -`winsav-save-configuration'." - :type 'hook - :group 'winsav) - -(defvar winsav-loaded-frames nil) -(defvar winsav-last-loaded-frame nil) - -(defun winsav-restore-frame (frame-params - window-tree-params - use-minibuffer-frame - window-state - window-visible) - "Restore a frame with specified values. -If this is a minibuffer only frame then just apply the frame -parameters FRAME-PARAMS. Otherwise create a new frame using -FRAME-PARAMS and set up windows and buffers according to -WINDOW-TREE-PARAMS. Also, if USE-MINIBUFFER-FRAME let the new -frame have this minibuffer frame. - -WINDOW-STATE is 1 for minimized, 2 for normal and 3 for -maximized." - (let* ((default-minibuffer-frame use-minibuffer-frame) - (frame-name (cdr (assoc 'name frame-params))) - (minibuffer-val (cdr (assoc 'minibuffer frame-params))) - (minibuffer-only (eq 'only minibuffer-val)) - (mini-frames - (delq nil (mapcar (lambda (frm) - (when (eq 'only (frame-parameter frm 'minibuffer)) - frm)) - (frame-list)))) - (frame-with-that-name - (when (and frame-name minibuffer-only) - (catch 'frame - (dolist (frame (frame-list)) - (when (string= frame-name (frame-parameter frame 'name)) - (throw 'frame frame)))))) - ;; If this is a minibuffer only frame then if it is already - ;; there under a correct name then do not create it because - ;; there might be variables pointing to it; just set the - ;; parameters. Perhaps even better: if it is not already - ;; there give an error - because it might be impossible to - ;; set things up correctly then. - (frame-with-that-name-has-mini - (when frame-with-that-name - (eq 'only - (frame-parameter frame-with-that-name 'minibuffer)))) - (this-mini-frame (when minibuffer-only - (or frame-with-that-name - (and (= 1 (length mini-frames)) - (car mini-frames))))) - (create-new - (if minibuffer-only - (if this-mini-frame ;frame-with-that-name-has-mini - nil - (error "Winsav: Can't find minibuffer only frame with name %s" - frame-name)) - t)) - (this-frame (if create-new - (make-frame frame-params) - this-mini-frame)) - (win (frame-first-window this-frame))) - ;;(message "create-new=%s, frame-with-that-name=%s" create-new frame-with-that-name) - ;; (when was-max - ;; (winsav-set-maximized-size this-frame) - ;; ;; Wait for maximize to occur so horizontal scrolling gets ok. - ;; (sit-for 1.5) - ;; ) - (case window-state - (1 (winsav-set-minimized-state this-frame)) - (3 (winsav-set-maximized-state this-frame))) - (unless window-visible - (make-frame-invisible this-frame)) - (if create-new - (winsav-put-window-tree window-tree-params win) - (modify-frame-parameters this-frame frame-params)) - (setq winsav-last-loaded-frame this-frame) - (setq winsav-loaded-frames (cons this-frame winsav-loaded-frames)) - )) - -(defcustom winsav-frame-parameters-to-save - '( - ;;explicit-name - ;;name - ;;parent-id - ;;title - alpha - auto-lower - auto-raise - background-color - background-mode - border-color - border-width - buffer-predicate - cursor-color - cursor-type - font - font-backend - foreground-color - fullscreen - icon-name - icon-type - icon-left - icon-top - internal-border-width - left-fringe - line-spacing - menu-bar-lines - modeline - mouse-color - right-fringe - screen-gamma - scroll-bar-width - tool-bar-lines - top left width height - tty-color-mode ;; ?? - unsplittable - user-position - user-size - vertical-scroll-bars - visibility - ) - "Parameters saved for frames by `winsav-save-configuration'. -Parameters are those returned by `frame-parameters'." - :type '(repeat (symbol :tag "Frame parameter")) - :group 'winsav) - -(defun frame-visible-really-p (frame) - "Return t if FRAME is visible. -This tries to be more corrent on w32 than `frame-visible-p'." - (cond ((fboundp 'w32-frame-placement) - (< 0 (nth 4 (w32-frame-placement frame)))) - (t - (frame-visible-p frame)))) - -(defun frame-maximized-p (frame) - "Return t if it is known that frame is maximized." - (cond ((fboundp 'w32-frame-placement) - (= 3 (abs (nth 4 (w32-frame-placement frame))))) - (t nil))) - -(defun frame-minimized-p (frame) - "Return t if it is known that frame is minimized." - (cond ((fboundp 'w32-frame-placement) - (= 3 (abs (nth 4 (w32-frame-placement frame))))) - (t nil))) - -;;(winsav-set-restore-size nil) -;; (defun winsav-set-restore-size (frame) -;; (when (fboundp 'w32-send-sys-command) -;; (let ((cur-frm (selected-frame))) -;; (select-frame-set-input-focus frame) -;; (w32-send-sys-command #xf120) -;; ;; Note: sit-for must be used, not sleep-for. Using the latter -;; ;; prevents the fetching of the new size (for some reason I do not -;; ;; understand). -;; (sit-for 1.5) -;; (select-frame-set-input-focus cur-frm)) -;; t)) - -(defun winsav-set-maximized-state (frame) - (when (fboundp 'w32-send-sys-command) - (select-frame-set-input-focus frame) - (w32-send-sys-command #xf030) - (sit-for 1.0) - t)) - -(defun winsav-set-minimized-state (frame) - (when (fboundp 'w32-send-sys-command) - (select-frame-set-input-focus frame) - (w32-send-sys-command #xf020) - (sit-for 1.0) - t)) - -(defun winsav-save-frame (frame mb-frm-nr buffer) - "Write into buffer BUFFER elisp code to recreate frame FRAME. -If MB-FRM-NR is a number then it is the order number of the frame -whose minibuffer should be used." - (message "winsav-save-frame buffer=%s" buffer) - (message "winsav-save-frame buffer 2=%s" (current-buffer)) - (let* ((start nil) - (end nil) - (obj (winsav-get-window-tree frame)) - (dummy (message "winsav-save-frame buffer 3=%s" (current-buffer))) - (frm-size-now (cons (frame-pixel-height frame) - (frame-pixel-width frame))) - (dummy (message "winsav-save-frame buffer 4=%s" (current-buffer))) - (placement (when (fboundp 'w32-frame-placement) (w32-frame-placement frame))) - ;; (was-max (and frm-size-rst - ;; (not (equal frm-size-now frm-size-rst)))) - (window-state (abs (nth 4 placement))) - ;; (frm-size-rst (when (winsav-set-restore-size frame) - ;; (cons (frame-pixel-height frame) - ;; (frame-pixel-width frame)))) - ;;(frm-size-rst (when was-max)) - ;;(frm-size-rst (when (= 3 (abs (nth 4 placement))))) - (dummy (message "winsav-save-frame buffer 5=%s" (current-buffer))) - (frm-par (frame-parameters frame)) - (dummy (message "winsav-save-frame buffer 6=%s" (current-buffer))) - ) - (message "winsav-save-frame a1 cb=%s" (current-buffer)) - (with-current-buffer buffer - ;;(y-or-n-p (format "was-max=%s" was-max)) - (message "winsav-save-frame a2 cb=%s" (current-buffer)) - (setq frm-par - (delq nil - (mapcar (lambda (elt) - (cond - ((memq (car elt) winsav-frame-parameters-to-save) - elt) - ((eq (car elt) 'minibuffer) - (let ((val (cdr elt))) - (if (not (windowp val)) - elt - (if (eq (window-frame val) frame) - nil - (cons 'minibuffer nil))))))) - frm-par))) - (message "winsav-save-frame b cb=%s" (current-buffer)) - (insert "(winsav-restore-frame\n'" - ;;make-frame-params - (winsav-serialize frm-par)) - (message "winsav-save-frame b.0.1") - ;;window-tree-params - (setq start (point)) - (insert "'" (winsav-serialize obj) "\n") - (message "winsav-save-frame b.0.2") - (setq end (copy-marker (point) t)) - (message "winsav-save-frame b.0.3") - (message "winsav-save-frame b.1") - ;; (replace-regexp (rx "#<buffer " - ;; (1+ (not (any ">"))) - ;; (1+ ">")) ;; 1+ for indirect buffers ... - ;; "buffer" - ;; nil start end) - (goto-char start) - (while (re-search-forward (rx "#<buffer " - (1+ (not (any ">"))) - (1+ ">")) ;; 1+ for indirect buffers ... - end t) - (replace-match "buffer" nil t)) - (message "winsav-save-frame b.2") - ;; (replace-regexp (rx "#<window " - ;; (1+ (not (any ">"))) - ;; (1+ ">")) - ;; "nil" - ;; nil start end) - (goto-char start) - (while (re-search-forward (rx "#<window " - (1+ (not (any ">"))) - (1+ ">")) ;; 1+ for indirect buffers ... - end t) - (replace-match "nil" nil t)) - (message "winsav-save-frame c") - (goto-char end) - ;;use-minibuffer-frame - (insert (if mb-frm-nr - (format "(nth %s (reverse winsav-loaded-frames))" mb-frm-nr) - "nil") - (format " %s" window-state) - (if (frame-visible-really-p frame) " t " " nil ") - ")\n\n") - - (insert " ;; ---- before after-save-frame-hook ----\n") - ;; (dolist (fun winsav-after-save-frame-hook) - ;; (funcall fun frame (current-buffer))) - (run-hooks winsav-after-save-frame-hook) - (message "winsav-save-frame d") - (insert " ;; ---- after after-save-frame-hook ----\n") - - ;;(insert " )\n\n\n") - ))) - -(defvar winsav-file-version "1" - "Version number of winsav file format. -Written into the winsav file and used at winsav read to provide -backward compatibility.") - - -;; fix-me: This should be in desktop.el -;; Fix-me: incomplete, not ready. -(defun winsav-restore-indirect-file-buffer (file name) - "Make indirect buffer from file buffer visiting file FILE. -Give it the name NAME." - (let* ((fbuf (find-file-noselect file))) - (when fbuf - (make-indirect-buffer fbuf name)))) - -(defun winsav-save-indirect-buffers (to-buffer) - "Save information about indirect buffers. -Only file visiting buffers currently. Clone the base buffers." - (with-current-buffer to-buffer - (dolist (buf (buffer-list)) - (when (buffer-base-buffer buf) - (let* ((base-buf (buffer-base-buffer buf)) - (file (buffer-file-name base-buf))) - (when file - (insert "(winsav-restore-indirect-file-buffer \"" - file "\" \"" (buffer-name buf) "\")\n"))))))) - -;; Fix-me: test -;; (defun winsav-restore-minibuffer (frame-num frm-num win-num) -;; (let* ((frame (nth (1- frame-num) winsav-loaded-frames)) -;; (mini-frm (nth (1- frm-num) winsav-loaded-frames)) -;; (mini-win (nth (1- win-num) (reverse (window-list mini-frm)))) -;; ) -;; (with-selected-frame frame -;; (set-minibuffer-window mini-win)))) - -(defvar winsav-minibuffer-alist nil) -(defun winsav-save-minibuffers (sorted-frames to-buffer) - "Save information about minibuffer frames. -SORTED-FRAMES should be a list of all frames sorted using -`winsav-frame-sort-predicate'." - (with-current-buffer to-buffer - (setq winsav-minibuffer-alist nil) - (dolist (frame sorted-frames) - (let* ((num-frames (length sorted-frames)) - (mini-win (minibuffer-window frame)) - (mini-frm (window-frame mini-win)) - (win-num (length - (memq mini-win - (window-list mini-frm t (frame-first-window mini-frm))))) - (frm-num (- num-frames (length (memq mini-frm sorted-frames)))) - (frame-num (- num-frames (length (memq frame sorted-frames))))) - (unless (and (eq mini-frm frame) - (= win-num 1)) - ;; Not the normal minibuffer window - ;;(insert (format ";;(winsav-restore-minibuffer %s %s %s)\n" - ;;(insert (format "'(%s %s)\n" frame-num frm-num) - (setq winsav-minibuffer-alist (cons (list frame-num frm-num) winsav-minibuffer-alist)) - ))) - (insert "(setq winsav-minibuffer-alist '" - (winsav-serialize winsav-minibuffer-alist) - ")\n"))) - -(defun winsav-restore-dedicated-window (frame-num win-num dedicate-flag) - "Set dedicated window flag. -On frame number FRAME-NUM in `winsav-loaded-frames' set the -dedicated flag on window number WIN-NUM to DEDICATE-FLAG." - (let* ((frame (nth (1- frame-num) winsav-loaded-frames)) - (win (nth (1- win-num) (reverse (window-list frame t - (frame-first-window frame)))))) - (set-window-dedicated-p win dedicate-flag))) - -(defun winsav-save-dedicated-windows (sorted-frames) - "Save information about dedicated windows on frames in SORTED-FRAMES. -Write this to current buffer." - (dolist (frame sorted-frames) - (dolist (win (window-list frame)) - (when (window-dedicated-p win) - (let ((frame-num (length (memq frame sorted-frames))) - (win-num (length - (memq win - (window-list frame t (frame-first-window frame))))) - (flag (window-dedicated-p win))) - (insert (format "(winsav-restore-dedicated-window %s %s %S)\n" frame-num win-num flag)) - ))))) - -(defun winsav-restore-ecb (frame-num layout-ecb) - "Restore ECB. -On frame number FRAME-NUM-ECB in `winsav-loaded-frames' restore -ECB layout LAYOUT-ECB." - (when (boundp 'ecb-minor-mode) - (let* ((frame (nth (1- frame-num) winsav-loaded-frames))) - (select-frame frame) - (unless (string= layout-ecb ecb-layout-name) - (setq ecb-layout-name layout-ecb)) - (ecb-minor-mode 1)))) - -(defun winsav-save-ecb (frame-ecb layout-ecb sorted-frames) - "Save information about ECB layout on frames in SORTED-FRAMES. -Write this in current buffer." - (dolist (frame sorted-frames) - (when (eq frame frame-ecb) - (let ((frame-num (length (memq frame sorted-frames)))) - (insert (format "(winsav-restore-ecb %s %S)\n" frame-num layout-ecb)))))) - -;; (make-frame '((minibuffer))) -;; (sort (frame-list) 'winsav-frame-sort-predicate) -(defun winsav-frame-sort-predicate (a b) - "Compare frame A and B for sorting. -Sort in the order frames can be created. - -- Frames without minibuffers will come later since the need to - refer to the minibuffer frame when they are created. - -- Invisible frames comes last since there must be at least one - visible frame from the beginning." - (let* ((a-mbw (minibuffer-window a)) - (a-mbw-frm (window-frame a-mbw)) - (b-mbw (minibuffer-window b)) - (b-mbw-frm (window-frame b-mbw)) - (a-visible (frame-visible-really-p a)) - (b-visible (frame-visible-really-p b)) - ) - ;;(message "a-mbw-frm=%s, b=%s" a-mbw-frm b) - ;;(message "b-mbw-frm=%s, a=%s" a-mbw-frm b) - (when (or (not b-visible) - (eq a-mbw-frm b) - (not (eq b-mbw-frm b))) - ;;(message "a > b") - t - ))) - -(defun winsav-can-read-config (config-version) - "Return t we can read config file version CONFIG-VERSION." - (when (<= config-version 1) - t)) - -(defvar winsav-file-modtime nil) - -;; Like desktop-save, fix-me -(defun winsav-save-configuration (&optional dirname release) - "Write elisp code to recreate all frames. -Write into the file name computed by `winsav-full-file-name' -given the argument DIRNAME. - -The information that is saved for each frame is its size and -position, the window configuration including buffers and the -parameters in `winsav-frame-parameters-to-save'. If you want save -more information for frames you can do that in the hook -`winsav-after-save-frame-hook'. - -See also the hook variables -`winsav-before-save-configuration-hook' and -`winsav-after-save-configuration-hook'. - -Fix-me: RELEASE is not implemented." - (winsav-save-config-to-file (winsav-full-file-name dirname))) - -(defun winsav-save-config-to-file (conf-file) - "Write elisp code to recreate all frames to CONF-FILE." - (let (start - end - (sorted-frames (sort (frame-list) 'winsav-frame-sort-predicate)) - (frm-nr 0) - frame-ecb - layout-ecb) - ;; Recreating invisible frames hits Emacs bug 3859 - (setq sorted-frames - (delq nil - (mapcar (lambda (f) - (when (frame-parameter f 'visibility) f)) - sorted-frames))) - (when (and (boundp 'ecb-minor-mode) ecb-minor-mode) - (when (frame-live-p ecb-frame) - (setq layout-ecb ecb-layout-name) - (setq frame-ecb ecb-frame)) - (ecb-minor-mode -1) - (sit-for 0) ;; Fix-me: is this needed? - ) - (message "winsav-save-config:here a") - (with-temp-buffer - (let ((this-buffer (current-buffer))) - (message "winsav-save-config:here b") - ;;(erase-buffer) - (insert - ";; -*- mode: emacs-lisp; coding: utf-8; -*-\n" - ";; --------------------------------------------------------------------------\n" - ";; Winsav File for Emacs\n" - ";; --------------------------------------------------------------------------\n" - ";; Created " (current-time-string) "\n" - ";; Winsav file format version " winsav-file-version "\n" - ";; Emacs version " emacs-version "\n\n" - "(if (not (winsav-can-read-config " winsav-file-version "))\n\n" - " (message \"Winsav: Can't read config file with version " winsav-file-version "\")\n") - (message "winsav-save-config:here c") - (insert ";; ---- indirect buffers ------------------------\n") - (winsav-save-indirect-buffers this-buffer) - (message "winsav-save-config:here c.1") - ;;(insert ";; ---- special minibuffers ------------------------\n") - (winsav-save-minibuffers sorted-frames this-buffer) - (message "winsav-save-config:here c.2") - (insert "(setq winsav-loaded-frames nil)\n") - (insert ";; ---- before winsav-before-save-configuration-hook ------------------------\n") - (run-hooks 'winsav-before-save-configuration-hook) - (message "winsav-save-config:here c.2a cb=%s" (current-buffer)) - (insert ";; ---- after winsav-before-save-configuration-hook ------------------------\n\n") - (dolist (frm sorted-frames) - (let ((mb-frm-nr (cadr (assoc frm-nr winsav-minibuffer-alist))) - ;;(mb-frm (when mb-frm-nr (nth mb-frm-nr sorted-frames))) - ) - (message "winsav-save-config:here c.2b.1 tb=%s cb=%s frm=%s" this-buffer (current-buffer) frm) - (winsav-save-frame frm mb-frm-nr this-buffer) - (message "winsav-save-config:here c.2b.2") - (setq frm-nr (1+ frm-nr)))) - (message "winsav-save-config:here c.2c cb=%s" (current-buffer)) - (insert ";; ---- dedicated windows ------------------------\n") - (winsav-save-dedicated-windows sorted-frames) - (message "winsav-save-config:here c.3") - (insert ";; ---- ECB --------------------------------------\n") - (winsav-save-ecb frame-ecb layout-ecb sorted-frames) - (message "winsav-save-config:here c.4") - (insert "\n\n;; ---- before winsav-after-save-configuration-hook ------------------------\n") - (run-hooks 'winsav-after-save-configuration-hook) - (message "winsav-save-config:here c.5") - (insert "\n\n;; ---- before winsav-after-save-configuration-hook ------------------------\n") - (run-hooks 'winsav-after-save-configuration-hook) - (message "winsav-save-config:here c.6") - (insert ";; ---- after winsav-after-save-configuration-hook ------------------------\n") - (insert "\n)\n") - (message "winsav-save-config:here d") - ;; For pp-buffer: - (let (emacs-lisp-mode-hook - after-change-major-mode-hook - change-major-mode-hook) - (font-lock-mode -1) - (emacs-lisp-mode)) - (message "winsav-save-config:here e") - (pp-buffer) - (message "winsav-save-config:here f") - (indent-region (point-min) (point-max)) - (message "winsav-save-config:here g") - ;;(save-buffer 0) ;; No backups - ;;(kill-buffer) - - ;;(with-current-buffer (find-file-noselect file) - (let ((coding-system-for-write 'utf-8)) - (write-region (point-min) (point-max) conf-file nil 'nomessage)) - (setq winsav-file-modtime (nth 5 (file-attributes conf-file))) - (setq winsav-dirname (file-name-as-directory (file-name-directory conf-file))) - (message "winsav-save-config:here h") - )))) - -(defvar winsav-current-config-name nil) - -;;(winsav-restore-configuration) -;;(winsav-full-file-name "~") -;; (defun winsav-restore-winsav-configuration () -;; ) - -(defcustom winsav-after-restore-hook nil - "Normal hook run after a successful `winsav-restore-configuration'." - :type 'hook - :group 'winsav) - -;; Like desktop-read, fix-me -(defun winsav-restore-configuration (&optional dirname) - "Restore frames from default file in directory DIRNAME. -The default file is given by `winsav-default-file-name'. - -The file was probably written by `winsav-save-configuration'. -Delete the frames that were used before." - ;;(message "winsav-restore-configuration %s" dirname) - (winsav-restore-config-from-file (winsav-full-file-name dirname))) - -(defun winsav-restore-config-from-file (conf-file) - "Restore frames from configuration file CONF-FILE. -The file was probably written by `winsav-save-configuration'. -Delete the frames that were used before." - (let ((old-frames (sort (frame-list) 'winsav-frame-sort-predicate)) - (num-old-deleted 0) - ;; Avoid winsav saving during restore. - (winsav-save nil)) - ;;(message "winsav:conf-file=%s" conf-file) - (if (or (not conf-file) - (not (file-exists-p conf-file))) - (progn - (message (propertize "Winsav: No default configuration file found" - 'face 'secondary-selection)) - t) ;; Ok - (setq debug-on-error t) ;; fix-me - (if (file-exists-p conf-file) - (progn - (load conf-file nil nil t) - (setq winsav-file-modtime (nth 5 (file-attributes conf-file))) - (setq winsav-dirname (file-name-as-directory (file-name-directory conf-file))) - (when (< 0 (length winsav-loaded-frames)) - (dolist (old (reverse old-frames)) - (unless (eq 'only (frame-parameter old 'minibuffer)) - (setq num-old-deleted (1+ num-old-deleted)) - (delete-frame old))) - ) - (message "winsav-after-restore-hook =%S" winsav-after-restore-hook) - (run-hooks 'winsav-after-restore-hook) - (message "Winsav: %s frame(s) restored" (length winsav-loaded-frames)) - t) - ;; No winsav file found - ;;(winsav-clear) - (message "No winsav file: %s" conf-file) - nil)))) - -;; (defcustom winsav-add-to-desktop nil -;; "Set this to let desktop save and restore also winsav configurations." -;; :type 'boolean -;; :set (lambda (sym val) -;; (set-default sym val) -;; (if value -;; (progn -;; (add-hook 'desktop-after-read-hook 'winsav-restore-configuration) -;; (add-hook 'desktop-save-hook 'winsav-save-configuration)) -;; (remove-hook 'desktop-after-read-hook 'winsav-restore-configuration) -;; (remove-hook 'desktop-save-hook 'winsav-save-configuration)) ) -;; :group 'winsav) - -(defun winsav-restore-configuration-protected (&optional dirname) - "Like `winsav-restore-configuration' but protect for errors. -DIRNAME has the same meaning." - (condition-case err - (winsav-restore-configuration dirname) - (error - (message "winsav-restore-configuration: %s" err)))) - -(defun winsav-relative-~-or-full (dirname) - (let* ((rel-dir (file-relative-name dirname - (file-name-directory - (winsav-full-file-name "~")))) - (confname (if (string= ".." (substring rel-dir 0 2)) - winsav-dirname - (if (string= rel-dir "./") - "(default)" - (concat "~/" rel-dir))))) - confname)) - -(defun winsav-tell-configuration () - "Tell which winsav configuration that is used." - (interactive) - (save-match-data ;; runs in timer - (let ((confname (if (not winsav-dirname) - "(none)" - (winsav-relative-~-or-full winsav-dirname)))) - (if t ;;(called-interactively-p) - (message (propertize (format "Current winsav config is '%s'" confname) - 'face 'secondary-selection)) - (save-window-excursion - (delete-other-windows) - (set-window-buffer (selected-window) - (get-buffer-create " *winsav*")) - (with-current-buffer (window-buffer) - (momentary-string-display - (propertize - (format "\n\n\n Current winsav config is '%s'\n\n\n\n" confname) - 'face 'secondary-selection) - (window-start) - (kill-buffer)))))))) - -(defun winsav-tell-configuration-request () - "Start an idle timer to call `winsav-tell-configuration'." - (run-with-idle-timer 1 nil 'winsav-tell-configuration)) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Startup and shut down - -;; Run after desktop at startup so that desktop has loaded files and -;; buffers. -(defun winsav-after-init () - "Restore frames and windows. -Run this once after Emacs startup, after desktop in the -`after-init-hook'." - ;; Turn off with --no-deskttop: - (unless desktop-save-mode (winsav-save-mode -1)) - (when winsav-save-mode - ;;(run-with-idle-timer 0.1 nil 'winsav-restore-configuration-protected) - ;;(message "winsav-after-init") - ;;(winsav-restore-configuration-protected) - ;; In case of error make sure winsav-save-mode is turned off - (setq inhibit-startup-screen t) - (winsav-save-mode -1) - (winsav-restore-configuration) - (winsav-save-mode 1) - )) - -(add-hook 'after-init-hook 'winsav-after-init t) - -(add-hook 'kill-emacs-hook 'winsav-kill) -;;(remove-hook 'kill-emacs-hook 'winsav-kill) - -(defun winsav-kill () - "Save winsav frame configuration. -Run this before Emacs exits." - ;; (when winsav-save-mode - ;; (let ((conf-dir (when winsav-current-config-name - ;; (winsav-full-config-dir-name winsav-current-config-name)))) - ;; (winsav-save-configuration conf-dir)))) - (when (and winsav-save-mode - (let ((exists (file-exists-p (winsav-full-file-name)))) - (or (eq winsav-save t) - (and exists (memq winsav-save '(ask-if-new if-exists))) - (and - (or (memq winsav-save '(ask ask-if-new)) - (and exists (eq winsav-save 'ask-if-exists))) - (y-or-n-p "Save winsav? "))))) - (unless winsav-dirname - ;; Fix-me: Since this can be a new user of winsav I think the - ;; best thing to do here is to encourage the user to save in the - ;; default directory since otherwise the winsav file will not be - ;; loaded at startup. Desktop does not currently do that however - ;; (report that!). - (when (y-or-n-p "Winsav was not loaded from file. Save it to file? ") - (let* ((full-file (winsav-full-file-name)) - (default-directory (directory-file-name - (file-name-directory full-file)))) - (setq winsav-dirname - (file-name-as-directory - (expand-file-name - (read-directory-name "Directory for winsav file: " nil nil t))))))) - (when winsav-dirname - (condition-case err - ;;(winsav-save winsav-dirname t) - (winsav-save-configuration winsav-dirname) - (file-error - (unless (yes-or-no-p - (format "Error while saving winsav config: %s Save anyway? " - (error-message-string err))) - (signal (car err) (cdr err))))))) - ;; If we own it, we don't anymore. - ;;(when (eq (emacs-pid) (winsav-owner)) (winsav-release-lock)) - ) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Switching configurations - -(defun winsav-restore-full-config (dirname) - "Restore the winsav configuration in directory DIRNAME. -If NAME is nil then restore the startup configuration." - ;;(desktop-change-dir dirname) - (when (and winsav-handle-also-desktop desktop-save-mode) - (when (eq (emacs-pid) (desktop-owner)) (desktop-release-lock)) - (desktop-clear) - (desktop-read dirname)) - (winsav-restore-configuration dirname) - ;;(setq winsav-current-config-name name) - (winsav-tell-configuration-request)) - -(defun winsav-full-config-dir-name (name) - "Return full directory path where configuration NAME is stored." - (let* ((base-dir (concat (winsav-full-file-name) ".d")) - (conf-dir (expand-file-name name base-dir))) - (setq conf-dir (file-name-as-directory conf-dir)) - ;;(message "conf-dir=%s" conf-dir) - conf-dir)) - -;;;###autoload -(defun winsav-save-full-config (dirname) - "Saved current winsav configuration in directory DIRNAME. -Then change to this configuration. - -See also `winsav-switch-config'." - (unless (file-name-absolute-p dirname) - (error "Directory ame must be absolute: %s" dirname)) - (let* ((conf-dir (or dirname "~")) - (old-conf-dir winsav-dirname)) - (make-directory conf-dir t) - (winsav-save-configuration conf-dir) - (when (and winsav-handle-also-desktop desktop-save-mode) - (desktop-release-lock) - (desktop-save conf-dir)) - ;;(unless (string= winsav-current-config-name name) - (unless (string= old-conf-dir conf-dir) - ;;(setq winsav-current-config-name name) - (winsav-tell-configuration-request)))) - -;; Fix-me: remove named configurations, use just dir as desktop -(defun winsav-switch-to-default-config () - "Change to default winsav configuration. -See also `winsav-switch-config'." - (interactive) - (winsav-switch-config "~")) - -;;;###autoload -(defun winsav-switch-config (dirname) - "Change to winsav configuration in directory DIRNAME. -If DIRNAME is the current winsav configuration directory then -offer to save it or restore it from saved values. - -Otherwise, before switching offer to save the current winsav -configuration. Then finally switch to the new winsav -configuration, creating it if it does not exist. - -If option `desktop-save-mode' is on then buffers and files are also -restored and saved the same way. - -See also option `winsav-save-mode' and command -`winsav-tell-configuration'." - (interactive - (list - (let ((default-directory (or winsav-dirname default-directory)) - (base-dir (concat (winsav-full-file-name) ".d")) - new-dir) - (make-directory base-dir t) - (setq new-dir - (read-directory-name "Winsav: Switch config directory: ")) - (when (string= "" new-dir) (setq new-dir nil)) - (or new-dir - "~")))) - (setq dirname (file-name-as-directory (expand-file-name dirname))) - (catch 'stop - (let ((conf-file (expand-file-name winsav-base-file-name dirname)) - config-exists) - (if (file-exists-p conf-file) - (setq config-exists t) - (unless (y-or-n-p (format "%s was not found. Create it? " conf-file)) - (throw 'stop nil))) - (if (string= winsav-dirname dirname) - (if (y-or-n-p "You are already using this configuration, restore it from saved values? ") - (winsav-restore-full-config winsav-dirname) - (when (y-or-n-p "You are already using this winsav configuration, save it? ") - (winsav-save-full-config winsav-dirname))) - (when (y-or-n-p - (format "Save current config, %s,\n first before switching to %s? " - (if (and winsav-dirname - (not (string= winsav-dirname - (file-name-directory (winsav-full-file-name "~"))))) - winsav-dirname - "the startup config") - dirname)) - (winsav-save-full-config winsav-dirname)) - (if config-exists - (winsav-restore-full-config dirname) - (winsav-save-full-config dirname)))))) - - - - -;;; Old things - -;; (defun winsav-log-buffer () -;; (get-buffer-create "winsav log buffer")) - -;; (defun winsav-log (mark obj) -;; (with-current-buffer (winsav-log-buffer) -;; (insert "=== " mark "===\n" (pp-to-string obj)))) - -;; (global-set-key [f2] 'winsav-test-get) -;; (global-set-key [f3] 'winsav-test-put) -;; (defvar winsav-saved-window-tree nil) - -;; (defun winsav-test-get() -;; (interactive) -;; (setq winsav-saved-window-tree (winsav-get-window-tree))) - -;; (defun winsav-test-put() -;; (interactive) -;; (let ((ret (winsav-put-window-tree winsav-saved-window-tree -;; (selected-window)))) -;; ;;(message "ret=%s" ret) -;; )) - -;; (defun winsav-serialize-to-file (obj file) -;; (with-current-buffer (find-file-noselect file) -;; ;;(erase-buffer) -;; (save-restriction -;; (widen) -;; (goto-char (point-max)) -;; (insert (winsav-serialize obj) -;; "\n")) -;; ;;(basic-save-buffer) -;; )) - -;;(global-set-key [f11] 'winsav-rotate) - -;; (defun winsav-de-serialize-window-tree-from-file (file) -;; (with-current-buffer (find-file-noselect file) -;; (save-restriction -;; (widen) -;; (let ((start (point)) -;; (end nil)) -;; (forward-list) -;; (setq end (point)) -;; ;;(goto-char (point-min)) -;; (winsav-de-serialize-window-tree (buffer-substring-no-properties start end)))))) - -;; (defun winsav-restore-from-file (file) -;; (winsav-put-window-tree -;; (winsav-de-serialize-window-tree-from-file file) -;; (selected-window))) - -;; (defun winsav-de-serialize-window-tree (str) -;; (save-match-data -;; (let ((read-str -;; (replace-regexp-in-string (rx "#<buffer " -;; (1+ (not (any ">"))) -;; ">") -;; "buffer" -;; str)) -;; obj-last -;; obj -;; last) -;; (setq read-str -;; (replace-regexp-in-string (rx "#<window " -;; (1+ (not (any ">"))) -;; ">") -;; "nil" -;; read-str)) -;; (setq obj-last (read-from-string read-str)) -;; (setq obj (car obj-last)) -;; (setq last (cdr obj-last)) -;; ;; Fix me, maby check there are only spaces left (or trim them above...) -;; obj))) - -(provide 'winsav) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; winsav.el ends here diff --git a/emacs.d/nxhtml/util/winsize.el b/emacs.d/nxhtml/util/winsize.el deleted file mode 100644 index 808daf5..0000000 --- a/emacs.d/nxhtml/util/winsize.el +++ /dev/null @@ -1,1173 +0,0 @@ -;;; winsize.el --- Interactive window structure editing -;; -;; Author: Lennart Borgman <lennart dot borgman at gmail dot com > -;; Maintainer: -;; Created: Wed Dec 07 15:35:09 2005 -(defconst winsize:version "0.98") ;;Version: 0.97 -;; Lxast-Updated: Sun Nov 18 02:14:52 2007 (3600 +0100) -;; Keywords: -;; Compatibility: -;; -;; Fxeatures that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; This file contains functions for interactive resizing of Emacs -;; windows. To use it put it in your `load-path' and add the following -;; to your .emacs: -;; -;; (require 'winsize) -;; (global-set-key [(control x) ?+] 'resize-windows) -;; -;; For more information see `resize-windows'. -;; -;; These functions are a slightly rewritten version of the second part -;; of the second part my proposal for a new `balance-windows' function -;; for Emacs 22. The rewrite is mostly a restructure to more easily -;; add new functions. All functions and variables have been renamed. -;; The file was originally named bw-interactive.el. -;; -;; New ideas for functionality have been to a large part adopted from -;; the Emacs Devel mailing list. Probably most of them originated from -;; Drew Adams and Bastien. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; TODO: Change mouse pointer shape during resizing. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'windmove)) -(eval-when-compile (require 'view)) -(eval-when-compile (require 'winsav nil t)) -(eval-when-compile (require 'ourcomments-widgets)) -(eval-when-compile (require 'ring)) - -;;; Custom variables - -(defcustom winsize-juris-way t - "" - :type 'boolean - :group 'winsize) - -(defcustom winsize-autoselect-borders t - "Determines how borders are selected by default. -If nil hever select borders automatically (but keep them on the -same side while changing window). If 'when-single select border -automatically if there is only one possible choice. If t alwasy -select borders automatically if they are not selected." - :type '(choice (const :tag "Always" t) - (const :tag "When only one possbility" when-single) - (const :tag "Never" nil)) - :group 'winsize) - -(defcustom winsize-mode-line-colors (list t (list "green" "green4")) - "Mode line colors used during resizing." - :type '(list (boolean :tag "Enable mode line color changes during resizing") - (list - (color :tag "- Active window mode line color") - (color :tag "- Inactive window mode line color"))) - :group 'winsize) - -(defcustom winsize-mark-selected-window t - "Mark selected window if non-nil." - :type 'boolean - :group 'winsize) - -(defcustom winsize-make-mouse-prominent t - "Try to make mouse more visible during resizing. -The mouse is positioned next to the borders that you can move. -It can however be hard to see if where it is. Setting this to on -makes the mouse jump a few times." - :type 'boolean - :group 'winsize) - -(defvar widget-command-prompt-value-history nil - "History of input to `widget-function-prompt-value'.") - -(defvar winsize-keymap nil - "Keymap used by `resize-windows'.") - -(defun winsize-make-keymap (let-me-use) - "Build the keymap that should be used by `winsize-keymap'." - (let ((map (make-sparse-keymap "Window Resizing"))) - (when (featurep 'winsav) - (define-key map [menu-bar bw rotate] - '("Rotate window configuration" . winsav-rotate)) - (define-key map [menu-bar bw sep3] '(menu-item "--"))) - (define-key map [menu-bar bw] - (cons "Resize" (make-sparse-keymap "second"))) - (define-key map [menu-bar bw save-config] - '("Save window configuration" . winsize-save-window-configuration)) - (define-key map [menu-bar bw next-config] - '("Next saved window configuration" . winsize-next-window-configuration)) - (define-key map [menu-bar bw prev-config] - '("Previous saved window configuration" . winsize-previous-window-configuration)) - (define-key map [menu-bar bw sep2] '(menu-item "--")) - (define-key map [menu-bar bw fit] - '("Fit Window to Buffer" . fit-window-to-buffer)) - (define-key map [menu-bar bw shrink] - '("Shrink Window to Buffer" . shrink-window-if-larger-than-buffer)) - (define-key map [menu-bar bw sep1] '(menu-item "--")) - (define-key map [menu-bar bw siblings] - '("Balance Window Siblings" . winsize-balance-siblings)) - (define-key map [menu-bar bw balance] - '("Balance Windows" . balance-windows)) - - (when (featurep 'winsav) - (define-key map [?|] 'winsav-rotate)) - (define-key map [?+] 'balance-windows) - (define-key map [?.] 'winsize-balance-siblings) - (define-key map [?=] 'fit-window-to-buffer) - (define-key map [?-] 'shrink-window-if-larger-than-buffer) - - (define-key map [(up)] 'winsize-move-border-up) - (define-key map [(down)] 'winsize-move-border-down) - (define-key map [(left)] 'winsize-move-border-left) - (define-key map [(right)] 'winsize-move-border-right) - - (define-key map [(shift up)] 'winsize-move-other-border-up) - (define-key map [(shift down)] 'winsize-move-other-border-down) - (define-key map [(shift left)] 'winsize-move-other-border-left) - (define-key map [(shift right)] 'winsize-move-other-border-right) - - (define-key map [(meta left)] 'winsize-to-border-or-window-left) - (define-key map [(meta up)] 'winsize-to-border-or-window-up) - (define-key map [(meta right)] 'winsize-to-border-or-window-right) - (define-key map [(meta down)] 'winsize-to-border-or-window-down) - - (define-key map [?0] 'delete-window) - (define-key map [?1] 'delete-other-windows) - (define-key map [?2] 'split-window-vertically) - (define-key map [?3] 'split-window-horizontally) - (define-key map [?4] 'other-window) - - (define-key map [?!] 'winsize-save-window-configuration) - (define-key map [?>] 'winsize-next-window-configuration) - (define-key map [?<] 'winsize-previous-window-configuration) - - ;; Fix-me: These keys could also be set to nil - (define-key map [mouse-1] 'mouse-set-point) - ;;(define-key map [down-mouse-1] 'mouse-set-point) - (define-key map [(mode-line) (down-mouse-1)] 'mouse-drag-mode-line) - (define-key map [(vertical-line) (down-mouse-1)] 'mouse-drag-vertical-line) - (define-key map [(vertical-scroll-bar) (mouse-1)] 'scroll-bar-toolkit-scroll) - - (define-key map [??] 'winsize-help) - (define-key map [(control ?g)] 'winsize-quit) - (define-key map [(control return)] 'winsize-stop-go-back) - (define-key map [(return)] 'winsize-stop) - (define-key map [t] 'winsize-stop-and-execute) - - (dolist (ks let-me-use) - (if (and (not (vectorp ks)) - (not (stringp ks)) - (commandp ks)) - (let ((ks-list (where-is-internal ks))) - (dolist (ks ks-list) - (unless (lookup-key map ks) - (define-key map ks nil)))) - (unless (lookup-key map ks) - (define-key map ks nil)))) - - (setq winsize-keymap map))) - -(defcustom winsize-let-me-use '(next-line ;;[(control ?n)] - previous-line ;;[(control ?p)] - forward-char ;;[(control ?f)] - backward-char ;;[(control ?b)] - [(home)] - [(end)] - ;; Fix-me: replace this with something - ;; pulling in help-event-list: - [(f1)] - execute-extended-command - eval-expression) - "Key sequences or commands that should not be overriden during resize. -The purpose is to make it easier to switch windows. The functions -`windmove-left' etc depends on the position when chosing the -window to move to." - :type '(repeat - (choice - ;; Note: key-sequence must be before command here, since - ;; the key sequences seems to match command too. - key-sequence command)) - :set (lambda (sym val) - (set-default sym val) - (winsize-make-keymap val)) - :group 'winsize) - -(defcustom winsize-selected-window-face 'winsize-selected-window-face - "Variable holding face for marking selected window. -This variable may be nil or a face symbol." - :type '(choice (const :tag "Do not mark selected window" nil) - face) - :group 'winsize) - -(defface winsize-selected-window-face - '((t (:inherit secondary-selection))) - "Face for marking selected window." - :group 'winsize) - - -;;; These variables all holds values to be reset when exiting resizing: - -(defvar winsize-old-mode-line-bg nil) -(defvar winsize-old-mode-line-inactive-bg nil) -(defvar winsize-old-overriding-terminal-local-map nil) -(defvar winsize-old-overriding-local-map-menu-flag nil) -(defvar winsize-old-temp-buffer-show-function nil) -(defvar winsize-old-mouse-avoidance-mode nil - "Hold the value of `mouse-avoidance-mode' at resizing start.") -(defvar winsize-old-view-exit-action nil) -(make-variable-buffer-local 'winsize-old-view-exit-action) - -(defvar winsize-message-end nil - "Marker, maybe at end of message buffer.") - -(defvar winsize-resizing nil - "t during resizing, nil otherwise.") - -(defvar winsize-window-config-init nil - "Hold window configuration from resizing start.") - -(defvar winsize-frame nil - "Frame that `resize-windows' is operating on.") - - -;;; Borders - -(defvar winsize-window-for-side-hor nil - "Window used internally for resizing in vertical direction.") - -(defvar winsize-window-for-side-ver nil - "Window used internally for resizing in horizontal direction.") - -(defvar winsize-border-hor nil - "Use internally to remember border choice. -This is set by `winsize-pre-command' and checked by -`winsize-post-command', see the latter for more information. - -The value should be either nil, 'left or 'right.") - -(defvar winsize-border-ver nil - "Use internally to remember border choice. -This is set by `winsize-pre-command' and checked by -`winsize-post-command', see the latter for more information. - -The value should be either nil, 'up or 'down.") - -(defvar winsize-window-at-entry nil - "Window that was selected when `resize-windows' started.") - - -;;; Keymap, interactive functions etc - -(defun winsize-pre-command () - "Do this before every command. -Runs this in `pre-command-hook'. - -Remember the currently used border sides for resizing. Also -remember position in message buffer to be able to see if next -command outputs some message. - -For more information see `winsize-post-command'." - (setq winsize-message-end (winsize-message-end)) - (setq winsize-border-hor (winsize-border-used-hor)) - (setq winsize-border-ver (winsize-border-used-ver))) - -(defun winsize-post-command () - "Done after every command. -Run this in `post-command-hook'. - -Check the border sides \(left/right, up/down) remembered in -`winsize-pre-command' and use the the same side if possible, -otherwise the opposite side if that is possible. \(This check is -of course not done if the last command changed the border side.) - -The reason for selecting borders this way is to try to give the -user a coherent and easy picture of what is going on when -changing window or when window structure is changed. \(Note that -the commands moving to another window or changing the window -structure does not have to belong to this package. Those commands -can therefore not select the border sides.) - -Give the user feedback about selected window and borders. Also -give a short help message unless last command gave some message." - (unless winsize-juris-way - (unless winsize-border-hor - (winsize-select-initial-border-hor)) - (when winsize-border-hor - (winsize-set-border winsize-border-hor t)) - (unless winsize-border-ver - (winsize-select-initial-border-ver)) - (when winsize-border-ver - (winsize-set-border winsize-border-ver t))) - (winsize-tell-user)) - -;;;###autoload -(defun resize-windows () - "Start window resizing. -During resizing a window is selected. You can move its -borders. In the default configuration the arrow keys moves the -right or bottom border if they are there. To move the opposite -border use S-arrowkeys. - -You can also do other window operations, like splitting, deleting -and balancing the sizes. The keybindings below describes the key -bindings during resizing:\\<winsize-keymap> - - `balance-windows' \\[balance-windows] - `winsize-balance-siblings' \\[winsize-balance-siblings] - `fit-window-to-buffer' \\[fit-window-to-buffer] - `shrink-window-if-larger-than-buffer' \\[shrink-window-if-larger-than-buffer] - - `winsav-rotate' \\[winsav-rotate] - - `winsize-move-border-up' \\[winsize-move-border-up] - `winsize-move-border-down' \\[winsize-move-border-down] - `winsize-move-border-left' \\[winsize-move-border-left] - `winsize-move-border-right' \\[winsize-move-border-right] - - `winsize-to-border-or-window-left' \\[winsize-to-border-or-window-left] - `winsize-to-border-or-window-up' \\[winsize-to-border-or-window-up] - `winsize-to-border-or-window-right' \\[winsize-to-border-or-window-right] - `winsize-to-border-or-window-down' \\[winsize-to-border-or-window-down] - - Note that you can also use your normal keys for - `forward-char', `backward-char', `next-line', `previous-line' - and what you have on HOME and END to move in the windows. That - might sometimes be necessary to directly select a - window. \(You may however also use `other-window' or click - with the mouse, see below.) - - `delete-window' \\[delete-window] - `delete-other-windows' \\[delete-other-windows] - `split-window-vertically' \\[split-window-vertically] - `split-window-horizontally' \\[split-window-horizontally] - `other-window' \\[other-window] - - `winsize-save-window-configuration' \\[winsize-save-window-configuration] - `winsize-next-window-configuration' \\[winsize-next-window-configuration] - `winsize-previous-window-configuration' \\[winsize-previous-window-configuration] - - `mouse-set-point' \\[mouse-set-point] - - `winsize-quit' \\[winsize-quit] - `winsize-stop-go-back' \\[winsize-stop-go-back] - `winsize-stop' \\[winsize-stop] - `winsize-stop-and-execute' \\[winsize-stop-and-execute] - - `winsize-help' \\[winsize-help] - `describe-key' \\[describe-key] - `describe-key-briefly' \\[describe-key-briefly] - (All the normal help keys work, and at least those above will - play well with resizing.) - -Nearly all other keys exits window resizing and they are also -executed. However, the key sequences in `winsize-let-me-use' and -dito for commands there are also executed without exiting -resizing. - -The colors of the modelines are changed to those given in -`winsize-mode-line-colors' to indicate that you are resizing -windows. To make this indication more prominent the text in the -selected window is marked with the face hold in the variable -`winsize-selected-window-face'. - -The option `winsize-juris-way' decides how the borders to move -are selected. If this option is non-nil then the right or bottom -border are the ones that are moved with the arrow keys and the -opposite border with shift arrow keys. - -If `winsize-juris-way' is nil then the following apply: - -As you select other borders or move to new a window the mouse -pointer is moved inside the selected window to show which borders -are beeing moved. The mouse jumps a little bit to make its -position more visible. You can turn this off by customizing -`winsize-make-mouse-prominent'. - -Which borders initially are choosen are controlled by the -variable `winsize-autoselect-borders'. - -** Example: Border selection, movements and windows. - - Suppose you have a frame divided into windows like in the - figure below. If window B is selected when you start resizing - then \(with default settings) the borders marked with 'v' and - 'h' will be the ones that the arrow keys moves. To indicate - this the mouse pointer is placed in the right lower corner of - the selected window B. - - +----------+-----------+--------+ - | | v | - | | v | - | A | _B_ v | - | | v | - | | v | - | | x v | - +hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh+ - | | | - | | | - | | | - | | | - | | | - | | | - +----------+---------+----------+ - - Now if you press M-<left> then the picture below shows what has - happened. Note that the selected vertical border is now the one - between A and B. The mouse pointer has moved to the - corresponding corner in the window B, which is still selected. - - +----------+-----------+--------+ - | v | | - | v | | - | A v _B_ | | - | v | | - | v | | - | v x | | - +hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh+ - | | | - | | | - | | | - | | | - | | | - | | | - +----------+---------+----------+ - - Press M-<left> once again. This gives this picture: - - +----------+-----------+--------+ - | v | | - | v | | - | _A_ v B | | - | v | | - | v | | - | x v | | - +hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh+ - | | | - | | | - | | | - | | | - | | | - | | | - +----------+---------+----------+ - - Note that the window A is now selected. However there is no - border that could be moved to the left of this window \(which - would otherwise be chosen now) so the border between A and B is - still the one that <left> and <right> moves. The mouse has - moved to A. - - If we now delete window A the new situation will look like - this: - - +----------+-----------+--------+ - | | | - | | | - | _B_ | | - | | | - | | | - | x | | - +hhhhhhhhhhhhhhhhhhhhhhhhhhhhhhh+ - | | | - | | | - | | | - | | | - | | | - | | | - +----------+---------+----------+ - - - ->>>> testing stuff >>>> -`help-mode-hook' -`temp-buffer-show-function' -`view-exit-action' -<<<<<<<<<<<<<<<<<<<<<<< -" - (interactive) - (setq winsize-resizing t) - ;; Save old values: - (unless winsize-old-mouse-avoidance-mode - (setq winsize-old-mouse-avoidance-mode mouse-avoidance-mode)) - ;; Setup user feedback things: - (mouse-avoidance-mode 'none) - (winsize-set-mode-line-colors t) - (winsize-create-short-help-message) - (setq winsize-message-end (winsize-message-end)) - ;; Save config for exiting: - (setq winsize-window-config-init (current-window-configuration)) - (setq winsize-window-at-entry (selected-window)) - (setq winsize-frame (selected-frame)) - ;; Setup keymap and command hooks etc: - (winsize-setup-local-map) - (winsize-add-command-hooks) - (setq winsize-window-for-side-hor nil) - (setq winsize-window-for-side-ver nil)) - - -(defun winsize-setup-local-map () - "Setup an overriding keymap and use this during resizing. -Save current keymaps." - ;; Fix-me: use copy-keymap for old? - (unless winsize-old-overriding-terminal-local-map - (setq winsize-old-overriding-terminal-local-map overriding-terminal-local-map)) - (setq overriding-terminal-local-map (copy-keymap winsize-keymap)) - (setq winsize-old-overriding-local-map-menu-flag overriding-local-map-menu-flag) - (setq overriding-local-map-menu-flag t)) - -(defun winsize-restore-local-map () - "Restore keymaps saved by `winsize-setup-local-map'." - (setq overriding-terminal-local-map winsize-old-overriding-terminal-local-map) - (setq winsize-old-overriding-terminal-local-map nil) - (setq overriding-local-map-menu-flag winsize-old-overriding-local-map-menu-flag) - (setq winsize-old-overriding-local-map-menu-flag nil)) - - -(defvar winsize-window-config-help nil - "Hold window configuration when help is shown.") - -(defvar winsize-window-config-init-help nil - "Hold window configuration from resizing start during help.") - -(defvar winsize-help-frame nil - "The frame from which help was called.") - -(defun winsize-restore-after-help (buffer) - "Restore window configuration after help. -Raise frame and reactivate resizing." - (remove-hook 'temp-buffer-setup-hook 'winsize-help-mode-hook-function) - (setq temp-buffer-show-function winsize-old-temp-buffer-show-function) - ;; Get rid of the view exit action and the extra text in the help - ;; buffer: - (with-current-buffer (help-buffer) - (setq view-exit-action winsize-old-view-exit-action) - (setq winsize-old-view-exit-action nil) - (let ((here (point-marker)) - (inhibit-read-only t)) - (goto-char (point-min)) - (forward-line 2) - (delete-region (point-min) (point)) - (goto-char (point-max)) - (forward-line -2) - (delete-region (point) (point-max)) - (goto-char here))) - ;; Restart resizing, restoring window configurations: - (when (select-frame winsize-help-frame) - (raise-frame) - (set-window-configuration winsize-window-config-help) - (resize-windows) - (setq winsize-window-config-init winsize-window-config-init-help))) - -(defun winsize-help-mode-hook-function () - "Setup temp buffer show function to only run second step. -The first step, `winsize-temp-buffer-show-function', has already been run." - (setq temp-buffer-show-function 'winsize-temp-buffer-show-function-1)) - -(defun winsize-temp-buffer-show-function (buffer) - "First step of setup for showing help during resizing. -This step is run when showing help during resizing. - -Save window configuration etc to be able to resume resizing. Stop -resizing. Delete other windows. - -Run second step (`winsize-temp-buffer-show-function-1') and -arrange so that second step is run when following help links." - (setq winsize-window-config-help (current-window-configuration)) - (setq winsize-window-config-init-help winsize-window-config-init) - (setq winsize-help-frame (selected-frame)) - (winsize-stop) - (delete-other-windows) - (winsize-temp-buffer-show-function-1 buffer) - (add-hook 'temp-buffer-setup-hook 'winsize-help-mode-hook-function)) - -(defun winsize-temp-buffer-show-function-1 (buffer) - "Second step of setup for showing help during resizing. -This is run after the first step when accessing help during -resizing. It is also when following help links." - (with-current-buffer buffer - (let ((inhibit-read-only t) - (buffer-read-only t) ;; It is reverted in `help-mode-finish' - ) - (run-hooks 'temp-buffer-show-hook)) - (let ((here (point-marker)) - (str "*** Type q to return to window resizing ***")) - (put-text-property 0 (length str) 'face 'highlight str) - (goto-char (point-min)) - (insert str "\n\n") - (goto-char (point-max)) - (insert "\n\n" str) - (goto-char here) - (setq buffer-read-only t)) - (unless winsize-old-view-exit-action - (setq winsize-old-view-exit-action view-exit-action) - (setq view-exit-action 'winsize-restore-after-help))) - (set-window-buffer (selected-window) buffer) - (message "Type q to return to window resizing")) - -(defun winsize-help () - "Give help during resizing. -Save current window configuration and pause resizing." - (interactive) - (if pop-up-frames - (progn - (winsize-exit-resizing nil) - (describe-function 'resize-windows)) - ;; Fix-me: move setup of view-exit-action etc here. Or was it - ;; temp-buffer-show-function? - ;; Setup help hooks etc: - (unless (or winsize-old-temp-buffer-show-function - ;; These things should not happen... : - (eq temp-buffer-show-function 'winsize-temp-buffer-show-function) - (eq temp-buffer-show-function 'winsize-temp-buffer-show-function-1)) - (setq winsize-old-temp-buffer-show-function temp-buffer-show-function)) - (setq temp-buffer-show-function 'winsize-temp-buffer-show-function) - (with-output-to-temp-buffer (help-buffer) - (with-current-buffer (help-buffer) - (insert "resize-windows is ") - (describe-function-1 'resize-windows))))) - -(defun winsize-quit () - "Quit resing, restore window configuration at start." - (interactive) - (set-window-configuration winsize-window-config-init) - (winsize-exit-resizing nil)) - -(defun winsize-stop-go-back () - "Exit window resizing. Go back to the window started in." - (interactive) - (winsize-exit-resizing nil t)) - -(defun winsize-stop-and-execute () - "Exit window resizing and put last key on the input queue. -Select the window marked during resizing before putting back the -last key." - ;; Fix-me: maybe replace this with a check of this-command in - ;; post-command-hook instead? - (interactive) - (winsize-exit-resizing t)) - -(defun winsize-stop () - "Exit window resizing. -Select the window marked during resizing." - (interactive) - (winsize-exit-resizing nil)) - -;;;###autoload -(defun winsize-balance-siblings () - "Make current window siblings the same height or width. -It works the same way as `balance-windows', but only for the -current window and its siblings." - (interactive) - (balance-windows (selected-window))) - -(defun winsize-to-border-or-window-left () - "Switch to border leftwards, maybe moving to next window. -If already at the left border, then move to left window, the same -way `windmove-left' does." - (interactive) (winsize-switch-border 'left t)) - -(defun winsize-to-border-or-window-right () - "Switch to border rightwards, maybe moving to next window. -For more information see `winsize-to-border-or-window-left'." - (interactive) (winsize-switch-border 'right t)) - -(defun winsize-to-border-or-window-up () - "Switch to border upwards, maybe moving to next window. -For more information see `winsize-to-border-or-window-left'." - (interactive) (winsize-switch-border 'up t)) - -(defun winsize-to-border-or-window-down () - "Switch to border downwards, maybe moving to next window. -For more information see `winsize-to-border-or-window-left'." - (interactive) (winsize-switch-border 'down t)) - - -(defun winsize-move-border-left () - "Move border left, but select border first if not done." - (interactive) (winsize-resize 'left nil)) - -(defun winsize-move-border-right () - "Move border right, but select border first if not done." - (interactive) (winsize-resize 'right nil)) - -(defun winsize-move-border-up () - "Move border up, but select border first if not done." - (interactive) (winsize-resize 'up nil)) - -(defun winsize-move-border-down () - "Move border down, but select border first if not done." - (interactive) (winsize-resize 'down nil)) - - -(defun winsize-move-other-border-left () - "Move border left, but select border first if not done." - (interactive) (winsize-resize 'left t)) - -(defun winsize-move-other-border-right () - "Move border right, but select border first if not done." - (interactive) (winsize-resize 'right t)) - -(defun winsize-move-other-border-up () - "Move border up, but select border first if not done." - (interactive) (winsize-resize 'up t)) - -(defun winsize-move-other-border-down () - "Move border down, but select border first if not done." - (interactive) (winsize-resize 'down t)) - - -;;; Internals - - - -(defun winsize-exit-resizing (put-back-last-event &optional stay) - "Stop window resizing. -Put back mode line colors and keymaps that were changed. - -Upon exit first select window. If STAY is non-nil then select -the window which was selected when `resize-windows' was called, -otherwise select the last window used during resizing. After -that, if PUT-BACK-LAST-EVENT is non-nil, put back the last input -event on the input queue." - (setq winsize-resizing nil) - ;; Reset user feedback things: - (mouse-avoidance-mode winsize-old-mouse-avoidance-mode) - (setq winsize-old-mouse-avoidance-mode nil) - (winsize-set-mode-line-colors nil) - (winsize-mark-selected-window nil) - ;; Remove all hooks etc for help: - (if (or (eq winsize-old-temp-buffer-show-function 'winsize-temp-buffer-show-function) - (eq winsize-old-temp-buffer-show-function 'winsize-temp-buffer-show-function-1)) - (setq temp-buffer-show-function nil) - (setq temp-buffer-show-function winsize-old-temp-buffer-show-function)) - (setq winsize-old-temp-buffer-show-function nil) - (remove-hook 'help-mode-hook 'winsize-help-mode-hook-function) - (remove-hook 'temp-buffer-setup-hook 'winsize-help-mode-hook-function) - ;; Restore keymap and command hooks: - (winsize-restore-local-map) - (winsize-remove-command-hooks) - ;; Exit: - (when stay (select-window winsize-window-at-entry)) - (message "Exited window resizing") - (when (and put-back-last-event) - ;; Add this to the input queue again: - (isearch-unread last-command-event))) - -(defun winsize-add-command-hooks () - (add-hook 'pre-command-hook 'winsize-pre-command) - (add-hook 'post-command-hook 'winsize-post-command)) - -(defun winsize-remove-command-hooks () - (remove-hook 'pre-command-hook 'winsize-pre-command) - (remove-hook 'post-command-hook 'winsize-post-command)) - - -;;; Borders - -(defun winsize-border-used-hor () - "Return the border side used for horizontal resizing." - (let ((hor (when winsize-window-for-side-hor - (if (eq (selected-window) winsize-window-for-side-hor) - 'right - 'left)))) - hor)) - -(defun winsize-border-used-ver () - "Return the border side used for vertical resizing." - (let ((ver (when winsize-window-for-side-ver - (if (eq (selected-window) winsize-window-for-side-ver) - 'down - 'up)))) - ver)) - -(defun winsize-switch-border (dir allow-windmove) - "Switch border that is beeing resized. -Switch to border in direction DIR. If ALLOW-WINDMOVE is non-nil -then change window if necessary, otherwise stay and do not change -border." - (let* ((window-in-that-dir (windmove-find-other-window - dir nil (selected-window)))) - (when (window-minibuffer-p window-in-that-dir) - (setq window-in-that-dir nil)) - (if winsize-juris-way - (if (not window-in-that-dir) - (message "No window in that direction") - (windmove-do-window-select dir nil)) - (if (not window-in-that-dir) - (message "No window or border in that direction") - (let* ((is-hor (memq dir '(left right))) - (border-used (if is-hor - (winsize-border-used-hor) - (winsize-border-used-ver))) - (using-dir-border (eq dir border-used))) - (if using-dir-border - (when allow-windmove - (setq winsize-window-for-side-hor nil) - (setq winsize-window-for-side-ver nil) - (windmove-do-window-select dir nil) - (message "Moved to new window")) - (winsize-select-border dir) - (message "Switched to border %swards" dir))))))) - - -(defun winsize-select-initial-border-hor () - "Select a default border horizontally." - (if winsize-juris-way - (winsize-set-border 'right t) - (let ((has-left (winsize-window-beside (selected-window) 'left)) - (has-right (winsize-window-beside (selected-window) 'right))) - (cond - ((not winsize-autoselect-borders) t) - ((eq winsize-autoselect-borders 'when-single) - (when (= 1 (length (delq nil (list has-left has-right)))) - (winsize-select-border 'right))) - (t - (winsize-select-border 'right)))))) - -(defun winsize-select-initial-border-ver () - "Select a default border vertically." - (if winsize-juris-way - (winsize-set-border 'up t) - (let ((has-up (winsize-window-beside (selected-window) 'up)) - (has-down (winsize-window-beside (selected-window) 'down))) - (cond - ((not winsize-autoselect-borders) t) - ((eq winsize-autoselect-borders 'when-single) - (when (= 1 (length (delq nil (list has-up has-down)))) - (winsize-select-border 'up))) - (t - (winsize-select-border 'up)))))) - -(defun winsize-select-border (dir) - "Select border to be set for resizing. -The actually setting is done in `post-command-hook'." - (cond - ((memq dir '(left right)) - (setq winsize-border-hor dir)) - ((memq dir '(up down)) - (setq winsize-border-ver dir)) - (t (error "Bad DIR=%s" dir)))) - -(defun winsize-set-border (dir allow-other-side) - "Set border for resizing." - (let ((window-beside (winsize-window-beside (selected-window) dir)) - (horizontal (memq dir '(left right)))) - (unless window-beside - (when allow-other-side - (setq dir (winsize-other-side dir)) - (setq window-beside - (winsize-window-beside (selected-window) dir)))) - (if horizontal - (progn - (setq winsize-border-hor nil) - (setq winsize-window-for-side-hor nil)) - (setq winsize-border-ver nil) - (setq winsize-window-for-side-ver nil)) - (when window-beside - (let ((window-for-side (if (memq dir '(right down)) - (selected-window) - window-beside))) - (if horizontal - (setq winsize-window-for-side-hor window-for-side) - (setq winsize-window-for-side-ver window-for-side)))))) - -(defun winsize-resize (dir other-side) - "Choose border to move. Or if border is chosen move that border. -Used by `winsize-move-border-left' etc." - (when winsize-juris-way - (let ((bside (if (memq dir '(left right)) - (if other-side 'left 'right) - (if other-side 'up 'down)))) - (winsize-set-border bside t))) - (let* ((horizontal (memq dir '(left right))) - (arg (if (memq dir '(left up)) -1 1)) - (window-for-side (if horizontal 'winsize-window-for-side-hor 'winsize-window-for-side-ver)) - (window-for-side-val (symbol-value window-for-side))) - (if (not window-for-side-val) - (winsize-select-border dir) - (when (and winsize-resizing - (not (eq window-for-side-val 'checked))) - (condition-case err - (adjust-window-trailing-edge (symbol-value window-for-side) arg horizontal) - (error (message "%s" (error-message-string err)))))))) - -(defun winsize-other-side (side) - "Return other side for 'left etc, ie 'left => 'right." - (cond - ((eq side 'left) 'right) - ((eq side 'right) 'left) - ((eq side 'up) 'down) - ((eq side 'down) 'up) - (t (error "Invalid SIDE=%s" side)))) - -(defun winsize-window-beside (window side) - "Return a window directly beside WINDOW at side SIDE. -That means one whose edge on SIDE is touching WINDOW. SIDE -should be one of 'left, 'up, 'right and 'down." - (require 'windmove) - (let* ((windmove-wrap-around nil) - (win (windmove-find-other-window side nil window))) - (unless (window-minibuffer-p win) - win))) - - -;;; Window configs - -(defconst winsize-window-configuration-ring (make-ring 20) - "Hold window configurations.") - -(defun winsize-ring-rotate (ring forward) - (when (< 1 (ring-length ring)) - (if forward - (ring-insert ring (ring-remove ring nil)) - (ring-insert-at-beginning ring (ring-remove ring 0))))) - -(defun winsize-ring-index (ring elem) - (let ((memb (member elem (ring-elements ring)))) - (when memb - (- (ring-length ring) - (length memb))))) - -(defun winsize-previous-window-configuration () - (interactive) - (winsize-goto-window-configuration nil)) - -(defun winsize-next-window-configuration () - (interactive) - (winsize-goto-window-configuration t)) - -(defun winsize-goto-window-configuration (forward) - (let* ((curr-conf (current-window-configuration)) - (ring winsize-window-configuration-ring) - (idx (winsize-ring-index ring curr-conf))) - (if idx - (progn - (setq idx (if forward (1- idx) (1+ idx))) - (set-window-configuration (ring-ref ring idx))) - ;; Unfortunately idx often seems to be nil so we will have to - ;; rotate the ring (or something similar). - (winsize-ring-rotate ring forward) - (set-window-configuration (ring-ref ring 0))))) - -;;;###autoload -(defun winsize-save-window-configuration () - (interactive) - (let* ((curr-conf (current-window-configuration)) - (ring winsize-window-configuration-ring)) - (if (winsize-ring-index ring curr-conf) - (error "Current configuration was already stored") - (ring-insert ring curr-conf) - (message "Saved window config, use '<' or '>' to get it back")))) - - -;;; User feedback - -;;;###autoload -(defun winsize-set-mode-line-colors (on) - "Turn mode line colors on if ON is non-nil, otherwise off." - (if on - (progn - (unless winsize-old-mode-line-inactive-bg - (setq winsize-old-mode-line-inactive-bg (face-attribute 'mode-line-inactive :background))) - (unless winsize-old-mode-line-bg - (setq winsize-old-mode-line-bg (face-attribute 'mode-line :background))) - (let* ((use-colors (car winsize-mode-line-colors)) - (colors (cadr winsize-mode-line-colors)) - (active-color (elt colors 0)) - (inactive-color (elt colors 1))) - (when use-colors - (set-face-attribute 'mode-line-inactive nil :background inactive-color) - (set-face-attribute 'mode-line nil :background active-color)))) - (when winsize-old-mode-line-inactive-bg - (set-face-attribute 'mode-line-inactive nil :background winsize-old-mode-line-inactive-bg)) - (setq winsize-old-mode-line-inactive-bg nil) - (when winsize-old-mode-line-bg - (set-face-attribute 'mode-line nil :background winsize-old-mode-line-bg)) - (setq winsize-old-mode-line-bg nil))) - -(defvar winsize-short-help-message nil - "Short help message shown in echo area.") - -(defun winsize-create-short-help-message () - "Create short help message to show in echo area." - (let ((msg "")) - (mapc (lambda (rec) - (let ((fun (elt rec 0)) - (desc (elt rec 1)) - (etc (elt rec 2))) - (when (< 0 (length msg)) - (setq msg (concat msg ", "))) - (setq msg (concat msg - desc - ":" - (key-description - (where-is-internal fun winsize-keymap t)) - (if etc " etc" ""))))) - '( - (balance-windows "balance" nil) - (winsize-move-border-left "resize" t) - (winsize-to-border-or-window-left "border" nil) - )) - (setq msg (concat msg ", exit:RET, help:?")) - (setq winsize-short-help-message msg))) - -(defun winsize-move-mouse-to-resized () - "Move mouse to show which border(s) are beeing moved." - (let* ((edges (window-edges (selected-window))) - (L (nth 0 edges)) - (T (nth 1 edges)) - (R (nth 2 edges)) - (B (nth 3 edges)) - (x (/ (+ L R) 2)) - (y (/ (+ T B) 2))) - (when (and winsize-window-for-side-hor - (not (eq winsize-window-for-side-hor 'checked))) - (setq x (if (eq (selected-window) winsize-window-for-side-hor) (- R 6) (+ L 2)))) - (when (and winsize-window-for-side-ver - (not (eq winsize-window-for-side-ver 'checked))) - (setq y (if (eq (selected-window) winsize-window-for-side-ver) (- B 2) (+ T 0)))) - (set-mouse-position (selected-frame) x y))) - -(defvar winsize-selected-window-overlay nil) - -(defun winsize-mark-selected-window (active) - (when winsize-selected-window-overlay - (delete-overlay winsize-selected-window-overlay) - (setq winsize-selected-window-overlay nil)) - (when active - (with-current-buffer (window-buffer (selected-window)) - (let ((ovl (make-overlay (point-min) (point-max) nil t))) - (setq winsize-selected-window-overlay ovl) - (overlay-put ovl 'window (selected-window)) - (overlay-put ovl 'pointer 'arrow) - (overlay-put ovl 'priority 1000) - (when winsize-selected-window-face - (overlay-put ovl 'face winsize-selected-window-face)))))) - -(defun winsize-message-end () - "Return a marker at the end of the message buffer." - (with-current-buffer (get-buffer-create "*Messages*") - (point-max-marker))) - -(defvar winsize-move-mouse 1) - -(defvar winsize-make-mouse-prominent-timer nil) - -(defun winsize-move-mouse () - ;;(setq winsize-move-mouse (- winsize-move-mouse)) - (save-match-data ;; runs in timer - (let* ((fxy (mouse-pixel-position)) - (f (car fxy)) - (x (cadr fxy)) - (y (cddr fxy)) - (m (mod winsize-move-mouse 2)) - (d (* (if (= 0 m) 1 -1) 1))) - (set-mouse-pixel-position f (+ d x) (+ d y)) - (when (< 1 winsize-move-mouse) - (setq winsize-move-mouse (1- winsize-move-mouse)) - (setq winsize-make-mouse-prominent-timer - (run-with-timer 0.2 nil 'winsize-move-mouse)))))) - -(defun winsize-make-mouse-prominent-f (doit) - (when (and winsize-make-mouse-prominent-timer - (timerp winsize-make-mouse-prominent-timer)) - (cancel-timer winsize-make-mouse-prominent-timer)) - (when doit - (setq winsize-move-mouse 3) - (setq winsize-make-mouse-prominent-timer - (run-with-idle-timer 0.1 nil 'winsize-move-mouse)))) - -(defun winsize-tell-user () - "Give the user feedback." - (when winsize-mark-selected-window - (winsize-mark-selected-window t)) - (unless winsize-juris-way - (let ((move-mouse (not (member this-command - '(mouse-drag-mode-line - mouse-drag-vertical-line - scroll-bar-toolkit-scroll))))) - ;;(message "%s, move-mouse=%s" this-command move-mouse);(sit-for 2) - (when move-mouse - (winsize-move-mouse-to-resized)) - (when winsize-make-mouse-prominent - (winsize-make-mouse-prominent-f move-mouse)))) - (when (= winsize-message-end (winsize-message-end)) - (message "%s" winsize-short-help-message))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Window rotating and mirroring - -;;;###autoload -(defun winsav-rotate (mirror transpose) - "Rotate window configuration on selected frame. -MIRROR should be either 'mirror-left-right, 'mirror-top-bottom or -nil. In the first case the window configuration is mirrored -vertically and in the second case horizontally. If MIRROR is nil -the configuration is not mirrored. - -If TRANSPOSE is non-nil then the window structure is transposed -along the diagonal from top left to bottom right (in analogy with -matrix transosition). - -If called interactively MIRROR will is 'mirror-left-right by -default, but 'mirror-top-bottom if called with prefix. TRANSPOSE -is t. This mean that the window configuration will be turned one -quarter clockwise (or counter clockwise with prefix)." - (interactive (list - (if current-prefix-arg - 'mirror-left-right - 'mirror-top-bottom) - t)) - (require 'winsav) - (let* ((wintree (winsav-get-window-tree)) - (tree (cadr wintree)) - (win-config (current-window-configuration))) - ;;(winsav-log "old-wintree" wintree) - (winsav-transform-1 tree mirror transpose) - ;;(winsav-log "new-wintree" wintree) - ;; - ;; Fix-me: Stay in corresponding window. How? - (delete-other-windows) - (condition-case err - (winsav-put-window-tree wintree (selected-window)) - (error - (set-window-configuration win-config) - (message "Can't rotate: %s" (error-message-string err)))) - )) - - -(provide 'winsize) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; winsize.el ends here diff --git a/emacs.d/nxhtml/util/wrap-to-fill.el b/emacs.d/nxhtml/util/wrap-to-fill.el deleted file mode 100644 index 223ce1b..0000000 --- a/emacs.d/nxhtml/util/wrap-to-fill.el +++ /dev/null @@ -1,364 +0,0 @@ -;;; wrap-to-fill.el --- Make a fill-column wide space for editing -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2009-08-12 Wed -;; Version: -;; Last-Updated: x -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; None -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; 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, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'mumamo)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; Wrapping - -;;;###autoload -(defgroup wrap-to-fill nil - "Customizing of `wrap-to-fill-column-mode'." - :group 'convenience) - -;;;###autoload -(defcustom wrap-to-fill-left-marg nil - "Left margin handling for `wrap-to-fill-column-mode'. -Used by `wrap-to-fill-column-mode'. If nil then center the -display columns. Otherwise it should be a number which will be -the left margin." - :type '(choice (const :tag "Center" nil) - (integer :tag "Left margin")) - :group 'wrap-to-fill) -(make-variable-buffer-local 'wrap-to-fill-left-marg) - -(defvar wrap-to-fill--saved-state nil) -;;(make-variable-buffer-local 'wrap-to-fill--saved-state) -(put 'wrap-to-fill--saved-state 'permanent-local t) - -;;;###autoload -(defcustom wrap-to-fill-left-marg-modes - '(text-mode - fundamental-mode) - "Major modes where `wrap-to-fill-left-margin' may be nil." - :type '(repeat command) - :group 'wrap-to-fill) - - - ;;ThisisaVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryLongWord ThisisaVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryVeryLongWord - -(defun wrap-to-fill-wider () - "Increase `fill-column' with 10." - (interactive) - (setq fill-column (+ fill-column 10)) - (wrap-to-fill-set-values-in-buffer-windows)) - -(defun wrap-to-fill-narrower () - "Decrease `fill-column' with 10." - (interactive) - (setq fill-column (- fill-column 10)) - (wrap-to-fill-set-values-in-buffer-windows)) - -(defun wrap-to-fill-normal () - "Reset `fill-column' to global value." - (interactive) - ;;(setq fill-column (default-value 'fill-column)) - (kill-local-variable 'fill-column) - (wrap-to-fill-set-values-in-buffer-windows)) - -(defvar wrap-to-fill-column-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control ?c) ?+] 'wrap-to-fill-wider) - (define-key map [(control ?c) ?-] 'wrap-to-fill-narrower) - (define-key map [(control ?c) ?0] 'wrap-to-fill-normal) - map)) - -;; Fix-me: Maybe make the `wrap-prefix' behavior an option or separate -;; minor mode. - -;; Fix-me: better handling of left-column in mumamo buffers (and other -;; if possible). - -;;;###autoload -(define-minor-mode wrap-to-fill-column-mode - "Use `fill-column' display columns in buffer windows. -By default the display columns are centered, but see the option -`wrap-to-fill-left-marg'. - -Fix-me: -Note 1: When turning this on `visual-line-mode' is also turned on. This -is not reset when turning off this mode. - -Note 2: The text properties 'wrap-prefix and 'wrap-to-fill-prefix -is set by this mode to indent continuation lines. - -Key bindings added by this minor mode: - -\\{wrap-to-fill-column-mode-map}" - :lighter " WrapFill" - :group 'wrap-to-fill - ;; (message "wrap-to-fill-column-mode %s, cb=%s, major=%s, multi=%s" wrap-to-fill-column-mode (current-buffer) - ;; major-mode mumamo-multi-major-mode) - (if wrap-to-fill-column-mode - (progn - ;; Old values (idea from visual-line-mode) - (set (make-local-variable 'wrap-to-fill--saved-state) nil) - (dolist (var '(visual-line-mode - ;;left-margin-width - ;;right-margin-width - )) - (push (list var (symbol-value var) (local-variable-p var)) - wrap-to-fill--saved-state)) - ;; Hooks - (add-hook 'window-configuration-change-hook 'wrap-to-fill-set-values nil t) - ;; Wrapping - (visual-line-mode 1) - (wrap-to-fill-set-values-in-buffer-windows)) - ;; Hooks - (remove-hook 'window-configuration-change-hook 'wrap-to-fill-set-values t) - ;; Old values - (dolist (saved wrap-to-fill--saved-state) - (let ((var (nth 0 saved)) - (val (nth 1 saved)) - (loc (nth 2 saved))) - (cond - ((eq var 'visual-line-mode) - (unless val (visual-line-mode -1))) - (t - (if loc - (set (make-local-variable var) val) - (kill-local-variable var)))))) - (kill-local-variable 'wrap-to-fill--saved-state) - ;; Margins - (dolist (win (get-buffer-window-list (current-buffer))) - (set-window-margins win left-margin-width right-margin-width)) - ;; Indentation - (let ((here (point)) - (inhibit-field-text-motion t) - beg-pos - end-pos) - (mumamo-with-buffer-prepared-for-jit-lock - (save-restriction - (widen) - (goto-char (point-min)) - (while (< (point) (point-max)) - (setq beg-pos (point)) - (setq end-pos (line-end-position)) - (when (equal (get-text-property beg-pos 'wrap-prefix) - (get-text-property beg-pos 'wrap-to-fill-prefix)) - (remove-list-of-text-properties - beg-pos end-pos - '(wrap-prefix))) - (forward-line)) - (remove-list-of-text-properties - (point-min) (point-max) - '(wrap-to-fill-prefix))) - (goto-char here)))) - (wrap-to-fill-font-lock wrap-to-fill-column-mode)) -(put 'wrap-to-fill-column-mode 'permanent-local t) - -(defcustom wrap-to-fill-major-modes '(org-mode - html-mode - nxhtml-mode) - "Major modes where to turn on `wrap-to-fill-column-mode'" - ;;:type '(repeat major-mode) - :type '(repeat command) - :group 'wrap-to-fill) - -(defun wrap-to-fill-turn-on-in-buffer () - "Turn on fun for globalization." - (when (catch 'turn-on - (dolist (m wrap-to-fill-major-modes) - (when (derived-mode-p m) - (throw 'turn-on t)))) - (wrap-to-fill-column-mode 1))) - -(define-globalized-minor-mode wrap-to-fill-column-global-mode wrap-to-fill-column-mode - wrap-to-fill-turn-on-in-buffer - :group 'wrap-to-fill) - -;; Fix-me: There is a confusion between buffer and window margins -;; here. Also the doc says that left-margin-width and dito right may -;; be nil. However they seem to be 0 by default, but when displaying a -;; buffer in a window then window-margins returns (nil). - -(defvar wrap-to-fill-timer nil) -(make-variable-buffer-local 'wrap-to-fill-timer) - -(defun wrap-to-fill-set-values () - (when (timerp wrap-to-fill-timer) - (cancel-timer wrap-to-fill-timer)) - (setq wrap-to-fill-timer - (run-with-idle-timer 0 nil 'wrap-to-fill-set-values-in-timer - (selected-window) (current-buffer)))) -(put 'wrap-to-fill-set-values 'permanent-local-hook t) - -(defun wrap-to-fill-set-values-in-timer (win buf) - (condition-case err - (when (buffer-live-p buf) - (wrap-to-fill-set-values-in-buffer-windows buf)) - (error (message "ERROR wrap-to-fill-set-values-in-timer: %s" - (error-message-string err))))) - -(defun wrap-to-fill-set-values-in-timer-old (win buf) - (when (and (window-live-p win) (buffer-live-p buf) - (eq buf (window-buffer win))) - (condition-case err - (with-current-buffer buf - (when wrap-to-fill-column-mode - (wrap-to-fill-set-values-in-window win))) - (error (message "ERROR wrap-to-fill-set-values: %s" - (error-message-string err)))))) - -(defun wrap-to-fill-set-values-in-buffer-windows (&optional buffer) - "Use `fill-column' display columns in buffer windows." - (let ((buf-windows (get-buffer-window-list (or buffer - (current-buffer)) - nil - t))) - (dolist (win buf-windows) - (if wrap-to-fill-column-mode - (wrap-to-fill-set-values-in-window win) - (set-window-buffer nil (current-buffer)))))) - -(defvar wrap-old-win-width nil) -(make-variable-buffer-local 'wrap-old-win-width) -;; Fix-me: compensate for left-margin-width etc -(defun wrap-to-fill-set-values-in-window (win) - (with-current-buffer (window-buffer win) - (when wrap-to-fill-column-mode - (let* ((win-width (window-width win)) - (win-margs (window-margins win)) - (win-full (+ win-width - (or (car win-margs) 0) - (or (cdr win-margs) 0))) - (extra-width (- win-full fill-column)) - (fill-left-marg (unless (memq major-mode wrap-to-fill-left-marg-modes) - (or (when (> left-margin-width 0) left-margin-width) - wrap-to-fill-left-marg))) - (left-marg (if fill-left-marg - fill-left-marg - (- (/ extra-width 2) 1))) - ;; Fix-me: Why do I have to subtract 1 here...??? - (right-marg (- win-full fill-column left-marg 1)) - (need-update nil) - ) - ;; (when wrap-old-win-width - ;; (unless (= wrap-old-win-width win-width) - ;; (message "-") - ;; (message "win-width 0: %s => %s, win-full=%s, e=%s l/r=%s/%s %S %S %S" wrap-old-win-width win-width win-full extra-width left-marg right-marg (window-edges) (window-inside-edges) (window-margins)) - ;; )) - (setq wrap-old-win-width win-width) - (unless (> left-marg 0) (setq left-marg 0)) - (unless (> right-marg 0) (setq right-marg 0)) - (unless nil;(= left-marg (or left-margin-width 0)) - ;;(setq left-margin-width left-marg) - (setq need-update t)) - (unless nil;(= right-marg (or right-margin-width 0)) - ;;(setq right-margin-width right-marg) - (setq need-update t)) - ;;(message "win-width a: %s => %s, win-full=%s, e=%s l/r=%s/%s %S %S %S" wrap-old-win-width win-width win-full extra-width left-margin-width right-margin-width (window-edges) (window-inside-edges) (window-margins)) - (when need-update - ;;(set-window-buffer win (window-buffer win)) - ;;(run-with-idle-timer 0 nil 'set-window-buffer win (window-buffer win)) - ;;(dolist (win (get-buffer-window-list (current-buffer))) - ;; Fix-me: check window width... - (set-window-margins win left-marg right-marg) - ;;) - ;;(message "win-width b: %s => %s, win-full=%s, e=%s l/r=%s/%s %S %S %S" wrap-old-win-width win-width win-full extra-width left-marg right-marg (window-edges) (window-inside-edges) (window-margins)) - ) - )))) - -;; (add-hook 'post-command-hook 'my-win-post-command nil t) -;; (remove-hook 'post-command-hook 'my-win-post-command t) -(defun my-win-post-command () - (message "win-post-command: l/r=%s/%s %S %S %S" left-margin-width right-margin-width (window-edges) (window-inside-edges) (window-margins)) - ) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Font lock - -(defun wrap-to-fill-fontify (bound) - (save-restriction - (widen) - (while (< (point) bound) - (let ((this-bol (if (bolp) (point) - (1+ (line-end-position))))) - (unless (< this-bol bound) (setq this-bol nil)) - (when this-bol - (goto-char (+ this-bol 0)) - (let (ind-str - ind-str-fill - (beg-pos this-bol) - (end-pos (line-end-position))) - (when (equal (get-text-property beg-pos 'wrap-prefix) - (get-text-property beg-pos 'wrap-to-fill-prefix)) - ;; Find indentation - (skip-chars-forward "[:blank:]") - (setq ind-str (buffer-substring-no-properties beg-pos (point))) - ;; Any special markers like -, * etc - (if (and (< (1+ (point)) (point-max)) - (memq (char-after) '(?- ;; 45 - ?– ;; 8211 - ?* - )) - (eq (char-after (1+ (point))) ?\ )) - (setq ind-str-fill (concat " " ind-str)) - (setq ind-str-fill ind-str)) - ;;(setq ind-str-fill (concat " " ind-str)) - (mumamo-with-buffer-prepared-for-jit-lock - (put-text-property beg-pos end-pos 'wrap-prefix ind-str-fill) - (put-text-property beg-pos end-pos 'wrap-to-fill-prefix ind-str-fill)))))) - (forward-line 1)) - ;; Note: doing it line by line and returning t gave problem in mumamo. - (when nil ;this-bol - (set-match-data (list (point) (point))) - t))) - -(defun wrap-to-fill-font-lock (on) - ;; See mlinks.el - (let* ((add-or-remove (if on 'font-lock-add-keywords 'font-lock-remove-keywords)) - (fontify-fun 'wrap-to-fill-fontify) - (args (list nil `(( ,fontify-fun ( 0 'font-lock-warning-face t )))))) - (when fontify-fun - (when on (setq args (append args (list t)))) - (apply add-or-remove args) - (font-lock-mode -1) - (font-lock-mode 1)))) - -(provide 'wrap-to-fill) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; wrap-to-fill.el ends here diff --git a/emacs.d/nxhtml/util/zencoding-mode.el b/emacs.d/nxhtml/util/zencoding-mode.el deleted file mode 100644 index 2545491..0000000 --- a/emacs.d/nxhtml/util/zencoding-mode.el +++ /dev/null @@ -1,801 +0,0 @@ -;;; zencoding-mode.el --- Unfold CSS-selector-like expressions to markup -;; -;; Copyright (C) 2009, Chris Done -;; -;; Author: Chris Done <chrisdone@gmail.com> -(defconst zencoding-mode:version "0.5") -;; Last-Updated: 2009-11-20 Fri -;; Keywords: convenience -;; -;; This file is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. -;; -;; This file is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Unfold CSS-selector-like expressions to markup. Intended to be used -;; with sgml-like languages; xml, html, xhtml, xsl, etc. -;; -;; See `zencoding-mode' for more information. -;; -;; Copy zencoding-mode.el to your load-path and add to your .emacs: -;; -;; (require 'zencoding-mode) -;; -;; Example setup: -;; -;; (add-to-list 'load-path "~/Emacs/zencoding/") -;; (require 'zencoding-mode) -;; (add-hook 'sgml-mode-hook 'zencoding-mode) ;; Auto-start on any markup modes -;; -;; Enable the minor mode with M-x zencoding-mode. -;; -;; See ``Test cases'' section for a complete set of expression types. -;; -;; If you are hacking on this project, eval (zencoding-test-cases) to -;; ensure that your changes have not broken anything. Feel free to add -;; new test cases if you add new features. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; History: -;; -;; Modified by Lennart Borgman. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Generic parsing macros and utilities - -(eval-when-compile (require 'cl)) - -(defcustom zencoding-preview-default t - "If non-nil then preview is the default action. -This determines how `zencoding-expand-line' works by default." - :type 'boolean - :group 'zencoding) - -(defcustom zencoding-insert-flash-time 0.5 - "Time to flash insertion. -Set this to a negative number if you do not want flashing the -expansion after insertion." - :type '(number :tag "Seconds") - :group 'zencoding) - -(defmacro zencoding-aif (test-form then-form &rest else-forms) - "Anaphoric if. Temporary variable `it' is the result of test-form." - `(let ((it ,test-form)) - (if it ,then-form ,@(or else-forms '(it))))) - -(defmacro zencoding-pif (test-form then-form &rest else-forms) - "Parser anaphoric if. Temporary variable `it' is the result of test-form." - `(let ((it ,test-form)) - (if (not (eq 'error (car it))) ,then-form ,@(or else-forms '(it))))) - -(defmacro zencoding-parse (regex nums label &rest body) - "Parse according to a regex and update the `input' variable." - `(zencoding-aif (zencoding-regex ,regex input ',(number-sequence 0 nums)) - (let ((input (elt it ,nums))) - ,@body) - `,`(error ,(concat "expected " ,label)))) - -(defmacro zencoding-run (parser then-form &rest else-forms) - "Run a parser and update the input properly, extract the parsed - expression." - `(zencoding-pif (,parser input) - (let ((input (cdr it)) - (expr (car it))) - ,then-form) - ,@(or else-forms '(it)))) - -(defmacro zencoding-por (parser1 parser2 then-form &rest else-forms) - "OR two parsers. Try one parser, if it fails try the next." - `(zencoding-pif (,parser1 input) - (let ((input (cdr it)) - (expr (car it))) - ,then-form) - (zencoding-pif (,parser2 input) - (let ((input (cdr it)) - (expr (car it))) - ,then-form) - ,@else-forms))) - -(defun zencoding-regex (regexp string refs) - "Return a list of (`ref') matches for a `regex' on a `string' or nil." - (if (string-match (concat "^" regexp "\\([^\n]*\\)$") string) - (mapcar (lambda (ref) (match-string ref string)) - (if (sequencep refs) refs (list refs))) - nil)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Zen coding parsers - -(defun zencoding-expr (input) - "Parse a zen coding expression. This pretty much defines precedence." - (zencoding-run zencoding-siblings - it - (zencoding-run zencoding-parent-child - it - (zencoding-run zencoding-multiplier - it - (zencoding-run zencoding-pexpr - it - (zencoding-run zencoding-tag - it - '(error "no match, expecting ( or a-zA-Z0-9"))))))) - -(defun zencoding-multiplier (input) - (zencoding-por zencoding-pexpr zencoding-tag - (let ((multiplier expr)) - (zencoding-parse "\\*\\([0-9]+\\)" 2 "*n where n is a number" - (let ((multiplicand (read (elt it 1)))) - `((list ,(make-list multiplicand multiplier)) . ,input)))) - '(error "expected *n multiplier"))) - -(defun zencoding-tag (input) - "Parse a tag." - (zencoding-run zencoding-tagname - (let ((result it) - (tagname (cdr expr))) - (zencoding-pif (zencoding-run zencoding-identifier - (zencoding-tag-classes - `(tag ,tagname ((id ,(cddr expr)))) input) - (zencoding-tag-classes `(tag ,tagname ()) input)) - (let ((expr-and-input it) (expr (car it)) (input (cdr it))) - (zencoding-pif (zencoding-tag-props expr input) - it - expr-and-input)))) - '(error "expected tagname"))) - -(defun zencoding-tag-props (tag input) - (zencoding-run zencoding-props - (let ((tagname (cadr tag)) - (existing-props (caddr tag)) - (props (cdr expr))) - `((tag ,tagname - ,(append existing-props props)) - . ,input)))) - -(defun zencoding-props (input) - "Parse many props." - (zencoding-run zencoding-prop - (zencoding-pif (zencoding-props input) - `((props . ,(cons expr (cdar it))) . ,(cdr it)) - `((props . ,(list expr)) . ,input)))) - -(defun zencoding-prop (input) - (zencoding-parse - " " 1 "space" - (zencoding-run - zencoding-name - (let ((name (cdr expr))) - (zencoding-parse "=\\([^\\,\\+\\>\\ )]*\\)" 2 - "=property value" - (let ((value (elt it 1)) - (input (elt it 2))) - `((,(read name) ,value) . ,input))))))) - -(defun zencoding-tag-classes (tag input) - (zencoding-run zencoding-classes - (let ((tagname (cadr tag)) - (props (caddr tag)) - (classes `(class ,(mapconcat - (lambda (prop) - (cdadr prop)) - (cdr expr) - " ")))) - `((tag ,tagname ,(append props (list classes))) . ,input)) - `(,tag . ,input))) - -(defun zencoding-tagname (input) - "Parse a tagname a-zA-Z0-9 tagname (e.g. html/head/xsl:if/br)." - (zencoding-parse "\\([a-zA-Z][a-zA-Z0-9:-]*\\)" 2 "tagname, a-zA-Z0-9" - `((tagname . ,(elt it 1)) . ,input))) - -(defun zencoding-pexpr (input) - "A zen coding expression with parentheses around it." - (zencoding-parse "(" 1 "(" - (zencoding-run zencoding-expr - (zencoding-aif (zencoding-regex ")" input '(0 1)) - `(,expr . ,(elt it 1)) - '(error "expecting `)'"))))) - -(defun zencoding-parent-child (input) - "Parse an tag>e expression, where `n' is an tag and `e' is any - expression." - (zencoding-run zencoding-multiplier - (let* ((items (cadr expr)) - (rest (zencoding-child-sans expr input))) - (if (not (eq (car rest) 'error)) - (let ((child (car rest)) - (input (cdr rest))) - (cons (cons 'list - (cons (mapcar (lambda (parent) - `(parent-child ,parent ,child)) - items) - nil)) - input)) - '(error "expected child"))) - (zencoding-run zencoding-tag - (zencoding-child expr input) - '(error "expected parent")))) - -(defun zencoding-child-sans (parent input) - (zencoding-parse ">" 1 ">" - (zencoding-run zencoding-expr - it - '(error "expected child")))) - -(defun zencoding-child (parent input) - (zencoding-parse ">" 1 ">" - (zencoding-run zencoding-expr - (let ((child expr)) - `((parent-child ,parent ,child) . ,input)) - '(error "expected child")))) - -(defun zencoding-sibling (input) - (zencoding-por zencoding-pexpr zencoding-multiplier - it - (zencoding-run zencoding-tag - it - '(error "expected sibling")))) - -(defun zencoding-siblings (input) - "Parse an e+e expression, where e is an tag or a pexpr." - (zencoding-run zencoding-sibling - (let ((parent expr)) - (zencoding-parse "\\+" 1 "+" - (zencoding-run zencoding-expr - (let ((child expr)) - `((zencoding-siblings ,parent ,child) . ,input)) - '(error "expected second sibling")))) - '(error "expected first sibling"))) - -(defun zencoding-name (input) - "Parse a class or identifier name, e.g. news, footer, mainimage" - (zencoding-parse "\\([a-zA-Z][a-zA-Z0-9-_]*\\)" 2 "class or identifer name" - `((name . ,(elt it 1)) . ,input))) - -(defun zencoding-class (input) - "Parse a classname expression, e.g. .foo" - (zencoding-parse "\\." 1 "." - (zencoding-run zencoding-name - `((class ,expr) . ,input) - '(error "expected class name")))) - -(defun zencoding-identifier (input) - "Parse an identifier expression, e.g. #foo" - (zencoding-parse "#" 1 "#" - (zencoding-run zencoding-name - `((identifier . ,expr) . ,input)))) - -(defun zencoding-classes (input) - "Parse many classes." - (zencoding-run zencoding-class - (zencoding-pif (zencoding-classes input) - `((classes . ,(cons expr (cdar it))) . ,(cdr it)) - `((classes . ,(list expr)) . ,input)) - '(error "expected class"))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Zen coding transformer from AST to HTML - -;; Fix-me: make mode specific -(defvar zencoding-single-tags - '("br" - "img")) - -(defvar zencoding-inline-tags - '("a" - "abbr" - "acronym" - "cite" - "code" - "dfn" - "em" - "h1" "h2" "h3" "h4" "h5" "h6" - "kbd" - "q" - "span" - "strong" - "var")) - -(defvar zencoding-block-tags - '("p")) - -;; li -;; a -;; em -;; p - -(defvar zencoding-leaf-function nil - "Function to execute when expanding a leaf node in the - Zencoding AST.") - -(defun zencoding-make-tag (tag &optional content) - (let* ((name (car tag)) - (lf (if - (or - (member name zencoding-block-tags) - (and - (> (length name) 1) - (not (member name zencoding-inline-tags)) - )) - "\n" "")) - (single (member name zencoding-single-tags)) - (props (apply 'concat (mapcar - (lambda (prop) - (concat " " (symbol-name (car prop)) - "=\"" (cadr prop) "\"")) - (cadr tag))))) - (concat lf "<" name props ">" lf - (if single - "" - (concat - (if content content - (if zencoding-leaf-function - (funcall zencoding-leaf-function) - "")) - lf "</" name ">"))))) - -(defun zencoding-transform (ast) - (let ((type (car ast))) - (cond - ((eq type 'list) - (mapconcat 'zencoding-transform (cadr ast) "")) - ((eq type 'tag) - (zencoding-make-tag (cdr ast))) - ((eq type 'parent-child) - (let ((parent (cdadr ast)) - (children (zencoding-transform (caddr ast)))) - (zencoding-make-tag parent children))) - ((eq type 'zencoding-siblings) - (let ((sib1 (zencoding-transform (cadr ast))) - (sib2 (zencoding-transform (caddr ast)))) - (concat sib1 sib2)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Test-cases - -(defun zencoding-test-cases () - (let ((tests '(;; Tags - ("a" "<a></a>") - ("a.x" "<a class=\"x\"></a>") - ("a#q.x" "<a id=\"q\" class=\"x\"></a>") - ("a#q.x.y.z" "<a id=\"q\" class=\"x y z\"></a>") - ;; Siblings - ("a+b" "<a></a><b></b>") - ("a+b+c" "<a></a><b></b><c></c>") - ("a.x+b" "<a class=\"x\"></a><b></b>") - ("a#q.x+b" "<a id=\"q\" class=\"x\"></a><b></b>") - ("a#q.x.y.z+b" "<a id=\"q\" class=\"x y z\"></a><b></b>") - ("a#q.x.y.z+b#p.l.m.n" "<a id=\"q\" class=\"x y z\"></a><b id=\"p\" class=\"l m n\"></b>") - ;; Parent > child - ("a>b" "<a><b></b></a>") - ("a>b>c" "<a><b><c></c></b></a>") - ("a.x>b" "<a class=\"x\"><b></b></a>") - ("a#q.x>b" "<a id=\"q\" class=\"x\"><b></b></a>") - ("a#q.x.y.z>b" "<a id=\"q\" class=\"x y z\"><b></b></a>") - ("a#q.x.y.z>b#p.l.m.n" "<a id=\"q\" class=\"x y z\"><b id=\"p\" class=\"l m n\"></b></a>") - ("a>b+c" "<a><b></b><c></c></a>") - ("a>b+c>d" "<a><b></b><c><d></d></c></a>") - ;; Multiplication - ("a*1" "<a></a>") - ("a*2" "<a></a><a></a>") - ("a*2+b*2" "<a></a><a></a><b></b><b></b>") - ("a*2>b*2" "<a><b></b><b></b></a><a><b></b><b></b></a>") - ("a>b*2" "<a><b></b><b></b></a>") - ("a#q.x>b#q.x*2" "<a id=\"q\" class=\"x\"><b id=\"q\" class=\"x\"></b><b id=\"q\" class=\"x\"></b></a>") - ;; Properties - ("a x=y" "<a x=\"y\"></a>") - ("a x=y m=l" "<a x=\"y\" m=\"l\"></a>") - ("a#foo x=y m=l" "<a id=\"foo\" x=\"y\" m=\"l\"></a>") - ("a.foo x=y m=l" "<a class=\"foo\" x=\"y\" m=\"l\"></a>") - ("a#foo.bar.mu x=y m=l" "<a id=\"foo\" class=\"bar mu\" x=\"y\" m=\"l\"></a>") - ("a x=y+b" "<a x=\"y\"></a><b></b>") - ("a x=y+b x=y" "<a x=\"y\"></a><b x=\"y\"></b>") - ("a x=y>b" "<a x=\"y\"><b></b></a>") - ("a x=y>b x=y" "<a x=\"y\"><b x=\"y\"></b></a>") - ("a x=y>b x=y+c x=y" "<a x=\"y\"><b x=\"y\"></b><c x=\"y\"></c></a>") - ;; Parentheses - ("(a)" "<a></a>") - ("(a)+(b)" "<a></a><b></b>") - ("a>(b)" "<a><b></b></a>") - ("(a>b)>c" "<a><b></b></a>") - ("(a>b)+c" "<a><b></b></a><c></c>") - ("z+(a>b)+c+k" "<z></z><a><b></b></a><c></c><k></k>") - ("(a)*2" "<a></a><a></a>") - ("((a)*2)" "<a></a><a></a>") - ("((a)*2)" "<a></a><a></a>") - ("(a>b)*2" "<a><b></b></a><a><b></b></a>") - ("(a+b)*2" "<a></a><b></b><a></a><b></b>") - ))) - (mapc (lambda (input) - (let ((expected (cadr input)) - (actual (zencoding-transform (car (zencoding-expr (car input)))))) - (if (not (equal expected actual)) - (error (concat "Assertion " (car input) " failed:" - expected - " == " - actual))))) - tests) - (concat (number-to-string (length tests)) " tests performed. All OK."))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Zencoding minor mode - -;;;###autoload -(defgroup zencoding nil - "Customization group for zencoding-mode." - :group 'convenience) - -(defun zencoding-expr-on-line () - "Extract a zencoding expression and the corresponding bounds - for the current line." - (let* ((start (line-beginning-position)) - (end (line-end-position)) - (line (buffer-substring-no-properties start end)) - (expr (zencoding-regex "\\([ \t]*\\)\\([^\n]+\\)" line 2))) - (if (first expr) - (list (first expr) start end)))) - -(defun zencoding-prettify (markup indent) - (save-match-data - ;;(setq markup (replace-regexp-in-string "><" ">\n<" markup)) - (setq markup (replace-regexp-in-string "\n\n" "\n" markup)) - (setq markup (replace-regexp-in-string "^\n" "" markup))) - (with-temp-buffer - (indent-to indent) - (insert "<i></i>") - (insert "\n") - (let ((here (point))) - (insert markup) - (sgml-mode) - (indent-region here (point-max)) - (buffer-substring-no-properties here (point-max))))) - -;;;###autoload -(defun zencoding-expand-line (arg) - "Replace the current line's zencode expression with the corresponding expansion. -If prefix ARG is given or region is visible call `zencoding-preview' to start an -interactive preview. - -Otherwise expand line directly. - -For more information see `zencoding-mode'." - (interactive "P") - (let* ((here (point)) - (preview (if zencoding-preview-default (not arg) arg)) - (beg (if preview - (progn - (beginning-of-line) - (skip-chars-forward " \t") - (point)) - (when mark-active (region-beginning)))) - (end (if preview - (progn - (end-of-line) - (skip-chars-backward " \t") - (point)) - (when mark-active (region-end))))) - (if beg - (progn - (goto-char here) - (zencoding-preview beg end)) - (let ((expr (zencoding-expr-on-line))) - (if expr - (let* ((markup (zencoding-transform (car (zencoding-expr (first expr))))) - (pretty (zencoding-prettify markup (current-indentation)))) - (save-excursion - (delete-region (second expr) (third expr)) - (zencoding-insert-and-flash pretty)))))))) - -(defvar zencoding-mode-keymap nil - "Keymap for zencode minor mode.") - -(if zencoding-mode-keymap - nil - (progn - (setq zencoding-mode-keymap (make-sparse-keymap)) - (define-key zencoding-mode-keymap (kbd "<C-return>") 'zencoding-expand-line))) - -;;;###autoload -(define-minor-mode zencoding-mode - "Minor mode for writing HTML and CSS markup. -With zen coding for HTML and CSS you can write a line like - - ul#name>li.item*2 - -and have it expanded to - - <ul id=\"name\"> - <li class=\"item\"></li> - <li class=\"item\"></li> - </ul> - -This minor mode defines keys for quick access: - -\\{zencoding-mode-keymap} - -Home page URL `http://www.emacswiki.org/emacs/ZenCoding'. - -See also `zencoding-expand-line'." - :lighter " Zen" - :keymap zencoding-mode-keymap) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Zencoding yasnippet integration - -(defun zencoding-transform-yas (ast) - (let* ((leaf-count 0) - (zencoding-leaf-function - (lambda () - (format "$%d" (incf leaf-count))))) - (zencoding-transform ast))) - -;;;###autoload -(defun zencoding-expand-yas () - (interactive) - (let ((expr (zencoding-expr-on-line))) - (if expr - (let* ((markup (zencoding-transform-yas (car (zencoding-expr (first expr))))) - (filled (replace-regexp-in-string "><" ">\n<" markup))) - (delete-region (second expr) (third expr)) - (insert filled) - (indent-region (second expr) (point)) - (yas/expand-snippet - (buffer-substring (second expr) (point)) - (second expr) (point)))))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Real-time preview -;; - -;;;;;;;;;; -;; Lennart's version - -(defvar zencoding-preview-input nil) -(make-local-variable 'zencoding-preview-input) -(defvar zencoding-preview-output nil) -(make-local-variable 'zencoding-preview-output) -(defvar zencoding-old-show-paren nil) -(make-local-variable 'zencoding-old-show-paren) - -(defface zencoding-preview-input - '((default :box t :inherit secondary-selection)) - "Face for preview input field." - :group 'zencoding) - -(defface zencoding-preview-output - '((default :inherit highlight)) - "Face for preview output field." - :group 'zencoding) - -(defvar zencoding-preview-keymap - (let ((map (make-sparse-keymap))) - (define-key map (kbd "<return>") 'zencoding-preview-accept) - (define-key map [(control ?g)] 'zencoding-preview-abort) - map)) - -(defun zencoding-preview-accept () - (interactive) - (let ((ovli zencoding-preview-input)) - (if (not (and (overlayp ovli) - (bufferp (overlay-buffer ovli)))) - (message "Preview is not active") - (let* ((indent (current-indentation)) - (markup (zencoding-preview-transformed indent))) - (when markup - (delete-region (line-beginning-position) (overlay-end ovli)) - (zencoding-insert-and-flash markup))))) - (zencoding-preview-abort)) - -(defvar zencoding-flash-ovl nil) -(make-variable-buffer-local 'zencoding-flash-ovl) - -(defun zencoding-remove-flash-ovl (buf) - (with-current-buffer buf - (when (overlayp zencoding-flash-ovl) - (delete-overlay zencoding-flash-ovl)) - (setq zencoding-flash-ovl nil))) - -(defun zencoding-insert-and-flash (markup) - (zencoding-remove-flash-ovl (current-buffer)) - (let ((here (point))) - (insert markup) - (setq zencoding-flash-ovl (make-overlay here (point))) - (overlay-put zencoding-flash-ovl 'face 'zencoding-preview-output) - (when (< 0 zencoding-insert-flash-time) - (run-with-idle-timer zencoding-insert-flash-time - nil 'zencoding-remove-flash-ovl (current-buffer))))) - -;;;###autoload -(defun zencoding-preview (beg end) - "Expand zencode between BEG and END interactively. -This will show a preview of the expanded zen code and you can -accept it or skip it." - (interactive (if mark-active - (list (region-beginning) (region-end)) - (list nil nil))) - (zencoding-preview-abort) - (if (not beg) - (message "Region not active") - (setq zencoding-old-show-paren show-paren-mode) - (show-paren-mode -1) - (let ((here (point))) - (goto-char beg) - (forward-line 1) - (unless (= 0 (current-column)) - (insert "\n")) - (let* ((opos (point)) - (ovli (make-overlay beg end nil nil t)) - (ovlo (make-overlay opos opos)) - (info (propertize " Zen preview. Choose with RET. Cancel by stepping out. \n" - 'face 'tooltip))) - (overlay-put ovli 'face 'zencoding-preview-input) - (overlay-put ovli 'keymap zencoding-preview-keymap) - (overlay-put ovlo 'face 'zencoding-preview-output) - (overlay-put ovlo 'before-string info) - (setq zencoding-preview-input ovli) - (setq zencoding-preview-output ovlo) - (add-hook 'before-change-functions 'zencoding-preview-before-change t t) - (goto-char here) - (add-hook 'post-command-hook 'zencoding-preview-post-command t t))))) - -(defvar zencoding-preview-pending-abort nil) -(make-variable-buffer-local 'zencoding-preview-pending-abort) - -(defun zencoding-preview-before-change (beg end) - (when - (or (> beg (overlay-end zencoding-preview-input)) - (< beg (overlay-start zencoding-preview-input)) - (> end (overlay-end zencoding-preview-input)) - (< end (overlay-start zencoding-preview-input))) - (setq zencoding-preview-pending-abort t))) - -(defun zencoding-preview-abort () - "Abort zen code preview." - (interactive) - (setq zencoding-preview-pending-abort nil) - (remove-hook 'before-change-functions 'zencoding-preview-before-change t) - (when (overlayp zencoding-preview-input) - (delete-overlay zencoding-preview-input)) - (setq zencoding-preview-input nil) - (when (overlayp zencoding-preview-output) - (delete-overlay zencoding-preview-output)) - (setq zencoding-preview-output nil) - (remove-hook 'post-command-hook 'zencoding-preview-post-command t) - (when zencoding-old-show-paren (show-paren-mode 1))) - -(defun zencoding-preview-post-command () - (condition-case err - (zencoding-preview-post-command-1) - (error (message "zencoding-preview-post: %s" err)))) - -(defun zencoding-preview-post-command-1 () - (if (and (not zencoding-preview-pending-abort) - (<= (point) (overlay-end zencoding-preview-input)) - (>= (point) (overlay-start zencoding-preview-input))) - (zencoding-update-preview (current-indentation)) - (zencoding-preview-abort))) - -(defun zencoding-preview-transformed (indent) - (let* ((string (buffer-substring-no-properties - (overlay-start zencoding-preview-input) - (overlay-end zencoding-preview-input))) - (ast (car (zencoding-expr string)))) - (when (not (eq ast 'error)) - (zencoding-prettify (zencoding-transform ast) - indent)))) - -(defun zencoding-update-preview (indent) - (let* ((pretty (zencoding-preview-transformed indent)) - (show (when pretty - (propertize pretty 'face 'highlight)))) - (when show - (overlay-put zencoding-preview-output 'after-string - (concat show "\n"))))) -;; a+bc - -;;;;;;;;;; -;; Chris's version - -;; (defvar zencoding-realtime-preview-keymap -;; (let ((map (make-sparse-keymap))) -;; (define-key map "\C-c\C-c" 'zencoding-delete-overlay-pair) - -;; map) -;; "Keymap used in zencoding realtime preview overlays.") - -;; ;;;###autoload -;; (defun zencoding-realtime-preview-of-region (beg end) -;; "Construct a real-time preview for the region BEG to END." -;; (interactive "r") -;; (let ((beg2) -;; (end2)) -;; (save-excursion -;; (goto-char beg) -;; (forward-line) -;; (setq beg2 (point) -;; end2 (point)) -;; (insert "\n")) -;; (let ((input-and-output (zencoding-make-overlay-pair beg end beg2 end2))) -;; (zencoding-handle-overlay-change (car input-and-output) nil nil nil))) -;; ) - -;; (defun zencoding-make-overlay-pair (beg1 end1 beg2 end2) -;; "Construct an input and an output overlay for BEG1 END1 and BEG2 END2" -;; (let ((input (make-overlay beg1 end1 nil t t)) -;; (output (make-overlay beg2 end2))) -;; ;; Setup input overlay -;; (overlay-put input 'face '(:underline t)) -;; (overlay-put input 'modification-hooks -;; (list #'zencoding-handle-overlay-change)) -;; (overlay-put input 'output output) -;; (overlay-put input 'keymap zencoding-realtime-preview-keymap) -;; ;; Setup output overlay -;; (overlay-put output 'face '(:overline t)) -;; (overlay-put output 'intangible t) -;; (overlay-put output 'input input) -;; ;; Return the overlays. -;; (list input output)) -;; ) - -;; (defun zencoding-delete-overlay-pair (&optional one) -;; "Delete a pair of input and output overlays based on ONE." -;; (interactive) ;; Since called from keymap -;; (unless one -;; (let ((overlays (overlays-at (point)))) -;; (while (and overlays -;; (not (or (overlay-get (car overlays) 'input) -;; (overlay-get (car overlays) 'output)))) -;; (setq overlays (cdr overlays))) -;; (setq one (car overlays)))) -;; (when one -;; (let ((other (or (overlay-get one 'input) -;; (overlay-get one 'output)))) -;; (delete-overlay one) -;; (delete-overlay other))) -;; ) - -;; (defun zencoding-handle-overlay-change (input del beg end &optional old) -;; "Update preview after overlay change." -;; (let* ((output (overlay-get input 'output)) -;; (start (overlay-start output)) -;; (string (buffer-substring-no-properties -;; (overlay-start input) -;; (overlay-end input))) -;; (ast (car (zencoding-expr string))) -;; (markup (when (not (eq ast 'error)) -;; (zencoding-transform ast)))) -;; (save-excursion -;; (delete-region start (overlay-end output)) -;; (goto-char start) -;; (if markup -;; (insert markup) -;; (insert (propertize "error" 'face 'font-lock-error-face))) -;; (move-overlay output start (point)))) -;; ) - -(provide 'zencoding-mode) - -;;; zencoding-mode.el ends here |