From 688cbfaafacf383374b162d6163ca957f7b84032 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 11 Apr 2008 14:46:11 +1200 Subject: [PATCH 01/23] Delocalise grow-lr --- extra/peg/peg.factor | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 7390c15684..164f7c9ee9 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -100,21 +100,21 @@ C: peg-head : setup-growth ( h p -- ) pos set dup involved-set>> clone >>eval-set drop ; -:: (grow-lr) ( h p r m -- ) - h p setup-growth - r eval-rule - dup m stop-growth? [ - drop +: (grow-lr) ( h p r m -- ) + >r >r [ setup-growth ] 2keep r> r> + >r dup eval-rule r> swap + dup pick stop-growth? [ + 4drop drop ] [ - m update-m - h p r m (grow-lr) + over update-m + (grow-lr) ] if ; inline -:: grow-lr ( h p r m -- ast ) - h p heads get set-at - h p r m (grow-lr) - p heads get delete-at - m pos>> pos set m ans>> +: grow-lr ( h p r m -- ast ) + >r >r [ heads get set-at ] 2keep r> r> + pick over >r >r (grow-lr) r> r> + swap heads get delete-at + dup pos>> pos set ans>> ; inline :: (setup-lr) ( r l s -- ) From 9a734b74cee2e2e99f65930b37ca18ad9efb2a7e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Apr 2008 14:48:42 -0500 Subject: [PATCH 02/23] Update readme --- README.txt | 109 ++++++++++++++++++----------------------------------- 1 file changed, 36 insertions(+), 73 deletions(-) diff --git a/README.txt b/README.txt index 12dade5ba1..dd7c3e7ad3 100755 --- a/README.txt +++ b/README.txt @@ -6,7 +6,6 @@ implementation. It is not an introduction to the language itself. * Contents -- Platform support - Compiling the Factor VM - Libraries needed for compilation - Bootstrapping the Factor image @@ -19,80 +18,50 @@ implementation. It is not an introduction to the language itself. - Source organization - Community -* Platform support - -Factor supports the following platforms: - - Linux/x86 - Linux/AMD64 - Linux/PowerPC - Linux/ARM - Mac OS X/x86 - Mac OS X/PowerPC - FreeBSD/x86 - FreeBSD/AMD64 - OpenBSD/x86 - OpenBSD/AMD64 - Solaris/x86 - Solaris/AMD64 - MS Windows/x86 (XP and above) - MS Windows CE/ARM - -Please donate time or hardware if you wish to see Factor running on -other platforms. In particular, we are interested in: - - Windows/AMD64 - Mac OS X/AMD64 - Solaris/UltraSPARC - Linux/MIPS - * Compiling the Factor VM The Factor runtime is written in GNU C99, and is built with GNU make and gcc. -Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc -3.3 or earlier. If you are using gcc 4.3, you might get an unusable -Factor binary unless you add 'SITE_CFLAGS=-fno-forward-propagate' to the -command-line arguments for make. +Factor supports various platforms. For an up-to-date list, see +. -Run 'make' (or 'gmake' on *BSD) with no parameters to see a list of -targets and build options. Then run 'make' with the appropriate target -for your platform. +Factor requires gcc 3.4 or later. + +On x86, Factor /will not/ build using gcc 3.3 or earlier. + +If you are using gcc 4.3, you might get an unusable Factor binary unless +you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line +arguments for make. + +Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM. Compilation will yield an executable named 'factor' on Unix, -'factor-nt.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE. +'factor.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE. * Libraries needed for compilation -For X11 support, you need recent development libraries for libc, Freetype, -X11, OpenGL and GLUT. On a Debian-derived Linux distribution (like Ubuntu), -you can use the line +For X11 support, you need recent development libraries for libc, +Freetype, X11, OpenGL and GLUT. On a Debian-derived Linux distribution +(like Ubuntu), you can use the line -sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev + sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev -to grab everything (if you're on a non-debian-derived distro please tell us -what the equivalent command is on there and it can be added :) +to grab everything (if you're on a non-debian-derived distro please tell +us what the equivalent command is on there and it can be added). * Bootstrapping the Factor image -The boot images are no longer included with the Factor distribution -due to size concerns. Instead, download a boot image from: - - http://factorcode.org/images/ - Once you have compiled the Factor runtime, you must bootstrap the Factor system using the image that corresponds to your CPU architecture. -Once you download the right image, bootstrap the system with the +Boot images can be obtained from . + +Once you download the right image, bootstrap Factor with the following command line: ./factor -i=boot..image -Or this command for Mac OS X systems: - -./Factor.app/Contents/MacOS/factor -i=boot..image - Bootstrap can take a while, depending on your system. When the process completes, a 'factor.image' file will be generated. Note that this image is both CPU and OS-specific, so in general cannot be shared between @@ -122,9 +91,8 @@ The latter keeps the terminal listener running. * Running Factor on Mac OS X - Cocoa UI -On Mac OS X 10.4 and later, a Cocoa UI is available in addition to the -terminal listener. If you are using Mac OS X 10.3, you can only run the -X11 UI, as documented in the next section. +On Mac OS X, a Cocoa UI is available in addition to the terminal +listener. The 'factor' executable runs the terminal listener: @@ -136,17 +104,16 @@ contains factor.image and the library sources. * Running Factor on Mac OS X - X11 UI -The X11 UI is available on Mac OS X, however its use is not recommended -since it does not integrate with the host OS. However, if you are -running Mac OS X 10.3, it is your only choice. +The X11 UI is also available on Mac OS X, however its use is not +recommended since it does not integrate with the host OS. When compiling Factor, pass the X11=1 parameter: - make macosx-ppc X11=1 + make X11=1 Then bootstrap with the following switches: - ./factor -i=boot.ppc.image -ui-backend=x11 + ./factor -i=boot..image -ui-backend=x11 Now if $DISPLAY is set, running ./factor will start the UI. @@ -155,40 +122,36 @@ Now if $DISPLAY is set, running ./factor will start the UI. If you did not download the binary package, you can bootstrap Factor in the command prompt: - factor-nt.exe -i=boot.x86.32.image + factor.exe -i=boot..image Once bootstrapped, double-clicking factor.exe starts the Factor UI. To run the listener in the command prompt: - factor-nt.exe -run=listener + factor.exe -run=listener * The Factor FAQ -The Factor FAQ lives online at http://factorcode.org/faq.fhtml +The Factor FAQ is available at . * Command line usage -The Factor VM supports a number of command line switches. To read -command line usage documentation, either enter the following in the UI -listener: +Factor supports a number of command line switches. To read command line +usage documentation, enter the following in the UI listener: "command-line" about * Source organization -The following two directories are managed by the module system; consult -the documentation for details: +The Factor source tree is organized as follows: + build-support/ - scripts used for compiling Factor core/ - Factor core library and compiler extra/ - more libraries - -The following directories contain additional files: - - misc/ - editor modes, icons, etc - vm/ - sources for the Factor runtime, written in C fonts/ - TrueType fonts used by UI + misc/ - editor modes, icons, etc unmaintained/ - unmaintained contributions, please help! + vm/ - sources for the Factor VM, written in C * Community From 5fda0ed040cdf193efeae89915e0c87a8110ae66 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Apr 2008 03:54:02 -0500 Subject: [PATCH 03/23] Throw error if superclass is not a tuple class --- core/classes/tuple/tuple-tests.factor | 3 +++ core/classes/tuple/tuple.factor | 11 ++++++++++- core/debugger/debugger.factor | 5 ++++- 3 files changed, 17 insertions(+), 2 deletions(-) diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 2575570d2f..94172a01ef 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -538,3 +538,6 @@ TUPLE: another-forget-accessors-test ; ] with-string-writer empty? ] with-variable ] unit-test + +! Missing error check +[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index aa8ef6cdb7..8c7b5437bd 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -58,6 +58,8 @@ PRIVATE> : all-slot-names ( class -- slots ) superclasses [ slot-names ] map concat \ class prefix ; +ERROR: bad-superclass class ; + GENERIC# define-tuple-class 2 ( class superclass slots -- ) M: word define-tuple-class + over check-superclass define-new-tuple-class ; M: tuple-class define-tuple-class 3dup tuple-class-unchanged? - [ 3dup redefine-tuple-class ] unless + [ over check-superclass 3dup redefine-tuple-class ] unless 3drop ; : define-error-class ( class superclass slots -- ) diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index dea1904e92..827a5c4e8d 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -215,7 +215,10 @@ M: check-method summary drop "Invalid parameters for create-method" ; M: no-tuple-class summary - drop "Invalid class for define-constructor" ; + drop "BOA constructors can only be defined for tuple classes" ; + +M: bad-superclass summary + drop "Tuple classes can only inherit from other tuple classes" ; M: no-cond summary drop "Fall-through in cond" ; From 5c94bd00b0b7f0614100c412658f0555989f830c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Apr 2008 03:54:17 -0500 Subject: [PATCH 04/23] Change unit test --- core/strings/strings-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 3ae7b92a5f..961c8cdf6e 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -96,7 +96,7 @@ unit-test [ ] [ [ 4 [ - 100 [ drop "obdurak" ] map + 100 [ drop "obdurak" clone ] map gc dup [ 1234 0 rot set-string-nth From 31e6604a68e4d3a0e7d4eb8930a2d9ebd4995384 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Apr 2008 03:54:34 -0500 Subject: [PATCH 05/23] Inheritance-friendly lexer type --- core/parser/parser.factor | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 13f768a810..0f7c1410ab 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -17,9 +17,14 @@ TUPLE: lexer text line line-text line-length column ; 0 >>column drop ; +: construct-lexer ( text class -- lexer ) + construct-empty + 0 >>line + swap >>text + dup next-line ; inline + : ( text -- lexer ) - 0 { set-lexer-text set-lexer-line } lexer construct - dup next-line ; + lexer construct-lexer ; : location ( -- loc ) file get lexer get lexer-line 2dup and From 421085c516c04ea5a9e656bf318581ec503996dc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Apr 2008 03:54:43 -0500 Subject: [PATCH 06/23] Fix inference error --- extra/db/mysql/mysql.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/db/mysql/mysql.factor b/extra/db/mysql/mysql.factor index dc7225514e..f8700debaa 100755 --- a/extra/db/mysql/mysql.factor +++ b/extra/db/mysql/mysql.factor @@ -9,7 +9,7 @@ TUPLE: mysql-statement ; TUPLE: mysql-result-set ; M: mysql-db db-open ( mysql-db -- ) - drop ; + ; M: mysql-db dispose ( mysql-db -- ) mysql-db-handle mysql_close ; From e31f03db4a5168d6b0986ff8803f002829e16376 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Apr 2008 03:54:51 -0500 Subject: [PATCH 07/23] Put farkup words in private --- extra/farkup/farkup.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor index 142fc5de6c..f876c9569b 100755 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -6,6 +6,8 @@ io.streams.string html peg.parsers html.elements sequences.deep unicode.categories ; IN: farkup +" swap "

" 3array ] unless ] action ; +PRIVATE> + PEG: parse-farkup ( -- parser ) [ list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl , From 4cdf0771cace849560db0f6aab17d18a3e3d858a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Apr 2008 04:34:26 -0500 Subject: [PATCH 08/23] Some minor improvements to http.server --- extra/http/http-tests.factor | 25 +- extra/http/server/auth/login/Untitled-13 | 7 + extra/http/server/auth/login/login.factor | 43 ++- .../auth/providers/assoc/assoc-tests.factor | 2 +- .../server/auth/providers/db/db-tests.factor | 2 +- .../server/auth/providers/providers.factor | 2 - .../server/components/components-tests.factor | 33 +- .../http/server/components/components.factor | 309 +++++++++--------- .../server/components/farkup/farkup.factor | 17 +- extra/http/server/db/db.factor | 4 +- extra/http/server/forms/forms.factor | 48 +++ extra/http/server/server.factor | 10 +- extra/http/server/sessions/sessions.factor | 19 +- .../http/server/templating/fhtml/fhtml.factor | 21 +- 14 files changed, 314 insertions(+), 228 deletions(-) create mode 100644 extra/http/server/auth/login/Untitled-13 create mode 100644 extra/http/server/forms/forms.factor diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 2e7370bc39..d1ffce721d 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -1,5 +1,6 @@ USING: http tools.test multiline tuple-syntax -io.streams.string kernel arrays splitting sequences ; +io.streams.string kernel arrays splitting sequences +assocs io.sockets ; IN: http.tests [ "hello%20world" ] [ "hello world" url-encode ] unit-test @@ -136,10 +137,12 @@ io.encodings.ascii ; [ ] [ [ - - [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>display - "quit" add-responder - "extra/http/test" resource-path >>default + + [ stop-server "text/html" [ "Goodbye" write ] >>body ] >>display + "quit" add-responder + + "extra/http/test" resource-path >>default + "nested" add-responder main-responder set [ 1237 httpd ] "HTTPD test" spawn drop @@ -148,7 +151,17 @@ io.encodings.ascii ; [ t ] [ "extra/http/test/foo.html" resource-path ascii file-contents - "http://localhost:1237/foo.html" http-get = + "http://localhost:1237/nested/foo.html" http-get = +] unit-test + +! Try with a slightly malformed request +[ t ] [ + "localhost" 1237 ascii [ + "GET nested HTTP/1.0\r\n" write flush + "\r\n" write flush + readln drop + read-header USE: prettyprint + ] with-stream dup . "location" swap at "/" head? ] unit-test [ "Goodbye" ] [ diff --git a/extra/http/server/auth/login/Untitled-13 b/extra/http/server/auth/login/Untitled-13 new file mode 100644 index 0000000000..ddf16405a6 --- /dev/null +++ b/extra/http/server/auth/login/Untitled-13 @@ -0,0 +1,7 @@ +hidden, how do we handle this? + +dan's delegation is the obvious solution. + +but... we have that ugly hack for integers there... + +i have hidden string, hidden username... hmmm.... diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 89984b0e84..4f04a1ff9b 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -1,20 +1,29 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors quotations assocs kernel splitting -base64 html.elements io combinators http.server -http.server.auth.providers http.server.auth.providers.null -http.server.actions http.server.components http.server.sessions -http.server.templating.fhtml http.server.validators -http.server.auth http sequences io.files namespaces hashtables +base64 io combinators sequences io.files namespaces hashtables fry io.sockets arrays threads locals qualified continuations -destructors ; +destructors + +html.elements +http +http.server +http.server.auth +http.server.auth.providers +http.server.auth.providers.null +http.server.actions +http.server.components +http.server.forms +http.server.sessions +http.server.templating.fhtml +http.server.validators ; IN: http.server.auth.login QUALIFIED: smtp SYMBOL: post-login-url SYMBOL: login-failed? -TUPLE: login users ; +TUPLE: login < dispatcher users ; : users login get users>> ; @@ -130,7 +139,7 @@ SYMBOL: user-exists? successful-login - login get responder>> init-user-profile + login get default>> responder>> init-user-profile ] >>submit ] ; @@ -178,7 +187,7 @@ SYMBOL: previous-page "password" value uid users check-login [ login-failed? on validation-failed ] unless - "new-password" value set-password + "new-password" value >>password ] unless "realname" value >>realname @@ -269,7 +278,8 @@ SYMBOL: lost-password-from : "new-password"
"resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template - "username" + "username" + hidden >>renderer t >>required add-field "new-password" @@ -278,7 +288,8 @@ SYMBOL: lost-password-from "verify-password" t >>required add-field - "ticket" + "ticket" + hidden >>renderer t >>required add-field ; @@ -342,22 +353,22 @@ C: protected "login" f ; M: protected call-responder ( path responder -- response ) - logged-in-user sget [ - dup save-user-after + logged-in-user sget dup [ + save-user-after request get request-url previous-page sset responder>> call-responder ] [ - 2drop + 3drop request get method>> { "GET" "HEAD" } member? [ show-login-page ] [ <400> ] if ] if ; M: login call-responder ( path responder -- response ) dup login set - delegate call-responder ; + call-next-method ; : ( responder -- auth ) - login + login new-dispatcher swap >>default "login" add-responder "logout" add-responder diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor index f99e4d3d2e..a8f17d6f5d 100755 --- a/extra/http/server/auth/providers/assoc/assoc-tests.factor +++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor @@ -26,7 +26,7 @@ namespaces accessors kernel ; [ t ] [ "user" get >boolean ] unit-test -[ ] [ "user" get "fdasf" set-password drop ] unit-test +[ ] [ "user" get "fdasf" >>password drop ] unit-test [ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor index 340e1bb35d..6daddac304 100755 --- a/extra/http/server/auth/providers/db/db-tests.factor +++ b/extra/http/server/auth/providers/db/db-tests.factor @@ -31,7 +31,7 @@ users-in-db "provider" set [ t ] [ "user" get >boolean ] unit-test - [ ] [ "user" get "fdasf" set-password drop ] unit-test + [ ] [ "user" get "fdasf" >>password drop ] unit-test [ ] [ "user" get "provider" get update-user ] unit-test diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor index eda3babf0f..6674a26dbc 100755 --- a/extra/http/server/auth/providers/providers.factor +++ b/extra/http/server/auth/providers/providers.factor @@ -17,8 +17,6 @@ GENERIC: new-user ( user provider -- user/f ) : check-login ( password username provider -- user/f ) get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ; -: set-password ( user password -- user ) >>password ; - ! Password recovery support :: issue-ticket ( email username provider -- user/f ) diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor index d372865b7e..3caeda1c9a 100755 --- a/extra/http/server/components/components-tests.factor +++ b/extra/http/server/components/components-tests.factor @@ -1,7 +1,10 @@ IN: http.server.components.tests -USING: http.server.components http.server.validators -namespaces tools.test kernel accessors -tuple-syntax mirrors http.server.actions ; +USING: http.server.components http.server.forms +http.server.validators namespaces tools.test kernel accessors +tuple-syntax mirrors http.server.actions +io.streams.string io.streams.null ; + +\ render-edit must-infer validation-failed? off @@ -99,11 +102,31 @@ TUPLE: test-tuple text number more-text ; "123" "n" get validate value>> ] unit-test - [ ] [ "n" get t >>integer drop ] unit-test + [ ] [ "i" "i" set ] unit-test [ 3 ] [ - "3" "n" get validate + "3" "i" get validate ] unit-test + + [ t ] [ + "3.9" "i" get validate validation-error? + ] unit-test + + H{ } clone values set + + [ ] [ 3 "i" set-value ] unit-test + + [ "3" ] [ [ "i" get render-view ] with-string-writer ] unit-test + + [ ] [ [ "i" get render-edit ] with-null-stream ] unit-test + + [ ] [ "t" "t" set ] unit-test + + [ ] [ "hello world" "t" set-value ] unit-test + + [ ] [ [ "t" get render-edit ] with-null-stream ] unit-test ] with-scope [ t ] [ "wake up sheeple" dup "n" validate = ] unit-test + +[ ] [ "password" "p" set ] unit-test diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index bd95bf4407..4b440089ad 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -2,23 +2,47 @@ ! See http://factorcode.org/license.txt for BSD license. USING: html.elements http.server.validators accessors namespaces kernel io math.parser assocs classes words classes.tuple arrays -sequences io.files http.server.templating.fhtml -http.server.actions splitting mirrors hashtables fry +sequences splitting mirrors hashtables fry combinators continuations math ; IN: http.server.components +! Renderer protocol +GENERIC: render-view* ( value renderer -- ) +GENERIC: render-edit* ( value id renderer -- ) + +TUPLE: field type ; + +C: field + +M: field render-view* drop write ; + +M: field render-edit* + > =type [ =id ] [ =name ] bi =value input/> ; + +: render-error ( message -- ) + write ; + +TUPLE: hidden < field ; + +: hidden ( -- renderer ) T{ hidden f "hidden" } ; inline + +M: hidden render-view* 2drop ; + +! Component protocol SYMBOL: components -TUPLE: component id required default ; +TUPLE: component id required default renderer ; : component ( name -- component ) dup components get at [ ] [ "No such component: " prepend throw ] ?if ; +GENERIC: init ( component -- component ) + +M: component init ; + GENERIC: validate* ( value component -- result ) -GENERIC: render-view* ( value component -- ) -GENERIC: render-edit* ( value component -- ) -GENERIC: render-error* ( reason value component -- ) +GENERIC: component-string ( value component -- string ) SYMBOL: values @@ -26,6 +50,41 @@ SYMBOL: values : set-value values get set-at ; +: blank-values H{ } clone values set ; + +: from-tuple values set ; + +: values-tuple values get mirror-object ; + +: render-view ( component -- ) + [ id>> value ] [ component-string ] [ renderer>> ] tri + render-view* ; + +> ] [ renderer>> ] bi render-edit* ; + +: render-edit-error ( component -- ) + [ id>> value ] keep + [ [ value>> ] dip render-edit-string ] + [ drop reason>> render-error ] 2bi ; + +: value-or-default ( component -- value ) + [ id>> value ] [ default>> ] bi or ; + +: render-edit-value ( component -- ) + [ value-or-default ] + [ component-string ] + [ render-edit-string ] + tri ; + +PRIVATE> + +: render-edit ( component -- ) + dup id>> value validation-error? + [ render-edit-error ] [ render-edit-value ] if ; + : validate ( value component -- result ) '[ , @@ -36,206 +95,130 @@ SYMBOL: values ] [ validate* ] if ] with-validator ; -: render-view ( component -- ) - [ id>> value ] [ render-view* ] bi ; - -: render-error ( error -- ) - write ; - -: render-edit ( component -- ) - dup id>> value dup validation-error? [ - [ reason>> ] [ value>> ] bi rot render-error* - ] [ - swap [ default>> or ] keep render-edit* - ] if ; - -: ( id class -- component ) - \ component construct-empty - swap construct-delegate - swap >>id ; inline - -! Forms -TUPLE: form view-template edit-template components ; - -: ( id -- form ) - form - V{ } clone >>components ; - -: add-field ( form component -- form ) - dup id>> pick components>> set-at ; - -: with-form ( form quot -- ) - >r components>> components r> with-variable ; inline - -: set-defaults ( form -- ) - [ - components get [ - swap values get [ - swap default>> or - ] change-at - ] assoc-each - ] with-form ; - -: view-form ( form -- ) - dup view-template>> '[ , run-template ] with-form ; - -: edit-form ( form -- ) - dup edit-template>> '[ , run-template ] with-form ; - -: validate-param ( id component -- ) - [ [ params get at ] [ validate ] bi* ] - [ drop set-value ] 2bi ; - -: (validate-form) ( form -- error? ) - [ - validation-failed? off - components get [ validate-param ] assoc-each - validation-failed? get - ] with-form ; - -: validate-form ( form -- ) - (validate-form) [ validation-failed ] when ; - -: blank-values H{ } clone values set ; - -: from-tuple values set ; - -: values-tuple values get mirror-object ; - -! ! ! -! Canned components: for simple applications and prototyping -! ! ! - -: render-input ( value component type -- ) - > [ =id ] [ =name ] bi - =value - input/> ; - -! Hidden fields -TUPLE: hidden ; - -: ( component -- component ) - hidden construct-delegate ; - -M: hidden render-view* - 2drop ; - -M: hidden render-edit* - >r dup number? [ number>string ] when r> - "hidden" render-input ; +: new-component ( id class renderer -- component ) + swap construct-empty + swap >>renderer + swap >>id + init ; inline ! String input fields -TUPLE: string min-length max-length ; +TUPLE: string < component one-line min-length max-length ; -: ( id -- component ) string ; +: new-string ( id class -- component ) + "text" new-component + t >>one-line ; inline + +: ( id -- component ) + string new-string ; M: string validate* - [ v-one-line ] [ - [ min-length>> [ v-min-length ] when* ] - [ max-length>> [ v-max-length ] when* ] - bi - ] bi* ; + [ one-line>> [ v-one-line ] when ] + [ min-length>> [ v-min-length ] when* ] + [ max-length>> [ v-max-length ] when* ] + tri ; -M: string render-view* - drop write ; - -M: string render-edit* - "text" render-input ; - -M: string render-error* - "text" render-input render-error ; +M: string component-string + drop ; ! Username fields -TUPLE: username ; +TUPLE: username < string ; + +M: username init + 2 >>min-length + 20 >>max-length ; : ( id -- component ) - username construct-delegate - 2 >>min-length - 20 >>max-length ; + username new-string ; M: username validate* - delegate validate* v-one-word ; + call-next-method v-one-word ; ! E-mail fields -TUPLE: email ; +TUPLE: email < string ; : ( id -- component ) - email construct-delegate + email new-string 5 >>min-length 60 >>max-length ; M: email validate* - delegate validate* dup empty? [ v-email ] unless ; + call-next-method dup empty? [ v-email ] unless ; + +! Don't send passwords back to the user +TUPLE: password-renderer < field ; + +: password-renderer T{ password-renderer f "password" } ; + +: blank-password >r >r drop "" r> r> ; + +M: password-renderer render-edit* + blank-password call-next-method ; ! Password fields -TUPLE: password ; +TUPLE: password < string ; + +M: password init + 6 >>min-length + 60 >>max-length ; : ( id -- component ) - password construct-delegate - 6 >>min-length - 60 >>max-length ; + password new-string + password-renderer >>renderer ; M: password validate* - delegate validate* v-one-word ; - -M: password render-edit* - >r drop f r> "password" render-input ; - -M: password render-error* - render-edit* render-error ; + call-next-method v-one-word ; ! Number fields -TUPLE: number min-value max-value integer ; +TUPLE: number < string min-value max-value ; -: ( id -- component ) number ; +: ( id -- component ) + number new-string ; M: number validate* [ v-number ] [ - [ integer>> [ v-integer ] when ] [ min-value>> [ v-min-value ] when* ] [ max-value>> [ v-max-value ] when* ] - tri + bi ] bi* ; -M: number render-view* - drop number>string write ; +M: number component-string + drop dup [ number>string ] when ; -M: number render-edit* - >r number>string r> "text" render-input ; +! Integer fields +TUPLE: integer < number ; -M: number render-error* - "text" render-input render-error ; +: ( id -- component ) + integer new-string ; -! Text areas -TUPLE: text ; - -: ( id -- component ) text ; - -M: text validate* drop ; - -M: text render-view* - drop write ; - -: render-textarea - ; - -M: text render-edit* - render-textarea ; - -M: text render-error* - render-textarea render-error ; +M: integer validate* + call-next-method v-integer ; ! Simple captchas -TUPLE: captcha ; +TUPLE: captcha < string ; : ( id -- component ) - captcha construct-delegate ; + captcha new-string ; M: captcha validate* drop v-captcha ; + +! Text areas +TUPLE: textarea-renderer ; + +: textarea-renderer T{ textarea-renderer } ; + +M: textarea-renderer render-view* + drop write ; + +M: textarea-renderer render-edit* + drop ; + +TUPLE: text < string ; + +: new-text ( id class -- component ) + new-string + f >>one-line + textarea-renderer >>renderer ; + +: ( id -- component ) + text new-text ; diff --git a/extra/http/server/components/farkup/farkup.factor b/extra/http/server/components/farkup/farkup.factor index 09c8471905..65e159513d 100755 --- a/extra/http/server/components/farkup/farkup.factor +++ b/extra/http/server/components/farkup/farkup.factor @@ -1,13 +1,16 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: splitting http.server.components kernel io sequences -farkup ; +USING: splitting kernel io sequences farkup accessors +http.server.components ; IN: http.server.components.farkup -TUPLE: farkup ; +TUPLE: farkup-renderer < textarea-renderer ; + +: farkup-renderer T{ farkup-renderer } ; + +M: farkup-renderer render-view* + drop string-lines "\n" join convert-farkup write ; : ( id -- component ) - farkup construct-delegate ; - -M: farkup render-view* - drop string-lines "\n" join convert-farkup write ; + + farkup-renderer >>renderer ; diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor index a0d732c1ef..a8b929bc98 100755 --- a/extra/http/server/db/db.factor +++ b/extra/http/server/db/db.factor @@ -9,8 +9,8 @@ TUPLE: db-persistence responder db params ; C: db-persistence : connect-db ( db-persistence -- ) - [ db>> ] [ params>> ] bi make-db - [ db set ] [ db-open ] [ add-always-destructor ] tri ; + [ db>> ] [ params>> ] bi make-db db-open + [ db set ] [ add-always-destructor ] bi ; M: db-persistence call-responder [ connect-db ] [ responder>> call-responder ] bi ; diff --git a/extra/http/server/forms/forms.factor b/extra/http/server/forms/forms.factor new file mode 100644 index 0000000000..cf8fd4ca8c --- /dev/null +++ b/extra/http/server/forms/forms.factor @@ -0,0 +1,48 @@ +USING: kernel accessors assocs namespaces io.files fry +http.server.actions +http.server.components +http.server.validators +http.server.templating.fhtml ; +IN: http.server.forms + +TUPLE: form < component view-template edit-template components ; + +M: form init V{ } clone >>components ; + +: ( id -- form ) + form f new-component ; + +: add-field ( form component -- form ) + dup id>> pick components>> set-at ; + +: with-form ( form quot -- ) + >r components>> components r> with-variable ; inline + +: set-defaults ( form -- ) + [ + components get [ + swap values get [ + swap default>> or + ] change-at + ] assoc-each + ] with-form ; + +: view-form ( form -- ) + dup view-template>> '[ , run-template ] with-form ; + +: edit-form ( form -- ) + dup edit-template>> '[ , run-template ] with-form ; + +: validate-param ( id component -- ) + [ [ params get at ] [ validate ] bi* ] + [ drop set-value ] 2bi ; + +: (validate-form) ( form -- error? ) + [ + validation-failed? off + components get [ validate-param ] assoc-each + validation-failed? get + ] with-form ; + +: validate-form ( form -- ) + (validate-form) [ validation-failed ] when ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index e1561bce89..8b3d6b8db1 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -105,8 +105,13 @@ SYMBOL: form-hook TUPLE: dispatcher default responders ; +: new-dispatcher ( class -- dispatcher ) + construct-empty + 404-responder get >>default + H{ } clone >>responders ; inline + : ( -- dispatcher ) - 404-responder get H{ } clone dispatcher construct-boa ; + dispatcher new-dispatcher ; : split-path ( path -- rest first ) [ CHAR: / = ] left-trim "/" split1 swap ; @@ -125,9 +130,6 @@ M: dispatcher call-responder ( path dispatcher -- response ) 2drop redirect-with-/ ] if ; -: ( class -- dispatcher ) - swap construct-delegate ; inline - TUPLE: vhost-dispatcher default responders ; : ( -- dispatcher ) diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index a3d06e8f18..0d875d255b 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -17,9 +17,10 @@ M: object init-session* drop ; TUPLE: session-manager responder sessions ; -: ( responder class -- responder' ) - >r session-manager construct-boa - r> construct-delegate ; inline +: construct-session-manager ( responder class -- responder' ) + construct-empty + >>sessions + swap >>responder ; inline SYMBOLS: session session-id session-changed? ; @@ -64,18 +65,18 @@ M: session-saver dispose [ [ session-id set ] [ session set ] bi* ] 2bi [ session-manager set ] [ responder>> call-responder ] bi ; -TUPLE: null-sessions ; +TUPLE: null-sessions < session-manager ; : - null-sessions ; + null-sessions construct-session-manager ; M: null-sessions call-responder ( path responder -- response ) H{ } clone f call-responder/session ; -TUPLE: url-sessions ; +TUPLE: url-sessions < session-manager ; : ( responder -- responder' ) - url-sessions ; + url-sessions construct-session-manager ; : session-id-key "factorsessid" ; @@ -107,10 +108,10 @@ M: url-sessions call-responder ( path responder -- response ) 2drop nip new-url-session ] if ; -TUPLE: cookie-sessions ; +TUPLE: cookie-sessions < session-manager ; : ( responder -- responder' ) - cookie-sessions ; + cookie-sessions construct-session-manager ; : current-cookie-session ( responder -- id namespace/f ) request get session-id-key get-cookie dup diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor index 6cd5c78b72..9ee3c5d4e2 100755 --- a/extra/http/server/templating/fhtml/fhtml.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -1,25 +1,22 @@ ! Copyright (C) 2005 Alex Chapman -! Copyright (C) 2006, 2007 Slava Pestov +! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: continuations sequences kernel parser namespaces io io.files io.streams.string html html.elements source-files debugger combinators math quotations generic strings splitting accessors http.server.static http.server assocs -io.encodings.utf8 fry ; +io.encodings.utf8 fry accessors ; IN: http.server.templating.fhtml : templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ; -! See apps/http-server/test/ or libs/furnace/ for template usage -! examples - ! We use a custom lexer so that %> ends a token even if not ! followed by whitespace -TUPLE: template-lexer ; +TUPLE: template-lexer < lexer ; : ( lines -- lexer ) - template-lexer construct-delegate ; + template-lexer construct-lexer ; M: template-lexer skip-word [ @@ -33,18 +30,18 @@ M: template-lexer skip-word DEFER: <% delimiter : check-<% ( lexer -- col ) - "<%" over lexer-line-text rot lexer-column start* ; + "<%" over line-text>> rot column>> start* ; : found-<% ( accum lexer col -- accum ) [ - over lexer-line-text - >r >r lexer-column r> r> subseq parsed + over line-text>> + >r >r column>> r> r> subseq parsed \ write-html parsed - ] 2keep 2 + swap set-lexer-column ; + ] 2keep 2 + >>column drop ; : still-looking ( accum lexer -- accum ) [ - dup lexer-line-text swap lexer-column tail + [ line-text>> ] [ column>> ] bi tail parsed \ print-html parsed ] keep next-line ; From 3ebb1fbdaec89999312a5145485a6a0c000af83a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Apr 2008 04:35:07 -0500 Subject: [PATCH 09/23] Remove bogus file --- extra/http/server/auth/login/Untitled-13 | 7 ------- 1 file changed, 7 deletions(-) delete mode 100644 extra/http/server/auth/login/Untitled-13 diff --git a/extra/http/server/auth/login/Untitled-13 b/extra/http/server/auth/login/Untitled-13 deleted file mode 100644 index ddf16405a6..0000000000 --- a/extra/http/server/auth/login/Untitled-13 +++ /dev/null @@ -1,7 +0,0 @@ -hidden, how do we handle this? - -dan's delegation is the obvious solution. - -but... we have that ugly hack for integers there... - -i have hidden string, hidden username... hmmm.... From 70bec926d03fae91fa1ac8f2ba9e90fa69df3de1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Apr 2008 05:07:31 -0500 Subject: [PATCH 10/23] New convention for parametrized constructors: new-* instead of construct-* --- core/alien/c-types/c-types.factor | 6 +++--- core/classes/tuple/tuple-docs.factor | 17 ++++++++++------- core/generator/registers/registers.factor | 6 +++--- core/parser/parser.factor | 6 +++--- core/prettyprint/prettyprint-docs.factor | 4 ++-- core/prettyprint/sections/sections-docs.factor | 2 +- core/prettyprint/sections/sections.factor | 18 +++++++++--------- extra/http/server/sessions/sessions.factor | 8 ++++---- .../http/server/templating/fhtml/fhtml.factor | 2 +- extra/io/monitors/monitors.factor | 2 +- .../monitors/recursive/recursive-tests.factor | 2 +- extra/io/monitors/recursive/recursive.factor | 2 +- extra/io/unix/backend/backend.factor | 2 +- extra/io/unix/epoll/epoll.factor | 2 +- extra/io/unix/kqueue/kqueue.factor | 4 ++-- extra/io/unix/linux/monitors/monitors.factor | 2 +- extra/io/unix/macosx/macosx.factor | 2 +- extra/io/unix/select/select.factor | 2 +- extra/io/windows/nt/monitors/monitors.factor | 2 +- 19 files changed, 47 insertions(+), 44 deletions(-) diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 2e5e05f6e8..c97c760695 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -18,12 +18,12 @@ boxer prep unboxer getter setter reg-class size align stack-align? ; -: construct-c-type ( class -- type ) +: new-c-type ( class -- type ) new int-regs >>reg-class ; : ( -- type ) - \ c-type construct-c-type ; + \ c-type new-c-type ; SYMBOL: c-types @@ -189,7 +189,7 @@ DEFER: >c-ushort-array TUPLE: long-long-type < c-type ; : ( -- type ) - long-long-type construct-c-type ; + long-long-type new-c-type ; M: long-long-type unbox-parameter ( n type -- ) c-type-unboxer %unbox-long-long ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 76165deb38..cdfdee9717 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -32,23 +32,23 @@ $nl "" ": add-occupant ( person vehicle -- ) occupants>> push ;" "" - ": construct-vehicle ( class -- vehicle )" + ": new-vehicle ( class -- vehicle )" " new" " V{ } clone >>occupants ;" "" "TUPLE: car < vehicle engine ;" ": ( max-speed engine -- car )" - " car construct-vehicle" + " car new-vehicle" " swap >>engine" " swap >>max-speed ;" "" "TUPLE: aeroplane < vehicle max-altitude ;" ": ( max-speed max-altitude -- aeroplane )" - " aeroplane construct-vehicle" + " aeroplane new-vehicle" " swap >>max-altitude" " swap >>max-speed ;" } -"The naming convention for parametrized constructors is " { $snippet "construct-" { $emphasis "class" } } "." ; +"The naming convention for parametrized constructors is " { $snippet "new-" { $emphasis "class" } } "." ; ARTICLE: "tuple-constructors" "Tuple constructors" "Tuples are created by calling one of two constructor primitives:" @@ -64,13 +64,16 @@ $nl { $code "TUPLE: color red green blue alpha ;" "" + "! The following two are equivalent" "C: rgba" - ": color boa ; ! identical to above" + ": color boa ;" "" + "! We can define constructors which call other constructors" ": f ;" "" - ": new ;" - ": f f f f ; ! identical to above" + "! The following two are equivalent" + ": color new ;" + ": f f f f ;" } { $subsection "parametrized-constructors" } ; diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index 454ea9c30d..627f51acc2 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -237,7 +237,7 @@ M: phantom-stack clone GENERIC: finalize-height ( stack -- ) -: construct-phantom-stack ( class -- stack ) +: new-phantom-stack ( class -- stack ) >r 0 V{ } clone r> boa ; inline : (loc) @@ -257,7 +257,7 @@ GENERIC: ( n stack -- loc ) TUPLE: phantom-datastack < phantom-stack ; : ( -- stack ) - phantom-datastack construct-phantom-stack ; + phantom-datastack new-phantom-stack ; M: phantom-datastack (loc) ; @@ -267,7 +267,7 @@ M: phantom-datastack finalize-height TUPLE: phantom-retainstack < phantom-stack ; : ( -- stack ) - phantom-retainstack construct-phantom-stack ; + phantom-retainstack new-phantom-stack ; M: phantom-retainstack (loc) ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index a9c6840c2a..7639ebaa69 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -17,14 +17,14 @@ TUPLE: lexer text line line-text line-length column ; 0 >>column drop ; -: construct-lexer ( text class -- lexer ) - construct-empty +: new-lexer ( text class -- lexer ) + new 0 >>line swap >>text dup next-line ; inline : ( text -- lexer ) - lexer construct-lexer ; + lexer new-lexer ; : location ( -- loc ) file get lexer get lexer-line 2dup and diff --git a/core/prettyprint/prettyprint-docs.factor b/core/prettyprint/prettyprint-docs.factor index 2b294115be..7cc141be22 100755 --- a/core/prettyprint/prettyprint-docs.factor +++ b/core/prettyprint/prettyprint-docs.factor @@ -60,8 +60,8 @@ $nl { $subsection short-section } { $subsection long-section } "Utilities to use when implementing sections:" -{ $subsection construct-section } -{ $subsection construct-block } +{ $subsection new-section } +{ $subsection new-block } { $subsection add-section } ; ARTICLE: "prettyprint-sections" "Prettyprinter sections" diff --git a/core/prettyprint/sections/sections-docs.factor b/core/prettyprint/sections/sections-docs.factor index bb1752b72e..ceb37c2fe4 100755 --- a/core/prettyprint/sections/sections-docs.factor +++ b/core/prettyprint/sections/sections-docs.factor @@ -78,7 +78,7 @@ HELP: section { { $snippet "overhang" } " - number of columns which must be left blank before the wrap margin for the prettyprinter to consider emitting this section as a " { $link short-section } ". Avoids lone hanging closing brackets" } } } ; -HELP: construct-section +HELP: new-section { $values { "length" integer } { "class" "a subclass of " { $link section } } { "section" section } } { $description "Creates a new section with the given length starting from " { $link position } ", advancing " { $link position } "." } ; diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor index 8a7f283fee..319e5eab65 100644 --- a/core/prettyprint/sections/sections.factor +++ b/core/prettyprint/sections/sections.factor @@ -71,7 +71,7 @@ start end start-group? end-group? style overhang ; -: construct-section ( length class -- section ) +: new-section ( length class -- section ) new position get >>start swap position [ + ] change @@ -127,7 +127,7 @@ M: object short-section? section-fits? ; TUPLE: line-break < section type ; : ( type -- section ) - 0 \ line-break construct-section + 0 \ line-break new-section swap >>type ; M: line-break short-section drop ; @@ -137,13 +137,13 @@ M: line-break long-section drop ; ! Block sections TUPLE: block < section sections ; -: construct-block ( style class -- block ) - 0 swap construct-section +: new-block ( style class -- block ) + 0 swap new-section V{ } clone >>sections swap >>style ; inline : ( style -- block ) - block construct-block ; + block new-block ; : pprinter-block ( -- block ) pprinter-stack get peek ; @@ -200,7 +200,7 @@ M: block short-section ( block -- ) TUPLE: text < section string ; : ( string style -- text ) - over length 1+ \ text construct-section + over length 1+ \ text new-section swap >>style swap >>string ; @@ -216,7 +216,7 @@ M: text long-section short-section ; TUPLE: inset < block narrow? ; : ( narrow? -- block ) - H{ } inset construct-block + H{ } inset new-block 2 >>overhang swap >>narrow? ; @@ -237,7 +237,7 @@ M: inset newline-after? drop t ; TUPLE: flow < block ; : ( -- block ) - H{ } flow construct-block ; + H{ } flow new-block ; M: flow short-section? ( section -- ? ) #! If we can make room for this entire block by inserting @@ -253,7 +253,7 @@ M: flow short-section? ( section -- ? ) TUPLE: colon < block ; : ( -- block ) - H{ } colon construct-block ; + H{ } colon new-block ; M: colon long-section short-section ; diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index 5df0888819..9e4f538583 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -17,7 +17,7 @@ M: object init-session* drop ; TUPLE: session-manager responder sessions ; -: construct-session-manager ( responder class -- responder' ) +: new-session-manager ( responder class -- responder' ) new >>sessions swap >>responder ; inline @@ -68,7 +68,7 @@ M: session-saver dispose TUPLE: null-sessions < session-manager ; : - null-sessions construct-session-manager ; + null-sessions new-session-manager ; M: null-sessions call-responder ( path responder -- response ) H{ } clone f call-responder/session ; @@ -76,7 +76,7 @@ M: null-sessions call-responder ( path responder -- response ) TUPLE: url-sessions < session-manager ; : ( responder -- responder' ) - url-sessions construct-session-manager ; + url-sessions new-session-manager ; : session-id-key "factorsessid" ; @@ -111,7 +111,7 @@ M: url-sessions call-responder ( path responder -- response ) TUPLE: cookie-sessions < session-manager ; : ( responder -- responder' ) - cookie-sessions construct-session-manager ; + cookie-sessions new-session-manager ; : current-cookie-session ( responder -- id namespace/f ) request get session-id-key get-cookie dup diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor index 9ee3c5d4e2..4a3bf38e23 100755 --- a/extra/http/server/templating/fhtml/fhtml.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -16,7 +16,7 @@ IN: http.server.templating.fhtml TUPLE: template-lexer < lexer ; : ( lines -- lexer ) - template-lexer construct-lexer ; + template-lexer new-lexer ; M: template-lexer skip-word [ diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index a9b3d414ba..863c8fc95c 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -27,7 +27,7 @@ M: monitor timeout timeout>> ; M: monitor set-timeout (>>timeout) ; -: construct-monitor ( path mailbox class -- monitor ) +: new-monitor ( path mailbox class -- monitor ) new swap >>queue swap >>path ; inline diff --git a/extra/io/monitors/recursive/recursive-tests.factor b/extra/io/monitors/recursive/recursive-tests.factor index c35401af83..44baadf39a 100644 --- a/extra/io/monitors/recursive/recursive-tests.factor +++ b/extra/io/monitors/recursive/recursive-tests.factor @@ -21,7 +21,7 @@ M: dummy-monitor dispose M: mock-io-backend (monitor) nip over exists? [ - dummy-monitor construct-monitor + dummy-monitor new-monitor dummy-monitor-created get [ 1+ ] change-i drop ] [ "Does not exist" throw diff --git a/extra/io/monitors/recursive/recursive.factor b/extra/io/monitors/recursive/recursive.factor index 8c2560f681..1b18015513 100644 --- a/extra/io/monitors/recursive/recursive.factor +++ b/extra/io/monitors/recursive/recursive.factor @@ -98,7 +98,7 @@ M: recursive-monitor dispose : ( path mailbox -- monitor ) >r (normalize-path) r> - recursive-monitor construct-monitor + recursive-monitor new-monitor H{ } clone >>children >>ready dup start-pump-thread diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 6bd3747ce3..ba4e587d13 100644 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -32,7 +32,7 @@ M: input-task io-task-container drop reads>> ; M: output-task io-task-container drop writes>> ; -: construct-mx ( class -- obj ) +: new-mx ( class -- obj ) new H{ } clone >>reads H{ } clone >>writes ; inline diff --git a/extra/io/unix/epoll/epoll.factor b/extra/io/unix/epoll/epoll.factor index 2d7ca9ba3f..db1e7086e0 100644 --- a/extra/io/unix/epoll/epoll.factor +++ b/extra/io/unix/epoll/epoll.factor @@ -13,7 +13,7 @@ TUPLE: epoll-mx < mx events ; 256 ; inline : ( -- mx ) - epoll-mx construct-mx + epoll-mx new-mx max-events epoll_create dup io-error over set-mx-fd max-events "epoll-event" over set-epoll-mx-events ; diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index 3e3ac18dd6..8e8fb0ec74 100644 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -16,7 +16,7 @@ TUPLE: kqueue-mx < mx events monitors ; 256 ; inline : ( -- mx ) - kqueue-mx construct-mx + kqueue-mx new-mx H{ } clone >>monitors kqueue dup io-error >>fd max-events "kevent" >>events ; @@ -142,7 +142,7 @@ TUPLE: vnode-monitor < monitor fd ; : ( path mailbox -- monitor ) >r [ O_RDONLY 0 open dup io-error ] keep r> - vnode-monitor construct-monitor swap >>fd + vnode-monitor new-monitor swap >>fd [ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ; M: vnode-monitor dispose diff --git a/extra/io/unix/linux/monitors/monitors.factor b/extra/io/unix/linux/monitors/monitors.factor index ee36fc82d1..58c1f0110c 100644 --- a/extra/io/unix/linux/monitors/monitors.factor +++ b/extra/io/unix/linux/monitors/monitors.factor @@ -10,7 +10,7 @@ IN: io.unix.linux.monitors TUPLE: linux-monitor < monitor wd ; : ( wd path mailbox -- monitor ) - linux-monitor construct-monitor + linux-monitor new-monitor swap >>wd ; SYMBOL: watches diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor index 60ba4c08b3..0a0aec6ab6 100644 --- a/extra/io/unix/macosx/macosx.factor +++ b/extra/io/unix/macosx/macosx.factor @@ -13,7 +13,7 @@ TUPLE: macosx-monitor < monitor handle ; ] curry each ; M:: macosx (monitor) ( path recursive? mailbox -- monitor ) - path mailbox macosx-monitor construct-monitor + path mailbox macosx-monitor new-monitor dup [ enqueue-notifications ] curry path 1array 0 0 >>handle ; diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor index facaf4d73d..9413556d4f 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -14,7 +14,7 @@ TUPLE: select-mx < mx read-fdset write-fdset ; little-endian? [ BIN: 11000 bitxor ] unless ; inline : ( -- mx ) - select-mx construct-mx + select-mx new-mx FD_SETSIZE 8 * >>read-fdset FD_SETSIZE 8 * >>write-fdset ; diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index 0dbf08d6a5..4c2277acb9 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -98,7 +98,7 @@ TUPLE: win32-monitor < monitor port ; M:: winnt (monitor) ( path recursive? mailbox -- monitor ) [ - path mailbox win32-monitor construct-monitor + path mailbox win32-monitor new-monitor path open-directory \ win32-monitor-port recursive? >>recursive >>port From 31a9954530c424e7dfb22a7da1cd80d5df5a7f8a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Apr 2008 05:19:26 -0500 Subject: [PATCH 11/23] Documentation updates and cleanups --- core/assocs/assocs-docs.factor | 9 +++++++-- core/sequences/sequences-docs.factor | 7 +------ core/sets/authors.txt | 2 ++ core/sets/sets-docs.factor | 7 +++++-- core/sets/summary.txt | 1 + core/sets/tags.txt | 1 + core/threads/threads.factor | 9 ++++++--- extra/arrays/lib/summary.txt | 1 + extra/concurrency/mailboxes/mailboxes.factor | 14 +++++--------- extra/help/handbook/handbook.factor | 3 ++- extra/sequences/lib/summary.txt | 1 + extra/sequences/next/summary.txt | 1 + extra/trees/splay/summary.txt | 2 +- 13 files changed, 34 insertions(+), 24 deletions(-) create mode 100644 core/sets/authors.txt create mode 100644 core/sets/summary.txt create mode 100644 core/sets/tags.txt create mode 100644 extra/arrays/lib/summary.txt create mode 100644 extra/sequences/lib/summary.txt create mode 100644 extra/sequences/next/summary.txt diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 687e60621e..863fdaecb3 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -76,7 +76,7 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs" { $subsection remove-all } { $subsection substitute } { $subsection substitute-here } -{ $see-also key? } ; +{ $see-also key? assoc-contains? assoc-all? "sets" } ; ARTICLE: "assocs-mutation" "Storing keys and values in assocs" "Utility operations built up from the " { $link "assocs-protocol" } ":" @@ -97,6 +97,7 @@ $nl { $subsection assoc-map } { $subsection assoc-push-if } { $subsection assoc-subset } +{ $subsection assoc-contains? } { $subsection assoc-all? } "Three additional combinators:" { $subsection cache } @@ -206,9 +207,13 @@ HELP: assoc-subset { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } } { $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ; +HELP: assoc-contains? +{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } } +{ $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ; + HELP: assoc-all? { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } } -{ $description "Applies a predicate quotation to entry in the assoc. Outputs true if the assoc yields true for each entry (which includes the case where the assoc is empty)." } ; +{ $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ; HELP: subassoc? { $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } } diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index a4696a76ae..bb3dc9337e 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -528,12 +528,7 @@ HELP: contains? HELP: all? { $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "?" "a boolean" } } -{ $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." } -{ $notes - "The implementation makes use of a well-known logical identity:" - $nl - { $snippet "P[x] for all x <==> not ((not P[x]) for some x)" } -} ; +{ $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." } ; HELP: push-if { $values { "elt" object } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "accum" "a resizable mutable sequence" } } diff --git a/core/sets/authors.txt b/core/sets/authors.txt new file mode 100644 index 0000000000..f372b574ae --- /dev/null +++ b/core/sets/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Doug Coleman diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index 01b8b8efd7..8217bb514b 100644 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -1,7 +1,9 @@ USING: kernel help.markup help.syntax sequences ; IN: sets -ARTICLE: "sets" "Set theoretic operations" +ARTICLE: "sets" "Set-theoretic operations on sequences" +"Set-theoretic operations on sequences are defined on the " { $vocab-link "sets" } " vocabulary. These operations use hashtables internally to achieve linear running time." +$nl "Remove duplicates:" { $subsection prune } "Test for duplicates:" @@ -9,7 +11,8 @@ ARTICLE: "sets" "Set theoretic operations" "Set operations on sequences:" { $subsection diff } { $subsection intersect } -{ $subsection union } ; +{ $subsection union } +{ $see-also member? memq? contains? all? "assocs-sets" } ; HELP: unique { $values { "seq" "a sequence" } { "assoc" "an assoc" } } diff --git a/core/sets/summary.txt b/core/sets/summary.txt new file mode 100644 index 0000000000..f987cc27ad --- /dev/null +++ b/core/sets/summary.txt @@ -0,0 +1 @@ +Set-theoretic operations on sequences diff --git a/core/sets/tags.txt b/core/sets/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/core/sets/tags.txt @@ -0,0 +1 @@ +collections diff --git a/core/threads/threads.factor b/core/threads/threads.factor index e15ebdf532..f99191b91f 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -56,13 +56,16 @@ mailbox variables sleep-entry ; PRIVATE> -: ( quot name -- thread ) - \ thread new +: new-thread ( quot name class -- thread ) + new swap >>name swap >>quot \ thread counter >>id >>continuation - [ ] >>exit-handler ; + [ ] >>exit-handler ; inline + +: ( quot name -- thread ) + \ thread new-thread ; : run-queue 42 getenv ; diff --git a/extra/arrays/lib/summary.txt b/extra/arrays/lib/summary.txt new file mode 100644 index 0000000000..5ecd994103 --- /dev/null +++ b/extra/arrays/lib/summary.txt @@ -0,0 +1 @@ +Non-core array words diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index 1507a36254..ac03197708 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -81,23 +81,19 @@ M: mailbox dispose : wait-for-close ( mailbox -- ) f wait-for-close-timeout ; -TUPLE: linked-error thread ; +TUPLE: linked-error error thread ; -: ( error thread -- linked ) - { set-delegate set-linked-error-thread } - linked-error construct ; +C: linked-error : ?linked dup linked-error? [ rethrow ] when ; -TUPLE: linked-thread supervisor ; +TUPLE: linked-thread < thread supervisor ; M: linked-thread error-in-thread - [ ] keep - linked-thread-supervisor mailbox-put ; + [ ] [ supervisor>> ] bi mailbox-put ; : ( quot name mailbox -- thread' ) - >r linked-thread construct-delegate r> - over set-linked-thread-supervisor ; + >r linked-thread new-thread r> >>supervisor ; : spawn-linked-to ( quot name mailbox -- thread ) [ (spawn) ] keep ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index acdbca82ee..4e6bfe4888 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -3,7 +3,7 @@ namespaces words sequences classes assocs vocabs kernel arrays prettyprint.backend kernel.private io generic math system strings sbufs vectors byte-arrays bit-arrays float-arrays quotations io.streams.byte-array io.encodings.string -classes.builtin ; +classes.builtin parser ; IN: help.handbook ARTICLE: "conventions" "Conventions" @@ -25,6 +25,7 @@ $nl { { $snippet { $emphasis "foo" } "?" } "outputs a boolean" { { $link empty? } } } { { $snippet "?" { $emphasis "foo" } } { "conditionally performs " { $snippet { $emphasis "foo" } } } { { $links ?nth } } } { { $snippet "<" { $emphasis "foo" } ">" } { "creates a new " { $snippet "foo" } } { { $link } } } + { { $snippet "new-" { $emphasis "foo" } } { "creates a new " { $snippet "foo" } ", taking some kind of parameter from the stack which determines the type of the object to be created" } { { $link new-sequence } ", " { $link new-lexer } ", " { $link new } } } { { $snippet { $emphasis "foo" } "*" } { "alternative form of " { $snippet "foo" } ", or a generic word called by " { $snippet "foo" } } { { $links at* pprint* } } } { { $snippet "(" { $emphasis "foo" } ")" } { "implementation detail word used by " { $snippet "foo" } } { { $link (clone) } } } { { $snippet "set-" { $emphasis "foo" } } { "sets " { $snippet "foo" } " to a new value" } { $links set-length } } diff --git a/extra/sequences/lib/summary.txt b/extra/sequences/lib/summary.txt new file mode 100644 index 0000000000..e389b415ca --- /dev/null +++ b/extra/sequences/lib/summary.txt @@ -0,0 +1 @@ +Non-core sequence words diff --git a/extra/sequences/next/summary.txt b/extra/sequences/next/summary.txt new file mode 100644 index 0000000000..fe5bd315de --- /dev/null +++ b/extra/sequences/next/summary.txt @@ -0,0 +1 @@ +Iteration with access to next element diff --git a/extra/trees/splay/summary.txt b/extra/trees/splay/summary.txt index e70c874e98..46391bbd28 100644 --- a/extra/trees/splay/summary.txt +++ b/extra/trees/splay/summary.txt @@ -1 +1 @@ -Splay Trees +Splay trees From 7f89cb73a16200ae7b5c0dd969dba05c998ce4e1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Apr 2008 05:27:04 -0500 Subject: [PATCH 12/23] Fix bootstrap --- core/bootstrap/primitives.factor | 18 +++++++++--------- core/classes/tuple/tuple.factor | 2 +- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 9d3c28b068..f1e41ac2b6 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -390,7 +390,7 @@ define-builtin ! Create special tombstone values "tombstone" "hashtables.private" create -"tuple" "kernel" lookup +tuple { } define-tuple-class "((empty))" "hashtables.private" create @@ -403,7 +403,7 @@ define-builtin ! Some tuple classes "hashtable" "hashtables" create -"tuple" "kernel" lookup +tuple { { { "array-capacity" "sequences.private" } @@ -424,7 +424,7 @@ define-builtin } define-tuple-class "sbuf" "sbufs" create -"tuple" "kernel" lookup +tuple { { { "string" "strings" } @@ -440,7 +440,7 @@ define-builtin } define-tuple-class "vector" "vectors" create -"tuple" "kernel" lookup +tuple { { { "array" "arrays" } @@ -456,7 +456,7 @@ define-builtin } define-tuple-class "byte-vector" "byte-vectors" create -"tuple" "kernel" lookup +tuple { { { "byte-array" "byte-arrays" } @@ -472,7 +472,7 @@ define-builtin } define-tuple-class "bit-vector" "bit-vectors" create -"tuple" "kernel" lookup +tuple { { { "bit-array" "bit-arrays" } @@ -488,7 +488,7 @@ define-builtin } define-tuple-class "float-vector" "float-vectors" create -"tuple" "kernel" lookup +tuple { { { "float-array" "float-arrays" } @@ -504,7 +504,7 @@ define-builtin } define-tuple-class "curry" "kernel" create -"tuple" "kernel" lookup +tuple { { { "object" "kernel" } @@ -525,7 +525,7 @@ define-builtin [ tuple-layout [ ] curry ] tri define "compose" "kernel" create -"tuple" "kernel" lookup +tuple { { { "object" "kernel" } diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index b2356a5200..c14205e1d9 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -188,7 +188,7 @@ M: tuple-class update-class rot tuck [ superclass = ] [ slot-names = ] 2bi* and ; : valid-superclass? ( class -- ? ) - [ tuple-class? ] [ tuple bootstrap-word eq? ] bi or ; + [ tuple-class? ] [ tuple eq? ] bi or ; : check-superclass ( superclass -- ) dup valid-superclass? [ bad-superclass ] unless drop ; From 9f0f2d0bbc0346046414b00f270c39d72d58042b Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 14 Apr 2008 22:42:45 +1200 Subject: [PATCH 13/23] peg delay parsers now infer --- extra/peg/ebnf/ebnf-tests.factor | 2 ++ extra/peg/peg.factor | 17 +++++++++++++++-- 2 files changed, 17 insertions(+), 2 deletions(-) diff --git a/extra/peg/ebnf/ebnf-tests.factor b/extra/peg/ebnf/ebnf-tests.factor index 0879ecda49..0292a88ad9 100644 --- a/extra/peg/ebnf/ebnf-tests.factor +++ b/extra/peg/ebnf/ebnf-tests.factor @@ -295,3 +295,5 @@ main = Primary { V{ V{ V{ "x" "[" "i" "]" } "[" "j" "]" } "." "y" } } [ "x[i][j].y" primary parse-result-ast ] unit-test + +'ebnf' compile must-infer diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 164f7c9ee9..8fe6664807 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -240,8 +240,21 @@ GENERIC: (compile) ( parser -- quot ) gensym tuck >>compiled 2dup parser-body 0 1 define-declared dupd "peg" set-word-prop ] if* ; +SYMBOL: delayed + +: fixup-delayed ( -- ) + #! Work through all delayed parsers and recompile their + #! words to have the correct bodies. + delayed get [ + call compiled-parser 1quotation 0 1 define-declared + ] assoc-each ; + : compile ( parser -- word ) - [ compiled-parser ] with-compilation-unit ; + [ + H{ } clone delayed [ + compiled-parser fixup-delayed + ] with-variable + ] with-compilation-unit ; : compiled-parse ( state word -- result ) swap [ execute ] with-packrat ; inline @@ -451,7 +464,7 @@ M: delay-parser (compile) ( parser -- quot ) #! For efficiency we memoize the quotation. #! This way it is run only once and the #! parser constructed once at run time. - quot>> '[ @ compile ] { } { "word" } memoize-quot '[ @ execute ] ; + quot>> gensym [ delayed get set-at ] keep 1quotation ; TUPLE: box-parser quot ; From 490d7fed0b5e342d17b8087bbbd82f695ce7ffaa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Apr 2008 06:04:01 -0500 Subject: [PATCH 14/23] Fixing minor bugs --- extra/html/html-tests.factor | 4 +++- extra/html/html.factor | 2 +- extra/serialize/serialize.factor | 2 +- extra/state-parser/state-parser.factor | 2 +- extra/xml/tests/test.factor | 2 ++ 5 files changed, 8 insertions(+), 4 deletions(-) diff --git a/extra/html/html-tests.factor b/extra/html/html-tests.factor index cac6526376..ce320ca75b 100644 --- a/extra/html/html-tests.factor +++ b/extra/html/html-tests.factor @@ -3,7 +3,9 @@ namespaces tools.test xml.writer sbufs sequences html.private ; IN: html.tests : make-html-string - [ with-html-stream ] with-string-writer ; + [ with-html-stream ] with-string-writer ; inline + +[ [ ] make-html-string ] must-infer [ ] [ 512 drop diff --git a/extra/html/html.factor b/extra/html/html.factor index 84597731d1..5c82b7f038 100755 --- a/extra/html/html.factor +++ b/extra/html/html.factor @@ -194,7 +194,7 @@ M: html-stream stream-nl ( stream -- ) ! Utilities : with-html-stream ( quot -- ) - stdio get swap with-stream* ; + stdio get swap with-stream* ; inline : xhtml-preamble "" write-html diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index 9107c0145a..bb69a8a41c 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -246,7 +246,7 @@ SYMBOL: deserialized (deserialize) ; :: (deserialize-seq) ( exemplar quot -- seq ) - deserialize-cell exemplar new + deserialize-cell exemplar new-sequence [ intern-object ] [ dup [ drop quot call ] change-each ] bi ; inline diff --git a/extra/state-parser/state-parser.factor b/extra/state-parser/state-parser.factor index cb0362609a..6a3bf1d552 100644 --- a/extra/state-parser/state-parser.factor +++ b/extra/state-parser/state-parser.factor @@ -97,7 +97,7 @@ SYMBOL: prolog-data #! advance spot to after the substring. [ [ dup slip swap dup [ get-char , ] unless - ] skip-until ] "" make nip ; + ] skip-until ] "" make nip ; inline : rest ( -- string ) [ f ] take-until ; diff --git a/extra/xml/tests/test.factor b/extra/xml/tests/test.factor index 98146136e6..72ab7b1340 100644 --- a/extra/xml/tests/test.factor +++ b/extra/xml/tests/test.factor @@ -6,6 +6,8 @@ USING: kernel xml tools.test io namespaces sequences xml.errors xml.entities continuations assocs sequences.deep ; ! This is insufficient +\ read-xml must-infer + SYMBOL: xml-file [ ] [ "extra/xml/tests/test.xml" resource-path [ file>xml ] with-html-entities xml-file set ] unit-test From 7601005ac6567b2fb32eeaf7758b96723e0488ed Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Apr 2008 07:53:54 -0500 Subject: [PATCH 15/23] Fix load, test, help failurse --- core/dlists/dlists-tests.factor | 2 +- core/sets/sets-docs.factor | 10 +++++----- extra/concurrency/combinators/combinators-tests.factor | 4 ++-- extra/concurrency/messaging/messaging-tests.factor | 4 ++-- extra/http/server/crud/crud.factor | 10 +++++++--- 5 files changed, 17 insertions(+), 13 deletions(-) diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor index c995dbb77f..b0fe2a1157 100755 --- a/core/dlists/dlists-tests.factor +++ b/core/dlists/dlists-tests.factor @@ -1,5 +1,5 @@ USING: dlists dlists.private kernel tools.test random assocs -hashtables sequences namespaces sorting debugger io prettyprint +sets sequences namespaces sorting debugger io prettyprint math ; IN: dlists.tests diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index 8217bb514b..8b6859260d 100644 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -25,14 +25,14 @@ HELP: prune { $values { "seq" "a sequence" } { "newseq" "a sequence" } } { $description "Outputs a new sequence with each distinct element of " { $snippet "seq" } " appearing only once. Elements are compared for equality using " { $link = } " and elements are ordered according to their position in " { $snippet "seq" } "." } { $examples - { $example "USING: sequences prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" } + { $example "USING: sets prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" } } ; HELP: all-unique? { $values { "seq" sequence } { "?" "a boolean" } } { $description "Tests whether a sequence contains any repeated elements." } { $example - "USING: hashtables prettyprint ;" + "USING: sets prettyprint ;" "{ 0 1 1 2 3 5 } all-unique? ." "f" } ; @@ -41,21 +41,21 @@ HELP: diff { $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } } { $description "Outputs a sequence consisting of elements present in " { $snippet "seq2" } " but not " { $snippet "seq1" } ", comparing elements for equality." } { $examples - { $example "USING: sequences prettyprint ;" "{ 1 2 3 } { 2 3 4 } diff ." "{ 4 }" } + { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } diff ." "{ 4 }" } } ; HELP: intersect { $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } } { $description "Outputs a sequence consisting of elements present in both " { $snippet "seq1" } " and " { $snippet "seq2" } "." } { $examples - { $example "USING: sequences prettyprint ;" "{ 1 2 3 } { 2 3 4 } intersect ." "{ 2 3 }" } + { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } intersect ." "{ 2 3 }" } } ; HELP: union { $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } } { $description "Outputs a sequence consisting of elements present in " { $snippet "seq1" } " and " { $snippet "seq2" } " which does not contain duplicate values." } { $examples - { $example "USING: sequences prettyprint ;" "{ 1 2 3 } { 2 3 4 } union ." "{ 1 2 3 4 }" } + { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } union ." "V{ 1 2 3 4 }" } } ; { diff intersect union } related-words diff --git a/extra/concurrency/combinators/combinators-tests.factor b/extra/concurrency/combinators/combinators-tests.factor index 0f18fcf431..731a740983 100755 --- a/extra/concurrency/combinators/combinators-tests.factor +++ b/extra/concurrency/combinators/combinators-tests.factor @@ -1,6 +1,6 @@ IN: concurrency.combinators.tests USING: concurrency.combinators tools.test random kernel math -concurrency.mailboxes threads sequences ; +concurrency.mailboxes threads sequences accessors ; [ [ drop ] parallel-each ] must-infer [ [ ] parallel-map ] must-infer @@ -11,7 +11,7 @@ concurrency.mailboxes threads sequences ; [ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test [ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ] -[ delegate "Even" = ] must-fail-with +[ error>> "Even" = ] must-fail-with [ V{ 0 3 6 9 } ] [ 10 [ 3 mod zero? ] parallel-subset ] unit-test diff --git a/extra/concurrency/messaging/messaging-tests.factor b/extra/concurrency/messaging/messaging-tests.factor index b69773f3b1..00184bac05 100755 --- a/extra/concurrency/messaging/messaging-tests.factor +++ b/extra/concurrency/messaging/messaging-tests.factor @@ -4,7 +4,7 @@ USING: kernel threads vectors arrays sequences namespaces tools.test continuations dlists strings math words match quotations concurrency.messaging concurrency.mailboxes -concurrency.count-downs ; +concurrency.count-downs accessors ; IN: concurrency.messaging.tests [ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test @@ -30,7 +30,7 @@ IN: concurrency.messaging.tests "crash" throw ] "Linked test" spawn-linked drop receive -] [ delegate "crash" = ] must-fail-with +] [ error>> "crash" = ] must-fail-with MATCH-VARS: ?from ?to ?value ; SYMBOL: increment diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor index 4893977f76..eb8ff943c7 100755 --- a/extra/http/server/crud/crud.factor +++ b/extra/http/server/crud/crud.factor @@ -1,9 +1,13 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces db.tuples math.parser +accessors fry locals hashtables +http.server +http.server.actions +http.server.components +http.server.forms +http.server.validators ; IN: http.server.crud -USING: kernel namespaces db.tuples math.parser http.server -http.server.actions http.server.components -http.server.validators accessors fry locals hashtables ; :: ( form ctor -- action ) From 1ef0042f6a6dce2b89d30362d39796f585d06301 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Sun, 13 Apr 2008 23:52:53 -0700 Subject: [PATCH 16/23] Add a solution to project-euler.164 --- extra/project-euler/164/164.factor | 33 ++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) create mode 100644 extra/project-euler/164/164.factor diff --git a/extra/project-euler/164/164.factor b/extra/project-euler/164/164.factor new file mode 100644 index 0000000000..67397593bd --- /dev/null +++ b/extra/project-euler/164/164.factor @@ -0,0 +1,33 @@ +! Copyright (c) 2008 Eric Mertens +! See http://factorcode.org/license.txt for BSD license. +USING: arrays assocs kernel math math.ranges sequences ; + +IN: project-euler.164 + +! http://projecteuler.net/index.php?section=problems&id=164 + +! DESCRIPTION +! ----------- + +! How many 20 digit numbers n (without any leading zero) exist such +! that no three consecutive digits of n have a sum greater than 9? + +! SOLUTION +! -------- + +assoc ; + +PRIVATE> + +: euler164 ( -- n ) + init-table 19 [ next-table ] times values sum ; \ No newline at end of file From 3a9404767a484c609ae273a4a9a1344b32a12ace Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 14 Apr 2008 22:46:19 -0500 Subject: [PATCH 17/23] Minor builder changes --- extra/builder/cleanup/cleanup.factor | 2 ++ extra/builder/common/common.factor | 18 ++++-------------- extra/builder/email/email.factor | 2 ++ 3 files changed, 8 insertions(+), 14 deletions(-) diff --git a/extra/builder/cleanup/cleanup.factor b/extra/builder/cleanup/cleanup.factor index 327b90e01f..e601506fb4 100644 --- a/extra/builder/cleanup/cleanup.factor +++ b/extra/builder/cleanup/cleanup.factor @@ -8,6 +8,8 @@ IN: builder.cleanup SYMBOL: builder-debug +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ; : delete-child-factor ( -- ) diff --git a/extra/builder/common/common.factor b/extra/builder/common/common.factor index e3c207eaaa..474606e451 100644 --- a/extra/builder/common/common.factor +++ b/extra/builder/common/common.factor @@ -7,6 +7,10 @@ IN: builder.common ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +SYMBOL: upload-to-factorcode + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SYMBOL: builds-dir : builds ( -- path ) @@ -21,15 +25,6 @@ VAR: stamp : builds/factor ( -- path ) builds "factor" append-path ; : build-dir ( -- path ) builds stamp> append-path ; -: create-build-dir ( -- ) - datestamp >stamp - build-dir make-directory ; - -: enter-build-dir ( -- ) build-dir set-current-directory ; - -: clone-builds-factor ( -- ) - { "git" "clone" builds/factor } to-strings try-process ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : prepare-build-machine ( -- ) @@ -57,8 +52,3 @@ SYMBOL: status { status-vm status-boot status-test status-build status-release status } [ off ] each ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -SYMBOL: upload-to-factorcode - diff --git a/extra/builder/email/email.factor b/extra/builder/email/email.factor index eed48cb177..ecde47f8f7 100644 --- a/extra/builder/email/email.factor +++ b/extra/builder/email/email.factor @@ -8,6 +8,8 @@ IN: builder.email SYMBOL: builder-from SYMBOL: builder-recipients +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : subject-status ( -- str ) status get [ "report" ] [ "error" ] if ; : subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ; From ec9954a00a97a1c673dbc9e1dd53ca21b3b65c01 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 15 Apr 2008 01:20:53 -0500 Subject: [PATCH 18/23] Add extra/update --- extra/update/update.factor | 62 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 62 insertions(+) create mode 100644 extra/update/update.factor diff --git a/extra/update/update.factor b/extra/update/update.factor new file mode 100644 index 0000000000..f186837548 --- /dev/null +++ b/extra/update/update.factor @@ -0,0 +1,62 @@ + +USING: kernel system sequences io.files io.launcher bootstrap.image + builder.util builder.release.branch ; + +IN: update + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: run-command ( cmd -- ) to-strings try-process ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: git-pull-clean ( -- ) + image parent-directory + [ + { "git" "pull" "git://factorcode.org/git/factor.git" branch-name } + run-command + ] + with-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: remote-clean-image ( -- url ) + "http://factorcode.org/images/clean/" my-boot-image-name append ; + +: download-clean-image ( -- ) { "wget" remote-clean-image } run-command ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: make-clean ( -- ) { gnu-make "clean" } run-command ; +: make ( -- ) { gnu-make } run-command ; +: boot ( -- ) { "./factor" { "-i=" my-boot-image-name } } run-command ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: rebuild ( -- ) + image parent-directory + [ + download-clean-image + make-clean + make + boot + ] + with-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: update ( -- ) + image parent-directory + [ + git-id + git-pull-clean + git-id + = not + [ rebuild ] + when + ] + with-directory ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: update \ No newline at end of file From 7bcadd99a4148f52b20c6b466cc472e2b34b20fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 15 Apr 2008 06:10:08 -0500 Subject: [PATCH 19/23] XML templating engine --- .../generate-syntax/generate-syntax.factor | 5 +- extra/http/http.factor | 15 +- extra/http/server/auth/login/boilerplate.xml | 9 + .../http/server/auth/login/edit-profile.fhtml | 77 -------- extra/http/server/auth/login/edit-profile.xml | 77 ++++++++ extra/http/server/auth/login/login.factor | 43 +++-- extra/http/server/auth/login/login.fhtml | 46 ----- extra/http/server/auth/login/login.xml | 44 +++++ extra/http/server/auth/login/recover-1.fhtml | 41 ----- extra/http/server/auth/login/recover-1.xml | 39 ++++ extra/http/server/auth/login/recover-2.fhtml | 9 - extra/http/server/auth/login/recover-2.xml | 9 + extra/http/server/auth/login/recover-3.fhtml | 46 ----- extra/http/server/auth/login/recover-3.xml | 43 +++++ extra/http/server/auth/login/recover-4.fhtml | 10 -- extra/http/server/auth/login/recover-4.xml | 9 + extra/http/server/auth/login/register.fhtml | 77 -------- extra/http/server/auth/login/register.xml | 79 ++++++++ .../server/boilerplate/boilerplate.factor | 49 +++++ .../server/components/components-tests.factor | 5 +- .../http/server/components/components.factor | 21 ++- .../server/components/farkup/farkup.factor | 5 +- extra/http/server/crud/crud.factor | 47 ++--- extra/http/server/forms/forms.factor | 32 +++- .../templating/chloe/chloe-tests.factor | 97 ++++++++++ .../http/server/templating/chloe/chloe.factor | 168 ++++++++++++++++++ .../server/templating/chloe/test/test1.xml | 5 + .../server/templating/chloe/test/test2.xml | 6 + .../templating/chloe/test/test3-aux.xml | 5 + .../server/templating/chloe/test/test3.xml | 12 ++ .../server/templating/chloe/test/test4.xml | 9 + .../server/templating/chloe/test/test5.xml | 9 + .../server/templating/chloe/test/test6.xml | 9 + .../server/templating/chloe/test/test7.xml | 9 + .../templating/fhtml/fhtml-tests.factor | 6 +- .../http/server/templating/fhtml/fhtml.factor | 30 ++-- .../http/server/templating/templating.factor | 13 ++ .../http/server/validators/validators.factor | 6 +- extra/xml/writer/writer.factor | 30 ++-- 39 files changed, 854 insertions(+), 397 deletions(-) create mode 100644 extra/http/server/auth/login/boilerplate.xml delete mode 100755 extra/http/server/auth/login/edit-profile.fhtml create mode 100644 extra/http/server/auth/login/edit-profile.xml delete mode 100755 extra/http/server/auth/login/login.fhtml create mode 100644 extra/http/server/auth/login/login.xml delete mode 100755 extra/http/server/auth/login/recover-1.fhtml create mode 100644 extra/http/server/auth/login/recover-1.xml delete mode 100755 extra/http/server/auth/login/recover-2.fhtml create mode 100644 extra/http/server/auth/login/recover-2.xml delete mode 100755 extra/http/server/auth/login/recover-3.fhtml create mode 100644 extra/http/server/auth/login/recover-3.xml delete mode 100755 extra/http/server/auth/login/recover-4.fhtml create mode 100755 extra/http/server/auth/login/recover-4.xml delete mode 100755 extra/http/server/auth/login/register.fhtml create mode 100644 extra/http/server/auth/login/register.xml create mode 100644 extra/http/server/boilerplate/boilerplate.factor create mode 100644 extra/http/server/templating/chloe/chloe-tests.factor create mode 100644 extra/http/server/templating/chloe/chloe.factor create mode 100644 extra/http/server/templating/chloe/test/test1.xml create mode 100644 extra/http/server/templating/chloe/test/test2.xml create mode 100644 extra/http/server/templating/chloe/test/test3-aux.xml create mode 100644 extra/http/server/templating/chloe/test/test3.xml create mode 100644 extra/http/server/templating/chloe/test/test4.xml create mode 100644 extra/http/server/templating/chloe/test/test5.xml create mode 100644 extra/http/server/templating/chloe/test/test6.xml create mode 100644 extra/http/server/templating/chloe/test/test7.xml create mode 100644 extra/http/server/templating/templating.factor diff --git a/extra/editors/vim/generate-syntax/generate-syntax.factor b/extra/editors/vim/generate-syntax/generate-syntax.factor index 178a1b3b8b..325a451a0b 100644 --- a/extra/editors/vim/generate-syntax/generate-syntax.factor +++ b/extra/editors/vim/generate-syntax/generate-syntax.factor @@ -1,9 +1,10 @@ ! Generate a new factor.vim file for syntax highlighting -USING: http.server.templating.fhtml io.files ; +USING: http.server.templating http.server.templating.fhtml +io.files ; IN: editors.vim.generate-syntax : generate-vim-syntax ( -- ) - "misc/factor.vim.fgen" resource-path + "misc/factor.vim.fgen" resource-path "misc/factor.vim" resource-path template-convert ; diff --git a/extra/http/http.factor b/extra/http/http.factor index e792802b5a..c25ae5590d 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -394,14 +394,17 @@ body ; [ unparse-cookies "set-cookie" pick set-at ] when* write-header ; -: write-response-body ( response -- response ) - dup body>> { - { [ dup not ] [ drop ] } - { [ dup string? ] [ write ] } - { [ dup callable? ] [ call ] } - [ stdio get stream-copy ] +: body>quot ( body -- quot ) + { + { [ dup not ] [ drop [ ] ] } + { [ dup string? ] [ [ write ] curry ] } + { [ dup callable? ] [ ] } + [ [ stdio get stream-copy ] curry ] } cond ; +: write-response-body ( response -- response ) + dup body>> body>quot call ; + M: response write-response ( respose -- ) write-response-version write-response-code diff --git a/extra/http/server/auth/login/boilerplate.xml b/extra/http/server/auth/login/boilerplate.xml new file mode 100644 index 0000000000..edc8c329df --- /dev/null +++ b/extra/http/server/auth/login/boilerplate.xml @@ -0,0 +1,9 @@ + + + + +

+ + + + diff --git a/extra/http/server/auth/login/edit-profile.fhtml b/extra/http/server/auth/login/edit-profile.fhtml deleted file mode 100755 index 7d94ca1791..0000000000 --- a/extra/http/server/auth/login/edit-profile.fhtml +++ /dev/null @@ -1,77 +0,0 @@ -<% USING: http.server.components http.server.auth.login -http.server namespaces kernel combinators ; %> - - -

Edit profile

- - -<% hidden-form-field %> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
User name:<% "username" component render-view %>
Real name:<% "realname" component render-edit %>
Specifying a real name is optional.
Current password:<% "password" component render-edit %>
If you don't want to change your current password, leave this field blank.
New password:<% "new-password" component render-edit %>
Verify:<% "verify-password" component render-edit %>
If you are changing your password, enter it twice to ensure it is correct.
E-mail:<% "email" component render-edit %>
Specifying an e-mail address is optional. It enables the "recover password" feature.
- -

- -<% { - { [ login-failed? get ] [ "invalid password" render-error ] } - { [ password-mismatch? get ] [ "passwords do not match" render-error ] } - { [ t ] [ ] } -} cond %> - -

- - - - - diff --git a/extra/http/server/auth/login/edit-profile.xml b/extra/http/server/auth/login/edit-profile.xml new file mode 100644 index 0000000000..86a4e86551 --- /dev/null +++ b/extra/http/server/auth/login/edit-profile.xml @@ -0,0 +1,77 @@ + + + + + Edit Profile + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
User name:
Real name:
Specifying a real name is optional.
Current password:
If you don't want to change your current password, leave this field blank.
New password:
Verify:
If you are changing your password, enter it twice to ensure it is correct.
E-mail:
Specifying an e-mail address is optional. It enables the "recover password" feature.
+ +

+ + + + invalid password + + + + passwords do not match + +

+ + + + diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 4f04a1ff9b..888234cc96 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -15,7 +15,9 @@ http.server.actions http.server.components http.server.forms http.server.sessions -http.server.templating.fhtml +http.server.boilerplate +http.server.templating +http.server.templating.chloe http.server.validators ; IN: http.server.auth.login QUALIFIED: smtp @@ -40,11 +42,15 @@ M: user-saver dispose : save-user-after ( user -- ) add-always-destructor ; +: login-template ( name -- template ) + "resource:extra/http/server/auth/login/" swap ".xml" + 3append ; + ! ! ! Login : "login"
- "resource:extra/http/server/auth/login/login.fhtml" >>edit-template + "login" login-template >>edit-template "username" t >>required add-field @@ -86,7 +92,7 @@ M: user-saver dispose : ( -- form ) "register" - "resource:extra/http/server/auth/login/register.fhtml" >>edit-template + "register" login-template >>edit-template "username" t >>required add-field @@ -147,7 +153,7 @@ SYMBOL: user-exists? : ( -- form ) "edit-profile" - "resource:extra/http/server/auth/login/edit-profile.fhtml" >>edit-template + "edit-profile" login-template >>edit-template "username" add-field "realname" add-field "password" add-field @@ -242,7 +248,7 @@ SYMBOL: lost-password-from : ( -- form ) "register" - "resource:extra/http/server/auth/login/recover-1.fhtml" >>edit-template + "recover-1" login-template >>edit-template "username" t >>required add-field @@ -271,13 +277,13 @@ SYMBOL: lost-password-from send-password-email ] when* - "resource:extra/http/server/auth/login/recover-2.fhtml" serve-template + "recover-2" login-template serve-template ] >>submit ] ; : "new-password" - "resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template + "recover-3" login-template >>edit-template "username" hidden >>renderer t >>required @@ -326,8 +332,7 @@ SYMBOL: lost-password-from "new-password" value >>password users update-user - "resource:extra/http/server/auth/login/recover-4.fhtml" - serve-template + "recover-4" login-template serve-template ] [ <400> ] if* @@ -367,24 +372,32 @@ M: login call-responder ( path responder -- response ) dup login set call-next-method ; +: ( responder -- responder' ) + + "boilerplate" login-template >>template ; + : ( responder -- auth ) login new-dispatcher swap >>default - "login" add-responder - "logout" add-responder + "login" add-responder + "logout" add-responder no-users >>users ; ! ! ! Configuration : allow-edit-profile ( login -- login ) - "edit-profile" add-responder ; + + "edit-profile" add-responder ; : allow-registration ( login -- login ) - "register" add-responder ; + + "register" add-responder ; : allow-password-recovery ( login -- login ) - "recover-password" add-responder - "new-password" add-responder ; + + "recover-password" add-responder + + "new-password" add-responder ; : allow-edit-profile? ( -- ? ) login get responders>> "edit-profile" swap key? ; diff --git a/extra/http/server/auth/login/login.fhtml b/extra/http/server/auth/login/login.fhtml deleted file mode 100755 index 07201719e5..0000000000 --- a/extra/http/server/auth/login/login.fhtml +++ /dev/null @@ -1,46 +0,0 @@ -<% USING: http.server.auth.login http.server.components http.server -kernel namespaces ; %> - - -

