From af26ff8c2bc0741eaca3a3f3c59ddd60227f38a3 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Mon, 1 Nov 2021 07:19:58 -0700
Subject: rel-path, path-equal: native Windows fixes.
The checks for native Windows are incorrect, plus there
are some issues in the path-volume function.
We cannot check for native Windows at macro-expansion time simply by
calling (find #\\ path-sep-chars) because we compile on Cygwin where
that is false. What we must do is check for being on Windows at
macro-expansion time, and then in the "yes" branch of that decision, the
code must perform the path-sep-char test at run-time. In the "no"
branch, we can output smaller code that doesn't deal with Windows.
* stdlib/copy-file.tl (if-windows, if-native-windows): New macro, which
give a clear syntax to the above described testing.
(path-split): Use if-native-windows.
(path-volume): Use if-native-windows. In addition, fix some broken
tests. The tests for a UNC path "//whatever" cannot just test that the
first components are "", because that also matches the path "/".
It has t be that the first two components are "", and there are more
components. A similar issue occurs in the situation when there is
a drive letter. We cannot conclude that if the component after the
drive letter is "", then it's a drive absolute path, because that
situation occurs in a path like "c:" which is relative.
We also destructively manipulate the path to splice out the volume
part and turn it into a simple relative or absolute path. This is
because the path-simplify function deosn't deal with the volume prefix;
its logic like eliminating .. navigations from root do not work if the
prefix component is present.
(rel-path): We handle a missing error case here: one path has volume
prefix and the other doesn't. Also the error cases that can only occur
on Windows are wrapped with if-windows to remove them at compile time.
---
stdlib/copy-file.tl | 62 +++++++++++++++++++++++++++++++++++++----------------
1 file changed, 43 insertions(+), 19 deletions(-)
(limited to 'stdlib')
diff --git a/stdlib/copy-file.tl b/stdlib/copy-file.tl
index 258192fc..3198b76e 100644
--- a/stdlib/copy-file.tl
+++ b/stdlib/copy-file.tl
@@ -225,9 +225,20 @@
(t (push c out))))
(nreverse out)))
+(eval-only
+ (defmacro if-windows (then : else)
+ (if (eql 2 (sizeof wchar))
+ then
+ else))
+
+ (defmacro if-native-windows (then else)
+ (if-windows
+ ^(if (find #\\ path-sep-chars) ,then ,else)
+ else)))
+
(defun path-split (str)
(let ((spl0 (sspl path-sep-chars str)))
- (if (macro-time (find #\\ path-sep-chars))
+ (if-native-windows
(iflet ((head (car spl0))
(p (pos #\: head)))
(list* [head 0..(succ p)]
@@ -237,18 +248,25 @@
spl0)))
(defun path-volume (comp)
- (let ((head (car comp))
- (next (cadr comp)))
- (if (macro-time (find #\\ path-sep-chars))
- (cond
- ((and (equal head "") (equal next ""))
- (let ((vol (caddr comp)))
- (if (nequal "" vol) vol :abs)))
- ((equal head "") :abs)
- ((and (m^ #/[A-Za-z0-9]+:/ head) head)
- (if (equal "" next)
- ^(:abs . ,head)
- ^(:rel . ,head))))
+ (let ((head (car comp)))
+ (if-native-windows
+ (let ((next (cadr comp))
+ (more (cddr comp)))
+ (cond
+ ((and (equal head "") (equal next "") more)
+ (let ((vol (car more)))
+ (cond
+ ((nequal "" vol)
+ (set (car comp) "")
+ (set (cdr comp) (cdr more))
+ vol)
+ (t :abs))))
+ ((and (m^ #/[A-Za-z0-9]+:/ head) head)
+ (set (car comp) next)
+ (set (cdr comp) more)
+ (if (and (equal "" next) more)
+ ^(:abs . ,head)
+ ^(:rel . ,head)))))
(if (equal head "") :abs))))
(defun rel-path (from to)
@@ -263,12 +281,18 @@
(if (meq :abs fvol tvol)
(error "~s: mixture of absolute and volume paths ~s ~s given"
'rel-path from to))
- (when (and (consp fvol) (consp tvol))
- (if (neq (car fvol) (car tvol))
- (error "~s: mixture of volume absolute and relative paths ~s ~s given"
- 'rel-path from to)
- (error "~s: paths on different volumes ~s ~s given"
- 'rel-path from to))))
+ (if-windows
+ (progn
+ (when (and (consp fvol) (consp tvol))
+ (if (neq (car fvol) (car tvol))
+ (error "~s: mixture of volume absolute and relative paths \
+ \ ~s ~s given"
+ 'rel-path from to)))
+ (when (neq (null fvol) (null tvol))
+ (error "~s: mixture of volume and non-volume paths ~s ~s given"
+ 'rel-path from to))
+ (error "~s: paths on different volumes ~s ~s given"
+ 'rel-path from to))))
(let* ((fcomp (path-simplify fspl))
(tcomp (path-simplify tspl))
(ncommon (mismatch fcomp tcomp)))
--
cgit v1.2.3