From bd424038350276b4c5d7e82305624716da06d4a8 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-226-177.res.carleton.edu>
Date: Fri, 12 Oct 2007 15:28:23 -0500
Subject: [PATCH 1/5] Fixed CDATA parsing bug
---
extra/xml/test/test.factor | 1 +
extra/xml/tokenize/tokenize.factor | 2 +-
2 files changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/xml/test/test.factor b/extra/xml/test/test.factor
index d9c7ca7e9d..a2fd2813ed 100644
--- a/extra/xml/test/test.factor
+++ b/extra/xml/test/test.factor
@@ -42,3 +42,4 @@ SYMBOL: xml-file
] unit-test
[ "foo" ] [ "<x y='foo'/>" string>xml "y" <name-tag> over
at swap "z" <name-tag> >r tuck r> swap set-at T{ name f "blah" "z" f } swap at ] unit-test
+[ "foo" ] [ "<boo><![CDATA[foo]]></boo>" string>xml children>string ] unit-test
diff --git a/extra/xml/tokenize/tokenize.factor b/extra/xml/tokenize/tokenize.factor
index d89ae57de9..5e3bf1edfa 100644
--- a/extra/xml/tokenize/tokenize.factor
+++ b/extra/xml/tokenize/tokenize.factor
@@ -137,7 +137,7 @@ SYMBOL: ns-stack
CHAR: > expect ;
: take-cdata ( -- string )
- "[CDATA[" expect-string "]]>" take-string next ;
+ "[CDATA[" expect-string "]]>" take-string ;
: take-directive ( -- directive )
CHAR: > take-char <directive> next ;
From 18259cdaa4ec36eeb94b564c596c14c6d0ff154e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 15 Oct 2007 06:23:00 -0400
Subject: [PATCH 2/5] Fix interactor problem when loading a vocab which has a
parse error
---
extra/ui/tools/interactor/interactor.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor
index d0791ac5ab..ca70895b09 100644
--- a/extra/ui/tools/interactor/interactor.factor
+++ b/extra/ui/tools/interactor/interactor.factor
@@ -137,7 +137,7 @@ M: interactor stream-read-partial
[ restore-vars parse ] keep save-vars
] [
>r f swap set-interactor-busy? drop r>
- dup [ unexpected-eof? ] is? [ drop f ] when
+ dup delegate unexpected-eof? [ drop f ] when
] recover
] with-scope ;
From ceba5efb1f5101bada1e12712b89b15671618cda Mon Sep 17 00:00:00 2001
From: "U-C4\\Administrator" <Administrator@c4.(none)>
Date: Mon, 15 Oct 2007 15:01:55 -0500
Subject: [PATCH 3/5] Redo destructors so they compile Fix all uses of
add-destructor
---
extra/destructors/destructors-docs.factor | 38 +++++----
extra/destructors/destructors-tests.factor | 24 ++++--
extra/destructors/destructors.factor | 92 +++++++++++++++++-----
extra/destructors/unix/unix.factor | 9 +++
extra/destructors/windows/windows.factor | 11 +++
extra/io/sniffer/bsd/bsd.factor | 4 +-
extra/io/windows/launcher/launcher.factor | 30 ++++---
extra/io/windows/mmap/mmap.factor | 8 +-
extra/io/windows/nt/backend/backend.factor | 2 +-
extra/io/windows/nt/sockets/sockets.factor | 20 ++---
extra/io/windows/windows.factor | 4 +-
11 files changed, 174 insertions(+), 68 deletions(-)
mode change 100644 => 100755 extra/destructors/destructors.factor
create mode 100644 extra/destructors/unix/unix.factor
create mode 100644 extra/destructors/windows/windows.factor
mode change 100644 => 100755 extra/io/windows/launcher/launcher.factor
mode change 100644 => 100755 extra/io/windows/nt/backend/backend.factor
mode change 100644 => 100755 extra/io/windows/nt/sockets/sockets.factor
diff --git a/extra/destructors/destructors-docs.factor b/extra/destructors/destructors-docs.factor
index 104641d368..dace054db8 100644
--- a/extra/destructors/destructors-docs.factor
+++ b/extra/destructors/destructors-docs.factor
@@ -1,25 +1,31 @@
-USING: help.markup help.syntax kernel destructors ;
+USING: help.markup help.syntax libc kernel destructors ;
IN: destructors
-HELP: add-destructor
-{ $values { "obj" "an object" }
- { "quot" "a quotation" }
- { "always?" "always cleanup?" }
-} { $description "Adds a destructor to be invoked by the " { $link call-destructors } " word to the current dynamic scope. Setting the 'always cleanup?' flag to f allows for keeping resources, such as a successfully opened file descriptor, open after a call to " { $link with-destructors } "." }
-{ $notes "The use of the " { $link with-destructors } " word is preferred over calling " { $link call-destructors } " manually." $nl
-"Destructors are not allowed to throw exceptions. No exceptions." }
-{ $see-also call-destructors with-destructors } ;
+HELP: free-always
+{ $values { "alien" "alien returned by malloc" } }
+{ $description "Adds a destructor that will " { $link free } " the alien. The free will happen whenever the quotation passed to " { $link with-destructors } " ends." }
+{ $see-also free-later } ;
-HELP: call-destructors
-{ $description "Iterates through a sequence of destructor tuples, calling the destructor quotation on each one." }
-{ $notes "The use of the " { $link with-destructors } " word is preferred over calling " { $link call-destructors } " manually." }
-{ $see-also add-destructor with-destructors } ;
+HELP: free-later
+{ $values { "alien" "alien returned by malloc" } }
+{ $description "Adds a destructor that will " { $link free } " the alien. The free will happen whenever the quotation passed to " { $link with-destructors } " errors or else the object will persist and manual cleanup is required later." }
+{ $see-also free-always } ;
+
+HELP: close-always
+{ $values { "handle" "an OS-dependent handle" } }
+{ $description "Adds a destructor that will close the system resource upon reaching the end of the quotation passed to " { $link with-destructors } "." }
+{ $see-also close-later } ;
+
+HELP: close-later
+{ $values { "handle" "an OS-dependent handle" } }
+{ $description "Adds a destructor that will close the system resource if an error occurs in the quotation passed to " { $link with-destructors } ". Otherwise, manual cleanup of the resource is required later." }
+{ $see-also close-always } ;
HELP: with-destructors
{ $values { "quot" "a quotation" } }
-{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by calling " { $link add-destructor } ". After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
+{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link (destruct) } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
{ $notes "Destructors are not allowed to throw exceptions. No exceptions." }
{ $examples
- { $code "[ 10 malloc dup [ free \"free 10 bytes\" print ] t add-destructor drop ] with-destructors" }
+ { $code "[ 10 malloc free-always ] with-destructors" }
}
-{ $see-also add-destructor call-destructors } ;
+{ $see-also } ;
diff --git a/extra/destructors/destructors-tests.factor b/extra/destructors/destructors-tests.factor
index a6ef2dc4be..bebbca420f 100644
--- a/extra/destructors/destructors-tests.factor
+++ b/extra/destructors/destructors-tests.factor
@@ -3,27 +3,39 @@ IN: temporary
TUPLE: dummy-obj destroyed? ;
+TUPLE: dummy-destructor ;
+
+: <dummy-destructor> ( obj ? -- newobj )
+ <destructor> dummy-destructor construct-delegate ;
+
+M: dummy-destructor (destruct) ( obj -- )
+ destructor-obj t swap set-dummy-obj-destroyed? ;
+
: <dummy-obj>
\ dummy-obj construct-empty ;
+: destroy-always
+ t <dummy-destructor> push-destructor ;
+
+: destroy-later
+ f <dummy-destructor> push-destructor ;
+
[ t ] [
[
- <dummy-obj>
- dup [ t swap set-dummy-obj-destroyed? ] t add-destructor
+ <dummy-obj> dup destroy-always
] with-destructors dummy-obj-destroyed?
] unit-test
[ f ] [
[
- <dummy-obj>
- dup [ t swap set-dummy-obj-destroyed? ] f add-destructor
+ <dummy-obj> dup destroy-later
] with-destructors dummy-obj-destroyed?
] unit-test
[ t ] [
<dummy-obj> [
[
- dup [ t swap set-dummy-obj-destroyed? ] t add-destructor
+ dup destroy-always
"foo" throw
] with-destructors
] catch drop dummy-obj-destroyed?
@@ -32,7 +44,7 @@ TUPLE: dummy-obj destroyed? ;
[ t ] [
<dummy-obj> [
[
- dup [ t swap set-dummy-obj-destroyed? ] f add-destructor
+ dup destroy-later
"foo" throw
] with-destructors
] catch drop dummy-obj-destroyed?
diff --git a/extra/destructors/destructors.factor b/extra/destructors/destructors.factor
old mode 100644
new mode 100755
index a4007bd2cf..42a6d4a0c9
--- a/extra/destructors/destructors.factor
+++ b/extra/destructors/destructors.factor
@@ -1,38 +1,94 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: continuations kernel namespaces sequences vectors ;
+USING: continuations io.backend libc kernel namespaces
+sequences system vectors ;
IN: destructors
SYMBOL: destructors
-SYMBOL: errored?
-TUPLE: destructor obj quot always? ;
-<PRIVATE
+TUPLE: destructor obj always? destroyed? ;
-: filter-destructors ( -- )
- errored? get [
- destructors [ [ destructor-always? ] subset ] change
- ] unless ;
+: <destructor> ( obj always? -- newobj )
+ {
+ set-destructor-obj
+ set-destructor-always?
+ } destructor construct ;
-PRIVATE>
+: push-destructor ( obj -- )
+ destructors [ ?push ] change ;
-: add-destructor ( obj quot always? -- )
- \ destructor construct-boa destructors [ ?push ] change ;
+GENERIC: (destruct) ( obj -- )
-: call-destructors ( -- )
- destructors get [
- dup destructor-obj swap destructor-quot call
- ] each ;
+: destruct ( obj -- )
+ dup destructor-destroyed? [
+ drop
+ ] [
+ [ (destruct) t ] keep set-destructor-destroyed?
+ ] if ;
+
+: destruct-always ( destructor -- )
+ dup destructor-always? [
+ destruct
+ ] [
+ drop
+ ] if ;
: with-destructors ( quot -- )
[
- [ call ] [ errored? on ] recover
- filter-destructors call-destructors
- errored? get [ rethrow ] when
+ [ call ]
+ [ destructors get [ destruct-always ] each ]
+ [ destructors get [ destruct ] each ] cleanup
] with-scope ; inline
+TUPLE: memory-destructor ;
+
+: <memory-destructor> ( obj ? -- newobj )
+ <destructor> memory-destructor construct-delegate ;
+
+TUPLE: handle-destructor ;
+
+: <handle-destructor> ( obj ? -- newobj )
+ <destructor> handle-destructor construct-delegate ;
+
+TUPLE: socket-destructor ;
+
+: <socket-destructor> ( obj ? -- newobj )
+ <destructor> socket-destructor construct-delegate ;
+
+M: memory-destructor (destruct) ( obj -- )
+ destructor-obj free ;
+
+HOOK: (handle-destructor) io-backend ( obj -- )
+HOOK: (socket-destructor) io-backend ( obj -- )
+
+M: handle-destructor (destruct) ( obj -- ) (handle-destructor) ;
+M: socket-destructor (destruct) ( obj -- ) (socket-destructor) ;
+
+: free-always ( alien -- )
+ t <memory-destructor> push-destructor ;
+
+: free-later ( alien -- )
+ f <memory-destructor> push-destructor ;
+
+: close-always ( handle -- )
+ t <handle-destructor> push-destructor ;
+
+: close-later ( handle -- )
+ f <handle-destructor> push-destructor ;
+
+: close-socket-always ( handle -- )
+ t <socket-destructor> push-destructor ;
+
+: close-socket-later ( handle -- )
+ f <socket-destructor> push-destructor ;
+
+USE-IF: windows? destructors.windows
+USE-IF: unix? destructors.unix
+
+
+
! : add-destructor ( word quot -- )
! >quotation
! "slot-destructor" set-word-prop ;
diff --git a/extra/destructors/unix/unix.factor b/extra/destructors/unix/unix.factor
new file mode 100644
index 0000000000..b971ef669e
--- /dev/null
+++ b/extra/destructors/unix/unix.factor
@@ -0,0 +1,9 @@
+USING: destructors io.windows kernel qualified ;
+QUALIFIED: unix
+IN: detructors.unix
+
+M: unix-io (handle-destructor) ( obj -- )
+ destructor-obj close drop ;
+
+
+
diff --git a/extra/destructors/windows/windows.factor b/extra/destructors/windows/windows.factor
new file mode 100644
index 0000000000..1cb937c2eb
--- /dev/null
+++ b/extra/destructors/windows/windows.factor
@@ -0,0 +1,11 @@
+USING: destructors io.windows kernel windows.kernel32
+windows.winsock ;
+IN: detructors.windows
+
+M: windows-io (handle-destructor) ( obj -- )
+ destructor-obj CloseHandle drop ;
+
+M: windows-io (socket-destructor) ( obj -- )
+ destructor-obj closesocket drop ;
+
+
diff --git a/extra/io/sniffer/bsd/bsd.factor b/extra/io/sniffer/bsd/bsd.factor
index 71e71ce91b..56b536cc39 100644
--- a/extra/io/sniffer/bsd/bsd.factor
+++ b/extra/io/sniffer/bsd/bsd.factor
@@ -50,7 +50,7 @@ C: <sniffer-spec> sniffer-spec
: make-ifreq-props ( ifname -- ifreq )
"ifreq" <c-object>
12 <short> 16 0 pad-right over set-ifreq-props
- swap malloc-char-string dup [ free ] t add-destructor
+ swap malloc-char-string dup free-always
over set-ifreq-name ;
: make-ioctl-buffer ( fd -- buffer )
@@ -77,7 +77,7 @@ M: unix-io <sniffer> ( obj -- sniffer )
[
sniffer-spec-path
open-read
- dup [ unix:close ] f add-destructor
+ dup close-later
] keep
dupd sniffer-spec-ifname ioctl-sniffer-fd
dup make-ioctl-buffer
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
old mode 100644
new mode 100755
index f012f8d736..a67aa96ce8
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -1,7 +1,10 @@
-USING: alien alien.c-types destructors io.windows libc
+USING: alien alien.c-types arrays continuations
+destructors io.windows libc
io.nonblocking io.streams.duplex windows.types math
windows.kernel32 windows namespaces io.launcher kernel
-io.windows.nt.backend ;
+sequences io.windows.nt.backend windows.errors ;
+USE: io
+USE: prettyprint
IN: io.windows.launcher
! From MSDN: "Handles in PROCESS_INFORMATION must be closed with CloseHandle when they are no longer needed."
@@ -88,35 +91,44 @@ C: <pipe> pipe
: ERROR_PIPE_CONNECT 535 ; inline
+: pipe-connect-error? ( n -- ? )
+ ERROR_SUCCESS ERROR_PIPE_CONNECT 2array member? not ;
+
+! clear "ls" <process-stream> contents
M: windows-nt-io <process-stream> ( command -- stream )
[
+
+ break
default-CreateProcess-args
TRUE over set-CreateProcess-args-bInheritHandles
- ! over set-CreateProcess-args-stdin-pipe
-
dup CreateProcess-args-lpStartupInfo
STARTF_USESTDHANDLES over set-STARTUPINFO-dwFlags
factor-pipe-name create-named-pipe
+ global [ "Named pipe: " write dup . ] bind
dup t set-inherit
[ add-completion ] keep
! CreateFile
! factor-pipe-name open-pipe-r/w
- factor-pipe-name GENERIC_READ GENERIC_WRITE bitor 0 f OPEN_EXISTING FILE_FLAG_OVERLAPPED f CreateFile dup invalid-handle? dup [ CloseHandle drop ] f add-destructor
+ factor-pipe-name GENERIC_READ GENERIC_WRITE bitor
+ 0 f OPEN_EXISTING FILE_FLAG_OVERLAPPED f
+ CreateFile
+ global [ "Created File: " write dup . ] bind
+ dup invalid-handle? dup close-later
dup add-completion
swap (make-overlapped) ConnectNamedPipe zero? [
- GetLastError ERROR_PIPE_CONNECT = [
+ GetLastError pipe-connect-error? [
win32-error-string throw
- ] unless
+ ] when
] when
-
dup t set-inherit
! ERROR_PIPE_CONNECTED
[ pick set-CreateProcess-args-stdin-pipe ] keep
+ global [ "Setting the stdios to: " write dup . ] bind
[ over set-STARTUPINFO-hStdOutput ] keep
[ over set-STARTUPINFO-hStdInput ] keep
swap set-STARTUPINFO-hStdError
@@ -134,7 +146,7 @@ M: windows-nt-io <process-stream> ( command -- stream )
0
CreatePipe win32-error=0/f
] 2keep
- [ *void* dup [ CloseHandle ] f add-destructor ] 2apply <pipe> ;
+ [ *void* dup close-later ] 2apply <pipe> ;
M: windows-ce-io <process-stream>
[
diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor
index cf8318e5cf..2742d1b006 100644
--- a/extra/io/windows/mmap/mmap.factor
+++ b/extra/io/windows/mmap/mmap.factor
@@ -31,7 +31,7 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
"TOKEN_PRIVILEGES" <c-object>
1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep
"LUID_AND_ATTRIBUTES" malloc-array
- dup [ free ] t add-destructor over set-TOKEN_PRIVILEGES-Privileges
+ dup free-always over set-TOKEN_PRIVILEGES-Privileges
swap [
SE_PRIVILEGE_ENABLED over TOKEN_PRIVILEGES-Privileges
@@ -60,10 +60,10 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
{ "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
>r >r open-file dup f r> 0 0 f
CreateFileMapping [ win32-error=0/f ] keep
- dup [ CloseHandle drop ] f add-destructor
+ dup close-later
dup
r> 0 0 0 MapViewOfFile [ win32-error=0/f ] keep
- dup [ CloseHandle drop ] f add-destructor
+ dup close-later
] with-privileges ;
M: windows-io <mapped-file> ( path length -- mmap )
@@ -81,7 +81,7 @@ M: windows-io <mapped-file> ( path length -- mmap )
M: windows-io close-mapped-file ( mapped-file -- )
[
dup mapped-file-handle [
- [ CloseHandle drop ] t add-destructor
+ close-always
] each
mapped-file-address UnmapViewOfFile win32-error=0/f
] with-destructors ;
diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor
old mode 100644
new mode 100755
index 1700f725e8..a7f803fd7f
--- a/extra/io/windows/nt/backend/backend.factor
+++ b/extra/io/windows/nt/backend/backend.factor
@@ -40,7 +40,7 @@ TUPLE: io-callback port continuation ;
C: <io-callback> io-callback
: (make-overlapped) ( -- overlapped-ext )
- "OVERLAPPED" malloc-object dup [ free ] t add-destructor
+ "OVERLAPPED" malloc-object dup free-always
0 over set-OVERLAPPED-internal
0 over set-OVERLAPPED-internal-high
0 over set-OVERLAPPED-offset-high
diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor
old mode 100644
new mode 100755
index 28df61eb27..0767c08002
--- a/extra/io/windows/nt/sockets/sockets.factor
+++ b/extra/io/windows/nt/sockets/sockets.factor
@@ -81,7 +81,7 @@ TUPLE: AcceptEx-args port
: init-accept-buffer ( server-port AcceptEx -- )
>r server-port-addr sockaddr-type heap-size 16 +
- dup dup 2 * malloc dup [ free ] t add-destructor r>
+ dup dup 2 * malloc dup free-always r>
[ set-AcceptEx-args-lpOutputBuffer* ] keep
[ set-AcceptEx-args-dwLocalAddressLength* ] keep
set-AcceptEx-args-dwRemoteAddressLength* ;
@@ -174,17 +174,17 @@ TUPLE: WSARecvFrom-args port
set-WSARecvFrom-args-s*
] 2keep [
>r datagram-port-addr sockaddr-type heap-size r>
- 2dup >r malloc dup [ free ] t add-destructor r> set-WSARecvFrom-args-lpFrom*
- >r malloc-int dup [ free ] t add-destructor r> set-WSARecvFrom-args-lpFromLen*
+ 2dup >r malloc dup free-always r> set-WSARecvFrom-args-lpFrom*
+ >r malloc-int dup free-always r> set-WSARecvFrom-args-lpFromLen*
] keep
- "WSABUF" malloc-object dup [ free ] t add-destructor
+ "WSABUF" malloc-object dup free-always
2dup swap set-WSARecvFrom-args-lpBuffers*
- default-buffer-size [ malloc dup [ free ] t add-destructor ] keep
+ default-buffer-size [ malloc dup free-always ] keep
pick set-WSABUF-len
swap set-WSABUF-buf
1 over set-WSARecvFrom-args-dwBufferCount*
- 0 malloc-int dup [ free ] t add-destructor over set-WSARecvFrom-args-lpFlags*
- 0 malloc-int dup [ free ] t add-destructor over set-WSARecvFrom-args-lpNumberOfBytesRecvd*
+ 0 malloc-int dup free-always over set-WSARecvFrom-args-lpFlags*
+ 0 malloc-int dup free-always over set-WSARecvFrom-args-lpNumberOfBytesRecvd*
(make-overlapped) [ over set-WSARecvFrom-args-lpOverlapped* ] keep
swap WSARecvFrom-args-port set-port-overlapped ;
@@ -230,14 +230,14 @@ TUPLE: WSASendTo-args port
set-WSASendTo-args-s*
] keep [
>r make-sockaddr >r
- malloc-byte-array dup [ free ] t add-destructor
+ malloc-byte-array dup free-always
r> heap-size r>
[ set-WSASendTo-args-iToLen* ] keep
set-WSASendTo-args-lpTo*
] keep [
- "WSABUF" malloc-object dup [ free ] t add-destructor
+ "WSABUF" malloc-object dup free-always
dup rot set-WSASendTo-args-lpBuffers*
- swap [ malloc-byte-array dup [ free ] t add-destructor ] keep length
+ swap [ malloc-byte-array dup free-always ] keep length
rot [ set-WSABUF-len ] keep
set-WSABUF-buf
] keep
diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor
index b56486915d..8e8c14c5c3 100644
--- a/extra/io/windows/windows.factor
+++ b/extra/io/windows/windows.factor
@@ -48,7 +48,7 @@ M: win32-file init-handle ( handle -- ) drop ;
: open-file ( path access-mode create-mode -- handle )
[
>r share-mode f r> CreateFile-flags f CreateFile
- dup invalid-handle? dup [ CloseHandle drop ] f add-destructor
+ dup invalid-handle? dup close-later
dup add-completion
] with-destructors ;
@@ -168,7 +168,7 @@ USE: windows.winsock
: server-fd ( addrspec type -- fd )
>r dup protocol-family r> open-socket
- dup [ closesocket drop ] f add-destructor
+ dup close-socket-later
dup rot make-sockaddr heap-size bind socket-error ;
USE: namespaces
From 35bd6202ef21ec5f4b9276413eb604126600053c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 15 Oct 2007 16:44:40 -0400
Subject: [PATCH 4/5] Fix webapps/help bug
---
extra/html/html.factor | 7 +-
extra/webapps/help/help.factor | 9 ++-
extra/webapps/planet/planet.factor | 118 +++++++++++++++++++++++++++++
extra/webapps/planet/planet.fhtml | 39 ++++++++++
4 files changed, 168 insertions(+), 5 deletions(-)
create mode 100644 extra/webapps/planet/planet.factor
create mode 100644 extra/webapps/planet/planet.fhtml
diff --git a/extra/html/html.factor b/extra/html/html.factor
index 9db97957a5..137cc473d3 100644
--- a/extra/html/html.factor
+++ b/extra/html/html.factor
@@ -35,8 +35,11 @@ TUPLE: html-sub-stream style stream ;
stdio get delegate stream-write ;
: object-link-tag ( style quot -- )
- presented pick at browser-link-href
- [ <a =href a> call </a> ] [ call ] if* ; inline
+ presented pick at [
+ browser-link-href [
+ <a =href a> call </a>
+ ] [ call ] if*
+ ] [ call ] if* ; inline
: hex-color, ( triplet -- )
3 head-slice
diff --git a/extra/webapps/help/help.factor b/extra/webapps/help/help.factor
index 366baffcb9..8456e499f1 100644
--- a/extra/webapps/help/help.factor
+++ b/extra/webapps/help/help.factor
@@ -20,8 +20,8 @@ IN: webapps.help
} define-action
M: link browser-link-href
- link-name
- dup word? [
+ link-name
+ dup word? over f eq? or [
browser-link-href
] [
dup array? [ " " join ] when
@@ -32,10 +32,13 @@ M: link browser-link-href
lookup show-help ;
\ show-word {
- { "vocab" "kernel" v-default }
{ "word" "call" v-default }
+ { "vocab" "kernel" v-default }
} define-action
+M: f browser-link-href
+ drop \ f browser-link-href ;
+
M: word browser-link-href
dup word-name swap word-vocabulary
[ show-word ] 2curry quot-link ;
diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
new file mode 100644
index 0000000000..bdbb1ccd29
--- /dev/null
+++ b/extra/webapps/planet/planet.factor
@@ -0,0 +1,118 @@
+USING: sequences rss arrays concurrency kernel sorting
+html.elements io assocs namespaces math threads vocabs html
+furnace http.server.templating calendar math.parser splitting ;
+IN: webapps.planet
+
+TUPLE: posting author title date link body ;
+
+: diagnostic write print flush ;
+
+: fetch-feed ( pair -- feed )
+ second
+ dup "Fetching " diagnostic
+ dup news-get feed-entries
+ swap "Done fetching " diagnostic ;
+
+: fetch-blogroll ( blogroll -- entries )
+ #! entries is an array of { author entries } pairs.
+ dup [
+ [ fetch-feed ] [ error. drop f ] recover
+ ] parallel-map [ ] subset
+ [ [ >r first r> 2array ] curry* map ] 2map concat ;
+
+: sort-entries ( entries -- entries' )
+ [ [ second entry-pub-date ] compare ] sort <reversed> ;
+
+: <posting> ( pair -- posting )
+ #! pair has shape { author entry }
+ first2
+ { entry-title entry-pub-date entry-link entry-description }
+ get-slots posting construct-boa ;
+
+: print-posting-summary ( posting -- )
+ <p "news" =class p>
+ <b> dup posting-title write </b> <br/>
+ "- " write
+ dup posting-author write bl
+ <a posting-link =href "more" =class a>
+ "Read More..." write
+ </a>
+ </p> ;
+
+: print-posting-summaries ( postings -- )
+ [ print-posting-summary ] each ;
+
+: print-blogroll ( blogroll -- )
+ <ul "description" =class ul>
+ [
+ <li> <a dup third =href a> first write </a> </li>
+ ] each
+ </ul> ;
+
+: format-date ( date -- string )
+ 10 head "-" split [ string>number ] map
+ first3 0 0 0 0 <timestamp>
+ [
+ dup timestamp-day #
+ " " %
+ dup timestamp-month month-abbreviations nth %
+ ", " %
+ timestamp-year #
+ ] "" make ;
+
+: print-posting ( posting -- )
+ <h2 "posting-title" =class h2>
+ <a dup posting-link =href a>
+ dup posting-title write
+ " - " write
+ dup posting-author write
+ </a>
+ </h2>
+ <p "posting-body" =class p> dup posting-body write-html </p>
+ <p "posting-date" =class p> posting-date format-date write </p> ;
+
+: print-postings ( postings -- )
+ [ print-posting ] each ;
+
+: browse-webapp-source ( vocab -- )
+ <a f >vocab-link browser-link-href =href a>
+ "Browse source" write
+ </a> ;
+
+SYMBOL: default-blogroll
+SYMBOL: cached-postings
+
+: update-cached-postings ( -- )
+ default-blogroll get fetch-blogroll sort-entries
+ [ <posting> ] map
+ cached-postings set-global ;
+
+: mini-planet-factor ( -- )
+ cached-postings get 4 head print-posting-summaries ;
+
+: planet-factor ( -- )
+ [
+ "resource:extra/webapps/planet/planet.fhtml"
+ run-template-file
+ ] with-html-stream ;
+
+\ planet-factor { } define-action
+
+{
+ { "Chris Double" "http://www.bluishcoder.co.nz/atom.xml" "http://www.bluishcoder.co.nz/" }
+ { "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" }
+ { "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" }
+ { "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" }
+ { "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" }
+ { "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" }
+} default-blogroll set-global
+
+: update-thread ( -- )
+ [ update-cached-postings ] try
+ 10 60 * 1000 * sleep
+ update-thread ;
+
+: start-update-thread ( -- )
+ [ update-thread ] in-thread ;
+
+"planet" "planet-factor" "extra/webapps/planet" web-app
diff --git a/extra/webapps/planet/planet.fhtml b/extra/webapps/planet/planet.fhtml
new file mode 100644
index 0000000000..fb5a673077
--- /dev/null
+++ b/extra/webapps/planet/planet.fhtml
@@ -0,0 +1,39 @@
+<% USING: namespaces html.elements webapps.planet sequences ; %>
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+ <meta http-equiv="Content-type" content="text/html; charset=utf-8" />
+
+ <title>planet-factor</title>
+ <link rel="stylesheet" href="/responder/file/css/news.css" type="text/css" media="screen" title="no title" charset="utf-8" />
+</head>
+
+<body id="index">
+ <h1 class="planet-title">[ planet-factor ]</h1>
+ <table width="100%" cellpadding="10">
+ <tr>
+ <td> <% cached-postings get 20 head print-postings %> </td>
+ <td valign="top" width="25%" class="infobox">
+ <p>
+ <b>planet-factor</b> is an Atom/RSS aggregator that collects the
+ contents of <a href="http://factorcode.org/">Factor</a>-related blogs. It is inspired by
+ <a href="http://planet.lisp.org">Planet Lisp</a>.
+ </p>
+ <p>
+ This webapp is written in <a href="http://factorcode.org/">Factor</a>.
+ <% "webapps.planet" browse-webapp-source %>
+ </p>
+ <h2 class="blogroll-title">Blogroll</h2>
+ <% default-blogroll get print-blogroll %>
+ <p>
+ If you want your weblog added to the blogroll, <a href="http://factorcode.org/gethelp.fhtml">just ask</a>.
+ </p>
+ </td>
+ </tr>
+ </table>
+</body>
+
+</html>
From 1306649c59cdbbe9666ed332680174cab88db6ef Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 15 Oct 2007 16:46:39 -0400
Subject: [PATCH 5/5] Fix from Sam
---
extra/models/models-docs.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/models/models-docs.factor b/extra/models/models-docs.factor
index aaa7ee32ee..2b58381fe0 100644
--- a/extra/models/models-docs.factor
+++ b/extra/models/models-docs.factor
@@ -83,7 +83,7 @@ HELP: filter
{ $examples
"The following code displays a label showing the result of applying " { $link sq } " to the value 5:"
{ $code
- "USING: models gadgets-labels gadgets-panes ;"
+ "USING: models ui.gadgets.labels ui.gadgets.panes ;"
"5 <model> [ sq ] <filter> [ number>string ] <filter>"
"<label-control> gadget."
}
@@ -142,7 +142,7 @@ HELP: delay
{ $examples
"The following code displays a sliders and a label which is updated half a second after the slider stops changing:"
{ $code
- "USING: models gadgets-labels gadgets-sliders gadgets-panes ;"
+ "USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes ;"
": <funny-slider>"
" 0 0 0 100 <range> <x-slider> 500 over set-slider-max ;"
"<funny-slider> dup gadget."