Mercurial > hg > xemacs-beta
annotate lisp/rect.el @ 5798:b94d6e89ea5b
Correct a couple of small things with my last change.
src/ChangeLog addition:
2014-06-18 Aidan Kehoe <kehoea@parhasard.net>
Correct a couple of things in my last change.
* extents.h:
Make #'delete-extent available.
* window.c:
* window.c (delete_saved_point): New.
* window.c (Fdelete_window): Delete the saved point extents on
deletion of the window, since otherwise they will only be
garbage-collected when the buffer is.
* window.c (Fset_window_buffer): Correct a thinko here, use a
saved point when it *hasn't* been detached.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 18 Jun 2014 09:26:54 +0100 |
| parents | 308d34e9f07d |
| children |
| rev | line source |
|---|---|
| 428 | 1 ;;; rect.el --- rectangle functions for XEmacs. |
| 2 | |
| 442 | 3 ;; Copyright (C) 1985-2000 Free Software Foundation, Inc. |
| 428 | 4 |
| 442 | 5 ;; Maintainer: Didier Verna <didier@xemacs.org> |
| 428 | 6 ;; Keywords: internal |
| 7 | |
| 8 ;; This file is part of XEmacs. | |
| 9 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
686
diff
changeset
|
10 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
686
diff
changeset
|
11 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
686
diff
changeset
|
12 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
686
diff
changeset
|
13 ;; option) any later version. |
| 428 | 14 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
686
diff
changeset
|
15 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
686
diff
changeset
|
16 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
686
diff
changeset
|
17 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
686
diff
changeset
|
18 ;; for more details. |
| 428 | 19 |
| 20 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
686
diff
changeset
|
21 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 428 | 22 |
| 23 ;;; Synched up with: to be incorporated in a forthcoming GNU Emacs | |
| 24 | |
| 25 ;;; Commentary: | |
| 26 | |
| 27 ;; This package provides the operations on rectangles that are documented | |
| 28 ;; in the XEmacs Reference Manual. | |
| 29 | |
| 440 | 30 ;; #### NOTE: this file has been almost completely rewritten by Didier Verna |
| 442 | 31 ;; <didier@xemacs.org>, Jul 99. The purpose of this rewrite is to be less |
| 428 | 32 ;; intrusive and fill lines with whitespaces only when needed. A few functions |
| 33 ;; are untouched though, as noted above their definition. | |
| 34 | |
| 35 | |
| 36 ;;; Code: | |
| 37 | |
| 440 | 38 ;; #### NOTE: this function is untouched, but not used anymore. |
| 428 | 39 ;; `apply-on-rectangle' is used instead. It's still there because it's |
| 40 ;; documented so people might use it in their code, so I've decided not to | |
| 41 ;; touch it. --dv | |
| 42 ;; XEmacs: extra-args | |
| 43 (defun operate-on-rectangle (function start end coerce-tabs &rest extra-args) | |
| 44 "Call FUNCTION for each line of rectangle with corners at START, END. | |
| 45 If COERCE-TABS is non-nil, convert multi-column characters | |
| 46 that span the starting or ending columns on any line | |
| 47 to multiple spaces before calling FUNCTION. | |
| 48 FUNCTION is called with three arguments: | |
| 49 position of start of segment of this line within the rectangle, | |
| 50 number of columns that belong to rectangle but are before that position, | |
| 51 number of columns that belong to rectangle but are after point. | |
| 52 Point is at the end of the segment of this line within the rectangle." | |
| 53 (let (startcol startlinepos endcol endlinepos) | |
| 54 (save-excursion | |
| 55 (goto-char start) | |
| 56 (setq startcol (current-column)) | |
| 57 (beginning-of-line) | |
| 58 (setq startlinepos (point))) | |
| 59 (save-excursion | |
| 60 (goto-char end) | |
| 61 (setq endcol (current-column)) | |
| 62 (forward-line 1) | |
| 63 (setq endlinepos (point-marker))) | |
| 64 (if (< endcol startcol) | |
| 65 ;; XEmacs | |
| 66 (let ((tem startcol)) | |
| 67 (setq startcol endcol endcol tem))) | |
| 68 (save-excursion | |
| 69 (goto-char startlinepos) | |
| 70 (while (< (point) endlinepos) | |
| 71 (let (startpos begextra endextra) | |
| 72 (move-to-column startcol coerce-tabs) | |
| 73 (setq begextra (- (current-column) startcol)) | |
| 74 (setq startpos (point)) | |
| 75 (move-to-column endcol coerce-tabs) | |
| 76 (setq endextra (- endcol (current-column))) | |
| 77 (if (< begextra 0) | |
| 78 (setq endextra (+ endextra begextra) | |
| 79 begextra 0)) | |
| 80 (if (< endextra 0) (setq endextra 0)) | |
| 81 (apply function startpos begextra endextra extra-args)) | |
| 82 (forward-line 1))) | |
| 83 (- endcol startcol))) | |
| 84 | |
| 85 ;; The replacement for `operate-on-rectangle' -- dv | |
| 86 (defun apply-on-rectangle (function start end &rest args) | |
| 87 "Call FUNCTION for each line of rectangle with corners at START and END. | |
| 88 FUNCTION is called with two arguments: the start and end columns of the | |
| 89 rectangle, plus ARGS extra arguments. Point is at the beginning of line | |
| 90 when the function is called." | |
| 91 (let (startcol startpt endcol endpt) | |
| 92 (save-excursion | |
| 93 (goto-char start) | |
| 94 (setq startcol (current-column)) | |
| 95 (beginning-of-line) | |
| 96 (setq startpt (point)) | |
| 97 (goto-char end) | |
| 98 (setq endcol (current-column)) | |
| 99 (forward-line 1) | |
| 100 (setq endpt (point-marker)) | |
| 101 ;; ensure the start column is the left one. | |
| 102 (if (< endcol startcol) | |
| 103 (let ((col startcol)) | |
| 104 (setq startcol endcol endcol col))) | |
| 105 ;; start looping over lines | |
| 106 (goto-char startpt) | |
| 107 (while (< (point) endpt) | |
| 108 (apply function startcol endcol args) | |
| 109 (forward-line 1))) | |
| 110 )) | |
| 111 | |
| 112 | |
| 442 | 113 (defun delete-rectangle-line (startcol endcol fill) |
| 114 (let ((pt (point-at-eol))) | |
| 115 (when (= (move-to-column startcol (or fill 'coerce)) startcol) | |
| 116 (if (and (not fill) (<= pt endcol)) | |
| 117 (delete-region (point) pt) | |
| 118 ;; else | |
| 119 (setq pt (point)) | |
| 120 (move-to-column endcol t) | |
| 121 (delete-region pt (point)))) | |
| 122 )) | |
| 428 | 123 |
| 124 ;;;###autoload | |
| 125 (defun delete-rectangle (start end &optional fill) | |
| 126 "Delete the text in the region-rectangle without saving it. | |
| 127 The same range of columns is deleted in each line starting with the line | |
| 128 where the region begins and ending with the line where the region ends. | |
| 129 | |
| 130 When called from a program, the rectangle's corners are START and END. | |
| 131 With a prefix (or FILL) argument, also fill lines where nothing has to be | |
| 132 deleted." | |
| 133 (interactive "*r\nP") | |
| 134 (apply-on-rectangle 'delete-rectangle-line start end fill)) | |
| 135 | |
| 136 | |
| 442 | 137 ;; I love ascii art ;-) |
| 138 (defconst spaces-strings '["" | |
| 139 " " | |
| 140 " " | |
| 141 " " | |
| 142 " " | |
| 143 " " | |
| 144 " " | |
| 145 " " | |
| 146 " "]) | |
| 428 | 147 |
| 442 | 148 ;; This function is untouched --dv |
| 149 (defun spaces-string (n) | |
| 150 (if (<= n 8) (aref spaces-strings n) | |
| 151 (let ((val "")) | |
| 152 (while (> n 8) | |
| 153 (setq val (concat " " val) | |
| 154 n (- n 8))) | |
| 155 (concat val (aref spaces-strings n))))) | |
| 156 | |
| 428 | 157 |
| 158 (defun delete-extract-rectangle-line (startcol endcol lines fill) | |
| 159 (let ((pt (point-at-eol))) | |
| 160 (if (< (move-to-column startcol (or fill 'coerce)) startcol) | |
| 161 (setcdr lines (cons (spaces-string (- endcol startcol)) | |
| 162 (cdr lines))) | |
| 163 ;; else | |
| 164 (setq pt (point)) | |
| 165 (move-to-column endcol t) | |
| 166 (setcdr lines (cons (buffer-substring pt (point)) (cdr lines))) | |
| 167 (delete-region pt (point))) | |
| 168 )) | |
| 169 | |
| 170 ;;;###autoload | |
| 442 | 171 (defun delete-extract-rectangle (start end &optional fill) |
| 172 "Delete the contents of the rectangle with corners at START and END, and | |
| 173 return it as a list of strings, one for each line of the rectangle. | |
| 174 | |
| 175 With an optional FILL argument, also fill lines where nothing has to be | |
| 176 deleted." | |
| 428 | 177 (let ((lines (list nil))) |
| 442 | 178 (apply-on-rectangle 'delete-extract-rectangle-line start end lines fill) |
| 428 | 179 (nreverse (cdr lines)))) |
| 180 | |
| 442 | 181 |
| 440 | 182 ;; #### NOTE: this is actually the only function that needs to do complicated |
| 428 | 183 ;; stuff like what's happening in `operate-on-rectangle', because the buffer |
| 184 ;; might be read-only. --dv | |
| 185 (defun extract-rectangle-line (startcol endcol lines) | |
| 186 (let (start end begextra endextra line) | |
| 187 (move-to-column startcol) | |
| 188 (setq start (point) | |
| 189 begextra (- (current-column) startcol)) | |
| 190 (move-to-column endcol) | |
| 191 (setq end (point) | |
| 192 endextra (- endcol (current-column))) | |
| 193 (setq line (buffer-substring start (point))) | |
| 194 (if (< begextra 0) | |
| 195 (setq endextra (+ endextra begextra) | |
| 196 begextra 0)) | |
| 197 (if (< endextra 0) | |
| 198 (setq endextra 0)) | |
| 199 (goto-char start) | |
| 200 (while (search-forward "\t" end t) | |
| 201 (let ((width (- (current-column) | |
| 446 | 202 (save-excursion (backward-char 1) |
| 428 | 203 (current-column))))) |
| 204 (setq line (concat (substring line 0 (- (point) end 1)) | |
| 205 (spaces-string width) | |
| 206 (substring line (+ (length line) | |
| 207 (- (point) end))))))) | |
| 208 (if (or (> begextra 0) (> endextra 0)) | |
| 209 (setq line (concat (spaces-string begextra) | |
| 210 line | |
| 211 (spaces-string endextra)))) | |
| 212 (setcdr lines (cons line (cdr lines))))) | |
| 213 | |
| 442 | 214 ;;;###autoload |
| 215 (defun extract-rectangle (start end) | |
| 216 "Return the contents of the rectangle with corners at START and END, | |
| 217 as a list of strings, one for each line of the rectangle." | |
| 218 (let ((lines (list nil))) | |
| 219 (apply-on-rectangle 'extract-rectangle-line start end lines) | |
| 220 (nreverse (cdr lines)))) | |
| 221 | |
| 222 | |
| 223 ;;;###autoload | |
| 224 (defvar killed-rectangle nil | |
| 225 "Rectangle for `yank-rectangle' to insert.") | |
| 226 | |
| 227 ;;;###autoload | |
| 228 (defun kill-rectangle (start end &optional fill) | |
| 229 "Delete the region-rectangle and save it as the last killed one. | |
| 230 You might prefer to use `delete-extract-rectangle' from a program. | |
| 231 | |
| 232 When called from a program, the rectangle's corners are START and END. | |
| 233 With a prefix (or FILL) argument, also fill lines where nothing has to be | |
| 234 deleted." | |
| 235 (interactive "*r\nP") | |
| 236 (when buffer-read-only | |
| 237 (setq killed-rectangle (extract-rectangle start end)) | |
| 238 (barf-if-buffer-read-only)) | |
| 239 (setq killed-rectangle (delete-extract-rectangle start end fill))) | |
| 240 | |
| 428 | 241 ;; This function is untouched --dv |
| 242 ;;;###autoload | |
| 243 (defun yank-rectangle () | |
| 244 "Yank the last killed rectangle with upper left corner at point." | |
| 245 (interactive "*") | |
| 246 (insert-rectangle killed-rectangle)) | |
| 247 | |
| 442 | 248 |
| 428 | 249 ;; This function is untouched --dv |
| 250 ;;;###autoload | |
| 251 (defun insert-rectangle (rectangle) | |
| 252 "Insert text of RECTANGLE with upper left corner at point. | |
| 253 RECTANGLE's first line is inserted at point, its second | |
| 254 line is inserted at a point vertically under point, etc. | |
| 255 RECTANGLE should be a list of strings. | |
| 256 After this command, the mark is at the upper left corner | |
| 257 and point is at the lower right corner." | |
| 258 (let ((lines rectangle) | |
| 259 (insertcolumn (current-column)) | |
| 260 (first t)) | |
| 261 (push-mark) | |
| 262 (while lines | |
| 263 (or first | |
| 264 (progn | |
| 265 (forward-line 1) | |
| 266 (or (bolp) (insert ?\n)) | |
| 267 (move-to-column insertcolumn t))) | |
| 268 (setq first nil) | |
| 269 (insert (car lines)) | |
| 270 (setq lines (cdr lines))))) | |
| 271 | |
| 442 | 272 |
| 273 (defun open-rectangle-line (startcol endcol fill) | |
| 274 (when (= (move-to-column startcol (or fill 'coerce)) startcol) | |
| 275 (unless (and (not fill) | |
| 276 (= (point) (point-at-eol))) | |
| 277 (indent-to endcol)))) | |
| 278 | |
| 428 | 279 ;;;###autoload |
| 280 (defun open-rectangle (start end &optional fill) | |
| 281 "Blank out the region-rectangle, shifting text right. | |
| 282 | |
| 283 When called from a program, the rectangle's corners are START and END. | |
| 284 With a prefix (or FILL) argument, fill with blanks even if there is no text | |
| 285 on the right side of the rectangle." | |
| 286 (interactive "*r\nP") | |
| 287 (apply-on-rectangle 'open-rectangle-line start end fill) | |
| 288 (goto-char start)) | |
| 289 | |
| 442 | 290 |
| 291 (defun string-rectangle-line (startcol endcol string delete) | |
| 292 (move-to-column startcol t) | |
| 293 (if delete | |
| 294 (delete-rectangle-line startcol endcol nil)) | |
| 295 (insert string)) | |
| 428 | 296 |
| 297 ;;;###autoload | |
| 298 (defun string-rectangle (start end string) | |
| 299 "Insert STRING on each line of the region-rectangle, shifting text right. | |
| 442 | 300 The left edge of the rectangle specifies the column for insertion. |
| 301 | |
| 302 If `pending-delete-mode' is active the string replace the region. | |
| 303 Otherwise this command does not delete or overwrite any existing text. | |
| 428 | 304 |
| 305 When called from a program, the rectangle's corners are START and END." | |
| 306 (interactive "*r\nsString rectangle: ") | |
| 442 | 307 (defvar pending-delete-mode) |
| 308 (apply-on-rectangle 'string-rectangle-line start end string | |
| 309 (and (boundp 'pending-delete-mode) pending-delete-mode))) | |
| 428 | 310 |
| 686 | 311 ;;;###autoload |
| 442 | 312 (defun replace-rectangle (start end string) |
| 313 "Like `string-rectangle', but unconditionally replace the original region, | |
| 314 as if `pending-delete-mode' were active." | |
| 315 (interactive "*r\nsString rectangle: ") | |
| 316 (apply-on-rectangle 'string-rectangle-line start end string t)) | |
| 428 | 317 |
| 318 | |
| 319 (defun clear-rectangle-line (startcol endcol fill) | |
| 320 (let ((pt (point-at-eol)) | |
| 321 spaces) | |
| 322 (when (= (move-to-column startcol (or fill 'coerce)) startcol) | |
| 323 (if (and (not fill) | |
| 324 (<= (save-excursion (goto-char pt) (current-column)) endcol)) | |
| 325 (delete-region (point) pt) | |
| 326 ;; else | |
| 327 (setq pt (point)) | |
| 328 (move-to-column endcol t) | |
| 329 (setq spaces (- (point) pt)) | |
| 330 (delete-region pt (point)) | |
| 331 (indent-to (+ (current-column) spaces)))) | |
| 332 )) | |
| 333 | |
| 442 | 334 ;;;###autoload |
| 335 (defun clear-rectangle (start end &optional fill) | |
| 336 "Blank out the region-rectangle. | |
| 337 The text previously in the region is overwritten with blanks. | |
| 338 | |
| 339 When called from a program, the rectangle's corners are START and END. | |
| 340 With a prefix (or FILL) argument, also fill with blanks the parts of the | |
| 341 rectangle which were empty." | |
| 342 (interactive "*r\nP") | |
| 343 (apply-on-rectangle 'clear-rectangle-line start end fill)) | |
| 344 | |
| 345 | |
| 428 | 346 (provide 'rect) |
| 347 | |
| 348 ;;; rect.el ends here |