xemacs-beta: lisp/coding.el comparison

comparison lisp/coding.el @ 4569:80e0588fb42f

Merge.

author	Aidan Kehoe <kehoea@parhasard.net>
date	Sun, 28 Dec 2008 14:55:02 +0000
parents	1d74a1d115ee
children	e6a7054a9c30

comparison

equal deleted inserted replaced

-:7ca6d57ce12d
+:80e0588fb42f
 This function is meant to be called interactively;
 from a Lisp program, use `detect-coding-region' instead."
 (interactive "r\nP")
 (princ (detect-coding-region start end)))
-(defun decode-coding-string (str coding-system)
+(defun decode-coding-string (str coding-system &optional nocopy)
 "Decode the string STR which is encoded in CODING-SYSTEM.
-Does not modify STR.  Returns the decoded string on successful conversion."
+Normally does not modify STR.  Returns the decoded string on
+successful conversion.
+Optional argument NOCOPY says that modifying STR and returning it is
+allowed."
 (with-string-as-buffer-contents
 str (decode-coding-region (point-min) (point-max) coding-system)))
-(defun encode-coding-string (str coding-system)
+(defun encode-coding-string (str coding-system &optional nocopy)
 "Encode the string STR using CODING-SYSTEM.
-Does not modify STR.  Returns the encoded string on successful conversion."
+Does not modify STR.  Returns the encoded string on successful conversion.
+Optional argument NOCOPY says that the original string may be returned
+if does not differ from the encoded string. "
 (with-string-as-buffer-contents
 str (encode-coding-region (point-min) (point-max) coding-system)))
 ;;;; Coding system accessors
 ; (define-coding-system-alias 'iso-8859-2 'raw-text)
 (define-coding-system-alias 'ctext 'raw-text))
 (make-compatible-variable 'enable-multibyte-characters "Unimplemented")
+;; Sure would be nice to be able to use defface here.
+(copy-face 'highlight 'query-coding-warning-face)
+(defvar default-query-coding-region-safe-charset-skip-chars-map
+#s(hash-table test equal data ())
+"A map from list of charsets to `skip-chars-forward' arguments for them.")
+(defsubst query-coding-clear-highlights (begin end &optional buffer)
+"Remove extent faces added by `query-coding-region' between BEGIN and END.
+Optional argument BUFFER is the buffer to use, and defaults to the current
+buffer.
+The HIGHLIGHTP argument to `query-coding-region' indicates that it should
+display unencodable characters using `query-coding-warning-face'.  After
+this function has been called, this will no longer be the case.  "
+(map-extents #'(lambda (extent ignored-arg)
+(when (eq 'query-coding-warning-face
+(extent-face extent))
+(delete-extent extent))) buffer begin end))
+(defun* default-query-coding-region (begin end coding-system
+				     &optional buffer errorp highlightp)
+"The default `query-coding-region' implementation.
+Uses the `safe-charsets' and `safe-chars' coding system properties.
+The former is a list of XEmacs character sets that can be safely
+encoded by CODING-SYSTEM; the latter a char table describing, in
+addition, characters that can be safely encoded by CODING-SYSTEM."
+(check-argument-type #'coding-system-p
+(setq coding-system (find-coding-system coding-system)))
+(check-argument-type #'integer-or-marker-p begin)
+(check-argument-type #'integer-or-marker-p end)
+(let* ((safe-charsets
+(or (coding-system-get coding-system 'safe-charsets)
+	      (coding-system-get (coding-system-base coding-system)
+				 'safe-charsets)))
+(safe-chars
+	  (or (coding-system-get coding-system 'safe-chars)
+	      (coding-system-get (coding-system-base coding-system)
+				 'safe-chars)))
+(skip-chars-arg
+(gethash safe-charsets
+default-query-coding-region-safe-charset-skip-chars-map))
+(ranges (make-range-table))
+fail-range-start fail-range-end char-after
+	 looking-at-arg failed extent)
+;; Coding systems with a value of t for safe-charsets support everything.
+(when (eq t safe-charsets)
+(return-from default-query-coding-region (values t nil)))
+(unless skip-chars-arg
+(setq skip-chars-arg
+	    (puthash safe-charsets
+		     (mapconcat #'charset-skip-chars-string
+				safe-charsets "")
+		     default-query-coding-region-safe-charset-skip-chars-map)))
+(when highlightp
+(query-coding-clear-highlights begin end buffer))
+(if (and (zerop (length skip-chars-arg)) (null safe-chars))
+	(progn
+	    ;; Uh-oh, nothing known about this coding system. Fail.
+	    (when errorp
+	      (error 'text-conversion-error
+		     "Coding system doesn't say what it can encode"
+		     (coding-system-name coding-system)))
+	    (put-range-table begin end t ranges)
+	    (when highlightp
+	      (setq extent (make-extent begin end buffer))
+	      (set-extent-priority extent (+ mouse-highlight-priority 2))
+	      (set-extent-face extent 'query-coding-warning-face))
+	    (values nil ranges))
+(setq looking-at-arg (if (equal "" skip-chars-arg)
+			       ;; Regexp that will never match.
+			       #r".\{0,0\}"
+(concat "[" skip-chars-arg "]")))
+(save-excursion
+	(goto-char begin buffer)
+	(skip-chars-forward skip-chars-arg end buffer)
+	(while (< (point buffer) end)
+	  ; (message
+	  ; "fail-range-start is %S, point is %S, end is %S"
+	  ;  fail-range-start (point buffer) end)
+	  (setq char-after (char-after (point buffer) buffer)
+		fail-range-start (point buffer))
+	  (while (and
+		  (< (point buffer) end)
+		  (not (looking-at looking-at-arg))
+		  (or (not safe-chars)
+		      (not (get-char-table char-after safe-chars))))
+	    (forward-char 1 buffer)
+	    (setq char-after (char-after (point buffer) buffer)
+		  failed t))
+	  (if (= fail-range-start (point buffer))
+	      ;; The character can actually be encoded by the coding
+	      ;; system; check the characters past it.
+	      (forward-char 1 buffer)
+;; Can't be encoded; note this.
+	    (when errorp
+	      (error 'text-conversion-error
+		     (format "Cannot encode %s using coding system"
+			     (buffer-substring fail-range-start (point buffer)
+					       buffer))
+		     (coding-system-name coding-system)))
+	    (put-range-table fail-range-start
+			     ;; If char-after is non-nil, we're not at
+			     ;; the end of the buffer.
+			     (setq fail-range-end (if char-after
+						      (point buffer)
+						    (point-max buffer)))
+			     t ranges)
+	    (when highlightp
+	      (setq extent (make-extent fail-range-start fail-range-end buffer))
+	      (set-extent-priority extent (+ mouse-highlight-priority 2))
+	      (set-extent-face extent 'query-coding-warning-face)))
+	  (skip-chars-forward skip-chars-arg end buffer))
+	(if failed
+	    (values nil ranges)
+	  (values t nil))))))
+(defun query-coding-region (start end coding-system &optional buffer
+errorp highlight)
+"Work out whether CODING-SYSTEM can losslessly encode a region.
+START and END are the beginning and end of the region to check.
+CODING-SYSTEM is the coding system to try.
+Optional argument BUFFER is the buffer to check, and defaults to the current
+buffer.  Optional argument ERRORP says to signal a `text-conversion-error'
+if some character in the region cannot be encoded, and defaults to nil.
+Optional argument HIGHLIGHT says to display unencodable characters in the
+region using `query-coding-warning-face'. It defaults to nil.
+This function returns a list; the intention is that callers use
+`multiple-value-bind' or the related CL multiple value functions to deal
+with it.  The first element is `t' if the region can be encoded using
+CODING-SYSTEM, or `nil' if not.  The second element is `nil' if the region
+can be encoded using CODING-SYSTEM; otherwise, it is a range table
+describing the positions of the unencodable characters. See
+`make-range-table'."
+(funcall (or (coding-system-get coding-system 'query-coding-function)
+#'default-query-coding-region)
+start end coding-system buffer errorp highlight))
+(defun query-coding-string (string coding-system &optional errorp highlight)
+"Work out whether CODING-SYSTEM can losslessly encode STRING.
+CODING-SYSTEM is the coding system to check.
+Optional argument ERRORP says to signal a `text-conversion-error' if some
+character in the region cannot be encoded, and defaults to nil.
+Optional argument HIGHLIGHT says to display unencodable characters in the
+region using `query-coding-warning-face'. It defaults to nil.
+This function returns a list; the intention is that callers use use
+`multiple-value-bind' or the related CL multiple value functions to deal
+with it.  The first element is `t' if the string can be encoded using
+CODING-SYSTEM, or `nil' if not.  The second element is `nil' if the string
+can be encoded using CODING-SYSTEM; otherwise, it is a range table
+describing the positions of the unencodable characters. See
+`make-range-table'."
+(with-temp-buffer
+(insert string)
+(query-coding-region (point-min) (point-max) coding-system (current-buffer)
+;; ### Will highlight work here?
+errorp highlight)))
+(defun unencodable-char-position  (start end coding-system
+&optional count string)
+"Return position of first un-encodable character in a region.
+START and END specify the region and CODING-SYSTEM specifies the
+encoding to check.  Return nil if CODING-SYSTEM does encode the region.
+If optional 4th argument COUNT is non-nil, it specifies at most how
+many un-encodable characters to search.  In this case, the value is a
+list of positions.
+If optional 5th argument STRING is non-nil, it is a string to search
+for un-encodable characters.  In that case, START and END are indexes
+in the string."
+(let ((thunk
+	 #'(lambda (start end coding-system &optional count)
+	     (multiple-value-bind (result ranges)
+		 (query-coding-region start end coding-system)
+	       (if result
+		   nil
+		 (block worked-it-all-out
+		   (if count
+		       (map-range-table
+			#'(lambda (begin end value)
+			    (while (and (< begin end)
+					(< (length result) count))
+			      (push begin result)
+			      (incf begin))
+			    (when (= (length result) count)
+			      (return-from worked-it-all-out result)))
+			ranges)
+		     (map-range-table
+		      #'(lambda (begin end value)
+			  (return-from worked-it-all-out begin))
+		      ranges))
+		   (assert (not (null count)) t
+			   "We should never reach this point with null COUNT.")
+		   result))))))
+(check-argument-type #'integer-or-marker-p start)
+(check-argument-type #'integer-or-marker-p end)
+(check-coding-system coding-system)
+(and count (check-argument-type #'natnump count)
+	 ;; Special-case zero, sigh.
+	 (if (zerop count) (setq count 1)))
+(and string (check-argument-type #'stringp string))
+(if string
+	(with-temp-buffer
+	  (insert string)
+	  (funcall thunk start end coding-system count))
+(funcall thunk start end coding-system count))))
+(defun encode-coding-char (char coding-system)
+"Encode CHAR by CODING-SYSTEM and return the resulting string.
+If CODING-SYSTEM can't safely encode CHAR, return nil."
+(check-argument-type #'characterp char)
+(multiple-value-bind (succeededp)
+(query-coding-string char coding-system)
+(when succeededp
+(encode-coding-string char coding-system))))
+(unless (featurep 'mule)
+;; If we're under non-Mule, every XEmacs character can be encoded
+;; with every XEmacs coding system.
+(fset #'default-query-coding-region
+	#'(lambda (&rest ignored) (values t nil)))
+(unintern 'default-query-coding-region-safe-charset-skip-chars-map))
 ;;; coding.el ends here

Mercurial > hg > xemacs-beta

comparison lisp/coding.el @ 4569:80e0588fb42f