74 lines
2.4 KiB
Scheme
74 lines
2.4 KiB
Scheme
;;; -*-scheme-*-
|
|
|
|
;;; GNU Mes --- Maxwell Equations of Software
|
|
;;; Copyright © 2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
;;;
|
|
;;; This file is part of GNU Mes.
|
|
;;;
|
|
;;; GNU Mes is free software; you can redistribute it and/or modify it
|
|
;;; under the terms of the GNU General Public License as published by
|
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
;;; your option) any later version.
|
|
;;;
|
|
;;; GNU Mes is distributed in the hope that it will be useful, but
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;;; GNU General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; Code:
|
|
|
|
(mes-use-module (srfi srfi-13))
|
|
|
|
(define R_OK 0)
|
|
(define S_IRWXU #o700)
|
|
|
|
(define (basename file-name . ext)
|
|
(let ((base (last (string-split file-name #\/)))
|
|
(ext (and (pair? ext) (car ext))))
|
|
(if (and ext
|
|
(string-suffix? ext base)) (string-drop-right base (string-length ext))
|
|
base)))
|
|
|
|
(define (force-output . port)
|
|
*unspecified*)
|
|
|
|
(define (search-path path file-name)
|
|
(let loop ((path path))
|
|
(and (pair? path)
|
|
(let ((f (string-append (car path) "/" file-name)))
|
|
(if (access? f R_OK) f
|
|
(loop (cdr path)))))))
|
|
|
|
(define (execlp file-name args)
|
|
(let ((executable (if (string-index file-name #\/) file-name
|
|
(search-path (string-split (getenv "PATH") #\:) file-name))))
|
|
(execl executable args)))
|
|
|
|
(define (system* file-name . args)
|
|
(let ((pid (primitive-fork)))
|
|
(cond ((zero? pid)
|
|
(let ((out (current-output-port))
|
|
(err (current-error-port)))
|
|
(when (and (> out 0)
|
|
(not (= out 1)))
|
|
(dup2 out 1))
|
|
(when (and (> err 0)
|
|
(not (= err 2)))
|
|
(dup2 err 2))
|
|
(exit (apply execlp file-name (list args)))))
|
|
((= -1 pid) (error "fork failed:" file-name))
|
|
(else (let ((pid+status (waitpid 0)))
|
|
(cdr pid+status))))))
|
|
|
|
(define (waitpid pid . options)
|
|
(let ((options (if (null? options) 0 (car options))))
|
|
(core:waitpid pid options)))
|
|
|
|
(define (status:exit-val status)
|
|
(ash status -8))
|