diff options
Diffstat (limited to 'emacs.d/nxhtml/util')
64 files changed, 41247 insertions, 0 deletions
diff --git a/emacs.d/nxhtml/util/anchored-transpose.el b/emacs.d/nxhtml/util/anchored-transpose.el new file mode 100644 index 0000000..3a5464c --- /dev/null +++ b/emacs.d/nxhtml/util/anchored-transpose.el @@ -0,0 +1,305 @@ +;;; 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 new file mode 100644 index 0000000..938ab92 --- /dev/null +++ b/emacs.d/nxhtml/util/appmenu-fold.el @@ -0,0 +1,79 @@ +;;; 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 new file mode 100644 index 0000000..1f060ef --- /dev/null +++ b/emacs.d/nxhtml/util/appmenu.el @@ -0,0 +1,523 @@ +;;; 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 new file mode 100644 index 0000000..b1330c1 --- /dev/null +++ b/emacs.d/nxhtml/util/as-external.el @@ -0,0 +1,310 @@ +;;; 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 new file mode 100644 index 0000000..d6459d6 --- /dev/null +++ b/emacs.d/nxhtml/util/buffer-bg.el @@ -0,0 +1,89 @@ +;;; 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 new file mode 100644 index 0000000..7470710 --- /dev/null +++ b/emacs.d/nxhtml/util/chartg.el @@ -0,0 +1,844 @@ +;;; 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 new file mode 100644 index 0000000..38d400c --- /dev/null +++ b/emacs.d/nxhtml/util/css-color.el @@ -0,0 +1,983 @@ +;;; 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 new file mode 100644 index 0000000..44287be --- /dev/null +++ b/emacs.d/nxhtml/util/css-palette.el @@ -0,0 +1,471 @@ +;;; 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 new file mode 100644 index 0000000..95bf27b --- /dev/null +++ b/emacs.d/nxhtml/util/css-simple-completion.el @@ -0,0 +1,238 @@ +;;; 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 new file mode 100644 index 0000000..c727425 --- /dev/null +++ b/emacs.d/nxhtml/util/cus-new-user.el @@ -0,0 +1,803 @@ +;;; 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 new file mode 100644 index 0000000..0495dd8 --- /dev/null +++ b/emacs.d/nxhtml/util/custsets.el @@ -0,0 +1,83 @@ +;;; 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 new file mode 100644 index 0000000..bdd86c6 --- /dev/null +++ b/emacs.d/nxhtml/util/ecb-batch-compile.el @@ -0,0 +1,65 @@ +;;; 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 new file mode 100644 index 0000000..12329bd --- /dev/null +++ b/emacs.d/nxhtml/util/ediff-url.el @@ -0,0 +1,188 @@ +;;; 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 new file mode 100644 index 0000000..42d1893 --- /dev/null +++ b/emacs.d/nxhtml/util/ffip.el @@ -0,0 +1,304 @@ +;;; 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 new file mode 100644 index 0000000..11b3a3d --- /dev/null +++ b/emacs.d/nxhtml/util/fold-dwim.el @@ -0,0 +1,466 @@ +;;; 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 new file mode 100644 index 0000000..0ffacc3 --- /dev/null +++ b/emacs.d/nxhtml/util/foldit.el @@ -0,0 +1,357 @@ +;;; 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 new file mode 100644 index 0000000..bb8b3af --- /dev/null +++ b/emacs.d/nxhtml/util/fupd.el @@ -0,0 +1,127 @@ +;;; 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 new file mode 100644 index 0000000..e624e9f --- /dev/null +++ b/emacs.d/nxhtml/util/gimpedit.el @@ -0,0 +1,172 @@ +;;; 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 new file mode 100644 index 0000000..a109555 --- /dev/null +++ b/emacs.d/nxhtml/util/gpl.el @@ -0,0 +1,213 @@ +;;; 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 new file mode 100644 index 0000000..0e0450d --- /dev/null +++ b/emacs.d/nxhtml/util/hfyview.el @@ -0,0 +1,651 @@ +;;; 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 new file mode 100644 index 0000000..7a160b6 --- /dev/null +++ b/emacs.d/nxhtml/util/hl-needed.el @@ -0,0 +1,402 @@ +;;; 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 new file mode 100644 index 0000000..c7a7c76 --- /dev/null +++ b/emacs.d/nxhtml/util/html-write.el @@ -0,0 +1,455 @@ +;;; 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 new file mode 100644 index 0000000..21f7a4c --- /dev/null +++ b/emacs.d/nxhtml/util/idn.el @@ -0,0 +1,151 @@ +;;; 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 new file mode 100644 index 0000000..9b07fb3 --- /dev/null +++ b/emacs.d/nxhtml/util/inlimg.el @@ -0,0 +1,429 @@ +;;; 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 new file mode 100644 index 0000000..ac4938c --- /dev/null +++ b/emacs.d/nxhtml/util/key-cat.el @@ -0,0 +1,329 @@ +;;; 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 new file mode 100644 index 0000000..7bdbea6 --- /dev/null +++ b/emacs.d/nxhtml/util/majmodpri.el @@ -0,0 +1,448 @@ +;;; 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 new file mode 100644 index 0000000..e1179b7 --- /dev/null +++ b/emacs.d/nxhtml/util/markchars.el @@ -0,0 +1,151 @@ +;;; 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 new file mode 100644 index 0000000..0f81654 --- /dev/null +++ b/emacs.d/nxhtml/util/mlinks.el @@ -0,0 +1,1367 @@ +;;; 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 new file mode 100644 index 0000000..c6bb2c7 --- /dev/null +++ b/emacs.d/nxhtml/util/mumamo-aspnet.el @@ -0,0 +1,227 @@ +;;; 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 new file mode 100644 index 0000000..eb3c5c2 --- /dev/null +++ b/emacs.d/nxhtml/util/mumamo-fun.el @@ -0,0 +1,3333 @@ +;;; 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 new file mode 100644 index 0000000..077be60 --- /dev/null +++ b/emacs.d/nxhtml/util/mumamo-regions.el @@ -0,0 +1,311 @@ +;;; 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 new file mode 100644 index 0000000..72b839b --- /dev/null +++ b/emacs.d/nxhtml/util/mumamo-trace.el @@ -0,0 +1,6 @@ +(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 new file mode 100644 index 0000000..3fefa1a --- /dev/null +++ b/emacs.d/nxhtml/util/mumamo.el @@ -0,0 +1,9100 @@ +;;; 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 + 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 'font-lock-beginning-of-syntax-function (custom-quote font-lock-beginning-of-syntax-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 'font-lock-beginning-of-syntax-function) + font-lock-beginning-of-syntax-function) + font-lock-beginning-of-syntax-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 new file mode 100644 index 0000000..024b8e6 --- /dev/null +++ b/emacs.d/nxhtml/util/n-back.el @@ -0,0 +1,1296 @@ +;;; 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 new file mode 100644 index 0000000..7ace679 --- /dev/null +++ b/emacs.d/nxhtml/util/new-key-seq-widget.el @@ -0,0 +1,312 @@ +;;; 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 new file mode 100644 index 0000000..0765acf --- /dev/null +++ b/emacs.d/nxhtml/util/nxml-mode-os-additions.el @@ -0,0 +1,99 @@ +;;; 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 new file mode 100644 index 0000000..0bcd1d9 --- /dev/null +++ b/emacs.d/nxhtml/util/ocr-user.el @@ -0,0 +1,86 @@ +;;; 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 new file mode 100644 index 0000000..a8dfec0 --- /dev/null +++ b/emacs.d/nxhtml/util/org-panel.el @@ -0,0 +1,745 @@ +;;; 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 new file mode 100644 index 0000000..5e9c2e6 --- /dev/null +++ b/emacs.d/nxhtml/util/ourcomments-util.el @@ -0,0 +1,2427 @@ +;;; 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 new file mode 100644 index 0000000..359a0b1 --- /dev/null +++ b/emacs.d/nxhtml/util/ourcomments-widgets.el @@ -0,0 +1,141 @@ +;;; 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 new file mode 100644 index 0000000..2e98d36 --- /dev/null +++ b/emacs.d/nxhtml/util/pause.el @@ -0,0 +1,794 @@ +;;; 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 new file mode 100644 index 0000000..7a17943 --- /dev/null +++ b/emacs.d/nxhtml/util/pointback.el @@ -0,0 +1,93 @@ +;;; 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 new file mode 100644 index 0000000..319145d --- /dev/null +++ b/emacs.d/nxhtml/util/popcmp.el @@ -0,0 +1,472 @@ +;;; 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 new file mode 100644 index 0000000..b9db030 --- /dev/null +++ b/emacs.d/nxhtml/util/readme.txt @@ -0,0 +1,3 @@ +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 new file mode 100644 index 0000000..cf4700c --- /dev/null +++ b/emacs.d/nxhtml/util/rebind.el @@ -0,0 +1,240 @@ +;;; 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 new file mode 100644 index 0000000..5829a50 --- /dev/null +++ b/emacs.d/nxhtml/util/rnc-mode.el @@ -0,0 +1,265 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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 new file mode 100644 index 0000000..505d0b4 --- /dev/null +++ b/emacs.d/nxhtml/util/rxi.el @@ -0,0 +1,148 @@ +;;; 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 new file mode 100644 index 0000000..b7b6dd2 --- /dev/null +++ b/emacs.d/nxhtml/util/search-form.el @@ -0,0 +1,473 @@ +;;; 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 new file mode 100644 index 0000000..290a1a0 --- /dev/null +++ b/emacs.d/nxhtml/util/sex-mode.el @@ -0,0 +1,463 @@ +;;; 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 new file mode 100644 index 0000000..882d184 --- /dev/null +++ b/emacs.d/nxhtml/util/sml-modeline.el @@ -0,0 +1,192 @@ +;;; 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 new file mode 100644 index 0000000..d35e651 --- /dev/null +++ b/emacs.d/nxhtml/util/tabkey2.el @@ -0,0 +1,1701 @@ +;;; 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 new file mode 100644 index 0000000..d4f3ea6 --- /dev/null +++ b/emacs.d/nxhtml/util/tyda.el @@ -0,0 +1,94 @@ +;;; 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 new file mode 100644 index 0000000..be3b35f --- /dev/null +++ b/emacs.d/nxhtml/util/udev-ecb.el @@ -0,0 +1,229 @@ +;;; 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 new file mode 100644 index 0000000..ed70c6c --- /dev/null +++ b/emacs.d/nxhtml/util/udev-rinari.el @@ -0,0 +1,204 @@ +;;; 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 new file mode 100644 index 0000000..ee9d86a --- /dev/null +++ b/emacs.d/nxhtml/util/udev.el @@ -0,0 +1,456 @@ +;;; 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 new file mode 100644 index 0000000..414d2f7 --- /dev/null +++ b/emacs.d/nxhtml/util/useful-commands.el @@ -0,0 +1,63 @@ +;;; 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 new file mode 100644 index 0000000..a941045 --- /dev/null +++ b/emacs.d/nxhtml/util/viper-tut.el @@ -0,0 +1,1009 @@ +;;; 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 new file mode 100644 index 0000000..62bc8dd --- /dev/null +++ b/emacs.d/nxhtml/util/vline.el @@ -0,0 +1,350 @@ +;;; 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 new file mode 100644 index 0000000..27943c8 --- /dev/null +++ b/emacs.d/nxhtml/util/web-vcs-revision.txt @@ -0,0 +1 @@ +321
diff --git a/emacs.d/nxhtml/util/whelp.el b/emacs.d/nxhtml/util/whelp.el new file mode 100644 index 0000000..77b8149 --- /dev/null +++ b/emacs.d/nxhtml/util/whelp.el @@ -0,0 +1,988 @@ +;; 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 new file mode 100644 index 0000000..771f6ce --- /dev/null +++ b/emacs.d/nxhtml/util/winsav.el @@ -0,0 +1,1585 @@ +;;; 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 new file mode 100644 index 0000000..808daf5 --- /dev/null +++ b/emacs.d/nxhtml/util/winsize.el @@ -0,0 +1,1173 @@ +;;; 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 new file mode 100644 index 0000000..223ce1b --- /dev/null +++ b/emacs.d/nxhtml/util/wrap-to-fill.el @@ -0,0 +1,364 @@ +;;; 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 new file mode 100644 index 0000000..2545491 --- /dev/null +++ b/emacs.d/nxhtml/util/zencoding-mode.el @@ -0,0 +1,801 @@ +;;; 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 |