core: typo: Remove trailing 1.
[mes.git] / module / mes / posix.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2017 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
5 ;;;
6 ;;; This file is part of Mes.
7 ;;;
8 ;;; 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 ;;; 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 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) (apply execlp file-name (list args)))
53           ((= -1 pid) (error "fork failed:" file-name))
54           (else (let ((pid+status (waitpid 0)))
55                   (cdr pid+status))))))
56
57 (define (waitpid pid . options)
58   (let ((options (if (null? options) 0 (car options))))
59     (core:waitpid pid options)))