factor/libs/httpd/examples/cont-examples.factor

124 lines
4.1 KiB
Factor
Raw Permalink Normal View History

! 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
IN: cont-examples
USE: cont-responder
USE: hashtables
USE: html
USE: kernel
USE: io
USE: html
USE: strings
USE: math
USE: namespaces
USE: prettyprint
USE: tools
USE: sequences
: 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>
] html-document
2006-07-24 19:45:37 -04:00
] show 2drop ;
: display-get-name-page ( -- name )
#! Display a page prompting for input of a name and return that name.
2006-07-24 19:45:37 -04:00
[
"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>
] html-document
] show "name" swap hash ;
: 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>
2006-07-24 19:45:37 -04:00
<li> "Test responder2" [ test-cont-responder2 ] quot-href </li>
</ol>
] 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 unit [ f ] swap append [ 1 + counter-example ] append quot-href
"--" over unit [ f ] swap append [ 1 - counter-example ] append quot-href
drop
] 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
] html-document
] show
drop ;
! Install the examples
2006-01-20 02:17:37 -05:00
"counter1" [ drop 0 counter-example ] install-cont-responder
"counter2" [ drop counter-example2 ] install-cont-responder
"test1" [ test-cont-responder ] install-cont-responder
2006-01-20 02:17:37 -05:00
"test2" [ drop test-cont-responder2 ] install-cont-responder
"test3" [ drop test-cont-responder3 ] install-cont-responder