diff options
Diffstat (limited to 'contrib/mmm/mmm-class.el')
| -rw-r--r-- | contrib/mmm/mmm-class.el | 328 |
1 files changed, 0 insertions, 328 deletions
diff --git a/contrib/mmm/mmm-class.el b/contrib/mmm/mmm-class.el deleted file mode 100644 index cc192f13..00000000 --- a/contrib/mmm/mmm-class.el +++ /dev/null @@ -1,328 +0,0 @@ -;;; mmm-class.el --- MMM submode class variables and functions - -;; Copyright (C) 2000, 2004 by Michael Abraham Shulman - -;; Author: Michael Abraham Shulman <viritrilbia@users.sourceforge.net> -;; Version: $Id$ - -;;{{{ GPL - -;; 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., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;}}} - -;;; Commentary: - -;; This file contains variable and function definitions for -;; manipulating and applying MMM submode classes. See `mmm-vars.el' -;; for variables that list classes. - -;;; Code: - -(require 'cl) -(require 'mmm-vars) -(require 'mmm-region) - -;;; CLASS SPECIFICATIONS -;;{{{ Get Class Specifications - -(defun mmm-get-class-spec (class) - "Get the class specification for CLASS. -CLASS can be either a symbol to look up in `mmm-classes-alist' or a -class specifier itself." - (cond ((symbolp class) ; A symbol must be looked up - (or (cdr (assq class mmm-classes-alist)) - (and (cadr (assq class mmm-autoloaded-classes)) - (load (cadr (assq class mmm-autoloaded-classes))) - (cdr (assq class mmm-classes-alist))) - (signal 'mmm-invalid-submode-class (list class)))) - ((listp class) ; A list must be a class spec - class) - (t (signal 'mmm-invalid-submode-class (list class))))) - -;;}}} -;;{{{ Get and Set Class Parameters - -(defun mmm-get-class-parameter (class param) - "Get the value of the parameter PARAM for CLASS, or nil if none." - (cadr (member param (mmm-get-class-spec class)))) - -(defun mmm-set-class-parameter (class param value) - "Set the value of the parameter PARAM for CLASS to VALUE. -Creates a new parameter if one is not present." - (let* ((spec (mmm-get-class-spec class)) - (current (member param spec))) - (if current - (setcar (cdr current) value) - (nconc spec (list param value))))) - -;;}}} -;;{{{ Apply Classes - -(defun* mmm-apply-class - (class &optional (start (point-min)) (stop (point-max)) face) - "Apply the submode class CLASS from START to STOP in FACE. -If FACE is nil, the face for CLASS is used, or the default face if -none is specified by CLASS." - ;; The "special" class t means do nothing. It is used to turn on - ;; MMM Mode without applying any classes. - (unless (eq class t) - (apply #'mmm-ify :start start :stop stop - (append (mmm-get-class-spec class) - (list :face face))) - (mmm-run-class-hook class) - ;; Hack in case class hook sets mmm-buffer-mode-display-name etc. - (mmm-set-mode-line))) - -(defun* mmm-apply-classes - (classes &key (start (point-min)) (stop (point-max)) face) - "Apply all submode classes in CLASSES, in order. -All classes are applied regardless of any errors that may occur in -other classes. If any errors occur, `mmm-apply-classes' exits with an -error once all classes have been applied." - (let (invalid-classes) - (dolist (class classes) - (condition-case err - (mmm-apply-class class start stop face) - (mmm-invalid-submode-class - ;; Save the name of the invalid class, so we can report them - ;; all together at the end. - (add-to-list 'invalid-classes (second err))))) - (when invalid-classes - (signal 'mmm-invalid-submode-class invalid-classes)))) - -;;}}} -;;{{{ Apply All Classes - -(defun* mmm-apply-all (&key (start (point-min)) (stop (point-max))) - "MMM-ify from START to STOP by all submode classes. -The classes come from mode/ext, `mmm-classes', `mmm-global-classes', -and interactive history." - (mmm-clear-overlays start stop 'strict) - (mmm-apply-classes (mmm-get-all-classes t) :start start :stop stop) - (mmm-update-submode-region) - (mmm-refontify-maybe start stop)) - -;;}}} - -;;; BUFFER SCANNING -;;{{{ Scan for Regions - -(defun* mmm-ify - (&rest all &key classes handler - submode match-submode - (start (point-min)) (stop (point-max)) - front back save-matches (case-fold-search t) - (beg-sticky (not (number-or-marker-p front))) - (end-sticky (not (number-or-marker-p back))) - include-front include-back - (front-offset 0) (back-offset 0) - (front-delim nil) (back-delim nil) - (delimiter-mode mmm-delimiter-mode) - front-face back-face - front-verify back-verify - front-form back-form - creation-hook - face match-face - save-name match-name - (front-match 0) (back-match 0) - end-not-begin - ;insert private - &allow-other-keys - ) - "Create submode regions from START to STOP according to arguments. -If CLASSES is supplied, it must be a list of valid CLASSes. Otherwise, -the rest of the arguments are for an actual class being applied. See -`mmm-classes-alist' for information on what they all mean." - ;; Make sure we get the default values in the `all' list. - (setq all (append - all - (list :start start :stop stop - :beg-sticky beg-sticky :end-sticky end-sticky - :front-offset front-offset :back-offset back-offset - :front-delim front-delim :back-delim back-delim - :front-match 0 :back-match 0 - ))) - (cond - ;; If we have a class list, apply them all. - (classes - (mmm-apply-classes classes :start start :stop stop :face face)) - ;; Otherwise, apply this class. - ;; If we have a handler, call it. - (handler - (apply handler all)) - ;; Otherwise, we search from START to STOP for submode regions, - ;; continuining over errors, until we don't find any more. If FRONT - ;; and BACK are number-or-markers, this should only execute once. - (t - (mmm-save-all - (goto-char start) - (loop for (beg end front-pos back-pos matched-front matched-back - matched-submode matched-face matched-name - invalid-resume ok-resume) = - (apply #'mmm-match-region :start (point) all) - while beg - if end ; match-submode, if present, succeeded. - do - (condition-case nil - (progn - (mmm-make-region - (or matched-submode submode) beg end - :face (or matched-face face) - :front front-pos :back back-pos - :evaporation 'front - :match-front matched-front :match-back matched-back - :beg-sticky beg-sticky :end-sticky end-sticky - :name matched-name - :delimiter-mode delimiter-mode - :front-face front-face :back-face back-face - :creation-hook creation-hook - ) - (goto-char ok-resume)) - ;; If our region is invalid, go back to the end of the - ;; front match and continue on. - (mmm-error (goto-char invalid-resume))) - ;; If match-submode was unable to find a match, go back to - ;; the end of the front match and continue on. - else do (goto-char invalid-resume) - ))))) - -;;}}} -;;{{{ Match Regions - -(defun* mmm-match-region - (&key start stop front back front-verify back-verify - include-front include-back front-offset back-offset - front-form back-form save-matches match-submode match-face - front-match back-match end-not-begin - save-name match-name - &allow-other-keys) - "Find the first valid region between point and STOP. -Return \(BEG END FRONT-POS BACK-POS FRONT-FORM BACK-FORM SUBMODE FACE -NAME INVALID-RESUME OK-RESUME) specifying the region. See -`mmm-match-and-verify' for the valid values of FRONT and BACK -\(markers, regexps, or functions). A nil value for END means that -MATCH-SUBMODE failed to find a valid submode. INVALID-RESUME is the -point at which the search should continue if the region is invalid, -and OK-RESUME if the region is valid." - (when (mmm-match-and-verify front start stop front-verify) - (let ((beg (mmm-match->point include-front front-offset front-match)) - (front-pos (with-no-warnings ; da: front-delim dyn scope? - (if front-delim - (mmm-match->point t front-delim front-match) - nil))) - (invalid-resume (match-end front-match)) - (front-form (mmm-get-form front-form))) - (let ((submode (if match-submode - (condition-case nil - (mmm-save-all - (funcall match-submode front-form)) - (mmm-no-matching-submode - (return-from - mmm-match-region - (values beg nil nil nil nil nil nil nil nil - invalid-resume nil)))) - nil)) - (name (cond ((functionp match-name) - (mmm-save-all (funcall match-name front-form))) - ((stringp match-name) - (if save-name - (mmm-format-matches match-name) - match-name)))) - (face (cond ((functionp match-face) - (mmm-save-all - (funcall match-face front-form))) - (match-face - (cdr (assoc front-form match-face)))))) - (when (mmm-match-and-verify - (if save-matches - (mmm-format-matches back) - back) - beg stop back-verify) - (let* ((end (mmm-match->point (not include-back) - back-offset back-match)) - (back-pos (with-no-warnings ; da: as above - (if back-delim - (mmm-match->point nil back-delim back-match) - nil))) - (back-form (mmm-get-form back-form)) - (ok-resume (if end-not-begin - (match-end back-match) - end))) - (values beg end front-pos back-pos front-form back-form - submode face name - invalid-resume ok-resume))))))) - -(defun mmm-match->point (beginp offset match) - "Find a point of starting or stopping from the match data. If -BEGINP, start at \(match-beginning MATCH), else \(match-end MATCH), -and move OFFSET. Handles all values of OFFSET--see `mmm-classes-alist'." - (save-excursion - (goto-char (with-no-warnings ; da: front/back-match dyn binding? - (if beginp - (match-beginning front-match) - (match-end back-match)))) - (dolist (spec (if (listp offset) offset (list offset))) - (if (numberp spec) - (forward-char (or spec 0)) - (funcall spec))) - (point))) - -(defun mmm-match-and-verify (pos start stop &optional verify) - "Find first match for POS between point and STOP satisfying VERIFY. -Return non-nil if a match was found, and set match data. POS can be a -number-or-marker, a regexp, or a function. - -If POS is a number-or-marker, it is used as-is. If it is a string, it -is searched for as a regexp until VERIFY returns non-nil. If it is a -function, it is called with argument STOP and must return non-nil iff -a match is found, and set the match data. Note that VERIFY is ignored -unless POS is a regexp." - (cond - ;; A marker can be used as-is, but only if it's in bounds. - ((and (number-or-marker-p pos) (>= pos start) (<= pos stop)) - (goto-char pos) - (looking-at "")) ; Set the match data - ;; Strings are searched for as regexps. - ((stringp pos) - (loop always (re-search-forward pos stop 'limit) - until (or (not verify) (mmm-save-all (funcall verify))))) - ;; Otherwise it must be a function. - ((functionp pos) - (funcall pos stop)))) - -;;}}} -;;{{{ Get Delimiter Forms - -(defun mmm-get-form (form) - "Return the delimiter form specified by FORM. -If FORM is nil, call `mmm-default-get-form'. If FORM is a string, -return it. If FORM is a function, call it. If FORM is a list, return -its `car' \(usually in this case, FORM is a one-element list -containing a function to be used as the delimiter form." - (cond ((stringp form) form) - ((not form) (mmm-default-get-form)) - ((functionp form) (mmm-save-all (funcall form))) - ((listp form) (car form)))) - -(defun mmm-default-get-form () - (regexp-quote (match-string 0))) - -;;}}} - -(provide 'mmm-class) - -;;; mmm-class.el ends here
\ No newline at end of file |