APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1336841465 -3600
# Node ID 00fd55d635fb2db4fb3b4647b1380769536f921c
# Parent 0df4d95bd98a41c9a7826a307427e6f6dbcb9842
Sync #'truncate-string-to-width with GNU, add tests for it.
lisp/ChangeLog addition:
2012-05-12 Aidan Kehoe <kehoea(a)parhasard.net>
* subr.el:
* subr.el (truncate-string-to-width):
Sync with GNU's version, use its test suite in mule-tests.el.
tests/ChangeLog addition:
2012-05-12 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/mule-tests.el:
Test #'truncate-string-to-width, thank you Colin Walters.
diff -r 0df4d95bd98a -r 00fd55d635fb lisp/ChangeLog
--- a/lisp/ChangeLog Sat May 12 15:03:24 2012 +0100
+++ b/lisp/ChangeLog Sat May 12 17:51:05 2012 +0100
@@ -1,3 +1,9 @@
+2012-05-12 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * subr.el:
+ * subr.el (truncate-string-to-width):
+ Sync with GNU's version, use its test suite in mule-tests.el.
+
2012-05-12 Aidan Kehoe <kehoea(a)parhasard.net>
* byte-optimize.el (byte-compile-unfold-lambda):
diff -r 0df4d95bd98a -r 00fd55d635fb lisp/subr.el
--- a/lisp/subr.el Sat May 12 15:03:24 2012 +0100
+++ b/lisp/subr.el Sat May 12 17:51:05 2012 +0100
@@ -1030,76 +1030,60 @@
(replace (the string string) obj :start1 idx)
(prog1 string (aset string idx obj))))
-;; From FSF 21.1; ELLIPSES is XEmacs addition.
+;; XEmacs; this is in mule-util in GNU. See tests/automated/mule-tests.el for
+;; the tests that Colin Walters includes in that file.
+(defun truncate-string-to-width (str end-column
+ &optional start-column padding ellipsis)
+ "Truncate string STR to end at column END-COLUMN.
+The optional 3rd arg START-COLUMN, if non-nil, specifies the starting
+column; that means to return the characters occupying columns
+START-COLUMN ... END-COLUMN of STR. Both END-COLUMN and START-COLUMN
+are specified in terms of character display width in the current
+buffer; see also `char-width'.
-(defun truncate-string-to-width (str end-column &optional start-column padding
- ellipses)
- "Truncate string STR to end at column END-COLUMN.
-The optional 3rd arg START-COLUMN, if non-nil, specifies
-the starting column; that means to return the characters occupying
-columns START-COLUMN ... END-COLUMN of STR.
-
-The optional 4th arg PADDING, if non-nil, specifies a padding character
-to add at the end of the result if STR doesn't reach column END-COLUMN,
-or if END-COLUMN comes in the middle of a character in STR.
-PADDING is also added at the beginning of the result
-if column START-COLUMN appears in the middle of a character in STR.
+The optional 4th arg PADDING, if non-nil, specifies a padding
+character (which should have a display width of 1) to add at the end
+of the result if STR doesn't reach column END-COLUMN, or if END-COLUMN
+comes in the middle of a character in STR. PADDING is also added at
+the beginning of the result if column START-COLUMN appears in the
+middle of a character in STR.
If PADDING is nil, no padding is added in these cases, so
the resulting string may be narrower than END-COLUMN.
-BUG: Currently assumes that the padding character is of width one. You
-will get weird results if not.
-
-If ELLIPSES is non-nil, add ellipses (specified by ELLIPSES if a string,
-else `...') if STR extends past END-COLUMN. The ellipses will be added in
-such a way that the total string occupies no more than END-COLUMN columns
--- i.e. if the string goes past END-COLUMN, it will be truncated somewhere
-short of END-COLUMN so that, with the ellipses added (and padding, if the
-proper place to truncate the string would be in the middle of a character),
-the string occupies exactly END-COLUMN columns."
+If ELLIPSIS is non-nil, it should be a string which will replace the
+end of STR (including any padding) if it extends beyond END-COLUMN,
+unless the display width of STR is equal to or less than the display
+width of ELLIPSIS. If it is non-nil and not a string, then ELLIPSIS
+defaults to \"...\"."
(or start-column
(setq start-column 0))
- (let ((len (length str))
+ (when (and ellipsis (not (stringp ellipsis)))
+ (setq ellipsis "..."))
+ (let ((str-len (length str))
+ (str-width (string-width str))
+ (ellipsis-len (if ellipsis (length ellipsis) 0))
+ (ellipsis-width (if ellipsis (string-width ellipsis) 0))
(idx 0)
(column 0)
(head-padding "") (tail-padding "")
ch last-column last-idx from-idx)
-
- ;; find the index of START-COLUMN; bail out if end of string reached.
(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)))
+ (args-out-of-range (setq idx str-len)))
(if (< column start-column)
- ;; if string ends before START-COLUMN, return either a blank string
- ;; or a string entirely padded.
- (if padding (make-string (- end-column start-column) padding) "")
- (if (and padding (> column start-column))
- (setq head-padding (make-string (- column start-column) padding)))
+ (if padding (make-string end-column padding) "")
+ (when (and padding (> column start-column))
+ (setq head-padding (make-string (- column start-column) padding)))
(setq from-idx idx)
- ;; If END-COLUMN is before START-COLUMN, then bail out.
- (if (< end-column column)
- (setq idx from-idx ellipses "")
-
- ;; handle ELLIPSES
- (cond ((null ellipses) (setq ellipses ""))
- ((if (<= (string-width str) end-column)
- ;; string fits, no ellipses
- (setq ellipses "")))
- (t
- ;; else, insert default value and ...
- (or (stringp ellipses) (setq ellipses "..."))
- ;; ... take away the width of the ellipses from the
- ;; destination. do all computations with new, shorter
- ;; width. the padding computed will get us exactly up to
- ;; the shorted width, which is right -- it just gets added
- ;; to the right of the ellipses.
- (setq end-column (- end-column (string-width ellipses)))))
-
- ;; find the index of END-COLUMN; bail out if end of string reached.
+ (when (>= end-column column)
+ (if (and (< end-column str-width)
+ (> str-width ellipsis-width))
+ (setq end-column (- end-column ellipsis-width))
+ (setq ellipsis ""))
(condition-case nil
(while (< column end-column)
(setq last-column column
@@ -1107,20 +1091,14 @@
ch (aref str idx)
column (+ column (char-width ch))
idx (1+ idx)))
- (args-out-of-range (setq idx len)))
- ;; if we went too far (stopped in middle of character), back up.
- (if (> column end-column)
- (setq column last-column idx last-idx))
- ;; compute remaining padding
- (if (and padding (< column end-column))
- (setq tail-padding (make-string (- end-column column) padding))))
- ;; get substring ...
- (setq str (substring str from-idx idx))
- ;; and construct result
- (if padding
- (concat head-padding str tail-padding ellipses)
- (concat str ellipses)))))
-
+ (args-out-of-range (setq idx str-len)))
+ (when (> column end-column)
+ (setq column last-column
+ idx last-idx))
+ (when (and padding (< column end-column))
+ (setq tail-padding (make-string (- end-column column) padding))))
+ (concat head-padding (substring str from-idx idx)
+ tail-padding ellipsis))))
;; alist/plist functions
(defun plist-to-alist (plist)
diff -r 0df4d95bd98a -r 00fd55d635fb tests/ChangeLog
--- a/tests/ChangeLog Sat May 12 15:03:24 2012 +0100
+++ b/tests/ChangeLog Sat May 12 17:51:05 2012 +0100
@@ -1,3 +1,8 @@
+2012-05-12 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/mule-tests.el:
+ Test #'truncate-string-to-width, thank you Colin Walters.
+
2012-05-06 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el:
diff -r 0df4d95bd98a -r 00fd55d635fb tests/automated/mule-tests.el
--- a/tests/automated/mule-tests.el Sat May 12 15:03:24 2012 +0100
+++ b/tests/automated/mule-tests.el Sat May 12 17:51:05 2012 +0100
@@ -808,7 +808,81 @@
(Assert (let (default-process-coding-system)
(shell-command "cat </dev/null >/dev/null")
t))))
-
+ ;;; Test suite for truncate-string-to-width, from Colin Walters' tests in
+ ;;; mult-util.el in GNU.
+ (macrolet
+ ((test-truncate-string-to-width (&rest tests)
+ (let ((decode-any-string
+ ;; We can't store the East Asian characters directly in this
+ ;; file, since it needs to be read (but not executed) by
+ ;; non-Mule. Store them as UTF-8, decode them at
+ ;; macro-expansion time.
+ #'(lambda (object)
+ (if (stringp object)
+ (decode-coding-string object 'utf-8)
+ object))))
+ (cons
+ 'progn
+ (mapcar
+ (function*
+ (lambda ((arguments . result))
+ `(Assert (equal (truncate-string-to-width
+ ,@(mapcar decode-any-string arguments))
+ ,(funcall decode-any-string result)))))
+ tests)))))
+ (test-truncate-string-to-width
+ (("" 0) . "")
+ (("x" 1) . "x")
+ (("xy" 1) . "x")
+ (("xy" 2 1) . "y")
+ (("xy" 0) . "")
+ (("xy" 3) . "xy")
+ (("\344\270\255" 0) . "")
+ (("\344\270\255" 1) . "")
+ (("\344\270\255" 2) . "\344\270\255")
+ (("\344\270\255" 1 nil ? ) . " ")
+ (("\344\270\255\346\226\207" 3 1 ? ) . " ")
+ (("x\344\270\255x" 2) . "x")
+ (("x\344\270\255x" 3) . "x\344\270\255")
+ (("x\344\270\255x" 3) . "x\344\270\255")
+ (("x\344\270\255x" 4 1) . "\344\270\255x")
+ (("kor\355\225\234e\352\270\200an" 8 1 ? ) .
+ "or\355\225\234e\352\270\200")
+ (("kor\355\225\234e\352\270\200an" 7 2 ? ) . "r\355\225\234e
")
+ (("" 0 nil nil "...") . "")
+ (("x" 3 nil nil "...") . "x")
+ (("\344\270\255" 3 nil nil "...") . "\344\270\255")
+ (("foo" 3 nil nil "...") . "foo")
+ (("foo" 2 nil nil "...") . "fo") ;; (old) XEmacs
failure?
+ (("foobar" 6 0 nil "...") . "foobar")
+ (("foobarbaz" 6 nil nil "...") . "foo...")
+ (("foobarbaz" 7 2 nil "...") . "ob...")
+ (("foobarbaz" 9 3 nil "...") . "barbaz")
+ (("\343\201\223h\343\202\223e\343\201\253l\343\201\241l\343\201\257o" 15
+ 1 ? t) . " h\343\202\223e\343\201\253l\343\201\241l\343\201\257o")
+ (("\343\201\223h\343\202\223e\343\201\253l\343\201\241l\343\201\257o" 14
+ 1 ? t) . " h\343\202\223e\343\201\253l\343\201\241...")
+ (("x" 3 nil nil "\347\262\265\350\252\236") . "x")
+ (("\344\270\255" 2 nil nil "\347\262\265\350\252\236") .
"\344\270\255")
+ ;; XEmacs used to error
+ (("\344\270\255" 1 nil ?x "\347\262\265\350\252\236") .
"x")
+ (("\344\270\255\346\226\207" 3 nil ?
"\347\262\265\350\252\236") .
+ ;; XEmacs used to error
+ "\344\270\255 ")
+ (("foobarbaz" 4 nil nil "\347\262\265\350\252\236") .
+ "\347\262\265\350\252\236")
+ (("foobarbaz" 5 nil nil "\347\262\265\350\252\236") .
+ "f\347\262\265\350\252\236")
+ (("foobarbaz" 6 nil nil "\347\262\265\350\252\236") .
+ "fo\347\262\265\350\252\236")
+ (("foobarbaz" 8 3 nil "\347\262\265\350\252\236") .
+ "b\347\262\265\350\252\236")
+ (("\343\201\223h\343\202\223e\343\201\253l\343\201\241l\343\201\257o" 14
+ 4 ?x "\346\227\245\346\234\254\350\252\236") .
+ "xe\343\201\253\346\227\245\346\234\254\350\252\236")
+ (("\343\201\223h\343\202\223e\343\201\253l\343\201\241l\343\201\257o" 13
+ 4 ?x "\346\227\245\346\234\254\350\252\236") .
+ "xex\346\227\245\346\234\254\350\252\236")))
) ; end of tests that require MULE built in.
;;; end of mule-tests.el
--
‘Iodine deficiency was endemic in parts of the UK until, through what has been
described as “an unplanned and accidental public health triumph”, iodine was
added to cattle feed to improve milk production in the 1930s.’
(EN Pearce, Lancet, June 2011)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches