/[cmucl]/src/hemlock/group.lisp
ViewVC logotype

Contents of /src/hemlock/group.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.3 - (hide annotations) (vendor branch)
Wed Aug 25 02:08:50 1993 UTC (20 years, 7 months ago) by ram
Changes since 1.1.1.2: +2 -2 lines
Fix compiler warnings.
1 ram 1.1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.1.1.2 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 ram 1.1.1.3 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/group.lisp,v 1.1.1.3 1993/08/25 02:08:50 ram Exp $")
11 ram 1.1.1.2 ;;;
12 ram 1.1 ;;; **********************************************************************
13     ;;;
14     ;;; File group stuff for Hemlock.
15     ;;; Written by Skef Wholey and Rob MacLachlan.
16     ;;;
17     ;;; The "Compile Group" and "List Compile Group" commands in lispeval
18     ;;; also know about groups.
19     ;;;
20     ;;; This file provides Hemlock commands for manipulating groups of files
21     ;;; that make up a larger system. A file group is a set of files whose
22     ;;; names are listed in some other file. At any given time one group of
23     ;;; files is the Active group. The Select Group command makes a group the
24     ;;; Active group, prompting for the name of a definition file if the group
25     ;;; has not been selected before. Once a group has been selected once, the
26     ;;; name of the definition file associated with that group is retained. If
27     ;;; one wishes to change the name of the definition file after a group has
28     ;;; been selected, one should call Select Group with a prefix argument.
29    
30 ram 1.1.1.3 (in-package "HEMLOCK")
31 ram 1.1
32     (defvar *file-groups* (make-string-table)
33     "A string table of file groups.")
34    
35     (defvar *active-file-group* ()
36     "The list of files in the currently active group.")
37    
38     (defvar *active-file-group-name* ()
39     "The name of the currently active group.")
40    
41    
42    
43     ;;;; Selecting the active group.
44    
45     (defcommand "Select Group" (p)
46     "Makes a group the active group. With a prefix argument, changes the
47     definition file associated with the group."
48     "Makes a group the active group."
49     (let* ((group-name
50     (prompt-for-keyword
51     (list *file-groups*)
52     :must-exist nil
53     :prompt "Select Group: "
54     :help
55     "Type the name of the file group you wish to become the active group."))
56     (old (getstring group-name *file-groups*))
57     (pathname
58     (if (and old (not p))
59     old
60     (prompt-for-file :must-exist t
61     :prompt "From File: "
62     :default (merge-pathnames
63     (make-pathname
64     :name group-name
65     :type "upd")
66     (value pathname-defaults))))))
67     (setq *active-file-group-name* group-name)
68     (setq *active-file-group* (nreverse (read-file-group pathname nil)))
69     (setf (getstring group-name *file-groups*) pathname)))
70    
71    
72     ;;; READ-FILE-GROUP reads an Update format file and returns a list of pathnames
73     ;;; of the files named in that file. This guy knows about @@ indirection and
74     ;;; ignores empty lines and lines that begin with @ but not @@. A simpler
75     ;;; scheme could be used for non-Spice implementations, but all this hair is
76     ;;; probably useful, so Update format may as well be a standard for this sort
77     ;;; of thing.
78     ;;;
79     (defun read-file-group (pathname tail)
80     (with-open-file (file pathname)
81     (do* ((name (read-line file nil nil) (read-line file nil nil))
82     (length (if name (length name)) (if name (length name))))
83     ((null name) tail)
84 ram 1.1.1.1 (declare (type (or simple-string null) name))
85 ram 1.1 (cond ((zerop length))
86     ((char= (char name 0) #\@)
87     (when (and (> length 1) (char= (char name 1) #\@))
88     (setq tail (read-file-group
89     (merge-pathnames (subseq name 2)
90     pathname)
91     tail))))
92     (t
93     (push (merge-pathnames (pathname name) pathname) tail))))))
94    
95    
96    
97     ;;;; DO-ACTIVE-GROUP.
98    
99     (defhvar "Group Find File"
100     "If true, group commands use \"Find File\" to read files, otherwise
101     non-resident files are read into the \"Group Search\" buffer."
102     :value nil)
103    
104     (defhvar "Group Save File Confirm"
105     "If true, then the group commands will ask for confirmation before saving
106     a modified file." :value t)
107    
108     (defmacro do-active-group (&rest forms)
109     "This iterates over the active file group executing forms once for each
110     file. When forms are executed, the file will be in the current buffer,
111     and the point will be at the start of the file."
112     (let ((n-buf (gensym))
113     (n-start-buf (gensym))
114     (n-save (gensym)))
115     `(progn
116     (unless *active-file-group*
117     (editor-error "There is no active file group."))
118    
119     (let ((,n-start-buf (current-buffer))
120     (,n-buf nil))
121     (unwind-protect
122     (dolist (file *active-file-group*)
123     (catch 'file-not-found
124     (setq ,n-buf (group-read-file file ,n-buf))
125     (with-mark ((,n-save (current-point) :right-inserting))
126     (unwind-protect
127     (progn
128     (buffer-start (current-point))
129     ,@forms)
130     (move-mark (current-point) ,n-save)))
131     (group-save-file)))
132     (if (member ,n-start-buf *buffer-list*)
133     (setf (current-buffer) ,n-start-buf
134     (window-buffer (current-window)) ,n-start-buf)
135     (editor-error "Original buffer deleted!")))))))
136    
137     ;;; GROUP-READ-FILE reads in files for the group commands via DO-ACTIVE-GROUP.
138     ;;; We use FIND-FILE-BUFFER, which creates a new buffer when the file hasn't
139     ;;; already been read, to get files in, and then we delete the buffer if it is
140     ;;; newly created and "Group Find File" is false. This lets FIND-FILE-BUFFER
141     ;;; do all the work. We don't actually use the "Find File" command, so the
142     ;;; buffer history isn't affected.
143     ;;;
144     ;;; Search-Buffer is any temporary search buffer left over from the last file
145     ;;; that we want deleted. We don't do the deletion if the buffer is modified.
146     ;;;
147     (defun group-read-file (name search-buffer)
148     (unless (probe-file name)
149     (message "File ~A not found." name)
150     (throw 'file-not-found nil))
151     (multiple-value-bind (buffer created-p)
152     (find-file-buffer name)
153     (setf (current-buffer) buffer)
154     (setf (window-buffer (current-window)) buffer)
155    
156     (when (and search-buffer (not (buffer-modified search-buffer)))
157     (dolist (w (buffer-windows search-buffer))
158     (setf (window-buffer w) (current-buffer)))
159     (delete-buffer search-buffer))
160    
161     (if (and created-p (not (value group-find-file)))
162     (current-buffer) nil)))
163    
164     ;;; GROUP-SAVE-FILE is used by DO-ACTIVE-GROUP.
165     ;;;
166     (defun group-save-file ()
167     (let* ((buffer (current-buffer))
168     (pn (buffer-pathname buffer))
169     (name (namestring pn)))
170     (when (and (buffer-modified buffer)
171     (or (not (value group-save-file-confirm))
172     (prompt-for-y-or-n
173     :prompt (list "Save changes in ~A? " name)
174     :default t)))
175     (save-file-command ()))))
176    
177    
178    
179     ;;;; Searching and Replacing commands.
180    
181     (defcommand "Group Search" (p)
182     "Searches the active group for a specified string, which is prompted for."
183     "Searches the active group for a specified string."
184     (declare (ignore p))
185     (let ((string (prompt-for-string :prompt "Group Search: "
186     :help "String to search for in active file group"
187     :default *last-search-string*)))
188     (get-search-pattern string :forward)
189     (do-active-group
190     (do ((won (find-pattern (current-point) *last-search-pattern*)
191     (find-pattern (current-point) *last-search-pattern*)))
192     ((not won))
193     (character-offset (current-point) won)
194     (command-case
195     (:prompt "Group Search: "
196     :help "Type a character indicating the action to perform."
197     :change-window nil)
198     (:no "Search for the next occurrence.")
199     (:do-all "Go on to the next file in the group."
200     (return nil))
201     ((:exit :yes) "Exit the search."
202     (return-from group-search-command))
203     (:recursive-edit "Enter a recursive edit."
204     (do-recursive-edit)
205     (get-search-pattern string :forward)))))
206     (message "All files in group ~S searched." *active-file-group-name*)))
207    
208     (defcommand "Group Replace" (p)
209     "Replaces one string with another in the active file group."
210     "Replaces one string with another in the active file group."
211     (declare (ignore p))
212     (let* ((target (prompt-for-string :prompt "Group Replace: "
213     :help "Target string"
214     :default *last-search-string*))
215     (replacement (prompt-for-string :prompt "With: "
216     :help "Replacement string")))
217     (do-active-group
218     (query-replace-function nil target replacement
219     "Group Replace on previous file" t))
220     (message "Replacement done in all files in group ~S."
221     *active-file-group-name*)))
222    
223     (defcommand "Group Query Replace" (p)
224     "Query Replace for the active file group."
225     "Query Replace for the active file group."
226     (declare (ignore p))
227     (let ((target (prompt-for-string :prompt "Group Query Replace: "
228     :help "Target string"
229     :default *last-search-string*)))
230     (let ((replacement (prompt-for-string :prompt "With: "
231     :help "Replacement string")))
232     (do-active-group
233     (unless (query-replace-function
234     nil target replacement "Group Query Replace on previous file")
235     (return nil)))
236     (message "Replacement done in all files in group ~S."
237     *active-file-group-name*))))

  ViewVC Help
Powered by ViewVC 1.1.5