From ba1a958a321efdec8be27cdb4c7b0edcffd13468 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 13:11:36 -0600 Subject: [PATCH] Move cd and cwd primitives to native I/O, fix Windows normalize-pathname --- core/bootstrap/primitives.factor | 2 - core/bootstrap/stage2.factor | 6 +-- core/io/files/files-docs.factor | 4 +- core/io/files/files.factor | 6 ++- extra/io/unix/files/files.factor | 9 +++- extra/io/windows/nt/backend/backend.factor | 37 +------------ extra/io/windows/nt/files/files.factor | 62 ++++++++++++++++++++-- extra/io/windows/nt/nt-tests.factor | 6 ++- extra/unix/bsd/bsd.factor | 2 + extra/unix/linux/linux.factor | 2 + extra/unix/unix.factor | 1 + extra/windows/kernel32/kernel32.factor | 6 ++- vm/io.h | 2 - vm/os-unix.c | 13 ----- vm/os-windows-ce.c | 10 ---- vm/os-windows-nt.c | 15 ------ vm/os-windows.h | 1 + vm/primitives.c | 2 - 18 files changed, 93 insertions(+), 93 deletions(-) mode change 100644 => 100755 extra/unix/bsd/bsd.factor mode change 100644 => 100755 extra/unix/linux/linux.factor mode change 100644 => 100755 vm/io.h diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 550aac71b0..967840a3dc 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -553,8 +553,6 @@ builtins get num-tags get tail f union-class define-class { "millis" "system" } { "type" "kernel.private" } { "tag" "kernel.private" } - { "cwd" "io.files" } - { "cd" "io.files" } { "modify-code-heap" "compiler.units" } { "dlopen" "alien" } { "dlsym" "alien" } diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index f3483add57..c601ba7671 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: init command-line namespaces words debugger io kernel.private math memory continuations kernel io.files io.backend system parser vocabs sequences prettyprint vocabs.loader combinators splitting source-files strings definitions assocs compiler.errors compiler.units -math.parser ; +math.parser generic ; IN: bootstrap.stage2 ! Wrap everything in a catch which starts a listener so @@ -88,5 +88,5 @@ IN: bootstrap.stage2 "output-image" get resource-path save-image-and-exit ] if ] [ - print-error :c "listener" vocab-main execute + print-error :c "listener" vocab-main execute 1 exit ] recover diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 3a23c8f6ef..0b9a748eb8 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -52,12 +52,12 @@ HELP: { $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." } { $errors "Throws an error if the file cannot be opened for writing." } ; -HELP: cwd ( -- path ) +HELP: cwd { $values { "path" "a pathname string" } } { $description "Outputs the current working directory of the Factor process." } { $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ; -HELP: cd ( path -- ) +HELP: cd { $values { "path" "a pathname string" } } { $description "Changes the current working directory of the Factor process." } { $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 6e4648b590..9952e6387b 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -1,10 +1,14 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.files USING: io.backend io.files.private io hashtables kernel math memory namespaces sequences strings assocs arrays definitions system combinators splitting sbufs ; +HOOK: cd io-backend ( path -- ) + +HOOK: cwd io-backend ( -- path ) + HOOK: io-backend ( path -- stream ) HOOK: io-backend ( path -- stream ) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index edee598435..3201c29c45 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -1,9 +1,16 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend io.nonblocking io.unix.backend io.files io unix kernel math continuations math.bitfields ; IN: io.unix.files +M: unix-io cwd + MAXPATHLEN dup getcwd + [ alien>char-string ] [ (io-error) ] if* ; + +M: unix-io cd + chdir io-error ; + : read-flags O_RDONLY ; inline : open-read ( path -- fd ) diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 88e7cdf84a..760bcec457 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -2,45 +2,10 @@ USING: alien alien.c-types arrays assocs combinators continuations destructors io io.backend io.nonblocking io.windows libc kernel math namespaces sequences threads tuples.lib windows windows.errors windows.kernel32 -strings splitting io.files qualified ascii ; +strings splitting io.files qualified ascii combinators.lib ; QUALIFIED: windows.winsock 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 - { - ! empty - { [ dup empty? ] [ "empty path" throw ] } - ! .\\foo - { [ dup ".\\" head? ] [ - >r unicode-prefix cwd r> 1 tail 3append - ] } - ! c:\\foo - { [ dup 1 tail ":" head? ] [ >r unicode-prefix r> append ] } - ! \\\\?\\c:\\foo - { [ dup unicode-prefix head? ] [ ] } - ! foo.txt ..\\foo.txt - { [ t ] [ - [ - unicode-prefix % cwd % - dup first CHAR: \\ = [ CHAR: \\ , ] unless % - ] "" make - ] } - } cond [ "/\\." member? ] right-trim - dup peek CHAR: : = [ "\\" append ] when ; - SYMBOL: io-hash TUPLE: io-callback port continuation ; diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 4a304e5ac9..43686707a2 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -1,8 +1,64 @@ -USING: continuations destructors io.buffers io.nonblocking -io.windows io.windows.nt.backend kernel libc math threads -windows windows.kernel32 ; +USING: continuations destructors io.buffers io.files io.backend +io.nonblocking io.windows io.windows.nt.backend kernel libc math +threads windows windows.kernel32 alien.c-types alien.arrays +sequences combinators combinators.lib ascii splitting alien +strings ; IN: io.windows.nt.files +M: windows-nt-io cwd + MAX_UNICODE_PATH dup "ushort" + [ GetCurrentDirectory win32-error=0/f ] keep + alien>u16-string ; + +M: windows-nt-io cd + SetCurrentDirectory win32-error=0/f ; + +: unicode-prefix ( -- seq ) + "\\\\?\\" ; inline + +M: windows-nt-io root-directory? ( path -- ? ) + dup length 2 = [ + dup first Letter? + swap second CHAR: : = and + ] [ + drop f + ] if ; + +: root-directory ( string -- string' ) + { + [ dup length 2 >= ] + [ dup second CHAR: : = ] + [ dup first Letter? ] + } && [ 2 head ] [ "Not an absolute path" throw ] if ; + +: prepend-prefix ( string -- string' ) + unicode-prefix swap append ; + +: windows-path+ ( cwd path -- newpath ) + { + ! empty + { [ dup empty? ] [ "empty path" throw ] } + ! \\\\?\\c:\\foo + { [ dup unicode-prefix head? ] [ nip ] } + ! ..\\foo + { [ dup "..\\" head? ] [ >r parent-directory r> 2 tail windows-path+ ] } + ! .\\foo + { [ dup ".\\" head? ] [ 1 tail append prepend-prefix ] } + ! \\foo + { [ dup "\\" head? ] [ >r root-directory r> append prepend-prefix ] } + ! c:\\foo + { [ dup second CHAR: : = ] [ nip prepend-prefix ] } + ! foo.txt + { [ t ] [ [ first CHAR: \\ = "" "\\" ? ] keep 3append prepend-prefix ] } + } cond ; + +M: windows-nt-io normalize-pathname ( string -- string ) + dup string? [ "pathname must be a string" throw ] unless + "/" split "\\" join + cwd swap windows-path+ + [ "/\\." member? ] right-trim + dup peek CHAR: : = [ "\\" append ] when ; + M: windows-nt-io CreateFile-flags ( DWORD -- DWORD ) FILE_FLAG_OVERLAPPED bitor ; diff --git a/extra/io/windows/nt/nt-tests.factor b/extra/io/windows/nt/nt-tests.factor index 9dfef6796d..ad409fb083 100755 --- a/extra/io/windows/nt/nt-tests.factor +++ b/extra/io/windows/nt/nt-tests.factor @@ -1,4 +1,4 @@ -USING: io.files kernel tools.test ; +USING: io.files kernel tools.test io.backend splitting ; IN: temporary [ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test @@ -14,3 +14,7 @@ IN: temporary [ f ] [ "c:\\foo" root-directory? ] unit-test [ f ] [ "." root-directory? ] unit-test [ f ] [ ".." root-directory? ] unit-test + +[ ] [ "" resource-path cd ] unit-test + +[ "\\foo\\bar" ] [ "/foo/bar" normalize-pathname ":" split1 nip ] unit-test diff --git a/extra/unix/bsd/bsd.factor b/extra/unix/bsd/bsd.factor old mode 100644 new mode 100755 index 0a5aa1080e..e652f1b9f9 --- a/extra/unix/bsd/bsd.factor +++ b/extra/unix/bsd/bsd.factor @@ -5,6 +5,8 @@ USING: alien.syntax ; ! FreeBSD +: MAXPATHLEN 1024 ; inline + : O_RDONLY HEX: 0000 ; inline : O_WRONLY HEX: 0001 ; inline : O_RDWR HEX: 0002 ; inline diff --git a/extra/unix/linux/linux.factor b/extra/unix/linux/linux.factor old mode 100644 new mode 100755 index 0a3eb7ee5f..11db6cc862 --- a/extra/unix/linux/linux.factor +++ b/extra/unix/linux/linux.factor @@ -5,6 +5,8 @@ USING: alien.syntax ; ! Linux. +: MAXPATHLEN 1024 ; inline + : O_RDONLY HEX: 0000 ; inline : O_WRONLY HEX: 0001 ; inline : O_RDWR HEX: 0002 ; inline diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 750a4b5044..d32fc25eab 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -124,6 +124,7 @@ FUNCTION: void freeaddrinfo ( addrinfo* ai ) ; FUNCTION: int futimes ( int id, timeval[2] times ) ; FUNCTION: char* gai_strerror ( int ecode ) ; FUNCTION: int getaddrinfo ( char* hostname, char* servname, addrinfo* hints, addrinfo** res ) ; +FUNCTION: char* getcwd ( char* buf, size_t size ) ; FUNCTION: int getdtablesize ; FUNCTION: gid_t getegid ; FUNCTION: uid_t geteuid ; diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 45bd6bfae9..b8928c5820 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -892,7 +892,8 @@ FUNCTION: DWORD GetConsoleTitleW ( LPWSTR lpConsoleTitle, DWORD nSize ) ; ! FUNCTION: GetCurrentActCtx ! FUNCTION: GetCurrentConsoleFont ! FUNCTION: GetCurrentDirectoryA -! FUNCTION: GetCurrentDirectoryW +FUNCTION: BOOL GetCurrentDirectoryW ( DWORD len, LPTSTR buf ) ; +: GetCurrentDirectory GetCurrentDirectoryW ; inline FUNCTION: HANDLE GetCurrentProcess ( ) ; ! FUNCTION: GetCurrentProcessId FUNCTION: HANDLE GetCurrentThread ( ) ; @@ -1387,7 +1388,8 @@ FUNCTION: BOOL SetConsoleTitleW ( LPCWSTR lpConsoleTitle ) ; ! FUNCTION: SetCPGlobal ! FUNCTION: SetCriticalSectionSpinCount ! FUNCTION: SetCurrentDirectoryA -! FUNCTION: SetCurrentDirectoryW +FUNCTION: BOOL SetCurrentDirectoryW ( LPCWSTR lpDirectory ) ; +: SetCurrentDirectory SetCurrentDirectoryW ; inline ! FUNCTION: SetDefaultCommConfigA ! FUNCTION: SetDefaultCommConfigW ! FUNCTION: SetDllDirectoryA diff --git a/vm/io.h b/vm/io.h old mode 100644 new mode 100755 index d8cc2a0578..39e7390c3e --- a/vm/io.h +++ b/vm/io.h @@ -13,5 +13,3 @@ DECLARE_PRIMITIVE(fread); DECLARE_PRIMITIVE(open_file); DECLARE_PRIMITIVE(stat); DECLARE_PRIMITIVE(read_dir); -DECLARE_PRIMITIVE(cwd); -DECLARE_PRIMITIVE(cd); diff --git a/vm/os-unix.c b/vm/os-unix.c index 41dbe9cabf..92028dfc43 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -115,19 +115,6 @@ DEFINE_PRIMITIVE(read_dir) dpush(result); } -DEFINE_PRIMITIVE(cwd) -{ - char wd[MAXPATHLEN]; - if(getcwd(wd,MAXPATHLEN) == NULL) - io_error(); - box_char_string(wd); -} - -DEFINE_PRIMITIVE(cd) -{ - chdir(unbox_char_string()); -} - DEFINE_PRIMITIVE(os_envs) { GROWABLE_ARRAY(result); diff --git a/vm/os-windows-ce.c b/vm/os-windows-ce.c index e68a6385ae..9b73692aa0 100755 --- a/vm/os-windows-ce.c +++ b/vm/os-windows-ce.c @@ -10,16 +10,6 @@ s64 current_millis(void) | (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10000; } -DEFINE_PRIMITIVE(cwd) -{ - not_implemented_error(); -} - -DEFINE_PRIMITIVE(cd) -{ - not_implemented_error(); -} - char *strerror(int err) { /* strerror() is not defined on WinCE */ diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index e356c2f674..99ac21f62f 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -8,21 +8,6 @@ s64 current_millis(void) - EPOCH_OFFSET) / 10000; } -DEFINE_PRIMITIVE(cwd) -{ - F_CHAR buf[MAX_UNICODE_PATH]; - - if(!GetCurrentDirectory(MAX_UNICODE_PATH, buf)) - io_error(); - - box_u16_string(buf); -} - -DEFINE_PRIMITIVE(cd) -{ - SetCurrentDirectory(unbox_u16_string()); -} - DEFINE_PRIMITIVE(os_envs) { GROWABLE_ARRAY(result); diff --git a/vm/os-windows.h b/vm/os-windows.h index f252c214af..a22252fde8 100755 --- a/vm/os-windows.h +++ b/vm/os-windows.h @@ -30,6 +30,7 @@ typedef wchar_t F_CHAR; F_STRING *get_error_message(void); DLLEXPORT F_CHAR *error_message(DWORD id); +void windows_error(void); void init_ffi(void); void ffi_dlopen(F_DLL *dll, bool error); diff --git a/vm/primitives.c b/vm/primitives.c index f2f8ccf18d..dc7333c667 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -109,8 +109,6 @@ void *primitives[] = { primitive_millis, primitive_type, primitive_tag, - primitive_cwd, - primitive_cd, primitive_modify_code_heap, primitive_dlopen, primitive_dlsym,