xemacs-beta: lisp/format.el comparison

comparison lisp/format.el @ 272:c5d627a313b1 r21-0b34

Import from CVS: tag r21-0b34

author	cvs
date	Mon, 13 Aug 2007 10:28:48 +0200
parents	557eaa0339bf
children	74fd4e045ea6

comparison

equal deleted inserted replaced

-:c7b7086b0a39
+:c5d627a313b1
 ;; risk losing any text-properties in the buffer).
 ;;
 ;; You can manually translate a buffer into or out of a particular format
 ;; with the functions `format-encode-buffer' and `format-decode-buffer'.
 ;; To translate just the region use the functions `format-encode-region'
 ;; and `format-decode-region'.
 ;;
 ;; You can define a new format by writing the encoding and decoding
 ;; functions, and adding an entry to `format-alist'.  See enriched.el for
 ;; an example of how to implement a file format.  There are various
 ;; functions defined in this file that may be useful for writing the
 		   richtext-decode richtext-encode t enriched-mode)
 (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)
 ;; (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).
 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.
 	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)
 	  (shell-command-on-region from to method t nil))
 	(point))
 (funcall method from to)))
 (defun format-annotate-function (format from to orig-buf)
-"Returns annotations for writing region as FORMAT.
+"Return 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."
 ;; This function is called by write-region (actually build-annotations)
 ;; for each element of buffer-file-format.
 (let* ((info (assq format format-alist))
 	 (to-fn  (nth 4 info))
 	 (modify (nth 5 info)))
 (if to-fn
 	  ;; Otherwise just call function, it will return annotations.
 	  (funcall to-fn from to orig-buf)))))
 (defun format-decode (format length &optional visit-flag)
 "Decode text from any known FORMAT.
 FORMAT is a symbol appearing in `format-alist' or a list of such symbols,
 or nil, in which case this function tries to guess the format of the data by
 matching against the regular expressions in `format-alist'.  After a match is
 found and the region decoded, the alist is searched again from the beginning
 for another match.
 ;;;
 (defun format-decode-buffer (&optional format)
 "Translate the buffer from some FORMAT.
 If the format is not specified, this function attempts to guess.
 `buffer-file-format' is set to the format used, and any mode-functions
 for the format are called."
 (interactive
 (list (format-read "Translate buffer from format (default: guess): ")))
 (save-excursion
 (goto-char (point-min))
 (defun format-decode-region (from to &optional format)
 "Decode the region from some format.
 Arg FORMAT is optional; if omitted the format will be determined by looking
 for identifying regular expressions at the beginning of the region."
 (interactive
 (list (region-beginning) (region-end)
 	 (format-read "Translate region from format (default: guess): ")))
 (save-excursion
 (goto-char from)
 (format-decode format (- to from) nil)))
 (if (symbolp format) (setq format (list format)))
 (save-excursion
 (goto-char end)
 (let ( ; (cur-buf (current-buffer))
 	 (end (point-marker)))
 (while format
 (let* ((info (assq (car format) format-alist))
 	      (to-fn  (nth 4 info))
 	      (modify (nth 5 info))
 	      ;; result
 	      )
 				    nil nil nil nil)
 		  (read-file-name "Write file: "
 				  (cdr (assq 'default-directory
 					     (buffer-local-variables)))
 				  nil nil (buffer-name))))
 	  (fmt (format-read (format "Write file `%s' in format: "
 				    (file-name-nondirectory file)))))
 (list file fmt)))
 (setq buffer-file-format format)
 (write-file filename))
 "Find the file FILE using data format FORMAT.
 If FORMAT is nil then do not do any format conversion."
 (interactive
 ;; Same interactive spec as write-file, plus format question.
 (let* ((file (read-file-name "Find file: "))
 	  (fmt (format-read (format "Read file `%s' in format: "
 				    (file-name-nondirectory file)))))
 (list file fmt)))
 (let ((format-alist nil))
 (find-file filename))
 (if format
 The return value is like the value of `insert-file-contents':
 a list (ABSOLUTE-FILE-NAME . SIZE)."
 (interactive
 ;; Same interactive spec as write-file, plus format question.
 (let* ((file (read-file-name "Find file: "))
 	  (fmt (format-read (format "Read file `%s' in format: "
 				    (file-name-nondirectory file)))))
 (list file fmt)))
 (let (value size)
 (let ((format-alist nil))
 (setq value (insert-file-contents filename nil beg end))
 "Do multiple replacements on the buffer.
 ALIST is a list of (from . to) pairs, which should be proper arguments to
 `search-forward' and `replace-match' respectively.
 Optional 2nd arg REVERSE, if non-nil, means the pairs are (to . from), so that
 you can use the same list in both directions if it contains only literal
 strings.
 Optional args BEGIN and END specify a region of the buffer to operate on."
 (save-excursion
 (save-restriction
 (or beg (setq beg (point-min)))
 (if end (narrow-to-region (point-min) end))
 ;;; Some list-manipulation functions that we need.
 (defun format-delq-cons (cons list)
 "Remove the given CONS from LIST by side effect,
 and return the new LIST.  Since CONS could be the first element
 of LIST, write `\(setq foo \(format-delq-cons element foo))' to be sure of
 changing the value of `foo'."
 (if (eq cons list)
 (cdr list)
 (let ((p list))
 (while (not (eq (cdr p) cons))
 	(if (null p) (error "format-delq-cons: not an element."))
 	(setq p (cdr p)))
 ;; Now (cdr p) is the cons to delete
 (setcdr p (cdr cons))
 list)))
 (defun format-make-relatively-unique (a b)
 "Delete common elements of lists A and B, return as pair.
 Compares using `equal'."
 (let* ((acopy (copy-sequence a))
 	 (bcopy (copy-sequence b))
 equivalent part of B.  If even the last items of the two are not equal,
 returns nil."
 (let ((la (length a))
 	(lb (length b)))
 ;; Make sure they are the same length
 (if (> la lb)
 	(setq a (nthcdr (- la lb) a))
 (setq b (nthcdr (- lb la) b))))
 (while (not (equal a b))
 (setq a (cdr a)
 	  b (cdr b)))
 Elements of ITEMS equal to elements of ORDER will be rearranged to follow the
 ORDER.  Unmatched items will go last."
 (if order
 (let ((item (member (car order) items)))
 	(if item
 	    (cons (car item)
 		  (format-reorder (format-delq-cons item items)
 			   (cdr order)))
 	  (format-reorder items (cdr order))))
 items))
 ;;; Decoding
 ;;;
 (defun format-deannotate-region (from to translations next-fn)
 "Translate annotations in the region into text properties.
 This sets text properties between FROM to TO as directed by the
 TRANSLATIONS and NEXT-FN arguments.
 NEXT-FN is a function that searches forward from point for an annotation.
 It should return a list of 4 elements: \(BEGIN END NAME POSITIVE).  BEGIN and
 END are buffer positions bounding the annotation, NAME is the name searched
 	 (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)))
 Inserts each element of the given LIST of buffer annotations at its
 appropriate place.  Use second arg OFFSET if the annotations' locations are
 not relative to the beginning of the buffer: annotations will be inserted
 at their location-OFFSET+1 \(ie, the offset is treated as the character number
 of the first character in the buffer)."
 (if (not offset)
 (setq offset 0)
 (setq offset (1- offset)))
 (let ((l (reverse list)))
 (while l
 (goto-char (- (car (car l)) offset))
 elements are VALUES of that property followed by the names of zero or more
 ANNOTATIONS.  Whenever the property takes on that value, the annotations
 \(as formatted by FORMAT-FN) are inserted into the file.
 When the property stops having that value, the matching negated annotation
 will be inserted \(it may actually be closed earlier and reopened, if
 necessary, to keep proper nesting).
 If the property's value is a list, then each element of the list is dealt with
 separately.
 If a VALUE is numeric, then it is assumed that there is a single annotation
 	      (message "Can't close %s: not open." (car neg-ans))
 	    (while (not (equal (car neg-ans) (car open-ans)))
 	      ;; To close anno. N, need to first close ans 1 to N-1,
 	      ;; remembering to re-open them later.
 	      (setq pos-ans (cons (car open-ans) pos-ans))
 	      (setq all-ans
 		    (cons (cons loc (funcall format-fn (car open-ans) nil))
 			  all-ans))
 	      (setq open-ans (cdr open-ans)))
 	    ;; Now remove the one we're really interested in from open list.
 	    (setq open-ans (cdr open-ans))
 	    ;; And put the closing annotation here.
 	    (setq all-ans
 		  (cons (cons loc (funcall format-fn (car neg-ans) nil))
 			all-ans)))
 	  (setq neg-ans (cdr neg-ans)))
 	;; Now deal with positive (opening) annotations
 	(let ( ; (p pos-ans)
 	      )
 	  (while pos-ans
 	    (setq open-ans (cons (car pos-ans) open-ans))
 	    (setq all-ans
 		  (cons (cons loc (funcall format-fn (car pos-ans) t))
 			all-ans))
 	    (setq pos-ans (cdr pos-ans))))))
 ;; Close any annotations still open
 (while open-ans
 (setq all-ans
 	    (cons (cons to (funcall format-fn (car open-ans) nil))
 		  all-ans))
 (setq open-ans (cdr open-ans)))
 (if not-found
 	(message "These text properties could not be saved:\n    %s"
 	  (let* ((old (if (listp old) old (list old)))
 		 (new (if (listp new) new (list new)))
 		 ;; (tail (format-common-tail old new))
 		 close open)
 	    (while old
 	      (setq close
 		    (append (car (format-annotate-atomic-property-change
 				  prop-alist (car old) nil))
 			    close)
 		    old (cdr old)))
 	    (while new
 	      (setq open
 		    (append (cdr (format-annotate-atomic-property-change
 				  prop-alist nil (car new)))
 			    open)
 		    new (cdr new)))
 	    (format-make-relatively-unique close open))

Mercurial > hg > xemacs-beta

comparison lisp/format.el @ 272:c5d627a313b1 r21-0b34