Login required

- - - -<% hidden-form-field %> - - - - - - - - - - - - - -
User name:<% "username" component render-edit %>
Password:<% "password" component render-edit %>
- -

-<% -login-failed? get -[ "Invalid username or password" render-error ] when -%> -

- - - -

-<% allow-registration? [ %> - ">Register -<% ] when %> -<% allow-password-recovery? [ %> - "> - Recover Password - -<% ] when %> -

- - - diff --git a/extra/http/server/auth/login/login.xml b/extra/http/server/auth/login/login.xml new file mode 100644 index 0000000000..2f16c09d8d --- /dev/null +++ b/extra/http/server/auth/login/login.xml @@ -0,0 +1,44 @@ + + + + + Login + + + + + + + + + + + + + + + +
User name:
Password:
+ +

+ + + + + invalid username or password + +

+ + + +

+ + Register + + | + + Recover Password + +

+ + diff --git a/extra/http/server/auth/login/recover-1.fhtml b/extra/http/server/auth/login/recover-1.fhtml deleted file mode 100755 index 8ec01f22e9..0000000000 --- a/extra/http/server/auth/login/recover-1.fhtml +++ /dev/null @@ -1,41 +0,0 @@ -<% USING: http.server.components http.server ; %> - - -

Recover lost password: step 1 of 4

