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

Contents of /src/hemlock/unixcoms.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (hide annotations)
Tue Jan 25 15:35:14 1994 UTC (20 years, 2 months ago) by wlott
Branch: MAIN
Changes since 1.8: +12 -8 lines
Restored the behavior of scribe-file to cd to the directory of the .mss
file before running scribe.  This was accidentally removed in an attempt to
clean up some compiler warnings.
1 ram 1.1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 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 wlott 1.9 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/unixcoms.lisp,v 1.9 1994/01/25 15:35:14 wlott Exp $")
11 ram 1.2 ;;;
12 ram 1.1 ;;; **********************************************************************
13     ;;;
14     ;;;
15     ;;; This file contains Commands useful when running on a Unix box. Hopefully
16     ;;; there are no CMU Unix dependencies though there are probably CMU Common
17     ;;; Lisp dependencies, such as RUN-PROGRAM.
18     ;;;
19     ;;; Written by Christopher Hoover.
20    
21     (in-package "HEMLOCK")
22    
23    
24    
25     ;;;; Region and File printing commands.
26    
27     (defhvar "Print Utility"
28     "UNIX(tm) program to invoke (via EXT:RUN-PROGRAM) to do printing.
29     The program should act like lpr: if a filename is given as an argument,
30     it should print that file, and if no name appears, standard input should
31     be assumed."
32 ram 1.6 :value "lpr")
33 ram 1.1
34     (defhvar "Print Utility Switches"
35     "Switches to pass to the \"Print Utility\" program. This should be a list
36     of strings."
37     :value ())
38    
39    
40     ;;; PRINT-SOMETHING calls RUN-PROGRAM on the utility-name and args. Output
41     ;;; and error output are done to the echo area, and errors are ignored for
42     ;;; now. Run-program-keys are other keywords to pass to RUN-PROGRAM in
43     ;;; addition to :wait, :output, and :error.
44     ;;;
45     (defmacro print-something (&optional (run-program-keys)
46     (utility-name '(value print-utility))
47     (args '(value print-utility-switches)))
48     (let ((pid (gensym))
49     (error-code (gensym)))
50     `(multiple-value-bind (,pid ,error-code)
51     (ext:run-program ,utility-name ,args
52     ,@run-program-keys
53     :wait t
54     :output *echo-area-stream*
55     :error *echo-area-stream*)
56     (declare (ignore ,pid ,error-code))
57     (force-output *echo-area-stream*)
58     ;; Keep the echo area from being cleared at the top of the command loop.
59     (setf (buffer-modified *echo-area-buffer*) nil))))
60    
61    
62     ;;; PRINT-REGION -- Interface
63     ;;;
64     ;;; Takes a region and outputs the text to the program defined by
65     ;;; the hvar "Print Utility" with options form the hvar "Print
66     ;;; Utility Options" using PRINT-SOMETHING.
67     ;;;
68     (defun print-region (region)
69     (with-input-from-region (s region)
70     (print-something (:input s))))
71    
72    
73     (defcommand "Print Buffer" (p)
74     "Prints the current buffer using the program defined by the hvar
75     \"Print Utility\" with the options from the hvar \"Print Utility
76     Options\". Errors appear in the echo area."
77     "Prints the contents of the buffer."
78     (declare (ignore p))
79     (message "Printing buffer...~%")
80     (print-region (buffer-region (current-buffer))))
81    
82     (defcommand "Print Region" (p)
83     "Prints the current region using the program defined by the hvar
84     \"Print Utility\" with the options from the hvar \"Print Utility
85     Options\". Errors appear in the echo area."
86     "Prints the current region."
87     (declare (ignore p))
88     (message "Printing region...~%")
89     (print-region (current-region)))
90    
91     (defcommand "Print File" (p)
92     "Prompts for a file and prints it usings the program defined by
93     the hvar \"Print Utility\" with the options from the hvar \"Print
94     Utility Options\". Errors appear in the echo area."
95     "Prints a file."
96     (declare (ignore p))
97     (let* ((pn (prompt-for-file :prompt "File to print: "
98     :help "Name of file to print."
99     :default (buffer-default-pathname (current-buffer))
100     :must-exist t))
101     (ns (namestring (truename pn))))
102     (message "Printing file...~%")
103     (print-something () (value print-utility)
104     (append (value print-utility-switches) (list ns)))))
105    
106    
107     ;;;; Scribe.
108    
109     (defcommand "Scribe File" (p)
110     "Scribe a file with the default directory set to the directory of the
111     specified file. The output from running Scribe is sent to the
112     \"Scribe Warnings\" buffer. See \"Scribe Utility\" and \"Scribe Utility
113     Switches\"."
114     "Scribe a file with the default directory set to the directory of the
115     specified file."
116     (declare (ignore p))
117     (scribe-file (prompt-for-file :prompt "Scribe file: "
118     :default
119     (buffer-default-pathname (current-buffer)))))
120    
121     (defhvar "Scribe Buffer File Confirm"
122     "When set, \"Scribe Buffer File\" prompts for confirmation before doing
123     anything."
124     :value t)
125    
126     (defcommand "Scribe Buffer File" (p)
127     "Scribe the file associated with the current buffer. The default directory
128     set to the directory of the file. The output from running Scribe is sent to
129     the \"Scribe Warnings\" buffer. See \"Scribe Utility\" and \"Scribe Utility
130     Switches\". Before doing anything the user is asked to confirm saving and
131     Scribe'ing the file. This prompting can be inhibited by with \"Scribe Buffer
132     File Confirm\"."
133     "Scribe a file with the default directory set to the directory of the
134     specified file."
135     (declare (ignore p))
136     (let* ((buffer (current-buffer))
137     (pathname (buffer-pathname buffer))
138     (modified (buffer-modified buffer)))
139     (when (or (not (value scribe-buffer-file-confirm))
140     (prompt-for-y-or-n
141     :default t :default-string "Y"
142     :prompt (list "~:[S~;Save and s~]cribe file ~A? "
143     modified (namestring pathname))))
144     (when modified (write-buffer-file buffer pathname))
145     (scribe-file pathname))))
146    
147     (defhvar "Scribe Utility"
148     "Program name to invoke (via EXT:RUN-PROGRAM) to do text formatting."
149 ram 1.6 :value "scribe")
150 ram 1.1
151     (defhvar "Scribe Utility Switches"
152     "Switches to pass to the \"Scribe Utility\" program. This should be a list
153     of strings."
154     :value ())
155    
156     (defun scribe-file (pathname)
157     (let* ((pathname (truename pathname))
158     (out-buffer (or (getstring "Scribe Warnings" *buffer-names*)
159     (make-buffer "Scribe Warnings")))
160     (out-point (buffer-end (buffer-point out-buffer)))
161 wlott 1.9 (stream (make-hemlock-output-stream out-point :line))
162     (orig-cwd (default-directory)))
163 ram 1.1 (buffer-end out-point)
164     (insert-character out-point #\newline)
165     (insert-character out-point #\newline)
166 wlott 1.9 (unwind-protect
167     (progn
168     (setf (default-directory) (directory-namestring pathname))
169     (ext:run-program (namestring (value scribe-utility))
170     (list* (namestring pathname)
171     (value scribe-utility-switches))
172     :output stream :error stream
173     :wait nil))
174     (setf (default-directory) orig-cwd))))
175 ram 1.1
176    
177     ;;;; UNIX Filter Region
178    
179     (defcommand "Unix Filter Region" (p)
180     "Unix Filter Region prompts for a UNIX program and then passes the current
181     region to the program as standard input. The standard output from the
182     program is used to replace the region. This command is undo-able."
183     "UNIX-FILTER-REGION-COMMAND is not intended to be called from normal
184     Hemlock commands; use UNIX-FILTER-REGION instead."
185     (declare (ignore p))
186     (let* ((region (current-region))
187     (filter-and-args (prompt-for-string
188     :prompt "Filter: "
189     :help "Unix program to filter the region through."))
190     (filter-and-args-list (listify-unix-filter-string filter-and-args))
191     (filter (car filter-and-args-list))
192     (args (cdr filter-and-args-list))
193     (new-region (unix-filter-region region filter args))
194     (start (copy-mark (region-start region) :right-inserting))
195     (end (copy-mark (region-end region) :left-inserting))
196     (old-region (region start end))
197     (undo-region (delete-and-save-region old-region)))
198     (ninsert-region end new-region)
199     (make-region-undo :twiddle "Unix Filter Region" old-region undo-region)))
200    
201     (defun unix-filter-region (region command args)
202     "Passes the region REGION as standard input to the program COMMAND
203     with arguments ARGS and returns the standard output as a freshly
204     cons'ed region."
205     (let ((new-region (make-empty-region)))
206     (with-input-from-region (input region)
207     (with-output-to-mark (output (region-end new-region) :full)
208     (ext:run-program command args
209     :input input
210     :output output
211     :error output)))
212     new-region))
213    
214     (defun listify-unix-filter-string (str)
215     (declare (simple-string str))
216     (let ((result nil)
217     (lastpos 0))
218     (loop
219     (let ((pos (position #\Space str :start lastpos :test #'char=)))
220     (push (subseq str lastpos pos) result)
221     (unless pos
222     (return))
223     (setf lastpos (1+ pos))))
224     (nreverse result)))
225 chiles 1.3
226    
227    
228     ;;;; Man pages.
229    
230     (defcommand "Manual Page" (p)
231     "Read the Unix manual pages in a View buffer.
232 chiles 1.4 If given an argument, this will put the man page in a Pop-up display."
233 chiles 1.3 "Read the Unix manual pages in a View buffer.
234     If given an argument, this will put the man page in a Pop-up display."
235 chiles 1.5 (let ((topic (prompt-for-string :prompt "Man topic: ")))
236 chiles 1.3 (if p
237     (with-pop-up-display (stream)
238     (execute-man topic stream))
239     (let* ((buf-name (format nil "Man Page ~a" topic))
240 chiles 1.5 (new-buffer (make-buffer buf-name :modes '("Fundamental" "View")))
241     (buffer (or new-buffer (getstring buf-name *buffer-names*)))
242 chiles 1.3 (point (buffer-point buffer)))
243 chiles 1.5 (change-to-buffer buffer)
244 chiles 1.3 (when new-buffer
245 chiles 1.5 (setf (value view-return-function) #'(lambda ()))
246 chiles 1.3 (with-writable-buffer (buffer)
247 chiles 1.5 (with-output-to-mark (s point :full)
248     (execute-man topic s))))
249     (buffer-start point buffer)))))
250    
251     (defun execute-man (topic stream)
252     (ext:run-program
253     "/bin/sh"
254     (list "-c"
255 ram 1.8 (format nil "man ~a| ul -t adm3" topic))
256 chiles 1.5 :output stream))

  ViewVC Help
Powered by ViewVC 1.1.5