[ { + } ] [ \ 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
[ ] [
! 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
: 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
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' )
: 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
! "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
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" } ;
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
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
get-ldp get-message next-message msgtype result-type
] with-bind
+] drop
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
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
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
] with-text
- "extra/pdf/test/font_test.pdf" resource-path save-to-file
+ "font_test.pdf" temp-file save-to-file
] with-pdf
+++ /dev/null
-%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\r
-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\r
-0000000015 00000 n\r
-0000000064 00000 n\r
-0000000123 00000 n\r
-0000000196 00000 n\r
-0000000518 00000 n\r
-0000002089 00000 n\r
-0000002109 00000 n\r
-0000002207 00000 n\r
-0000002303 00000 n\r
-0000002404 00000 n\r
-0000002509 00000 n\r
-0000002618 00000 n\r
-0000002722 00000 n\r
-0000002829 00000 n\r
-0000002940 00000 n\r
-0000003041 00000 n\r
-0000003141 00000 n\r
-0000003243 00000 n\r
-0000003349 00000 n\r
-0000003417 00000 n\r
-trailer
-<<
-/Root 1 0 R
-/Info 3 0 R
-/Size 21
->>
-startxref
-3491
-%%EOF
! 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 } } [
: method-words
{
- method-def
forget-word
} ;
[ ] [
[
+ "localhost" smtp-host set
4321 smtp-port set
"Hi guys\nBye guys"
send-simple-message
] with-scope
-] unit-test
\ No newline at end of file
+] unit-test
: MAP_FAILED -1 <alien> ; inline
+: ESRCH 3 ; inline
: EEXIST 17 ; inline
! ! ! Unix functions
+++ /dev/null
-Chris Double
-Slava Pestov
+++ /dev/null
-! 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
+++ /dev/null
-Chris Double
+++ /dev/null
-! 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 ;
+++ /dev/null
-Chris Double
+++ /dev/null
-! 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
projects / factor.git / commitdiff