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

Contents of /src/hemlock/unixcoms.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Mon Jul 29 11:23:34 1991 UTC (22 years, 8 months ago) by chiles
Branch: MAIN
Changes since 1.2: +33 -1 lines
Added Mike's "Manual Page" command.
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 chiles 1.3 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/unixcoms.lisp,v 1.3 1991/07/29 11:23:34 chiles 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     :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 chiles 1.3
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 Po-pup 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 "Read what man page: ")))
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
240     :modes '("Fundamental" "View")))
241     (buffer (or new-buffer
242     (getstring buf-name *buffer-names*)))
243     (point (buffer-point buffer)))
244     (when new-buffer
245     (setf (variable-value 'view-return-function :buffer buffer)
246     #'(lambda ()))
247     (with-writable-buffer (buffer)
248     (ext:run-program
249     "/bin/sh"
250     (list "-c"
251     (format nil "man ~a|cat -s|sed -e 's/_//g' -e 's/o//g'"
252     topic))
253     :output (make-hemlock-output-stream point :full))))
254     (buffer-start point buffer)
255     (change-to-buffer buffer)))))

  ViewVC Help
Powered by ViewVC 1.1.5