xemacs-beta: lisp/format.el comparison

comparison lisp/format.el @ 215:1f0dabaa0855 r20-4b6

Import from CVS: tag r20-4b6

author	cvs
date	Mon, 13 Aug 2007 10:07:35 +0200
parents	41ff10fd062f
children	262b8bb4a523

comparison

equal deleted inserted replaced

-:c5d88c05e1e9
+:1f0dabaa0855
 ;; You should have received a copy of the GNU General Public License
 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 ;; 02111-1307, USA.
-;;; Synched up with: Emacs/Mule zeta.
+;;; Synched up with: Emacs 20.2.
 ;;; Commentary:
 ;; This file is dumped with XEmacs.
 		   "Content-[Tt]ype:[ \t]*text/enriched"
 		   enriched-decode enriched-encode t enriched-mode)
 (text/richtext "Extended MIME obsolete text/richtext format."
 		   "Content-[Tt]ype:[ \t]*text/richtext"
 		   richtext-decode richtext-encode t enriched-mode)
-(plain "Standard ASCII format, no text properties."
+(plain "ISO 8859-1 standard format, no text properties."
 	   ;; Plain only exists so that there is an obvious neutral choice in
 	   ;; the completion list.
-	   nil nil nil nil nil))
+	   nil nil nil nil nil)
+;; (ibm   "IBM Code Page 850 (DOS)"
+;;        "1\\(^\\)"
+;;        "recode ibm-pc:latin1" "recode latin1:ibm-pc" t nil)
+;; (mac   "Apple Macintosh"
+;;        "1\\(^\\)"
+;;        "recode mac:latin1" "recode latin1:mac" t nil)
+;; (hp    "HP Roman8"
+;;        "1\\(^\\)"
+;;        "recode roman8:latin1" "recode latin1:roman8" t nil)
+;; (TeX   "TeX (encoding)"
+;;        "1\\(^\\)"
+;;        iso-tex2iso iso-iso2tex t nil)
+;; (gtex  "German TeX (encoding)"
+;;        "1\\(^\\)"
+;;        iso-gtex2iso iso-iso2gtex t nil)
+;; (html  "HTML (encoding)"
+;;        "1\\(^\\)"
+;;        "recode html:latin1" "recode latin1:html" t nil)
+;; (rot13 "rot13"
+;;        "1\\(^\\)"
+;;        "tr a-mn-z n-za-m" "tr a-mn-z n-za-m" t nil)
+;; (duden "Duden Ersatzdarstellung"
+;;        "1\\(^\\)"
+;;        "diac" iso-iso2duden t nil)
+;; (de646 "German ASCII (ISO 646)"
+;;        "1\\(^\\)"
+;;        "recode iso646-ge:latin1" "recode latin1:iso646-ge" t nil)
+;; (denet "net German"
+;;        "1\\(^\\)"
+;;        iso-german iso-cvt-read-only t nil)
+;; (esnet "net Spanish"
+;;        "1\\(^\\)"
+;;        iso-spanish iso-cvt-read-only t nil)
+)
 "List of information about understood file formats.
 Elements are of the form \(NAME DOC-STR REGEXP FROM-FN TO-FN MODIFY MODE-FN).
 NAME    is a symbol, which is stored in `buffer-file-format'.
 DOC-STR should be a single line providing more information about the
 format.  It is currently unused, but in the future will be shown to
 the user if they ask for more information.
 REGEXP  is a regular expression to match against the beginning of the file;
 it should match only files in that format.
 FROM-FN is called to decode files in that format; it gets two args, BEGIN
 and END, and can make any modifications it likes, returning the new
 end.  It must make sure that the beginning of the file no longer
 matches REGEXP, or else it will get called again.
+	Alternatively, FROM-FN can be a string, which specifies a shell command
+	(including options) to be used as a filter to perform the conversion.
 TO-FN   is called to encode a region into that format; it is passed three
 arguments: BEGIN, END, and BUFFER.  BUFFER is the original buffer that
 the data being written came from, which the function could use, for
 example, to find the values of local variables.  TO-FN should either
 return a list of annotations like `write-region-annotate-functions',
 or modify the region and return the new end.
+	Alternatively, TO-FN can be a string, which specifies a shell command
+	(including options) to be used as a filter to perform the conversion.
 MODIFY, if non-nil, means the TO-FN wants to modify the region.  If nil,
 TO-FN will not make any changes but will instead return a list of
 annotations.
 MODE-FN, if specified, is called when visiting a file with that format.")
 ;;; Basic Functions (called from Lisp)
