/[emacs]/emacs/lisp/international/mule-util.el
ViewVC logotype

Diff of /emacs/lisp/international/mule-util.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.46 by fx, Sat Dec 15 16:43:11 2001 UTC revision 1.47 by walters, Tue May 21 21:22:21 2002 UTC
# Line 84  TYPE should be `list' or `vector'." Line 84  TYPE should be `list' or `vector'."
84    string)    string)
85    
86  ;;;###autoload  ;;;###autoload
87  (defun truncate-string-to-width (str end-column &optional start-column padding)  (defun truncate-string-to-width (str end-column
88                                         &optional start-column padding ellipsis)
89    "Truncate string STR to end at column END-COLUMN.    "Truncate string STR to end at column END-COLUMN.
90  The optional 3rd arg START-COLUMN, if non-nil, specifies  The optional 3rd arg START-COLUMN, if non-nil, specifies the starting
91  the starting column; that means to return the characters occupying  column; that means to return the characters occupying columns
92  columns START-COLUMN ... END-COLUMN of STR.  START-COLUMN ... END-COLUMN of STR.  Both END-COLUMN and START-COLUMN
93    are specified in terms of character display width in the current
94  The optional 4th arg PADDING, if non-nil, specifies a padding character  buffer; see also `char-width'.
95  to add at the end of the result if STR doesn't reach column END-COLUMN,  
96  or if END-COLUMN comes in the middle of a character in STR.  The optional 4th arg PADDING, if non-nil, specifies a padding
97  PADDING is also added at the beginning of the result  character (which should have a display width of 1) to add at the end
98  if column START-COLUMN appears in the middle of a character in STR.  of the result if STR doesn't reach column END-COLUMN, or if END-COLUMN
99    comes in the middle of a character in STR.  PADDING is also added at
100    the beginning of the result if column START-COLUMN appears in the
101    middle of a character in STR.
102    
103  If PADDING is nil, no padding is added in these cases, so  If PADDING is nil, no padding is added in these cases, so
104  the resulting string may be narrower than END-COLUMN."  the resulting string may be narrower than END-COLUMN.
105    
106    If ELLIPSIS is non-nil, it should be a string which will replace the
107    end of STR (including any padding) if it extends beyond END-COLUMN,
108    unless the display width of STR is equal to or less than the display
109    width of ELLIPSIS.  If it is non-nil and not a string, then ELLIPSIS
110    defaults to \"...\"."
111    (or start-column    (or start-column
112        (setq start-column 0))        (setq start-column 0))
113    (let ((len (length str))    (when (and ellipsis (not (stringp ellipsis)))
114        (setq ellipsis "..."))
115      (let ((str-len (length str))
116            (str-width (string-width str))
117            (ellipsis-len (if ellipsis (length ellipsis) 0))
118            (ellipsis-width (if ellipsis (string-width ellipsis) 0))
119          (idx 0)          (idx 0)
120          (column 0)          (column 0)
121          (head-padding "") (tail-padding "")          (head-padding "") (tail-padding "")
# Line 110  the resulting string may be narrower tha Line 125  the resulting string may be narrower tha
125            (setq ch (aref str idx)            (setq ch (aref str idx)
126                  column (+ column (char-width ch))                  column (+ column (char-width ch))
127                  idx (1+ idx)))                  idx (1+ idx)))
128        (args-out-of-range (setq idx len)))        (args-out-of-range (setq idx str-len)))
129      (if (< column start-column)      (if (< column start-column)
130          (if padding (make-string end-column padding) "")          (if padding (make-string end-column padding) "")
131        (if (and padding (> column start-column))        (when (and padding (> column start-column))
132            (setq head-padding (make-string (- column start-column) padding)))          (setq head-padding (make-string (- column start-column) padding)))
133        (setq from-idx idx)        (setq from-idx idx)
134        (if (< end-column column)        (when (>= end-column column)
135            (setq idx from-idx)          (if (and (< end-column str-width)
136                     (> str-width ellipsis-width))
137                (setq end-column (- end-column ellipsis-width))
138              (setq ellipsis ""))
139          (condition-case nil          (condition-case nil
140              (while (< column end-column)              (while (< column end-column)
141                (setq last-column column                (setq last-column column
# Line 125  the resulting string may be narrower tha Line 143  the resulting string may be narrower tha
143                      ch (aref str idx)                      ch (aref str idx)
144                      column (+ column (char-width ch))                      column (+ column (char-width ch))
145                      idx (1+ idx)))                      idx (1+ idx)))
146            (args-out-of-range (setq idx len)))            (args-out-of-range (setq idx str-len)))
147          (if (> column end-column)          (when (> column end-column)
148              (setq column last-column idx last-idx))            (setq column last-column
149          (if (and padding (< column end-column))                  idx last-idx))
150              (setq tail-padding (make-string (- end-column column) padding))))          (when (and padding (< column end-column))
151        (setq str (substring str from-idx idx))            (setq tail-padding (make-string (- end-column column) padding))))
152        (if padding        (concat head-padding (substring str from-idx idx)
153            (concat head-padding str tail-padding)                tail-padding ellipsis))))
154          str))))  
155    ;;; Test suite for truncate-string-to-width
156    ;; (dolist (test '((("" 0) . "")
157    ;;              (("x" 1) . "x")
158    ;;              (("xy" 1) . "x")
159    ;;              (("xy" 2 1) . "y")
160    ;;              (("xy" 0) . "")
161    ;;              (("xy" 3) . "xy")
162    ;;              (("$AVP(B" 0) . "")
163    ;;              (("$AVP(B" 1) . "")
164    ;;              (("$AVP(B" 2) . "$AVP(B")
165    ;;              (("$AVP(B" 1 nil ? ) . " ")
166    ;;              (("$AVPND(B" 3 1 ? ) . "  ")
167    ;;              (("x$AVP(Bx" 2) . "x")
168    ;;              (("x$AVP(Bx" 3) . "x$AVP(B")
169    ;;              (("x$AVP(Bx" 3) . "x$AVP(B")
170    ;;              (("x$AVP(Bx" 4 1) . "$AVP(Bx")
171    ;;              (("kor$(CGQ(Be$(C1[(Ban" 8 1 ? ) . "or$(CGQ(Be$(C1[(B")
172    ;;              (("kor$(CGQ(Be$(C1[(Ban" 7 2 ? ) . "r$(CGQ(Be ")
173    ;;              (("" 0 nil nil "...") . "")
174    ;;              (("x" 3 nil nil "...") . "x")
175    ;;              (("$AVP(B" 3 nil nil "...") . "$AVP(B")
176    ;;              (("foo" 3 nil nil "...") . "foo")
177    ;;              (("foo" 2 nil nil "...") . "fo") ;; XEmacs failure?
178    ;;              (("foobar" 6 0 nil "...") . "foobar")
179    ;;              (("foobarbaz" 6 nil nil "...") . "foo...")
180    ;;              (("foobarbaz" 7 2 nil "...") . "ob...")
181    ;;              (("foobarbaz" 9 3 nil "...") . "barbaz")
182    ;;              (("$B$3(Bh$B$s(Be$B$K(Bl$B$A(Bl$B$O(Bo" 15 1 ?  t) . " h$B$s(Be$B$K(Bl$B$A(Bl$B$O(Bo")
183    ;;              (("$B$3(Bh$B$s(Be$B$K(Bl$B$A(Bl$B$O(Bo" 14 1 ?  t) . " h$B$s(Be$B$K(Bl$B$A(B...")
184    ;;              (("x" 3 nil nil "$(0GnM$(B") . "x")
185    ;;              (("$AVP(B" 2 nil nil "$(0GnM$(B") . "$AVP(B")
186    ;;              (("$AVP(B" 1 nil ?x "$(0GnM$(B") . "x") ;; XEmacs error
187    ;;              (("$AVPND(B" 3 nil ?  "$(0GnM$(B") . "$AVP(B ") ;; XEmacs error
188    ;;              (("foobarbaz" 4 nil nil  "$(0GnM$(B") . "$(0GnM$(B")
189    ;;              (("foobarbaz" 5 nil nil  "$(0GnM$(B") . "f$(0GnM$(B")
190    ;;              (("foobarbaz" 6 nil nil  "$(0GnM$(B") . "fo$(0GnM$(B")
191    ;;              (("foobarbaz" 8 3 nil "$(0GnM$(B") . "b$(0GnM$(B")
192    ;;              (("$B$3(Bh$B$s(Be$B$K(Bl$B$A(Bl$B$O(Bo" 14 4 ?x "$BF|K\8l(B") . "xe$B$KF|K\8l(B")
193    ;;              (("$B$3(Bh$B$s(Be$B$K(Bl$B$A(Bl$B$O(Bo" 13 4 ?x "$BF|K\8l(B") . "xex$BF|K\8l(B")
194    ;;              ))
195    ;;   (let (ret)
196    ;;     (condition-case e
197    ;;      (setq ret (apply #'truncate-string-to-width (car test)))
198    ;;       (error (setq ret e)))
199    ;;     (unless (equal ret (cdr test))
200    ;;       (error "%s: expected %s, got %s"
201    ;;           (prin1-to-string (cons 'truncate-string-to-width (car test)))
202    ;;           (prin1-to-string (cdr test))
203    ;;           (if (consp ret)
204    ;;               (format "error: %s: %s" (car ret)
205    ;;                       (prin1-to-string (cdr ret)))
206    ;;             (prin1-to-string ret))))))
207    
208  ;;; For backward compatibility ...  ;;; For backward compatibility ...
209  ;;;###autoload  ;;;###autoload
# Line 300  language environment LANG-ENV." Line 370  language environment LANG-ENV."
370    
371  (provide 'mule-util)  (provide 'mule-util)
372    
373    ;; Local Variables:
374    ;; coding: iso-2022-7bit
375    ;; End:
376    
377  ;;; mule-util.el ends here  ;;; mule-util.el ends here

Legend:
Removed from v.1.46  
changed lines
  Added in v.1.47

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26