Mercurial > hg > xemacs-beta

comparison lisp/packages/file-part.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 0293115a14e9
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; file-part.el --- treat a section of a buffer as a separate file
2
3 ;; Keywords: extensions, tools
4
5 ;; Copyright (C) 1992-1993 Sun Microsystems.
6
7 ;; This file is part of XEmacs.
8
9 ;; XEmacs is free software; you can redistribute it and/or modify it
10 ;; under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
12 ;; any later version.
13
14 ;; XEmacs is distributed in the hope that it will be useful, but
15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 ;; General Public License for more details.
18
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with XEmacs; see the file COPYING. If not, write to the Free
21 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
22
23 ;;; Synched up with: Not in FSF.
24
25 ;; Written by Ben Wing.
26
27 (provide 'file-part)
28
29 (define-error 'file-part-error "File part error" 'file-error)
30
31 (defvar file-part-extent-alist nil
32 "Alist of file parts in the current buffer.
33 Each element of the alist maps an extent describing the file part
34 to the buffer containing the file part. DON'T MODIFY THIS.")
35 (make-variable-buffer-local 'file-part-extent-alist)
36 (setq-default file-part-extent-alist nil)
37
38 (defvar file-part-master-extent nil
39 "Extent this file part refers to in the master buffer.
40 NIL if this buffer is not a file part. The master buffer itself
41 can be found by calling `extent-buffer' on this extent.
42 DON'T MODIFY THIS.")
43 (make-variable-buffer-local 'file-part-master-extent)
44 (setq-default file-part-master-extent nil)
45
46 (or (assq 'file-part-master-extent minor-mode-alist)
47 (setq minor-mode-alist
48 (cons minor-mode-alist
49 '((file-part-master-extent " File-part")))))
50
51 ; apply a function to each element of a list and return true if
52 ; any of the functions returns true.
53 (defun file-part-maptrue (fn list)
54 (cond ((null list) nil)
55 ((funcall fn (car list)))
56 (t (file-part-maptrue fn (cdr list)))))
57
58 ; return a buffer to operate on. If NIL is specified, this is the
59 ; current buffer. If a string is specified, this is the buffer with
60 ; that name.
61 (defun file-part-buffer-from-arg (arg)
62 (get-buffer (or arg (current-buffer))))
63
64 ;;;###autoload
65 (defun make-file-part (&optional start end name buffer)
66 "Make a file part on buffer BUFFER out of the region. Call it NAME.
67 This command creates a new buffer containing the contents of the
68 region and marks the buffer as referring to the specified buffer,
69 called the `master buffer'. When the file-part buffer is saved,
70 its changes are integrated back into the master buffer. When the
71 master buffer is deleted, all file parts are deleted with it.
72
73 When called from a function, expects four arguments, START, END,
74 NAME, and BUFFER, all of which are optional and default to the
75 beginning of BUFFER, the end of BUFFER, a name generated from
76 BUFFER's name, and the current buffer, respectively."
77 (interactive "r\nsName of file part: ")
78 (setq buffer (file-part-buffer-from-arg buffer))
79 (if (null start) (setq start (point-min)))
80 (if (null end) (setq end (point-max)))
81 (if (null name) (setq name (concat (buffer-name buffer) "-part")))
82 (if (> start end) nil
83 (set-buffer buffer)
84 (make-local-variable 'write-contents-hooks)
85 (make-local-variable 'kill-buffer-hook)
86 (make-local-variable 'revert-buffer-function)
87 (add-hook 'write-contents-hooks 'write-master-buffer-hook)
88 (add-hook 'kill-buffer-hook 'kill-master-buffer-hook)
89 (setq revert-buffer-function 'revert-master-buffer-function)
90 (if (file-part-maptrue (function (lambda (x)
91 (let ((b (extent-start-position (car x)))
92 (e (extent-end-position (car x))))
93 (and
94 (numberp b)
95 (numberp e)
96 (not (or (and (<= b start) (<= e start))
97 (and (>= b end) (>= e end))))))))
98 file-part-extent-alist)
99 (signal 'file-part-error (list "Overlapping file parts not allowed"
100 buffer))
101 (let ((x (make-extent start end))
102 (filebuf (generate-new-buffer name)))
103 (set-extent-property x 'read-only t)
104 (setq file-part-extent-alist
105 (cons (cons x filebuf) file-part-extent-alist))
106 (switch-to-buffer filebuf)
107 (setq buffer-file-name (concat "File part on " (buffer-name buffer)))
108 (make-local-variable 'write-file-hooks)
109 (make-local-variable 'kill-buffer-hook)
110 (make-local-variable 'revert-buffer-function)
111 (make-local-variable 'first-change-hook)
112 (add-hook 'write-file-hooks 'write-file-part-hook)
113 (add-hook 'kill-buffer-hook 'kill-file-part-hook)
114 (setq revert-buffer-function 'revert-file-part-function)
115 (setq file-part-master-extent x)
116 (insert-buffer-substring buffer start end)
117 ; do this after inserting the text so the master buffer isn't marked as
118 ; modified.
119 (add-hook 'first-change-hook 'file-part-first-change-hook)
120 (set-buffer-modified-p nil)
121 filebuf))))
122
123 (defun kill-file-part-hook ()
124 "Hook to be called when a file-part buffer is killed.
125 Removes the file part from the master buffer's list of file parts."
126 (let ((x file-part-master-extent)
127 (buf (current-buffer)))
128 (if x (save-excursion
129 (set-buffer (extent-buffer x))
130 (setq file-part-extent-alist
131 (delete (cons x buf) file-part-extent-alist))
132 (delete-extent x)))))
133
134 (defun kill-all-file-parts (&optional bufname no-ask)
135 "Kill all file parts on buffer BUFNAME.
136 The argument may be a buffer or the name of a buffer.
137 If one or more of the file parts needs saving, prompts for
138 confirmation unless optional second argument NO-ASK is non-nil.
139 BUFFER defaults to the current buffer if not specified."
140 (interactive "b")
141 (setq bufname (file-part-buffer-from-arg bufname))
142 (save-excursion
143 (set-buffer bufname)
144 (and (or no-ask
145 (not (file-parts-modified-p bufname))
146 (y-or-n-p "Buffer has modified file parts; kill anyway? "))
147 (mapcar (function (lambda (x)
148 (set-buffer (cdr x))
149 (set-buffer-modified-p nil)
150 (kill-buffer (cdr x))))
151 file-part-extent-alist))))
152
153 (defun kill-master-buffer-hook ()
154 "Hook to be called when a master buffer is killed.
155 Kills the associated file parts."
156 (kill-all-file-parts (current-buffer) t))
157
158 (defun file-part-check-attached (x)
159 (cond ((null x) nil)
160 ((extent-property x 'detached)
161 (kill-file-part-hook)
162 (setq buffer-file-name nil)
163 (setq file-part-master-extent nil)
164 (message "File part has become detached.")
165 nil)
166 (t)))
167
168 (defun write-file-part-hook ()
169 "Hook to be called when a file part is saved.
170 Saves the file part into the master buffer."
171 (let ((x file-part-master-extent)
172 (buf (current-buffer))
173 (len (- (point-max) (point-min)))
174 (retval (not (null file-part-master-extent))))
175 (and (file-part-check-attached x)
176 (let ((b (extent-start-position x))
177 (e (extent-end-position x)))
178 (save-excursion
179 (set-buffer (extent-buffer x))
180 (set-extent-property x 'read-only nil)
181 (goto-char b)
182 (insert-buffer-substring buf)
183 (delete-region (+ len b) (+ len e))
184 (set-extent-property x 'read-only t)
185 (set-buffer buf)
186 (set-buffer-modified-p nil)
187 (message (format "Wrote file part %s on %s"
188 (buffer-name buf)
189 (buffer-name (extent-buffer x))))
190 t)))
191 retval))
192
193 (defun write-master-buffer-hook ()
194 "Hook to be called when a master buffer is saved.
195 If there are modified file parts on the buffer, optionally
196 saves the file parts back into the buffer."
197 (save-some-file-part-buffers)
198 nil)
199
200 (defun save-some-file-part-buffers (&optional arg buffer)
201 "Save some modified file-part buffers on BUFFER. Asks user about each one.
202 Optional argument (the prefix) non-nil means save all with no questions.
203 BUFFER defaults to the current buffer if not specified."
204 (interactive "p")
205 (setq buffer (file-part-buffer-from-arg buffer))
206 (let ((alist file-part-extent-alist)
207 (name (buffer-name buffer)))
208 (while alist
209 (let ((buf (cdr (car alist))))
210 (and (buffer-modified-p buf)
211 (or arg
212 (y-or-n-p (format "Save file part %s on %s? "
213 (buffer-name buf) (buffer-name buffer))))
214 (condition-case ()
215 (save-excursion
216 (set-buffer buf)
217 (save-buffer))
218 (error nil))))
219 (setq alist (cdr alist)))))
220
221 (defun file-parts-modified-p (&optional buffer)
222 "Return true if BUFFER has any modified file parts on it.
223 BUFFER defaults to the current buffer if not specified."
224 (save-excursion
225 (and buffer (set-buffer buffer))
226 (file-part-maptrue (function (lambda (x) (buffer-modified-p (cdr x))))
227 file-part-extent-alist)))
228
229 (defun revert-file-part-function (&optional check-auto noconfirm)
230 "Hook to be called when a file part is reverted.
231 Reverts the file part from the master buffer."
232 (let ((x file-part-master-extent))
233 (and (file-part-check-attached x)
234 (let ((master (extent-buffer x)))
235 (and
236 (or noconfirm
237 (yes-or-no-p
238 (format
239 "Revert file part from master buffer %s? "
240 (buffer-name master))))
241 (progn
242 (erase-buffer)
243 (let ((mod (buffer-modified-p master)))
244 (insert-buffer-substring master
245 (extent-start-position x)
246 (extent-end-position x))
247 (set-buffer-modified-p nil)
248 (save-excursion
249 (set-buffer master)
250 (set-buffer-modified-p mod)))))))))
251
252 (defun revert-master-buffer-function (&optional check-auto noconfirm)
253 "Hook to be called when a master-buffer is reverted.
254 Makes sure the user is aware that the file parts will become detached,
255 then proceeds as normal."
256 (or noconfirm
257 (null file-part-extent-alist)
258 (progn
259 (message "Warning: file parts will become detached.")
260 (sleep-for 2)))
261 (let ((revert-buffer-function nil))
262 (revert-buffer (not check-auto) noconfirm)))
263
264 (defun file-part-first-change-hook ()
265 "Hook to be called when a file part is first modified.
266 Marks the master buffer as modified."
267 (let ((x file-part-master-extent))
268 (and (file-part-check-attached x)
269 (save-excursion
270 (set-buffer (extent-buffer x))
271 (set-buffer-modified-p t)))))
272