Unit test fixes
dharmatech
parent
bff5d2af6d
commit
a336cb7570
|
|
@ -141,7 +141,11 @@ SYMBOL: quot-uses-b
|
||||||
|
|
||||||
[ { + } ] [ \ quot-uses-b uses ] unit-test
|
[ { + } ] [ \ 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
|
[ [ undefined? ] is? ] must-fail-with
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Doug Coleman.
|
! Copyright (C) 2008 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: io.files kernel tools.test db db.tuples
|
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
|
prettyprint tools.walker db.sqlite calendar
|
||||||
math.intervals ;
|
math.intervals ;
|
||||||
IN: db.tuples.tests
|
IN: db.tuples.tests
|
||||||
|
|
@ -161,8 +161,8 @@ TUPLE: annotation n paste-id summary author mode contents ;
|
||||||
: test-sqlite ( quot -- )
|
: test-sqlite ( quot -- )
|
||||||
>r "tuples-test.db" temp-file sqlite-db r> with-db ;
|
>r "tuples-test.db" temp-file sqlite-db r> with-db ;
|
||||||
|
|
||||||
: test-postgresql ( -- )
|
! : test-postgresql ( -- )
|
||||||
>r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ;
|
! >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ;
|
||||||
|
|
||||||
[ native-person-schema test-tuples ] test-sqlite
|
[ native-person-schema test-tuples ] test-sqlite
|
||||||
[ assigned-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
|
USING: assocs html.parser kernel math sequences strings ascii
|
||||||
arrays shuffle unicode.case namespaces splitting
|
arrays shuffle unicode.case namespaces splitting http ;
|
||||||
http.server.responders ;
|
|
||||||
IN: html.parser.analyzer
|
IN: html.parser.analyzer
|
||||||
|
|
||||||
: remove-blank-text ( vector -- vector' )
|
: remove-blank-text ( vector -- vector' )
|
||||||
|
|
@ -82,8 +81,8 @@ IN: html.parser.analyzer
|
||||||
: href-contains? ( str tag -- ? )
|
: href-contains? ( str tag -- ? )
|
||||||
tag-attributes "href" swap at* [ subseq? ] [ 2drop f ] if ;
|
tag-attributes "href" swap at* [ subseq? ] [ 2drop f ] if ;
|
||||||
|
|
||||||
: query>hash* ( str -- hash )
|
: query>assoc* ( str -- hash )
|
||||||
"?" split1 nip query>hash ;
|
"?" split1 nip query>assoc ;
|
||||||
|
|
||||||
! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map
|
! 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
|
! "a" over find-opening-tags-by-name
|
||||||
! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-subset
|
! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-subset
|
||||||
! first first 8 + over nth
|
! 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
|
! "lat" over at "lon" rot at
|
||||||
|
|
|
||||||
|
|
@ -7,7 +7,7 @@ sequences io.sniffer.backend ;
|
||||||
QUALIFIED: unix
|
QUALIFIED: unix
|
||||||
IN: io.sniffer.bsd
|
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-UNION: ifreq_props "sockaddr-in" "short" "int" "caddr_t" ;
|
||||||
C-STRUCT: ifreq { { "char" 16 } "name" } { "ifreq_props" "props" } ;
|
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 ;
|
swap io-task-filter over set-kevent-filter ;
|
||||||
|
|
||||||
: register-kevent ( kevent mx -- )
|
: 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 -- )
|
M: kqueue-mx register-io-task ( task mx -- )
|
||||||
over EV_ADD make-kevent over register-kevent
|
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
|
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
|
get-ldp LDAP_OPT_PROTOCOL_VERSION "int*" <c-object> [ get-option ] keep
|
||||||
|
*int
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
get-ldp "cn=jimbob,dc=example,dc=com" "secret" [
|
get-ldp "cn=jimbob,dc=example,dc=com" "secret" [
|
||||||
|
|
||||||
! get-ldp "dc=example,dc=com" LDAP_SCOPE_ONELEVEL "(objectclass=*)" f 0
|
! 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
|
get-ldp get-message next-message msgtype result-type
|
||||||
|
|
||||||
] with-bind
|
] with-bind
|
||||||
|
] drop
|
||||||
|
|
|
||||||
|
|
@ -9,11 +9,11 @@ USING: alien alien.syntax combinators kernel system ;
|
||||||
|
|
||||||
IN: ldap.libldap
|
IN: ldap.libldap
|
||||||
|
|
||||||
"libldap" {
|
<< "libldap" {
|
||||||
{ [ win32? ] [ "libldap.dll" "stdcall" ] }
|
{ [ win32? ] [ "libldap.dll" "stdcall" ] }
|
||||||
{ [ macosx? ] [ "libldap.dylib" "cdecl" ] }
|
{ [ macosx? ] [ "libldap.dylib" "cdecl" ] }
|
||||||
{ [ unix? ] [ "$LD_LIBRARY_PATH/libldap.so" "cdecl" ] }
|
{ [ unix? ] [ "$LD_LIBRARY_PATH/libldap.so" "cdecl" ] }
|
||||||
} cond add-library
|
} cond add-library >>
|
||||||
|
|
||||||
: LDAP_VERSION1 1 ; inline
|
: LDAP_VERSION1 1 ; inline
|
||||||
: LDAP_VERSION2 2 ; inline
|
: LDAP_VERSION2 2 ; inline
|
||||||
|
|
|
||||||
|
|
@ -9,11 +9,11 @@ USING: alien alien.syntax combinators kernel system ;
|
||||||
|
|
||||||
IN: openssl.libssl
|
IN: openssl.libssl
|
||||||
|
|
||||||
"libssl" {
|
<< "libssl" {
|
||||||
{ [ win32? ] [ "ssleay32.dll" "stdcall" ] }
|
{ [ win32? ] [ "ssleay32.dll" "stdcall" ] }
|
||||||
{ [ macosx? ] [ "libssl.dylib" "cdecl" ] }
|
{ [ macosx? ] [ "libssl.dylib" "cdecl" ] }
|
||||||
{ [ unix? ] [ "$LD_LIBRARY_PATH/libssl.so" "cdecl" ] }
|
{ [ unix? ] [ "$LD_LIBRARY_PATH/libssl.so" "cdecl" ] }
|
||||||
} cond add-library
|
} cond add-library >>
|
||||||
|
|
||||||
: X509_FILETYPE_PEM 1 ; inline
|
: X509_FILETYPE_PEM 1 ; inline
|
||||||
: X509_FILETYPE_ASN1 2 ; inline
|
: X509_FILETYPE_ASN1 2 ; inline
|
||||||
|
|
|
||||||
|
|
@ -9,11 +9,11 @@ USING: alien alien.syntax combinators system ;
|
||||||
|
|
||||||
IN: pdf.libhpdf
|
IN: pdf.libhpdf
|
||||||
|
|
||||||
"libhpdf" {
|
<< "libhpdf" {
|
||||||
{ [ win32? ] [ "libhpdf.dll" "stdcall" ] }
|
{ [ win32? ] [ "libhpdf.dll" "stdcall" ] }
|
||||||
{ [ macosx? ] [ "libhpdf.dylib" "cdecl" ] }
|
{ [ macosx? ] [ "libhpdf.dylib" "cdecl" ] }
|
||||||
{ [ unix? ] [ "$LD_LIBRARY_PATH/libhpdf.so" "cdecl" ] }
|
{ [ unix? ] [ "$LD_LIBRARY_PATH/libhpdf.so" "cdecl" ] }
|
||||||
} cond add-library
|
} cond add-library >>
|
||||||
|
|
||||||
! compression mode
|
! compression mode
|
||||||
: HPDF_COMP_NONE HEX: 00 ; inline ! No contents are compressed
|
: HPDF_COMP_NONE HEX: 00 ; inline ! No contents are compressed
|
||||||
|
|
|
||||||
|
|
@ -92,6 +92,6 @@ SYMBOL: twidth
|
||||||
|
|
||||||
] with-text
|
] with-text
|
||||||
|
|
||||||
"extra/pdf/test/font_test.pdf" resource-path save-to-file
|
"font_test.pdf" temp-file save-to-file
|
||||||
|
|
||||||
] with-pdf
|
] 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.
|
! Copyright (C) 2007 Chris Double.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
IN: peg.search.tests
|
||||||
|
|
||||||
{ V{ 123 456 } } [
|
{ V{ 123 456 } } [
|
||||||
|
|
|
||||||
|
|
@ -54,7 +54,6 @@ IN: random-tester.safe-words
|
||||||
|
|
||||||
: method-words
|
: method-words
|
||||||
{
|
{
|
||||||
method-def
|
|
||||||
forget-word
|
forget-word
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -84,6 +84,7 @@ IN: smtp.tests
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
[
|
[
|
||||||
|
"localhost" smtp-host set
|
||||||
4321 smtp-port set
|
4321 smtp-port set
|
||||||
|
|
||||||
"Hi guys\nBye guys"
|
"Hi guys\nBye guys"
|
||||||
|
|
|
||||||
|
|
@ -21,6 +21,7 @@ TYPEDEF: ulong size_t
|
||||||
|
|
||||||
: MAP_FAILED -1 <alien> ; inline
|
: MAP_FAILED -1 <alien> ; inline
|
||||||
|
|
||||||
|
: ESRCH 3 ; inline
|
||||||
: EEXIST 17 ; inline
|
: EEXIST 17 ; inline
|
||||||
|
|
||||||
! ! ! Unix functions
|
! ! ! 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