diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2021-05-03 07:07:14 -0700 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2021-05-03 07:07:14 -0700 |
| commit | 49008cd459d87f7b38045bddf5a5bbd1c6f1a189 (patch) | |
| tree | a1964c35294581d7f9a870d8832ed059f3c476cd /share | |
| parent | 8be2ee867659dc8b6c47d4fb6694aceaf10bfd7c (diff) | |
| download | txr-49008cd459d87f7b38045bddf5a5bbd1c6f1a189.tar.gz txr-49008cd459d87f7b38045bddf5a5bbd1c6f1a189.tar.bz2 txr-49008cd459d87f7b38045bddf5a5bbd1c6f1a189.zip | |
rel-path: bugfixes.
* share/txr/stdlib/copy-file.tl: When removing .. components,
a dotdot must only cancel preceding non-dotdot. We must check
not only that the out stack is not empty but that the top
element isn't dotdot. Also, eliminate empty components, like
the documentation says. Lastly, we must check for the impossible
cases, when the from path uses .. components that are
impossible to navigate backwards to form a relative path.
* tests/018/rel-path.tl: Test cases added.
* txr.1: Updated with additional descriptions, fixes and
examples.
Diffstat (limited to 'share')
| -rw-r--r-- | share/txr/stdlib/copy-file.tl | 23 |
1 files changed, 14 insertions, 9 deletions
diff --git a/share/txr/stdlib/copy-file.tl b/share/txr/stdlib/copy-file.tl index 67c3493a..28460b72 100644 --- a/share/txr/stdlib/copy-file.tl +++ b/share/txr/stdlib/copy-file.tl @@ -230,17 +230,22 @@ (flet ((canon (comp) (let (out) (each ((c comp)) - (cond - ((and out (equal ".." c)) (pop out)) - ((equal "." c)) + (casequal c + (".." (if (and out (nequal (car out) "..")) + (pop out) + (push c out))) + (("." "")) (t (push c out)))) (nreverse out)))) (let* ((fcomp (canon (spl path-sep-chars from))) (tcomp (canon (spl path-sep-chars to))) (ncommon (mismatch fcomp tcomp))) - (if (null ncommon) - "." - (let ((nup (- (len fcomp) ncommon)) - (down [tcomp ncommon..:])) - (cat-str (append (repeat '("..") nup) down) - [path-sep-chars 0]))))))) + (cond + ((null ncommon) ".") + ((find ".." (nthcdr ncommon fcomp)) + (error "~s: from path uses ... to escapes common prefix: ~s ~s" + 'rel-path from to)) + (t (let ((nup (- (len fcomp) ncommon)) + (down [tcomp ncommon..:])) + (cat-str (append (repeat '("..") nup) down) + [path-sep-chars 0])))))))) |