From 6afa62b57cee77dae0c62ed4f192204127b3d402 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 22 Apr 2008 20:19:54 -0500
Subject: [PATCH 01/14] Add RFC822 date parser
---
extra/calendar/calendar-tests.factor | 4 +
extra/calendar/calendar.factor | 35 +++---
extra/calendar/format/format-tests.factor | 33 ++++--
extra/calendar/format/format.factor | 100 +++++++++++++-----
.../{blog-summary.xml => blog-admin-link.xml} | 0
.../{mini-planet.xml => postings-summary.xml} | 0
6 files changed, 124 insertions(+), 48 deletions(-)
rename extra/webapps/planet/{blog-summary.xml => blog-admin-link.xml} (100%)
rename extra/webapps/planet/{mini-planet.xml => postings-summary.xml} (100%)
diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor
index e49d3ad894..c05d4f60eb 100755
--- a/extra/calendar/calendar-tests.factor
+++ b/extra/calendar/calendar-tests.factor
@@ -2,6 +2,10 @@ USING: arrays calendar kernel math sequences tools.test
continuations system ;
IN: calendar.tests
+\ time+ must-infer
+\ time* must-infer
+\ time- must-infer
+
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 2 30 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2003 2 29 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor
index 8dcb4af7f1..2f93bf8218 100755
--- a/extra/calendar/calendar.factor
+++ b/extra/calendar/calendar.factor
@@ -211,12 +211,14 @@ M: duration time+
#! Uses average month/year length since dt loses calendar
#! data
0 swap
- [ year>> + ] keep
- [ month>> months-per-year / + ] keep
- [ day>> days-per-year / + ] keep
- [ hour>> hours-per-year / + ] keep
- [ minute>> minutes-per-year / + ] keep
- second>> seconds-per-year / + ;
+ {
+ [ year>> + ]
+ [ month>> months-per-year / + ]
+ [ day>> days-per-year / + ]
+ [ hour>> hours-per-year / + ]
+ [ minute>> minutes-per-year / + ]
+ [ second>> seconds-per-year / + ]
+ } cleave ;
M: duration <=> [ dt>years ] compare ;
@@ -252,14 +254,21 @@ M: timestamp time-
#! Exact calendar-time difference
(time-) seconds ;
+: time* ( obj1 obj2 -- obj3 )
+ dup real? [ swap ] when
+ dup real? [ * ] [
+ {
+ [ year>> * ]
+ [ month>> * ]
+ [ day>> * ]
+ [ hour>> * ]
+ [ minute>> * ]
+ [ second>> * ]
+ } 2cleave <duration>
+ ] if ;
+
: before ( dt -- -dt )
- [ year>> neg ] keep
- [ month>> neg ] keep
- [ day>> neg ] keep
- [ hour>> neg ] keep
- [ minute>> neg ] keep
- second>> neg
- <duration> ;
+ -1 time* ;
M: duration time-
before time+ ;
diff --git a/extra/calendar/format/format-tests.factor b/extra/calendar/format/format-tests.factor
index 88bd0733c0..1ba892bef3 100755
--- a/extra/calendar/format/format-tests.factor
+++ b/extra/calendar/format/format-tests.factor
@@ -1,26 +1,45 @@
-USING: calendar.format calendar kernel tools.test
-io.streams.string ;
+USING: calendar.format calendar kernel math tools.test
+io.streams.string accessors io ;
IN: calendar.format.tests
[ 0 ] [
- "Z" [ read-rfc3339-gmt-offset ] with-string-reader
+ "Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
] unit-test
[ 1 ] [
- "+01" [ read-rfc3339-gmt-offset ] with-string-reader
+ "+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
] unit-test
[ -1 ] [
- "-01" [ read-rfc3339-gmt-offset ] with-string-reader
+ "-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
] unit-test
[ -1-1/2 ] [
- "-01:30" [ read-rfc3339-gmt-offset ] with-string-reader
+ "-01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
] unit-test
[ 1+1/2 ] [
- "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader
+ "+01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours
] unit-test
[ ] [ now timestamp>rfc3339 drop ] unit-test
[ ] [ now timestamp>rfc822 drop ] unit-test
+
+[ 8/1000 -4 ] [
+ "2008-04-19T04:56:00.008-04:00" rfc3339>timestamp
+ [ second>> ] [ gmt-offset>> hour>> ] bi
+] unit-test
+
+[ T{ duration f 0 0 0 0 0 0 } ] [
+ "GMT" parse-rfc822-gmt-offset
+] unit-test
+
+[ T{ duration f 0 0 0 -5 0 0 } ] [
+ "-0500" parse-rfc822-gmt-offset
+] unit-test
+
+[ T{ timestamp f 2008 4 22 14 36 12 T{ duration f 0 0 0 0 0 0 } } ] [
+ "Tue, 22 Apr 2008 14:36:12 GMT" rfc822>timestamp
+] unit-test
+
+[ t ] [ now dup timestamp>rfc822 rfc822>timestamp time- 1 seconds before? ] unit-test
diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor
index 26ed873fd3..7bdaea70b5 100755
--- a/extra/calendar/format/format.factor
+++ b/extra/calendar/format/format.factor
@@ -1,5 +1,6 @@
USING: math math.parser kernel sequences io calendar
-accessors arrays io.streams.string combinators accessors ;
+accessors arrays io.streams.string splitting
+combinators accessors debugger ;
IN: calendar.format
GENERIC: day. ( obj -- )
@@ -58,11 +59,11 @@ M: timestamp year. ( timestamp -- )
[ hour>> write-00 ] [ minute>> write-00 ] bi ;
: write-gmt-offset ( gmt-offset -- )
- dup instant <=> {
- { [ dup 0 = ] [ 2drop "GMT" write ] }
- { [ dup 0 < ] [ drop "-" write before (write-gmt-offset) ] }
- { [ dup 0 > ] [ drop "+" write (write-gmt-offset) ] }
- } cond ;
+ dup instant <=> sgn {
+ { 0 [ drop "GMT" write ] }
+ { -1 [ "-" write before (write-gmt-offset) ] }
+ { 1 [ "+" write (write-gmt-offset) ] }
+ } case ;
: timestamp>rfc822 ( timestamp -- str )
#! RFC822 timestamp format
@@ -83,20 +84,22 @@ M: timestamp year. ( timestamp -- )
[ minute>> write-00 ] bi ;
: write-rfc3339-gmt-offset ( duration -- )
- dup instant <=> {
- { [ dup 0 = ] [ 2drop "Z" write ] }
- { [ dup 0 < ] [ drop CHAR: - write1 before (write-rfc3339-gmt-offset) ] }
- { [ dup 0 > ] [ drop CHAR: + write1 (write-rfc3339-gmt-offset) ] }
- } cond ;
+ dup instant <=> sgn {
+ { 0 [ drop "Z" write ] }
+ { -1 [ CHAR: - write1 before (write-rfc3339-gmt-offset) ] }
+ { 1 [ CHAR: + write1 (write-rfc3339-gmt-offset) ] }
+ } case ;
: (timestamp>rfc3339) ( timestamp -- )
- dup year>> number>string write CHAR: - write1
- dup month>> write-00 CHAR: - write1
- dup day>> write-00 CHAR: T write1
- dup hour>> write-00 CHAR: : write1
- dup minute>> write-00 CHAR: : write1
- dup second>> >fixnum write-00
- gmt-offset>> write-rfc3339-gmt-offset ;
+ {
+ [ year>> number>string write CHAR: - write1 ]
+ [ month>> write-00 CHAR: - write1 ]
+ [ day>> write-00 CHAR: T write1 ]
+ [ hour>> write-00 CHAR: : write1 ]
+ [ minute>> write-00 CHAR: : write1 ]
+ [ second>> >fixnum write-00 ]
+ [ gmt-offset>> write-rfc3339-gmt-offset ]
+ } cleave ;
: timestamp>rfc3339 ( timestamp -- str )
[ (timestamp>rfc3339) ] with-string-writer ;
@@ -106,14 +109,20 @@ M: timestamp year. ( timestamp -- )
: read-00 2 read string>number ;
+: read-000 3 read string>number ;
+
: read-0000 4 read string>number ;
-: read-rfc3339-gmt-offset ( -- n )
- read1 dup CHAR: Z = [ drop 0 ] [
- { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case
- read-00
- read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case
- 60 / + *
+: signed-gmt-offset ( dt ch -- dt' )
+ { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;
+
+: read-rfc3339-gmt-offset ( ch -- dt )
+ dup CHAR: Z = [ drop instant ] [
+ >r
+ read-00 hours
+ read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
+ time+
+ r> signed-gmt-offset
] if ;
: read-ymd ( -- y m d )
@@ -126,26 +135,61 @@ M: timestamp year. ( timestamp -- )
read-ymd
"Tt" expect
read-hms
- read-rfc3339-gmt-offset ! timezone
+ read1 { { CHAR: . [ read-000 1000 / + read1 ] } [ ] } case
+ read-rfc3339-gmt-offset
<timestamp> ;
: rfc3339>timestamp ( str -- timestamp )
[ (rfc3339>timestamp) ] with-string-reader ;
+ERROR: invalid-rfc822-date ;
+
+: check-rfc822-date ( obj/f -- obj ) [ invalid-rfc822-date ] unless* ;
+
+: read-token ( seps -- token )
+ [ read-until ] keep member? check-rfc822-date drop ;
+
+: read-sp ( -- token ) " " read-token ;
+
+: checked-number ( str -- n )
+ string>number check-rfc822-date ;
+
+: parse-rfc822-gmt-offset ( string -- dt )
+ dup "GMT" = [ drop instant ] [
+ unclip >r
+ 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
+ r> signed-gmt-offset
+ ] if ;
+
+: (rfc822>timestamp) ( -- timestamp )
+ timestamp new
+ "," read-token day-abbreviations3 member? check-rfc822-date drop
+ read1 CHAR: \s assert=
+ read-sp checked-number >>day
+ read-sp month-abbreviations index check-rfc822-date >>month
+ read-sp checked-number >>year
+ ":" read-token checked-number >>hour
+ ":" read-token checked-number >>minute
+ " " read-token checked-number >>second
+ readln parse-rfc822-gmt-offset >>gmt-offset ;
+
+: rfc822>timestamp ( str -- timestamp )
+ [ (rfc822>timestamp) ] with-string-reader ;
+
: (ymdhms>timestamp) ( -- timestamp )
- read-ymd " " expect read-hms 0 <timestamp> ;
+ read-ymd " " expect read-hms instant <timestamp> ;
: ymdhms>timestamp ( str -- timestamp )
[ (ymdhms>timestamp) ] with-string-reader ;
: (hms>timestamp) ( -- timestamp )
- f f f read-hms f <timestamp> ;
+ f f f read-hms instant <timestamp> ;
: hms>timestamp ( str -- timestamp )
[ (hms>timestamp) ] with-string-reader ;
: (ymd>timestamp) ( -- timestamp )
- read-ymd f f f f <timestamp> ;
+ read-ymd f f f instant <timestamp> ;
: ymd>timestamp ( str -- timestamp )
[ (ymd>timestamp) ] with-string-reader ;
diff --git a/extra/webapps/planet/blog-summary.xml b/extra/webapps/planet/blog-admin-link.xml
similarity index 100%
rename from extra/webapps/planet/blog-summary.xml
rename to extra/webapps/planet/blog-admin-link.xml
diff --git a/extra/webapps/planet/mini-planet.xml b/extra/webapps/planet/postings-summary.xml
similarity index 100%
rename from extra/webapps/planet/mini-planet.xml
rename to extra/webapps/planet/postings-summary.xml
From bfa34122f3ac2eb429b33dd340dfebfaa4badff1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 22 Apr 2008 20:23:49 -0500
Subject: [PATCH 02/14] Fix chunked encoding
---
extra/http/client/client.factor | 4 +--
extra/http/http.factor | 43 +++++++++++++++++++++++----------
2 files changed, 32 insertions(+), 15 deletions(-)
diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor
index ac5d220a52..8879a76a5c 100755
--- a/extra/http/client/client.factor
+++ b/extra/http/client/client.factor
@@ -74,8 +74,8 @@ PRIVATE>
] with-variable ;
: read-chunks ( -- )
- readln ";" split1 drop hex>
- dup { f 0 } member? [ drop ] [ read % read-chunks ] if ;
+ read-crlf ";" split1 drop hex> dup { f 0 } member?
+ [ drop ] [ read % read-crlf "" assert= read-chunks ] if ;
: do-chunked-encoding ( response stream -- response stream/string )
over "transfer-encoding" header "chunked" = [
diff --git a/extra/http/http.factor b/extra/http/http.factor
index 5e90962b27..4aaab2205e 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -1,10 +1,18 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry hashtables io io.streams.string kernel math sets
-namespaces math.parser assocs sequences strings splitting ascii
-io.encodings.utf8 io.encodings.string io.sockets namespaces
-unicode.case combinators vectors sorting accessors calendar
-calendar.format quotations arrays combinators.lib byte-arrays ;
+USING: accessors kernel combinators math namespaces
+
+assocs sequences splitting sorting sets debugger
+strings vectors hashtables quotations arrays byte-arrays
+math.parser calendar calendar.format
+
+io io.streams.string io.encodings.utf8 io.encodings.string
+io.sockets
+
+unicode.case unicode.categories qualified ;
+
+EXCLUDE: fry => , ;
+
IN: http
: http-port 80 ; inline
@@ -13,11 +21,12 @@ IN: http
#! In a URL, can this character be used without
#! URL-encoding?
{
- [ dup letter? ]
- [ dup LETTER? ]
- [ dup digit? ]
- [ dup "/_-.:" member? ]
- } || nip ; foldable
+ { [ dup letter? ] [ t ] }
+ { [ dup LETTER? ] [ t ] }
+ { [ dup digit? ] [ t ] }
+ { [ dup "/_-.:" member? ] [ t ] }
+ [ f ]
+ } cond nip ; foldable
: push-utf8 ( ch -- )
1string utf8 encode
@@ -75,8 +84,16 @@ IN: http
] if
] if ;
+: read-lf ( -- string )
+ "\n" read-until CHAR: \n assert= ;
+
+: read-crlf ( -- string )
+ "\r" read-until
+ CHAR: \r assert=
+ read1 CHAR: \n assert= ;
+
: read-header-line ( -- )
- readln dup
+ read-crlf dup
empty? [ drop ] [ header-line read-header-line ] if ;
: read-header ( -- assoc )
@@ -224,7 +241,7 @@ cookies ;
dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ;
: read-request-version ( request -- request )
- readln [ CHAR: \s = ] left-trim
+ read-crlf [ CHAR: \s = ] left-trim
parse-version
>>version ;
@@ -372,7 +389,7 @@ body ;
>>code ;
: read-response-message
- readln >>message ;
+ read-crlf >>message ;
: read-response-header
read-header >>header
From f9ce5dd6c38ecbe1cd93af780a97e96e17a0ead4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 22 Apr 2008 20:23:54 -0500
Subject: [PATCH 03/14] Fix RSS2.0 support
---
extra/rss/rss.factor | 14 +++++---------
1 file changed, 5 insertions(+), 9 deletions(-)
diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor
index 2e735d2f06..5fc688967a 100644
--- a/extra/rss/rss.factor
+++ b/extra/rss/rss.factor
@@ -23,7 +23,7 @@ C: <entry> entry
[ "link" tag-named children>string ] keep
[ "description" tag-named children>string ] keep
f "date" "http://purl.org/dc/elements/1.1/" <name>
- tag-named dup [ children>string rfc3339>timestamp ] when
+ tag-named dup [ children>string rfc822>timestamp ] when
<entry> ;
: rss1.0 ( xml -- feed )
@@ -39,7 +39,7 @@ C: <entry> entry
[ "link" tag-named ] keep
[ "guid" tag-named dupd ? children>string ] keep
[ "description" tag-named children>string ] keep
- "pubDate" tag-named children>string rfc3339>timestamp <entry> ;
+ "pubDate" tag-named children>string rfc822>timestamp <entry> ;
: rss2.0 ( xml -- feed )
"channel" tag-named
@@ -71,16 +71,12 @@ C: <entry> entry
{ "feed" [ atom1.0 ] }
} case ;
-: read-feed ( stream -- feed )
- [ read-xml ] with-html-entities xml>feed ;
+: read-feed ( string -- feed )
+ [ string>xml xml>feed ] with-html-entities ;
: download-feed ( url -- feed )
#! Retrieve an news syndication file, return as a feed tuple.
- http-get-stream swap code>> success? [
- read-feed
- ] [
- dispose "Error retrieving newsfeed file" throw
- ] if ;
+ http-get read-feed ;
! Atom generation
: simple-tag, ( content name -- )
From 138cff4d47f9fd9e63d358e436592c53141d683c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 22 Apr 2008 21:06:24 -0500
Subject: [PATCH 04/14] stack effects for recusive words
---
extra/windows/windows.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/windows/windows.factor b/extra/windows/windows.factor
index 0e555ed7e9..3e7520d406 100644
--- a/extra/windows/windows.factor
+++ b/extra/windows/windows.factor
@@ -30,10 +30,10 @@ FUNCTION: void* error_message ( DWORD id ) ;
: win32-error ( -- )
GetLastError (win32-error) ;
-: win32-error=0/f { 0 f } member? [ win32-error ] when ;
-: win32-error>0 0 > [ win32-error ] when ;
-: win32-error<0 0 < [ win32-error ] when ;
-: win32-error<>0 zero? [ win32-error ] unless ;
+: win32-error=0/f ( n -- ) { 0 f } member? [ win32-error ] when ;
+: win32-error>0 ( n -- ) 0 > [ win32-error ] when ;
+: win32-error<0 ( n -- ) 0 < [ win32-error ] when ;
+: win32-error<>0 ( n -- ) zero? [ win32-error ] unless ;
: invalid-handle? ( handle -- )
INVALID_HANDLE_VALUE = [
From 6e89f7b085bd2ec63948296344ff7f89375169a3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 22 Apr 2008 21:08:27 -0500
Subject: [PATCH 05/14] Working on planet factor rewrite
---
extra/http/server/auth/login/login.factor | 2 +-
.../server/boilerplate/boilerplate.factor | 2 +-
.../http/server/components/components.factor | 29 +++++-
extra/http/server/forms/forms.factor | 2 +-
extra/http/server/server.factor | 29 +++---
.../http/server/templating/chloe/chloe.factor | 3 +-
.../http/server/templating/fhtml/fhtml.factor | 2 +-
.../http/server/templating/templating.factor | 17 +++-
.../factor-website/factor-website.factor | 38 ++++++++
.../{planet => factor-website}/page.xml | 35 ++++---
extra/webapps/planet/admin.xml | 13 +++
extra/webapps/planet/entry.xml | 14 ++-
extra/webapps/planet/planet.factor | 96 +++++++++++--------
extra/webapps/planet/planet.xml | 42 ++++----
extra/webapps/planet/postings.xml | 19 ++++
extra/webapps/todo/page.xml | 45 ---------
extra/webapps/todo/todo.css | 16 ----
extra/webapps/todo/todo.factor | 34 +------
18 files changed, 236 insertions(+), 202 deletions(-)
create mode 100644 extra/webapps/factor-website/factor-website.factor
rename extra/webapps/{planet => factor-website}/page.xml (89%)
create mode 100644 extra/webapps/planet/admin.xml
create mode 100644 extra/webapps/planet/postings.xml
delete mode 100644 extra/webapps/todo/page.xml
diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor
index b0cc0c21d1..7593f217f7 100755
--- a/extra/http/server/auth/login/login.factor
+++ b/extra/http/server/auth/login/login.factor
@@ -363,7 +363,7 @@ M: login call-responder ( path responder -- response )
: <login> ( responder -- auth )
login new-dispatcher
- swap <protected> >>default
+ swap >>default
<login-action> <login-boilerplate> "login" add-responder
<logout-action> <login-boilerplate> "logout" add-responder
no-users >>users ;
diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor
index 6c62452ec2..eabcefeb7f 100644
--- a/extra/http/server/boilerplate/boilerplate.factor
+++ b/extra/http/server/boilerplate/boilerplate.factor
@@ -48,7 +48,7 @@ SYMBOL: next-template
: call-next-template ( -- )
next-template get write ;
-M: f call-template drop call-next-template ;
+M: f call-template* drop call-next-template ;
: with-boilerplate ( body template -- )
[
diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor
index bdcdd95c71..331231dfb3 100755
--- a/extra/http/server/components/components.factor
+++ b/extra/http/server/components/components.factor
@@ -280,6 +280,22 @@ TUPLE: date < string ;
M: date component-string
drop timestamp>string ;
+! Link components
+
+GENERIC: link-title ( obj -- string )
+GENERIC: link-href ( obj -- url )
+
+SINGLETON: link-renderer
+
+M: link-renderer render-view*
+ drop <a dup link-href =href a> link-title write </a> ;
+
+TUPLE: link < string ;
+
+: <link> ( id -- component )
+ link new-string
+ link-renderer >>renderer ;
+
! List components
SYMBOL: +plain+
SYMBOL: +ordered+
@@ -289,17 +305,20 @@ TUPLE: list-renderer component type ;
C: <list-renderer> list-renderer
-: render-plain-list ( seq quot component -- )
- swap '[ , @ ] each ; inline
+: render-plain-list ( seq component quot -- )
+ '[ , component>> renderer>> @ ] each ; inline
+
+: render-li-list ( seq component quot -- )
+ '[ <li> @ </li> ] render-plain-list ; inline
: render-ordered-list ( seq quot component -- )
- swap <ol> '[ <li> , @ </li> ] each </ol> ; inline
+ <ol> render-li-list </ol> ; inline
: render-unordered-list ( seq quot component -- )
- swap <ul> '[ <li> , @ </li> ] each </ul> ; inline
+ <ul> render-li-list </ul> ; inline
: render-list ( value renderer quot -- )
- swap [ component>> ] [ type>> ] bi {
+ over type>> {
{ +plain+ [ render-plain-list ] }
{ +ordered+ [ render-ordered-list ] }
{ +unordered+ [ render-unordered-list ] }
diff --git a/extra/http/server/forms/forms.factor b/extra/http/server/forms/forms.factor
index f45bf6ec65..60f3da25b6 100644
--- a/extra/http/server/forms/forms.factor
+++ b/extra/http/server/forms/forms.factor
@@ -78,4 +78,4 @@ M: form render-view*
dup view-template>> render-form ;
M: form render-edit*
- dup edit-template>> render-form ;
+ nip dup edit-template>> render-form ;
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index db03645a24..d3bd6c6bbe 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -160,23 +160,30 @@ drop
SYMBOL: development-mode
+: http-error. ( error -- )
+ "Internal server error" [
+ development-mode get [
+ [ print-error nl :c ] with-html-stream
+ ] [
+ 500 "Internal server error"
+ trivial-response-body
+ ] if
+ ] simple-page ;
+
: <500> ( error -- response )
500 "Internal server error" <trivial-response>
- swap '[
- , "Internal server error" [
- development-mode get [
- [ print-error nl :c ] with-html-stream
- ] [
- 500 "Internal server error"
- trivial-response-body
- ] if
- ] simple-page
- ] >>body ;
+ swap '[ , http-error. ] >>body ;
: do-response ( response -- )
dup write-response
request get method>> "HEAD" =
- [ drop ] [ write-response-body ] if ;
+ [ drop ] [
+ '[
+ , write-response-body
+ ] [
+ http-error.
+ ] recover
+ ] if ;
LOG: httpd-hit NOTICE
diff --git a/extra/http/server/templating/chloe/chloe.factor b/extra/http/server/templating/chloe/chloe.factor
index 8142c5e3b7..685988dfaf 100644
--- a/extra/http/server/templating/chloe/chloe.factor
+++ b/extra/http/server/templating/chloe/chloe.factor
@@ -153,6 +153,7 @@ SYMBOL: tags
{ "form" [ form-tag ] }
{ "error" [ error-tag ] }
{ "if" [ if-tag ] }
+ { "comment" [ drop ] }
{ "call-next-template" [ drop call-next-template ] }
[ "Unknown chloe tag: " swap append throw ]
} case ;
@@ -189,7 +190,7 @@ SYMBOL: tags
] if
] with-scope ;
-M: chloe call-template
+M: chloe call-template*
path>> utf8 <file-reader> read-xml process-chloe ;
INSTANCE: chloe template
diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor
index 1cba4b9b2e..2cc053a0ca 100755
--- a/extra/http/server/templating/fhtml/fhtml.factor
+++ b/extra/http/server/templating/fhtml/fhtml.factor
@@ -76,7 +76,7 @@ TUPLE: fhtml path ;
C: <fhtml> fhtml
-M: fhtml call-template ( filename -- )
+M: fhtml call-template* ( filename -- )
'[
, path>> [
"quiet" on
diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor
index f69dd9bfe0..610ec78fed 100644
--- a/extra/http/server/templating/templating.factor
+++ b/extra/http/server/templating/templating.factor
@@ -1,10 +1,21 @@
-USING: accessors kernel fry io.encodings.utf8 io.files
-http http.server ;
+USING: accessors kernel fry io io.encodings.utf8 io.files
+http http.server debugger prettyprint continuations ;
IN: http.server.templating
MIXIN: template
-GENERIC: call-template ( template -- )
+GENERIC: call-template* ( template -- )
+
+ERROR: template-error template error ;
+
+M: template-error error.
+ "Error while processing template " write
+ [ template>> pprint ":" print nl ]
+ [ error>> error. ]
+ bi ;
+
+: call-template ( template -- )
+ [ call-template* ] [ template-error ] recover ;
M: template write-response-body* call-template ;
diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor
new file mode 100644
index 0000000000..3483d4321e
--- /dev/null
+++ b/extra/webapps/factor-website/factor-website.factor
@@ -0,0 +1,38 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences io.files io.sockets
+db.sqlite smtp namespaces db
+http.server.db
+http.server.sessions
+http.server.auth.login
+http.server.auth.providers.db
+http.server.sessions.storage.db
+http.server.boilerplate
+http.server.templating.chloe ;
+IN: webapps.factor-website
+
+: factor-template ( path -- template )
+ "resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ;
+
+: test-db "todo.db" resource-path sqlite-db ;
+
+: <factor-boilerplate> ( responder -- responder' )
+ <login>
+ users-in-db >>users
+ allow-registration
+ allow-password-recovery
+ allow-edit-profile
+ <boilerplate>
+ "page" factor-template >>template
+ <url-sessions>
+ sessions-in-db >>sessions
+ test-db <db-persistence> ;
+
+: init-factor-website ( -- )
+ "factorcode.org" 25 <inet> smtp-server set-global
+ "todo@factorcode.org" lost-password-from set-global
+
+ test-db [
+ init-sessions-table
+ init-users-table
+ ] with-db ;
diff --git a/extra/webapps/planet/page.xml b/extra/webapps/factor-website/page.xml
similarity index 89%
rename from extra/webapps/planet/page.xml
rename to extra/webapps/factor-website/page.xml
index 1278c8174c..d929042320 100644
--- a/extra/webapps/planet/page.xml
+++ b/extra/webapps/factor-website/page.xml
@@ -10,52 +10,49 @@
<head>
<t:write-title />
- <t:write-atom />
-
<t:style>
+ body, button {
+ font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+ color:#444;
+ }
+
.link-button {
padding: 0px;
background: none;
border: none;
}
- .inline {
- display: inline;
- }
-
- body, button {
- font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
- color:#444;
- }
-
a, .link {
color: #222;
border-bottom:1px dotted #666;
text-decoration:none;
}
- h1 a {
- border: none;
- }
-
a:hover, .link:hover {
border-bottom:1px solid #66a;
}
.error { color: #a00; }
-
+
.field-label {
text-align: right;
}
+
+ .inline {
+ display: inline;
+ }
+
+ .navbar {
+ background-color: #eee;
+ padding: 5px;
+ border: 1px solid #ccc;
+ }
</t:style>
<t:write-style />
</head>
<body>
-
- <h1><t:a href="planet"><t:write-title /></t:a></h1>
-
<t:call-next-template />
</body>
diff --git a/extra/webapps/planet/admin.xml b/extra/webapps/planet/admin.xml
new file mode 100644
index 0000000000..1a18cad94b
--- /dev/null
+++ b/extra/webapps/planet/admin.xml
@@ -0,0 +1,13 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Planet Factor Administration</t:title>
+
+ <t:summary component="blogroll" />
+
+ <p>
+ <t:a href="edit-blog">Add Blog</t:a> | <t:a href="update">Update</t:a>
+ </p>
+
+</t:chloe>
diff --git a/extra/webapps/planet/entry.xml b/extra/webapps/planet/entry.xml
index a9383d16f2..bc89af3263 100644
--- a/extra/webapps/planet/entry.xml
+++ b/extra/webapps/planet/entry.xml
@@ -2,8 +2,16 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <h2 class="posting-title"><t:view component="title" /></h2>
- <p class="posting-body"> <t:view component="description" /> </p>
- <p class="posting-date"> <t:view component="pub-date" /> </p>
+ <h2 class="posting-title">
+ <t:a value="link"><t:view component="title" /></t:a>
+ </h2>
+
+ <p class="posting-body">
+ <t:view component="description" />
+ </p>
+
+ <p class="posting-date">
+ <t:a value="link"><t:view component="pub-date" /></t:a>
+ </p>
</t:chloe>
diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
index 966bcc1d0b..464e2bbfb3 100755
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sorting locals math
-calendar alarms logging concurrency.combinators
+calendar alarms logging concurrency.combinators namespaces
db.types db.tuples db
rss xml.writer
http.server
@@ -10,11 +10,22 @@ http.server.forms
http.server.actions
http.server.boilerplate
http.server.templating.chloe
-http.server.components ;
+http.server.components
+http.server.auth.login
+webapps.factor-website ;
IN: webapps.planet
+TUPLE: planet-factor < dispatcher postings ;
+
+: planet-template ( name -- template )
+ "resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
+
TUPLE: blog id name www-url atom-url ;
+M: blog link-title name>> ;
+
+M: blog link-href www-url>> ;
+
blog "BLOGS"
{
{ "id" "ID" INTEGER +native-id+ }
@@ -29,8 +40,8 @@ blog "BLOGS"
blog new
swap >>id ;
-: planet-template ( name -- template )
- "resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
+: blogroll ( -- seq )
+ f <blog> select-tuples [ [ name>> ] compare ] sort ;
: <entry-form> ( -- form )
"entry" <form>
@@ -44,7 +55,7 @@ blog "BLOGS"
"blog" <form>
"edit-blog" planet-template >>edit-template
"view-blog" planet-template >>view-template
- "blog-summary" planet-template >>summary-template
+ "blog-admin-link" planet-template >>summary-template
"id" <integer>
hidden >>renderer
add-field
@@ -60,15 +71,27 @@ blog "BLOGS"
: <planet-factor-form> ( -- form )
"planet-factor" <form>
- "planet" planet-template >>view-template
- "mini-planet" planet-template >>summary-template
+ "postings" planet-template >>view-template
+ "postings-summary" planet-template >>summary-template
"postings" <entry-form> +plain+ <list> add-field
+ "blogroll" "blog" <link> +unordered+ <list> add-field ;
+
+: <admin-form> ( -- form )
+ "admin" <form>
+ "admin" planet-template >>view-template
"blogroll" <blog-form> +unordered+ <list> add-field ;
-: blogroll ( -- seq )
- f <blog> select-tuples [ [ name>> ] compare ] sort ;
+:: <edit-blogroll-action> ( planet -- action )
+ [let | form [ <admin-form> ] |
+ <action>
+ [
+ blank-values
-TUPLE: planet-factor < dispatcher postings ;
+ blogroll "blogroll" set-value
+
+ form view-form
+ ] >>display
+ ] ;
:: <planet-action> ( planet -- action )
[let | form [ <planet-factor-form> ] |
@@ -90,7 +113,7 @@ TUPLE: planet-factor < dispatcher postings ;
feed new
"[ planet-factor ]" >>title
"http://planet.factorcode.org" >>link
- planet postings>> 30 safe-head >>entries ;
+ planet postings>> 16 safe-head >>entries ;
:: <feed-action> ( planet -- action )
<action>
@@ -117,7 +140,8 @@ TUPLE: planet-factor < dispatcher postings ;
: update-cached-postings ( planet -- )
"webapps.planet" [
- blogroll fetch-blogroll sort-entries >>postings drop
+ blogroll fetch-blogroll sort-entries 8 safe-head
+ >>postings drop
] with-logging ;
:: <update-action> ( planet -- action )
@@ -127,16 +151,11 @@ TUPLE: planet-factor < dispatcher postings ;
"" f <temporary-redirect>
] >>display ;
-: start-update-task ( planet -- )
- [ update-cached-postings ] curry 10 minutes every drop ;
-
-:: <planet-factor> ( -- responder )
+:: <planet-factor-admin> ( planet-factor -- responder )
[let | blog-form [ <blog-form> ]
blog-ctor [ [ <blog> ] ] |
- planet-factor new-dispatcher
- dup <planet-action> >>default
- dup <feed-action> "feed.xml" add-responder
- dup <update-action> "update" add-responder
+ <dispatcher>
+ planet-factor <edit-blogroll-action> >>default
! Administrative CRUD
blog-ctor "" <delete-action> "delete-blog" add-responder
@@ -144,30 +163,25 @@ TUPLE: planet-factor < dispatcher postings ;
blog-form blog-ctor "view-blog" <edit-action> "edit-blog" add-responder
] ;
-USING: namespaces io.files io.sockets
-db.sqlite smtp
-http.server.db
-http.server.sessions
-http.server.auth.login
-http.server.auth.providers.db
-http.server.sessions.storage.db ;
-
-: test-db "planet.db" resource-path sqlite-db ;
-
-: <planet-app> ( -- responder )
- <planet-factor>
+: <planet-factor> ( -- responder )
+ planet-factor new-dispatcher
+ dup <planet-action> >>default
+ dup <feed-action> "feed.xml" add-responder
+ dup <update-action> "update" add-responder
+ dup <planet-factor-admin> <protected> "admin" add-responder
<boilerplate>
- "page" planet-template >>template
- ! <url-sessions>
- ! sessions-in-db >>sessions
- test-db <db-persistence> ;
+ "planet" planet-template >>template ;
+
+: <planet-app> ( -- responder )
+ <planet-factor> <factor-boilerplate> ;
+
+: start-update-task ( planet -- )
+ [ update-cached-postings ] curry 10 minutes every drop ;
: init-planet ( -- )
- ! test-db [
- ! init-blog-table
- ! init-users-table
- ! init-sessions-table
- ! ] with-db
+ test-db [
+ init-blog-table
+ ] with-db
<dispatcher>
<planet-app> "planet" add-responder
diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml
index dc762fafc6..772f81906d 100644
--- a/extra/webapps/planet/planet.xml
+++ b/extra/webapps/planet/planet.xml
@@ -2,36 +2,30 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:title>Planet Factor</t:title>
-
+<t:comment>
<t:atom title="Planet Factor - Atom" href="feed.xml" />
-
+</t:comment>
<t:style include="resource:extra/webapps/planet/planet.css" />
- <table width="100%" cellpadding="10">
- <tr>
- <td> <t:view component="postings" /> </td>
+ <div class="navbar">
+ <t:a href="list">Front Page</t:a>
+ | <t:a href="feed.xml">Atom Feed</t:a>
- <td valign="top" width="25%" class="infobox">
- <p>
- <strong>planet-factor</strong> is an Atom feed aggregator that collects the
- contents of <a href="http://factorcode.org/">Factor</a>-related blogs. It was inspired by
- <a href="http://planet.lisp.org">Planet Lisp</a>.
- </p>
- <p>
- <img src="http://planet.lisp.org/feed-icon-14x14.png" />
- <a href="feed.xml"> Syndicate </a>
- </p>
+ | <t:a href="admin">Admin</t:a>
- <h2>Blogroll</h2>
+ <t:comment>
+ <t:if code="http.server.auth.login:allow-edit-profile?">
+ | <t:a href="edit-profile">Edit Profile</t:a>
+ </t:if>
- <t:summary component="blogroll" />
+ <t:form action="logout" class="inline">
+ | <button type="submit" class="link-button link">Logout</button>
+ </t:form>
+ </t:comment>
+ </div>
- Admin: <t:a href="edit-blog">Add Blog</t:a>
- |
- <t:a href="update">Update</t:a>
- </td>
- </tr>
- </table>
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
</t:chloe>
diff --git a/extra/webapps/planet/postings.xml b/extra/webapps/planet/postings.xml
new file mode 100644
index 0000000000..f59a4f61b8
--- /dev/null
+++ b/extra/webapps/planet/postings.xml
@@ -0,0 +1,19 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Planet Factor</t:title>
+
+ <table width="100%" cellpadding="10">
+ <tr>
+ <td> <t:view component="postings" /> </td>
+
+ <td valign="top" width="25%" class="infobox">
+ <h2>Blogroll</h2>
+
+ <t:summary component="blogroll" />
+ </td>
+ </tr>
+ </table>
+
+</t:chloe>
diff --git a/extra/webapps/todo/page.xml b/extra/webapps/todo/page.xml
deleted file mode 100644
index f40c79d299..0000000000
--- a/extra/webapps/todo/page.xml
+++ /dev/null
@@ -1,45 +0,0 @@
-<?xml version='1.0' ?>
-
-<!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">
-
- <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <head>
- <t:write-title />
-
- <t:style>
- body, button {
- font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
- color:#444;
- }
-
- a, .link {
- color: #222;
- border-bottom:1px dotted #666;
- text-decoration:none;
- }
-
- a:hover, .link:hover {
- border-bottom:1px solid #66a;
- }
-
- .error { color: #a00; }
-
- .field-label {
- text-align: right;
- }
- </t:style>
-
- <t:write-style />
- </head>
-
- <body>
- <t:call-next-template />
- </body>
-
- </t:chloe>
-
-</html>
diff --git a/extra/webapps/todo/todo.css b/extra/webapps/todo/todo.css
index c2e8a7fd79..2520a56128 100644
--- a/extra/webapps/todo/todo.css
+++ b/extra/webapps/todo/todo.css
@@ -10,22 +10,6 @@
color: #000000;
}
-.link-button {
- padding: 0px;
- background: none;
- border: none;
-}
-
-.navbar {
- background-color: #eeeeee;
- padding: 5px;
- border: 1px solid #ccc;
-}
-
-.inline {
- display: inline;
-}
-
pre {
font-size: 75%;
}
diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor
index 917b9bf7a7..08555b92ed 100755
--- a/extra/webapps/todo/todo.factor
+++ b/extra/webapps/todo/todo.factor
@@ -1,12 +1,13 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel locals sequences
+USING: accessors kernel locals sequences namespaces
db db.types db.tuples
http.server.components http.server.components.farkup
http.server.forms http.server.templating.chloe
http.server.boilerplate http.server.crud http.server.auth
http.server.actions http.server.db
-http.server ;
+http.server
+webapps.factor-website ;
IN: webapps.todo
TUPLE: todo uid id priority summary description ;
@@ -71,37 +72,10 @@ TUPLE: todo-responder < dispatcher ;
"todo" todo-template >>template
] ;
-! What follows below is somewhat akin to a 'deployment descriptor'
-! for the todo application. The <todo-responder> can be integrated
-! into an existing web app that provides session management and
-! login facilities, or <todo-app> can be used to run a
-! self-contained todo instance.
-USING: namespaces io.files io.sockets
-db.sqlite smtp
-http.server.sessions
-http.server.auth.login
-http.server.auth.providers.db
-http.server.sessions.storage.db ;
-
-: test-db "todo.db" resource-path sqlite-db ;
-
: <todo-app> ( -- responder )
- <todo-responder>
- <login>
- users-in-db >>users
- allow-registration
- allow-password-recovery
- allow-edit-profile
- <boilerplate>
- "page" todo-template >>template
- <url-sessions>
- sessions-in-db >>sessions
- test-db <db-persistence> ;
+ <todo-responder> <protected> <factor-boilerplate> ;
: init-todo ( -- )
- "factorcode.org" 25 <inet> smtp-server set-global
- "todo@factorcode.org" lost-password-from set-global
-
test-db [
init-todo-table
init-users-table
From 6a0dc9f02451015d909f8941594a27250f89b4b6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 23 Apr 2008 00:07:26 -0500
Subject: [PATCH 06/14] fix unit tests
---
extra/db/tuples/tuples-tests.factor | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 1c900edc68..32562a4ae8 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -80,9 +80,9 @@ SYMBOL: person4
"teddy"
10
3.14
- T{ timestamp f 2008 3 5 16 24 11 0 }
- T{ timestamp f 2008 11 22 f f f f }
- T{ timestamp f f f f 12 34 56 f }
+ T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 2008 11 22 f f f T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
}
] [ T{ person f 3 } select-tuple ] unit-test
@@ -96,9 +96,9 @@ SYMBOL: person4
"eddie"
10
3.14
- T{ timestamp f 2008 3 5 16 24 11 0 }
- T{ timestamp f 2008 11 22 f f f f }
- T{ timestamp f f f f 12 34 56 f }
+ T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 2008 11 22 f f f T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f
H{ { 1 2 } { 3 4 } { 5 "lol" } }
}
From 2045f44ced34a546d215c872cda542171014a6dc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 23 Apr 2008 00:08:49 -0500
Subject: [PATCH 07/14] Fix RSS unit tests
---
extra/rss/rss-tests.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/rss/rss-tests.factor b/extra/rss/rss-tests.factor
index 7523d0509f..252defe99b 100755
--- a/extra/rss/rss-tests.factor
+++ b/extra/rss/rss-tests.factor
@@ -5,7 +5,7 @@ IN: rss.tests
: load-news-file ( filename -- feed )
#! Load an news syndication file and process it, returning
#! it as an feed tuple.
- utf8 <file-reader> read-feed ;
+ utf8 file-contents read-feed ;
[ T{
feed
@@ -36,7 +36,7 @@ IN: rss.tests
"http://example.org/2005/04/02/atom"
"\n <div xmlns=\"http://www.w3.org/1999/xhtml\">\n <p><i>[Update: The Atom draft is finished.]</i></p>\n </div>\n "
- T{ timestamp f 2003 12 13 8 29 29 -4 }
+ T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } }
}
}
} ] [ "extra/rss/atom.xml" resource-path load-news-file ] unit-test
From 2f2d31a623785b936e7fc7b18fc72af34ab0792e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 23 Apr 2008 00:53:42 -0500
Subject: [PATCH 08/14] Fix HTTP unit tests
---
extra/http/http-tests.factor | 15 +++++++++------
extra/http/http.factor | 3 +--
extra/http/server/actions/actions-tests.factor | 10 +++++++---
3 files changed, 17 insertions(+), 11 deletions(-)
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index 9302045624..3a50630335 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -24,6 +24,8 @@ IN: http.tests
[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
[ "/bar" ] [ "/bar" url>path ] unit-test
+: lf>crlf "\n" split "\r\n" join ;
+
STRING: read-request-test-1
GET http://foo/bar HTTP/1.1
Some-Header: 1
@@ -45,7 +47,7 @@ blah
cookies: V{ }
}
] [
- read-request-test-1 [
+ read-request-test-1 lf>crlf [
read-request
] with-string-reader
] unit-test
@@ -59,7 +61,7 @@ blah
;
read-request-test-1' 1array [
- read-request-test-1
+ read-request-test-1 lf>crlf
[ read-request ] with-string-reader
[ write-request ] with-string-writer
! normalize crlf
@@ -69,6 +71,7 @@ read-request-test-1' 1array [
STRING: read-request-test-2
HEAD http://foo/bar HTTP/1.1
Host: www.sex.com
+
;
[
@@ -83,7 +86,7 @@ Host: www.sex.com
cookies: V{ }
}
] [
- read-request-test-2 [
+ read-request-test-2 lf>crlf [
read-request
] with-string-reader
] unit-test
@@ -104,7 +107,7 @@ blah
cookies: V{ }
}
] [
- read-response-test-1
+ read-response-test-1 lf>crlf
[ read-response ] with-string-reader
] unit-test
@@ -117,7 +120,7 @@ content-type: text/html
;
read-response-test-1' 1array [
- read-response-test-1
+ read-response-test-1 lf>crlf
[ read-response ] with-string-reader
[ write-response ] with-string-writer
! normalize crlf
@@ -162,7 +165,7 @@ io.encodings.ascii ;
"localhost" 1237 <inet> ascii <client> [
"GET nested HTTP/1.0\r\n" write flush
"\r\n" write flush
- readln drop
+ read-crlf drop
read-header
] with-stream "location" swap at "/" head?
] unit-test
diff --git a/extra/http/http.factor b/extra/http/http.factor
index 4aaab2205e..3e81fccd24 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -89,8 +89,7 @@ IN: http
: read-crlf ( -- string )
"\r" read-until
- CHAR: \r assert=
- read1 CHAR: \n assert= ;
+ [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
: read-header-line ( -- )
read-crlf dup
diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor
index ebf8e8770b..90e632d7f5 100755
--- a/extra/http/server/actions/actions-tests.factor
+++ b/extra/http/server/actions/actions-tests.factor
@@ -1,7 +1,7 @@
IN: http.server.actions.tests
USING: http.server.actions http.server.validators
tools.test math math.parser multiline namespaces http
-io.streams.string http.server sequences accessors ;
+io.streams.string http.server sequences splitting accessors ;
[
"a" [ v-number ] { { "a" "123" } } validate-param
@@ -13,6 +13,8 @@ io.streams.string http.server sequences accessors ;
{ { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params
"action-1" set
+: lf>crlf "\n" split "\r\n" join ;
+
STRING: action-request-test-1
GET http://foo/bar?a=12&b=13 HTTP/1.1
@@ -20,7 +22,8 @@ blah
;
[ 25 ] [
- action-request-test-1 [ read-request ] with-string-reader
+ action-request-test-1 lf>crlf
+ [ read-request ] with-string-reader
request set
"/blah"
"action-1" get call-responder
@@ -40,7 +43,8 @@ xxx=4
;
[ "/blahXXXX" ] [
- action-request-test-2 [ read-request ] with-string-reader
+ action-request-test-2 lf>crlf
+ [ read-request ] with-string-reader
request set
"/blah"
"action-2" get call-responder
From 3be7f29b25c5a939521b0f1b61de480237dd921c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 23 Apr 2008 00:54:41 -0500
Subject: [PATCH 09/14] Fix todo load error
---
extra/webapps/todo/todo.factor | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor
index 08555b92ed..97af356dc5 100755
--- a/extra/webapps/todo/todo.factor
+++ b/extra/webapps/todo/todo.factor
@@ -6,6 +6,7 @@ http.server.components http.server.components.farkup
http.server.forms http.server.templating.chloe
http.server.boilerplate http.server.crud http.server.auth
http.server.actions http.server.db
+http.server.auth.login
http.server
webapps.factor-website ;
IN: webapps.todo
@@ -78,8 +79,6 @@ TUPLE: todo-responder < dispatcher ;
: init-todo ( -- )
test-db [
init-todo-table
- init-users-table
- init-sessions-table
] with-db
<dispatcher>
From 04e9b1c37fb0c72f06e86e1ba2a42ae8e56a6ea2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@goo.local>
Date: Wed, 23 Apr 2008 01:31:32 -0500
Subject: [PATCH 10/14] Fix Cocoa UI bug
---
extra/ui/cocoa/views/views.factor | 7 +++++++
1 file changed, 7 insertions(+)
diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor
index 5b975f40de..442eda90ef 100755
--- a/extra/ui/cocoa/views/views.factor
+++ b/extra/ui/cocoa/views/views.factor
@@ -126,6 +126,13 @@ CLASS: {
{ +name+ "FactorView" }
{ +protocols+ { "NSTextInput" } }
}
+
+! Rendering
+! Rendering
+{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" }
+ [ 3drop window relayout-1 ]
+}
+
! Events
{ "acceptsFirstMouse:" "bool" { "id" "SEL" "id" }
[ 3drop 1 ]
From 3a69c972980251af21c731f771d0e61625593bb9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 23 Apr 2008 01:42:30 -0500
Subject: [PATCH 11/14] https:// is absolute
---
extra/http/client/client.factor | 13 ++++++++++---
1 file changed, 10 insertions(+), 3 deletions(-)
diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor
index 8879a76a5c..cc356ca8e3 100755
--- a/extra/http/client/client.factor
+++ b/extra/http/client/client.factor
@@ -39,13 +39,16 @@ DEFER: http-request
SYMBOL: redirects
+: absolute-url? ( url -- ? )
+ [ "http://" head? ] [ "https://" head? ] bi or ;
+
: do-redirect ( response -- response stream )
dup response-code 300 399 between? [
stdio get dispose
redirects inc
redirects get max-redirects < [
header>> "location" swap at
- dup "http://" head? [
+ dup absolute-url? [
absolute-redirect
] [
relative-redirect
@@ -116,8 +119,12 @@ M: download-failed error.
: download-to ( url file -- )
#! Downloads the contents of a URL to a file.
- swap http-get-stream swap check-response
- [ swap latin1 <file-writer> stream-copy ] with-disposal ;
+ swap http-get-stream check-response
+ dup string? [
+ latin1 [ write ] with-file-writer
+ ] [
+ [ swap latin1 <file-writer> stream-copy ] with-disposal
+ ] if ;
: download ( url -- )
dup download-name download-to ;
From df41c8b68f44a04209ef484a8f689f358266159c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 23 Apr 2008 02:46:35 -0500
Subject: [PATCH 12/14] Fix documentation
---
core/alien/strings/strings-docs.factor | 4 ++--
core/alien/strings/strings.factor | 2 +-
extra/bit-vectors/bit-vectors-docs.factor | 4 ++--
extra/byte-vectors/byte-vectors-docs.factor | 2 +-
extra/columns/columns-docs.factor | 2 +-
extra/float-vectors/float-vectors-docs.factor | 4 ++--
6 files changed, 9 insertions(+), 9 deletions(-)
diff --git a/core/alien/strings/strings-docs.factor b/core/alien/strings/strings-docs.factor
index 0dbb4ffd38..27b0122ebe 100644
--- a/core/alien/strings/strings-docs.factor
+++ b/core/alien/strings/strings-docs.factor
@@ -3,14 +3,14 @@ debugger ;
IN: alien.strings
HELP: string>alien
-{ $values { "string" string } { "encoding" "an encoding descriptor" } { "array" byte-array } }
+{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." }
{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ;
{ string>alien alien>string malloc-string } related-words
HELP: alien>string
-{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string" string } }
+{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } }
{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ;
HELP: malloc-string
diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor
index 463fc11e0d..d69d8e9e8e 100644
--- a/core/alien/strings/strings.factor
+++ b/core/alien/strings/strings.factor
@@ -6,7 +6,7 @@ io.streams.byte-array io.streams.memory io.encodings.utf8
io.encodings.utf16 system alien strings cpu.architecture ;
IN: alien.strings
-GENERIC# alien>string 1 ( alien encoding -- string/f )
+GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
M: c-ptr alien>string
>r <memory-stream> r> <decoder>
diff --git a/extra/bit-vectors/bit-vectors-docs.factor b/extra/bit-vectors/bit-vectors-docs.factor
index 9ceb2df342..41f32b4cdb 100755
--- a/extra/bit-vectors/bit-vectors-docs.factor
+++ b/extra/bit-vectors/bit-vectors-docs.factor
@@ -3,7 +3,7 @@ bit-vectors.private combinators ;
IN: bit-vectors
ARTICLE: "bit-vectors" "Bit vectors"
-"A bit vector is a resizable mutable sequence of bits. The literal syntax is covered in " { $link "syntax-bit-vectors" } ". Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
+"A bit vector is a resizable mutable sequence of bits. Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."
$nl
"Bit vectors form a class:"
{ $subsection bit-vector }
@@ -19,7 +19,7 @@ $nl
ABOUT: "bit-vectors"
HELP: bit-vector
-{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ;
+{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;
HELP: <bit-vector>
{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }
diff --git a/extra/byte-vectors/byte-vectors-docs.factor b/extra/byte-vectors/byte-vectors-docs.factor
index f34bc20219..139cbab822 100755
--- a/extra/byte-vectors/byte-vectors-docs.factor
+++ b/extra/byte-vectors/byte-vectors-docs.factor
@@ -19,7 +19,7 @@ $nl
ABOUT: "byte-vectors"
HELP: byte-vector
-{ $description "The class of resizable byte vectors. See " { $link "syntax-byte-vectors" } " for syntax and " { $link "byte-vectors" } " for general information." } ;
+{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ;
HELP: <byte-vector>
{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }
diff --git a/extra/columns/columns-docs.factor b/extra/columns/columns-docs.factor
index 6b2adce9d9..a2f0cccf3b 100644
--- a/extra/columns/columns-docs.factor
+++ b/extra/columns/columns-docs.factor
@@ -14,7 +14,7 @@ HELP: <column> ( seq n -- column )
{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
{ $examples
{ $example
- "USING: arrays prettyprint sequences ;"
+ "USING: arrays prettyprint columns ;"
"{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 <column> >array ."
"{ 1 4 7 }"
}
diff --git a/extra/float-vectors/float-vectors-docs.factor b/extra/float-vectors/float-vectors-docs.factor
index 8d25da54be..5e06f05a2b 100755
--- a/extra/float-vectors/float-vectors-docs.factor
+++ b/extra/float-vectors/float-vectors-docs.factor
@@ -3,7 +3,7 @@ float-vectors.private combinators ;
IN: float-vectors
ARTICLE: "float-vectors" "Float vectors"
-"A float vector is a resizable mutable sequence of unsigned floats. The literal syntax is covered in " { $link "syntax-float-vectors" } ". Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary."
+"A float vector is a resizable mutable sequence of unsigned floats. Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary."
$nl
"Float vectors form a class:"
{ $subsection float-vector }
@@ -19,7 +19,7 @@ $nl
ABOUT: "float-vectors"
HELP: float-vector
-{ $description "The class of resizable float vectors. See " { $link "syntax-float-vectors" } " for syntax and " { $link "float-vectors" } " for general information." } ;
+{ $description "The class of resizable float vectors. See " { $link "float-vectors" } " for information." } ;
HELP: <float-vector>
{ $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } }
From d2d2c5d84fbf6eaa2c5150067fd19dc8f6a314c6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 10 Apr 2008 20:00:04 -0500
Subject: [PATCH 13/14] fix using in hardware-info
---
extra/hardware-info/windows/windows.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor
index 10474c09f7..3162496974 100755
--- a/extra/hardware-info/windows/windows.factor
+++ b/extra/hardware-info/windows/windows.factor
@@ -1,7 +1,7 @@
USING: alien alien.c-types kernel libc math namespaces
windows windows.kernel32 windows.advapi32
words combinators vocabs.loader hardware-info.backend
-system ;
+system alien.strings ;
IN: hardware-info.windows
: system-info ( -- SYSTEM_INFO )
From 8a0909d84923ce59a47e5322e449eb1c149d2768 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 10 Apr 2008 20:09:36 -0500
Subject: [PATCH 14/14] fix ffi test int ffi test 36 point 5
---
core/alien/compiler/compiler-tests.factor | 750 +++++++++++-----------
vm/ffi_test.c | 2 +-
2 files changed, 376 insertions(+), 376 deletions(-)
diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor
index 3d0f36e415..57bf163443 100755
--- a/core/alien/compiler/compiler-tests.factor
+++ b/core/alien/compiler/compiler-tests.factor
@@ -1,375 +1,375 @@
-IN: alien.compiler.tests
-USING: alien alien.c-types alien.syntax compiler kernel
-namespaces namespaces tools.test sequences inference words
-arrays parser quotations continuations inference.backend effects
-namespaces.private io io.streams.string memory system threads
-tools.test math ;
-
-FUNCTION: void ffi_test_0 ;
-[ ] [ ffi_test_0 ] unit-test
-
-FUNCTION: int ffi_test_1 ;
-[ 3 ] [ ffi_test_1 ] unit-test
-
-FUNCTION: int ffi_test_2 int x int y ;
-[ 5 ] [ 2 3 ffi_test_2 ] unit-test
-[ "hi" 3 ffi_test_2 ] must-fail
-
-FUNCTION: int ffi_test_3 int x int y int z int t ;
-[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
-
-FUNCTION: float ffi_test_4 ;
-[ 1.5 ] [ ffi_test_4 ] unit-test
-
-FUNCTION: double ffi_test_5 ;
-[ 1.5 ] [ ffi_test_5 ] unit-test
-
-FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
-[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
-[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
-[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
-
-C-STRUCT: foo
- { "int" "x" }
- { "int" "y" }
-;
-
-: make-foo ( x y -- foo )
- "foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
-
-FUNCTION: int ffi_test_11 int a foo b int c ;
-
-[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
-
-FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
-
-[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
-
-FUNCTION: foo ffi_test_14 int x int y ;
-
-[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
-
-FUNCTION: char* ffi_test_15 char* x char* y ;
-
-[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
-[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
-[ 1 2 ffi_test_15 ] must-fail
-
-C-STRUCT: bar
- { "long" "x" }
- { "long" "y" }
- { "long" "z" }
-;
-
-FUNCTION: bar ffi_test_16 long x long y long z ;
-
-[ 11 6 -7 ] [
- 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
-] unit-test
-
-C-STRUCT: tiny
- { "int" "x" }
-;
-
-FUNCTION: tiny ffi_test_17 int x ;
-
-[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
-
-[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
-
-: indirect-test-1
- "int" { } "cdecl" alien-indirect ;
-
-{ 1 1 } [ indirect-test-1 ] must-infer-as
-
-[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
-
-[ -1 indirect-test-1 ] must-fail
-
-: indirect-test-2
- "int" { "int" "int" } "cdecl" alien-indirect gc ;
-
-{ 3 1 } [ indirect-test-2 ] must-infer-as
-
-[ 5 ]
-[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
-unit-test
-
-: indirect-test-3
- "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
- gc ;
-
-<< "f-stdcall" f "stdcall" add-library >>
-
-[ f ] [ "f-stdcall" load-library ] unit-test
-[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test
-
-: ffi_test_18 ( w x y z -- int )
- "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
- alien-invoke gc ;
-
-[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
-
-: ffi_test_19 ( x y z -- bar )
- "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
- alien-invoke gc ;
-
-[ 11 6 -7 ] [
- 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
-] unit-test
-
-FUNCTION: double ffi_test_6 float x float y ;
-[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
-[ "a" "b" ffi_test_6 ] must-fail
-
-FUNCTION: double ffi_test_7 double x double y ;
-[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
-
-FUNCTION: double ffi_test_8 double x float y double z float t int w ;
-[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
-
-FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
-[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
-
-FUNCTION: void ffi_test_20 double x1, double x2, double x3,
- double y1, double y2, double y3,
- double z1, double z2, double z3 ;
-
-[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
-
-! Make sure XT doesn't get clobbered in stack frame
-
-: ffi_test_31
- "void"
- f "ffi_test_31"
- { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
- alien-invoke gc 3 ;
-
-[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
-
-FUNCTION: longlong ffi_test_21 long x long y ;
-
-[ 121932631112635269 ]
-[ 123456789 987654321 ffi_test_21 ] unit-test
-
-FUNCTION: long ffi_test_22 long x longlong y longlong z ;
-
-[ 987655432 ]
-[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
-
-[ 1111 f 123456789 ffi_test_22 ] must-fail
-
-C-STRUCT: rect
- { "float" "x" }
- { "float" "y" }
- { "float" "w" }
- { "float" "h" }
-;
-
-: <rect>
- "rect" <c-object>
- [ set-rect-h ] keep
- [ set-rect-w ] keep
- [ set-rect-y ] keep
- [ set-rect-x ] keep ;
-
-FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
-
-[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
-
-[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
-
-FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
-
-[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test
-
-! Test odd-size structs
-C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
-
-FUNCTION: test-struct-1 ffi_test_24 ;
-
-[ B{ 1 } ] [ ffi_test_24 ] unit-test
-
-C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
-
-FUNCTION: test-struct-2 ffi_test_25 ;
-
-[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
-
-C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
-
-FUNCTION: test-struct-3 ffi_test_26 ;
-
-[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
-
-C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
-
-FUNCTION: test-struct-4 ffi_test_27 ;
-
-[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
-
-C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
-
-FUNCTION: test-struct-5 ffi_test_28 ;
-
-[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
-
-C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
-
-FUNCTION: test-struct-6 ffi_test_29 ;
-
-[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
-
-C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
-
-FUNCTION: test-struct-7 ffi_test_30 ;
-
-[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
-
-C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
-
-FUNCTION: double ffi_test_32 test-struct-8 x int y ;
-
-[ 9.0 ] [
- "test-struct-8" <c-object>
- 1.0 over set-test-struct-8-x
- 2.0 over set-test-struct-8-y
- 3 ffi_test_32
-] unit-test
-
-C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
-
-FUNCTION: double ffi_test_33 test-struct-9 x int y ;
-
-[ 9.0 ] [
- "test-struct-9" <c-object>
- 1.0 over set-test-struct-9-x
- 2.0 over set-test-struct-9-y
- 3 ffi_test_33
-] unit-test
-
-C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
-
-FUNCTION: double ffi_test_34 test-struct-10 x int y ;
-
-[ 9.0 ] [
- "test-struct-10" <c-object>
- 1.0 over set-test-struct-10-x
- 2 over set-test-struct-10-y
- 3 ffi_test_34
-] unit-test
-
-C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
-
-FUNCTION: double ffi_test_35 test-struct-11 x int y ;
-
-[ 9.0 ] [
- "test-struct-11" <c-object>
- 1 over set-test-struct-11-x
- 2 over set-test-struct-11-y
- 3 ffi_test_35
-] unit-test
-
-C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
-
-: make-struct-12
- "test-struct-12" <c-object>
- [ set-test-struct-12-x ] keep ;
-
-FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
-
-[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
-
-FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
-
-[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
-
-! Test callbacks
-
-: callback-1 "void" { } "cdecl" [ ] alien-callback ;
-
-[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
-
-[ t ] [ callback-1 alien? ] unit-test
-
-: callback_test_1 "void" { } "cdecl" alien-indirect ;
-
-[ ] [ callback-1 callback_test_1 ] unit-test
-
-: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
-
-[ ] [ callback-2 callback_test_1 ] unit-test
-
-: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
-
-[ t ] [
- namestack*
- 3 "x" set callback-3 callback_test_1
- namestack* eq?
-] unit-test
-
-[ 5 ] [
- [
- 3 "x" set callback-3 callback_test_1 "x" get
- ] with-scope
-] unit-test
-
-: callback-4
- "void" { } "cdecl" [ "Hello world" write ] alien-callback
- gc ;
-
-[ "Hello world" ] [
- [ callback-4 callback_test_1 ] with-string-writer
-] unit-test
-
-: callback-5
- "void" { } "cdecl" [ gc ] alien-callback ;
-
-[ "testing" ] [
- "testing" callback-5 callback_test_1
-] unit-test
-
-: callback-5a
- "void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
-
-! Hack; if we're on ARM, we probably don't have much RAM, so
-! skip this test.
-! cpu "arm" = [
-! [ "testing" ] [
-! "testing" callback-5a callback_test_1
-! ] unit-test
-! ] unless
-
-: callback-6
- "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
-
-[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
-
-: callback-7
- "void" { } "cdecl" [ 1000 sleep ] alien-callback ;
-
-[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
-
-[ f ] [ namespace global eq? ] unit-test
-
-: callback-8
- "void" { } "cdecl" [
- [ continue ] callcc0
- ] alien-callback ;
-
-[ ] [ callback-8 callback_test_1 ] unit-test
-
-: callback-9
- "int" { "int" "int" "int" } "cdecl" [
- + + 1+
- ] alien-callback ;
-
-FUNCTION: void ffi_test_36_point_5 ( ) ;
-
-[ ] [ ffi_test_36_point_5 ] unit-test
-
-FUNCTION: int ffi_test_37 ( void* func ) ;
-
-[ 1 ] [ callback-9 ffi_test_37 ] unit-test
-
-[ 7 ] [ callback-9 ffi_test_37 ] unit-test
+IN: alien.compiler.tests
+USING: alien alien.c-types alien.syntax compiler kernel
+namespaces namespaces tools.test sequences inference words
+arrays parser quotations continuations inference.backend effects
+namespaces.private io io.streams.string memory system threads
+tools.test math ;
+
+FUNCTION: void ffi_test_0 ;
+[ ] [ ffi_test_0 ] unit-test
+
+FUNCTION: int ffi_test_1 ;
+[ 3 ] [ ffi_test_1 ] unit-test
+
+FUNCTION: int ffi_test_2 int x int y ;
+[ 5 ] [ 2 3 ffi_test_2 ] unit-test
+[ "hi" 3 ffi_test_2 ] must-fail
+
+FUNCTION: int ffi_test_3 int x int y int z int t ;
+[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
+
+FUNCTION: float ffi_test_4 ;
+[ 1.5 ] [ ffi_test_4 ] unit-test
+
+FUNCTION: double ffi_test_5 ;
+[ 1.5 ] [ ffi_test_5 ] unit-test
+
+FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
+[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
+[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
+[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
+
+C-STRUCT: foo
+ { "int" "x" }
+ { "int" "y" }
+;
+
+: make-foo ( x y -- foo )
+ "foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
+
+FUNCTION: int ffi_test_11 int a foo b int c ;
+
+[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
+
+FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
+
+[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
+
+FUNCTION: foo ffi_test_14 int x int y ;
+
+[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
+
+FUNCTION: char* ffi_test_15 char* x char* y ;
+
+[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
+[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
+[ 1 2 ffi_test_15 ] must-fail
+
+C-STRUCT: bar
+ { "long" "x" }
+ { "long" "y" }
+ { "long" "z" }
+;
+
+FUNCTION: bar ffi_test_16 long x long y long z ;
+
+[ 11 6 -7 ] [
+ 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
+] unit-test
+
+C-STRUCT: tiny
+ { "int" "x" }
+;
+
+FUNCTION: tiny ffi_test_17 int x ;
+
+[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
+
+[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
+
+: indirect-test-1
+ "int" { } "cdecl" alien-indirect ;
+
+{ 1 1 } [ indirect-test-1 ] must-infer-as
+
+[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
+
+[ -1 indirect-test-1 ] must-fail
+
+: indirect-test-2
+ "int" { "int" "int" } "cdecl" alien-indirect gc ;
+
+{ 3 1 } [ indirect-test-2 ] must-infer-as
+
+[ 5 ]
+[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
+unit-test
+
+: indirect-test-3
+ "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
+ gc ;
+
+<< "f-stdcall" f "stdcall" add-library >>
+
+[ f ] [ "f-stdcall" load-library ] unit-test
+[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test
+
+: ffi_test_18 ( w x y z -- int )
+ "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
+ alien-invoke gc ;
+
+[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
+
+: ffi_test_19 ( x y z -- bar )
+ "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
+ alien-invoke gc ;
+
+[ 11 6 -7 ] [
+ 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
+] unit-test
+
+FUNCTION: double ffi_test_6 float x float y ;
+[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
+[ "a" "b" ffi_test_6 ] must-fail
+
+FUNCTION: double ffi_test_7 double x double y ;
+[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
+
+FUNCTION: double ffi_test_8 double x float y double z float t int w ;
+[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
+
+FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
+[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
+
+FUNCTION: void ffi_test_20 double x1, double x2, double x3,
+ double y1, double y2, double y3,
+ double z1, double z2, double z3 ;
+
+[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
+
+! Make sure XT doesn't get clobbered in stack frame
+
+: ffi_test_31
+ "void"
+ f "ffi_test_31"
+ { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
+ alien-invoke gc 3 ;
+
+[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
+
+FUNCTION: longlong ffi_test_21 long x long y ;
+
+[ 121932631112635269 ]
+[ 123456789 987654321 ffi_test_21 ] unit-test
+
+FUNCTION: long ffi_test_22 long x longlong y longlong z ;
+
+[ 987655432 ]
+[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
+
+[ 1111 f 123456789 ffi_test_22 ] must-fail
+
+C-STRUCT: rect
+ { "float" "x" }
+ { "float" "y" }
+ { "float" "w" }
+ { "float" "h" }
+;
+
+: <rect>
+ "rect" <c-object>
+ [ set-rect-h ] keep
+ [ set-rect-w ] keep
+ [ set-rect-y ] keep
+ [ set-rect-x ] keep ;
+
+FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
+
+[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
+
+[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
+
+FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
+
+[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test
+
+! Test odd-size structs
+C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
+
+FUNCTION: test-struct-1 ffi_test_24 ;
+
+[ B{ 1 } ] [ ffi_test_24 ] unit-test
+
+C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
+
+FUNCTION: test-struct-2 ffi_test_25 ;
+
+[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
+
+C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
+
+FUNCTION: test-struct-3 ffi_test_26 ;
+
+[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
+
+C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
+
+FUNCTION: test-struct-4 ffi_test_27 ;
+
+[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
+
+C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
+
+FUNCTION: test-struct-5 ffi_test_28 ;
+
+[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
+
+C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
+
+FUNCTION: test-struct-6 ffi_test_29 ;
+
+[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
+
+C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
+
+FUNCTION: test-struct-7 ffi_test_30 ;
+
+[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
+
+C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
+
+FUNCTION: double ffi_test_32 test-struct-8 x int y ;
+
+[ 9.0 ] [
+ "test-struct-8" <c-object>
+ 1.0 over set-test-struct-8-x
+ 2.0 over set-test-struct-8-y
+ 3 ffi_test_32
+] unit-test
+
+C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
+
+FUNCTION: double ffi_test_33 test-struct-9 x int y ;
+
+[ 9.0 ] [
+ "test-struct-9" <c-object>
+ 1.0 over set-test-struct-9-x
+ 2.0 over set-test-struct-9-y
+ 3 ffi_test_33
+] unit-test
+
+C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
+
+FUNCTION: double ffi_test_34 test-struct-10 x int y ;
+
+[ 9.0 ] [
+ "test-struct-10" <c-object>
+ 1.0 over set-test-struct-10-x
+ 2 over set-test-struct-10-y
+ 3 ffi_test_34
+] unit-test
+
+C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
+
+FUNCTION: double ffi_test_35 test-struct-11 x int y ;
+
+[ 9.0 ] [
+ "test-struct-11" <c-object>
+ 1 over set-test-struct-11-x
+ 2 over set-test-struct-11-y
+ 3 ffi_test_35
+] unit-test
+
+C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
+
+: make-struct-12
+ "test-struct-12" <c-object>
+ [ set-test-struct-12-x ] keep ;
+
+FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
+
+[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
+
+FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
+
+[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
+
+! Test callbacks
+
+: callback-1 "void" { } "cdecl" [ ] alien-callback ;
+
+[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
+
+[ t ] [ callback-1 alien? ] unit-test
+
+: callback_test_1 "void" { } "cdecl" alien-indirect ;
+
+[ ] [ callback-1 callback_test_1 ] unit-test
+
+: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
+
+[ ] [ callback-2 callback_test_1 ] unit-test
+
+: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
+
+[ t ] [
+ namestack*
+ 3 "x" set callback-3 callback_test_1
+ namestack* eq?
+] unit-test
+
+[ 5 ] [
+ [
+ 3 "x" set callback-3 callback_test_1 "x" get
+ ] with-scope
+] unit-test
+
+: callback-4
+ "void" { } "cdecl" [ "Hello world" write ] alien-callback
+ gc ;
+
+[ "Hello world" ] [
+ [ callback-4 callback_test_1 ] with-string-writer
+] unit-test
+
+: callback-5
+ "void" { } "cdecl" [ gc ] alien-callback ;
+
+[ "testing" ] [
+ "testing" callback-5 callback_test_1
+] unit-test
+
+: callback-5a
+ "void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
+
+! Hack; if we're on ARM, we probably don't have much RAM, so
+! skip this test.
+! cpu "arm" = [
+! [ "testing" ] [
+! "testing" callback-5a callback_test_1
+! ] unit-test
+! ] unless
+
+: callback-6
+ "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
+
+[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
+
+: callback-7
+ "void" { } "cdecl" [ 1000 sleep ] alien-callback ;
+
+[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
+
+[ f ] [ namespace global eq? ] unit-test
+
+: callback-8
+ "void" { } "cdecl" [
+ [ continue ] callcc0
+ ] alien-callback ;
+
+[ ] [ callback-8 callback_test_1 ] unit-test
+
+: callback-9
+ "int" { "int" "int" "int" } "cdecl" [
+ + + 1+
+ ] alien-callback ;
+
+FUNCTION: void int_ffi_test_36_point_5 ( ) ;
+
+[ ] [ int_ffi_test_36_point_5 ] unit-test
+
+FUNCTION: int ffi_test_37 ( void* func ) ;
+
+[ 1 ] [ callback-9 ffi_test_37 ] unit-test
+
+[ 7 ] [ callback-9 ffi_test_37 ] unit-test
diff --git a/vm/ffi_test.c b/vm/ffi_test.c
index b2cbf9b6b5..4293a6bbae 100755
--- a/vm/ffi_test.c
+++ b/vm/ffi_test.c
@@ -253,7 +253,7 @@ double ffi_test_36(struct test_struct_12 x)
static int global_var;
-void ffi_test_36_point_5(void)
+void int_ffi_test_36_point_5(void)
{
printf("int_ffi_test_36_point_5\n");
global_var = 0;