- -

Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.

- -
- -<% hidden-form-field %> - - - - - - - - - - - - - - - - - - - - - - - -
User name:<% "username" component render-edit %>
E-mail:<% "email" component render-edit %>
Captcha:<% "captcha" component render-edit %>
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.
- - - -
- - - diff --git a/extra/http/server/auth/login/recover-1.xml b/extra/http/server/auth/login/recover-1.xml new file mode 100644 index 0000000000..dd3a60f1d1 --- /dev/null +++ b/extra/http/server/auth/login/recover-1.xml @@ -0,0 +1,39 @@ + + + + + Recover lost password: step 1 of 4 + +

Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.

+ + + + + + + + + + + + + + + + + + + + + + + + + +
User name:
E-mail:
Captcha:
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.
+ + + + + + diff --git a/extra/http/server/auth/login/recover-2.fhtml b/extra/http/server/auth/login/recover-2.fhtml deleted file mode 100755 index 9b13734273..0000000000 --- a/extra/http/server/auth/login/recover-2.fhtml +++ /dev/null @@ -1,9 +0,0 @@ -<% USING: http.server.components ; %> - - -

Recover lost password: step 2 of 4

- -

If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.

- - - diff --git a/extra/http/server/auth/login/recover-2.xml b/extra/http/server/auth/login/recover-2.xml new file mode 100644 index 0000000000..c7819bd21b --- /dev/null +++ b/extra/http/server/auth/login/recover-2.xml @@ -0,0 +1,9 @@ + + + + + Recover lost password: step 2 of 4 + +

If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.

+ + diff --git a/extra/http/server/auth/login/recover-3.fhtml b/extra/http/server/auth/login/recover-3.fhtml deleted file mode 100755 index ca4823baab..0000000000 --- a/extra/http/server/auth/login/recover-3.fhtml +++ /dev/null @@ -1,46 +0,0 @@ -<% USING: http.server.components http.server.auth.login http.server -namespaces kernel combinators ; %> - - -

Recover lost password: step 3 of 4

- -

Choose a new password for your account.

- -
- -<% hidden-form-field %> - - - -<% "username" component render-edit %> -<% "ticket" component render-edit %> - - - - - - - - - - - - - - - - -
Password:<% "new-password" component render-edit %>
Verify password:<% "verify-password" component render-edit %>
Enter your password twice to ensure it is correct.
- -

- -<% password-mismatch? get [ - "passwords do not match" render-error -] when %> - -

- -
- - - diff --git a/extra/http/server/auth/login/recover-3.xml b/extra/http/server/auth/login/recover-3.xml new file mode 100644 index 0000000000..115c2cea21 --- /dev/null +++ b/extra/http/server/auth/login/recover-3.xml @@ -0,0 +1,43 @@ + + + + + Recover lost password: step 3 of 4 + +

Choose a new password for your account.

