Mercurial > hg > xemacs-beta

changeset 5664:00fd55d635fb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Sync #'truncate-string-to-width with GNU, add tests for it. lisp/ChangeLog addition: 2012-05-12 Aidan Kehoe <kehoea@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@parhasard.net> * automated/mule-tests.el: Test #'truncate-string-to-width, thank you Colin Walters.
author Aidan Kehoe <kehoea@parhasard.net>
date Sat, 12 May 2012 17:51:05 +0100
parents 0df4d95bd98a
children 8593e614573a
files lisp/ChangeLog lisp/subr.el tests/ChangeLog tests/automated/mule-tests.el
diffstat 4 files changed, 129 insertions(+), 66 deletions(-) [+]
line wrap: on
line diff
--- 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@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@parhasard.net>
 
 	* byte-optimize.el (byte-compile-unfold-lambda):
--- 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.
-
-(defun truncate-string-to-width (str end-column &optional start-column padding
-				 ellipses)
+;; 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.
+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'.
 
-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)
--- 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@parhasard.net>
+
+	* automated/mule-tests.el:
+	Test #'truncate-string-to-width, thank you Colin Walters.
+
 2012-05-06  Aidan Kehoe  <kehoea@parhasard.net>
 
 	* automated/lisp-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