Commit c43c16b3 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Use os-cond in more places.

parent d32057a3
...@@ -174,14 +174,16 @@ Going forward, we recommend new users should be using the source-registry. ...@@ -174,14 +174,16 @@ Going forward, we recommend new users should be using the source-registry.
:truename truename)) :truename truename))
(return file)) (return file))
#-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
(when (and (os-windows-p) (physical-pathname-p defaults)) (os-cond
(let ((shortcut ((os-windows-p)
(make-pathname (when (physical-pathname-p defaults)
:defaults defaults :case :local (let ((shortcut
:name (strcat name ".asd") (make-pathname
:type "lnk"))) :defaults defaults :case :local
(when (probe-file* shortcut) :name (strcat name ".asd")
(ensure-pathname (parse-windows-shortcut shortcut) :namestring :native))))))) :type "lnk")))
(when (probe-file* shortcut)
(ensure-pathname (parse-windows-shortcut shortcut) :namestring :native)))))))))
(defun sysdef-central-registry-search (system) (defun sysdef-central-registry-search (system)
(let ((name (primary-system-name system)) (let ((name (primary-system-name system))
......
...@@ -331,7 +331,8 @@ this function tries to locate the Windows FOLDER for one of ...@@ -331,7 +331,8 @@ this function tries to locate the Windows FOLDER for one of
(defun config-system-pathnames (&optional app &rest more) (defun config-system-pathnames (&optional app &rest more)
"Determine system user configuration directories" "Determine system user configuration directories"
(when (os-unix-p) (list (resolve-location `(,(parse-unix-namestring "/etc/") ,app ,more))))) (os-cond
((os-unix-p) (list (resolve-location `(,(parse-unix-namestring "/etc/") ,app ,more))))))
(defun clean-search-pathnames (dirs) (defun clean-search-pathnames (dirs)
"Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list" "Parse strings as unix namestrings and remove duplicates and non absolute-pathnames in a list"
......
...@@ -37,8 +37,9 @@ ...@@ -37,8 +37,9 @@
#+(or cmu scl) (ext:unix-namestring p nil) #+(or cmu scl) (ext:unix-namestring p nil)
#+sbcl (sb-ext:native-namestring p) #+sbcl (sb-ext:native-namestring p)
#-(or clozure cmu sbcl scl) #-(or clozure cmu sbcl scl)
(if (os-unix-p) (unix-namestring p) (os-cond
(namestring p))))) ((os-unix-p) (unix-namestring p))
(t (namestring p))))))
(defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys) (defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys)
"From a native namestring suitable for use by the operating system, return "From a native namestring suitable for use by the operating system, return
...@@ -50,9 +51,9 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" ...@@ -50,9 +51,9 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
#+clozure (ccl:native-to-pathname string) #+clozure (ccl:native-to-pathname string)
#+sbcl (sb-ext:parse-native-namestring string) #+sbcl (sb-ext:parse-native-namestring string)
#-(or clozure sbcl) #-(or clozure sbcl)
(if (os-unix-p) (os-cond
(parse-unix-namestring string :ensure-directory ensure-directory) ((os-unix-p) (parse-unix-namestring string :ensure-directory ensure-directory))
(parse-namestring string))))) (t (parse-namestring string))))))
(pathname (pathname
(if ensure-directory (if ensure-directory
(and pathname (ensure-directory-pathname pathname)) (and pathname (ensure-directory-pathname pathname))
...@@ -501,7 +502,7 @@ Note that this operation is usually NOT thread-safe." ...@@ -501,7 +502,7 @@ Note that this operation is usually NOT thread-safe."
(with-upgradability () (with-upgradability ()
(defun inter-directory-separator () (defun inter-directory-separator ()
"What character does the current OS conventionally uses to separate directories?" "What character does the current OS conventionally uses to separate directories?"
(if (os-unix-p) #\: #\;)) (os-cond ((os-unix-p) #\:) (t #\;)))
(defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys) (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
"Given a string of pathnames specified in native OS syntax, separate them in a list, "Given a string of pathnames specified in native OS syntax, separate them in a list,
......
...@@ -656,9 +656,10 @@ given DEFAULTS-PATHNAME as a base pathname." ...@@ -656,9 +656,10 @@ given DEFAULTS-PATHNAME as a base pathname."
(defun directorize-pathname-host-device (pathname) (defun directorize-pathname-host-device (pathname)
"Given a PATHNAME, return a pathname that has representations of its HOST and DEVICE components "Given a PATHNAME, return a pathname that has representations of its HOST and DEVICE components
added to its DIRECTORY component. This is useful for output translations." added to its DIRECTORY component. This is useful for output translations."
#+(or unix abcl) (os-cond
(when (and #+abcl (os-unix-p) (physical-pathname-p pathname)) ((os-unix-p)
(return-from directorize-pathname-host-device pathname)) (when (physical-pathname-p pathname)
(return-from directorize-pathname-host-device pathname))))
(let* ((root (pathname-root pathname)) (let* ((root (pathname-root pathname))
(wild-root (wilden root)) (wild-root (wilden root))
(absolute-pathname (merge-pathnames* pathname root)) (absolute-pathname (merge-pathnames* pathname root))
......
...@@ -739,7 +739,9 @@ It returns a process-info plist with possible keys: ...@@ -739,7 +739,9 @@ It returns a process-info plist with possible keys:
(etypecase command (etypecase command
(string command) (string command)
(list (escape-shell-command (list (escape-shell-command
(if (os-unix-p) (cons "exec" command) command))))) (os-cond
((os-unix-p) (cons "exec" command))
(t command))))))
(defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM
(flet ((redirect (spec operator) (flet ((redirect (spec operator)
...@@ -756,14 +758,16 @@ It returns a process-info plist with possible keys: ...@@ -756,14 +758,16 @@ It returns a process-info plist with possible keys:
(escape-shell-token (native-namestring pathname))))))) (escape-shell-token (native-namestring pathname)))))))
(multiple-value-bind (before after) (multiple-value-bind (before after)
(let ((normalized (%normalize-system-command command))) (let ((normalized (%normalize-system-command command)))
(if (os-unix-p) (os-cond
(values '("exec") (list " ; " normalized)) ((os-unix-p) (values '("exec") (list " ; " normalized)))
(values (list normalized) ()))) (t (values (list normalized) ()))))
(reduce/strcat (reduce/strcat
(append (append
before (redirect in " <") (redirect out " >") (redirect err " 2>") before (redirect in " <") (redirect out " >") (redirect err " 2>")
(when (and directory (os-unix-p)) ;; NB: unless on Unix, %system uses with-current-directory (os-cond
`(" ; cd " ,(escape-shell-token (native-namestring directory)))) ((os-unix-p)
(when directory ;; NB: unless on Unix, %system uses with-current-directory
`(" ; cd " ,(escape-shell-token (native-namestring directory))))))
after))))) after)))))
(defun %system (command &rest keys (defun %system (command &rest keys
...@@ -782,7 +786,7 @@ It returns a process-info plist with possible keys: ...@@ -782,7 +786,7 @@ It returns a process-info plist with possible keys:
(apply '%run-program %command :wait t (apply '%run-program %command :wait t
:input :interactive :output :interactive :error-output :interactive keys)) :input :interactive :output :interactive :error-output :interactive keys))
#-(or clisp (and lispworks os-windows)) #-(or clisp (and lispworks os-windows))
(with-current-directory ((unless (os-unix-p) directory)) (with-current-directory ((os-cond ((not (os-unix-p)) directory)))
#+abcl (ext:run-shell-command %command) #+abcl (ext:run-shell-command %command)
#+cormanlisp (win32:system %command) #+cormanlisp (win32:system %command)
#+(or clasp ecl) (let ((*standard-input* *stdin*) #+(or clasp ecl) (let ((*standard-input* *stdin*)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment