io.files overhaul
Slava Pestov
parent
cf9105c056
commit
fef5ebec01
|
|
@ -3,14 +3,32 @@ io.backend io.files.private ;
|
|||
IN: io.files
|
||||
|
||||
ARTICLE: "file-streams" "Reading and writing files"
|
||||
"File streams:"
|
||||
{ $subsection <file-reader> }
|
||||
{ $subsection <file-writer> }
|
||||
{ $subsection <file-appender> }
|
||||
"Utility combinators:"
|
||||
{ $subsection with-file-reader }
|
||||
{ $subsection with-file-writer }
|
||||
{ $subsection with-file-appender } ;
|
||||
|
||||
ARTICLE: "pathnames" "Pathname manipulation"
|
||||
"Pathname manipulation:"
|
||||
{ $subsection parent-directory }
|
||||
{ $subsection file-name }
|
||||
{ $subsection last-path-separator }
|
||||
{ $subsection path+ }
|
||||
"Pathnames relative to Factor's install directory:"
|
||||
{ $subsection resource-path }
|
||||
{ $subsection ?resource-path }
|
||||
"Pathnames relative to Factor's temporary files directory:"
|
||||
{ $subsection temp-directory }
|
||||
{ $subsection temp-file }
|
||||
"Pathname presentations:"
|
||||
{ $subsection pathname }
|
||||
{ $subsection <pathname> } ;
|
||||
|
||||
ARTICLE: "file-system" "The file system"
|
||||
"File system meta-data:"
|
||||
{ $subsection exists? }
|
||||
{ $subsection directory? }
|
||||
|
|
@ -19,24 +37,43 @@ ARTICLE: "file-streams" "Reading and writing files"
|
|||
{ $subsection stat }
|
||||
"Directory listing:"
|
||||
{ $subsection directory }
|
||||
"File management:"
|
||||
{ $subsection delete-file }
|
||||
{ $subsection directory* }
|
||||
"Creating directories:"
|
||||
{ $subsection make-directory }
|
||||
{ $subsection make-directories }
|
||||
"Deleting files:"
|
||||
{ $subsection delete-file }
|
||||
{ $subsection delete-directory }
|
||||
{ $subsection delete-tree }
|
||||
"Moving files:"
|
||||
{ $subsection move-file }
|
||||
{ $subsection move-file-to }
|
||||
"Copying files:"
|
||||
{ $subsection copy-file }
|
||||
{ $subsection copy-file-to }
|
||||
{ $subsection copy-tree }
|
||||
"Current and home directories:"
|
||||
{ $subsection home }
|
||||
{ $subsection cwd }
|
||||
{ $subsection cd }
|
||||
"Pathnames relative to the Factor install directory:"
|
||||
{ $subsection resource-path }
|
||||
{ $subsection ?resource-path }
|
||||
"Pathname presentations:"
|
||||
{ $subsection pathname }
|
||||
{ $subsection <pathname> }
|
||||
{ $subsection with-directory }
|
||||
{ $subsection home }
|
||||
{ $see-also "os" } ;
|
||||
|
||||
ARTICLE: "io.files" "Basic file operations"
|
||||
"The " { $vocab-link "io.files" } " vocabulary provides basic support for working with files."
|
||||
{ $subsection "file-streams" }
|
||||
{ $subsection "pathnames" }
|
||||
{ $subsection "file-system" } ;
|
||||
ABOUT: "file-streams"
|
||||
|
||||
HELP: path-separator?
|
||||
{ $values { "ch" "a code point" } { "?" "a boolean" } }
|
||||
{ $description "Tests if the code point is a platform-specific path separator." }
|
||||
{ $examples
|
||||
"On Unix:"
|
||||
{ $example "USING: io.files prettyprint ;" "CHAR: / path-separator? ." "t" }
|
||||
} ;
|
||||
|
||||
HELP: <file-reader>
|
||||
{ $values { "path" "a pathname string" } { "stream" "an input stream" } }
|
||||
{ $description "Outputs an input stream for reading from the specified pathname." }
|
||||
|
|
|
|||
|
|
@ -6,63 +6,118 @@ USING: tools.test io.files io threads kernel continuations ;
|
|||
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
|
||||
|
||||
[ ] [
|
||||
"test-foo.txt" resource-path [
|
||||
"test-foo.txt" temp-file [
|
||||
"Hello world." print
|
||||
] with-file-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"test-foo.txt" resource-path <file-appender> [
|
||||
"test-foo.txt" temp-file <file-appender> [
|
||||
"Hello appender." print
|
||||
] with-stream
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"test-bar.txt" resource-path <file-appender> [
|
||||
"test-bar.txt" temp-file <file-appender> [
|
||||
"Hello appender." print
|
||||
] with-stream
|
||||
] unit-test
|
||||
|
||||
[ "Hello world.\nHello appender.\n" ] [
|
||||
"test-foo.txt" resource-path file-contents
|
||||
"test-foo.txt" temp-file file-contents
|
||||
] unit-test
|
||||
|
||||
[ "Hello appender.\n" ] [
|
||||
"test-bar.txt" resource-path file-contents
|
||||
"test-bar.txt" temp-file file-contents
|
||||
] unit-test
|
||||
|
||||
[ ] [ "test-foo.txt" resource-path delete-file ] unit-test
|
||||
[ ] [ "test-foo.txt" temp-file delete-file ] unit-test
|
||||
|
||||
[ ] [ "test-bar.txt" resource-path delete-file ] unit-test
|
||||
[ ] [ "test-bar.txt" temp-file delete-file ] unit-test
|
||||
|
||||
[ f ] [ "test-foo.txt" resource-path exists? ] unit-test
|
||||
[ f ] [ "test-foo.txt" temp-file exists? ] unit-test
|
||||
|
||||
[ f ] [ "test-bar.txt" resource-path exists? ] unit-test
|
||||
[ f ] [ "test-bar.txt" temp-file exists? ] unit-test
|
||||
|
||||
[ ] [ "test-blah" resource-path make-directory ] unit-test
|
||||
[ ] [ "test-blah" temp-file make-directory ] unit-test
|
||||
|
||||
[ ] [
|
||||
"test-blah/fooz" resource-path <file-writer> dispose
|
||||
"test-blah/fooz" temp-file <file-writer> dispose
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
"test-blah/fooz" resource-path exists?
|
||||
"test-blah/fooz" temp-file exists?
|
||||
] unit-test
|
||||
|
||||
[ ] [ "test-blah/fooz" resource-path delete-file ] unit-test
|
||||
[ ] [ "test-blah/fooz" temp-file delete-file ] unit-test
|
||||
|
||||
[ ] [ "test-blah" resource-path delete-directory ] unit-test
|
||||
[ ] [ "test-blah" temp-file delete-directory ] unit-test
|
||||
|
||||
[ f ] [ "test-blah" resource-path exists? ] unit-test
|
||||
[ f ] [ "test-blah" temp-file exists? ] unit-test
|
||||
|
||||
[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
|
||||
[ ] [ "test-quux.txt" temp-file [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
|
||||
|
||||
[ ] [ "test-quux.txt" resource-path delete-file ] unit-test
|
||||
[ ] [ "test-quux.txt" temp-file delete-file ] unit-test
|
||||
|
||||
[ ] [ "test-quux.txt" resource-path [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
|
||||
[ ] [ "test-quux.txt" temp-file [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
|
||||
|
||||
[ ] [ "test-quux.txt" "quux-test.txt" [ resource-path ] 2apply rename-file ] unit-test
|
||||
[ t ] [ "quux-test.txt" resource-path exists? ] unit-test
|
||||
[ ] [ "test-quux.txt" "quux-test.txt" [ temp-file ] 2apply move-file ] unit-test
|
||||
[ t ] [ "quux-test.txt" temp-file exists? ] unit-test
|
||||
|
||||
[ ] [ "quux-test.txt" resource-path delete-file ] unit-test
|
||||
[ ] [ "quux-test.txt" temp-file delete-file ] unit-test
|
||||
|
||||
[ ] [ "delete-tree-test/a/b/c" temp-file make-directories ] unit-test
|
||||
|
||||
[ ] [
|
||||
"delete-tree-test/a/b/c/d" temp-file
|
||||
[ "Hi" print ] with-file-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"delete-tree-test" temp-file delete-tree
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"copy-tree-test/a/b/c" temp-file make-directories
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"copy-tree-test/a/b/c/d" temp-file
|
||||
[ "Foobar" write ] with-file-writer
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"copy-tree-test" temp-file
|
||||
"copy-destination" temp-file copy-tree
|
||||
] unit-test
|
||||
|
||||
[ "Foobar" ] [
|
||||
"copy-destination/a/b/c/d" temp-file file-contents
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"copy-destination" temp-file delete-tree
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"copy-tree-test" temp-file
|
||||
"copy-destination" temp-file copy-tree-to
|
||||
] unit-test
|
||||
|
||||
[ "Foobar" ] [
|
||||
"copy-destination/copy-tree-test/a/b/c/d" temp-file file-contents
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"copy-destination/copy-tree-test/a/b/c/d" temp-file "" temp-file copy-file-to
|
||||
] unit-test
|
||||
|
||||
[ "Foobar" ] [
|
||||
"d" temp-file file-contents
|
||||
] unit-test
|
||||
|
||||
[ ] [ "d" temp-file delete-file ] unit-test
|
||||
|
||||
[ ] [ "copy-destination" temp-file delete-tree ] unit-test
|
||||
|
||||
[ ] [ "copy-tree-test" temp-file delete-tree ] unit-test
|
||||
|
|
|
|||
|
|
@ -5,30 +5,9 @@ USING: io.backend io.files.private io hashtables kernel math
|
|||
memory namespaces sequences strings assocs arrays definitions
|
||||
system combinators splitting sbufs continuations ;
|
||||
|
||||
HOOK: cd io-backend ( path -- )
|
||||
|
||||
HOOK: cwd io-backend ( -- path )
|
||||
|
||||
HOOK: <file-reader> io-backend ( path -- stream )
|
||||
|
||||
HOOK: <file-writer> io-backend ( path -- stream )
|
||||
|
||||
HOOK: <file-appender> io-backend ( path -- stream )
|
||||
|
||||
HOOK: delete-file io-backend ( path -- )
|
||||
|
||||
HOOK: rename-file io-backend ( from to -- )
|
||||
|
||||
HOOK: make-directory io-backend ( path -- )
|
||||
|
||||
HOOK: delete-directory io-backend ( path -- )
|
||||
|
||||
! Pathnames
|
||||
: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
|
||||
|
||||
HOOK: root-directory? io-backend ( path -- ? )
|
||||
|
||||
M: object root-directory? ( path -- ? ) path-separator? ;
|
||||
|
||||
: right-trim-separators ( str -- newstr )
|
||||
[ path-separator? ] right-trim ;
|
||||
|
||||
|
|
@ -39,33 +18,15 @@ M: object root-directory? ( path -- ? ) path-separator? ;
|
|||
>r right-trim-separators "/" r>
|
||||
left-trim-separators 3append ;
|
||||
|
||||
: stat ( path -- directory? permissions length modified )
|
||||
normalize-pathname (stat) ;
|
||||
|
||||
: file-length ( path -- n ) stat 4array third ;
|
||||
|
||||
: file-modified ( path -- n ) stat >r 3drop r> ; inline
|
||||
|
||||
: exists? ( path -- ? ) file-modified >boolean ;
|
||||
|
||||
: directory? ( path -- ? ) stat 3drop ;
|
||||
|
||||
: special-directory? ( name -- ? )
|
||||
{ "." ".." } member? ;
|
||||
|
||||
: fixup-directory ( path seq -- newseq )
|
||||
[
|
||||
dup string?
|
||||
[ tuck path+ directory? 2array ] [ nip ] if
|
||||
] with map
|
||||
[ first special-directory? not ] subset ;
|
||||
|
||||
: directory ( path -- seq )
|
||||
normalize-directory dup (directory) fixup-directory ;
|
||||
|
||||
: last-path-separator ( path -- n ? )
|
||||
[ length 1- ] keep [ path-separator? ] find-last* ;
|
||||
|
||||
HOOK: root-directory? io-backend ( path -- ? )
|
||||
|
||||
M: object root-directory? ( path -- ? ) path-separator? ;
|
||||
|
||||
: special-directory? ( name -- ? ) { "." ".." } member? ;
|
||||
|
||||
TUPLE: no-parent-directory path ;
|
||||
|
||||
: no-parent-directory ( path -- * )
|
||||
|
|
@ -89,15 +50,30 @@ TUPLE: no-parent-directory path ;
|
|||
{ [ t ] [ drop ] }
|
||||
} cond ;
|
||||
|
||||
: resource-path ( path -- newpath )
|
||||
\ resource-path get [ image parent-directory ] unless*
|
||||
swap path+ ;
|
||||
! File metadata
|
||||
: stat ( path -- directory? permissions length modified )
|
||||
normalize-pathname (stat) ;
|
||||
|
||||
: ?resource-path ( path -- newpath )
|
||||
"resource:" ?head [ resource-path ] when ;
|
||||
: file-length ( path -- n ) stat drop 2nip ;
|
||||
|
||||
: resource-exists? ( path -- ? )
|
||||
?resource-path exists? ;
|
||||
: file-modified ( path -- n ) stat >r 3drop r> ;
|
||||
|
||||
: file-permissions ( path -- perm ) stat 2drop nip ;
|
||||
|
||||
: exists? ( path -- ? ) file-modified >boolean ;
|
||||
|
||||
: directory? ( path -- ? ) stat 3drop ;
|
||||
|
||||
! Current working directory
|
||||
HOOK: cd io-backend ( path -- )
|
||||
|
||||
HOOK: cwd io-backend ( -- path )
|
||||
|
||||
: with-directory ( path quot -- )
|
||||
swap cd cwd [ cd ] curry [ ] cleanup ; inline
|
||||
|
||||
! Creating directories
|
||||
HOOK: make-directory io-backend ( path -- )
|
||||
|
||||
: make-directories ( path -- )
|
||||
normalize-pathname right-trim-separators {
|
||||
|
|
@ -111,35 +87,102 @@ TUPLE: no-parent-directory path ;
|
|||
] }
|
||||
} cond drop ;
|
||||
|
||||
! Directory listings
|
||||
: fixup-directory ( path seq -- newseq )
|
||||
[
|
||||
dup string?
|
||||
[ tuck path+ directory? 2array ] [ nip ] if
|
||||
] with map
|
||||
[ first special-directory? not ] subset ;
|
||||
|
||||
: directory ( path -- seq )
|
||||
normalize-directory dup (directory) fixup-directory ;
|
||||
|
||||
: directory* ( path -- seq )
|
||||
dup directory [ first2 >r path+ r> 2array ] with map ;
|
||||
|
||||
! Touching files
|
||||
HOOK: touch-file io-backend ( path -- )
|
||||
|
||||
! Deleting files
|
||||
HOOK: delete-file io-backend ( path -- )
|
||||
|
||||
HOOK: delete-directory io-backend ( path -- )
|
||||
|
||||
: (delete-tree) ( path dir? -- )
|
||||
[
|
||||
dup directory* [ (delete-tree) ] assoc-each
|
||||
delete-directory
|
||||
] [ delete-file ] if ;
|
||||
|
||||
: delete-tree ( path -- )
|
||||
dup directory? (delete-tree) ;
|
||||
|
||||
: to-directory over file-name path+ ;
|
||||
|
||||
! Moving and renaming files
|
||||
HOOK: move-file io-backend ( from to -- )
|
||||
|
||||
: move-file-to ( from to -- )
|
||||
to-directory move-file ;
|
||||
|
||||
: move-files-to ( files to -- )
|
||||
[ move-file-to ] curry each ;
|
||||
|
||||
! Copying files
|
||||
HOOK: copy-file io-backend ( from to -- )
|
||||
|
||||
M: object copy-file
|
||||
dup parent-directory make-directories
|
||||
<file-writer> [
|
||||
swap <file-reader> [
|
||||
swap stream-copy
|
||||
] with-disposal
|
||||
] with-disposal ;
|
||||
: copy-file-to ( from to -- )
|
||||
to-directory copy-file ;
|
||||
|
||||
: copy-directory ( from to -- )
|
||||
DEFER: copy-tree-to
|
||||
|
||||
: copy-tree ( from to -- )
|
||||
over directory? [
|
||||
dup make-directories
|
||||
>r dup directory swap r> [
|
||||
>r >r first r> over path+ r> rot path+ copy-file
|
||||
] 2curry each ;
|
||||
>r swap first path+ r> copy-tree-to
|
||||
] 2curry each
|
||||
] [
|
||||
copy-file
|
||||
] if ;
|
||||
|
||||
: home ( -- dir )
|
||||
{
|
||||
{ [ winnt? ] [ "USERPROFILE" os-env ] }
|
||||
{ [ wince? ] [ "" resource-path ] }
|
||||
{ [ unix? ] [ "HOME" os-env ] }
|
||||
} cond ;
|
||||
: copy-tree-to ( from to -- )
|
||||
to-directory copy-tree ;
|
||||
|
||||
! Special paths
|
||||
: resource-path ( path -- newpath )
|
||||
\ resource-path get [ image parent-directory ] unless*
|
||||
swap path+ ;
|
||||
|
||||
: ?resource-path ( path -- newpath )
|
||||
"resource:" ?head [ resource-path ] when ;
|
||||
|
||||
: resource-exists? ( path -- ? )
|
||||
?resource-path exists? ;
|
||||
|
||||
: temp-directory ( -- path )
|
||||
"temp" resource-path
|
||||
dup exists? not
|
||||
[ dup make-directory ]
|
||||
when ;
|
||||
|
||||
: temp-file ( name -- path ) temp-directory swap path+ ;
|
||||
|
||||
! Pathname presentations
|
||||
TUPLE: pathname string ;
|
||||
|
||||
C: <pathname> pathname
|
||||
|
||||
M: pathname <=> [ pathname-string ] compare ;
|
||||
|
||||
! Streams
|
||||
HOOK: <file-reader> io-backend ( path -- stream )
|
||||
|
||||
HOOK: <file-writer> io-backend ( path -- stream )
|
||||
|
||||
HOOK: <file-appender> io-backend ( path -- stream )
|
||||
|
||||
: file-lines ( path -- seq ) <file-reader> lines ;
|
||||
|
||||
: file-contents ( path -- str )
|
||||
|
|
@ -155,10 +198,10 @@ M: pathname <=> [ pathname-string ] compare ;
|
|||
: with-file-appender ( path quot -- )
|
||||
>r <file-appender> r> with-stream ; inline
|
||||
|
||||
: temp-directory ( -- path )
|
||||
"temp" resource-path
|
||||
dup exists? not
|
||||
[ dup make-directory ]
|
||||
when ;
|
||||
|
||||
: temp-file ( name -- path ) temp-directory swap path+ ;
|
||||
! Home directory
|
||||
: home ( -- dir )
|
||||
{
|
||||
{ [ winnt? ] [ "USERPROFILE" os-env ] }
|
||||
{ [ wince? ] [ "" resource-path ] }
|
||||
{ [ unix? ] [ "HOME" os-env ] }
|
||||
} cond ;
|
||||
|
|
@ -62,11 +62,7 @@ M: duplex-stream stream-read-quot
|
|||
[ quit-flag off ]
|
||||
[ listen until-quit ] if ; inline
|
||||
|
||||
: print-banner ( -- )
|
||||
"Factor #" write build number>string write
|
||||
" on " write os write "/" write cpu print ;
|
||||
|
||||
: listener ( -- )
|
||||
print-banner [ until-quit ] with-interactive-vocabs ;
|
||||
[ until-quit ] with-interactive-vocabs ;
|
||||
|
||||
MAIN: listener
|
||||
|
|
|
|||
|
|
@ -163,7 +163,7 @@ ARTICLE: "syntax-byte-vectors" "Byte vector syntax"
|
|||
|
||||
ARTICLE: "syntax-pathnames" "Pathname syntax"
|
||||
{ $subsection POSTPONE: P" }
|
||||
"Pathnames are documented in " { $link "file-streams" } "." ;
|
||||
"Pathnames are documented in " { $link "pathnames" } "." ;
|
||||
|
||||
ARTICLE: "syntax-literals" "Literals"
|
||||
"Many different types of objects can be constructed at parse time via literal syntax. Numbers are a special case since support for reading them is built-in to the parser. All other literals are constructed via parsing words."
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ ARTICLE: "os" "System interface"
|
|||
{ $subsection millis }
|
||||
"Exiting the Factor VM:"
|
||||
{ $subsection exit }
|
||||
{ $see-also "file-streams" "network-streams" "io.launcher" "io.mmap" } ;
|
||||
{ $see-also "io.files" "network-streams" "io.launcher" "io.mmap" } ;
|
||||
|
||||
ABOUT: "os"
|
||||
|
||||
|
|
|
|||
|
|
@ -172,22 +172,23 @@ ARTICLE: "collections" "Collections"
|
|||
USING: io.sockets io.launcher io.mmap io.monitors ;
|
||||
|
||||
ARTICLE: "io" "Input and output"
|
||||
{ $heading "Streams" }
|
||||
{ $subsection "streams" }
|
||||
"External streams:"
|
||||
{ $subsection "file-streams" }
|
||||
{ $subsection "network-streams" }
|
||||
"Wrapper streams:"
|
||||
{ $subsection "io.streams.duplex" }
|
||||
{ $subsection "io.streams.lines" }
|
||||
{ $subsection "io.streams.plain" }
|
||||
{ $subsection "io.streams.string" }
|
||||
"Stream utilities:"
|
||||
"Utilities:"
|
||||
{ $subsection "stream-binary" }
|
||||
{ $subsection "styles" }
|
||||
"Advanced features:"
|
||||
{ $subsection "io.launcher" }
|
||||
{ $heading "Files" }
|
||||
{ $subsection "io.files" }
|
||||
{ $subsection "io.mmap" }
|
||||
{ $subsection "io.monitors" }
|
||||
{ $heading "Other features" }
|
||||
{ $subsection "network-streams" }
|
||||
{ $subsection "io.launcher" }
|
||||
{ $subsection "io.timeouts" } ;
|
||||
|
||||
ARTICLE: "tools" "Developer tools"
|
||||
|
|
|
|||
|
|
@ -37,7 +37,15 @@ M: unix-io <file-writer> ( path -- stream )
|
|||
M: unix-io <file-appender> ( path -- stream )
|
||||
open-append <writer> ;
|
||||
|
||||
M: unix-io rename-file ( from to -- )
|
||||
: touch-mode
|
||||
{ O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
|
||||
|
||||
M: unix-io touch-file ( path -- )
|
||||
touch-mode file-mode open
|
||||
dup 0 < [ err_no EEXIST = [ err_no io-error ] unless ] when
|
||||
close ;
|
||||
|
||||
M: unix-io move-file ( from to -- )
|
||||
rename io-error ;
|
||||
|
||||
M: unix-io delete-file ( path -- )
|
||||
|
|
@ -48,3 +56,14 @@ M: unix-io make-directory ( path -- )
|
|||
|
||||
M: unix-io delete-directory ( path -- )
|
||||
rmdir io-error ;
|
||||
|
||||
: (copy-file) ( from to -- )
|
||||
dup parent-directory make-directories
|
||||
<file-writer> [
|
||||
swap <file-reader> [
|
||||
swap stream-copy
|
||||
] with-disposal
|
||||
] with-disposal ;
|
||||
|
||||
M: unix-io copy-file ( from to -- )
|
||||
over file-permissions >r (copy-file) r> chmod io-error ;
|
||||
|
|
|
|||
|
|
@ -59,7 +59,8 @@ M: windows-nt-io root-directory? ( path -- ? )
|
|||
} cond ;
|
||||
|
||||
M: windows-nt-io normalize-pathname ( string -- string )
|
||||
dup string? [ "pathname must be a string" throw ] unless
|
||||
dup string? [ "Pathname must be a string" throw ] unless
|
||||
dup empty? [ "Empty pathname" throw ] when
|
||||
{ { CHAR: / CHAR: \\ } } substitute
|
||||
cwd swap windows-path+
|
||||
[ "/\\." member? ] right-trim
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ io.windows.nt.backend kernel math windows windows.kernel32
|
|||
windows.types libc assocs alien namespaces continuations
|
||||
io.monitors io.monitors.private io.nonblocking io.buffers
|
||||
io.files io.timeouts io sequences hashtables sorting arrays
|
||||
combinators ;
|
||||
combinators math.bitfields ;
|
||||
IN: io.windows.nt.monitors
|
||||
|
||||
: open-directory ( path -- handle )
|
||||
|
|
@ -13,7 +13,7 @@ IN: io.windows.nt.monitors
|
|||
share-mode
|
||||
f
|
||||
OPEN_EXISTING
|
||||
FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED bitor
|
||||
{ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags
|
||||
f
|
||||
CreateFile
|
||||
dup invalid-handle?
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
|
|||
HOOK: add-completion io-backend ( port -- )
|
||||
|
||||
M: windows-io normalize-directory ( string -- string )
|
||||
"\\" ?tail drop "\\*" append ;
|
||||
normalize-pathname "\\" ?tail drop "\\*" append ;
|
||||
|
||||
: share-mode ( -- fixnum )
|
||||
{
|
||||
|
|
@ -121,7 +121,7 @@ M: windows-io <file-writer> ( path -- stream )
|
|||
M: windows-io <file-appender> ( path -- stream )
|
||||
open-append <win32-file> <writer> ;
|
||||
|
||||
M: windows-io rename-file ( from to -- )
|
||||
M: windows-io move-file ( from to -- )
|
||||
[ normalize-pathname ] 2apply MoveFile win32-error=0/f ;
|
||||
|
||||
M: windows-io delete-file ( path -- )
|
||||
|
|
|
|||
|
|
@ -68,11 +68,11 @@ SYMBOL: log-files
|
|||
|
||||
: delete-oldest keep-logs log# ?delete-file ;
|
||||
|
||||
: ?rename-file ( old new -- )
|
||||
over exists? [ rename-file ] [ 2drop ] if ;
|
||||
: ?move-file ( old new -- )
|
||||
over exists? [ move-file ] [ 2drop ] if ;
|
||||
|
||||
: advance-log ( path n -- )
|
||||
[ 1- log# ] 2keep log# ?rename-file ;
|
||||
[ 1- log# ] 2keep log# ?move-file ;
|
||||
|
||||
: rotate-log ( service -- )
|
||||
dup close-log
|
||||
|
|
|
|||
|
|
@ -1,36 +1,22 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io io.files io.launcher kernel namespaces sequences
|
||||
system tools.deploy.backend tools.deploy.config assocs
|
||||
hashtables prettyprint io.unix.backend cocoa
|
||||
cocoa.application cocoa.classes cocoa.plists qualified ;
|
||||
QUALIFIED: unix
|
||||
USING: io io.files kernel namespaces sequences system
|
||||
tools.deploy.backend tools.deploy.config assocs hashtables
|
||||
prettyprint cocoa cocoa.application cocoa.classes cocoa.plists ;
|
||||
IN: tools.deploy.macosx
|
||||
|
||||
: touch ( path -- )
|
||||
{ "touch" } swap add try-process ;
|
||||
|
||||
: rm ( path -- )
|
||||
{ "rm" "-rf" } swap add try-process ;
|
||||
|
||||
: bundle-dir ( -- dir )
|
||||
vm parent-directory parent-directory ;
|
||||
|
||||
: copy-bundle-dir ( name dir -- )
|
||||
bundle-dir over path+ -rot
|
||||
>r "Contents" path+ r> path+ copy-directory ;
|
||||
|
||||
: chmod ( path perms -- )
|
||||
unix:chmod io-error ;
|
||||
bundle-dir swap path+ swap "Contents" path+ copy-tree ;
|
||||
|
||||
: copy-vm ( executable bundle-name -- vm )
|
||||
"Contents/MacOS/" path+ swap path+ vm swap
|
||||
[ copy-file ] keep
|
||||
[ OCT: 755 chmod ] keep ;
|
||||
"Contents/MacOS/" path+ swap path+ vm swap copy-file ;
|
||||
|
||||
: copy-fonts ( name -- )
|
||||
"fonts/" resource-path
|
||||
swap "Contents/Resources/fonts/" path+ copy-directory ;
|
||||
swap "Contents/Resources/" path+ copy-tree ;
|
||||
|
||||
: print-app-plist ( executable bundle-name -- )
|
||||
[
|
||||
|
|
@ -75,7 +61,7 @@ M: macosx-deploy-implementation deploy* ( vocab -- )
|
|||
".app deploy tool" assert.app
|
||||
"." resource-path cd
|
||||
dup deploy-config [
|
||||
bundle-name rm
|
||||
bundle-name delete-tree
|
||||
[ bundle-name create-app-dir ] keep
|
||||
[ bundle-name deploy.app-image ] keep
|
||||
namespace make-deploy-image
|
||||
|
|
|
|||
|
|
@ -9,8 +9,7 @@ IN: tools.deploy.windows
|
|||
swap path+ ".exe" append vm swap [ copy-file ] keep ;
|
||||
|
||||
: copy-fonts ( bundle-name -- )
|
||||
"fonts/" resource-path
|
||||
swap "fonts/" path+ copy-directory ;
|
||||
"fonts/" resource-path swap copy-tree ;
|
||||
|
||||
: copy-dlls ( bundle-name -- )
|
||||
{
|
||||
|
|
@ -18,7 +17,7 @@ IN: tools.deploy.windows
|
|||
"zlib1.dll"
|
||||
"factor-nt.dll"
|
||||
} [
|
||||
dup resource-path -rot path+ copy-file
|
||||
resource-path swap copy-file-to
|
||||
] with each ;
|
||||
|
||||
: create-exe-dir ( vocab bundle-name -- vm )
|
||||
|
|
|
|||
|
|
@ -102,6 +102,8 @@ C-STRUCT: timespec
|
|||
|
||||
: MAP_FAILED -1 <alien> ; inline
|
||||
|
||||
: EEXIST 17 ; inline
|
||||
|
||||
! ! ! Unix functions
|
||||
LIBRARY: factor
|
||||
FUNCTION: int err_no ( ) ;
|
||||
|
|
|
|||
|
|
@ -174,7 +174,7 @@ DEFINE_PRIMITIVE(read_dir)
|
|||
GROWABLE_ADD(result,pair);
|
||||
}
|
||||
while (FindNextFile(dir, &find_data));
|
||||
CloseHandle(dir);
|
||||
FindClose(dir);
|
||||
}
|
||||
|
||||
UNREGISTER_ROOT(result);
|
||||
|
|
|
|||
Loading…
Reference in New Issue