+ + + + + + + + + + + + + + + + + + + + + + + +
Password:
Verify password:
Enter your password twice to ensure it is correct.
+ +

+ + + + passwords do not match + +

+ + + + diff --git a/extra/http/server/auth/login/recover-4.fhtml b/extra/http/server/auth/login/recover-4.fhtml deleted file mode 100755 index 239d71d293..0000000000 --- a/extra/http/server/auth/login/recover-4.fhtml +++ /dev/null @@ -1,10 +0,0 @@ -<% USING: http.server ; %> - - -

Recover lost password: step 4 of 4

- -

Your password has been reset. -You may now ">log in.

- - - diff --git a/extra/http/server/auth/login/recover-4.xml b/extra/http/server/auth/login/recover-4.xml new file mode 100755 index 0000000000..3c10869fbd --- /dev/null +++ b/extra/http/server/auth/login/recover-4.xml @@ -0,0 +1,9 @@ + + + + + Recover lost password: step 4 of 4 + +

Your password has been reset. You may now log in.

+ + diff --git a/extra/http/server/auth/login/register.fhtml b/extra/http/server/auth/login/register.fhtml deleted file mode 100755 index 9106497def..0000000000 --- a/extra/http/server/auth/login/register.fhtml +++ /dev/null @@ -1,77 +0,0 @@ -<% USING: http.server.components http.server.auth.login -http.server namespaces kernel combinators ; %> - - -

