From c7568d565fabd1d961c76e71c5716de0216330cc Mon Sep 17 00:00:00 2001 From: Christian Kellermann Date: Sat, 23 Jul 2016 21:23:50 +0200 Subject: [PATCH] Fix buffer overflow in posix execvp/execve wrapper This fixes bug #1308 found by wasamasa. It turns out that we don't check the number of arguments or the number of env entries before trying to write them to the target string. Instead of checking the argument count, this patch replaces the static buffer with a dynamically allocated string and relies on errno being set to E2BIG if the argument vector is too large. Furthermore, this merges the process-execute and process-spawn code from Windows and Unix some more to use more common code. This should make it easier to tweak this code in the future. This new version also fixes a memory leak which would be triggered when the arg or env list contained non-string objects or embedded NULs, or when the exec itself would fail. Most C code in these procedures was rewritten to Scheme. Signed-off-by: Peter Bex Conflicts: manual/Acknowledgements posix-common.scm posixunix.scm posixwin.scm --- NEWS | 6 ++ manual/Acknowledgements | 62 +++++++++---------- posix-common.scm | 62 +++++++++++++++++++ posixunix.scm | 84 ++++--------------------- posixwin.scm | 159 ++++++++++++++++-------------------------------- rules.make | 2 + 6 files changed, 165 insertions(+), 210 deletions(-) diff --git a/NEWS b/NEWS index d4eb49d..bc03768 100644 --- a/NEWS +++ b/NEWS @@ -53,6 +53,12 @@ 4.11.1 +- Security fixes + - Fix buffer overrun due to excessively long argument or + environment lists in process-execute and process-spawn (#1308). + This also removes unnecessary limitations on the length of + these lists (thanks to Vasilij Schneidermann). + - Compiler: - define-constant now correctly keeps symbol values quoted. - Warnings are now emitted when using vector-{ref,set!} or one diff --git a/manual/Acknowledgements b/manual/Acknowledgements index 7cfb6c6..7b6fe2f 100644 --- a/manual/Acknowledgements +++ b/manual/Acknowledgements @@ -6,15 +6,15 @@ Many thanks to Jules Altfas, Nico Amtsberg, Alonso Andres, William Annis, Jason E. Aten, Marc Baily, Peter Barabas, Andrei Barbu, Jonah Beckford, Arto Bendiken, Andy Bennett, Kevin Beranek, Peter Bex, Jean-Francois Bignolles, Oivind Binde, Alaric Blagrave Snell-Pym, Dave -Bodenstab, Fabian Böhlke, T. Kurt Bond, Ashley Bone, Dominique Boucher, -Terence Brannon, Roy Bryant, Adam Buchbinder, Hans Bulfone, "Category -5", Taylor Campbell, Naruto Canada, Mark Carter, Esteban U. Caamano -Castro, Semih Cemiloglu, Alex Charlton, Franklin Chen, Joo ChurlSoo, -Thomas Chust, Gian Paolo Ciceri, Fulvio Ciriaco, Paul Colby, Tobia -Conforto, John Cowan, Grzegorz Chrupala, James Crippen, Evan Hanson, -Adhi Hargo, Moritz Heidkamp, Tollef Fog Heen, Drew Hess, Alejandro -Forero Cuervo, Peter Danenberg, Linh Dang, Brian Denheyer, Sean -D'Epagnier, "dgym", "Don", Chris Double, "Brown Dragon", David +Bodenstab, Fabian Böhlke, T. Kurt Bond, Ashley Bone, Dominique +Boucher, Terence Brannon, Roy Bryant, Adam Buchbinder, Hans Bulfone, +"Category 5", Taylor Campbell, Naruto Canada, Mark Carter, Esteban +U. Caamano Castro, Semih Cemiloglu, Alex Charlton, Franklin Chen, Joo +ChurlSoo, Thomas Chust, Gian Paolo Ciceri, Fulvio Ciriaco, Paul Colby, +Tobia Conforto, John Cowan, Grzegorz Chrupala, James Crippen, Evan +Hanson, Adhi Hargo, Moritz Heidkamp, Tollef Fog Heen, Drew Hess, +Alejandro Forero Cuervo, Peter Danenberg, Linh Dang, Brian Denheyer, +Sean D'Epagnier, "dgym", "Don", Chris Double, "Brown Dragon", David Dreisigmeyer, Jarod Eells, Petter Egesund, Stephen Eilert, Steve Elkins, Daniel B. Faken, Erik Falor, Will Farr, Graham Fawcett, Marc Feeley, "Fizzie", Matthew Flatt, Kimura Fuyuki, Tony Garnock-Jones, @@ -28,33 +28,33 @@ Jäger, Matt Jones, Dale Jordan, Valentin Kamyshenko, Daishi Kato, Peter Keller, Christian Kellermann, Brad Kind, Ron Kneusel, Matthias Köppe, Krysztof Kowalczyk, Andre Kühne, Todd R. Kueny Sr, Goran Krampe, David Krentzlin, Ben Kurtz, Michele La Monaca, Micky -Latowicki, Kristian Lein-Mathisen, "LemonBoy", John Lenz, -Kirill Lisovsky, Jürgen Lorenz, Kon Lovett, Lam Luu, Arthur Maciel, -Vitaly Magerya, Leonardo Valeri Manera, Claude Marinier, Dennis Marti, +Latowicki, Kristian Lein-Mathisen, "LemonBoy", John Lenz, Kirill +Lisovsky, Jürgen Lorenz, Kon Lovett, Lam Luu, Arthur Maciel, Vitaly +Magerya, Leonardo Valeri Manera, Claude Marinier, Dennis Marti, Charles Martin, Bob McIsaac, "megane", Alain Mellan, Eric Merrit, Perry Metzger, Scott G. Miller, Mikael, Karel Miklav, Bruce Mitchener, -Fadi Moukayed, Chris Moline, Eric E. Moore, Julian Morrison, -Dan Muresan, David N. Murray, Timo Myyrä, "nicktick", Lars Nilsson, -Ian Oversby, "o.t.", Gene Pavlovsky, Levi Pearson, Jeronimo Pellegrini, -Nicolas Pelletier, Derrell Piper, Carlos Pita, "Pluijzer", -Robin Lee Powell, Alan Post, "Pupeno", Davide Puricelli, "presto", -Doug Quale, Imran Rafique, Eric Raible, Ivan Raikov, Santosh Rajan, -Joel Reymont, "rivo", Chris Roberts, Eric Rochester, Paul Romanchenko, -Andreas Rottman, David Rush, Lars Rustemeier, Daniel Sadilek, -Otavio Salvador, Burton Samograd, "Sandro", "satori", Aleksej Saushev, -Oskar Schirmer, Reed Sheridan, Ronald Schröder, Spencer Schumann, -Ivan Shcheklein, Alexander Shendi, Alex Shinn, Ivan Shmakov, "Shmul", -Tony Sidaway, Jeffrey B. Siegal, Andrey Sidorenko, Michele Simionato, -Iruata Souza, Volker Stolz, Jon Strait, Dorai Sitaram, Robert Skeels, -Jason Songhurst, Clifford Stein, David Steiner, Sunnan, +Fadi Moukayed, Chris Moline, Eric E. Moore, Julian Morrison, Dan +Muresan, David N. Murray, Timo Myyrä, "nicktick", Lars Nilsson, Ian +Oversby, "o.t.", Gene Pavlovsky, Levi Pearson, Jeronimo Pellegrini, +Nicolas Pelletier, Derrell Piper, Carlos Pita, "Pluijzer", Robin Lee +Powell, Alan Post, "Pupeno", Davide Puricelli, "presto", Doug Quale, +Imran Rafique, Eric Raible, Ivan Raikov, Santosh Rajan, Joel Reymont, +"rivo", Chris Roberts, Eric Rochester, Paul Romanchenko, Andreas +Rottman, David Rush, Lars Rustemeier, Daniel Sadilek, Otavio Salvador, +Burton Samograd, "Sandro", "satori", Aleksej Saushev, Oskar Schirmer, +Vasilij Schneidermann, Reed Sheridan, Ronald Schröder, Spencer +Schumann, Ivan Shcheklein, Alexander Shendi, Alex Shinn, Ivan Shmakov, +"Shmul", Tony Sidaway, Jeffrey B. Siegal, Andrey Sidorenko, Michele +Simionato, Iruata Souza, Volker Stolz, Jon Strait, Dorai Sitaram, +Robert Skeels, Jason Songhurst, Clifford Stein, David Steiner, Sunnan, Zbigniew Szadkowski, Rick Taube, Nathan Thern, Mike Thomas, Minh Thu, Christian Tismer, Andre van Tonder, John Tobey, Henrik Tramberend, -Vladimir Tsichevsky, James Ursetto, Neil van Dyke, Sam Varner, -Taylor Venable, Sander Vesik, Jaques Vidrine, Panagiotis Vossos, -Shawn Wagner, Peter Wang, Ed Watkeys, Brad Watson, Thomas Weidner, Göran +Vladimir Tsichevsky, James Ursetto, Neil van Dyke, Sam Varner, Taylor +Venable, Sander Vesik, Jaques Vidrine, Panagiotis Vossos, Shawn +Wagner, Peter Wang, Ed Watkeys, Brad Watson, Thomas Weidner, Göran Weinholt, Matthew Welland, Drake Wilson, Jörg Wittenberger, Peter -Wright, Mark Wutka, Adam Young, Richard Zidlicky, Houman Zolfaghari and -Florian Zumbiehl for bug-fixes, tips and suggestions. +Wright, Mark Wutka, Adam Young, Richard Zidlicky, Houman Zolfaghari +and Florian Zumbiehl for bug-fixes, tips and suggestions. Special thanks to Brandon van Every for contributing the (now defunct) [[http://www.cmake.org|CMake]] support and for helping with Windows diff --git a/posix-common.scm b/posix-common.scm index 4bb21fb..e5cd930 100644 --- a/posix-common.scm +++ b/posix-common.scm @@ -699,3 +699,65 @@ EOF (if (fx= epid -1) (posix-error #:process-error 'process-wait "waiting for child process failed" pid) (values epid enorm ecode) ) ) ) ) ) ) + +;; This can construct argv or envp for process-execute or process-run +(define list->c-string-buffer + (let* ((c-string->allocated-pointer + (foreign-lambda* c-pointer ((scheme-object o)) + "char *ptr = malloc(C_header_size(o)); \n" + "if (ptr != NULL) {\n" + " C_memcpy(ptr, C_data_pointer(o), C_header_size(o)); \n" + "}\n" + "C_return(ptr);")) ) + (lambda (string-list convert loc) + (##sys#check-list string-list loc) + + (let* ((string-count (##sys#length string-list)) + ;; NUL-terminated, so we must add one + (buffer (make-pointer-vector (add1 string-count) #f))) + + (handle-exceptions exn + ;; Free to avoid memory leak, then reraise + (begin (free-c-string-buffer buffer) (signal exn)) + + (do ((sl string-list (cdr sl)) + (i 0 (fx+ i 1)) ) + ((or (null? sl) (fx= i string-count))) ; Should coincide + + (##sys#check-string (car sl) loc) + ;; This avoids embedded NULs and appends a NUL, so "cs" is + ;; safe to copy and use as-is in the pointer-vector. + (let* ((cs (##sys#make-c-string (convert (car sl)) loc)) + (csp (c-string->allocated-pointer cs))) + (unless csp (error loc "Out of memory")) + (pointer-vector-set! buffer i csp)) ) + + buffer) ) ) ) ) + +(define (free-c-string-buffer buffer-array) + (let ((size (pointer-vector-length buffer-array))) + (do ((i 0 (fx+ i 1))) + ((fx= i size)) + (and-let* ((s (pointer-vector-ref buffer-array i))) + (free s))))) + +(define call-with-exec-args + (let ((pathname-strip-directory pathname-strip-directory) + (nop (lambda (x) x))) + (lambda (loc filename argconv arglist envlist proc) + (let* ((stripped-filename (pathname-strip-directory filename)) + (args (cons stripped-filename arglist)) ; Add argv[0] + (argbuf (list->c-string-buffer args argconv loc)) + (envbuf #f)) + + (handle-exceptions exn + ;; Free to avoid memory leak, then reraise + (begin (free-c-string-buffer argbuf) + (when envbuf (free-c-string-buffer envbuf)) + (signal exn)) + + ;; Envlist is never converted, so we always use nop here + (when envlist + (set! envbuf (list->c-string-buffer envlist nop loc))) + + (proc (##sys#make-c-string filename loc) argbuf envbuf) ))))) diff --git a/posixunix.scm b/posixunix.scm index 63cef98..562a7cd 100644 --- a/posixunix.scm +++ b/posixunix.scm @@ -27,7 +27,7 @@ (declare (unit posix) - (uses scheduler irregex pathname ports) + (uses scheduler irregex pathname extras files ports lolevel) (disable-interrupts) (not inline ##sys#interrupt-hook ##sys#user-interrupt-hook)) @@ -84,6 +84,7 @@ (import chicken.bitwise chicken.foreign chicken.irregex + chicken.memory chicken.pathname chicken.ports chicken.time) @@ -130,10 +131,6 @@ static C_TLS int C_wait_status; # define O_TEXT 0 #endif -#ifndef ARG_MAX -# define ARG_MAX 256 -#endif - #ifndef MAP_FILE # define MAP_FILE 0 #endif @@ -152,16 +149,10 @@ extern char **environ; # define C_getenventry(i) (environ[ i ]) #endif -#ifndef ENV_MAX -# define ENV_MAX 1024 -#endif - #ifndef FILENAME_MAX # define FILENAME_MAX 1024 #endif -static C_TLS char *C_exec_args[ ARG_MAX ]; -static C_TLS char *C_exec_env[ ENV_MAX ]; static C_TLS struct utsname C_utsname; static C_TLS struct flock C_flock; static C_TLS DIR *temphandle; @@ -224,29 +215,8 @@ static C_TLS struct stat C_statbuf; #define C_lstat(fn) C_fix(lstat((char *)C_data_pointer(fn), &C_statbuf)) -static void C_fcall C_set_arg_string(char **where, int i, char *a, int len) { - char *ptr; - if(a != NULL) { - ptr = (char *)C_malloc(len + 1); - C_memcpy(ptr, a, len); - ptr[ len ] = '\0'; - /* Can't barf() here, so the NUL byte check happens in Scheme */ - } - else ptr = NULL; - where[ i ] = ptr; -} - -static void C_fcall C_free_arg_string(char **where) { - while((*where) != NULL) C_free(*(where++)); -} - -#define C_set_exec_arg(i, a, len) C_set_arg_string(C_exec_args, i, a, len) -#define C_free_exec_args() C_free_arg_string(C_exec_args) -#define C_set_exec_env(i, a, len) C_set_arg_string(C_exec_env, i, a, len) -#define C_free_exec_env() C_free_arg_string(C_exec_env) - -#define C_execvp(f) C_fix(execvp(C_data_pointer(f), C_exec_args)) -#define C_execve(f) C_fix(execve(C_data_pointer(f), C_exec_args, C_exec_env)) +#define C_u_i_execvp(f,a) C_fix(execvp(C_data_pointer(f), (char *const *)C_c_pointer_vector_or_null(a))) +#define C_u_i_execve(f,a,e) C_fix(execve(C_data_pointer(f), (char *const *)C_c_pointer_vector_or_null(a), (char *const *)C_c_pointer_vector_or_null(e))) #if defined(__FreeBSD__) || defined(C_MACOSX) || defined(__NetBSD__) || defined(__OpenBSD__) || defined(__sgi__) || defined(sgi) || defined(__DragonFly__) || defined(__SUNPRO_C) static C_TLS int C_uw; @@ -1447,43 +1417,15 @@ EOF (exit 0))) pid))))) -(define process-execute - ;; NOTE: We use c-string here instead of scheme-object. - ;; Because set_exec_* make a copy, this implies a double copy. - ;; At least it's secure, we can worry about performance later, if at all - (let ([setarg (foreign-lambda void "C_set_exec_arg" int c-string int)] - [freeargs (foreign-lambda void "C_free_exec_args")] - [setenv (foreign-lambda void "C_set_exec_env" int c-string int)] - [freeenv (foreign-lambda void "C_free_exec_env")] - [pathname-strip-directory pathname-strip-directory] ) - (lambda (filename #!optional (arglist '()) envlist) - (##sys#check-string filename 'process-execute) - (##sys#check-list arglist 'process-execute) - (let ([s (pathname-strip-directory filename)]) - (setarg 0 s (##sys#size s)) ) - (do ([al arglist (cdr al)] - [i 1 (fx+ i 1)] ) - ((null? al) - (setarg i #f 0) - (when envlist - (##sys#check-list envlist 'process-execute) - (do ([el envlist (cdr el)] - [i 0 (fx+ i 1)] ) - ((null? el) (setenv i #f 0)) - (let ([s (car el)]) - (##sys#check-string s 'process-execute) - (setenv i s (##sys#size s)) ) ) ) - (let* ([prg (##sys#make-c-string filename 'process-execute)] - [r (if envlist - (##core#inline "C_execve" prg) - (##core#inline "C_execvp" prg) )] ) - (when (fx= r -1) - (freeargs) - (freeenv) - (posix-error #:process-error 'process-execute "cannot execute process" filename) ) ) ) - (let ([s (car al)]) - (##sys#check-string s 'process-execute) - (setarg i s (##sys#size s)) ) ) ) ) ) +(define (process-execute filename #!optional (arglist '()) envlist) + (call-with-exec-args + 'process-execute filename (lambda (x) x) arglist envlist + (lambda (prg argbuf envbuf) + (let ((r (if envbuf + (##core#inline "C_u_i_execve" prg argbuf envbuf) + (##core#inline "C_u_i_execvp" prg argbuf) )) ) + (when (fx= r -1) + (posix-error #:process-error 'process-execute "cannot execute process" filename) ) ))) ) (define-foreign-variable _wnohang int "WNOHANG") (define-foreign-variable _wait-status int "C_wait_status") diff --git a/posixwin.scm b/posixwin.scm index 9ad9eff..1ef9498 100644 --- a/posixwin.scm +++ b/posixwin.scm @@ -62,9 +62,9 @@ (declare (unit posix) - (uses scheduler data-structures irregex pathname ports) + (uses scheduler data-structures irregex extras pathname files ports lolevel) (disable-interrupts) - (hide $quote-args-list $exec-setup $exec-teardown) + (hide quote-arg-string) (not inline ##sys#interrupt-hook ##sys#user-interrupt-hook) (foreign-declare #< #include -#define ARG_MAX 256 #define PIPE_BUF 512 -#ifndef ENV_MAX -# define ENV_MAX 1024 -#endif -static C_TLS char *C_exec_args[ ARG_MAX ]; -static C_TLS char *C_exec_env[ ENV_MAX ]; static C_TLS int C_pipefds[ 2 ]; static C_TLS time_t C_secs; @@ -209,39 +203,12 @@ readdir(DIR * dir) #define C_lstat(fn) C_stat(fn) -static void C_fcall -C_set_arg_string(char **where, int i, char *dat, int len) -{ - char *ptr; - if (dat) - { - ptr = (char *)C_malloc(len + 1); - C_memcpy(ptr, dat, len); - ptr[ len ] = '\0'; - /* Can't barf() here, so the NUL byte check happens in Scheme */ - } - else - ptr = NULL; - where[ i ] = ptr; -} - -static void C_fcall -C_free_arg_string(char **where) { - while (*where) C_free(*(where++)); -} - -#define C_set_exec_arg(i, a, len) C_set_arg_string(C_exec_args, i, a, len) -#define C_set_exec_env(i, a, len) C_set_arg_string(C_exec_env, i, a, len) - -#define C_free_exec_args() (C_free_arg_string(C_exec_args), C_SCHEME_TRUE) -#define C_free_exec_env() (C_free_arg_string(C_exec_env), C_SCHEME_TRUE) - -#define C_execvp(f) C_fix(execvp(C_data_pointer(f), (const char *const *)C_exec_args)) -#define C_execve(f) C_fix(execve(C_data_pointer(f), (const char *const *)C_exec_args, (const char *const *)C_exec_env)) +#define C_u_i_execvp(f,a) C_fix(execvp(C_data_pointer(f), (const char *const *)C_c_pointer_vector_or_null(a))) +#define C_u_i_execve(f,a,e) C_fix(execve(C_data_pointer(f), (const char *const *)C_c_pointer_vector_or_null(a), (const char *const *)C_c_pointer_vector_or_null(e))) /* MS replacement for the fork-exec pair */ -#define C_spawnvp(m, f) C_fix(spawnvp(C_unfix(m), C_data_pointer(f), (const char *const *)C_exec_args)) -#define C_spawnvpe(m, f) C_fix(spawnvpe(C_unfix(m), C_data_pointer(f), (const char *const *)C_exec_args, (const char *const *)C_exec_env)) +#define C_u_i_spawnvp(m,f,a) C_fix(spawnvp(C_unfix(m), C_data_pointer(f), (const char *const *)C_c_pointer_vector_or_null(a))) +#define C_u_i_spawnvpe(m,f,a,e) C_fix(spawnvpe(C_unfix(m), C_data_pointer(f), (const char *const *)C_c_pointer_vector_or_null(a), (const char *const *)C_c_pointer_vector_or_null(e))) #define C_open(fn, fl, m) C_fix(open(C_c_string(fn), C_unfix(fl), C_unfix(m))) #define C_read(fd, b, n) C_fix(read(C_unfix(fd), C_data_pointer(b), C_unfix(n))) @@ -707,6 +674,7 @@ EOF chicken.data-structures chicken.foreign chicken.irregex + chicken.memory chicken.pathname chicken.ports chicken.random @@ -1167,74 +1135,45 @@ EOF ; Windows uses a commandline style for process arguments. Thus any ; arguments with embedded whitespace will parse incorrectly. Must ; string-quote such arguments. -(define $quote-args-list - (lambda (lst exactf) - (if exactf - lst - (let ([needs-quoting? - ; This is essentially (string-any char-whitespace? s) but we don't - ; want a SRFI-13 dependency. (Do we?) - (lambda (s) - (let ([len (string-length s)]) - (let loop ([i 0]) - (cond - [(fx= i len) #f] - [(char-whitespace? (string-ref s i)) #t] - [else (loop (fx+ i 1))]))))]) - (let loop ([ilst lst] [olst '()]) - (if (null? ilst) - (##sys#fast-reverse olst) - (let ([str (car ilst)]) - (loop - (cdr ilst) - (cons - (if (needs-quoting? str) (string-append "\"" str "\"") str) - olst)) ) ) ) ) ) ) ) - -(define $exec-setup - ;; NOTE: We use c-string here instead of scheme-object. - ;; Because set_exec_* make a copy, this implies a double copy. - ;; At least it's secure, we can worry about performance later, if at all - (let ([setarg (foreign-lambda void "C_set_exec_arg" int c-string int)] - [setenv (foreign-lambda void "C_set_exec_env" int c-string int)] - [build-exec-argvec - (lambda (loc lst argvec-setter idx) - (if lst - (begin - (##sys#check-list lst loc) - (do ([l lst (cdr l)] - [i idx (fx+ i 1)] ) - ((null? l) (argvec-setter i #f 0)) - (let ([s (car l)]) - (##sys#check-string s loc) - (argvec-setter i s (##sys#size s)) ) ) ) - (argvec-setter idx #f 0) ) )]) - (lambda (loc filename arglst envlst exactf) - (##sys#check-string filename loc) - (let ([s (pathname-strip-directory filename)]) - (setarg 0 s (##sys#size s)) ) - (build-exec-argvec loc (and arglst ($quote-args-list arglst exactf)) setarg 1) - (build-exec-argvec loc envlst setenv 0) - (##core#inline "C_flushall") - (##sys#make-c-string filename loc) ) ) ) - -(define ($exec-teardown loc msg filename res) - (##sys#update-errno) - (##core#inline "C_free_exec_args") - (##core#inline "C_free_exec_env") - (if (fx= res -1) - (##sys#error loc msg filename) - res ) ) - -(define (process-execute filename #!optional arglst envlst exactf) - (let ([prg ($exec-setup 'process-execute filename arglst envlst exactf)]) - ($exec-teardown 'process-execute "cannot execute process" filename - (if envlst (##core#inline "C_execve" prg) (##core#inline "C_execvp" prg))) ) ) - -(define (process-spawn mode filename #!optional arglst envlst exactf) - (let ([prg ($exec-setup 'process-spawn filename arglst envlst exactf)]) - ($exec-teardown 'process-spawn "cannot spawn process" filename - (if envlst (##core#inline "C_spawnvpe" mode prg) (##core#inline "C_spawnvp" mode prg))) ) ) +(define quote-arg-string + (let ((needs-quoting? + ;; This is essentially (string-any char-whitespace? s) but we + ;; don't want a SRFI-13 dependency. (Do we?) + (lambda (s) + (let ((len (string-length s))) + (let loop ((i 0)) + (cond + ((fx= i len) #f) + ((char-whitespace? (string-ref s i)) #t) + (else (loop (fx+ i 1)))) ) )) )) + (lambda (str) + (if (needs-quoting? str) (string-append "\"" str "\"") str) ) ) ) + +(define (process-execute filename #!optional (arglist '()) envlist exactf) + (let ((argconv (if exactf (lambda (x) x) quote-arg-string))) + (call-with-exec-args + 'process-execute filename argconv arglist envlist + (lambda (prg argbuf envbuf) + (##core#inline "C_flushall") + (let ((r (if envbuf + (##core#inline "C_u_i_execve" prg argbuf envbuf) + (##core#inline "C_u_i_execvp" prg argbuf) )) ) + (when (fx= r -1) + (posix-error #:process-error 'process-execute "cannot execute process" filename) ) ) )) ) ) + +(define (process-spawn mode filename #!optional (arglist '()) envlist exactf) + (let ((argconv (if exactf (lambda (x) x) quote-arg-string))) + (##sys#check-exact mode 'process-spawn) + + (call-with-exec-args + 'process-spawn filename argconv arglist envlist + (lambda (prg argbuf envbuf) + (##core#inline "C_flushall") + (let ((r (if envbuf + (##core#inline "C_u_i_spawnvpe" mode prg argbuf envbuf) + (##core#inline "C_u_i_spawnvp" mode prg argbuf) )) ) + (when (fx= r -1) + (posix-error #:process-error 'process-spawn "cannot spawn process" filename) ) ) )) ) ) (define-foreign-variable _shlcmd c-string "C_shlcmd") @@ -1283,7 +1222,11 @@ EOF ; information for the system drives. i.e !C:=... ; For now any environment is ignored. (lambda (loc cmd args env stdoutf stdinf stderrf #!optional exactf) - (let ([cmdlin (string-intersperse ($quote-args-list (cons cmd args) exactf))]) + (let* ((arglist (cons cmd args)) + (cmdlin (string-intersperse + (if exactf + arglist + (map quote-arg-string arglist))))) (let-location ([handle int -1] [stdin_fd int -1] [stdout_fd int -1] [stderr_fd int -1]) (let ([res diff --git a/rules.make b/rules.make index 17e7da4..29f4896 100644 --- a/rules.make +++ b/rules.make @@ -717,6 +717,7 @@ posixunix.c: posixunix.scm \ chicken.bitwise.import.scm \ chicken.foreign.import.scm \ chicken.irregex.import.scm \ + chicken.memory.import.scm \ chicken.pathname.import.scm \ chicken.ports.import.scm \ chicken.time.import.scm @@ -724,6 +725,7 @@ posixwin.c: posixwin.scm \ chicken.bitwise.import.scm \ chicken.foreign.import.scm \ chicken.irregex.import.scm \ + chicken.memory.import.scm \ chicken.pathname.import.scm \ chicken.ports.import.scm \ chicken.time.import.scm -- 2.1.4