comparison lisp/international/mule-util.el @ 20730:42d729244a85

(find-safe-coding-system): Moved to mule-cmds.el. (detect-coding-with-priority): New macro. (detect-coding-with-language-environment): New function. (string-to-sequence): Adjusted for the change of multibyte-form handling (byte-base to char-base). (store-substring): Likewise. (truncate-string-to-width): Likewise. (decompose-region): Likewise. (decompose-string): Likewise. (decompose-composite-char): Call string instead of concat-chars.

20729:821b2167b6c3

;;;###autoload
(defun string-to-sequence (string type)
  "Convert STRING to a sequence of TYPE which contains characters in STRING.
TYPE should be `list' or `vector'."
  (or (eq type 'list) (eq type 'vector)
      (error "Invalid type: %s" type))
  (let* ((len (length string))
	 (i 0)
	 l ch)
    (while (< i len)
      (setq ch (if enable-multibyte-characters
		   (sref string i) (aref string i)))
      (setq l (cons ch l))
      (setq i (+ i (char-bytes ch))))
    (setq l (nreverse l))
    (if (eq type 'list)
	l
      (vconcat l))))

;;;###autoload
(defsubst string-to-list (string)
  "Return a list of characters in STRING."
  (string-to-sequence string 'list))

  (string-to-sequence string 'vector))

;;;###autoload
(defun store-substring (string idx obj)
  "Embed OBJ (string or character) at index IDX of STRING."
  (let* ((str (cond ((stringp obj) obj)
		    ((integerp obj) (char-to-string obj))
		    (t (error
			"Invalid argument (should be string or character): %s"
			obj))))
	 (string-len (length string))
	 (len (length str))
	 (i 0))
    (while (and (< i len) (< idx string-len))
      (aset string idx (aref str i))
      (setq idx (1+ idx) i (1+ i)))
    string))

;;;###autoload
(defun truncate-string-to-width (str end-column &optional start-column padding)
  "Truncate string STR to end at column END-COLUMN.
The optional 2nd arg START-COLUMN, if non-nil, specifies

	(column 0)
	(head-padding "") (tail-padding "")
	ch last-column last-idx from-idx)
    (condition-case nil
	(while (< column start-column)
	  (setq ch (sref str idx)
		column (+ column (char-width ch))
		idx (+ idx (char-bytes ch))))
      (args-out-of-range (setq idx len)))
    (if (< column start-column)
	(if padding (make-string end-column padding) "")
      (if (and padding (> column start-column))
	  (setq head-padding (make-string (- column start-column) ?\ )))
      (setq from-idx idx)
      (if (< end-column column)
	  (setq idx from-idx)
	(condition-case nil
	    (while (< column end-column)
	      (setq last-column column
		    last-idx idx
		    ch (sref str idx)
		    column (+ column (char-width ch))
		    idx (+ idx (char-bytes ch))))
	  (args-out-of-range (setq idx len)))
	(if (> column end-column)
	    (setq column last-column idx last-idx))
	(if (and padding (< column end-column))
	    (setq tail-padding (make-string (- end-column column) padding))))

		 (eol-type-2 (coding-system-eol-type coding-system-2)))
	     (or (eq eol-type-1 eol-type-2)
		 (and (vectorp eol-type-1) (vectorp eol-type-2)))))))

