libs/httpd/examples/cont-examples.factor

   1 ! Copyright (C) 2004 Chris Double.
   2 !
   3 ! Redistribution and use in source and binary forms, with or without
   4 ! modification, are permitted provided that the following conditions are met:
   5 !
   6 ! 1. Redistributions of source code must retain the above copyright notice,
   7 !    this list of conditions and the following disclaimer.
   8 !
   9 ! 2. Redistributions in binary form must reproduce the above copyright notice,
  10 !    this list of conditions and the following disclaimer in the documentation
  11 !    and/or other materials provided with the distribution.
  12 !
  13 ! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
  14 ! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
  15 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  16 ! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  17 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  18 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
  19 ! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  20 ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  21 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
  22 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  23 !
  24 ! Simple test applications
  25 IN: cont-examples
  26 USE: cont-responder
  27 USE: hashtables
  28 USE: html
  29 USE: kernel
  30 USE: io
  31 USE: html
  32 USE: strings
  33 USE: math
  34 USE: namespaces
  35 USE: prettyprint
  36 USE: tools
  37 USE: sequences
  38
  39 : display-page ( title -- )
  40   #! Display a page with some text to test the cont-responder.
  41   #! The page has a link to the 'next' continuation.
  42   [
  43     <h1> over write </h1>
  44     swap [
  45       <a =href a> "Next" write </a>
  46     ] html-document
  47   ] show 2drop ;
  48
  49 : display-get-name-page ( -- name )
  50   #! Display a page prompting for input of a name and return that name.
  51   [
  52     "Enter your name" [
  53       <h1> swap write </h1>
  54       <form "post" =method =action form>
  55         "Name: " write
  56         <input "text" =type "name" =name "20" =size input/>
  57         <input "submit" =type "Ok" =value input/>
  58       </form>
  59     ] html-document
  60   ] show "name" swap hash ;
  61
  62 : test-cont-responder ( - )
  63   #! Test the cont-responder responder by displaying a few pages in a row.
  64   "Page one" display-page
  65   "Hello " display-get-name-page append display-page
  66   "Page three" display-page ;
  67
  68 : test-cont-responder2 ( - )
  69   #! Test the cont-responder responder by displaying a few pages in a loop.
  70   [ "one" "two" "three" "four" ] [ display-page ]  each
  71   "Done!" display-page  ;
  72
  73 : test-cont-responder3 ( - )
  74   #! Test the quot-href word by displaying a menu of the current
  75   #! test words. Note that we use show-final as we don't link to a 'next' page.
  76   [
  77     "Menu" [
  78       <h1> "Menu" write </h1>
  79       <ol>
  80         <li> "Test responder1" [ test-cont-responder ] quot-href </li>
  81         <li> "Test responder2" [ test-cont-responder2 ] quot-href </li>
  82       </ol>
  83     ] html-document
  84   ] show-final ;
  85
  86 : counter-example ( count - )
  87   #! Display a counter which can be incremented or decremented
  88   #! using anchors.
  89   #!
  90   #! Don't need the original alist
  91   [
  92     #! And we don't need the 'url' argument
  93     drop
  94     "Counter: " over unparse append [
  95       dup <h2> unparse write </h2>
  96       "++" over unit [ f ] swap append [ 1 + counter-example ] append quot-href
  97       "--" over unit [ f ] swap append [ 1 - counter-example ] append quot-href
  98       drop
  99     ] html-document
 100   ] show drop ;
 101
 102 : counter-example2 ( - )
 103   #! Display a counter which can be incremented or decremented
 104   #! using anchors.
 105   #!
 106   0 "counter" set
 107   [
 108     #! We don't need the 'url' argument
 109     drop
 110     "Counter: " "counter" get unparse append [
 111       <h2> "counter" get unparse write </h2>
 112       "++" [ "counter" get 1 + "counter" set ] quot-href
 113       "--" [ "counter" get 1 - "counter" set ] quot-href
 114     ] html-document
 115   ] show
 116   drop ;
 117
 118 ! Install the examples
 119 "counter1" [ drop 0 counter-example ] install-cont-responder
 120 "counter2" [ drop counter-example2 ] install-cont-responder
 121 "test1" [ test-cont-responder ] install-cont-responder
 122 "test2" [ drop test-cont-responder2 ] install-cont-responder
 123 "test3" [ drop test-cont-responder3 ] install-cont-responder