← Back to branch summary

~ubuntu-branches/ubuntu/quantal/cl-kmrcl/quantal

« back to all changes in this revision

Viewing changes to os.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Kevin M. Rosenberg
  • Date: 2004-06-12 08:14:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040612081446-7fylzj3qe93x2ugp
Tags: upstream-1.73
Import upstream version 1.73

Show diffs side-by-side

added added

removed removed

Lines of Context:
os.lisp
 
1
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 
2
;;;; *************************************************************************
 
3
;;;; FILE IDENTIFICATION
 
4
;;;;
 
5
;;;; Name:          os.lisp
 
6
;;;; Purpose:       Operating System utilities
 
7
;;;; Programmer:    Kevin M. Rosenberg
 
8
;;;; Date Started:  Jul 2003
 
9
;;;;
 
10
;;;; $Id: os.lisp 9086 2004-04-19 06:32:34Z kevin $
 
11
;;;;
 
12
;;;; *************************************************************************
 
13
 
 
14
(in-package #:kmrcl)
 
15
 
 
16
(defun command-output (control-string &rest args)
 
17
  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
 
18
synchronously execute the result using a Bourne-compatible shell, 
 
19
returns (VALUES string-output error-output exit-status)"
 
20
  (let ((command (apply #'format nil control-string args)))
 
21
    #+sbcl
 
22
    (let* ((process (sb-ext:run-program  
 
23
                    "/bin/sh"
 
24
                    (list "-c" command)
 
25
                    :input nil :output :stream :error :stream))
 
26
           (output (read-stream-to-string (sb-impl::process-output process)))
 
27
           (error (read-stream-to-string (sb-impl::process-error process))))
 
28
      (close (sb-impl::process-output process))
 
29
      (close (sb-impl::process-error process))
 
30
      (values
 
31
       output
 
32
       error
 
33
       (sb-impl::process-exit-code process)))    
 
34
 
 
35
    
 
36
    #+(or cmu scl)
 
37
    (let* ((process (ext:run-program  
 
38
                     "/bin/sh"
 
39
                     (list "-c" command)
 
40
                     :input nil :output :stream :error :stream))
 
41
           (output (read-stream-to-string (ext::process-output process)))
 
42
           (error (read-stream-to-string (ext::process-error process))))
 
43
      (close (ext::process-output process))
 
44
      (close (ext::process-error process))
 
45
 
 
46
      (values
 
47
       output
 
48
       error
 
49
       (ext::process-exit-code process)))
 
50
 
 
51
    #+allegro
 
52
    (multiple-value-bind (output error status)
 
53
        (excl.osi:command-output command :whole t)
 
54
      (values output error status))
 
55
    
 
56
    #+lispworks
 
57
    ;; BUG: Lispworks combines output and error streams
 
58
    (let ((output (make-string-output-stream)))
 
59
      (unwind-protect
 
60
          (let ((status 
 
61
                 (system:call-system-showing-output
 
62
                  command
 
63
                  :shell-type "/bin/sh"
 
64
                  :output-stream output)))
 
65
            (values (get-output-stream-string output) nil status))
 
66
        (close output)))
 
67
    
 
68
    #+clisp             
 
69
    ;; BUG: CLisp doesn't allow output to user-specified stream
 
70
    (values
 
71
     nil
 
72
     nil
 
73
     (ext:run-shell-command  command :output :terminal :wait t))
 
74
    
 
75
    #+openmcl
 
76
    (let* ((process (ccl:run-program  
 
77
                     "/bin/sh"
 
78
                     (list "-c" command)
 
79
                     :input nil :output :stream :error :stream
 
80
                     :wait t))
 
81
           (output (read-stream-to-string (ccl::external-process-output-stream process)))
 
82
           (error (read-stream-to-string (ccl::external-process-error-stream process))))
 
83
      (close (ccl::external-process-output-stream process))
 
84
      (close (ccl::external-process-error-stream process))
 
85
      (values output
 
86
              error
 
87
              (nth-value 1 (ccl::external-process-status process))))
 
88
  
 
89
    #-(or openmcl clisp lispworks allegro scl cmu sbcl)
 
90
    (error "COMMAND-OUTPUT not implemented for this Lisp")
 
91
 
 
92
    ))
 
93
 
 
94
(defun run-shell-command (control-string &rest args)
 
95
  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
 
96
synchronously execute the result using a Bourne-compatible shell, 
 
97
returns (VALUES output-string pid)"
 
98
  (let ((command (apply #'format nil control-string args)))
 
99
    #+sbcl
 
100
    (sb-impl::process-exit-code
 
101
     (sb-ext:run-program  
 
102
      "/bin/sh"
 
103
      (list  "-c" command)
 
104
      :input nil :output nil))
 
105
    
 
106
    #+(or cmu scl)
 
107
    (ext:process-exit-code
 
108
     (ext:run-program  
 
109
      "/bin/sh"
 
110
      (list  "-c" command)
 
111
      :input nil :output nil))
 
112
    
 
113
    
 
114
    #+allegro
 
115
    (excl:run-shell-command command :input nil :output nil
 
116
                            :wait t)
 
117
 
 
118
    #+lispworks
 
119
    (system:call-system-showing-output
 
120
     command
 
121
     :shell-type "/bin/sh"
 
122
     :output-stream output)
 
123
    
 
124
    #+clisp             ;XXX not exactly *verbose-out*, I know
 
125
    (ext:run-shell-command  command :output :terminal :wait t)
 
126
    
 
127
    #+openmcl
 
128
    (nth-value 1
 
129
               (ccl:external-process-status
 
130
                (ccl:run-program "/bin/sh" (list "-c" command)
 
131
                                 :input nil :output nil
 
132
                                 :wait t)))
 
133
           
 
134
    #-(or openmcl clisp lispworks allegro scl cmu sbcl)
 
135
    (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
 
136
 
 
137
    ))