-(defun format-annotate-function (format from to)
+(defun format-encode-run-method (method from to &optional buffer)
+"Translate using function or shell script METHOD the text from FROM to TO.
+If METHOD is a string, it is a shell command;
+otherwise, it should be a Lisp function.
+BUFFER should be the buffer that the output originally came from."
+(if (stringp method)
+(save-current-buffer
+	(set-buffer buffer)
+	(with-output-to-temp-buffer "*Format Errors*"
+	  (shell-command-on-region from to method t nil standard-output))
+	(point))
+(funcall method from to buffer)))
+(defun format-decode-run-method (method from to &optional buffer)
+"Decode using function or shell script METHOD the text from FROM to TO.
+If METHOD is a string, it is a shell command;
+otherwise, it should be a Lisp function."
+(if (stringp method)
+(progn
+	(with-output-to-temp-buffer "*Format Errors*"
+	  (shell-command-on-region from to method t nil standard-output))
+	(point))
+(funcall method from to)))
+(defun format-annotate-function (format from to orig-buf)
 "Returns annotations for writing region as FORMAT.
 FORMAT is a symbol naming one of the formats defined in `format-alist',
 it must be a single symbol, not a list like `buffer-file-format'.
 FROM and TO delimit the region to be operated on in the current buffer.
+ORIG-BUF is the original buffer that the data came from.
 This function works like a function on `write-region-annotate-functions':
 it either returns a list of annotations, or returns with a different buffer
 current, which contains the modified text to write.
 For most purposes, consider using `format-encode-region' instead."
 	    ;; To-function wants to modify region.  Copy to safe place.
 	    (let ((copy-buf (get-buffer-create " *Format Temp*")))
 	      (copy-to-buffer copy-buf from to)
 	      (set-buffer copy-buf)
 	      (format-insert-annotations write-region-annotations-so-far from)
-	      (funcall to-fn (point-min) (point-max))
+	      (format-encode-run-method to-fn (point-min) (point-max) orig-buf)
 	      nil)
 	  ;; Otherwise just call function, it will return annotations.
-	  (funcall to-fn from to)))))
+	  (funcall to-fn from to orig-buf)))))
 (defun format-decode (format length &optional visit-flag)
 ;; This function is called by insert-file-contents whenever a file is read.
 "Decode text from any known FORMAT.
 FORMAT is a symbol appearing in `format-alist' or a list of such symbols,
 	      (if (and regexp (looking-at regexp)
 		       (< (match-end 0) (+ begin length)))
 		  (progn
 		    (setq format (cons (car f) format))
 		    ;; Decode it
-		    (if (nth 3 f) (setq end (funcall (nth 3 f) begin end)))
+		    (if (nth 3 f)
+			(setq end (format-decode-run-method (nth 3 f) begin end)))
 		    ;; Call visit function if required
 		    (if (and visit-flag (nth 6 f)) (funcall (nth 6 f) 1))
 		    ;; Safeguard against either of the functions changing pt.
 		    (goto-char p)
 		    ;; Rewind list to look for another format
 (let ((do format) f)
 	(while do
 	  (or (setq f (assq (car do) format-alist))
 	      (error "Unknown format" (car do)))
 	  ;; Decode:
-	  (if (nth 3 f) (setq end (funcall (nth 3 f) begin end)))
+	  (if (nth 3 f)
+	      (setq end (format-decode-run-method (nth 3 f) begin end)))
 	  ;; Call visit function if required
 	  (if (and visit-flag (nth 6 f)) (funcall (nth 6 f) 1))
 	  (setq do (cdr do)))))
 (if visit-flag
 	(setq buffer-file-format format))
 	      (modify (nth 5 info))
 	      ;; result
 	      )
 	 (if to-fn
 	     (if modify
-		 (setq end (funcall to-fn beg end (current-buffer)))
+		 (setq end (format-encode-run-method to-fn beg end
+						     (current-buffer)))
 	       (format-insert-annotations
 		(funcall to-fn beg end (current-buffer)))))
 	 (setq format (cdr format)))))))
 (defun format-write-file (filename format)
 		 (positive (nth 3 next))
 		 (found    nil))
 	    ;; Delete the annotation
 	    (delete-region loc end)
-	    (if positive
+	    (cond
-		;; Positive annotations are stacked, remembering location
+	     ;; Positive annotations are stacked, remembering location
-		(setq open-ans (cons (list name loc) open-ans))
+	     (positive (setq open-ans (cons `(,name ((,loc . nil))) open-ans)))
-	      ;; It is a negative annotation:
+	     ;; It is a negative annotation:
-	      ;; Close the top annotation & add its text property.
+	     ;; Close the top annotation & add its text property.
-	      ;; If the file's nesting is messed up, the close might not match
+	     ;; If the file's nesting is messed up, the close might not match
-	      ;; the top thing on the open-annotations stack.
+	     ;; the top thing on the open-annotations stack.
-	      ;; If no matching annotation is open, just ignore the close.
+	     ;; If no matching annotation is open, just ignore the close.
-	      (if (not (assoc name open-ans))
+	     ((not (assoc name open-ans))
-		  (message "Extra closing annotation (%s) in file" name)
+	      (message "Extra closing annotation (%s) in file" name))
-	      ;; If one is open, but not on the top of the stack, close
+	     ;; If one is open, but not on the top of the stack, close
-	      ;; the things in between as well.  Set `found' when the real
+	     ;; the things in between as well.  Set `found' when the real
-	      ;; one is closed.
+	     ;; one is closed.
-		(while (not found)
+	     (t
-		  (let* ((top (car open-ans)) ; first on stack: should match.
+	      (while (not found)
-			 (top-name (car top))
+		(let* ((top (car open-ans))	; first on stack: should match.
-			 (start (car (cdr top))) ; location of start
+		       (top-name (car top))	; text property name
-			 (params (cdr (cdr top))) ; parameters
+		       (top-extents (nth 1 top)) ; property regions
-			 (aalist translations)
+		       (params (cdr (cdr top)))	; parameters
-			 (matched nil))
+		       (aalist translations)
-		    (if (equal name top-name)
+		       (matched nil))
-			(setq found t)
+		  (if (equal name top-name)
-		      (message "Improper nesting in file."))
+		      (setq found t)
-		    ;; Look through property names in TRANSLATIONS
+		    (message "Improper nesting in file."))
-		    (while aalist
+		  ;; Look through property names in TRANSLATIONS
-		      (let ((prop (car (car aalist)))
+		  (while aalist
-			    (alist (cdr (car aalist))))
+		    (let ((prop (car (car aalist)))
-			;; And look through values for each property
+			  (alist (cdr (car aalist))))
-			(while alist
+		      ;; And look through values for each property
-			  (let ((value (car (car alist)))
+		      (while alist
-				(ans (cdr (car alist))))
+			(let ((value (car (car alist)))
-			    (if (member top-name ans)
+			      (ans (cdr (car alist))))
-				;; This annotation is listed, but still have to
+			  (if (member top-name ans)
-				;; check if multiple annotations are satisfied
+			      ;; This annotation is listed, but still have to
-				(if (member 'nil (mapcar
+			      ;; check if multiple annotations are satisfied
-						  (lambda (r)
+			      (if (member nil (mapcar (lambda (r)
-						    (assoc r open-ans))
+							(assoc r open-ans))
-						  ans))
+						      ans))
-				    nil	; multiple ans not satisfied
+				  nil	; multiple ans not satisfied
-				  ;; Yes, all set.
+				;; If there are multiple annotations going
-				  ;; If there are multiple annotations going
+				;; into one text property, split up the other
-				  ;; into one text property, adjust the
+				;; annotations so they apply individually to
-				  ;; begin points of the other annotations
+				;; the other regions.
-				  ;; so that we don't get double marking.
+				(setcdr (car top-extents) loc)
-				  (let ((to-reset ans)
+				(let ((to-split ans) this-one extents)
-					this-one)
+				  (while to-split
-				    (while to-reset
+				    (setq this-one
-				      (setq this-one
+					  (assoc (car to-split) open-ans)
-					    (assoc (car to-reset)
+					  extents (nth 1 this-one))
-						   (cdr open-ans)))
+				    (if (not (eq this-one top))
-				      (if this-one
+					(setcar (cdr this-one)
-					  (setcar (cdr this-one) loc))
+						(format-subtract-regions
-				      (setq to-reset (cdr to-reset))))
+						 extents top-extents)))
-				  ;; Set loop variables to nil so loop
+				    (setq to-split (cdr to-split))))
-				  ;; will exit.
+				;; Set loop variables to nil so loop
-				  (setq alist nil aalist nil matched t
+				;; will exit.
-					;; pop annotation off stack.
+				(setq alist nil aalist nil matched t
-					open-ans (cdr open-ans))
+				      ;; pop annotation off stack.
-				  (cond
+				      open-ans (cdr open-ans))
-				   ;; Check for pseudo-properties
+				(let ((extents top-extents)
-				   ((eq prop 'PARAMETER)
+				      (start (car (car top-extents)))
-				    ;; This is a parameter of the top open ann:
+				      (loc (cdr (car top-extents))))
-				    ;; delete text and use as arg.
+				  (while extents
-				    (if open-ans
+				    (cond
-					;; (If nothing open, discard).
+				     ;; Check for pseudo-properties
-					(setq open-ans
+				     ((eq prop 'PARAMETER)
-					      (cons (append (car open-ans)
+				      ;; A parameter of the top open ann:
-							    (list
+				      ;; delete text and use as arg.
-							     (buffer-substring
+				      (if open-ans
-							      start loc)))
+					  ;; (If nothing open, discard).
-						    (cdr open-ans))))
+					  (setq open-ans
-				    (delete-region start loc))
+						(cons
-				   ((eq prop 'FUNCTION)
+						 (append (car open-ans)
-				    ;; Not a property, but a function to call.
+							 (list
-				    (let ((rtn (apply value start loc params)))
+							  (buffer-substring
-				      (if rtn (setq todo (cons rtn todo)))))
+							   start loc)))
-				   (t
+						 (cdr open-ans))))
-				    ;; Normal property/value pair
+				      (delete-region start loc))
-				    (setq todo
+				     ((eq prop 'FUNCTION)
-					  (cons (list start loc prop value)
+				      ;; Not a property, but a function.
-						todo)))))))
+				      (let ((rtn
-			  (setq alist (cdr alist))))
+					     (apply value start loc params)))
-		      (setq aalist (cdr aalist)))
+					(if rtn (setq todo (cons rtn todo)))))
-		    (if matched
+				     (t
-			nil
+				      ;; Normal property/value pair
+				      (setq todo
+					    (cons (list start loc prop value)
+						  todo))))
+				    (setq extents (cdr extents)
+					  start (car (car extents))
+					  loc (cdr (car extents))))))))
+			(setq alist (cdr alist))))
+		    (setq aalist (cdr aalist)))
+		  (if (not matched)
 		      ;; Didn't find any match for the annotation:
 		      ;; Store as value of text-property `unknown'.
-		      (setq open-ans (cdr open-ans))
+		      (let ((extents top-extents)
-		      (setq todo (cons (list start loc 'unknown top-name)
+			    (start (car (car top-extents)))
-				       todo))
+			    (loc (cdr (car top-extents))))
-		      (setq unknown-ans (cons name unknown-ans)))))))))
+			(while extents
+			  (setq open-ans (cdr open-ans)
+				todo (cons (list start loc 'unknown top-name)
+					   todo)
+				unknown-ans (cons name unknown-ans)
+				extents (cdr extents)
+				start (car (car extents))
+				loc (cdr (car extents))))))))))))
 	;; Once entire file has been scanned, add the properties.
 	(while todo
 	  (let* ((item (car todo))
 		 (from (nth 0 item))
 		 (to   (nth 1 item))
 		 (prop (nth 2 item))
 		 (val  (nth 3 item)))
-	    (put-text-property
+	    (if (numberp val)	; add to ambient value if numeric
+		(format-property-increment-region from to prop val 0)
+	      (put-text-property
 	       from to prop
-	       (cond ((numberp val) ; add to ambient value if numeric
+	       (cond ((get prop 'format-list-valued) ; value gets consed onto
-		      (+ val (or (get-text-property from prop) 0)))
-		     ((get prop 'format-list-valued) ; value gets consed onto
 						     ; list-valued properties
 		      (let ((prev (get-text-property from prop)))
 			(cons val (if (listp prev) prev (list prev)))))
-		     (t val)))) ; normally, just set to val.
+		     (t val))))) ; normally, just set to val.
 	  (setq todo (cdr todo)))
 	(if unknown-ans
 	    (message "Unknown annotations: %s" unknown-ans))))))
+(defun format-subtract-regions (minu subtra)
+"Remove the regions in SUBTRAHEND from the regions in MINUEND.  A region
+is a dotted pair (from . to).  Both parameters are lists of regions.  Each
+list must contain nonoverlapping, noncontiguous regions, in descending
+order.  The result is also nonoverlapping, noncontiguous, and in descending
+order.  The first element of MINUEND can have a cdr of nil, indicating that
+the end of that region is not yet known."
+(let* ((minuend (copy-alist minu))
+	 (subtrahend (copy-alist subtra))
+	 (m (car minuend))
+	 (s (car subtrahend))
+	 results)
+(while (and minuend subtrahend)
+(cond
+;; The minuend starts after the subtrahend ends; keep it.
+((> (car m) (cdr s))
+	(setq results (cons m results)
+	      minuend (cdr minuend)
+	      m (car minuend)))
+;; The minuend extends beyond the end of the subtrahend.  Chop it off.
+((or (null (cdr m)) (> (cdr m) (cdr s)))
+	(setq results (cons (cons (1+ (cdr s)) (cdr m)) results))
+	(setcdr m (cdr s)))
+;; The subtrahend starts after the minuend ends; throw it away.
+((< (cdr m) (car s))
+	(setq subtrahend (cdr subtrahend) s (car subtrahend)))
+;; The subtrahend extends beyond the end of the minuend.  Chop it off.
+(t	;(<= (cdr m) (cdr s)))
+	(if (>= (car m) (car s))
+	    (setq minuend (cdr minuend) m (car minuend))
+	  (setcdr m (1- (car s)))
+	  (setq subtrahend (cdr subtrahend) s (car subtrahend))))))
+(nconc (nreverse results) minuend)))
+;; This should probably go somewhere other than format.el.  Then again,
+;; indent.el has alter-text-property.  NOTE: We can also use
+;; next-single-property-change instead of text-property-not-all, but then
+;; we have to see if we passed TO.
+(defun format-property-increment-region (from to prop delta default)
+"Increment property PROP over the region between FROM and TO by the
+amount DELTA (which may be negative).  If property PROP is nil anywhere
+in the region, it is treated as though it were DEFAULT."
+(let ((cur from) val newval next)
+(while cur
+(setq val    (get-text-property cur prop)
+	    newval (+ (or val default) delta)
+	    next   (text-property-not-all cur to prop val))
+(put-text-property cur (or next to) prop newval)
+(setq cur next))))
 ;;;
 ;;; Encoding
 ;;;
 (let ((prop-alist (cdr (assoc prop trans)))
 	;; default
 	)
 (if (not prop-alist)
 	nil
-;; If property is numeric, nil means 0
-(cond ((and (numberp old) (null new))
-	     (setq new 0))
-	    ((and (numberp new) (null old))
-	     (setq old 0)))
 ;; If either old or new is a list, have to treat both that way.
 (if (or (consp old) (consp new))
 	  (let* ((old (if (listp old) old (list old)))
 		 (new (if (listp new) new (list new)))
 		 ;; (tail (format-common-tail old new))
 (defun format-annotate-atomic-property-change (prop-alist old new)
 "Internal function annotate a single property change.
 PROP-ALIST is the relevant segment of a TRANSLATIONS list.
 OLD and NEW are the values."
-(cond
+(let (num-ann)
-;; Numerical annotation - use difference
+;; If old and new values are numbers,
-((and (numberp old) (numberp new))
+;; look for a number in PROP-ALIST.
-(let* ((entry (progn
+(if (and (or (null old) (numberp old))
-		    (while (and (car (car prop-alist))
+	     (or (null new) (numberp new)))
-				(not (numberp (car (car prop-alist)))))
+	(progn
-		      (setq prop-alist (cdr prop-alist)))
+	  (setq num-ann prop-alist)
-		    (car prop-alist)))
+	  (while (and num-ann (not (numberp (car (car num-ann)))))
-	   (increment (car (car prop-alist)))
+	    (setq num-ann (cdr num-ann)))))
-	   (n (ceiling (/ (float (- new old)) (float increment))))
+(if num-ann
-	   (anno (car (cdr (car prop-alist)))))
+	;; Numerical annotation - use difference
-(if (> n 0)
+	(progn
-	  (cons nil (make-list n anno))
+	  ;; If property is numeric, nil means 0
-	(cons (make-list (- n) anno) nil))))
+	  (cond ((and (numberp old) (null new))
+		 (setq new 0))
-;; Standard annotation
+		((and (numberp new) (null old))
-(t (let ((close (and old (cdr (assoc old prop-alist))))
+		 (setq old 0)))
+	  (let* ((entry (car num-ann))
+		 (increment (car entry))
+		 (n (ceiling (/ (float (- new old)) (float increment))))
+		 (anno (car (cdr entry))))
+	    (if (> n 0)
+		(cons nil (make-list n anno))
+	      (cons (make-list (- n) anno) nil))))
+;; Standard annotation
+(let ((close (and old (cdr (assoc old prop-alist))))
 	    (open  (and new (cdr (assoc new prop-alist)))))
 	(if (or close open)
 	    (format-make-relatively-unique close open)
 	  ;; Call "Default" function, if any
 	  (let ((default (assq nil prop-alist)))

Mercurial > hg > xemacs-beta

comparison lisp/format.el @ 215:1f0dabaa0855 r20-4b6