From 1eda70f1ad1f0d744ed846ce8c975a1cd4b28fb6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Tue, 5 Feb 2008 19:16:22 -0600
Subject: [PATCH] Bug fixes
---
core/io/files/files.factor | 13 ++++++++-----
core/vocabs/loader/loader-docs.factor | 2 +-
core/vocabs/loader/loader.factor | 2 +-
extra/io/windows/nt/files/files.factor | 12 +++++++++---
extra/io/windows/nt/nt-tests.factor | 22 +++++++++++++++++++---
5 files changed, 38 insertions(+), 13 deletions(-)
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 9952e6387b..9a99090699 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -29,12 +29,15 @@ HOOK: root-directory? io-backend ( path -- ? )
M: object root-directory? ( path -- ? ) path-separator? ;
-: trim-path-separators ( str -- newstr )
+: right-trim-separators ( str -- newstr )
[ path-separator? ] right-trim ;
+: left-trim-separators ( str -- newstr )
+ [ path-separator? ] left-trim ;
+
: path+ ( str1 str2 -- str )
- >r trim-path-separators "/" r>
- [ path-separator? ] left-trim 3append ;
+ >r right-trim-separators "/" r>
+ left-trim-separators 3append ;
: stat ( path -- directory? permissions length modified )
normalize-pathname (stat) ;
@@ -69,7 +72,7 @@ TUPLE: no-parent-directory path ;
\ no-parent-directory construct-boa throw ;
: parent-directory ( path -- parent )
- trim-path-separators {
+ right-trim-separators {
{ [ dup empty? ] [ drop "/" ] }
{ [ dup root-directory? ] [ ] }
{ [ dup [ path-separator? ] contains? not ] [ drop "." ] }
@@ -90,7 +93,7 @@ TUPLE: no-parent-directory path ;
"resource:" ?head [ resource-path ] when ;
: make-directories ( path -- )
- normalize-pathname trim-path-separators {
+ normalize-pathname right-trim-separators {
{ [ dup "." = ] [ ] }
{ [ dup root-directory? ] [ ] }
{ [ dup empty? ] [ ] }
diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor
index bc88661530..f8626f3370 100755
--- a/core/vocabs/loader/loader-docs.factor
+++ b/core/vocabs/loader/loader-docs.factor
@@ -124,7 +124,7 @@ HELP: refresh
{ $values { "prefix" string } }
{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ;
-HELP: refresh-all-error
+HELP: require-all-error
{ $values { "vocabs" "a sequence of vocabularies" } }
{ $description "Throws a " { $link require-all-error } "." }
{ $error-description "Thrown by " { $link require-all } " if one or more vocabulary failed to load." } ;
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index 6e6d1923e0..64372fe4b7 100755
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -149,7 +149,7 @@ SYMBOL: load-help?
dup modified-sources swap modified-docs ;
: load-error. ( vocab error -- )
- "While loading " swap dup >vocab-link write-object ":" print
+ "While loading " rot dup >vocab-link write-object ":" print
print-error ;
TUPLE: require-all-error vocabs ;
diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor
index 5cbcd063bd..a1c331816c 100755
--- a/extra/io/windows/nt/files/files.factor
+++ b/extra/io/windows/nt/files/files.factor
@@ -37,11 +37,13 @@ M: windows-nt-io root-directory? ( path -- ? )
: windows-path+ ( cwd path -- newpath )
{
! empty
- { [ dup empty? ] [ "empty path" throw ] }
+ { [ dup empty? ] [ drop ] }
+ ! ..
+ { [ dup ".." = ] [ drop parent-directory prepend-prefix ] }
! \\\\?\\c:\\foo
{ [ dup unicode-prefix head? ] [ nip ] }
! ..\\foo
- { [ dup "..\\" head? ] [ >r parent-directory r> 2 tail windows-path+ ] }
+ { [ dup "..\\" head? ] [ >r parent-directory r> 3 tail windows-path+ ] }
! .\\foo
{ [ dup ".\\" head? ] [ 1 tail append prepend-prefix ] }
! \\foo
@@ -49,7 +51,11 @@ M: windows-nt-io root-directory? ( path -- ? )
! c:\\foo
{ [ dup ?second CHAR: : = ] [ nip prepend-prefix ] }
! foo.txt
- { [ t ] [ [ first CHAR: \\ = "" "\\" ? ] keep 3append prepend-prefix ] }
+ { [ t ] [
+ >r right-trim-separators "\\" r>
+ left-trim-separators
+ 3append prepend-prefix
+ ] }
} cond ;
M: windows-nt-io normalize-pathname ( string -- string )
diff --git a/extra/io/windows/nt/nt-tests.factor b/extra/io/windows/nt/nt-tests.factor
index ad409fb083..e4ebe3dd37 100755
--- a/extra/io/windows/nt/nt-tests.factor
+++ b/extra/io/windows/nt/nt-tests.factor
@@ -1,4 +1,5 @@
-USING: io.files kernel tools.test io.backend splitting ;
+USING: io.files kernel tools.test io.backend
+io.windows.nt.files splitting ;
IN: temporary
[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test
@@ -9,8 +10,8 @@ IN: temporary
[ "Z:" ] [ "Z:\\" parent-directory ] unit-test
[ "c:" ] [ "c:" parent-directory ] unit-test
[ "Z:" ] [ "Z:" parent-directory ] unit-test
-[ t ] [ "c:\\" trim-path-separators root-directory? ] unit-test
-[ t ] [ "Z:\\" trim-path-separators root-directory? ] unit-test
+[ t ] [ "c:\\" right-trim-separators root-directory? ] unit-test
+[ t ] [ "Z:\\" right-trim-separators root-directory? ] unit-test
[ f ] [ "c:\\foo" root-directory? ] unit-test
[ f ] [ "." root-directory? ] unit-test
[ f ] [ ".." root-directory? ] unit-test
@@ -18,3 +19,18 @@ IN: temporary
[ ] [ "" resource-path cd ] unit-test
[ "\\foo\\bar" ] [ "/foo/bar" normalize-pathname ":" split1 nip ] unit-test
+
+[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
+ "C:\\builds\\factor\\12345\\"
+ "..\\log.txt" windows-path+
+] unit-test
+
+[ "\\\\?\\C:\\builds\\" ] [
+ "C:\\builds\\factor\\12345\\"
+ "..\\.." windows-path+
+] unit-test
+
+[ "\\\\?\\C:\\builds\\" ] [
+ "C:\\builds\\factor\\12345\\"
+ "..\\.." windows-path+
+] unit-test