From 232ce7d9f4c5bf82bedbc34b5f3d13edf3f8d344 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <wayo.cavazos@gmail.com>
Date: Sun, 11 Nov 2007 12:11:07 -0600
Subject: [PATCH 1/9] Restored io.unix.launcher to previous state
---
extra/io/unix/launcher/launcher.factor | 25 +------------------------
1 file changed, 1 insertion(+), 24 deletions(-)
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index 61a6f706f6..45da3bf1c7 100644
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -1,36 +1,13 @@
USING: io io.launcher io.unix.backend io.nonblocking
sequences kernel namespaces math system alien.c-types
-debugger continuations combinators.lib threads ;
+debugger continuations ;
IN: io.unix.launcher
! Search unix first
USE: unix
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Factor friendly versions of the exec functions
-
-: >argv ( seq -- alien ) [ malloc-char-string ] map f add >c-void*-array ;
-
-: execv* ( pathname argv -- int ) [ malloc-char-string ] [ >argv ] bi* execv ;
-: execvp* ( filename argv -- int ) [ malloc-char-string ] [ >argv ] bi* execvp ;
-
-: execve* ( pathname argv envp -- int )
- [ malloc-char-string ] [ >argv ] [ >argv ] tri* execve ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Wait for a pid to finish without freezing up all the Factor threads.
-! Need to find a less kludgy way to do this.
-
-: wait-for-pid ( pid -- )
- dup "int" <c-object> WNOHANG waitpid
- 0 = [ 100 sleep wait-for-pid ] [ drop ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: with-fork ( child parent -- pid )
fork [ zero? -rot if ] keep ; inline
From b002cc1e9483e461d8b05d0b8b028716cccedcba Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 11 Nov 2007 16:09:24 -0500
Subject: [PATCH 2/9] Fix Windows CE UDP and <file-appender>
---
extra/io/windows/ce/sockets/sockets.factor | 153 +++++++--------------
extra/io/windows/windows.factor | 28 ++--
extra/windows/kernel32/kernel32.factor | 1 +
extra/windows/winsock/winsock.factor | 7 +-
4 files changed, 74 insertions(+), 115 deletions(-)
mode change 100644 => 100755 extra/windows/kernel32/kernel32.factor
diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor
index 659f481188..da64b25933 100755
--- a/extra/io/windows/ce/sockets/sockets.factor
+++ b/extra/io/windows/ce/sockets/sockets.factor
@@ -8,89 +8,16 @@ IN: io.windows.ce
M: windows-ce-io WSASocket-flags ( -- DWORD ) 0 ;
-TUPLE: WSAArgs
- s
- lpBuffers
- dwBufferCount
- lpNumberOfBytesRet
- lpFlags
- lpOverlapped
- lpCompletionRoutine ;
-C: <WSAArgs> WSAArgs
-
-: make-WSAArgs ( port -- <WSARecv> )
- [ port-handle win32-file-handle ] keep
- 1 "DWORD" <c-object> f f f <WSAArgs> ;
-
-: setup-WSARecv ( <WSAArgs> -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine )
- [ WSAArgs-s ] keep
- [
- WSAArgs-lpBuffers [ buffer-capacity ] keep
- buffer-end
- "WSABUF" <c-object>
- [ windows.winsock:set-WSABUF-buf ] keep
- [ windows.winsock:set-WSABUF-len ] keep
- ] keep
- [ WSAArgs-dwBufferCount ] keep
- [ WSAArgs-lpNumberOfBytesRet ] keep
- [ WSAArgs-lpFlags ] keep
- [ WSAArgs-lpOverlapped ] keep
- WSAArgs-lpCompletionRoutine ;
-
-! M: win32-socket wince-read ( port port-handle -- )
- ! drop dup make-WSAArgs dup setup-WSARecv WSARecv zero? [
- ! drop port-errored
- ! ] [
- ! WSAArgs-lpNumberOfBytesRet *uint dup zero? [
- ! drop
- ! t swap set-port-eof?
- ! ] [
- ! swap n>buffer
- ! ] if
- ! ] if ;
-
M: win32-socket wince-read ( port port-handle -- )
win32-file-handle over buffer-end pick buffer-capacity 0
windows.winsock:recv
dup windows.winsock:SOCKET_ERROR = [
drop port-errored
] [
- dup zero? [
- drop
- t swap set-port-eof?
- ] [
- swap n>buffer
- ] if
+ dup zero?
+ [ drop t swap set-port-eof? ] [ swap n>buffer ] if
] if ;
-: setup-WSASend ( <WSAArgs> -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine )
- [ WSAArgs-s ] keep
- [
- WSAArgs-lpBuffers [ buffer-length ] keep
- buffer@
- "WSABUF" <c-object>
- [ windows.winsock:set-WSABUF-buf ] keep
- [ windows.winsock:set-WSABUF-len ] keep
- ] keep
- [ WSAArgs-dwBufferCount ] keep
- [ WSAArgs-lpNumberOfBytesRet ] keep
- [ WSAArgs-lpFlags ] keep
- [ WSAArgs-lpOverlapped ] keep
- WSAArgs-lpCompletionRoutine ;
-
-! M: win32-socket wince-write ( port port-handle -- )
- ! drop dup make-WSAArgs dup setup-WSASend WSASend zero? [
- ! drop port-errored
- ! ] [
- ! FileArgs-lpNumberOfBytesRet *uint ! *DWORD
- ! over delegate [ buffer-consume ] keep
- ! buffer-length 0 > [
- ! flush-output
- ! ] [
- ! drop
- ! ] if
- ! ] if ;
-
M: win32-socket wince-write ( port port-handle -- )
win32-file-handle over buffer@ pick buffer-length 0
windows.winsock:send
@@ -100,8 +27,9 @@ M: win32-socket wince-write ( port port-handle -- )
: do-connect ( addrspec -- socket )
[ tcp-socket dup ] keep
make-sockaddr/size
- f f f f windows.winsock:WSAConnect zero?
- [ windows.winsock:winsock-error ] unless ;
+ f f f f
+ windows.winsock:WSAConnect
+ windows.winsock:winsock-error!=0/f ;
M: windows-ce-io (client) ( addrspec -- duplex-stream )
do-connect <win32-socket> dup handle>duplex-stream ;
@@ -121,7 +49,8 @@ M: windows-ce-io accept ( server -- client )
swap server-port-addr sockaddr-type heap-size
dup <byte-array> [
swap <int> f 0
- windows.winsock:WSAAccept dup windows.winsock:INVALID_SOCKET =
+ windows.winsock:WSAAccept
+ dup windows.winsock:INVALID_SOCKET =
[ windows.winsock:winsock-error ] when
] keep
] keep server-port-addr parse-sockaddr swap
@@ -132,39 +61,55 @@ M: windows-ce-io <datagram> ( addrspec -- datagram )
windows.winsock:SOCK_DGRAM server-fd <win32-socket> f <port>
] keep <datagram-port> ;
+: packet-size 65536 ; inline
+
+: receive-buffer ( -- buf )
+ \ receive-buffer get-global expired? [
+ packet-size malloc \ receive-buffer set-global
+ ] when
+ \ receive-buffer get-global ;
+
+: make-WSABUF ( len buf -- ptr )
+ "WSABUF" <c-object>
+ [ windows.winsock:set-WSABUF-buf ] keep
+ [ windows.winsock:set-WSABUF-len ] keep ;
+
+: receive-WSABUF ( -- buf )
+ packet-size receive-buffer make-WSABUF ;
+
+: packet-data ( len -- byte-array )
+ receive-buffer swap memory>string >byte-array ;
+
+packet-size <byte-array> receive-buffer set-global
+
M: windows-ce-io receive ( datagram -- packet addrspec )
dup check-datagram-port
[
port-handle win32-file-handle
- "WSABUF" <c-object>
- default-buffer-size get over windows.winsock:set-WSABUF-len
- default-buffer-size get <byte-array> over windows.winsock:set-WSABUF-buf
- [
- 1
- 0 <uint> [
- 0 <uint>
- 64 "char" <c-array> [
- 64 <int>
- f
- f
- windows.winsock:WSARecvFrom zero?
- [ windows.winsock:winsock-error ] unless
- ] keep
- ] keep *uint
- ] keep
- ] keep
- ! sockaddr count buf datagram
- >r windows.winsock:WSABUF-buf swap memory>string swap r>
- datagram-port-addr parse-sockaddr ;
+ receive-WSABUF
+ 1
+ 0 <uint> [
+ 0 <uint>
+ 64 "char" <c-array> [
+ 64 <int>
+ f
+ f
+ windows.winsock:WSARecvFrom
+ windows.winsock:winsock-error!=0/f
+ ] keep
+ ] keep *uint packet-data swap
+ ] keep datagram-port-addr parse-sockaddr ;
+
+: send-WSABUF ( byte-array -- ptr )
+ dup length packet-size > [ "UDP packet too long" throw ] when
+ dup length receive-buffer rot pick memcpy
+ receive-buffer make-WSABUF ;
M: windows-ce-io send ( packet addrspec datagram -- )
3dup check-datagram-send
port-handle win32-file-handle
- rot dup length "WSABUF" <c-object>
- [ windows.winsock:set-WSABUF-len ] keep
- [ windows.winsock:set-WSABUF-buf ] keep
-
+ rot send-WSABUF
rot make-sockaddr/size
>r >r 1 0 <uint> 0 r> r> f f
- windows.winsock:WSASendTo zero?
- [ windows.winsock:winsock-error ] unless ;
+ windows.winsock:WSASendTo
+ windows.winsock:winsock-error!=0/f ;
diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor
index 16b7c4847f..ff9cd22d23 100755
--- a/extra/io/windows/windows.factor
+++ b/extra/io/windows/windows.factor
@@ -1,9 +1,8 @@
-USING: alien alien.c-types arrays destructors io
-io.backend io.buffers io.files io.nonblocking io.sockets
-io.sockets.impl windows.errors strings io.streams.duplex
-kernel math namespaces sequences windows
-windows.kernel32 windows.winsock windows.winsock.private ;
-USE: prettyprint
+USING: alien alien.c-types arrays destructors io io.backend
+io.buffers io.files io.nonblocking io.sockets io.binary
+io.sockets.impl windows.errors strings io.streams.duplex kernel
+math namespaces sequences windows windows.kernel32
+windows.winsock windows.winsock.private ;
IN: io.windows
TUPLE: windows-nt-io ;
@@ -67,9 +66,18 @@ M: win32-file close-handle ( handle -- )
: (open-append) ( path -- handle )
normalize-pathname GENERIC_WRITE OPEN_ALWAYS open-file ;
+: set-file-pointer ( handle length -- )
+ dupd d>w/w <uint> FILE_BEGIN SetFilePointer
+ INVALID_SET_FILE_POINTER = [
+ CloseHandle "SetFilePointer failed" throw
+ ] when drop ;
+
: open-append ( path -- handle length )
- dup file-length dup
- [ >r (open-append) r> ] [ drop open-write ] if ;
+ dup file-length dup [
+ >r (open-append) r> 2dup set-file-pointer
+ ] [
+ drop open-write
+ ] if ;
TUPLE: FileArgs
hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRet lpOverlapped ;
@@ -160,13 +168,13 @@ USE: namespaces
: listen-backlog ( -- n ) HEX: 7fffffff ; inline
: listen-on-socket ( socket -- )
- listen-backlog listen winsock-error!=0/f ;
+ listen-backlog listen winsock-return-check ;
M: win32-socket stream-close ( stream -- )
win32-file-handle closesocket drop ;
M: windows-io addrinfo-error ( n -- )
- winsock-error!=0/f ;
+ winsock-return-check ;
: tcp-socket ( addrspec -- socket )
protocol-family SOCK_STREAM open-socket ;
diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor
old mode 100644
new mode 100755
index e11f6ed081..cdf87c5cca
--- a/extra/windows/kernel32/kernel32.factor
+++ b/extra/windows/kernel32/kernel32.factor
@@ -96,6 +96,7 @@ TYPEDEF: FILE_NOTIFY_INFORMATION* PFILE_NOTIFY_INFORMATION
: INVALID_HANDLE_VALUE -1 <alien> ; inline
: INVALID_FILE_SIZE HEX: FFFFFFFF ; inline
+: INVALID_SET_FILE_POINTER HEX: ffffffff ; inline
: FILE_BEGIN 0 ; inline
: FILE_CURRENT 1 ; inline
diff --git a/extra/windows/winsock/winsock.factor b/extra/windows/winsock/winsock.factor
index f87ebab0d8..7cad474cac 100755
--- a/extra/windows/winsock/winsock.factor
+++ b/extra/windows/winsock/winsock.factor
@@ -413,6 +413,11 @@ FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, voi
] when ;
: winsock-error!=0/f ( n/f -- )
+ { 0 f } member? [
+ winsock-error-string throw
+ ] unless ;
+
+: winsock-return-check ( n/f -- )
dup { 0 f } member? [
drop
] [
@@ -433,5 +438,5 @@ FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, voi
SOCKET_ERROR = [ winsock-error ] when ;
: init-winsock ( -- )
- HEX: 0202 <wsadata> WSAStartup winsock-error!=0/f ;
+ HEX: 0202 <wsadata> WSAStartup winsock-return-check ;
From a790fdf75ff848fd5d107997e3407abf8b77bfdf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 11 Nov 2007 19:30:45 -0500
Subject: [PATCH 3/9] Fix stack effect of to-refresh
---
core/flow-chart/flow-chart.factor | 74 +++++++++++++++++++++++++++++++
core/vocabs/loader/loader.factor | 2 +-
2 files changed, 75 insertions(+), 1 deletion(-)
create mode 100644 core/flow-chart/flow-chart.factor
diff --git a/core/flow-chart/flow-chart.factor b/core/flow-chart/flow-chart.factor
new file mode 100644
index 0000000000..5b6cb5f4f5
--- /dev/null
+++ b/core/flow-chart/flow-chart.factor
@@ -0,0 +1,74 @@
+USING: kernel words math inference.dataflow sequences
+optimizer.def-use combinators.private namespaces arrays
+math.parser assocs prettyprint io strings inference hashtables ;
+IN: flow-chart
+
+GENERIC: flow-chart* ( n word -- value nodes )
+
+M: word flow-chart*
+ 2drop f f ;
+
+M: compound flow-chart*
+ word-def swap 1+ [ drop <computed> ] map
+ [ dataflow-with compute-def-use ] keep
+ first dup used-by prune [ t eq? not ] subset ;
+
+GENERIC: node-word ( node -- word )
+
+M: #call node-word node-param ;
+
+M: #if node-word drop \ if ;
+
+M: #dispatch node-word drop \ dispatch ;
+
+DEFER: flow-chart
+
+: flow-chart-node ( value node -- )
+ [ node-in-d <reversed> index ] keep
+ node-word flow-chart , ;
+
+SYMBOL: pruned
+
+SYMBOL: nesting
+
+SYMBOL: max-nesting
+
+2 max-nesting set
+
+: flow-chart ( n word -- seq )
+ [
+ 2dup 2array ,
+ nesting dup inc get max-nesting get > [
+ 2drop pruned ,
+ ] [
+ flow-chart* dup length 5 > [
+ 2drop pruned ,
+ ] [
+ [ flow-chart-node ] curry* each
+ ] if
+ ] if
+ ] { } make ;
+
+: th ( n -- )
+ dup number>string write
+ 100 mod dup 20 > [ 10 mod ] when
+ H{ { 1 "st" } { 2 "nd" } { 3 "rd" } } at "th" or write ;
+
+: chart-heading. ( pair -- )
+ first2 >r 1+ th " argument to " write r> . ;
+
+GENERIC# show-chart 1 ( seq n -- )
+
+: indent CHAR: \s <string> write ;
+
+M: sequence show-chart
+ dup indent
+ >r unclip chart-heading. r>
+ 2 + [ show-chart ] curry each ;
+
+M: word show-chart
+ dup indent
+ "... pruned" print ;
+
+: flow-chart. ( n word -- )
+ flow-chart 2 show-chart ;
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index e9dc4f3e55..a7a112b58a 100644
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -145,7 +145,7 @@ SYMBOL: load-help?
: update-roots ( vocabs -- )
[ dup find-vocab-root swap vocab set-vocab-root ] each ;
-: to-refresh ( prefix -- seq )
+: to-refresh ( prefix -- modified-sources modified-docs )
child-vocabs
dup update-roots
dup modified-sources swap modified-docs ;
From b548162628aa5be5f932287f2ebbb9e13d327c62 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 12 Nov 2007 01:30:32 -0500
Subject: [PATCH 4/9] New network-clipboard tool
---
.../network-clipboard.factor | 99 +++++++++++++++++++
1 file changed, 99 insertions(+)
create mode 100644 extra/network-clipboard/network-clipboard.factor
diff --git a/extra/network-clipboard/network-clipboard.factor b/extra/network-clipboard/network-clipboard.factor
new file mode 100644
index 0000000000..208de386bd
--- /dev/null
+++ b/extra/network-clipboard/network-clipboard.factor
@@ -0,0 +1,99 @@
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.server io.sockets io strings parser byte-arrays
+namespaces ui.clipboards ui.gadgets.panes ui.gadgets.scrollers
+ui.gadgets.buttons ui.gadgets.tracks ui.gadgets ui.operations
+ui.commands ui kernel splitting combinators continuations
+sequences io.streams.duplex models ;
+IN: network-clipboard
+
+: clipboard-port 4444 ;
+
+: get-request
+ clipboard get clipboard-contents write ;
+
+: contents ( -- str )
+ [ 1024 read dup ] [ ] [ drop ] unfold concat ;
+
+: set-request
+ contents clipboard get set-clipboard-contents ;
+
+: clipboard-server ( -- )
+ clipboard-port internet-server "clip-server" [
+ readln {
+ { "GET" [ get-request ] }
+ { "SET" [ set-request ] }
+ } case
+ ] with-server ;
+
+\ clipboard-server H{
+ { +nullary+ t }
+ { +listener+ t }
+} define-command
+
+: <client-datagram> ( -- datagram )
+ "0.0.0.0" 0 <inet4> <datagram> ;
+
+: with-client ( addrspec quot -- )
+ >r <client> r> with-stream ; inline
+
+: send-text ( text host -- )
+ clipboard-port <inet4> [ write ] with-client ;
+
+TUPLE: host name ;
+
+C: <host> host
+
+M: string host-name ;
+
+: send-clipboard ( host -- )
+ host-name
+ "SET\n" clipboard get clipboard-contents append swap send-text ;
+
+[ host? ] \ send-clipboard H{ } define-operation
+
+: ask-text ( text host -- )
+ clipboard-port <inet4>
+ [ write flush contents ] with-client ;
+
+: receive-clipboard ( host -- )
+ host-name
+ "GET\n" swap ask-text
+ clipboard get set-clipboard-contents ;
+
+[ host? ] \ receive-clipboard H{ } define-operation
+
+: hosts. ( seq -- )
+ "Hosts:" print
+ [ dup <host> write-object nl ] each ;
+
+TUPLE: network-clipboard-tool ;
+
+\ network-clipboard-tool "toolbar" f {
+ { f clipboard-server }
+} define-command-map
+
+: <network-clipboard-tool> ( model -- gadget )
+ \ network-clipboard-tool construct-empty [
+ toolbar,
+ [ hosts. ] <pane-control> <scroller> 1 track,
+ ] { 0 1 } build-track ;
+
+SYMBOL: network-clipboards
+
+{ } <model> network-clipboards set-global
+
+: set-network-clipboards ( seq -- )
+ network-clipboards get set-model ;
+
+: add-network-clipboard ( host -- )
+ network-clipboards get [ swap add ] change-model ;
+
+: network-clipboard-tool ( -- )
+ [
+ network-clipboards get
+ <network-clipboard-tool>
+ "Network clipboard" open-window
+ ] with-ui ;
+
+MAIN: network-clipboard-tool
From 243caeb64ee87e0c2dca7e3dcdfafdb8aa525c21 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 12 Nov 2007 01:30:38 -0500
Subject: [PATCH 5/9] Planet fix
---
extra/webapps/planet/planet.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
index 3f7fed6446..aaefa6d324 100644
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -92,7 +92,7 @@ SYMBOL: cached-postings
cached-postings get 4 head print-posting-summaries ;
: planet-factor ( -- )
- [
+ serving-html [
"resource:extra/webapps/planet/planet.fhtml"
run-template-file
] with-html-stream ;
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 6/9] 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 )
From 9d4db784eedc37ea7603ba8252dacbbae5ec0ef4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 12 Nov 2007 01:41:27 -0500
Subject: [PATCH 7/9] io.server with-datagrams fix
---
extra/io/server/server.factor | 5 +++--
1 file changed, 3 insertions(+), 2 deletions(-)
mode change 100644 => 100755 extra/io/server/server.factor
diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor
old mode 100644
new mode 100755
index 6b42d1dc8a..6389c2c024
--- a/extra/io/server/server.factor
+++ b/extra/io/server/server.factor
@@ -80,7 +80,8 @@ SYMBOL: log-stream
: datagram-loop ( quot datagram -- )
[
- [ receive dup log-datagram >r swap call r> ] keep send
+ [ receive dup log-datagram >r swap call r> ] keep
+ pick [ send ] [ 3drop ] keep
] 2keep datagram-loop ; inline
: spawn-datagrams ( quot addrspec -- )
@@ -91,4 +92,4 @@ SYMBOL: log-stream
: with-datagrams ( seq service quot -- )
[
[ swap spawn-datagrams ] curry concurrency:parallel-each
- ] with-logging ; inline
+ ] curry with-logging ; inline
From 6f19e210b32dc8161d127d9462354db5e7657ad8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 12 Nov 2007 01:56:40 -0500
Subject: [PATCH 8/9] Fix parent-directory on /
---
core/io/files/files.factor | 14 ++++++++------
1 file changed, 8 insertions(+), 6 deletions(-)
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index efa9096791..2bbcab8f93 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -66,12 +66,14 @@ TUPLE: no-parent-directory path ;
: parent-directory ( path -- parent )
trim-path-separators
- dup root-directory? [ ] [
- dup last-path-separator drop [
- 1+ cut
- special-directory?
- [ no-parent-directory ] when
- ] when*
+ dup empty? [ drop "/" ] [
+ dup root-directory? [ ] [
+ dup last-path-separator drop [
+ 1+ cut
+ special-directory?
+ [ no-parent-directory ] when
+ ] when*
+ ] if
] if ;
: file-name ( path -- string )
From 9ebd234e98a3b4ea922380bdf45c5e333351012e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 12 Nov 2007 01:56:46 -0500
Subject: [PATCH 9/9] Fix planet USING:
---
extra/webapps/planet/planet.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
index aaefa6d324..75302eb59c 100644
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -1,7 +1,7 @@
USING: sequences rss arrays concurrency kernel sorting
html.elements io assocs namespaces math threads vocabs html
furnace http.server.templating calendar math.parser splitting
-continuations debugger system ;
+continuations debugger system http.server.responders ;
IN: webapps.planet
TUPLE: posting author title date link body ;