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

Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 0293115a14e9
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/packages/file-part.el	Mon Aug 13 08:45:50 2007 +0200
@@ -0,0 +1,272 @@
+;;; file-part.el --- treat a section of a buffer as a separate file
+
+;; Keywords: extensions, tools
+
+;; Copyright (C) 1992-1993 Sun Microsystems.
+
+;; This file is part of XEmacs.
+
+;; XEmacs is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XEmacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs; see the file COPYING.  If not, write to the Free
+;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Synched up with: Not in FSF.
+
+;; Written by Ben Wing.
+
+(provide 'file-part)
+
+(define-error 'file-part-error "File part error" 'file-error)
+
+(defvar file-part-extent-alist nil
+  "Alist of file parts in the current buffer.
+Each element of the alist maps an extent describing the file part
+to the buffer containing the file part.  DON'T MODIFY THIS.")
+(make-variable-buffer-local 'file-part-extent-alist)
+(setq-default file-part-extent-alist nil)
+
+(defvar file-part-master-extent nil
+  "Extent this file part refers to in the master buffer.
+NIL if this buffer is not a file part.  The master buffer itself
+can be found by calling `extent-buffer' on this extent.
+DON'T MODIFY THIS.")
+(make-variable-buffer-local 'file-part-master-extent)
+(setq-default file-part-master-extent nil)
+
+(or (assq 'file-part-master-extent minor-mode-alist)
+    (setq minor-mode-alist
+	  (cons minor-mode-alist
+		'((file-part-master-extent " File-part")))))
+
+; apply a function to each element of a list and return true if
+; any of the functions returns true.
+(defun file-part-maptrue (fn list)
+  (cond ((null list) nil)
+	((funcall fn (car list)))
+	(t (file-part-maptrue fn (cdr list)))))
+
+; return a buffer to operate on.  If NIL is specified, this is the
+; current buffer.  If a string is specified, this is the buffer with
+; that name.
+(defun file-part-buffer-from-arg (arg)
+  (get-buffer (or arg (current-buffer))))
+
+;;;###autoload
+(defun make-file-part (&optional start end name buffer)
+  "Make a file part on buffer BUFFER out of the region.  Call it NAME.
+This command creates a new buffer containing the contents of the
+region and marks the buffer as referring to the specified buffer,
+called the `master buffer'.  When the file-part buffer is saved,
+its changes are integrated back into the master buffer.  When the
+master buffer is deleted, all file parts are deleted with it.
+
+When called from a function, expects four arguments, START, END,
+NAME, and BUFFER, all of which are optional and default to the
+beginning of BUFFER, the end of BUFFER, a name generated from
+BUFFER's name, and the current buffer, respectively."
+  (interactive "r\nsName of file part: ")
+  (setq buffer (file-part-buffer-from-arg buffer))
+  (if (null start) (setq start (point-min)))
+  (if (null end) (setq end (point-max)))
+  (if (null name) (setq name (concat (buffer-name buffer) "-part")))
+  (if (> start end) nil
+    (set-buffer buffer)
+    (make-local-variable 'write-contents-hooks)
+    (make-local-variable 'kill-buffer-hook)
+    (make-local-variable 'revert-buffer-function)
+    (add-hook 'write-contents-hooks 'write-master-buffer-hook)
+    (add-hook 'kill-buffer-hook 'kill-master-buffer-hook)
+    (setq revert-buffer-function 'revert-master-buffer-function)
+    (if (file-part-maptrue (function (lambda (x)
+			     (let ((b (extent-start-position (car x)))
+				   (e (extent-end-position (car x))))
+			       (and
+				(numberp b)
+				(numberp e)
+				(not (or (and (<= b start) (<= e start))
+					 (and (>= b end) (>= e end))))))))
+		 file-part-extent-alist)
+	(signal 'file-part-error (list "Overlapping file parts not allowed"
+				       buffer))
+      (let ((x (make-extent start end))
+ 	    (filebuf (generate-new-buffer name)))
+	(set-extent-property x 'read-only t)
+	(setq file-part-extent-alist
+	      (cons (cons x filebuf) file-part-extent-alist))
+	(switch-to-buffer filebuf)
+        (setq buffer-file-name (concat "File part on " (buffer-name buffer)))
+        (make-local-variable 'write-file-hooks)
+        (make-local-variable 'kill-buffer-hook)
+	(make-local-variable 'revert-buffer-function)
+	(make-local-variable 'first-change-hook)
+        (add-hook 'write-file-hooks 'write-file-part-hook)
+        (add-hook 'kill-buffer-hook 'kill-file-part-hook)
+	(setq revert-buffer-function 'revert-file-part-function)
+	(setq file-part-master-extent x)
+	(insert-buffer-substring buffer start end)
+	; do this after inserting the text so the master buffer isn't marked as
+	; modified.
+	(add-hook 'first-change-hook 'file-part-first-change-hook)
+        (set-buffer-modified-p nil)
+	filebuf))))
+
+(defun kill-file-part-hook ()
+  "Hook to be called when a file-part buffer is killed.
+Removes the file part from the master buffer's list of file parts."
+  (let ((x file-part-master-extent)
+	(buf (current-buffer)))
+    (if x (save-excursion
+	    (set-buffer (extent-buffer x))
+	    (setq file-part-extent-alist
+		  (delete (cons x buf) file-part-extent-alist))
+	    (delete-extent x)))))
+
+(defun kill-all-file-parts (&optional bufname no-ask)
+  "Kill all file parts on buffer BUFNAME.
+The argument may be a buffer or the name of a buffer.
+If one or more of the file parts needs saving, prompts for
+confirmation unless optional second argument NO-ASK is non-nil.
+BUFFER defaults to the current buffer if not specified."
+  (interactive "b")
+  (setq bufname (file-part-buffer-from-arg bufname))
+  (save-excursion
+    (set-buffer bufname)
+    (and (or no-ask
+	     (not (file-parts-modified-p bufname))
+	     (y-or-n-p "Buffer has modified file parts; kill anyway? "))
+	 (mapcar (function (lambda (x)
+			     (set-buffer (cdr x))
+			     (set-buffer-modified-p nil)
+			     (kill-buffer (cdr x))))
+		 file-part-extent-alist))))
+
+(defun kill-master-buffer-hook ()
+  "Hook to be called when a master buffer is killed.
+Kills the associated file parts."
+  (kill-all-file-parts (current-buffer) t))
+
+(defun file-part-check-attached (x)
+  (cond ((null x) nil)
+	((extent-property x 'detached)
+	 (kill-file-part-hook)
+	 (setq buffer-file-name nil)
+	 (setq file-part-master-extent nil)
+	 (message "File part has become detached.")
+	 nil)
+	(t)))
+
+(defun write-file-part-hook ()
+  "Hook to be called when a file part is saved.
+Saves the file part into the master buffer."
+  (let ((x file-part-master-extent)
+	(buf (current-buffer))
+	(len (- (point-max) (point-min)))
+	(retval (not (null file-part-master-extent))))
+    (and (file-part-check-attached x)
+	 (let ((b (extent-start-position x))
+	       (e (extent-end-position x)))
+	   (save-excursion
+	     (set-buffer (extent-buffer x))
+	     (set-extent-property x 'read-only nil)
+	     (goto-char b)
+	     (insert-buffer-substring buf)
+	     (delete-region (+ len b) (+ len e))
+	     (set-extent-property x 'read-only t)
+	     (set-buffer buf)
+	     (set-buffer-modified-p nil)
+	     (message (format "Wrote file part %s on %s"
+			      (buffer-name buf)
+			      (buffer-name (extent-buffer x))))
+	     t)))
+    retval))
+
+(defun write-master-buffer-hook ()
+  "Hook to be called when a master buffer is saved.
+If there are modified file parts on the buffer, optionally
+saves the file parts back into the buffer."
+  (save-some-file-part-buffers)
+  nil)
+
+(defun save-some-file-part-buffers (&optional arg buffer)
+  "Save some modified file-part buffers on BUFFER.  Asks user about each one.
+Optional argument (the prefix) non-nil means save all with no questions.
+BUFFER defaults to the current buffer if not specified."
+  (interactive "p")
+  (setq buffer (file-part-buffer-from-arg buffer))
+  (let ((alist file-part-extent-alist)
+	(name (buffer-name buffer)))
+    (while alist
+      (let ((buf (cdr (car alist))))
+	(and (buffer-modified-p buf)
+	     (or arg
+		 (y-or-n-p (format "Save file part %s on %s? "
+				   (buffer-name buf) (buffer-name buffer))))
+	     (condition-case ()
+		 (save-excursion
+		   (set-buffer buf)
+		   (save-buffer))
+	       (error nil))))
+      (setq alist (cdr alist)))))
+
+(defun file-parts-modified-p (&optional buffer)
+  "Return true if BUFFER has any modified file parts on it.
+BUFFER defaults to the current buffer if not specified."
+  (save-excursion
+    (and buffer (set-buffer buffer))
+    (file-part-maptrue (function (lambda (x) (buffer-modified-p (cdr x))))
+		       file-part-extent-alist)))
+
+(defun revert-file-part-function (&optional check-auto noconfirm)
+  "Hook to be called when a file part is reverted.
+Reverts the file part from the master buffer."
+  (let ((x file-part-master-extent))
+    (and (file-part-check-attached x)
+	 (let ((master (extent-buffer x)))
+	   (and
+	    (or noconfirm
+		(yes-or-no-p
+		 (format
+		  "Revert file part from master buffer %s? "
+		  (buffer-name master))))
+	    (progn
+	      (erase-buffer)
+	      (let ((mod (buffer-modified-p master)))
+		(insert-buffer-substring master
+					 (extent-start-position x)
+					 (extent-end-position x))
+		(set-buffer-modified-p nil)
+		(save-excursion
+		  (set-buffer master)
+		  (set-buffer-modified-p mod)))))))))
+
+(defun revert-master-buffer-function (&optional check-auto noconfirm)
+  "Hook to be called when a master-buffer is reverted.
+Makes sure the user is aware that the file parts will become detached,
+then proceeds as normal."
+  (or noconfirm
+      (null file-part-extent-alist)
+      (progn
+	(message "Warning: file parts will become detached.")
+	(sleep-for 2)))
+  (let ((revert-buffer-function nil))
+    (revert-buffer (not check-auto) noconfirm)))
+
+(defun file-part-first-change-hook ()
+  "Hook to be called when a file part is first modified.
+Marks the master buffer as modified."
+  (let ((x file-part-master-extent))
+    (and (file-part-check-attached x)
+	 (save-excursion
+	   (set-buffer (extent-buffer x))
+	   (set-buffer-modified-p t)))))
+