Mercurial > hg > xemacs-beta

comparison tests/automated/extent-tests.el @ 468:20ae8821c23d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2001-04-13 09:11:17 by michaels] The Great Trunk Move from release-21-2.
author michaels
date Fri, 13 Apr 2001 09:11:46 +0000
parents
children 189fb67ca31a
comparison
equal deleted inserted replaced
467:13d500863631 468:20ae8821c23d
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)))))