src/os.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          os.cl
   6 ;;;; Purpose:       Operating system interface for UFFI
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Sep 2002
   9 ;;;;
  10 ;;;; $Id: os.lisp,v 1.4 2002/10/23 19:51:20 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg.
  13 ;;;; Much of this code was taken from other open source project and copyright
  14 ;;;; for that code is noted below where appropriate.
  15 ;;;;
  16 ;;;; UFFI users are granted the rights to distribute and use this software
  17 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  18 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  19 ;;;; *************************************************************************
  20
  21 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  22 (in-package :uffi)
  23
  24
  25 ;; modified from function ASDF -- Copyright Dan Barlow and Contributors
  26
  27 (defun run-shell-command (control-string  &rest args &key output)
  28   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
  29 synchronously execute the result using a Bourne-compatible shell, with
  30 output to *trace-output*.  Returns the shell's exit code."
  31   (unless output
  32     (setq output *trace-output*))
  33
  34   (let ((command (apply #'format nil control-string args)))
  35     #+sbcl
  36     (sb-impl::process-exit-code
  37      (sb-ext:run-program
  38       "/bin/sh"
  39       (list "-c" command)
  40       :input nil :output output))
  41
  42     #+(or cmu scl)
  43     (ext:process-exit-code
  44      (ext:run-program
  45       "/bin/sh"
  46       (list "-c" command)
  47       :input nil :output output))
  48
  49     #+allegro
  50     (excl:run-shell-command command :input nil :output output)
  51
  52     #+lispworks
  53     (system:call-system-showing-output
  54      command
  55      :shell-type "/bin/sh"
  56      :output-stream output)
  57
  58     #+clisp                             ;XXX not exactly *trace-output*, I know
  59     (ext:run-shell-command  command :output :terminal :wait t)
  60
  61     #+openmcl
  62     (nth-value 1
  63                (ccl:external-process-status
  64                 (ccl:run-program "/bin/sh" (list "-c" command)
  65                                  :input nil :output output
  66                                  :wait t)))
  67
  68     #-(or openmcl clisp lispworks allegro scl cmu sbcl)
  69     (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
  70     ))