diff --git a/src/filesystem_utilities.c b/src/filesystem_utilities.c index 73f0c8aaa9..f398119a2b 100644 --- a/src/filesystem_utilities.c +++ b/src/filesystem_utilities.c @@ -1,6 +1,24 @@ #include #include +#ifndef _WIN32 +#include +#include +#include +#include +#include +#include +#include + +extern char **environ; +#endif + +#ifdef _WIN32 +#include +#include +#include +#endif + #if defined(__APPLE__) && !defined(__aarch64__) && !defined(__ppc__) && !defined(__i386__) DIR * opendir$INODE64( const char * dirName ); struct dirent * readdir$INODE64( DIR * dir ); @@ -29,3 +47,218 @@ struct dirent *c_readdir(DIR *dirp) { return readdir(dirp); } + +#ifdef _WIN32 +/* Quote one argv token using the CommandLineToArgvW rules so that + CreateProcess reconstructs the exact token. Caller frees the result. */ +static char *win_quote_arg(const char *arg) +{ + size_t len = strlen(arg); + size_t i; + int needs = (len == 0); + char *out; + char *q; + + for (i = 0; i < len; ++i) { + char c = arg[i]; + if (c == ' ' || c == '\t' || c == '\n' || c == '\v' || c == '"') { + needs = 1; + break; + } + } + + if (!needs) { + out = (char *)malloc(len + 1); + if (out) memcpy(out, arg, len + 1); + return out; + } + + out = (char *)malloc(2 * len + 3); + if (!out) return NULL; + q = out; + *q++ = '"'; + for (i = 0; i < len;) { + size_t nbs = 0; + size_t k; + while (i < len && arg[i] == '\\') { ++nbs; ++i; } + if (i == len) { + for (k = 0; k < 2 * nbs; ++k) *q++ = '\\'; + break; + } else if (arg[i] == '"') { + for (k = 0; k < 2 * nbs + 1; ++k) *q++ = '\\'; + *q++ = '"'; + ++i; + } else { + for (k = 0; k < nbs; ++k) *q++ = '\\'; + *q++ = arg[i++]; + } + } + *q++ = '"'; + *q = '\0'; + return out; +} +#endif + +int c_run_argv(const char *joined, int argc, const char *redirect) +{ +#ifdef _WIN32 + const char *p = joined; + int i; + int use_redirect = redirect != NULL && redirect[0] != '\0'; + const char **argv = NULL; + char *cmd = NULL; + size_t cap = 1, n = 0; + char apppath[MAX_PATH]; + char *appname = NULL; + DWORD found; + HANDLE hout = INVALID_HANDLE_VALUE; + SECURITY_ATTRIBUTES sa; + STARTUPINFOA si; + PROCESS_INFORMATION pi; + BOOL ok; + int result; + + if (argc < 1) return 0; + + argv = (const char **)calloc((size_t)argc + 1, sizeof(char *)); + if (argv == NULL) return -1; + for (i = 0; i < argc; ++i) { + argv[i] = p; + p += strlen(p) + 1; + } + + /* Reassemble a properly quoted command line for CreateProcess. */ + cmd = (char *)malloc(cap); + if (cmd == NULL) { free((void *)argv); return -1; } + cmd[0] = '\0'; + for (i = 0; i < argc; ++i) { + char *qa = win_quote_arg(argv[i]); + size_t ql; + size_t need; + if (qa == NULL) { free(cmd); free((void *)argv); return -1; } + ql = strlen(qa); + need = n + ql + 2; + if (need > cap) { + char *t; + cap = need * 2; + t = (char *)realloc(cmd, cap); + if (t == NULL) { free(qa); free(cmd); free((void *)argv); return -1; } + cmd = t; + } + if (i > 0) cmd[n++] = ' '; + memcpy(cmd + n, qa, ql); + n += ql; + cmd[n] = '\0'; + free(qa); + } + + /* Resolve the program through PATH with a default .exe extension. */ + found = SearchPathA(NULL, argv[0], ".exe", MAX_PATH, apppath, NULL); + if (found > 0 && found < MAX_PATH) appname = apppath; + + ZeroMemory(&si, sizeof(si)); + si.cb = sizeof(si); + ZeroMemory(&pi, sizeof(pi)); + + /* Only override the child's std handles when redirecting. Setting + STARTF_USESTDHANDLES with the (often non-inheritable) console handles + can strip the child's console, so leave them alone otherwise and let + the child inherit the parent console normally. */ + if (use_redirect) { + ZeroMemory(&sa, sizeof(sa)); + sa.nLength = sizeof(sa); + sa.bInheritHandle = TRUE; + hout = CreateFileA(redirect, GENERIC_WRITE, FILE_SHARE_READ, &sa, + CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL); + if (hout == INVALID_HANDLE_VALUE) { free(cmd); free((void *)argv); return -1; } + si.dwFlags |= STARTF_USESTDHANDLES; + si.hStdInput = GetStdHandle(STD_INPUT_HANDLE); + si.hStdOutput = hout; + si.hStdError = hout; + } + + ok = CreateProcessA(appname, cmd, NULL, NULL, use_redirect, 0, NULL, NULL, &si, &pi); + if (!ok) { + result = -1; + } else { + DWORD code = 1; + WaitForSingleObject(pi.hProcess, INFINITE); + GetExitCodeProcess(pi.hProcess, &code); + CloseHandle(pi.hProcess); + CloseHandle(pi.hThread); + /* Keep a real (possibly high-bit) exit code positive so the caller + does not mistake it for the stat < 0 spawn-failure sentinel. */ + result = (code > 0x7fffffff) ? 1 : (int)code; + } + + if (hout != INVALID_HANDLE_VALUE) CloseHandle(hout); + free(cmd); + free((void *)argv); + return result; +#else + char **argv = NULL; + const char *p = joined; + pid_t pid; + int spawn_status; + int wait_status; + int i; + int use_redirect = redirect != NULL && redirect[0] != '\0'; + posix_spawn_file_actions_t actions; + posix_spawn_file_actions_t *actions_ptr = NULL; + + if (argc < 1) { + return 0; + } + + argv = calloc((size_t)argc + 1, sizeof(char *)); + if (argv == NULL) { + return -1; + } + + for (i = 0; i < argc; ++i) { + argv[i] = (char *)p; + p += strlen(p) + 1; + } + + if (use_redirect) { + if (posix_spawn_file_actions_init(&actions) != 0) { + free(argv); + return -1; + } + actions_ptr = &actions; + if (posix_spawn_file_actions_addopen(&actions, STDOUT_FILENO, redirect, + O_WRONLY | O_CREAT | O_TRUNC, 0666) != 0 || + posix_spawn_file_actions_adddup2(&actions, STDOUT_FILENO, STDERR_FILENO) != 0) { + posix_spawn_file_actions_destroy(&actions); + free(argv); + return -1; + } + } + + spawn_status = posix_spawnp(&pid, argv[0], actions_ptr, NULL, argv, environ); + if (use_redirect) { + posix_spawn_file_actions_destroy(&actions); + } + free(argv); + + if (spawn_status != 0) { + return spawn_status; + } + + do { + spawn_status = waitpid(pid, &wait_status, 0); + } while (spawn_status < 0 && errno == EINTR); + + if (spawn_status < 0) { + return -1; + } + + if (WIFEXITED(wait_status)) { + return WEXITSTATUS(wait_status); + } + if (WIFSIGNALED(wait_status)) { + return 128 + WTERMSIG(wait_status); + } + return -1; +#endif +} diff --git a/src/fpm_compiler.F90 b/src/fpm_compiler.F90 index 711f13aae3..214dd915ba 100644 --- a/src/fpm_compiler.F90 +++ b/src/fpm_compiler.F90 @@ -38,9 +38,10 @@ module fpm_compiler OS_FREEBSD, & OS_OPENBSD, & OS_UNKNOWN, & + os_is_unix, & library_filename use fpm_filesystem, only: join_path, basename, get_temp_filename, delete_file, unix_path, & - & getline, run + & getline, run, run_argv use fpm_strings, only: split, string_cat, string_t, str_ends_with, str_begins_with_str, & & string_array_contains, lower, add_strings use fpm_error, only: error_t, fatal_error, fpm_stop @@ -1427,8 +1428,9 @@ subroutine compile_fortran(self, input, output, args, log_file, stat, table, dry logical, optional, intent(in) :: dry_run character(len=:), allocatable :: command + type(string_t), allocatable :: argv(:) type(error_t), allocatable :: error - logical :: mock + logical :: mock, tokenized ! Initialize intent(out) status so the mock path with no table returns ! a defined value. @@ -1438,12 +1440,32 @@ subroutine compile_fortran(self, input, output, args, log_file, stat, table, dry mock = .false. if (present(dry_run)) mock = dry_run - ! Set command + ! Set command (shell fallback string) and build the argv token list. The + ! command is split with the OS-native lexer (POSIX on Unix, Windows rules + ! otherwise) so quoting and backslash paths survive on both platforms. command = self%fc // " -c " // input // " " // args // " -o " // output + tokenized = .true. + call split_append(argv, self%fc, .false., .false., tokenized) + if (tokenized) then + call add_strings(argv, string_t("-c")) + call add_strings(argv, string_t(input)) + end if + if (tokenized .and. len_trim(args) > 0) then + call split_append(argv, args, .true., .true., tokenized) + end if + if (tokenized) then + call add_strings(argv, string_t("-o")) + call add_strings(argv, string_t(output)) + end if + ! Execute command if (.not.mock) then - call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) + if (tokenized) then + call run_argv(argv, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) + else + call run(command, echo=self%echo, verbose=self%verbose, redirect=log_file, exitstat=stat) + end if if (stat/=0) return endif @@ -1453,6 +1475,60 @@ subroutine compile_fortran(self, input, output, args, log_file, stat, table, dry stat = merge(-1,0,allocated(error)) endif +contains + + !> Split a command fragment into argv tokens with the OS-native lexer and + !> append them to argv. fortran-shlex is not reentrant, so the split runs + !> in a critical region. join_spaced/keep_quotes apply to the POSIX lexer; + !> the Windows lexer already returns final argv tokens. + subroutine split_append(argv, str, join_spaced, keep_quotes, ok) + type(string_t), allocatable, intent(inout) :: argv(:) + character(len=*), intent(in) :: str + logical, intent(in) :: join_spaced, keep_quotes + logical, intent(inout) :: ok + + character(len=:), allocatable :: parts(:) + integer :: k + + if (.not.ok) return + + !$omp critical(fpm_shlex_split) + if (os_is_unix()) then + parts = sh_split(str, join_spaced=join_spaced, keep_quotes=keep_quotes, success=ok) + else + parts = ms_split(str, success=ok) + end if + !$omp end critical(fpm_shlex_split) + if (.not.ok) return + + do k = 1, size(parts) + if (len_trim(parts(k)) == 0) cycle + if (os_is_unix()) then + call add_strings(argv, string_t(clean_shlex_token(parts(k)))) + else + call add_strings(argv, string_t(trim(parts(k)))) + end if + end do + end subroutine split_append + + function clean_shlex_token(token) result(clean) + character(len=*), intent(in) :: token + character(len=:), allocatable :: clean + + integer :: j + + clean = "" + do j = 1, len_trim(token) + select case (token(j:j)) + case ("'", '"') + cycle + case default + clean = clean//token(j:j) + end select + end do + clean = trim(adjustl(clean)) + end function clean_shlex_token + end subroutine compile_fortran diff --git a/src/fpm_filesystem.F90 b/src/fpm_filesystem.F90 index 6b22f498f9..91d18b8ba2 100644 --- a/src/fpm_filesystem.F90 +++ b/src/fpm_filesystem.F90 @@ -8,7 +8,7 @@ module fpm_filesystem OS_CYGWIN, OS_SOLARIS, OS_FREEBSD, OS_OPENBSD use fpm_environment, only: separator, get_env, os_is_unix use fpm_strings, only: f_string, replace, string_t, split, split_lines_first_last, dilate, add_strings, & - str_begins_with_str + str_begins_with_str, string_cat use iso_c_binding, only: c_char, c_ptr, c_int, c_null_char, c_associated, c_f_pointer use fpm_error, only : fpm_stop, error_t, fatal_error implicit none @@ -16,7 +16,7 @@ module fpm_filesystem public :: basename, canon_path, dirname, is_dir, join_path, number_of_rows, list_files, get_local_prefix, & mkdir, exists, get_temp_filename, windows_path, unix_path, getline, delete_file, fileopen, fileclose, & filewrite, warnwrite, parent_dir, is_hidden_file, read_lines, read_lines_expanded, which, run, & - os_delete_dir, is_absolute_path, get_home, execute_and_read_output, get_dos_path + run_argv, os_delete_dir, is_absolute_path, get_home, execute_and_read_output, get_dos_path #ifndef FPM_BOOTSTRAP interface @@ -49,6 +49,13 @@ function c_is_dir(path) result(r) bind(c, name="c_is_dir") character(kind=c_char), intent(in) :: path(*) integer(kind=c_int) :: r end function c_is_dir + + function c_run_argv(joined, argc, redirect) result(r) bind(c, name="c_run_argv") + import c_char, c_int + character(kind=c_char), intent(in) :: joined(*), redirect(*) + integer(kind=c_int), intent(in), value :: argc + integer(kind=c_int) :: r + end function c_run_argv end interface #endif @@ -1060,6 +1067,97 @@ subroutine run(cmd,echo,exitstat,verbose,redirect) end subroutine run +subroutine run_argv(args,echo,exitstat,verbose,redirect) + type(string_t), intent(in) :: args(:) + logical,intent(in),optional :: echo + integer, intent(out),optional :: exitstat + logical, intent(in), optional :: verbose + character(*), intent(in), optional :: redirect + + character(:), allocatable :: command + character(:), allocatable :: joined + character(:), allocatable :: redirect_file + character(:), allocatable :: line + character(len=256) :: iomsg + logical :: echo_local, verbose_local + integer :: stat, fh, iostat, i + + command = string_cat(args, " ") + + if(present(echo))then + echo_local=echo + else + echo_local=.true. + end if + + if(present(verbose))then + verbose_local=verbose + else + verbose_local=.true. + end if + + if (present(redirect)) then + redirect_file = redirect + else + if(verbose_local)then + redirect_file = "" + else + if (os_is_unix()) then + redirect_file = "/dev/null" + else + redirect_file = "NUL" + end if + end if + end if + + if(echo_local) print *, '+ ', command + + if (size(args) < 1) then + stat = 0 +#ifndef FPM_BOOTSTRAP + else + joined = "" + do i = 1, size(args) + joined = joined//args(i)%s//c_null_char + end do + stat = c_run_argv(joined//c_null_char, int(size(args), c_int), & + redirect_file//c_null_char) +#else + else + call run(command, echo=.false., verbose=verbose_local, redirect=redirect_file, exitstat=stat) +#endif + end if + + ! Fall back to the shell if the argv spawn was unavailable or failed (stat < 0). + if (stat < 0) then + call run(command, echo=.false., verbose=verbose_local, redirect=redirect_file, exitstat=stat) + end if + + if (verbose_local.and.present(redirect)) then + + open(newunit=fh,file=redirect,status='old',iostat=iostat,iomsg=iomsg) + if(iostat == 0)then + do + call getline(fh, line, iostat) + if (iostat /= 0) exit + write(*,'(A)') trim(line) + end do + else + write(*,'(A)') trim(iomsg) + endif + + close(fh) + + end if + + if (present(exitstat)) then + exitstat = stat + elseif (stat /= 0) then + call fpm_stop(stat,'*run_argv*: Command '//command//' returned a non-zero status code') + end if + +end subroutine run_argv + !> Delete directory using system OS remove directory commands subroutine os_delete_dir(is_unix, dir, echo) logical, intent(in) :: is_unix