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

Contents of /src/hemlock/unixcoms.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5