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

Contents of /src/hemlock/unixcoms.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Thu Aug 1 11:35:44 1991 UTC (22 years, 8 months ago) by chiles
Branch: MAIN
Changes since 1.4: +16 -16 lines
Fixed bug in "Manual Page".
1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/unixcoms.lisp,v 1.5 1991/08/01 11:35:44 chiles Exp $")
11 ;;;
12 ;;; **********************************************************************
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 :value "/usr/cs/bin/lpr")
33
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 :value "/usr/misc/bin/scribe")
150
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 (stream (make-hemlock-output-stream out-point :line)))
162 (buffer-end out-point)
163 (insert-character out-point #\newline)
164 (insert-character out-point #\newline)
165 (ext:run-program (namestring (value scribe-utility))
166 (list* (namestring pathname)
167 (value scribe-utility-switches))
168 :output stream :error stream
169 :wait nil
170 :before-execve
171 #'(lambda ()
172 (setf (default-directory) (directory-namestring pathname))))))
173
174
175
176 ;;;; UNIX Filter Region
177
178 (defcommand "Unix Filter Region" (p)
179 "Unix Filter Region prompts for a UNIX program and then passes the current
180 region to the program as standard input. The standard output from the
181 program is used to replace the region. This command is undo-able."
182 "UNIX-FILTER-REGION-COMMAND is not intended to be called from normal
183 Hemlock commands; use UNIX-FILTER-REGION instead."
184 (declare (ignore p))
185 (let* ((region (current-region))
186 (filter-and-args (prompt-for-string
187 :prompt "Filter: "
188 :help "Unix program to filter the region through."))
189 (filter-and-args-list (listify-unix-filter-string filter-and-args))
190 (filter (car filter-and-args-list))
191 (args (cdr filter-and-args-list))
192 (new-region (unix-filter-region region filter args))
193 (start (copy-mark (region-start region) :right-inserting))
194 (end (copy-mark (region-end region) :left-inserting))
195 (old-region (region start end))
196 (undo-region (delete-and-save-region old-region)))
197 (ninsert-region end new-region)
198 (make-region-undo :twiddle "Unix Filter Region" old-region undo-region)))
199
200 (defun unix-filter-region (region command args)
201 "Passes the region REGION as standard input to the program COMMAND
202 with arguments ARGS and returns the standard output as a freshly
203 cons'ed region."
204 (let ((new-region (make-empty-region)))
205 (with-input-from-region (input region)
206 (with-output-to-mark (output (region-end new-region) :full)
207 (ext:run-program command args
208 :input input
209 :output output
210 :error output)))
211 new-region))
212
213 (defun listify-unix-filter-string (str)
214 (declare (simple-string str))
215 (let ((result nil)
216 (lastpos 0))
217 (loop
218 (let ((pos (position #\Space str :start lastpos :test #'char=)))
219 (push (subseq str lastpos pos) result)
220 (unless pos
221 (return))
222 (setf lastpos (1+ pos))))
223 (nreverse result)))
224
225
226
227 ;;;; Man pages.
228
229 (defcommand "Manual Page" (p)
230 "Read the Unix manual pages in a View buffer.
231 If given an argument, this will put the man page in a Pop-up display."
232 "Read the Unix manual pages in a View buffer.
233 If given an argument, this will put the man page in a Pop-up display."
234 (let ((topic (prompt-for-string :prompt "Man topic: ")))
235 (if p
236 (with-pop-up-display (stream)
237 (execute-man topic stream))
238 (let* ((buf-name (format nil "Man Page ~a" topic))
239 (new-buffer (make-buffer buf-name :modes '("Fundamental" "View")))
240 (buffer (or new-buffer (getstring buf-name *buffer-names*)))
241 (point (buffer-point buffer)))
242 (change-to-buffer buffer)
243 (when new-buffer
244 (setf (value view-return-function) #'(lambda ()))
245 (with-writable-buffer (buffer)
246 (with-output-to-mark (s point :full)
247 (execute-man topic s))))
248 (buffer-start point buffer)))))
249
250 (defun execute-man (topic stream)
251 (ext:run-program
252 "/bin/sh"
253 (list "-c"
254 (format nil "man ~a|cat -s|sed -e 's/_//g' -e 's/o//g'" topic))
255 :output stream))

  ViewVC Help
Powered by ViewVC 1.1.5