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

Contents of /src/hemlock/unixcoms.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (hide annotations)
Wed Nov 17 15:58:50 1993 UTC (20 years, 5 months ago) by ram
Branch: MAIN
Changes since 1.7: +2 -2 lines
Changed from using sed to ul in the "Manual Entry" command, since
this works better on HP, etc.
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 ram 1.8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/unixcoms.lisp,v 1.8 1993/11/17 15:58:50 ram 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     (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 ram 1.7 :wait nil)))
170 ram 1.1
171    
172    
173     ;;;; UNIX Filter Region
174    
175     (defcommand "Unix Filter Region" (p)
176     "Unix Filter Region prompts for a UNIX program and then passes the current
177     region to the program as standard input. The standard output from the
178     program is used to replace the region. This command is undo-able."
179     "UNIX-FILTER-REGION-COMMAND is not intended to be called from normal
180     Hemlock commands; use UNIX-FILTER-REGION instead."
181     (declare (ignore p))
182     (let* ((region (current-region))
183     (filter-and-args (prompt-for-string
184     :prompt "Filter: "
185     :help "Unix program to filter the region through."))
186     (filter-and-args-list (listify-unix-filter-string filter-and-args))
187     (filter (car filter-and-args-list))
188     (args (cdr filter-and-args-list))
189     (new-region (unix-filter-region region filter args))
190     (start (copy-mark (region-start region) :right-inserting))
191     (end (copy-mark (region-end region) :left-inserting))
192     (old-region (region start end))
193     (undo-region (delete-and-save-region old-region)))
194     (ninsert-region end new-region)
195     (make-region-undo :twiddle "Unix Filter Region" old-region undo-region)))
196    
197     (defun unix-filter-region (region command args)
198     "Passes the region REGION as standard input to the program COMMAND
199     with arguments ARGS and returns the standard output as a freshly
200     cons'ed region."
201     (let ((new-region (make-empty-region)))
202     (with-input-from-region (input region)
203     (with-output-to-mark (output (region-end new-region) :full)
204     (ext:run-program command args
205     :input input
206     :output output
207     :error output)))
208     new-region))
209    
210     (defun listify-unix-filter-string (str)
211     (declare (simple-string str))
212     (let ((result nil)
213     (lastpos 0))
214     (loop
215     (let ((pos (position #\Space str :start lastpos :test #'char=)))
216     (push (subseq str lastpos pos) result)
217     (unless pos
218     (return))
219     (setf lastpos (1+ pos))))
220     (nreverse result)))
221 chiles 1.3
222    
223    
224     ;;;; Man pages.
225    
226     (defcommand "Manual Page" (p)
227     "Read the Unix manual pages in a View buffer.
228 chiles 1.4 If given an argument, this will put the man page in a Pop-up display."
229 chiles 1.3 "Read the Unix manual pages in a View buffer.
230     If given an argument, this will put the man page in a Pop-up display."
231 chiles 1.5 (let ((topic (prompt-for-string :prompt "Man topic: ")))
232 chiles 1.3 (if p
233     (with-pop-up-display (stream)
234     (execute-man topic stream))
235     (let* ((buf-name (format nil "Man Page ~a" topic))
236 chiles 1.5 (new-buffer (make-buffer buf-name :modes '("Fundamental" "View")))
237     (buffer (or new-buffer (getstring buf-name *buffer-names*)))
238 chiles 1.3 (point (buffer-point buffer)))
239 chiles 1.5 (change-to-buffer buffer)
240 chiles 1.3 (when new-buffer
241 chiles 1.5 (setf (value view-return-function) #'(lambda ()))
242 chiles 1.3 (with-writable-buffer (buffer)
243 chiles 1.5 (with-output-to-mark (s point :full)
244     (execute-man topic s))))
245     (buffer-start point buffer)))))
246    
247     (defun execute-man (topic stream)
248     (ext:run-program
249     "/bin/sh"
250     (list "-c"
251 ram 1.8 (format nil "man ~a| ul -t adm3" topic))
252 chiles 1.5 :output stream))

  ViewVC Help
Powered by ViewVC 1.1.5