From a6ef4582c32b31bc61f3074cc5465f388eeb5a21 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 12 Nov 2007 01:41:13 -0500
Subject: [PATCH] io.files now has a path-separator? hook; cleanup
---
core/io/files/files.factor | 64 ++++++++++---------
extra/io/unix/files/files.factor | 3 -
extra/io/windows/nt/backend/backend.factor | 8 +++
.../nt-tests.factor} | 8 +--
extra/io/windows/windows.factor | 9 ---
5 files changed, 45 insertions(+), 47 deletions(-)
mode change 100644 => 100755 extra/io/unix/files/files.factor
rename extra/io/windows/{windows-tests.factor => nt/nt-tests.factor} (69%)
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 441dcfbee3..efa9096791 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -19,17 +19,17 @@ HOOK: make-directory io-backend ( path -- )
HOOK: delete-directory io-backend ( path -- )
+: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
+
HOOK: root-directory? io-backend ( path -- ? )
-M: object root-directory? ( path -- ? ) "/" = ;
+M: object root-directory? ( path -- ? ) path-separator? ;
-! Words for accessing filesystem meta-data.
-
-: path-separator? ( ch -- ? )
- "/\\" member? ;
+: trim-path-separators ( str -- newstr )
+ [ path-separator? ] right-trim ;
: path+ ( str1 str2 -- str )
- >r [ path-separator? ] right-trim "/" r>
+ >r trim-path-separators "/" r>
[ path-separator? ] left-trim 3append ;
: stat ( path -- directory? permissions length modified )
@@ -39,12 +39,15 @@ M: object root-directory? ( path -- ? ) "/" = ;
: directory? ( path -- ? ) stat 3drop ;
+: special-directory? ( name -- ? )
+ { "." ".." } member? ;
+
: fixup-directory ( path seq -- newseq )
[
dup string?
[ tuck path+ directory? 2array ] [ nip ] if
] curry* map
- [ first { "." ".." } member? not ] subset ;
+ [ first special-directory? not ] subset ;
: directory ( path -- seq )
normalize-directory dup (directory) fixup-directory ;
@@ -62,17 +65,17 @@ TUPLE: no-parent-directory path ;
\ no-parent-directory construct-boa throw ;
: parent-directory ( path -- parent )
- {
- { [ dup root-directory? ] [ ] }
- { [ dup "/\\" split ".." over member? "." rot member? or ]
- [ no-parent-directory ] }
- { [ t ] [ dup last-path-separator
- [ 1+ head ] [ 2drop "." ] if ] }
- } cond ;
+ trim-path-separators
+ dup root-directory? [ ] [
+ dup last-path-separator drop [
+ 1+ cut
+ special-directory?
+ [ no-parent-directory ] when
+ ] when*
+ ] if ;
: file-name ( path -- string )
- dup last-path-separator
- [ 1+ tail ] [ drop ] if ;
+ dup last-path-separator [ 1+ tail ] [ drop ] if ;
: resource-path ( path -- newpath )
\ resource-path get [ image parent-directory ] unless*
@@ -82,8 +85,7 @@ TUPLE: no-parent-directory path ;
"resource:" ?head [ resource-path ] when ;
: make-directories ( path -- )
- normalize-pathname
- {
+ normalize-pathname trim-path-separators {
{ [ dup "." = ] [ ] }
{ [ dup root-directory? ] [ ] }
{ [ dup empty? ] [ ] }
@@ -94,19 +96,6 @@ TUPLE: no-parent-directory path ;
] }
} cond drop ;
-TUPLE: pathname string ;
-
-C: <pathname> pathname
-
-M: pathname <=> [ pathname-string ] compare ;
-
-: home ( -- dir )
- {
- { [ winnt? ] [ "USERPROFILE" os-env ] }
- { [ wince? ] [ "" resource-path ] }
- { [ unix? ] [ "HOME" os-env ] }
- } cond ;
-
: copy-file ( from to -- )
dup parent-directory make-directories
<file-writer> [
@@ -121,3 +110,16 @@ M: pathname <=> [ pathname-string ] compare ;
>r dup directory swap r> [
>r >r first r> over path+ r> rot path+ copy-file
] 2curry each ;
+
+: home ( -- dir )
+ {
+ { [ winnt? ] [ "USERPROFILE" os-env ] }
+ { [ wince? ] [ "" resource-path ] }
+ { [ unix? ] [ "HOME" os-env ] }
+ } cond ;
+
+TUPLE: pathname string ;
+
+C: <pathname> pathname
+
+M: pathname <=> [ pathname-string ] compare ;
diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor
old mode 100644
new mode 100755
index 9c0ef54195..f9d642d661
--- a/extra/io/unix/files/files.factor
+++ b/extra/io/unix/files/files.factor
@@ -4,9 +4,6 @@ USING: io.backend io.nonblocking io.unix.backend io.files io
unix kernel math continuations ;
IN: io.unix.files
-M: unix-io root-directory? ( path -- ? )
- "/" = ;
-
: open-read ( path -- fd )
O_RDONLY file-mode open dup io-error ;
diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor
index 16e01b6103..c3a6bfd78b 100755
--- a/extra/io/windows/nt/backend/backend.factor
+++ b/extra/io/windows/nt/backend/backend.factor
@@ -8,6 +8,14 @@ IN: io.windows.nt.backend
: unicode-prefix ( -- seq )
"\\\\?\\" ; inline
+M: windows-nt-io root-directory? ( path -- ? )
+ dup length 2 = [
+ dup first Letter?
+ swap second CHAR: : = and
+ ] [
+ drop f
+ ] if ;
+
M: windows-nt-io normalize-pathname ( string -- string )
dup string? [ "pathname must be a string" throw ] unless
"/" split "\\" join
diff --git a/extra/io/windows/windows-tests.factor b/extra/io/windows/nt/nt-tests.factor
similarity index 69%
rename from extra/io/windows/windows-tests.factor
rename to extra/io/windows/nt/nt-tests.factor
index 4c090590df..9dfef6796d 100755
--- a/extra/io/windows/windows-tests.factor
+++ b/extra/io/windows/nt/nt-tests.factor
@@ -5,12 +5,12 @@ IN: temporary
[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test
[ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test
! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing
-[ "c:\\" ] [ "c:\\" parent-directory ] unit-test
-[ "Z:\\" ] [ "Z:\\" parent-directory ] unit-test
+[ "c:" ] [ "c:\\" parent-directory ] unit-test
+[ "Z:" ] [ "Z:\\" parent-directory ] unit-test
[ "c:" ] [ "c:" parent-directory ] unit-test
[ "Z:" ] [ "Z:" parent-directory ] unit-test
-[ t ] [ "c:\\" root-directory? ] unit-test
-[ t ] [ "Z:\\" root-directory? ] unit-test
+[ t ] [ "c:\\" trim-path-separators root-directory? ] unit-test
+[ t ] [ "Z:\\" trim-path-separators root-directory? ] unit-test
[ f ] [ "c:\\foo" root-directory? ] unit-test
[ f ] [ "." root-directory? ] unit-test
[ f ] [ ".." root-directory? ] unit-test
diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor
index ff9cd22d23..2bf0570b09 100755
--- a/extra/io/windows/windows.factor
+++ b/extra/io/windows/windows.factor
@@ -15,15 +15,6 @@ M: windows-io (handle-destructor) ( obj -- )
M: windows-io (socket-destructor) ( obj -- )
destructor-obj closesocket drop ;
-M: windows-io root-directory? ( path -- ? )
- [ path-separator? ] right-trim
- dup length 2 = [
- dup first Letter?
- swap second CHAR: : = and
- ] [
- drop f
- ] if ;
-
TUPLE: win32-file handle ptr overlapped ;
: <win32-file> ( handle ptr -- obj )