New user registration

- -
-<% hidden-form-field %> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
User name:<% "username" component render-edit %>
Real name:<% "realname" component render-edit %>
Specifying a real name is optional.
Password:<% "new-password" component render-edit %>
Verify:<% "verify-password" component render-edit %>
Enter your password twice to ensure it is correct.
E-mail:<% "email" component render-edit %>
Specifying an e-mail address is optional. It enables the "recover password" feature.
Captcha:<% "captcha" component render-edit %>
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.
- -

- -<% { - { [ password-mismatch? get ] [ "passwords do not match" render-error ] } - { [ user-exists? get ] [ "username taken" render-error ] } - { [ t ] [ ] } -} cond %> - -

- -
- - - diff --git a/extra/http/server/auth/login/register.xml b/extra/http/server/auth/login/register.xml new file mode 100644 index 0000000000..1bacf71801 --- /dev/null +++ b/extra/http/server/auth/login/register.xml @@ -0,0 +1,79 @@ + + + + + New User Registration + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
User name:
Real name:
Specifying a real name is optional.
Password:
Verify:
Enter your password twice to ensure it is correct.
E-mail:
Specifying an e-mail address is optional. It enables the "recover password" feature.
Captcha:
Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.
+ +

+ + + + + username taken + + + + passwords do not match + + +

+ + + + diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor new file mode 100644 index 0000000000..2bd6eee340 --- /dev/null +++ b/extra/http/server/boilerplate/boilerplate.factor @@ -0,0 +1,49 @@ +! Copyright (c) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel namespaces boxes sequences strings +io io.streams.string +http.server +http.server.templating ; +IN: http.server.boilerplate + +TUPLE: boilerplate responder template ; + +: f boilerplate boa ; + +SYMBOL: title + +: set-title ( string -- ) + title get >box ; + +: write-title ( -- ) + title get value>> write ; + +SYMBOL: style + +: add-style ( string -- ) + "\n" style get push-all + style get push-all ; + +: write-style ( -- ) + style get >string write ; + +SYMBOL: next-template + +: call-next-template ( -- ) + next-template get write ; + +M: f call-template drop call-next-template ; + +: with-boilerplate ( body template -- ) + [ + title get [ title set ] unless + style get [ SBUF" " clone style set ] unless + + swap with-string-writer next-template set + + call-template + ] with-scope ; inline + +M: boilerplate call-responder + [ responder>> call-responder clone ] [ template>> ] bi + [ [ with-boilerplate ] 2curry ] curry change-body ; diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor index f1c43fe8ae..29cfa1de8b 100755 --- a/extra/http/server/components/components-tests.factor +++ b/extra/http/server/components/components-tests.factor @@ -2,6 +2,7 @@ IN: http.server.components.tests USING: http.server.components http.server.forms http.server.validators namespaces tools.test kernel accessors tuple-syntax mirrors http.server.actions +http.server.templating.fhtml io.streams.string io.streams.null ; \ render-edit must-infer @@ -49,8 +50,8 @@ TUPLE: test-tuple text number more-text ; : ( -- form ) "test"
- "resource:extra/http/server/components/test/form.fhtml" >>view-template - "resource:extra/http/server/components/test/form.fhtml" >>edit-template + "resource:extra/http/server/components/test/form.fhtml" >>view-template + "resource:extra/http/server/components/test/form.fhtml" >>edit-template "text" t >>required add-field diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index 1e5e33c4a0..3ab0bdd770 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -203,22 +203,35 @@ M: captcha validate* drop v-captcha ; ! Text areas -TUPLE: textarea-renderer ; +TUPLE: textarea-renderer rows cols ; -: textarea-renderer T{ textarea-renderer } ; +: new-textarea-renderer ( class -- renderer ) + new + 60 >>cols + 20 >>rows ; + +: ( -- renderer ) + textarea-renderer new-textarea-renderer ; M: textarea-renderer render-view* drop write ; M: textarea-renderer render-edit* - drop ; + ; TUPLE: text < string ; : new-text ( id class -- component ) new-string f >>one-line - textarea-renderer >>renderer ; + >>renderer ; : ( id -- component ) text new-text ; diff --git a/extra/http/server/components/farkup/farkup.factor b/extra/http/server/components/farkup/farkup.factor index 65e159513d..fb1c6fd25a 100755 --- a/extra/http/server/components/farkup/farkup.factor +++ b/extra/http/server/components/farkup/farkup.factor @@ -6,11 +6,12 @@ IN: http.server.components.farkup TUPLE: farkup-renderer < textarea-renderer ; -: farkup-renderer T{ farkup-renderer } ; +: + farkup-renderer new-textarea-renderer ; M: farkup-renderer render-view* drop string-lines "\n" join convert-farkup write ; : ( id -- component ) - farkup-renderer >>renderer ; + >>renderer ; diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor index eb8ff943c7..cf9771e15f 100755 --- a/extra/http/server/crud/crud.factor +++ b/extra/http/server/crud/crud.factor @@ -23,29 +23,18 @@ IN: http.server.crud : ( id next -- response ) swap number>string "id" associate ; -:: ( form ctor next -- action ) - - [ f ctor call from-tuple form set-defaults ] >>init - - [ - "text/html" - [ form edit-form ] >>body - ] >>display - - [ - f ctor call from-tuple - - form validate-form - - values-tuple insert-tuple - - "id" value next - ] >>submit ; - :: ( form ctor next -- action ) - { { "id" [ v-number ] } } >>get-params - [ "id" get ctor call select-tuple from-tuple ] >>init + { { "id" [ [ v-number ] v-optional ] } } >>get-params + + [ + "id" get ctor call + + "id" get + [ select-tuple from-tuple ] + [ from-tuple form set-defaults ] + if + ] >>init [ "text/html" @@ -57,7 +46,8 @@ IN: http.server.crud form validate-form - values-tuple update-tuple + values-tuple + "id" value [ update-tuple ] [ insert-tuple ] if "id" value next ] >>submit ; @@ -71,3 +61,16 @@ IN: http.server.crud next f ] >>submit ; + +:: ( form ctor -- action ) + + [ + "text/html" + [ + blank-values + + f ctor call select-tuples "list" set-value + + form view-form + ] >>body + ] >>display ; diff --git a/extra/http/server/forms/forms.factor b/extra/http/server/forms/forms.factor index cf8fd4ca8c..2c2b673f83 100644 --- a/extra/http/server/forms/forms.factor +++ b/extra/http/server/forms/forms.factor @@ -1,11 +1,13 @@ -USING: kernel accessors assocs namespaces io.files fry +USING: kernel accessors assocs namespaces io.files sequences fry http.server.actions http.server.components http.server.validators -http.server.templating.fhtml ; +http.server.templating ; IN: http.server.forms -TUPLE: form < component view-template edit-template components ; +TUPLE: form < component +view-template edit-template summary-template +components ; M: form init V{ } clone >>components ; @@ -28,10 +30,13 @@ M: form init V{ } clone >>components ; ] with-form ; : view-form ( form -- ) - dup view-template>> '[ , run-template ] with-form ; + dup view-template>> '[ , call-template ] with-form ; : edit-form ( form -- ) - dup edit-template>> '[ , run-template ] with-form ; + dup edit-template>> '[ , call-template ] with-form ; + +: summary-form ( form -- ) + dup summary-template>> '[ , call-template ] with-form ; : validate-param ( id component -- ) [ [ params get at ] [ validate ] bi* ] @@ -46,3 +51,20 @@ M: form init V{ } clone >>components ; : validate-form ( form -- ) (validate-form) [ validation-failed ] when ; + +! List components +TUPLE: list-renderer form ; + +C: list-renderer + +M: list-renderer render-view* + form>> [ + [ >r from-tuple r> summary-form ] with-scope + ] curry each ; + +TUPLE: list < component ; + +: ( id form -- list ) + list swap new-component ; + +M: list component-string drop ; diff --git a/extra/http/server/templating/chloe/chloe-tests.factor b/extra/http/server/templating/chloe/chloe-tests.factor new file mode 100644 index 0000000000..f517af4a12 --- /dev/null +++ b/extra/http/server/templating/chloe/chloe-tests.factor @@ -0,0 +1,97 @@ +USING: http.server.templating http.server.templating.chloe +http.server.components http.server.boilerplate tools.test +io.streams.string kernel sequences ascii boxes namespaces xml +splitting ; +IN: http.server.templating.chloe.tests + +[ "foo" ] +[ "blah" string>xml "href" required-attr ] +unit-test + +[ "blah" string>xml "href" required-attr ] +[ "href attribute is required" = ] +must-fail-with + +[ f ] [ f parse-query-attr ] unit-test + +[ f ] [ "" parse-query-attr ] unit-test + +[ H{ { "a" "b" } } ] [ + blank-values + "b" "a" set-value + "a" parse-query-attr +] unit-test + +[ H{ { "a" "b" } { "c" "d" } } ] [ + blank-values + "b" "a" set-value + "d" "c" set-value + "a,c" parse-query-attr +] unit-test + +: run-template + with-string-writer [ "\r\n\t" member? not ] subset + "?>" split1 nip ; inline + +: test-template ( name -- template ) + "resource:extra/http/server/templating/chloe/test/" + swap + ".xml" 3append ; + +[ "Hello world" ] [ + [ + "test1" test-template call-template + ] run-template +] unit-test + +[ "Blah blah" "Hello world" ] [ + [ + title set + [ + "test2" test-template call-template + ] run-template + title get box> + ] with-scope +] unit-test + +[ "Hello worldBlah blah" ] [ + [ + [ + "test2" test-template call-template + ] "test3" test-template with-boilerplate + ] run-template +] unit-test + +: test4-aux? t ; + +[ "True" ] [ + [ + "test4" test-template call-template + ] run-template +] unit-test + +: test5-aux? f ; + +[ "" ] [ + [ + "test5" test-template call-template + ] run-template +] unit-test + +SYMBOL: test6-aux? + +[ "True" ] [ + [ + test6-aux? on + "test6" test-template call-template + ] run-template +] unit-test + +SYMBOL: test7-aux? + +[ "" ] [ + [ + test7-aux? off + "test7" test-template call-template + ] run-template +] unit-test diff --git a/extra/http/server/templating/chloe/chloe.factor b/extra/http/server/templating/chloe/chloe.factor new file mode 100644 index 0000000000..9da153607f --- /dev/null +++ b/extra/http/server/templating/chloe/chloe.factor @@ -0,0 +1,168 @@ +USING: accessors kernel sequences combinators kernel namespaces +classes.tuple assocs splitting words arrays +io.files io.encodings.utf8 html.elements unicode.case +tuple-syntax xml xml.data xml.writer xml.utilities +http.server +http.server.auth +http.server.components +http.server.sessions +http.server.templating +http.server.boilerplate ; +IN: http.server.templating.chloe + +! Chloe is Ed's favorite web designer + +TUPLE: chloe path ; + +C: chloe + +DEFER: process-template + +: chloe-ns TUPLE{ name url: "http://factorcode.org/chloe/1.0" } ; + +: chloe-tag? ( tag -- ? ) + { + { [ dup tag? not ] [ f ] } + { [ dup chloe-ns names-match? not ] [ f ] } + [ t ] + } cond nip ; + +SYMBOL: tags + +: required-attr ( tag name -- value ) + dup rot at* + [ nip ] [ drop " attribute is required" append throw ] if ; + +: optional-attr ( tag name -- value ) + swap at ; + +: write-title-tag ( tag -- ) + drop + "head" tags get member? "title" tags get member? not and + [ write-title ] [ write-title ] if ; + +: style-tag ( tag -- ) + dup "include" optional-attr dup [ + swap children>string empty? [ + "style tag cannot have both an include attribute and a body" throw + ] unless + utf8 file-contents + ] [ + drop children>string + ] if add-style ; + +: write-style-tag ( tag -- ) + drop ; + +: component-attr ( tag -- name ) + "component" required-attr ; + +: view-tag ( tag -- ) + component-attr component render-view ; + +: edit-tag ( tag -- ) + component-attr component render-edit ; + +: parse-query-attr ( string -- assoc ) + dup empty? + [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ; + +: a-start-tag ( tag -- ) + string =href + a> ; + +: process-tag-children ( tag -- ) + [ process-template ] each ; + +: a-tag ( tag -- ) + [ a-start-tag ] + [ process-tag-children ] + [ drop ] + tri ; + +: form-start-tag ( tag -- ) + + hidden-form-field ; + +: form-tag ( tag -- ) + [ form-start-tag ] + [ process-tag-children ] + [ drop ] + tri ; + +: attr>word ( value -- word/f ) + dup ":" split1 swap lookup + [ ] [ "No such word: " swap append throw ] ?if ; + +: attr>var ( value -- word/f ) + attr>word dup symbol? [ + "Must be a symbol: " swap append throw + ] unless ; + +: if-satisfied? ( tag -- ? ) + { + [ "code" optional-attr [ attr>word execute ] [ t ] if* ] + [ "var" optional-attr [ attr>var get ] [ t ] if* ] + [ "svar" optional-attr [ attr>var sget ] [ t ] if* ] + [ "uvar" optional-attr [ attr>var uget ] [ t ] if* ] + } cleave 4array [ ] all? ; + +: if-tag ( tag -- ) + dup if-satisfied? [ process-tag-children ] [ drop ] if ; + +: error-tag ( tag -- ) + children>string render-error ; + +: process-chloe-tag ( tag -- ) + dup name-tag { + { "chloe" [ [ process-template ] each ] } + { "title" [ children>string set-title ] } + { "write-title" [ write-title-tag ] } + { "style" [ style-tag ] } + { "write-style" [ write-style-tag ] } + { "view" [ view-tag ] } + { "edit" [ edit-tag ] } + { "a" [ a-tag ] } + { "form" [ form-tag ] } + { "error" [ error-tag ] } + { "if" [ if-tag ] } + { "call-next-template" [ drop call-next-template ] } + [ "Unknown chloe tag: " swap append throw ] + } case ; + +: process-tag ( tag -- ) + { + [ name-tag >lower tags get push ] + [ write-start-tag ] + [ process-tag-children ] + [ write-end-tag ] + [ drop tags get pop* ] + } cleave ; + +: process-template ( xml -- ) + { + { [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] } + { [ dup [ tag? ] is? ] [ process-tag ] } + { [ t ] [ write-item ] } + } cond ; + +: process-chloe ( xml -- ) + [ + V{ } clone tags set + + { + [ xml-prolog write-prolog ] + [ xml-before write-chunk ] + [ process-template ] + [ xml-after write-chunk ] + } cleave + ] with-scope ; + +M: chloe call-template + path>> utf8 read-xml process-chloe ; diff --git a/extra/http/server/templating/chloe/test/test1.xml b/extra/http/server/templating/chloe/test/test1.xml new file mode 100644 index 0000000000..daccd57b17 --- /dev/null +++ b/extra/http/server/templating/chloe/test/test1.xml @@ -0,0 +1,5 @@ + + + + Hello world + diff --git a/extra/http/server/templating/chloe/test/test2.xml b/extra/http/server/templating/chloe/test/test2.xml new file mode 100644 index 0000000000..05b9dde54f --- /dev/null +++ b/extra/http/server/templating/chloe/test/test2.xml @@ -0,0 +1,6 @@ + + + + Hello world + Blah blah + diff --git a/extra/http/server/templating/chloe/test/test3-aux.xml b/extra/http/server/templating/chloe/test/test3-aux.xml new file mode 100644 index 0000000000..99f61afe33 --- /dev/null +++ b/extra/http/server/templating/chloe/test/test3-aux.xml @@ -0,0 +1,5 @@ + + + + Hello world + diff --git a/extra/http/server/templating/chloe/test/test3.xml b/extra/http/server/templating/chloe/test/test3.xml new file mode 100644 index 0000000000..845dd356c9 --- /dev/null +++ b/extra/http/server/templating/chloe/test/test3.xml @@ -0,0 +1,12 @@ + + + + + + + + + + + + diff --git a/extra/http/server/templating/chloe/test/test4.xml b/extra/http/server/templating/chloe/test/test4.xml new file mode 100644 index 0000000000..0381bcc27a --- /dev/null +++ b/extra/http/server/templating/chloe/test/test4.xml @@ -0,0 +1,9 @@ + + + + + + True + + + diff --git a/extra/http/server/templating/chloe/test/test5.xml b/extra/http/server/templating/chloe/test/test5.xml new file mode 100644 index 0000000000..d74a5e5368 --- /dev/null +++ b/extra/http/server/templating/chloe/test/test5.xml @@ -0,0 +1,9 @@ + + + + + + True + + + diff --git a/extra/http/server/templating/chloe/test/test6.xml b/extra/http/server/templating/chloe/test/test6.xml new file mode 100644 index 0000000000..5b6a71cf6b --- /dev/null +++ b/extra/http/server/templating/chloe/test/test6.xml @@ -0,0 +1,9 @@ + + + + + + True + + + diff --git a/extra/http/server/templating/chloe/test/test7.xml b/extra/http/server/templating/chloe/test/test7.xml new file mode 100644 index 0000000000..4381b5cec4 --- /dev/null +++ b/extra/http/server/templating/chloe/test/test7.xml @@ -0,0 +1,9 @@ + + + + + + True + + + diff --git a/extra/http/server/templating/fhtml/fhtml-tests.factor b/extra/http/server/templating/fhtml/fhtml-tests.factor index 9d8a6f4617..42bec43570 100755 --- a/extra/http/server/templating/fhtml/fhtml-tests.factor +++ b/extra/http/server/templating/fhtml/fhtml-tests.factor @@ -1,13 +1,13 @@ USING: io io.files io.streams.string io.encodings.utf8 -http.server.templating.fhtml kernel tools.test sequences -parser ; +http.server.templating http.server.templating.fhtml kernel +tools.test sequences parser ; IN: http.server.templating.fhtml.tests : test-template ( path -- ? ) "resource:extra/http/server/templating/fhtml/test/" prepend [ - ".fhtml" append [ run-template ] with-string-writer + ".fhtml" append [ call-template ] with-string-writer ] keep ".html" append utf8 file-contents = ; diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor index 4a3bf38e23..237931dc34 100755 --- a/extra/http/server/templating/fhtml/fhtml.factor +++ b/extra/http/server/templating/fhtml/fhtml.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2005 Alex Chapman ! Copyright (C) 2006, 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: continuations sequences kernel parser namespaces io -io.files io.streams.string html html.elements source-files -debugger combinators math quotations generic strings splitting -accessors http.server.static http.server assocs -io.encodings.utf8 fry accessors ; - +USING: continuations sequences kernel namespaces debugger +combinators math quotations generic strings splitting +accessors assocs fry +parser io io.files io.streams.string io.encodings.utf8 source-files +html html.elements +http.server.static http.server http.server.templating ; IN: http.server.templating.fhtml : templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ; @@ -72,9 +72,13 @@ DEFER: <% delimiter : html-error. ( error -- ) 
 error.
; -: run-template ( filename -- ) +TUPLE: fhtml path ; + +C: fhtml + +M: fhtml call-template ( filename -- ) '[ - , [ + , path>> [ "quiet" on parser-notes off templating-vocab use+ @@ -85,16 +89,8 @@ DEFER: <% delimiter ] with-file-vocabs ] assert-depth ; -: template-convert ( infile outfile -- ) - utf8 [ run-template ] with-file-writer ; - -! responder integration -: serve-template ( name -- response ) - "text/html" - swap '[ , run-template ] >>body ; - ! file responder integration : enable-fhtml ( responder -- responder ) - [ serve-template ] + [ serve-template ] "application/x-factor-server-page" pick special>> set-at ; diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor new file mode 100644 index 0000000000..378823e9d1 --- /dev/null +++ b/extra/http/server/templating/templating.factor @@ -0,0 +1,13 @@ +USING: accessors kernel fry io.encodings.utf8 io.files +http.server ; +IN: http.server.templating + +GENERIC: call-template ( template -- ) + +: template-convert ( template output -- ) + utf8 [ call-template ] with-file-writer ; + +! responder integration +: serve-template ( template -- response ) + "text/html" + swap '[ , call-template ] >>body ; diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor index 5be064c5ce..692a5dec7c 100755 --- a/extra/http/server/validators/validators.factor +++ b/extra/http/server/validators/validators.factor @@ -11,8 +11,7 @@ TUPLE: validation-error value reason ; C: validation-error : with-validator ( value quot -- result ) - [ validation-failed? on ] recover ; - inline + [ validation-failed? on ] recover ; inline : v-default ( str def -- str ) over empty? spin ? ; @@ -20,6 +19,9 @@ C: validation-error : v-required ( str -- str ) dup empty? [ "required" throw ] when ; +: v-optional ( str quot -- str ) + over empty? [ 2drop f ] [ call ] if ; inline + : v-min-length ( str n -- str ) over length over < [ [ "must be at least " % # " characters" % ] "" make diff --git a/extra/xml/writer/writer.factor b/extra/xml/writer/writer.factor index 27880da07f..44c92006a0 100644 --- a/extra/xml/writer/writer.factor +++ b/extra/xml/writer/writer.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: hashtables kernel math namespaces sequences strings -io io.streams.string xml.data assocs wrap xml.entities -unicode.categories ; +assocs combinators io io.streams.string +xml.data wrap xml.entities unicode.categories ; IN: xml.writer SYMBOL: xml-pprint? @@ -61,6 +61,9 @@ M: string write-item ?indent CHAR: < write1 dup print-name tag-attrs print-attrs ; +: write-start-tag ( tag -- ) + write-tag ">" write ; + M: contained-tag write-item write-tag "/>" write ; @@ -72,11 +75,14 @@ M: contained-tag write-item ?indent " write1 ; M: open-tag write-item - xml-pprint? [ [ - over sensitive? not and xml-pprint? set - dup write-tag CHAR: > write1 - dup write-children write-end-tag - ] keep ] change ; + xml-pprint? get >r + { + [ sensitive? not xml-pprint? get and xml-pprint? set ] + [ write-start-tag ] + [ write-children ] + [ write-end-tag ] + } cleave + r> xml-pprint? set ; M: comment write-item "" write ; @@ -97,10 +103,12 @@ M: instruction write-item [ write-item ] each ; : write-xml ( xml -- ) - dup xml-prolog write-prolog - dup xml-before write-chunk - dup write-item - xml-after write-chunk ; + { + [ xml-prolog write-prolog ] + [ xml-before write-chunk ] + [ write-item ] + [ xml-after write-chunk ] + } cleave ; : print-xml ( xml -- ) write-xml nl ; From cd0b715161aceb7065b8ef4713948194d00a0877 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 15 Apr 2008 06:19:39 -0500 Subject: [PATCH 20/23] Use 
 tags

---
 extra/farkup/farkup.factor | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor
index f876c9569b..b98f6c6954 100755
--- a/extra/farkup/farkup.factor
+++ b/extra/farkup/farkup.factor
@@ -55,7 +55,8 @@ MEMO: eq ( -- parser )
 
 : render-code ( string mode -- string' )
     >r string-lines r>
-    [ [ htmlize-lines ] with-html-stream ] with-string-writer ;
+    [ [ htmlize-lines ] with-html-stream ] with-string-writer
+    "pre" surround-with-foo ;
 
 : escape-link ( href text -- href-esc text-esc )
     >r escape-quoted-string r> escape-string ;

From dd42130aed7649c77e6be50fbe56971b48b7badc Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Tue, 15 Apr 2008 06:23:15 -0500
Subject: [PATCH 21/23] Fix farkup tests

---
 extra/farkup/farkup-tests.factor |  2 +-
 extra/farkup/farkup.factor       | 17 +++++++++++------
 2 files changed, 12 insertions(+), 7 deletions(-)

diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor
index af4ddd8839..8dc590449e 100755
--- a/extra/farkup/farkup-tests.factor
+++ b/extra/farkup/farkup-tests.factor
@@ -54,7 +54,7 @@ IN: farkup.tests
 [ "
=
foo
" ] [ "===foo==" convert-farkup ] unit-test
 [ "
foo
=
" ] [ "=foo==" convert-farkup ] unit-test
 
-[ "int main()
" ]
+[ "
int main()
" ]
 [ "[c{int main()}]" convert-farkup ] unit-test
 
 [ "
" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor
index b98f6c6954..527ba8b4fa 100755
--- a/extra/farkup/farkup.factor
+++ b/extra/farkup/farkup.factor
@@ -1,9 +1,9 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io kernel memoize namespaces peg sequences strings
-html.elements xml.entities xmode.code2html splitting
-io.streams.string html peg.parsers html.elements sequences.deep
-unicode.categories ;
+USING: arrays io io.styles kernel memoize namespaces peg
+sequences strings html.elements xml.entities xmode.code2html
+splitting io.streams.string html peg.parsers html.elements
+sequences.deep unicode.categories ;
 IN: farkup
 
 r string-lines r>
-    [ [ htmlize-lines ] with-html-stream ] with-string-writer
-    "pre" surround-with-foo ;
+    [
+        [
+            H{ { wrap-margin f } } [
+                htmlize-lines
+            ] with-nesting
+        ] with-html-stream
+    ] with-string-writer ;
 
 : escape-link ( href text -- href-esc text-esc )
     >r escape-quoted-string r> escape-string ;

From c0206b3165ecc1f8ab3424d4c51ad05c98e16f25 Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Tue, 15 Apr 2008 06:35:06 -0500
Subject: [PATCH 22/23] Adding todo webapp

---
 extra/webapps/todo/edit-todo.xml    |  26 +++++++
 extra/webapps/todo/page.xml         |  45 +++++++++++
 extra/webapps/todo/todo-list.xml    |  12 +++
 extra/webapps/todo/todo-summary.xml |  20 +++++
 extra/webapps/todo/todo.css         |  41 ++++++++++
 extra/webapps/todo/todo.factor      | 111 ++++++++++++++++++++++++++++
 extra/webapps/todo/todo.xml         |  26 +++++++
 extra/webapps/todo/view-todo.xml    |  23 ++++++
 8 files changed, 304 insertions(+)
 create mode 100644 extra/webapps/todo/edit-todo.xml
 create mode 100644 extra/webapps/todo/page.xml
 create mode 100644 extra/webapps/todo/todo-list.xml
 create mode 100644 extra/webapps/todo/todo-summary.xml
 create mode 100644 extra/webapps/todo/todo.css
 create mode 100755 extra/webapps/todo/todo.factor
 create mode 100644 extra/webapps/todo/todo.xml
 create mode 100644 extra/webapps/todo/view-todo.xml

diff --git a/extra/webapps/todo/edit-todo.xml b/extra/webapps/todo/edit-todo.xml
new file mode 100644
index 0000000000..71d6900f1a
--- /dev/null
+++ b/extra/webapps/todo/edit-todo.xml
@@ -0,0 +1,26 @@
+
+
+
+
+	Edit Item
+
+	
+		
+
+		
+			
+			
+			
+		
Summary:    
Priority:   
Description:

+
+		
+	
+
+	View
+	|
+	
+		
+		
+	
+
+
diff --git a/extra/webapps/todo/page.xml b/extra/webapps/todo/page.xml
new file mode 100644
index 0000000000..f40c79d299
--- /dev/null
+++ b/extra/webapps/todo/page.xml
@@ -0,0 +1,45 @@
+
+
+
+
+
+
+	
+
+		
+			
+
+			
+				body, button {
+					font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+					color:#444;
+				}
+
+				a, .link {
+					color: #222;
+					border-bottom:1px dotted #666;
+					text-decoration:none;
+				}
+				
+				a:hover, .link:hover {
+					border-bottom:1px solid #66a;
+				}
+
+				.error { color: #a00; }
+				
+				.field-label {
+					text-align: right;
+				}
+			
+
+			
+		
+
+		
+			
+		
+
+	
+
+
diff --git a/extra/webapps/todo/todo-list.xml b/extra/webapps/todo/todo-list.xml
new file mode 100644
index 0000000000..056a9c6242
--- /dev/null
+++ b/extra/webapps/todo/todo-list.xml
@@ -0,0 +1,12 @@
+
+
+
+
+	My Todo List
+
+	
+		
+		
+	
SummaryPriorityViewEdit

+
+
diff --git a/extra/webapps/todo/todo-summary.xml b/extra/webapps/todo/todo-summary.xml
new file mode 100644
index 0000000000..9e03b7f135
--- /dev/null
+++ b/extra/webapps/todo/todo-summary.xml
@@ -0,0 +1,20 @@
+
+
+
+
+	
+		
+			
+		
+		
+			
+		
+		
+			View
+		
+		
+			Edit
+		
+	
+
+
diff --git a/extra/webapps/todo/todo.css b/extra/webapps/todo/todo.css
new file mode 100644
index 0000000000..f7a6cfa1a2
--- /dev/null
+++ b/extra/webapps/todo/todo.css
@@ -0,0 +1,41 @@
+.big-field-label {
+	vertical-align: top;
+}
+
+.description {
+	border: 1px dashed #ccc;
+	background-color: #f5f5f5;
+	padding: 5px;
+	font-size: 150%;
+	color: #000000;3
+}
+
+.link-button {
+	padding: 0px;
+	background: none;
+	border: none;
+}
+
+.navbar {
+	background-color: #eeeeee;
+	padding: 5px;
+	border: 1px solid #ccc;
+}
+
+.inline {
+	display: inline;
+}
+
+pre {
+	font-size: 75%;
+}
+
+.todo-list {
+	border-style: none;
+}
+
+.todo-list td, .todo-list th {
+	border-width: 1px;
+	padding: 2px;
+	border-style: solid;
+}
diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor
new file mode 100755
index 0000000000..6277216eef
--- /dev/null
+++ b/extra/webapps/todo/todo.factor
@@ -0,0 +1,111 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel locals sequences
+db db.types db.tuples
+http.server.components http.server.components.farkup
+http.server.forms http.server.templating.chloe
+http.server.boilerplate http.server.crud http.server.auth
+http.server.actions http.server.db
+http.server ;
+IN: todo
+
+TUPLE: todo uid id priority summary description ;
+
+todo "TODO"
+{
+    { "uid" "UID" { VARCHAR 256 } +not-null+ }
+    { "id" "ID" +native-id+ }
+    { "priority" "PRIORITY" INTEGER +not-null+ }
+    { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
+    { "description" "DESCRIPTION" { VARCHAR 256 } }
+} define-persistent
+
+: init-todo-table todo ensure-table ;
+
+:  ( id -- todo )
+    todo new
+        swap >>id
+        uid >>uid ;
+
+: todo-template ( name -- template )
+    "resource:extra/webapps/todo/" swap ".xml" 3append  ;
+
+:  ( -- form )
+    "todo" 

+        "view-todo" todo-template >>view-template
+        "edit-todo" todo-template >>edit-template
+        "todo-summary" todo-template >>summary-template
+        "id" 
+            hidden >>renderer
+            add-field
+        "summary" 
+            t >>required
+            add-field
+        "priority" 
+            t >>required
+            0 >>default
+            0 >>min-value
+            10 >>max-value
+            add-field
+        "description" 
+            add-field ;
+
+:  ( -- form )
+    "todo-list" 
+        "todo-list" todo-template >>view-template
+        "list"  
+        add-field ;
+
+TUPLE: todo-responder < dispatcher ;
+
+::  ( -- responder )
+    [let | todo-form [  ]
+           list-form [  ]
+           ctor [ [  ] ] |
+        todo-responder new-dispatcher
+            list-form ctor           "list"   add-main-responder
+            todo-form ctor           "view"   add-responder
+            todo-form ctor "view"    "edit"   add-responder
+                      ctor "list"  "delete" add-responder
+        
+            "todo" todo-template >>template
+    ] ;
+
+! What follows below is somewhat akin to a 'deployment descriptor'
+! for the todo application. The  can be integrated
+! into an existing web app that provides session management and
+! login facilities, or  can be used to run a
+! self-contained todo instance.
+USING: namespaces io.files io.sockets
+db.sqlite smtp
+http.server.sessions
+http.server.auth.login
+http.server.auth.providers.db
+http.server.sessions.storage.db ;
+
+: test-db "todo.db" resource-path sqlite-db ;
+
+:  ( -- responder )
+    
+    
+        users-in-db >>users
+        allow-registration
+        allow-password-recovery
+        allow-edit-profile
+    
+        "page" todo-template >>template
+    
+        sessions-in-db >>sessions
+    test-db  ;
+
+: init-todo ( -- )
+    "factorcode.org" 25  smtp-server set-global
+    "todo@factorcode.org" lost-password-from set-global
+
+    test-db [
+        init-todo-table
+        init-users-table
+        init-sessions-table
+    ] with-db
+
+     main-responder set-global ;
diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml
new file mode 100644
index 0000000000..a76ed2730f
--- /dev/null
+++ b/extra/webapps/todo/todo.xml
@@ -0,0 +1,26 @@
+
+
+
+
+	
+
+	
+
+	

+		  List Items
+		| New Items
+
+		
+			| Edit Profile
+		
+
+		
+			| 
+		
+	

+
+	

+
+	
+
+
diff --git a/extra/webapps/todo/view-todo.xml b/extra/webapps/todo/view-todo.xml
new file mode 100644
index 0000000000..fea77c1189
--- /dev/null
+++ b/extra/webapps/todo/view-todo.xml
@@ -0,0 +1,23 @@
+
+
+
+
+	View Item
+
+	
+		
+		
+	
Summary:    
Priority:   

+
+	

+		
+	

+
+	Edit
+	|
+	
+		
+		
+	
+
+

From 783d0d613d3389af5108ff917178bb0eaa2408dd Mon Sep 17 00:00:00 2001
From: Slava Pestov 
Date: Tue, 15 Apr 2008 07:09:01 -0500
Subject: [PATCH 23/23] Fix todo app

---
 extra/webapps/todo/todo.factor | 8 +++++---
 extra/webapps/todo/todo.xml    | 2 +-
 2 files changed, 6 insertions(+), 4 deletions(-)

diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor
index 6277216eef..d8d9988109 100755
--- a/extra/webapps/todo/todo.factor
+++ b/extra/webapps/todo/todo.factor
@@ -7,7 +7,7 @@ http.server.forms http.server.templating.chloe
 http.server.boilerplate http.server.crud http.server.auth
 http.server.actions http.server.db
 http.server ;
-IN: todo
+IN: webapps.todo
 
 TUPLE: todo uid id priority summary description ;
 
@@ -86,7 +86,7 @@ http.server.sessions.storage.db ;
 : test-db "todo.db" resource-path sqlite-db ;
 
 :  ( -- responder )
-    
+    
     
         users-in-db >>users
         allow-registration
@@ -108,4 +108,6 @@ http.server.sessions.storage.db ;
         init-sessions-table
     ] with-db
 
-     main-responder set-global ;
+    
+         "todo" add-responder
+    main-responder set-global ;
diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml
index a76ed2730f..81a5d3a425 100644
--- a/extra/webapps/todo/todo.xml
+++ b/extra/webapps/todo/todo.xml
@@ -8,7 +8,7 @@
 
 	

 		  List Items
-		| New Items
+		| Add Item
 
 		
 			| Edit Profile