mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Change `system*' to not leave dangling processes behind.

Browse source 
Fixes <http://bugs.gnu.org/13166>.

* libguile/simpos.c (scm_system_star): In the child, call `_exit'
  instead of `SCM_SYSERROR' when `execvp' fails.
* test-suite/tests/posix.test ("system*"): New test prefix.
This commit is contained in:
Ludovic Courtès 2012-12-19 23:15:45 +01:00
parent b9d724982d
commit 668ba7c955
2 changed files with 29 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

18
libguile/simpos.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2009, 2010 Free Software
* Foundation, Inc.
/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2003, 2004, 2009,
* 2010, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -26,6 +26,7 @@
#include <errno.h>
#include <signal.h> /* for SIG constants */
#include <stdlib.h> /* for getenv */
#include <stdio.h>
#include "libguile/_scm.h"
@ -138,9 +139,16 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
{
/* child */
execvp (execargv[0], execargv);
SCM_SYSERROR;
/* not reached. */
return SCM_BOOL_F;
/* Something went wrong. */
fprintf (stderr, "In execvp of %s: %s\n",
execargv[0], strerror (errno));
/* Exit directly instead of throwing, because otherwise this
process may keep on running. Use exit status 127, like
shells in this case, as per POSIX
<http://pubs.opengroup.org/onlinepubs/007904875/utilities/xcu_chap02.html#tag_02_09_01_01>. */
_exit (127);
}
else
{

15
test-suite/tests/posix.test
View file

@ -1,6 +1,6 @@
;;;; posix.test --- Test suite for Guile POSIX functions. -*- scheme -*-
;;;;
;;;; Copyright 2003, 2004, 2006, 2007, 2010 Free Software Foundation, Inc.
;;;; Copyright 2003, 2004, 2006, 2007, 2010, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -198,3 +198,16 @@
(setaffinity (getpid) mask)
(equal? mask (getaffinity (getpid))))
(throw 'unresolved))))
;;
;; system*
;;
(with-test-prefix "system*"
(pass-if "http://bugs.gnu.org/13166"
;; With Guile up to 2.0.7 included, the child process launched by
;; `system*' would remain alive after an `execvp' failure.
(let ((me (getpid)))
(and (not (zero? (pk (system* "something-that-does-not-exist"))))
(= me (getpid))))))