Renamed file contrib/mmm/mmm-class.el, formerly mmm/mmm-class.el

1 files changed, 328 insertions, 0 deletions

diff --git a/contrib/mmm/mmm-class.el b/contrib/mmm/mmm-class.el
new file mode 100644
index 00000000..cc192f13
--- /dev/null
+++ b/contrib/mmm/mmm-class.el
@@ -0,0 +1,328 @@
+;;; 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