60 lines
2.0 KiB
Scheme
60 lines
2.0 KiB
Scheme
;;; -*-scheme-*-
|
|
|
|
;;; Mes --- Maxwell Equations of Software
|
|
;;; Copyright © 2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
;;;
|
|
;;; This file is part of Mes.
|
|
;;;
|
|
;;; 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.
|
|
;;;
|
|
;;; 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 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 (search-path path file-name)
|
|
(if (access? file-name R_OK) 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) (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)))
|