;;; -*-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))