Mercurial > hg > xemacs-beta

comparison lisp/subr.el @ 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 b7ae5f44b950
children 8593e614573a
comparison
equal deleted inserted replaced
5663:0df4d95bd98a 5664:00fd55d635fb
1028 "Embed OBJ (string or character) at index IDX of STRING." 1028 "Embed OBJ (string or character) at index IDX of STRING."
1029 (if (stringp obj) 1029 (if (stringp obj)
1030 (replace (the string string) obj :start1 idx) 1030 (replace (the string string) obj :start1 idx)
1031 (prog1 string (aset string idx obj)))) 1031 (prog1 string (aset string idx obj))))
1032 1032
1033 ;; From FSF 21.1; ELLIPSES is XEmacs addition. 1033 ;; XEmacs; this is in mule-util in GNU. See tests/automated/mule-tests.el for
1034 1034 ;; the tests that Colin Walters includes in that file.
1035 (defun truncate-string-to-width (str end-column &optional start-column padding 1035 (defun truncate-string-to-width (str end-column
1036 ellipses) 1036 &optional start-column padding ellipsis)
1037 "Truncate string STR to end at column END-COLUMN. 1037 "Truncate string STR to end at column END-COLUMN.
1038 The optional 3rd arg START-COLUMN, if non-nil, specifies 1038 The optional 3rd arg START-COLUMN, if non-nil, specifies the starting
1039 the starting column; that means to return the characters occupying 1039 column; that means to return the characters occupying columns
1040 columns START-COLUMN ... END-COLUMN of STR. 1040 START-COLUMN ... END-COLUMN of STR. Both END-COLUMN and START-COLUMN
1041 1041 are specified in terms of character display width in the current
1042 The optional 4th arg PADDING, if non-nil, specifies a padding character 1042 buffer; see also `char-width'.
1043 to add at the end of the result if STR doesn't reach column END-COLUMN, 1043
1044 or if END-COLUMN comes in the middle of a character in STR. 1044 The optional 4th arg PADDING, if non-nil, specifies a padding
1045 PADDING is also added at the beginning of the result 1045 character (which should have a display width of 1) to add at the end
1046 if column START-COLUMN appears in the middle of a character in STR. 1046 of the result if STR doesn't reach column END-COLUMN, or if END-COLUMN
1047 comes in the middle of a character in STR. PADDING is also added at
1048 the beginning of the result if column START-COLUMN appears in the
1049 middle of a character in STR.
1047 1050
1048 If PADDING is nil, no padding is added in these cases, so 1051 If PADDING is nil, no padding is added in these cases, so
1049 the resulting string may be narrower than END-COLUMN. 1052 the resulting string may be narrower than END-COLUMN.
1050 1053
1051 BUG: Currently assumes that the padding character is of width one. You 1054 If ELLIPSIS is non-nil, it should be a string which will replace the
1052 will get weird results if not. 1055 end of STR (including any padding) if it extends beyond END-COLUMN,
1053 1056 unless the display width of STR is equal to or less than the display
1054 If ELLIPSES is non-nil, add ellipses (specified by ELLIPSES if a string, 1057 width of ELLIPSIS. If it is non-nil and not a string, then ELLIPSIS
1055 else `...') if STR extends past END-COLUMN. The ellipses will be added in 1058 defaults to \"...\"."
1056 such a way that the total string occupies no more than END-COLUMN columns
1057 -- i.e. if the string goes past END-COLUMN, it will be truncated somewhere
1058 short of END-COLUMN so that, with the ellipses added (and padding, if the
1059 proper place to truncate the string would be in the middle of a character),
1060 the string occupies exactly END-COLUMN columns."
1061 (or start-column 1059 (or start-column
1062 (setq start-column 0)) 1060 (setq start-column 0))
1063 (let ((len (length str)) 1061 (when (and ellipsis (not (stringp ellipsis)))
1062 (setq ellipsis "..."))
1063 (let ((str-len (length str))
1064 (str-width (string-width str))
1065 (ellipsis-len (if ellipsis (length ellipsis) 0))
1066 (ellipsis-width (if ellipsis (string-width ellipsis) 0))
1064 (idx 0) 1067 (idx 0)
1065 (column 0) 1068 (column 0)
1066 (head-padding "") (tail-padding "") 1069 (head-padding "") (tail-padding "")
1067 ch last-column last-idx from-idx) 1070 ch last-column last-idx from-idx)
1068
1069 ;; find the index of START-COLUMN; bail out if end of string reached.
1070 (condition-case nil 1071 (condition-case nil
1071 (while (< column start-column) 1072 (while (< column start-column)
1072 (setq ch (aref str idx) 1073 (setq ch (aref str idx)
1073 column (+ column (char-width ch)) 1074 column (+ column (char-width ch))
1074 idx (1+ idx))) 1075 idx (1+ idx)))
1075 (args-out-of-range (setq idx len))) 1076 (args-out-of-range (setq idx str-len)))
1076 (if (< column start-column) 1077 (if (< column start-column)
1077 ;; if string ends before START-COLUMN, return either a blank string 1078 (if padding (make-string end-column padding) "")
1078 ;; or a string entirely padded. 1079 (when (and padding (> column start-column))
1079 (if padding (make-string (- end-column start-column) padding) "") 1080 (setq head-padding (make-string (- column start-column) padding)))
1080 (if (and padding (> column start-column))
1081 (setq head-padding (make-string (- column start-column) padding)))
1082 (setq from-idx idx) 1081 (setq from-idx idx)
1083 ;; If END-COLUMN is before START-COLUMN, then bail out. 1082 (when (>= end-column column)
1084 (if (< end-column column) 1083 (if (and (< end-column str-width)
1085 (setq idx from-idx ellipses "") 1084 (> str-width ellipsis-width))
1086 1085 (setq end-column (- end-column ellipsis-width))
1087 ;; handle ELLIPSES 1086 (setq ellipsis ""))
1088 (cond ((null ellipses) (setq ellipses ""))
1089 ((if (<= (string-width str) end-column)
1090 ;; string fits, no ellipses
1091 (setq ellipses "")))
1092 (t
1093 ;; else, insert default value and ...
1094 (or (stringp ellipses) (setq ellipses "..."))
1095 ;; ... take away the width of the ellipses from the
1096 ;; destination. do all computations with new, shorter
1097 ;; width. the padding computed will get us exactly up to
1098 ;; the shorted width, which is right -- it just gets added
1099 ;; to the right of the ellipses.
1100 (setq end-column (- end-column (string-width ellipses)))))
1101
1102 ;; find the index of END-COLUMN; bail out if end of string reached.
1103 (condition-case nil 1087 (condition-case nil
1104 (while (< column end-column) 1088 (while (< column end-column)
1105 (setq last-column column 1089 (setq last-column column
1106 last-idx idx 1090 last-idx idx
1107 ch (aref str idx) 1091 ch (aref str idx)
1108 column (+ column (char-width ch)) 1092 column (+ column (char-width ch))
1109 idx (1+ idx))) 1093 idx (1+ idx)))
1110 (args-out-of-range (setq idx len))) 1094 (args-out-of-range (setq idx str-len)))
1111 ;; if we went too far (stopped in middle of character), back up. 1095 (when (> column end-column)
1112 (if (> column end-column) 1096 (setq column last-column
1113 (setq column last-column idx last-idx)) 1097 idx last-idx))
1114 ;; compute remaining padding 1098 (when (and padding (< column end-column))
1115 (if (and padding (< column end-column)) 1099 (setq tail-padding (make-string (- end-column column) padding))))
1116 (setq tail-padding (make-string (- end-column column) padding)))) 1100 (concat head-padding (substring str from-idx idx)
1117 ;; get substring ... 1101 tail-padding ellipsis))))
1118 (setq str (substring str from-idx idx))
1119 ;; and construct result
1120 (if padding
1121 (concat head-padding str tail-padding ellipses)
1122 (concat str ellipses)))))
1123
1124 1102
1125 ;; alist/plist functions 1103 ;; alist/plist functions
1126 (defun plist-to-alist (plist) 1104 (defun plist-to-alist (plist)
1127 "Convert property list PLIST into the equivalent association-list form. 1105 "Convert property list PLIST into the equivalent association-list form.
1128 The alist is returned. This converts from 1106 The alist is returned. This converts from