;;;###autoload
(defun find-safe-coding-system (from to)
  "Return a list of proper coding systems to encode a text between FROM and TO.
All coding systems in the list can safely encode any multibyte characters
in the region.

If the region contains no multibyte charcters, the returned list
contains a single element `undecided'.

Kludgy feature: if FROM is a string, then that string is the target
for finding proper coding systems, and TO is ignored."
  (let ((found (if (stringp from)
		   (find-charset-string from)
		 (find-charset-region from to)))
	(l coding-system-list)
	codings coding safe)
    (if (and (= (length found) 1)
	     (eq 'ascii (car found)))
	'(undecided)
      (while l
	(setq coding (car l) l (cdr l))
	(if (and (eq coding (coding-system-base coding))
		 (setq safe (coding-system-get coding 'safe-charsets))
		 (or (eq safe t)
		     (catch 'tag
		       (mapcar (function (lambda (x)
					   (if (not (memq x safe))
					       (throw 'tag nil))))
			       found))))
	    (setq codings (cons coding codings))))
      codings)))


;;; Composite charcater manipulations.

;;;###autoload

  "Decompose all composite characters in the current region.
Composite characters are broken up into individual components.
When called from a program, expects two arguments,
positions (integers or markers) specifying the region."
  (interactive "r")
  (save-restriction
    (narrow-to-region start end)
    (goto-char (point-min))
    (let ((enable-multibyte-characters nil)
	  ;; This matches the whole bytes of single composite character.
	  (re-cmpchar "\200[\240-\377]+")
	  p ch str)
      (while (re-search-forward re-cmpchar nil t)
	(setq str (buffer-substring (match-beginning 0) (match-end 0)))
	(delete-region (match-beginning 0) (match-end 0))
	(insert (decompose-composite-char (string-to-char str)))))))

;;;###autoload
(defun decompose-string (string)
  "Decompose all composite characters in STRING."
  (let* ((l (string-to-list string))
	 (tail l)
	 ch)
    (while tail
      (setq ch (car tail))
      (setcar tail (if (cmpcharp ch) (decompose-composite-char ch)
		     (char-to-string ch)))
      (setq tail (cdr tail)))
    (apply 'concat l)))

;;;###autoload
(defconst reference-point-alist
  '((tl . 0) (tc . 1) (tr . 2)
    (ml . 3) (mc . 4) (mr . 5)

	  (let ((rule (- (composite-char-composition-rule char i) ?\xA0)))
	    (setq l (cons (cons (/ rule 9) (% rule 9)) l))))
      (setq i (1- i)))
    (setq l (cons (composite-char-component char 0) l))
    (cond ((eq type 'string)
	   (apply 'concat-chars l))
	  ((eq type 'list)
	   l)
	  (t				; i.e. TYPE is vector
	   (vconcat l)))))

20730:42d729244a85

;;;###autoload
(defun string-to-sequence (string type)
  "Convert STRING to a sequence of TYPE which contains characters in STRING.
TYPE should be `list' or `vector'."
  (let ((len (length string))
	(i 0)
	val)
    (cond ((eq type 'list)
	   (setq val (make-list len 0))
	   (let ((l val))
	     (while (< i len)
	       (setcar l (aref string i))
	       (setq l (cdr l) i (1+ i)))))
	  ((eq type 'vector)
	   (setq val (make-vector len 0))
	   (while (< i len)
	     (aset val i (aref string i))
	     (setq i (1+ i))))
	  (t
	   (error "Invalid type: %s" type)))
    val))

;;;###autoload
(defsubst string-to-list (string)
  "Return a list of characters in STRING."
  (string-to-sequence string 'list))

  (string-to-sequence string 'vector))

;;;###autoload
(defun store-substring (string idx obj)
  "Embed OBJ (string or character) at index IDX of STRING."
  (if (integerp obj)
      (aset string idx obj)
    (let ((len1 (length obj))
	  (len2 (length string))
	  (i 0))
      (while (< i len1)
	(aset string (+ idx i) (aref obj i))
	(setq i (1+ i)))))
  string)

;;;###autoload
(defun truncate-string-to-width (str end-column &optional start-column padding)
  "Truncate string STR to end at column END-COLUMN.
The optional 2nd arg START-COLUMN, if non-nil, specifies

	(column 0)
	(head-padding "") (tail-padding "")
	ch last-column last-idx from-idx)
    (condition-case nil
	(while (< column start-column)
	  (setq ch (aref str idx)
		column (+ column (char-width ch))
		idx (1+ idx)))
      (args-out-of-range (setq idx len)))
    (if (< column start-column)
	(if padding (make-string end-column padding) "")
      (if (and padding (> column start-column))
	  (setq head-padding (make-string (- column start-column) padding)))
      (setq from-idx idx)
      (if (< end-column column)
	  (setq idx from-idx)
	(condition-case nil
	    (while (< column end-column)
	      (setq last-column column
		    last-idx idx
		    ch (aref str idx)
		    column (+ column (char-width ch))
		    idx (1+ idx)))
	  (args-out-of-range (setq idx len)))
	(if (> column end-column)
	    (setq column last-column idx last-idx))
	(if (and padding (< column end-column))
	    (setq tail-padding (make-string (- end-column column) padding))))

		 (eol-type-2 (coding-system-eol-type coding-system-2)))
	     (or (eq eol-type-1 eol-type-2)
		 (and (vectorp eol-type-1) (vectorp eol-type-2)))))))

;;;###autoload
(defmacro detect-coding-with-priority (from to priority-list)
  "Detect a coding system of the text between FROM and TO with PRIORITY-LIST.
PRIORITY-LIST is an alist of coding categories vs the corresponding
coding systems ordered by priority."
  `(let* ((prio-list ,priority-list)
	  (coding-category-list coding-category-list)
	  ,@(mapcar (function (lambda (x) (list x x))) coding-category-list))
     (mapcar (function (lambda (x) (set (car x) (cdr x))))
	     prio-list)
     (set-coding-priority (mapcar (function (lambda (x) (car x))) prio-list))
     (detect-coding-region ,from ,to)))

;;;###autoload
(defun detect-coding-with-language-environment (from to lang-env)
  "Detect a coding system of the text between FROM and TO with LANG-ENV.
The detection takes into accont the coding system priorities for the
language environment LANG-ENV."
  (let ((coding-priority (get-language-info lang-env 'coding-priority)))
    (if coding-priority
	(detect-coding-with-priority
	 from to
	 (mapcar (function (lambda (x)
			     (cons (coding-system-get x 'coding-category) x)))
		 coding-priority))
      (detect-coding-region from to))))


;;; Composite charcater manipulations.

;;;###autoload

  "Decompose all composite characters in the current region.
Composite characters are broken up into individual components.
When called from a program, expects two arguments,
positions (integers or markers) specifying the region."
  (interactive "r")
  (save-excursion
    (save-restriction
      (narrow-to-region start end)
      (goto-char (point-min))
      (while (not (eobp))
	(let ((ch (following-char)))
	  (if (>= ch min-composite-char)
	      (progn
		(delete-char 1)
		(insert (decompose-composite-char ch)))
	    (forward-char 1)))))))

;;;###autoload
(defun decompose-string (string)
  "Decompose all composite characters in STRING."
  (let ((len (length string))
	(idx 0)
	(i 0)
	(str-list nil)
	ch)
    (while (< idx len)
      (setq ch (aref string idx))
      (if (>= ch min-composite-char)
	  (progn
	    (if (> idx i)
		(setq str-list (cons (substring string i idx) str-list)))
	    (setq str-list (cons (decompose-composite-char ch) str-list))
	    (setq i (1+ idx))))
      (setq idx (1+ idx)))
    (if (not str-list)
	(copy-sequence string)
      (if (> idx i)
	  (setq str-list (cons (substring string i idx) str-list)))
      (apply 'concat (nreverse str-list)))))

;;;###autoload
(defconst reference-point-alist
  '((tl . 0) (tc . 1) (tr . 2)
    (ml . 3) (mc . 4) (mr . 5)

	  (let ((rule (- (composite-char-composition-rule char i) ?\xA0)))
	    (setq l (cons (cons (/ rule 9) (% rule 9)) l))))
      (setq i (1- i)))
    (setq l (cons (composite-char-component char 0) l))
    (cond ((eq type 'string)
	   (apply 'string l))
	  ((eq type 'list)
	   l)
	  (t				; i.e. TYPE is vector
	   (vconcat l)))))