Fix incremental archiving of renamed directories.
[tar/ericb.git] / rebox.el
blob1e4586bc7a7081d296e2f95797d3b3304e215788
1 ;;; Handling of comment boxes.
2 ;;; Copyright (C) 1991, 92, 93, 94, 95, 96, 97 Free Software Foundation, Inc.
3 ;;; François Pinard <pinard@iro.umontreal.ca>, April 1991.
5 ;;; I first observed rounded corners, as in style 223 boxes, in code from
6 ;;; Warren Tucker <wht@n4hgf.mt-park.ga.us>, a previous shar maintainer.
8 ;;; Refilling paragraphs inside comments, stretching or shrinking the
9 ;;; surrounding box as needed, is a pain to do "by hand". This GNU Emacs
10 ;;; LISP code eases my life on this and I find it fair, giving all sources
11 ;;; for a package, to also give the means for nicely modifying comments.
13 ;;; The function rebox-comment discovers the extent of the boxed comments
14 ;;; near the cursor, possibly refills the text, then adjusts the comment
15 ;;; box style. The function rebox-region does the same, except that it
16 ;;; takes the current region as a boxed comment. Numeric prefixes are
17 ;;; used to add or remove a box, change its style (language, quality or
18 ;;; type), or to prevent refilling of its text. A minus sign alone as
19 ;;; prefix asks for interactive style selection.
21 ;;; For most Emacs language editing modes, refilling does not make sense
22 ;;; outside comments, so you may redefine the M-q command and link it to
23 ;;; this file. For example, I use this in my .emacs file:
25 ;;; (setq c-mode-hook
26 ;;; '(lambda ()
27 ;;; (define-key c-mode-map "\M-q" 'rebox-comment)))
28 ;;; (autoload 'rebox-comment "rebox" nil t)
29 ;;; (autoload 'rebox-region "rebox" nil t)
31 ;;; The cursor should be within a comment before any of these commands,
32 ;;; or else it should be between two comments, in which case the command
33 ;;; applies to the next comment. When the command is given without prefix,
34 ;;; the current comment box style is recognized from the comment itself
35 ;;; as far as possible, and preserved. A prefix may be used to force
36 ;;; a particular box style. A style is made up of three attributes: a
37 ;;; language (the hundreds digit), a quality (the tens digit) and a type
38 ;;; (the units digit). A zero or negative flag value changes the default
39 ;;; box style to its absolute value. Zero digits in default style,
40 ;;; when not overriden in flag, asks for recognition of corresponding
41 ;;; attributes from the current box. `C-u' avoids refilling the text,
42 ;;; using the default box style. `C-u -' defines the style interactively.
44 ;;; Box language is associated with comment delimiters. Values are 100
45 ;;; for none or unknown, 200 for `/*' and `*/' as in plain C, 300 for
46 ;;; '//' as in C++, 400 for `#' as in most scripting languages, 500 for
47 ;;; `;' as in LISP or assembler and 600 for `%' as in TeX or PostScript.
49 ;;; Box quality differs according to language. For unknown languages (100)
50 ;;; or for the C language (200), values are 10 for simple, 20 or 30 for
51 ;;; rounded, and 40 for starred. For all others, box quality indicates
52 ;;; the thickness in characters of the left and right sides of the box:
53 ;;; values are 10, 20, 30 or 40 for 1, 2, 3 or 4 characters wide. C++
54 ;;; quality 10 is always promoted to 20. Roughly said, simple quality
55 ;;; boxes (10) use comment delimiters to left and right of each comment
56 ;;; line, and also for the top or bottom line when applicable. Rounded
57 ;;; quality boxes (20 or 30) try to suggest rounded corners in boxes.
58 ;;; Starred quality boxes (40) mostly use a left margin of asterisks or
59 ;;; X'es, and use them also in box surroundings. Experiment a little to
60 ;;; see what happens.
62 ;;; Box type values are 1 for fully opened boxes for which boxing is done
63 ;;; only for the left and right but not for top or bottom, 2 for half
64 ;;; single lined boxes for which boxing is done on all sides except top,
65 ;;; 3 for fully single lined boxes for which boxing is done on all sides,
66 ;;; 4 for half double lined boxes which is like type 2 but more bold,
67 ;;; or 5 for fully double lined boxes which is like type 3 but more bold.
69 ;;; The special style 221 or 231 is worth a note, because it is fairly
70 ;;; common: the whole C comment stays between a single opening `/*'
71 ;;; and a single closing `*/'. The special style 111 deletes a box.
72 ;;; The initial default style is 023 so, unless overriden, comments are
73 ;;; put in single lined boxes, C comments are of rounded quality.
75 (defvar rebox-default-style 0 "*Preferred style for box comments.")
77 ;;; Help strings for prompting or error messages.
79 (defconst REBOX_HELP_FOR_LANGUAGE
80 "Box language is 100-none, 200-/*, 300-//, 400-#, 500-;, 600-%%")
81 (defconst REBOX_LANGUAGE_NONE 100)
82 (defconst REBOX_LANGUAGE_C 200)
83 (defconst REBOX_LANGUAGE_C++ 300)
84 (defconst REBOX_LANGUAGE_AWK 400)
85 (defconst REBOX_LANGUAGE_LISP 500)
86 (defconst REBOX_LANGUAGE_TEX 600)
88 (defun rebox-help-string-for-language (language)
89 (cond ((= language 0) "default language")
90 ((= language REBOX_LANGUAGE_NONE) "no language")
91 ((= language REBOX_LANGUAGE_C) "plain C")
92 ((= language REBOX_LANGUAGE_C++) "C++")
93 ((= language REBOX_LANGUAGE_AWK) "sh/Perl/make")
94 ((= language REBOX_LANGUAGE_LISP) "LISP/assembler")
95 ((= language REBOX_LANGUAGE_TEX) "TeX/PostScript")
96 (t "<Unknown Language>")))
98 (defconst REBOX_HELP_FOR_QUALITY
99 "Box quality/width is 10-simple, 20-rounded, 30-rounded or 40-starred")
100 (defconst REBOX_QUALITY_SIMPLE_ONE 10)
101 (defconst REBOX_QUALITY_ROUNDED_TWO 20)
102 (defconst REBOX_QUALITY_ROUNDED_THREE 30)
103 (defconst REBOX_QUALITY_STARRED_FOUR 40)
105 (defun rebox-help-string-for-quality (quality)
106 (cond ((= quality 0) "default quality")
107 ((= quality REBOX_QUALITY_SIMPLE_ONE) "square or 1-wide")
108 ((= quality REBOX_QUALITY_ROUNDED_TWO) "rounded or 2-wide")
109 ((= quality REBOX_QUALITY_ROUNDED_THREE) "rounded or 3-wide")
110 ((= quality REBOX_QUALITY_STARRED_FOUR) "starred or 4-wide")
111 (t "<Unknown Quality>")))
113 (defconst REBOX_HELP_FOR_TYPE
114 "Box type is 1-open, 2-half-single, 3-single, 4-half-double or 5-double")
115 (defconst REBOX_TYPE_OPEN 1)
116 (defconst REBOX_TYPE_HALF_SINGLE 2)
117 (defconst REBOX_TYPE_SINGLE 3)
118 (defconst REBOX_TYPE_HALF_DOUBLE 4)
119 (defconst REBOX_TYPE_DOUBLE 5)
121 (defun rebox-help-string-for-type (type)
122 (cond ((= type 0) "default type")
123 ((= type REBOX_TYPE_OPEN) "opened box")
124 ((= type REBOX_TYPE_HALF_SINGLE) "half normal")
125 ((= type REBOX_TYPE_SINGLE) "full normal")
126 ((= type REBOX_TYPE_HALF_DOUBLE) "half bold")
127 ((= type REBOX_TYPE_DOUBLE) "full bold")
128 (t "<Unknown Type>")))
130 (defconst REBOX_MAX_LANGUAGE 6)
131 (defconst REBOX_MAX_QUALITY 4)
132 (defconst REBOX_MAX_TYPE 5)
134 ;;; Request the style interactively, using the minibuffer.
136 (defun rebox-ask-for-style ()
137 (let (key language quality type)
138 (while (not language)
139 (message REBOX_HELP_FOR_LANGUAGE)
140 (setq key (read-char))
141 (if (and (>= key ?0) (<= key (+ ?0 REBOX_MAX_LANGUAGE)))
142 (setq language (- key ?0))))
143 (while (not quality)
144 (message REBOX_HELP_FOR_QUALITY)
145 (setq key (read-char))
146 (if (and (>= key ?0) (<= key (+ ?0 REBOX_MAX_QUALITY)))
147 (setq quality (- key ?0))))
148 (while (not type)
149 (message REBOX_HELP_FOR_TYPE)
150 (setq key (read-char))
151 (if (and (>= key ?0) (<= key (+ ?0 REBOX_MAX_TYPE)))
152 (setq type (- key ?0))))
153 (+ (* 100 language) (* 10 quality) type)))
155 ;;; Write some TEXT followed by an edited STYLE value into the minibuffer.
157 (defun rebox-show-style (text style)
158 (message
159 (concat text (format " (%03d)" style)
160 ": " (rebox-help-string-for-language (* (/ style 100) 100))
161 ", " (rebox-help-string-for-quality (* (% (/ style 10) 10) 10))
162 ", " (rebox-help-string-for-type (% style 10)))))
164 ;;; Validate FLAG and usually return t if not interrupted by errors.
165 ;;; But if FLAG is zero or negative, then change default box style and
166 ;;; return nil.
168 (defun rebox-validate-flag (flag)
170 ;; Validate flag.
172 (if (numberp flag)
173 (let ((value (if (< flag 0) (- flag) flag)))
174 (if (> (/ value 100) REBOX_MAX_LANGUAGE)
175 (error REBOX_HELP_FOR_LANGUAGE))
176 (if (> (% (/ value 10) 10) REBOX_MAX_QUALITY)
177 (error REBOX_HELP_FOR_QUALITY))
178 (if (> (% value 10) REBOX_MAX_TYPE)
179 (error REBOX_HELP_FOR_TYPE))))
181 ;; Change default box style if requested.
183 (if (and (numberp flag) (<= flag 0))
184 (progn
185 (setq flag (- flag))
186 (if (not (zerop (/ flag 100)))
187 (setq rebox-default-style
188 (+ (* (/ flag 100) 100)
189 (% rebox-default-style 100))))
190 (if (not (zerop (% (/ flag 10) 10)))
191 (setq rebox-default-style
192 (+ (* (/ rebox-default-style 100) 100)
193 (* (% (/ flag 10) 10) 10)
194 (% rebox-default-style 10))))
195 (if (not (zerop (% flag 10)))
196 (setq rebox-default-style
197 (+ (* (/ rebox-default-style 10) 10)
198 (% flag 10))))
199 (rebox-show-style "Default style" rebox-default-style)
200 nil)
203 ;;; Return the minimum value of the left margin of all lines, or -1 if
204 ;;; all lines are empty.
206 (defun rebox-left-margin ()
207 (let ((margin -1))
208 (goto-char (point-min))
209 (while (not (eobp))
210 (skip-chars-forward " \t")
211 (if (not (looking-at "\n"))
212 (setq margin
213 (if (< margin 0)
214 (current-column)
215 (min margin (current-column)))))
216 (forward-line 1))
217 margin))
219 ;;; Return the maximum value of the right margin of all lines. Any
220 ;;; sentence ending a line has a space guaranteed before the margin.
222 (defun rebox-right-margin ()
223 (let ((margin 0) period)
224 (goto-char (point-min))
225 (while (not (eobp))
226 (end-of-line)
227 (if (bobp)
228 (setq period 0)
229 (backward-char 1)
230 (setq period (if (looking-at "[.?!]") 1 0))
231 (forward-char 1))
232 (setq margin (max margin (+ (current-column) period)))
233 (forward-char 1))
234 margin))
236 ;;; Return a regexp to match the start or end of a comment for some
237 ;;; LANGUAGE, leaving the comment marks themselves available in \1.
239 ;; FIXME: Recognize style 1** boxes.
241 (defun rebox-regexp-start (language)
242 (cond ((= language 0) "^[ \t]*\\(/\\*\\|//+\\|#+\\|;+\\|%+\\)")
243 ((= language REBOX_LANGUAGE_NONE) "^\\(\\)")
244 ((= language REBOX_LANGUAGE_C) "^[ \t]*\\(/\\*\\)")
245 ((= language REBOX_LANGUAGE_C++) "^[ \t]*\\(//+\\)")
246 ((= language REBOX_LANGUAGE_AWK) "^[ \t]*\\(#+\\)")
247 ((= language REBOX_LANGUAGE_LISP) "^[ \t]*\\(;+\\)")
248 ((= language REBOX_LANGUAGE_TEX) "^[ \t]*\\(%+\\)")))
250 (defun rebox-regexp-end (language)
251 (cond ((= language 0) "\\(\\*/\\|//+\\|#+\\|;+\\|%+\\)[ \t]*$")
252 ((= language REBOX_LANGUAGE_NONE) "\\(\\)$")
253 ((= language REBOX_LANGUAGE_C) "\\(\\*/\\)[ \t]*$")
254 ((= language REBOX_LANGUAGE_C++) "\\(//+\\)[ \t]*$")
255 ((= language REBOX_LANGUAGE_AWK) "\\(#+\\)[ \t]*$")
256 ((= language REBOX_LANGUAGE_LISP) "\\(;+\\)[ \t]*$")
257 ((= language REBOX_LANGUAGE_TEX) "\\(%+\\)[ \t]*$")))
259 ;;; By looking at the text starting at the cursor position, guess the
260 ;;; language in use, and return it.
262 (defun rebox-guess-language ()
263 (let ((language REBOX_LANGUAGE_NONE)
264 (value (* 100 REBOX_MAX_LANGUAGE)))
265 (while (not (zerop value))
266 (if (looking-at (rebox-regexp-start value))
267 (progn
268 (setq language value)
269 (setq value 0))
270 (setq value (- value 100))))
271 language))
273 ;;; Find the limits of the block of comments following or enclosing
274 ;;; the cursor, or return an error if the cursor is not within such a
275 ;;; block of comments. Extend it as far as possible in both
276 ;;; directions, then narrow the buffer around it.
278 (defun rebox-find-and-narrow ()
279 (save-excursion
280 (let (start end temp language)
282 ;; Find the start of the current or immediately following comment.
284 (beginning-of-line)
285 (skip-chars-forward " \t\n")
286 (beginning-of-line)
287 (if (not (looking-at (rebox-regexp-start 0)))
288 (progn
289 (setq temp (point))
290 (if (re-search-forward "\\*/" nil t)
291 (progn
292 (re-search-backward "/\\*")
293 (if (> (point) temp)
294 (error "outside any comment block"))
295 (setq temp (point))
296 (beginning-of-line)
297 (skip-chars-forward " \t")
298 (if (not (= (point) temp))
299 (error "text before start of comment"))
300 (beginning-of-line))
301 (error "outside any comment block"))))
303 (setq start (point))
304 (setq language (rebox-guess-language))
306 ;; - find the end of this comment
308 (if (= language REBOX_LANGUAGE_C)
309 (progn
310 (search-forward "*/")
311 (if (not (looking-at "[ \t]*$"))
312 (error "text after end of comment"))))
313 (end-of-line)
314 (if (eobp)
315 (insert "\n")
316 (forward-char 1))
317 (setq end (point))
319 ;; - try to extend the comment block backwards
321 (goto-char start)
322 (while (and (not (bobp))
323 (if (= language REBOX_LANGUAGE_C)
324 (progn
325 (skip-chars-backward " \t\n")
326 (if (and (looking-at "[ \t]*\n[ \t]*/\\*")
327 (> (point) 2))
328 (progn
329 (backward-char 2)
330 (if (looking-at "\\*/")
331 (progn
332 (re-search-backward "/\\*")
333 (setq temp (point))
334 (beginning-of-line)
335 (skip-chars-forward " \t")
336 (if (= (point) temp)
337 (progn (beginning-of-line) t)))))))
338 (previous-line 1)
339 (looking-at (rebox-regexp-start language))))
340 (setq start (point)))
342 ;; - try to extend the comment block forward
344 (goto-char end)
345 (while (looking-at (rebox-regexp-start language))
346 (if (= language REBOX_LANGUAGE_C)
347 (progn
348 (re-search-forward "[ \t]*/\\*")
349 (re-search-forward "\\*/")
350 (if (looking-at "[ \t]*$")
351 (progn
352 (beginning-of-line)
353 (forward-line 1)
354 (setq end (point)))))
355 (forward-line 1)
356 (setq end (point))))
358 ;; - narrow to the whole block of comments
360 (narrow-to-region start end))))
362 ;;; After refilling it if REFILL is not nil, while respecting a left
363 ;;; MARGIN, put the narrowed buffer back into a boxed LANGUAGE comment
364 ;;; box of a given QUALITY and TYPE.
366 (defun rebox-reconstruct (refill margin language quality type)
367 (rebox-show-style "Style" (+ language quality type))
369 (let (right-margin nw nn ne ww ee sw ss se x xx)
371 ;; - decide the elements of the box being produced
373 (cond ((= language REBOX_LANGUAGE_NONE)
374 ;; - planify a comment for no language in particular
376 (cond ((= quality REBOX_QUALITY_SIMPLE_ONE)
377 ;; - planify a simple box
379 (cond ((= type REBOX_TYPE_OPEN)
380 (setq nw "") (setq sw "")
381 (setq ww "") (setq ee ""))
382 ((= type REBOX_TYPE_HALF_SINGLE)
383 (setq nw "")
384 (setq ww "| ") (setq ee " |")
385 (setq sw "+-") (setq ss ?-) (setq se "-+"))
386 ((= type REBOX_TYPE_SINGLE)
387 (setq nw "+-") (setq nn ?-) (setq ne "-+")
388 (setq ww "| ") (setq ee " |")
389 (setq sw "+-") (setq ss ?-) (setq se "-+"))
390 ((= type REBOX_TYPE_HALF_DOUBLE)
391 (setq nw "")
392 (setq ww "| ") (setq ee " |")
393 (setq sw "*=") (setq ss ?=) (setq se "=*"))
394 ((= type REBOX_TYPE_DOUBLE)
395 (setq nw "*=") (setq nn ?=) (setq ne "=*")
396 (setq ww "| ") (setq ee " |")
397 (setq sw "*=") (setq ss ?=) (setq se "=*"))))
399 ((or (= quality REBOX_QUALITY_ROUNDED_TWO)
400 (= quality REBOX_QUALITY_ROUNDED_THREE))
401 ;; - planify a rounded box
403 (cond ((= type REBOX_TYPE_OPEN)
404 (setq nw "") (setq sw "")
405 (setq ww "| ") (setq ee " |"))
406 ((= type REBOX_TYPE_HALF_SINGLE)
407 (setq nw "")
408 (setq ww "| ") (setq ee " |")
409 (setq sw "`-") (setq ss ?-) (setq se "-'"))
410 ((= type REBOX_TYPE_SINGLE)
411 (setq nw ".-") (setq nn ?-) (setq ne "-.")
412 (setq ww "| ") (setq ee " |")
413 (setq sw "`-") (setq ss ?-) (setq se "-'"))
414 ((= type REBOX_TYPE_HALF_DOUBLE)
415 (setq nw "")
416 (setq ww "| " ) (setq ee " |" )
417 (setq sw "\\=") (setq ss ?=) (setq se "=/" ))
418 ((= type REBOX_TYPE_DOUBLE)
419 (setq nw "/=" ) (setq nn ?=) (setq ne "=\\")
420 (setq ww "| " ) (setq ee " |" )
421 (setq sw "\\=") (setq ss ?=) (setq se "=/" ))))
423 ((= quality REBOX_QUALITY_STARRED_FOUR)
424 ;; - planify a starred box
426 (cond ((= type REBOX_TYPE_OPEN)
427 (setq nw "") (setq sw "")
428 (setq ww "| ") (setq ee ""))
429 ((= type REBOX_TYPE_HALF_SINGLE)
430 (setq nw "")
431 (setq ww "* ") (setq ee " *")
432 (setq sw "**") (setq ss ?*) (setq se "**"))
433 ((= type REBOX_TYPE_SINGLE)
434 (setq nw "**") (setq nn ?*) (setq ne "**")
435 (setq ww "* ") (setq ee " *")
436 (setq sw "**") (setq ss ?*) (setq se "**"))
437 ((= type REBOX_TYPE_HALF_DOUBLE)
438 (setq nw "")
439 (setq ww "X ") (setq ee " X")
440 (setq sw "XX") (setq ss ?X) (setq se "XX"))
441 ((= type REBOX_TYPE_DOUBLE)
442 (setq nw "XX") (setq nn ?X) (setq ne "XX")
443 (setq ww "X ") (setq ee " X")
444 (setq sw "XX") (setq ss ?X) (setq se "XX"))))))
446 ((= language REBOX_LANGUAGE_C)
447 ;; - planify a comment for C
449 (cond ((= quality REBOX_QUALITY_SIMPLE_ONE)
450 ;; - planify a simple C comment
452 (cond ((= type REBOX_TYPE_OPEN)
453 (setq nw "") (setq sw "")
454 (setq ww "/* ") (setq ee " */"))
455 ((= type REBOX_TYPE_HALF_SINGLE)
456 (setq nw "")
457 (setq ww "/* ") (setq ee " */")
458 (setq sw "/* ") (setq ss ?-) (setq se " */"))
459 ((= type REBOX_TYPE_SINGLE)
460 (setq nw "/* ") (setq nn ?-) (setq ne " */")
461 (setq ww "/* ") (setq ee " */")
462 (setq sw "/* ") (setq ss ?-) (setq se " */"))
463 ((= type REBOX_TYPE_HALF_DOUBLE)
464 (setq nw "")
465 (setq ww "/* ") (setq ee " */")
466 (setq sw "/* ") (setq ss ?=) (setq se " */"))
467 ((= type REBOX_TYPE_DOUBLE)
468 (setq nw "/* ") (setq nn ?=) (setq ne " */")
469 (setq ww "/* ") (setq ee " */")
470 (setq sw "/* ") (setq ss ?=) (setq se " */"))))
472 ((or (= quality REBOX_QUALITY_ROUNDED_TWO)
473 (= quality REBOX_QUALITY_ROUNDED_THREE))
474 ;; - planify a rounded C comment
476 (cond ((= type REBOX_TYPE_OPEN)
477 ;; ``open rounded'' is a special case
478 (setq nw "") (setq sw "")
479 (setq ww " ") (setq ee ""))
480 ((= type REBOX_TYPE_HALF_SINGLE)
481 (setq nw "/*") (setq nn ? ) (setq ne " .")
482 (setq ww "| ") (setq ee " |")
483 (setq sw "`-") (setq ss ?-) (setq se "*/"))
484 ((= type REBOX_TYPE_SINGLE)
485 (setq nw "/*") (setq nn ?-) (setq ne "-.")
486 (setq ww "| ") (setq ee " |")
487 (setq sw "`-") (setq ss ?-) (setq se "*/"))
488 ((= type REBOX_TYPE_HALF_DOUBLE)
489 (setq nw "/*" ) (setq nn ? ) (setq ne " \\")
490 (setq ww "| " ) (setq ee " |" )
491 (setq sw "\\=") (setq ss ?=) (setq se "*/" ))
492 ((= type REBOX_TYPE_DOUBLE)
493 (setq nw "/*" ) (setq nn ?=) (setq ne "=\\")
494 (setq ww "| " ) (setq ee " |" )
495 (setq sw "\\=") (setq ss ?=) (setq se "*/" ))))
497 ((= quality REBOX_QUALITY_STARRED_FOUR)
498 ;; - planify a starred C comment
500 (cond ((= type REBOX_TYPE_OPEN)
501 (setq nw "/* ") (setq nn ? ) (setq ne "")
502 (setq ww " * ") (setq ee "")
503 (setq sw " */") (setq ss ? ) (setq se ""))
504 ((= type REBOX_TYPE_HALF_SINGLE)
505 (setq nw "/* ") (setq nn ? ) (setq ne " *")
506 (setq ww " * ") (setq ee " *")
507 (setq sw " **") (setq ss ?*) (setq se "**/"))
508 ((= type REBOX_TYPE_SINGLE)
509 (setq nw "/**") (setq nn ?*) (setq ne "**")
510 (setq ww " * ") (setq ee " *")
511 (setq sw " **") (setq ss ?*) (setq se "**/"))
512 ((= type REBOX_TYPE_HALF_DOUBLE)
513 (setq nw "/* " ) (setq nn ? ) (setq ne " *\\")
514 (setq ww "|* " ) (setq ee " *|" )
515 (setq sw "\\**") (setq ss ?*) (setq se "**/" ))
516 ((= type REBOX_TYPE_DOUBLE)
517 (setq nw "/**" ) (setq nn ?*) (setq ne "**\\")
518 (setq ww "|* " ) (setq ee " *|" )
519 (setq sw "\\**") (setq ss ?*) (setq se "**/" ))))))
522 ;; - planify a comment for all other things
524 (if (and (= language REBOX_LANGUAGE_C++)
525 (= quality REBOX_QUALITY_SIMPLE_ONE))
526 (setq quality REBOX_QUALITY_ROUNDED_TWO))
527 (setq x (cond ((= language REBOX_LANGUAGE_C++) ?/)
528 ((= language REBOX_LANGUAGE_AWK) ?#)
529 ((= language REBOX_LANGUAGE_LISP) ?\;)
530 ((= language REBOX_LANGUAGE_TEX) ?%)))
531 (setq xx (make-string (/ quality 10) x))
532 (setq ww (concat xx " "))
533 (cond ((= type REBOX_TYPE_OPEN)
534 (setq nw "") (setq sw "") (setq ee ""))
535 ((= type REBOX_TYPE_HALF_SINGLE)
536 (setq ee (concat " " xx))
537 (setq nw "")
538 (setq sw ww) (setq ss ?-) (setq se ee))
539 ((= type REBOX_TYPE_SINGLE)
540 (setq ee (concat " " xx))
541 (setq nw ww) (setq nn ?-) (setq ne ee)
542 (setq sw ww) (setq ss ?-) (setq se ee))
543 ((= type REBOX_TYPE_HALF_DOUBLE)
544 (setq ee (concat " " xx))
545 (setq xx (make-string (1+ (/ quality 10)) x))
546 (setq nw "")
547 (setq sw xx) (setq ss x) (setq se xx))
548 ((= type REBOX_TYPE_DOUBLE)
549 (setq ee (concat " " xx))
550 (setq xx (make-string (1+ (/ quality 10)) x))
551 (setq nw xx) (setq nn x) (setq ne xx)
552 (setq sw xx) (setq ss x) (setq se xx)))))
554 ;; - possibly refill, and adjust margins to account for left inserts
556 (if (not (and flag (listp flag)))
557 (let ((fill-prefix (make-string margin ? ))
558 (fill-column (- fill-column (+ (length ww) (length ee)))))
559 (fill-region (point-min) (point-max))))
561 (setq right-margin (+ (rebox-right-margin) (length ww)))
563 ;; - construct the box comment, from top to bottom
565 (goto-char (point-min))
566 (if (and (= language REBOX_LANGUAGE_C)
567 (or (= quality REBOX_QUALITY_ROUNDED_TWO)
568 (= quality REBOX_QUALITY_ROUNDED_THREE))
569 (= type REBOX_TYPE_OPEN))
570 (progn
571 ;; - construct an 33 style comment
573 (skip-chars-forward " " (+ (point) margin))
574 (insert (make-string (- margin (current-column)) ? )
575 "/* ")
576 (end-of-line)
577 (forward-char 1)
578 (while (not (eobp))
579 (skip-chars-forward " " (+ (point) margin))
580 (insert (make-string (- margin (current-column)) ? )
582 (beginning-of-line)
583 (forward-line 1))
584 (backward-char 1)
585 (insert " */"))
587 ;; - construct all other comment styles
589 ;; construct one top line
590 (if (not (zerop (length nw)))
591 (progn
592 (indent-to margin)
593 (insert nw)
594 (if (or (not (eq nn ? )) (not (zerop (length ne))))
595 (insert (make-string (- right-margin (current-column)) nn)
596 ne))
597 (insert "\n")))
599 ;; construct one middle line
600 (while (not (eobp))
601 (skip-chars-forward " " (+ (point) margin))
602 (insert (make-string (- margin (current-column)) ? )
604 (end-of-line)
605 (if (not (zerop (length ee)))
606 (progn
607 (indent-to right-margin)
608 (insert ee)))
609 (beginning-of-line)
610 (forward-line 1))
612 ;; construct one bottom line
613 (if (not (zerop (length sw)))
614 (progn
615 (indent-to margin)
616 (insert sw)
617 (if (or (not (eq ss ? )) (not (zerop (length se))))
618 (insert (make-string (- right-margin (current-column)) ss)
619 se "\n")))))))
621 ;;; Add, delete or adjust a comment box in the narrowed buffer.
622 ;;; Various FLAG values are explained at beginning of this file.
624 (defun rebox-engine (flag)
625 (let ((undo-list buffer-undo-list)
626 (marked-point (point-marker))
627 (language (progn (goto-char (point-min)) (rebox-guess-language)))
628 (quality 0)
629 (type 0))
631 (untabify (point-min) (point-max))
633 ;; Remove all the comment marks, and move all the text rigidly to the
634 ;; left for insuring that the left margin stays at the same place.
635 ;; At the same time, try recognizing the box style, saving its quality
636 ;; in QUALITY and its type in TYPE. (LANGUAGE is already guessed.)
638 (let ((indent-tabs-mode nil)
639 (previous-margin (rebox-left-margin))
640 actual-margin)
642 ;; FIXME: Cleanup style 1** boxes.
643 ;; FIXME: Recognize really all cases of type and quality.
645 ;; - remove all comment marks
647 (if (= language REBOX_LANGUAGE_NONE)
649 (goto-char (point-min))
650 (while (re-search-forward (rebox-regexp-start language) nil t)
651 (goto-char (match-beginning 1))
652 (delete-region (point) (match-end 1))
653 (insert (make-string (- (match-end 1) (point)) ? )))
654 (goto-char (point-min))
655 (while (re-search-forward (rebox-regexp-end language) nil t)
656 (replace-match "" t t)))
658 (if (= language REBOX_LANGUAGE_C)
659 (progn
660 (goto-char (point-min))
661 (while (re-search-forward "\\*/ */\\*" nil t)
662 (replace-match " " t t))
664 (goto-char (point-min))
665 (while (re-search-forward "^\\( *\\)|\\*\\(.*\\)\\*| *$" nil t)
666 (setq quality REBOX_QUALITY_STARRED_FOUR)
667 (setq type REBOX_TYPE_DOUBLE)
668 (replace-match "\\1 \\2" t))
670 (goto-char (point-min))
671 (while (re-search-forward "^\\( *\\)\\*\\(.*\\)\\* *$" nil t)
672 (setq quality REBOX_QUALITY_STARRED_FOUR)
673 (setq type REBOX_TYPE_SINGLE)
674 (replace-match "\\1 \\2" t))
676 (goto-char (point-min))
677 (while (re-search-forward "^\\( *\\)|\\(.*\\)| *$" nil t)
678 (setq quality REBOX_QUALITY_ROUNDED_TWO)
679 (replace-match "\\1 \\2" t))
681 (goto-char (point-min))
682 (if (zerop quality)
683 (while (re-search-forward "^\\( +\\)\\* " nil t)
684 (setq quality REBOX_QUALITY_STARRED_FOUR)
685 (setq type REBOX_TYPE_OPEN)
686 (replace-match "\\1 " t)))))
688 ;; - remove the first dashed or starred line
690 (goto-char (point-min))
691 (if (looking-at "^ *\\(--+\\|\\*\\*+\\)[.\+\\]? *\n")
692 (progn
693 (setq type REBOX_TYPE_SINGLE)
694 (replace-match "" t t))
695 (if (looking-at "^ *\\(==\\|XX+\\|##+\\|;;+\\)[.\+\\]? *\n")
696 (progn
697 (setq type REBOX_TYPE_DOUBLE)
698 (replace-match "" t t))))
700 ;; - remove the last dashed or starred line
702 (goto-char (point-max))
703 (previous-line 1)
704 (if (looking-at "^ *[`\+\\]?*--+ *\n")
705 (progn
706 (if (= type REBOX_TYPE_OPEN)
707 (setq type REBOX_TYPE_HALF_SINGLE))
708 (replace-match "" t t))
709 (if (looking-at "^ *[`\+\\]?*\\(==+\\|##+\\|;;+\\) *\n")
710 (progn
711 (if (= type REBOX_TYPE_OPEN)
712 (setq type REBOX_TYPE_HALF_DOUBLE))
713 (replace-match "" t t))
714 (if (looking-at "^ *\\*\\*+[.\+\\]? *\n")
715 (progn
716 (setq quality REBOX_QUALITY_STARRED_FOUR)
717 (setq type REBOX_TYPE_HALF_SINGLE)
718 (replace-match "" t t))
719 (if (looking-at "^ *XX+[.\+\\]? *\n")
720 (progn
721 (setq quality REBOX_QUALITY_STARRED_FOUR)
722 (setq type REBOX_TYPE_HALF_DOUBLE)
723 (replace-match "" t t))))))
725 ;; - remove all spurious whitespace
727 (goto-char (point-min))
728 (while (re-search-forward " +$" nil t)
729 (replace-match "" t t))
731 (goto-char (point-min))
732 (if (looking-at "\n+")
733 (replace-match "" t t))
735 (goto-char (point-max))
736 (skip-chars-backward "\n")
737 (if (looking-at "\n\n+")
738 (replace-match "\n" t t))
740 (goto-char (point-min))
741 (while (re-search-forward "\n\n\n+" nil t)
742 (replace-match "\n\n" t t))
744 ;; - move the text left is adequate
746 (setq actual-margin (rebox-left-margin))
747 (if (not (= previous-margin actual-margin))
748 (indent-rigidly (point-min) (point-max)
749 (- previous-margin actual-margin))))
751 ;; Override box style according to FLAG or chosen default style.
752 ;; Else, use either recognized style elements or built-in defaults.
754 (cond ((and (numberp flag) (not (zerop (/ flag 100))))
755 (setq language (* (/ flag 100) 100)))
756 ((not (zerop (/ rebox-default-style 100)))
757 (setq language (* (/ rebox-default-style 100) 100))))
759 (cond ((and (numberp flag) (not (zerop (% (/ flag 10) 10))))
760 (setq quality (* (% (/ flag 10) 10) 10)))
761 ((not (zerop (% (/ rebox-default-style 10) 10)))
762 (setq quality (* (% (/ rebox-default-style 10) 10) 10)))
763 ((zerop quality)
764 (setq quality REBOX_QUALITY_ROUNDED_TWO)))
766 (cond ((and (numberp flag) (not (zerop (% flag 10))))
767 (setq type (% flag 10)))
768 ((not (zerop (% rebox-default-style 10)))
769 (setq type (% rebox-default-style 10)))
770 ((zerop type)
771 (setq type 1)))
773 ;; Possibly refill, then reconstruct the comment box.
775 (let ((indent-tabs-mode nil))
776 (rebox-reconstruct (not (and flag (listp flag)))
777 (rebox-left-margin)
778 language quality type))
780 ;; Retabify to the left only (adapted from tabify.el).
782 (if indent-tabs-mode
783 (progn
784 (goto-char (point-min))
785 (while (re-search-forward "^[ \t][ \t]+" nil t)
786 (let ((column (current-column)))
787 (delete-region (match-beginning 0) (point))
788 (indent-to column)))))
790 ;; Restore the point position.
792 (goto-char (marker-position marked-point))
794 ;; Remove all intermediate boundaries from the undo list.
796 (if (not (eq buffer-undo-list undo-list))
797 (let ((cursor buffer-undo-list))
798 (while (not (eq (cdr cursor) undo-list))
799 (if (car (cdr cursor))
800 (setq cursor (cdr cursor))
801 (rplacd cursor (cdr (cdr cursor)))))))))
803 ;;; Set or reset the Taarna team's own way for a C style. You do not
804 ;;; really want to know about this.
806 (defvar c-mode-taarna-style nil "*Non-nil for Taarna team C-style.")
808 (defun taarna-mode ()
809 (interactive)
810 (if c-mode-taarna-style
811 (progn
813 (setq c-mode-taarna-style nil)
814 (setq c-indent-level 2)
815 (setq c-continued-statement-offset 2)
816 (setq c-brace-offset 0)
817 (setq c-argdecl-indent 5)
818 (setq c-label-offset -2)
819 (setq c-tab-always-indent t)
820 (setq rebox-default-style REBOX_QUALITY_ROUNDED_TWO)
821 (message "C mode: GNU style"))
823 (setq c-mode-taarna-style t)
824 (setq c-indent-level 4)
825 (setq c-continued-statement-offset 4)
826 (setq c-brace-offset -4)
827 (setq c-argdecl-indent 4)
828 (setq c-label-offset -4)
829 (setq c-tab-always-indent t)
830 (setq rebox-default-style
831 (+ REBOX_QUALITY_SIMPLE_ONE REBOX_TYPE_HALF_SINGLE))
832 (message "C mode: Taarna style")))
834 ;;; Rebox the current region.
836 (defun rebox-region (flag)
837 (interactive "P")
838 (if (eq flag '-) (setq flag (rebox-ask-for-style)))
839 (if (rebox-validate-flag flag)
840 (save-restriction
841 (narrow-to-region (region-beginning) (region-end))
842 (rebox-engine flag))))
844 ;;; Rebox the surrounding comment.
846 (defun rebox-comment (flag)
847 (interactive "P")
848 (if (eq flag '-) (setq flag (rebox-ask-for-style)))
849 (if (rebox-validate-flag flag)
850 (save-restriction
851 (rebox-find-and-narrow)
852 (rebox-engine flag))))