Unit test fixes
dharmatech
parent
bff5d2af6d
commit
a336cb7570
|
|
@ -141,7 +141,11 @@ SYMBOL: quot-uses-b
|
|||
|
||||
[ { + } ] [ \ quot-uses-b uses ] unit-test
|
||||
|
||||
[ "IN: words.tests FORGET: undef-test : undef-test ; << undef-test >>" eval ]
|
||||
"undef-test" "words.tests" lookup [
|
||||
[ forget ] with-compilation-unit
|
||||
] when*
|
||||
|
||||
[ "IN: words.tests : undef-test ; << undef-test >>" eval ]
|
||||
[ [ undefined? ] is? ] must-fail-with
|
||||
|
||||
[ ] [
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.files kernel tools.test db db.tuples
|
||||
db.types continuations namespaces db.postgresql math
|
||||
db.types continuations namespaces math
|
||||
prettyprint tools.walker db.sqlite calendar
|
||||
math.intervals ;
|
||||
IN: db.tuples.tests
|
||||
|
|
@ -161,8 +161,8 @@ TUPLE: annotation n paste-id summary author mode contents ;
|
|||
: test-sqlite ( quot -- )
|
||||
>r "tuples-test.db" temp-file sqlite-db r> with-db ;
|
||||
|
||||
: test-postgresql ( -- )
|
||||
>r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ;
|
||||
! : test-postgresql ( -- )
|
||||
! >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ;
|
||||
|
||||
[ native-person-schema test-tuples ] test-sqlite
|
||||
[ assigned-person-schema test-tuples ] test-sqlite
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
USING: assocs html.parser kernel math sequences strings ascii
|
||||
arrays shuffle unicode.case namespaces splitting
|
||||
http.server.responders ;
|
||||
arrays shuffle unicode.case namespaces splitting http ;
|
||||
IN: html.parser.analyzer
|
||||
|
||||
: remove-blank-text ( vector -- vector' )
|
||||
|
|
@ -82,8 +81,8 @@ IN: html.parser.analyzer
|
|||
: href-contains? ( str tag -- ? )
|
||||
tag-attributes "href" swap at* [ subseq? ] [ 2drop f ] if ;
|
||||
|
||||
: query>hash* ( str -- hash )
|
||||
"?" split1 nip query>hash ;
|
||||
: query>assoc* ( str -- hash )
|
||||
"?" split1 nip query>assoc ;
|
||||
|
||||
! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map
|
||||
|
||||
|
|
@ -91,5 +90,5 @@ IN: html.parser.analyzer
|
|||
! "a" over find-opening-tags-by-name
|
||||
! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-subset
|
||||
! first first 8 + over nth
|
||||
! tag-attributes "href" swap at query>hash*
|
||||
! tag-attributes "href" swap at query>assoc*
|
||||
! "lat" over at "lon" rot at
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ sequences io.sniffer.backend ;
|
|||
QUALIFIED: unix
|
||||
IN: io.sniffer.bsd
|
||||
|
||||
M: unix-io destruct-handle ( obj -- ) unix:close drop ;
|
||||
M: unix-io destruct-handle ( obj -- ) unix:close ;
|
||||
|
||||
C-UNION: ifreq_props "sockaddr-in" "short" "int" "caddr_t" ;
|
||||
C-STRUCT: ifreq { { "char" 16 } "name" } { "ifreq_props" "props" } ;
|
||||
|
|
|
|||
|
|
@ -31,7 +31,8 @@ M: output-task io-task-filter drop EVFILT_WRITE ;
|
|||
swap io-task-filter over set-kevent-filter ;
|
||||
|
||||
: register-kevent ( kevent mx -- )
|
||||
mx-fd swap 1 f 0 f kevent io-error ;
|
||||
mx-fd swap 1 f 0 f kevent
|
||||
0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
|
||||
|
||||
M: kqueue-mx register-io-task ( task mx -- )
|
||||
over EV_ADD make-kevent over register-kevent
|
||||
|
|
|
|||
|
|
@ -5,10 +5,12 @@ tools.test ;
|
|||
|
||||
get-ldp LDAP_OPT_PROTOCOL_VERSION LDAP_VERSION3 <int> set-option
|
||||
|
||||
[ B{ 0 0 0 3 } ] [
|
||||
[ 3 ] [
|
||||
get-ldp LDAP_OPT_PROTOCOL_VERSION "int*" <c-object> [ get-option ] keep
|
||||
*int
|
||||
] unit-test
|
||||
|
||||
[
|
||||
get-ldp "cn=jimbob,dc=example,dc=com" "secret" [
|
||||
|
||||
! get-ldp "dc=example,dc=com" LDAP_SCOPE_ONELEVEL "(objectclass=*)" f 0
|
||||
|
|
@ -52,3 +54,4 @@ get-ldp "cn=jimbob,dc=example,dc=com" "secret" [
|
|||
get-ldp get-message next-message msgtype result-type
|
||||
|
||||
] with-bind
|
||||
] drop
|
||||
|
|
|
|||
|
|
@ -9,11 +9,11 @@ USING: alien alien.syntax combinators kernel system ;
|
|||
|
||||
IN: ldap.libldap
|
||||
|
||||
"libldap" {
|
||||
<< "libldap" {
|
||||
{ [ win32? ] [ "libldap.dll" "stdcall" ] }
|
||||
{ [ macosx? ] [ "libldap.dylib" "cdecl" ] }
|
||||
{ [ unix? ] [ "$LD_LIBRARY_PATH/libldap.so" "cdecl" ] }
|
||||
} cond add-library
|
||||
} cond add-library >>
|
||||
|
||||
: LDAP_VERSION1 1 ; inline
|
||||
: LDAP_VERSION2 2 ; inline
|
||||
|
|
|
|||
|
|
@ -9,11 +9,11 @@ USING: alien alien.syntax combinators kernel system ;
|
|||
|
||||
IN: openssl.libssl
|
||||
|
||||
"libssl" {
|
||||
<< "libssl" {
|
||||
{ [ win32? ] [ "ssleay32.dll" "stdcall" ] }
|
||||
{ [ macosx? ] [ "libssl.dylib" "cdecl" ] }
|
||||
{ [ unix? ] [ "$LD_LIBRARY_PATH/libssl.so" "cdecl" ] }
|
||||
} cond add-library
|
||||
} cond add-library >>
|
||||
|
||||
: X509_FILETYPE_PEM 1 ; inline
|
||||
: X509_FILETYPE_ASN1 2 ; inline
|
||||
|
|
|
|||
|
|
@ -9,11 +9,11 @@ USING: alien alien.syntax combinators system ;
|
|||
|
||||
IN: pdf.libhpdf
|
||||
|
||||
"libhpdf" {
|
||||
<< "libhpdf" {
|
||||
{ [ win32? ] [ "libhpdf.dll" "stdcall" ] }
|
||||
{ [ macosx? ] [ "libhpdf.dylib" "cdecl" ] }
|
||||
{ [ unix? ] [ "$LD_LIBRARY_PATH/libhpdf.so" "cdecl" ] }
|
||||
} cond add-library
|
||||
} cond add-library >>
|
||||
|
||||
! compression mode
|
||||
: HPDF_COMP_NONE HEX: 00 ; inline ! No contents are compressed
|
||||
|
|
|
|||
|
|
@ -92,6 +92,6 @@ SYMBOL: twidth
|
|||
|
||||
] with-text
|
||||
|
||||
"extra/pdf/test/font_test.pdf" resource-path save-to-file
|
||||
"font_test.pdf" temp-file save-to-file
|
||||
|
||||
] with-pdf
|
||||
|
|
|
|||
|
|
@ -1,300 +0,0 @@
|
|||
%PDF-1.3
|
||||
%·¾ª
|
||||
1 0 obj
|
||||
<<
|
||||
/Type /Catalog
|
||||
/Pages 2 0 R
|
||||
>>
|
||||
endobj
|
||||
2 0 obj
|
||||
<<
|
||||
/Type /Pages
|
||||
/Kids [ 4 0 R ]
|
||||
/Count 1
|
||||
>>
|
||||
endobj
|
||||
3 0 obj
|
||||
<<
|
||||
/Producer (Haru\040Free\040PDF\040Library\0402.0.8)
|
||||
>>
|
||||
endobj
|
||||
4 0 obj
|
||||
<<
|
||||
/Type /Page
|
||||
/MediaBox [ 0 0 595 841 ]
|
||||
/Contents 5 0 R
|
||||
/Resources <<
|
||||
/ProcSet [ /PDF /Text /ImageB /ImageC /ImageI ]
|
||||
/Font <<
|
||||
/F1 7 0 R
|
||||
/F2 8 0 R
|
||||
/F3 9 0 R
|
||||
/F4 10 0 R
|
||||
/F5 11 0 R
|
||||
/F6 12 0 R
|
||||
/F7 13 0 R
|
||||
/F8 14 0 R
|
||||
/F9 15 0 R
|
||||
/F10 16 0 R
|
||||
/F11 17 0 R
|
||||
/F12 18 0 R
|
||||
/F13 19 0 R
|
||||
/F14 20 0 R
|
||||
>>
|
||||
>>
|
||||
/Parent 2 0 R
|
||||
>>
|
||||
endobj
|
||||
5 0 obj
|
||||
<<
|
||||
/Length 6 0 R
|
||||
>>
|
||||
stream
|
||||
1 w
|
||||
50 50 495 731 re
|
||||
S
|
||||
/F1 24 Tf
|
||||
BT
|
||||
238.148 791 Td
|
||||
(Font\040Demo) Tj
|
||||
ET
|
||||
BT
|
||||
/F1 16 Tf
|
||||
60 761 Td
|
||||
(\074Standard\040Type1\040font\040samples\076) Tj
|
||||
ET
|
||||
BT
|
||||
60 736 Td
|
||||
/F2 9 Tf
|
||||
(Courier) Tj
|
||||
0 -18 Td
|
||||
/F2 20 Tf
|
||||
(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
|
||||
0 -20 Td
|
||||
/F3 9 Tf
|
||||
(Courier-Bold) Tj
|
||||
0 -18 Td
|
||||
/F3 20 Tf
|
||||
(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
|
||||
0 -20 Td
|
||||
/F4 9 Tf
|
||||
(Courier-Oblique) Tj
|
||||
0 -18 Td
|
||||
/F4 20 Tf
|
||||
(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
|
||||
0 -20 Td
|
||||
/F5 9 Tf
|
||||
(Courier-BoldOblique) Tj
|
||||
0 -18 Td
|
||||
/F5 20 Tf
|
||||
(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
|
||||
0 -20 Td
|
||||
/F1 9 Tf
|
||||
(Helvetica) Tj
|
||||
0 -18 Td
|
||||
/F1 20 Tf
|
||||
(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
|
||||
0 -20 Td
|
||||
/F6 9 Tf
|
||||
(Helvetica-Bold) Tj
|
||||
0 -18 Td
|
||||
/F6 20 Tf
|
||||
(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
|
||||
0 -20 Td
|
||||
/F7 9 Tf
|
||||
(Helvetica-Oblique) Tj
|
||||
0 -18 Td
|
||||
/F7 20 Tf
|
||||
(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
|
||||
0 -20 Td
|
||||
/F8 9 Tf
|
||||
(Helvetica-BoldOblique) Tj
|
||||
0 -18 Td
|
||||
/F8 20 Tf
|
||||
(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
|
||||
0 -20 Td
|
||||
/F9 9 Tf
|
||||
(Times-Roman) Tj
|
||||
0 -18 Td
|
||||
/F9 20 Tf
|
||||
(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
|
||||
0 -20 Td
|
||||
/F10 9 Tf
|
||||
(Times-Bold) Tj
|
||||
0 -18 Td
|
||||
/F10 20 Tf
|
||||
(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
|
||||
0 -20 Td
|
||||
/F11 9 Tf
|
||||
(Times-Italic) Tj
|
||||
0 -18 Td
|
||||
/F11 20 Tf
|
||||
(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
|
||||
0 -20 Td
|
||||
/F12 9 Tf
|
||||
(Times-BoldItalic) Tj
|
||||
0 -18 Td
|
||||
/F12 20 Tf
|
||||
(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
|
||||
0 -20 Td
|
||||
/F13 9 Tf
|
||||
(Symbol) Tj
|
||||
0 -18 Td
|
||||
/F13 20 Tf
|
||||
(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
|
||||
0 -20 Td
|
||||
/F14 9 Tf
|
||||
(ZapfDingbats) Tj
|
||||
0 -18 Td
|
||||
/F14 20 Tf
|
||||
(abcdefgABCDEFG12345!\043$\045&+-@?) Tj
|
||||
0 -20 Td
|
||||
ET
|
||||
|
||||
endstream
|
||||
endobj
|
||||
6 0 obj
|
||||
1517
|
||||
endobj
|
||||
7 0 obj
|
||||
<<
|
||||
/Type /Font
|
||||
/BaseFont /Helvetica
|
||||
/Subtype /Type1
|
||||
/Encoding /StandardEncoding
|
||||
>>
|
||||
endobj
|
||||
8 0 obj
|
||||
<<
|
||||
/Type /Font
|
||||
/BaseFont /Courier
|
||||
/Subtype /Type1
|
||||
/Encoding /StandardEncoding
|
||||
>>
|
||||
endobj
|
||||
9 0 obj
|
||||
<<
|
||||
/Type /Font
|
||||
/BaseFont /Courier-Bold
|
||||
/Subtype /Type1
|
||||
/Encoding /StandardEncoding
|
||||
>>
|
||||
endobj
|
||||
10 0 obj
|
||||
<<
|
||||
/Type /Font
|
||||
/BaseFont /Courier-Oblique
|
||||
/Subtype /Type1
|
||||
/Encoding /StandardEncoding
|
||||
>>
|
||||
endobj
|
||||
11 0 obj
|
||||
<<
|
||||
/Type /Font
|
||||
/BaseFont /Courier-BoldOblique
|
||||
/Subtype /Type1
|
||||
/Encoding /StandardEncoding
|
||||
>>
|
||||
endobj
|
||||
12 0 obj
|
||||
<<
|
||||
/Type /Font
|
||||
/BaseFont /Helvetica-Bold
|
||||
/Subtype /Type1
|
||||
/Encoding /StandardEncoding
|
||||
>>
|
||||
endobj
|
||||
13 0 obj
|
||||
<<
|
||||
/Type /Font
|
||||
/BaseFont /Helvetica-Oblique
|
||||
/Subtype /Type1
|
||||
/Encoding /StandardEncoding
|
||||
>>
|
||||
endobj
|
||||
14 0 obj
|
||||
<<
|
||||
/Type /Font
|
||||
/BaseFont /Helvetica-BoldOblique
|
||||
/Subtype /Type1
|
||||
/Encoding /StandardEncoding
|
||||
>>
|
||||
endobj
|
||||
15 0 obj
|
||||
<<
|
||||
/Type /Font
|
||||
/BaseFont /Times-Roman
|
||||
/Subtype /Type1
|
||||
/Encoding /StandardEncoding
|
||||
>>
|
||||
endobj
|
||||
16 0 obj
|
||||
<<
|
||||
/Type /Font
|
||||
/BaseFont /Times-Bold
|
||||
/Subtype /Type1
|
||||
/Encoding /StandardEncoding
|
||||
>>
|
||||
endobj
|
||||
17 0 obj
|
||||
<<
|
||||
/Type /Font
|
||||
/BaseFont /Times-Italic
|
||||
/Subtype /Type1
|
||||
/Encoding /StandardEncoding
|
||||
>>
|
||||
endobj
|
||||
18 0 obj
|
||||
<<
|
||||
/Type /Font
|
||||
/BaseFont /Times-BoldItalic
|
||||
/Subtype /Type1
|
||||
/Encoding /StandardEncoding
|
||||
>>
|
||||
endobj
|
||||
19 0 obj
|
||||
<<
|
||||
/Type /Font
|
||||
/BaseFont /Symbol
|
||||
/Subtype /Type1
|
||||
>>
|
||||
endobj
|
||||
20 0 obj
|
||||
<<
|
||||
/Type /Font
|
||||
/BaseFont /ZapfDingbats
|
||||
/Subtype /Type1
|
||||
>>
|
||||
endobj
|
||||
xref
|
||||
0 21
|
||||
0000000000 65535 f
|
||||
0000000015 00000 n
|
||||
0000000064 00000 n
|
||||
0000000123 00000 n
|
||||
0000000196 00000 n
|
||||
0000000518 00000 n
|
||||
0000002089 00000 n
|
||||
0000002109 00000 n
|
||||
0000002207 00000 n
|
||||
0000002303 00000 n
|
||||
0000002404 00000 n
|
||||
0000002509 00000 n
|
||||
0000002618 00000 n
|
||||
0000002722 00000 n
|
||||
0000002829 00000 n
|
||||
0000002940 00000 n
|
||||
0000003041 00000 n
|
||||
0000003141 00000 n
|
||||
0000003243 00000 n
|
||||
0000003349 00000 n
|
||||
0000003417 00000 n
|
||||
trailer
|
||||
<<
|
||||
/Root 1 0 R
|
||||
/Info 3 0 R
|
||||
/Size 21
|
||||
>>
|
||||
startxref
|
||||
3491
|
||||
%%EOF
|
||||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
USING: kernel math math.parser arrays tools.test peg peg.search ;
|
||||
USING: kernel math math.parser arrays tools.test peg peg.parsers
|
||||
peg.search ;
|
||||
IN: peg.search.tests
|
||||
|
||||
{ V{ 123 456 } } [
|
||||
|
|
|
|||
|
|
@ -54,7 +54,6 @@ IN: random-tester.safe-words
|
|||
|
||||
: method-words
|
||||
{
|
||||
method-def
|
||||
forget-word
|
||||
} ;
|
||||
|
||||
|
|
|
|||
|
|
@ -84,6 +84,7 @@ IN: smtp.tests
|
|||
|
||||
[ ] [
|
||||
[
|
||||
"localhost" smtp-host set
|
||||
4321 smtp-port set
|
||||
|
||||
"Hi guys\nBye guys"
|
||||
|
|
@ -96,4 +97,4 @@ IN: smtp.tests
|
|||
|
||||
send-simple-message
|
||||
] with-scope
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ TYPEDEF: ulong size_t
|
|||
|
||||
: MAP_FAILED -1 <alien> ; inline
|
||||
|
||||
: ESRCH 3 ; inline
|
||||
: EEXIST 17 ; inline
|
||||
|
||||
! ! ! Unix functions
|
||||
|
|
|
|||
|
|
@ -1,2 +0,0 @@
|
|||
Chris Double
|
||||
Slava Pestov
|
||||
|
|
@ -1,126 +0,0 @@
|
|||
! Copyright (C) 2004 Chris Double.
|
||||
! Copyright (C) 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: html http http.server.responders io kernel math
|
||||
namespaces prettyprint continuations random system sequences
|
||||
assocs ;
|
||||
IN: webapps.callback
|
||||
|
||||
#! Name of the variable holding the continuation used to exit
|
||||
#! back to the httpd responder.
|
||||
SYMBOL: exit-continuation
|
||||
|
||||
#! Tuple to hold global request data. This gets passed to
|
||||
#! the continuation when resumed so it can restore things
|
||||
#! like 'stdio' so it writes to the correct socket.
|
||||
TUPLE: request stream exitcc method url raw-query query header response ;
|
||||
|
||||
: <request> ( -- request )
|
||||
stdio get
|
||||
exit-continuation get
|
||||
"method" get
|
||||
"request" get
|
||||
"raw-query" get
|
||||
"query" get
|
||||
"header" get
|
||||
"response" get
|
||||
request construct-boa ;
|
||||
|
||||
: restore-request ( -- )
|
||||
request get
|
||||
dup request-stream stdio set
|
||||
dup request-method "method" set
|
||||
dup request-raw-query "raw-query" set
|
||||
dup request-query "query" set
|
||||
dup request-header "header" set
|
||||
dup request-response "response" set
|
||||
request-exitcc exit-continuation set ;
|
||||
|
||||
: update-request ( request new-request -- )
|
||||
[ request-stream over set-request-stream ] keep
|
||||
[ request-method over set-request-method ] keep
|
||||
[ request-url over set-request-url ] keep
|
||||
[ request-raw-query over set-request-raw-query ] keep
|
||||
[ request-query over set-request-query ] keep
|
||||
[ request-header over set-request-header ] keep
|
||||
[ request-response over set-request-response ] keep
|
||||
request-exitcc swap set-request-exitcc ;
|
||||
|
||||
: with-exit-continuation ( quot -- )
|
||||
#! Call the quotation with the variable exit-continuation bound
|
||||
#! such that when the exit continuation is called, computation
|
||||
#! will resume from the end of this 'with-exit-continuation' call.
|
||||
[
|
||||
exit-continuation set call exit-continuation get continue
|
||||
] callcc0 drop ;
|
||||
|
||||
: expiry-timeout ( -- ms ) 900 1000 * ;
|
||||
|
||||
: get-random-id ( -- id )
|
||||
#! Generate a random id to use for continuation URL's
|
||||
4 big-random unparse ;
|
||||
|
||||
: callback-table ( -- <hashtable> )
|
||||
#! Return the global table of continuations
|
||||
\ callback-table get-global ;
|
||||
|
||||
: reset-callback-table ( -- )
|
||||
#! Create the initial global table
|
||||
H{ } clone \ callback-table set-global ;
|
||||
|
||||
reset-callback-table
|
||||
|
||||
#! Tuple for holding data related to a callback.
|
||||
TUPLE: item quot expire? request id time-added ;
|
||||
|
||||
: <item> ( quot expire? request id -- item )
|
||||
millis item construct-boa ;
|
||||
|
||||
: expired? ( item -- ? )
|
||||
#! Return true if the callback item is expirable
|
||||
#! and has expired (ie. was added to the table more than
|
||||
#! timeout milliseconds ago).
|
||||
[ item-time-added expiry-timeout + millis < ] keep
|
||||
item-expire? and ;
|
||||
|
||||
: expire-callbacks ( -- )
|
||||
#! Expire all continuations in the continuation table
|
||||
#! if they are 'timeout-seconds' old (ie. were added
|
||||
#! more than 'timeout-seconds' ago.
|
||||
callback-table clone [
|
||||
expired? [ callback-table delete-at ] [ drop ] if
|
||||
] assoc-each ;
|
||||
|
||||
: id>url ( id -- string )
|
||||
#! Convert the continuation id to an URL suitable for
|
||||
#! embedding in an HREF or other HTML.
|
||||
"/responder/callback/?id=" swap url-encode append ;
|
||||
|
||||
: register-callback ( quot expire? -- url )
|
||||
#! Store a continuation in the table and associate it with
|
||||
#! a random id. That continuation will be expired after
|
||||
#! a certain period of time if 'expire?' is true.
|
||||
request get get-random-id [ <item> ] keep
|
||||
[ callback-table set-at ] keep
|
||||
id>url ;
|
||||
|
||||
: register-html-callback ( quot expire? -- url )
|
||||
>r [ serving-html ] swap append r> register-callback ;
|
||||
|
||||
: callback-responder ( -- )
|
||||
expire-callbacks
|
||||
"id" query-param callback-table at [
|
||||
[
|
||||
dup item-request [
|
||||
<request> update-request
|
||||
] when*
|
||||
item-quot call
|
||||
exit-continuation get continue
|
||||
] with-exit-continuation drop
|
||||
] [
|
||||
"404 Callback not available" httpd-error
|
||||
] if* ;
|
||||
|
||||
global [
|
||||
"callback" [ callback-responder ] add-simple-responder
|
||||
] bind
|
||||
|
|
@ -1 +0,0 @@
|
|||
Chris Double
|
||||
|
|
@ -1,151 +0,0 @@
|
|||
! Copyright (C) 2004 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: http math namespaces io strings kernel html html.elements
|
||||
hashtables continuations quotations parser generic sequences
|
||||
webapps.callback http.server.responders ;
|
||||
IN: webapps.continuation
|
||||
|
||||
#! Used inside the session state of responders to indicate whether the
|
||||
#! next request should use the post-refresh-get pattern. It is set to
|
||||
#! true after each request.
|
||||
SYMBOL: post-refresh-get?
|
||||
|
||||
: >callable ( quot|interp|f -- interp )
|
||||
dup continuation? [
|
||||
[ continue ] curry
|
||||
] when ;
|
||||
|
||||
: forward-to-url ( url -- )
|
||||
#! When executed inside a 'show' call, this will force a
|
||||
#! HTTP 302 to occur to instruct the browser to forward to
|
||||
#! the request URL.
|
||||
[
|
||||
"HTTP/1.1 302 Document Moved\nLocation: " % %
|
||||
"\nContent-Length: 0\nContent-Type: text/plain\n\n" %
|
||||
] "" make write exit-continuation get continue ;
|
||||
|
||||
: forward-to-id ( id -- )
|
||||
#! When executed inside a 'show' call, this will force a
|
||||
#! HTTP 302 to occur to instruct the browser to forward to
|
||||
#! the request URL.
|
||||
>r "request" get r> id>url append forward-to-url ;
|
||||
|
||||
SYMBOL: current-show
|
||||
|
||||
: store-current-show ( -- )
|
||||
#! Store the current continuation in the variable 'current-show'
|
||||
#! so it can be returned to later by href callbacks. Note that it
|
||||
#! recalls itself when the continuation is called to ensure that
|
||||
#! it resets its value back to the most recent show call.
|
||||
[ ( 0 -- )
|
||||
[ ( 0 1 -- )
|
||||
current-show set ( 0 -- )
|
||||
continue
|
||||
] callcc1
|
||||
nip
|
||||
restore-request
|
||||
call
|
||||
store-current-show
|
||||
] callcc0 restore-request ;
|
||||
|
||||
: redirect-to-here ( -- )
|
||||
#! Force a redirect to the client browser so that the browser
|
||||
#! goes to the current point in the code. This forces an URL
|
||||
#! change on the browser so that refreshing that URL will
|
||||
#! immediately run from this code point. This prevents the
|
||||
#! "this request will issue a POST" warning from the browser
|
||||
#! and prevents re-running the previous POST logic. This is
|
||||
#! known as the 'post-refresh-get' pattern.
|
||||
post-refresh-get? get [
|
||||
[
|
||||
>callable t register-callback forward-to-url
|
||||
] callcc0 restore-request
|
||||
] [
|
||||
t post-refresh-get? set
|
||||
] if ;
|
||||
|
||||
: (show) ( quot -- hashtable )
|
||||
#! See comments for show. The difference is the
|
||||
#! quotation MUST set the content-type using 'serving-html'
|
||||
#! or similar.
|
||||
store-current-show redirect-to-here
|
||||
[
|
||||
>callable t register-callback swap with-scope
|
||||
exit-continuation get continue
|
||||
] callcc0 drop restore-request "response" get ;
|
||||
|
||||
: show ( quot -- namespace )
|
||||
#! Call the quotation with the URL associated with the current
|
||||
#! continuation. All output from the quotation goes to the client
|
||||
#! browser. When the URL is later referenced then
|
||||
#! computation will resume from this 'show' call with a hashtable on
|
||||
#! the stack containing any query or post parameters.
|
||||
#! 'quot' has stack effect ( url -- )
|
||||
#! NOTE: On return from 'show' the stack is exactly the same as
|
||||
#! initial entry with 'quot' popped off and the hashtable pushed on. Even
|
||||
#! if the quotation consumes items on the stack.
|
||||
[ serving-html ] swap append (show) ;
|
||||
|
||||
: (show-final) ( quot -- namespace )
|
||||
#! See comments for show-final. The difference is the
|
||||
#! quotation MUST set the content-type using 'serving-html'
|
||||
#! or similar.
|
||||
store-current-show redirect-to-here
|
||||
with-scope exit-continuation get continue ;
|
||||
|
||||
: show-final ( quot -- namespace )
|
||||
#! Similar to 'show', except the quotation does not receive the URL
|
||||
#! to resume computation following 'show-final'. No continuation is
|
||||
#! stored for this resumption. As a result, 'show-final' is for use
|
||||
#! when a page is to be displayed with no further action to occur. Its
|
||||
#! use is an optimisation to save having to generate and save a continuation
|
||||
#! in that special case.
|
||||
#! 'quot' has stack effect ( -- ).
|
||||
[ serving-html ] swap compose (show-final) ;
|
||||
|
||||
#! Name of variable for holding initial continuation id that starts
|
||||
#! the responder.
|
||||
SYMBOL: root-callback
|
||||
|
||||
: cont-get/post-responder ( id-or-f -- )
|
||||
#! httpd responder that handles the root continuation request.
|
||||
#! The requests for actual continuation are processed by the
|
||||
#! 'callback-responder'.
|
||||
[
|
||||
[ f post-refresh-get? set <request> request set root-callback get call ] with-scope
|
||||
exit-continuation get continue
|
||||
] with-exit-continuation drop ;
|
||||
|
||||
: quot-url ( quot -- url )
|
||||
current-show get [ continue-with ] 2curry t register-callback ;
|
||||
|
||||
: quot-href ( text quot -- )
|
||||
#! Write to standard output an HTML HREF where the href,
|
||||
#! when referenced, will call the quotation and then return
|
||||
#! back to the most recent 'show' call (via the callback-cc).
|
||||
#! The text of the link will be the 'text' argument on the
|
||||
#! stack.
|
||||
<a quot-url =href a> write </a> ;
|
||||
|
||||
: install-cont-responder ( name quot -- )
|
||||
#! Install a cont-responder with the given name
|
||||
#! that will initially run the given quotation.
|
||||
#!
|
||||
#! Convert the quotation so it is run within a session namespace
|
||||
#! and that namespace is initialized first.
|
||||
[
|
||||
[ cont-get/post-responder ] "get" set
|
||||
[ cont-get/post-responder ] "post" set
|
||||
swap "responder" set
|
||||
root-callback set
|
||||
] make-responder ;
|
||||
|
||||
: show-message-page ( message -- )
|
||||
#! Display the message in an HTML page with an OK button.
|
||||
[
|
||||
"Press OK to Continue" [
|
||||
swap paragraph
|
||||
<a =href a> "OK" write </a>
|
||||
] simple-page
|
||||
] show 2drop ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Chris Double
|
||||
|
|
@ -1,115 +0,0 @@
|
|||
! Copyright (C) 2004 Chris Double.
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions are met:
|
||||
!
|
||||
! 1. Redistributions of source code must retain the above copyright notice,
|
||||
! this list of conditions and the following disclaimer.
|
||||
!
|
||||
! 2. Redistributions in binary form must reproduce the above copyright notice,
|
||||
! this list of conditions and the following disclaimer in the documentation
|
||||
! and/or other materials provided with the distribution.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
|
||||
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
|
||||
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
||||
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
|
||||
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
|
||||
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
||||
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
|
||||
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
|
||||
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
! Simple test applications
|
||||
USING: hashtables html kernel io html html.elements strings math
|
||||
assocs quotations webapps.continuation namespaces prettyprint
|
||||
sequences ;
|
||||
|
||||
IN: webapps.continuation.examples
|
||||
|
||||
: display-page ( title -- )
|
||||
#! Display a page with some text to test the cont-responder.
|
||||
#! The page has a link to the 'next' continuation.
|
||||
[
|
||||
<h1> over write </h1>
|
||||
swap [
|
||||
<a =href a> "Next" write </a>
|
||||
] simple-html-document
|
||||
] show 2drop ;
|
||||
|
||||
: display-get-name-page ( -- name )
|
||||
#! Display a page prompting for input of a name and return that name.
|
||||
[
|
||||
"Enter your name" [
|
||||
<h1> swap write </h1>
|
||||
<form "post" =method =action form>
|
||||
"Name: " write
|
||||
<input "text" =type "name" =name "20" =size input/>
|
||||
<input "submit" =type "Ok" =value input/>
|
||||
</form>
|
||||
] simple-html-document
|
||||
] show "name" swap at ;
|
||||
|
||||
: test-cont-responder ( -- )
|
||||
#! Test the cont-responder responder by displaying a few pages in a row.
|
||||
"Page one" display-page
|
||||
"Hello " display-get-name-page append display-page
|
||||
"Page three" display-page ;
|
||||
|
||||
: test-cont-responder2 ( -- )
|
||||
#! Test the cont-responder responder by displaying a few pages in a loop.
|
||||
[ "one" "two" "three" "four" ] [ display-page ] each
|
||||
"Done!" display-page ;
|
||||
|
||||
: test-cont-responder3 ( -- )
|
||||
#! Test the quot-href word by displaying a menu of the current
|
||||
#! test words. Note that we use show-final as we don't link to a 'next' page.
|
||||
[
|
||||
"Menu" [
|
||||
<h1> "Menu" write </h1>
|
||||
<ol>
|
||||
<li> "Test responder1" [ test-cont-responder ] quot-href </li>
|
||||
<li> "Test responder2" [ test-cont-responder2 ] quot-href </li>
|
||||
</ol>
|
||||
] simple-html-document
|
||||
] show-final ;
|
||||
|
||||
: counter-example ( count -- )
|
||||
#! Display a counter which can be incremented or decremented
|
||||
#! using anchors.
|
||||
#!
|
||||
#! Don't need the original alist
|
||||
[
|
||||
#! And we don't need the 'url' argument
|
||||
drop
|
||||
"Counter: " over unparse append [
|
||||
dup <h2> unparse write </h2>
|
||||
"++" over 1quotation [ f ] swap append [ 1 + counter-example ] append quot-href
|
||||
"--" over 1quotation [ f ] swap append [ 1 - counter-example ] append quot-href
|
||||
drop
|
||||
] simple-html-document
|
||||
] show drop ;
|
||||
|
||||
: counter-example2 ( -- )
|
||||
#! Display a counter which can be incremented or decremented
|
||||
#! using anchors.
|
||||
#!
|
||||
0 "counter" set
|
||||
[
|
||||
#! We don't need the 'url' argument
|
||||
drop
|
||||
"Counter: " "counter" get unparse append [
|
||||
<h2> "counter" get unparse write </h2>
|
||||
"++" [ "counter" get 1 + "counter" set ] quot-href
|
||||
"--" [ "counter" get 1 - "counter" set ] quot-href
|
||||
] simple-html-document
|
||||
] show
|
||||
drop ;
|
||||
|
||||
! Install the examples
|
||||
"counter1" [ drop 0 counter-example ] install-cont-responder
|
||||
"counter2" [ drop counter-example2 ] install-cont-responder
|
||||
"test1" [ test-cont-responder ] install-cont-responder
|
||||
"test2" [ drop test-cont-responder2 ] install-cont-responder
|
||||
"test3" [ drop test-cont-responder3 ] install-cont-responder
|
||||
Loading…
Reference in New Issue