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/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor index af4ddd8839..7176486f8e 100755 --- a/extra/farkup/farkup-tests.factor +++ b/extra/farkup/farkup-tests.factor @@ -54,10 +54,12 @@ 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 [ "

\"teh

" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test [ "

" ] [ "[[lol.com]]" convert-farkup ] unit-test [ "

haha

" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test + +[ ] [ "[{}]" convert-farkup drop ] unit-test diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor index f876c9569b..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 ; + [ + [ + 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 ; diff --git a/extra/http/http.factor b/extra/http/http.factor index e792802b5a..9e31855e53 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -394,13 +394,18 @@ body ; [ unparse-cookies "set-cookie" pick set-at ] when* write-header ; +GENERIC: write-response-body* ( body -- ) + +M: f write-response-body* drop ; + +M: string write-response-body* write ; + +M: callable write-response-body* call ; + +M: object write-response-body* stdio get stream-copy ; + : write-response-body ( response -- response ) - dup body>> { - { [ dup not ] [ drop ] } - { [ dup string? ] [ write ] } - { [ dup callable? ] [ call ] } - [ stdio get stream-copy ] - } cond ; + dup body>> write-response-body* ; M: response write-response ( respose -- ) write-response-version 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..b0cc0c21d1 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 @@ -62,10 +68,7 @@ M: user-saver dispose [ blank-values ] >>init - [ - "text/html" - [ form edit-form ] >>body - ] >>display + [ form edit-form ] >>display [ blank-values @@ -86,7 +89,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 @@ -114,10 +117,7 @@ SYMBOL: user-exists? [ blank-values ] >>init - [ - "text/html" - [ form edit-form ] >>body - ] >>display + [ form edit-form ] >>display [ blank-values @@ -147,7 +147,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 @@ -168,10 +168,7 @@ SYMBOL: previous-page dup email>> "email" set-value ] >>init - [ - "text/html" - [ form edit-form ] >>body - ] >>display + [ form edit-form ] >>display [ blank-values @@ -242,7 +239,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 @@ -256,10 +253,7 @@ SYMBOL: lost-password-from [ blank-values ] >>init - [ - "text/html" - [ form edit-form ] >>body - ] >>display + [ form edit-form ] >>display [ blank-values @@ -271,13 +265,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 @@ -308,10 +302,7 @@ SYMBOL: lost-password-from ] H{ } make-assoc values set ] >>init - [ - "text/html" - [ edit-form ] >>body - ] >>display + [ edit-form ] >>display [ blank-values @@ -326,8 +317,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 +357,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..4e847cff70 --- /dev/null +++ b/extra/http/server/boilerplate/boilerplate.factor @@ -0,0 +1,58 @@ +! 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 +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: nested-template? + +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 + + [ + [ + nested-template? on + write-response-body* + ] with-string-writer + next-template set + ] + [ call-template ] + bi* + ] 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..6d3a048ac4 100755 --- a/extra/http/server/components/components-tests.factor +++ b/extra/http/server/components/components-tests.factor @@ -1,11 +1,10 @@ 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 +tuple-syntax mirrors +http http.server.actions http.server.templating.fhtml io.streams.string io.streams.null ; -\ render-edit must-infer - validation-failed? off [ 3 ] [ "3" "n" validate ] unit-test @@ -49,8 +48,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 @@ -64,9 +63,9 @@ TUPLE: test-tuple text number more-text ; "hi" >>default add-field ; -[ ] [ values set view-form ] unit-test +[ ] [ values set view-form write-response-body drop ] unit-test -[ ] [ values set edit-form ] unit-test +[ ] [ values set edit-form write-response-body drop ] unit-test [ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [ from-tuple diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor index 1e5e33c4a0..50353c6b87 100755 --- a/extra/http/server/components/components.factor +++ b/extra/http/server/components/components.factor @@ -7,9 +7,12 @@ continuations math ; IN: http.server.components ! Renderer protocol +GENERIC: render-summary* ( value renderer -- ) GENERIC: render-view* ( value renderer -- ) GENERIC: render-edit* ( value id renderer -- ) +M: object render-summary* render-view* ; + TUPLE: field type ; C: field @@ -203,22 +206,67 @@ 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 ; + +! List components +SYMBOL: +plain+ +SYMBOL: +ordered+ +SYMBOL: +unordered+ + +TUPLE: list-renderer component type ; + +C: list-renderer + +: render-list ( value component -- ) + [ render-summary* ] curry each ; + +: render-ordered-list ( value component -- ) + [
  • render-summary*
    • ] curry each ; + +: render-unordered-list ( value component -- ) + [
  • render-summary*
    • ] curry each ; + +M: list-renderer render-view* + [ component>> ] [ type>> ] bi { + { +plain+ [ render-list ] } + { +ordered+ [
      render-ordered-list
    ] } + { +unordered+ [
      render-unordered-list
    ] } + } case ; + +TUPLE: list < component ; + +: ( id component type -- list ) + list swap new-component ; + +M: list component-string drop ; 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..65de881adb 100755 --- a/extra/http/server/crud/crud.factor +++ b/extra/http/server/crud/crud.factor @@ -15,49 +15,33 @@ IN: http.server.crud [ "id" get ctor call select-tuple from-tuple ] >>init - [ - "text/html" - [ form view-form ] >>body - ] >>display ; + [ form view-form ] >>display ; : ( 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 [ - "text/html" - [ form edit-form ] >>body - ] >>display + "id" get ctor call + + "id" get + [ select-tuple from-tuple ] + [ from-tuple form set-defaults ] + if + ] >>init + + [ form edit-form ] >>display [ f ctor call from-tuple form validate-form - values-tuple update-tuple + values-tuple + "id" value [ update-tuple ] [ insert-tuple ] if "id" value next ] >>submit ; @@ -71,3 +55,13 @@ IN: http.server.crud next f ] >>submit ; + +:: ( form ctor -- action ) + + [ + blank-values + + f ctor call select-tuples "list" set-value + + form view-form + ] >>display ; diff --git a/extra/http/server/forms/forms.factor b/extra/http/server/forms/forms.factor index cf8fd4ca8c..1b4f7f4d37 100644 --- a/extra/http/server/forms/forms.factor +++ b/extra/http/server/forms/forms.factor @@ -1,11 +1,16 @@ -USING: kernel accessors assocs namespaces io.files fry +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors assocs namespaces io.files sequences fry +http.server 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 ; @@ -15,8 +20,11 @@ M: form init V{ } clone >>components ; : add-field ( form component -- form ) dup id>> pick components>> set-at ; +: set-components ( form -- ) + components>> components set ; + : with-form ( form quot -- ) - >r components>> components r> with-variable ; inline + [ [ set-components ] [ call ] bi* ] with-scope ; inline : set-defaults ( form -- ) [ @@ -27,11 +35,16 @@ M: form init V{ } clone >>components ; ] assoc-each ] with-form ; -: view-form ( form -- ) - dup view-template>> '[ , run-template ] with-form ; +: ( form template -- response ) + [ components>> components set ] + [ "text/html" swap >>body ] + bi* ; -: edit-form ( form -- ) - dup edit-template>> '[ , run-template ] with-form ; +: view-form ( form -- response ) + dup view-template>> ; + +: edit-form ( form -- response ) + dup edit-template>> ; : validate-param ( id component -- ) [ [ params get at ] [ validate ] bi* ] @@ -46,3 +59,20 @@ M: form init V{ } clone >>components ; : validate-form ( form -- ) (validate-form) [ validation-failed ] when ; + +: render-form ( value form template -- ) + [ + [ from-tuple ] + [ set-components ] + [ call-template ] + tri* + ] with-scope ; + +M: form render-summary* + dup summary-template>> render-form ; + +M: form render-view* + dup view-template>> render-form ; + +M: form render-edit* + dup edit-template>> render-form ; 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..06cf2936ce --- /dev/null +++ b/extra/http/server/templating/chloe/chloe.factor @@ -0,0 +1,174 @@ +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 + + nested-template? get [ + process-template + ] [ + { + [ xml-prolog write-prolog ] + [ xml-before write-chunk ] + [ process-template ] + [ xml-after write-chunk ] + } cleave + ] if + ] with-scope ; + +M: chloe call-template + path>> utf8 read-xml process-chloe ; + +INSTANCE: chloe template 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..1cba4b9b2e 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,10 @@ 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 ; + +INSTANCE: fhtml template diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor new file mode 100644 index 0000000000..f69dd9bfe0 --- /dev/null +++ b/extra/http/server/templating/templating.factor @@ -0,0 +1,17 @@ +USING: accessors kernel fry io.encodings.utf8 io.files +http http.server ; +IN: http.server.templating + +MIXIN: template + +GENERIC: call-template ( template -- ) + +M: template write-response-body* call-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/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 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..c2e8a7fd79 --- /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; +} + +.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..917b9bf7a7 --- /dev/null +++ b/extra/webapps/todo/todo.factor @@ -0,0 +1,113 @@ +! 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: webapps.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" +plain+ + 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 + + + "todo" add-responder + main-responder set-global ; diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml new file mode 100644 index 0000000000..81a5d3a425 --- /dev/null +++ b/extra/webapps/todo/todo.xml @@ -0,0 +1,26 @@ + + + + + + + + +
    + List Items + | Add Item + + + | 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 + | + + + + + +     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 ; diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor index 62f0f6ede3..22d3217ee6 100755 --- a/extra/xmode/catalog/catalog.factor +++ b/extra/xmode/catalog/catalog.factor @@ -36,9 +36,13 @@ TAGS> f \ modes set-global ; MEMO: (load-mode) ( name -- rule-sets ) - modes at mode-file - "extra/xmode/modes/" prepend - resource-path utf8 parse-mode ; + modes at [ + mode-file + "extra/xmode/modes/" prepend + resource-path utf8 parse-mode + ] [ + "text" (load-mode) + ] if* ; SYMBOL: rule-sets