|
468
|
1 ;; Copyright (C) 2001 Free Software Foundation, Inc.
|
|
|
2
|
|
|
3 ;; Author: Hrvoje Niksic <hniksic@xemacs.org>
|
|
|
4 ;; Maintainer: Hrvoje Niksic <hniksic@xemacs.org>
|
|
|
5 ;; Created: 1999
|
|
|
6 ;; Keywords: tests
|
|
|
7
|
|
|
8 ;; This file is part of XEmacs.
|
|
|
9
|
|
|
10 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
11 ;; under the terms of the GNU General Public License as published by
|
|
|
12 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
13 ;; any later version.
|
|
|
14
|
|
|
15 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
18 ;; General Public License for more details.
|
|
|
19
|
|
|
20 ;; You should have received a copy of the GNU General Public License
|
|
|
21 ;; along with XEmacs; see the file COPYING. If not, write to the Free
|
|
|
22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
|
|
23 ;; 02111-1307, USA.
|
|
|
24
|
|
|
25 ;;; Synched up with: Not in FSF.
|
|
|
26
|
|
|
27 ;;; Commentary:
|
|
|
28
|
|
|
29 ;; Test extents operations.
|
|
|
30 ;; See test-harness.el for instructions on how to run these tests.
|
|
|
31
|
|
|
32 (eval-when-compile
|
|
|
33 (condition-case nil
|
|
|
34 (require 'test-harness)
|
|
|
35 (file-error
|
|
|
36 (push "." load-path)
|
|
|
37 (when (and (boundp 'load-file-name) (stringp load-file-name))
|
|
|
38 (push (file-name-directory load-file-name) load-path))
|
|
|
39 (require 'test-harness))))
|
|
|
40
|
|
|
41
|
|
|
42 ;;-----------------------------------------------------
|
|
|
43 ;; Creating and attaching.
|
|
|
44 ;;-----------------------------------------------------
|
|
|
45
|
|
|
46 (with-temp-buffer
|
|
|
47 (let ((extent (make-extent nil nil))
|
|
|
48 (string "somecoolstring"))
|
|
|
49
|
|
|
50 ;; Detached extent.
|
|
|
51 (Assert (extent-detached-p extent))
|
|
|
52
|
|
|
53 ;; Put it in a buffer.
|
|
|
54 (set-extent-endpoints extent 1 1 (current-buffer))
|
|
|
55 (Assert (eq (extent-object extent) (current-buffer)))
|
|
|
56
|
|
|
57 ;; And then into another buffer.
|
|
|
58 (with-temp-buffer
|
|
|
59 (set-extent-endpoints extent 1 1 (current-buffer))
|
|
|
60 (Assert (eq (extent-object extent) (current-buffer))))
|
|
|
61
|
|
|
62 ;; Now that the buffer doesn't exist, extent should be detached
|
|
|
63 ;; again.
|
|
|
64 (Assert (extent-detached-p extent))
|
|
|
65
|
|
|
66 ;; This line crashes XEmacs 21.2.46 and prior.
|
|
|
67 (set-extent-endpoints extent 1 (length string) string)
|
|
|
68 (Assert (eq (extent-object extent) string))
|
|
|
69 )
|
|
|
70
|
|
|
71 (let ((extent (make-extent 1 1)))
|
|
|
72 ;; By default, extent should be closed-open
|
|
|
73 (Assert (eq (get extent 'start-closed) t))
|
|
|
74 (Assert (eq (get extent 'start-open) nil))
|
|
|
75 (Assert (eq (get extent 'end-open) t))
|
|
|
76 (Assert (eq (get extent 'end-closed) nil))
|
|
|
77
|
|
|
78 ;; Make it closed-closed.
|
|
|
79 (set-extent-property extent 'end-closed t)
|
|
|
80
|
|
|
81 (Assert (eq (get extent 'start-closed) t))
|
|
|
82 (Assert (eq (get extent 'start-open) nil))
|
|
|
83 (Assert (eq (get extent 'end-open) nil))
|
|
|
84 (Assert (eq (get extent 'end-closed) t))
|
|
|
85
|
|
|
86 ;; open-closed
|
|
|
87 (set-extent-property extent 'start-open t)
|
|
|
88
|
|
|
89 (Assert (eq (get extent 'start-closed) nil))
|
|
|
90 (Assert (eq (get extent 'start-open) t))
|
|
|
91 (Assert (eq (get extent 'end-open) nil))
|
|
|
92 (Assert (eq (get extent 'end-closed) t))
|
|
|
93
|
|
|
94 ;; open-open
|
|
|
95 (set-extent-property extent 'end-open t)
|
|
|
96
|
|
|
97 (Assert (eq (get extent 'start-closed) nil))
|
|
|
98 (Assert (eq (get extent 'start-open) t))
|
|
|
99 (Assert (eq (get extent 'end-open) t))
|
|
|
100 (Assert (eq (get extent 'end-closed) nil)))
|
|
|
101
|
|
|
102 )
|
|
|
103
|
|
|
104 ;;-----------------------------------------------------
|
|
|
105 ;; Insertion behavior.
|
|
|
106 ;;-----------------------------------------------------
|
|
|
107
|
|
|
108 (defun et-range (extent)
|
|
|
109 "List (START-POSITION END-POSITION) of EXTENT."
|
|
|
110 (list (extent-start-position extent)
|
|
|
111 (extent-end-position extent)))
|
|
|
112
|
|
|
113 (defun et-insert-at (string position)
|
|
|
114 "Insert STRING at POSITION in the current buffer."
|
|
|
115 (save-excursion
|
|
|
116 (goto-char position)
|
|
|
117 (insert string)))
|
|
|
118
|
|
|
119 ;; Test insertion at the beginning, middle, and end of the extent.
|
|
|
120
|
|
|
121 ;; closed-open
|
|
|
122
|
|
|
123 (with-temp-buffer
|
|
|
124 (insert "###eee###")
|
|
|
125 (let ((e (make-extent 4 7)))
|
|
|
126 ;; current state: "###[eee)###"
|
|
|
127 ;; 123 456 789
|
|
|
128 (Assert (equal (et-range e) '(4 7)))
|
|
|
129
|
|
|
130 (et-insert-at "xxx" 4)
|
|
|
131
|
|
|
132 ;; current state: "###[xxxeee)###"
|
|
|
133 ;; 123 456789 012
|
|
|
134 (Assert (equal (et-range e) '(4 10)))
|
|
|
135
|
|
|
136 (et-insert-at "yyy" 7)
|
|
|
137
|
|
|
138 ;; current state: "###[xxxyyyeee)###"
|
|
|
139 ;; 123 456789012 345
|
|
|
140 (Assert (equal (et-range e) '(4 13)))
|
|
|
141
|
|
|
142 (et-insert-at "zzz" 13)
|
|
|
143
|
|
|
144 ;; current state: "###[xxxyyyeee)zzz###"
|
|
|
145 ;; 123 456789012 345678
|
|
|
146 (Assert (equal (et-range e) '(4 13)))
|
|
|
147 ))
|
|
|
148
|
|
|
149 ;; closed-closed
|
|
|
150
|
|
|
151 (with-temp-buffer
|
|
|
152 (insert "###eee###")
|
|
|
153 (let ((e (make-extent 4 7)))
|
|
|
154 (put e 'end-closed t)
|
|
|
155
|
|
|
156 ;; current state: "###[eee]###"
|
|
|
157 ;; 123 456 789
|
|
|
158 (Assert (equal (et-range e) '(4 7)))
|
|
|
159
|
|
|
160 (et-insert-at "xxx" 4)
|
|
|
161
|
|
|
162 ;; current state: "###[xxxeee]###"
|
|
|
163 ;; 123 456789 012
|
|
|
164 (Assert (equal (et-range e) '(4 10)))
|
|
|
165
|
|
|
166 (et-insert-at "yyy" 7)
|
|
|
167
|
|
|
168 ;; current state: "###[xxxyyyeee]###"
|
|
|
169 ;; 123 456789012 345
|
|
|
170 (Assert (equal (et-range e) '(4 13)))
|
|
|
171
|
|
|
172 (et-insert-at "zzz" 13)
|
|
|
173
|
|
|
174 ;; current state: "###[xxxyyyeeezzz]###"
|
|
|
175 ;; 123 456789012345 678
|
|
|
176 (Assert (equal (et-range e) '(4 16)))
|
|
|
177 ))
|
|
|
178
|
|
|
179 ;; open-closed
|
|
|
180
|
|
|
181 (with-temp-buffer
|
|
|
182 (insert "###eee###")
|
|
|
183 (let ((e (make-extent 4 7)))
|
|
|
184 (put e 'start-open t)
|
|
|
185 (put e 'end-closed t)
|
|
|
186
|
|
|
187 ;; current state: "###(eee]###"
|
|
|
188 ;; 123 456 789
|
|
|
189 (Assert (equal (et-range e) '(4 7)))
|
|
|
190
|
|
|
191 (et-insert-at "xxx" 4)
|
|
|
192
|
|
|
193 ;; current state: "###xxx(eee]###"
|
|
|
194 ;; 123456 789 012
|
|
|
195 (Assert (equal (et-range e) '(7 10)))
|
|
|
196
|
|
|
197 (et-insert-at "yyy" 8)
|
|
|
198
|
|
|
199 ;; current state: "###xxx(eyyyee]###"
|
|
|
200 ;; 123456 789012 345
|
|
|
201 (Assert (equal (et-range e) '(7 13)))
|
|
|
202
|
|
|
203 (et-insert-at "zzz" 13)
|
|
|
204
|
|
|
205 ;; current state: "###xxx(eyyyeezzz]###"
|
|
|
206 ;; 123456 789012345 678
|
|
|
207 (Assert (equal (et-range e) '(7 16)))
|
|
|
208 ))
|
|
|
209
|
|
|
210 ;; open-open
|
|
|
211
|
|
|
212 (with-temp-buffer
|
|
|
213 (insert "###eee###")
|
|
|
214 (let ((e (make-extent 4 7)))
|
|
|
215 (put e 'start-open t)
|
|
|
216
|
|
|
217 ;; current state: "###(eee)###"
|
|
|
218 ;; 123 456 789
|
|
|
219 (Assert (equal (et-range e) '(4 7)))
|
|
|
220
|
|
|
221 (et-insert-at "xxx" 4)
|
|
|
222
|
|
|
223 ;; current state: "###xxx(eee)###"
|
|
|
224 ;; 123456 789 012
|
|
|
225 (Assert (equal (et-range e) '(7 10)))
|
|
|
226
|
|
|
227 (et-insert-at "yyy" 8)
|
|
|
228
|
|
|
229 ;; current state: "###xxx(eyyyee)###"
|
|
|
230 ;; 123456 789012 345
|
|
|
231 (Assert (equal (et-range e) '(7 13)))
|
|
|
232
|
|
|
233 (et-insert-at "zzz" 13)
|
|
|
234
|
|
|
235 ;; current state: "###xxx(eyyyee)zzz###"
|
|
|
236 ;; 123456 789012 345678
|
|
|
237 (Assert (equal (et-range e) '(7 13)))
|
|
|
238 ))
|
|
|
239
|
|
|
240
|
|
|
241 ;;-----------------------------------------------------
|
|
|
242 ;; Deletion behavior.
|
|
|
243 ;;-----------------------------------------------------
|
|
|
244
|
|
|
245 (dolist (props '((start-closed t end-open t)
|
|
|
246 (start-closed t end-open nil)
|
|
|
247 (start-closed nil end-open nil)
|
|
|
248 (start-closed nil end-open t)))
|
|
|
249 ;; Deletion needs to behave the same regardless of the open-ness of
|
|
|
250 ;; the boundaries.
|
|
|
251
|
|
|
252 (with-temp-buffer
|
|
|
253 (insert "xxxxxxxxxx")
|
|
|
254 (let ((e (make-extent 3 9)))
|
|
|
255 (set-extent-properties e props)
|
|
|
256
|
|
|
257 ;; current state: xx[xxxxxx]xx
|
|
|
258 ;; 12 345678 90
|
|
|
259 (Assert (equal (et-range e) '(3 9)))
|
|
|
260
|
|
|
261 (delete-region 1 2)
|
|
|
262
|
|
|
263 ;; current state: x[xxxxxx]xx
|
|
|
264 ;; 1 234567 89
|
|
|
265 (Assert (equal (et-range e) '(2 8)))
|
|
|
266
|
|
|
267 (delete-region 2 4)
|
|
|
268
|
|
|
269 ;; current state: x[xxxx]xx
|
|
|
270 ;; 1 2345 67
|
|
|
271 (Assert (equal (et-range e) '(2 6)))
|
|
|
272
|
|
|
273 (delete-region 1 3)
|
|
|
274
|
|
|
275 ;; current state: [xxx]xx
|
|
|
276 ;; 123 45
|
|
|
277 (Assert (equal (et-range e) '(1 4)))
|
|
|
278
|
|
|
279 (delete-region 3 5)
|
|
|
280
|
|
|
281 ;; current state: [xx]x
|
|
|
282 ;; 12 3
|
|
|
283 (Assert (equal (et-range e) '(1 3)))
|
|
|
284
|
|
|
285 )))
|
|
|
286
|
|
|
287 ;;; #### Should have a test for read-only-ness and insertion and
|
|
|
288 ;;; deletion!
|
|
|
289
|
|
|
290 ;;-----------------------------------------------------
|
|
|
291 ;; `detachable' property
|
|
|
292 ;;-----------------------------------------------------
|
|
|
293
|
|
|
294 (dolist (props '((start-closed t end-open t)
|
|
|
295 (start-closed t end-open nil)
|
|
|
296 (start-closed nil end-open nil)
|
|
|
297 (start-closed nil end-open t)))
|
|
|
298 ;; `detachable' shouldn't relate to region properties, hence the
|
|
|
299 ;; loop.
|
|
|
300 (with-temp-buffer
|
|
|
301 (insert "###eee###")
|
|
|
302 (let ((e (make-extent 4 7)))
|
|
|
303 (set-extent-properties e props)
|
|
|
304 (Assert (get e 'detachable))
|
|
|
305
|
|
|
306 (Assert (not (extent-detached-p e)))
|
|
|
307
|
|
|
308 (delete-region 4 5)
|
|
|
309 ;; ###ee### (not detached yet)
|
|
|
310 (Assert (not (extent-detached-p e)))
|
|
|
311
|
|
|
312 (delete-region 4 6)
|
|
|
313 ;; ###### (should be detached now)
|
|
|
314 (Assert (extent-detached-p e))))
|
|
|
315
|
|
|
316 (with-temp-buffer
|
|
|
317 (insert "###eee###")
|
|
|
318 (let ((e (make-extent 4 7)))
|
|
|
319 (set-extent-properties e props)
|
|
|
320 (put e 'detachable nil)
|
|
|
321 (Assert (not (get e 'detachable)))
|
|
|
322
|
|
|
323 (Assert (not (extent-detached-p e)))
|
|
|
324
|
|
|
325 (delete-region 4 5)
|
|
|
326 ;; ###ee###
|
|
|
327 (Assert (not (extent-detached-p e)))
|
|
|
328
|
|
|
329 (delete-region 4 6)
|
|
|
330 ;; ###[]###
|
|
|
331 (Assert (not (extent-detached-p e)))
|
|
|
332 (Assert (equal (et-range e) '(4 4)))
|
|
|
333 ))
|
|
|
334 )
|
|
|
335
|
|
|
336
|
|
|
337 ;;-----------------------------------------------------
|
|
|
338 ;; Zero-length extents.
|
|
|
339 ;;-----------------------------------------------------
|
|
|
340
|
|
|
341 ;; closed-open (should stay put)
|
|
|
342 (with-temp-buffer
|
|
|
343 (insert "######")
|
|
|
344 (let ((e (make-extent 4 4)))
|
|
|
345 (et-insert-at "foo" 4)
|
|
|
346 (Assert (equal (et-range e) '(4 4)))))
|
|
|
347
|
|
|
348 ;; open-closed (should move)
|
|
|
349 (with-temp-buffer
|
|
|
350 (insert "######")
|
|
|
351 (let ((e (make-extent 4 4)))
|
|
|
352 (put e 'start-open t)
|
|
|
353 (put e 'end-closed t)
|
|
|
354 (et-insert-at "foo" 4)
|
|
|
355 (Assert (equal (et-range e) '(7 7)))))
|
|
|
356
|
|
|
357 ;; closed-closed (should extend)
|
|
|
358 (with-temp-buffer
|
|
|
359 (insert "######")
|
|
|
360 (let ((e (make-extent 4 4)))
|
|
|
361 (put e 'end-closed t)
|
|
|
362 (et-insert-at "foo" 4)
|
|
|
363 (Assert (equal (et-range e) '(4 7)))))
|
|
|
364
|
|
|
365 ;; open-open (illegal; forced to behave like closed-open)
|
|
|
366 (with-temp-buffer
|
|
|
367 (insert "######")
|
|
|
368 (let ((e (make-extent 4 4)))
|
|
|
369 (put e 'start-open t)
|
|
|
370 (et-insert-at "foo" 4)
|
|
|
371 (Assert (equal (et-range e) '(4 4)))))
|
