c9c7165f8ee011806d05f16feb7f6b2c60b5cb62
[mes.git] / mes / module / mes / posix.mes
1 ;;; -*-scheme-*-
2
3 ;;; GNU Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of GNU Mes.
7 ;;;
8 ;;; GNU Mes is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
12 ;;;
13 ;;; GNU Mes is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 ;;; GNU General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
20
21 ;;; Commentary:
22
23 ;;; Code:
24
25 (mes-use-module (srfi srfi-13))
26
27 (define R_OK 0)
28 (define S_IRWXU #o700)
29
30 (define (basename file-name . ext)
31   (let ((base (last (string-split file-name #\/)))
32         (ext (and (pair? ext) (car ext))))
33     (if (and ext
34              (string-suffix? ext base)) (string-drop-right base (string-length ext))
35              base)))
36
37 (define (search-path path file-name)
38   (if (access? file-name R_OK) file-name
39       (let loop ((path path))
40         (and (pair? path)
41              (let ((f (string-append (car path) "/" file-name)))
42                (if (access? f R_OK) f
43                    (loop (cdr path))))))))
44
45 (define (execlp file-name args)
46   (let ((executable (if (string-index file-name #\/) file-name
47                         (search-path (string-split (getenv "PATH") #\:) file-name))))
48     (execl executable args)))
49
50 (define (system* file-name . args)
51   (let ((pid (primitive-fork)))
52     (cond ((zero? pid)
53            (let ((out (current-output-port))
54                  (err (current-error-port)))
55              (when (and (> out 0)
56                         (not (= out 1)))
57                (dup2 out 1))
58              (when (and (> err 0)
59                         (not (= err 2)))
60                (dup2 err 2))
61              (exit (apply execlp file-name (list args)))))
62           ((= -1 pid) (error "fork failed:" file-name))
63           (else (let ((pid+status (waitpid 0)))
64                   (cdr pid+status))))))
65
66 (define (waitpid pid . options)
67   (let ((options (if (null? options) 0 (car options))))
68     (core:waitpid pid options)))
69
70 (define (status:exit-val status)
71   (ash status -8))