2 new commits in XEmacs:
https://bitbucket.org/xemacs/xemacs/changeset/00fd55d635fb/
changeset: 00fd55d635fb
user: kehoea
date: 2012-05-12 18:51:05
summary: 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.
affected #: 4 files
diff -r 0df4d95bd98a41c9a7826a307427e6f6dbcb9842 -r
00fd55d635fb2db4fb3b4647b1380769536f921c lisp/ChangeLog
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -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 0df4d95bd98a41c9a7826a307427e6f6dbcb9842 -r
00fd55d635fb2db4fb3b4647b1380769536f921c lisp/subr.el
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -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 0df4d95bd98a41c9a7826a307427e6f6dbcb9842 -r
00fd55d635fb2db4fb3b4647b1380769536f921c tests/ChangeLog
--- a/tests/ChangeLog
+++ b/tests/ChangeLog
@@ -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 0df4d95bd98a41c9a7826a307427e6f6dbcb9842 -r
00fd55d635fb2db4fb3b4647b1380769536f921c tests/automated/mule-tests.el
--- a/tests/automated/mule-tests.el
+++ b/tests/automated/mule-tests.el
@@ -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
https://bitbucket.org/xemacs/xemacs/changeset/8593e614573a/
changeset: 8593e614573a
user: kehoea
date: 2012-05-12 19:12:13
summary: Avoid signalling args-out-of-range errors, #'truncate-string-to-width
lisp/ChangeLog addition:
Avoid args-out-of-range errors, this function is regularly called
from menu code and with debug-on-signal non-nil, this can be very
irritating.
Don't bind ellipsis-len, we don't use it.
affected #: 2 files
diff -r 00fd55d635fb2db4fb3b4647b1380769536f921c -r
8593e614573a4a167af4d3e73201dfa46c7e30a8 lisp/ChangeLog
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -3,6 +3,10 @@
* subr.el:
* subr.el (truncate-string-to-width):
Sync with GNU's version, use its test suite in mule-tests.el.
+ Avoid args-out-of-range errors, this function is regularly called
+ from menu code and with debug-on-signal non-nil, this can be very
+ irritating.
+ Don't bind ellipsis-len, we don't use it.
2012-05-12 Aidan Kehoe <kehoea(a)parhasard.net>
diff -r 00fd55d635fb2db4fb3b4647b1380769536f921c -r
8593e614573a4a167af4d3e73201dfa46c7e30a8 lisp/subr.el
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -1062,18 +1062,15 @@
(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)
- (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 str-len)))
+ (while (and (< column start-column) (< idx str-len))
+ (setq ch (aref str idx)
+ column (+ column (char-width ch))
+ idx (1+ idx)))
(if (< column start-column)
(if padding (make-string end-column padding) "")
(when (and padding (> column start-column))
@@ -1084,14 +1081,12 @@
(> str-width ellipsis-width))
(setq end-column (- end-column ellipsis-width))
(setq ellipsis ""))
- (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 str-len)))
+ (while (and (< column end-column) (< idx str-len))
+ (setq last-column column
+ last-idx idx
+ ch (aref str idx)
+ column (+ column (char-width ch))
+ idx (1+ idx)))
(when (> column end-column)
(setq column last-column
idx last-idx))
Repository URL:
https://bitbucket.org/xemacs/xemacs/
--
This is a commit notification from
bitbucket.org. You are receiving
this because you have the service enabled, addressing the recipient of
this email.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches