From 8dfe287e90c0e63f42afe9787d1510f86079f603 Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Sat, 12 Apr 2008 18:24:31 -0300
Subject: [PATCH 01/66] qualified: fixing docs a bit.
---
extra/qualified/qualified-docs.factor | 12 ++++++++++++
1 file changed, 12 insertions(+)
diff --git a/extra/qualified/qualified-docs.factor b/extra/qualified/qualified-docs.factor
index d336d31114..49ff4e9374 100755
--- a/extra/qualified/qualified-docs.factor
+++ b/extra/qualified/qualified-docs.factor
@@ -15,19 +15,31 @@ HELP: QUALIFIED-WITH:
HELP: FROM:
{ $syntax "FROM: vocab => words ... ;" }
+<<<<<<< HEAD:extra/qualified/qualified-docs.factor
+{ $description "Imports " { $snippet "words" } " from " { $snippet "vocab" } "." }
+=======
{ $description "Imports the specified words from vocab." }
+>>>>>>> 04e914c... qualified: fixing docs a bit.:extra/qualified/qualified-docs.factor
{ $examples { $code
"FROM: math.parser => bin> hex> ; ! imports only bin> and hex>" } } ;
HELP: EXCLUDE:
{ $syntax "EXCLUDE: vocab => words ... ;" }
+<<<<<<< HEAD:extra/qualified/qualified-docs.factor
+{ $description "Imports everything from " { $snippet "vocab" } " excluding " { $snippet "words" } "." }
+=======
{ $description "Imports everything from vocab excluding the specified words" }
+>>>>>>> 04e914c... qualified: fixing docs a bit.:extra/qualified/qualified-docs.factor
{ $examples { $code
"EXCLUDE: math.parser => bin> hex> ; ! imports everythin but bin> and hex>" } } ;
HELP: RENAME:
{ $syntax "RENAME: word vocab => newname " }
+<<<<<<< HEAD:extra/qualified/qualified-docs.factor
+{ $description "Imports " { $snippet "word" } " from " { $snippet "vocab" } ", but renamed to " { $snippet "newname" } "." }
+=======
{ $description "Imports word from vocab, but renamed to newname." }
+>>>>>>> 04e914c... qualified: fixing docs a bit.:extra/qualified/qualified-docs.factor
{ $examples { $code
"RENAME: + math => -"
"2 3 - ! => 5" } } ;
From 7ef3109ff142c6cb5fa514432d4dbabf4457d4ec Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Sat, 12 Apr 2008 18:27:04 -0300
Subject: [PATCH 02/66] qualified: another docs fix
---
extra/qualified/qualified-docs.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/qualified/qualified-docs.factor b/extra/qualified/qualified-docs.factor
index 49ff4e9374..2c707c5bae 100755
--- a/extra/qualified/qualified-docs.factor
+++ b/extra/qualified/qualified-docs.factor
@@ -8,8 +8,8 @@ HELP: QUALIFIED:
"QUALIFIED: math\n1 2 math:+ ! ==> 3" } } ;
HELP: QUALIFIED-WITH:
-{ $syntax "QUALIFIED-WITH: vocab prefix" }
-{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses the specified prefix." }
+{ $syntax "QUALIFIED-WITH: vocab word-prefix" }
+{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses " { $snippet "word-prefix" } " as prefix." }
{ $examples { $code
"QUALIFIED-WITH: math m\n1 2 m:+ ! ==> 3" } } ;
From 2f4cec443c229b99457741b36c7ae85331150b42 Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Sat, 12 Apr 2008 19:09:46 -0300
Subject: [PATCH 03/66] qualified: docs fix
---
extra/qualified/qualified-docs.factor | 12 ------------
1 file changed, 12 deletions(-)
diff --git a/extra/qualified/qualified-docs.factor b/extra/qualified/qualified-docs.factor
index 2c707c5bae..c5cb088db3 100755
--- a/extra/qualified/qualified-docs.factor
+++ b/extra/qualified/qualified-docs.factor
@@ -15,31 +15,19 @@ HELP: QUALIFIED-WITH:
HELP: FROM:
{ $syntax "FROM: vocab => words ... ;" }
-<<<<<<< HEAD:extra/qualified/qualified-docs.factor
{ $description "Imports " { $snippet "words" } " from " { $snippet "vocab" } "." }
-=======
-{ $description "Imports the specified words from vocab." }
->>>>>>> 04e914c... qualified: fixing docs a bit.:extra/qualified/qualified-docs.factor
{ $examples { $code
"FROM: math.parser => bin> hex> ; ! imports only bin> and hex>" } } ;
HELP: EXCLUDE:
{ $syntax "EXCLUDE: vocab => words ... ;" }
-<<<<<<< HEAD:extra/qualified/qualified-docs.factor
{ $description "Imports everything from " { $snippet "vocab" } " excluding " { $snippet "words" } "." }
-=======
-{ $description "Imports everything from vocab excluding the specified words" }
->>>>>>> 04e914c... qualified: fixing docs a bit.:extra/qualified/qualified-docs.factor
{ $examples { $code
"EXCLUDE: math.parser => bin> hex> ; ! imports everythin but bin> and hex>" } } ;
HELP: RENAME:
{ $syntax "RENAME: word vocab => newname " }
-<<<<<<< HEAD:extra/qualified/qualified-docs.factor
{ $description "Imports " { $snippet "word" } " from " { $snippet "vocab" } ", but renamed to " { $snippet "newname" } "." }
-=======
-{ $description "Imports word from vocab, but renamed to newname." }
->>>>>>> 04e914c... qualified: fixing docs a bit.:extra/qualified/qualified-docs.factor
{ $examples { $code
"RENAME: + math => -"
"2 3 - ! => 5" } } ;
From a96deb5995a5d67cca1f0ccab2b4372bea71a9da Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Wed, 7 May 2008 17:15:31 -0300
Subject: [PATCH 04/66] Fix typo
---
extra/qualified/qualified-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/qualified/qualified-docs.factor b/extra/qualified/qualified-docs.factor
index c5cb088db3..d62f696a74 100755
--- a/extra/qualified/qualified-docs.factor
+++ b/extra/qualified/qualified-docs.factor
@@ -23,7 +23,7 @@ HELP: EXCLUDE:
{ $syntax "EXCLUDE: vocab => words ... ;" }
{ $description "Imports everything from " { $snippet "vocab" } " excluding " { $snippet "words" } "." }
{ $examples { $code
- "EXCLUDE: math.parser => bin> hex> ; ! imports everythin but bin> and hex>" } } ;
+ "EXCLUDE: math.parser => bin> hex> ; ! imports everything but bin> and hex>" } } ;
HELP: RENAME:
{ $syntax "RENAME: word vocab => newname " }
From e8815e7bb2faefea760faccd3462b9f7298f3042 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 22 May 2008 22:41:23 -0500
Subject: [PATCH 05/66] Moving validators to their own vocabulary
---
extra/validators/validators-tests.factor | 70 +++++++++++
extra/validators/validators.factor | 142 +++++++++++++++++++++++
2 files changed, 212 insertions(+)
create mode 100644 extra/validators/validators-tests.factor
create mode 100644 extra/validators/validators.factor
diff --git a/extra/validators/validators-tests.factor b/extra/validators/validators-tests.factor
new file mode 100644
index 0000000000..6ed0e0363a
--- /dev/null
+++ b/extra/validators/validators-tests.factor
@@ -0,0 +1,70 @@
+IN: validators.tests
+USING: kernel sequences tools.test validators accessors ;
+
+[ "foo" v-number ] must-fail
+[ 123 ] [ "123" v-number ] unit-test
+
+[ "slava@factorcode.org" ] [
+ "slava@factorcode.org" v-email
+] unit-test
+
+[ "slava+foo@factorcode.org" ] [
+ "slava+foo@factorcode.org" v-email
+] unit-test
+
+[ "slava@factorcode.o" v-email ]
+[ "invalid e-mail" = ] must-fail-with
+
+[ "sla@@factorcode.o" v-email ]
+[ "invalid e-mail" = ] must-fail-with
+
+[ "slava@factorcodeorg" v-email ]
+[ "invalid e-mail" = ] must-fail-with
+
+[ "http://www.factorcode.org" ]
+[ "http://www.factorcode.org" v-url ] unit-test
+
+[ "http:/www.factorcode.org" v-url ]
+[ "invalid URL" = ] must-fail-with
+
+[ 14 V{ } ] [
+ [
+ "14" "age" [ drop v-number 13 v-min-value 100 v-max-value ] validate
+ ] with-validation
+] unit-test
+
+[ f t ] [
+ [
+ "140" "age" [ drop v-number 13 v-min-value 100 v-max-value ] validate
+ ] with-validation first
+ [ first "age" = ]
+ [ second validation-error? ]
+ [ second value>> "140" = ]
+ tri and and
+] unit-test
+
+TUPLE: person name age ;
+
+person {
+ { "name" [ v-required ] }
+ { "age" [ v-number 13 v-min-value 100 v-max-value ] }
+} define-validators
+
+[ 14 V{ } ] [
+ [
+ person new dup
+ { { "age" "14" } }
+ deposit-slots
+ age>>
+ ] with-validation
+] unit-test
+
+[ t ] [
+ [
+ { { "age" "" } } required-values
+ ] with-validation first
+ [ first "age" = ]
+ [ second validation-error? ]
+ [ second message>> "required" = ]
+ tri and and
+] unit-test
diff --git a/extra/validators/validators.factor b/extra/validators/validators.factor
new file mode 100644
index 0000000000..23bda8cb6c
--- /dev/null
+++ b/extra/validators/validators.factor
@@ -0,0 +1,142 @@
+! Copyright (C) 2006, 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel continuations sequences math namespaces sets
+math.parser assocs regexp fry unicode.categories sequences
+arrays hashtables words combinators mirrors classes quotations ;
+IN: validators
+
+: v-default ( str def -- str )
+ over empty? spin ? ;
+
+: 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
+ throw
+ ] [
+ drop
+ ] if ;
+
+: v-max-length ( str n -- str )
+ over length over > [
+ [ "must be no more than " % # " characters" % ] "" make
+ throw
+ ] [
+ drop
+ ] if ;
+
+: v-number ( str -- n )
+ dup string>number [ ] [ "must be a number" throw ] ?if ;
+
+: v-integer ( n -- n )
+ dup integer? [ "must be an integer" throw ] unless ;
+
+: v-min-value ( x n -- x )
+ 2dup < [
+ [ "must be at least " % # ] "" make throw
+ ] [
+ drop
+ ] if ;
+
+: v-max-value ( x n -- x )
+ 2dup > [
+ [ "must be no more than " % # ] "" make throw
+ ] [
+ drop
+ ] if ;
+
+: v-regexp ( str what regexp -- str )
+ >r over r> matches?
+ [ drop ] [ "invalid " prepend throw ] if ;
+
+: v-email ( str -- str )
+ #! From http://www.regular-expressions.info/email.html
+ "e-mail"
+ R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
+ v-regexp ;
+
+: v-url ( str -- str )
+ "URL"
+ R' (ftp|http|https)://(\w+:?\w*@)?(\S+)(:[0-9]+)?(/|/([\w#!:.?+=&%@!\-/]))?'
+ v-regexp ;
+
+: v-captcha ( str -- str )
+ dup empty? [ "must remain blank" throw ] unless ;
+
+: v-one-line ( str -- str )
+ dup "\r\n" intersect empty?
+ [ "must be a single line" throw ] unless ;
+
+: v-one-word ( str -- str )
+ dup [ alpha? ] all?
+ [ "must be a single word" throw ] unless ;
+
+SYMBOL: validation-messages
+
+: with-validation ( quot -- messages )
+ V{ } clone [
+ validation-messages rot with-variable
+ ] keep ; inline
+
+: (validation-message) ( obj -- )
+ validation-messages get push ;
+
+: (validation-message-for) ( obj name -- )
+ swap 2array (validation-message) ;
+
+TUPLE: validation-message message ;
+
+C: <validation-message> validation-message
+
+: validation-message ( string -- )
+ <validation-message> (validation-message) ;
+
+: validation-message-for ( string name -- )
+ [ <validation-message> ] dip (validation-message-for) ;
+
+TUPLE: validation-error value message ;
+
+C: <validation-error> validation-error
+
+: validation-error ( reason -- )
+ f <validation-error> (validation-message) ;
+
+: validation-error-for ( reason value name -- )
+ [ <validation-error> ] dip (validation-message-for) ;
+
+: validation-failed? ( -- ? )
+ validation-messages get [
+ dup pair? [ second ] when validation-error?
+ ] contains? ;
+
+: define-validators ( class validators -- )
+ >hashtable "validators" set-word-prop ;
+
+: validate ( value name quot -- result )
+ [ swap validation-error-for f ] recover ; inline
+
+: validate-value ( value name validators -- result )
+ '[
+ , at {
+ { [ dup pair? ] [ first ] }
+ { [ dup quotation? ] [ ] }
+ } cond call
+ ] validate ;
+
+: required-values ( assoc -- )
+ [ swap [ drop v-required ] validate drop ] assoc-each ;
+
+: validate-values ( assoc validators -- assoc' )
+ '[ over , validate-value ] assoc-map ;
+
+: deposit-values ( destination assoc validators -- )
+ validate-values update ;
+
+: deposit-slots ( tuple assoc -- )
+ [ [ <mirror> ] [ class "validators" word-prop ] bi ] dip
+ swap deposit-values ;
From 3ee56c3a68eea3570d0cb0cb61df30ff84ba2831 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 22 May 2008 22:41:48 -0500
Subject: [PATCH 06/66] Add extract-keys word
---
core/assocs/assocs-tests.factor | 14 ++++++++++++++
core/assocs/assocs.factor | 3 +++
.../standard/engines/predicate/predicate.factor | 3 +--
core/inference/class/class.factor | 12 ++++++------
4 files changed, 24 insertions(+), 8 deletions(-)
diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor
index 30f2ec23c4..43a1bac82d 100755
--- a/core/assocs/assocs-tests.factor
+++ b/core/assocs/assocs-tests.factor
@@ -104,3 +104,17 @@ unit-test
2drop
] { } make
] unit-test
+
+[
+ H{
+ { "bangers" "mash" }
+ { "fries" "onion rings" }
+ }
+] [
+ { "bangers" "fries" } H{
+ { "fish" "chips" }
+ { "bangers" "mash" }
+ { "fries" "onion rings" }
+ { "nachos" "cheese" }
+ } extract-keys
+] unit-test
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index 92db38573a..6b0798f2e3 100755
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -150,6 +150,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: map>assoc ( seq quot exemplar -- assoc )
>r [ 2array ] compose { } map-as r> assoc-like ; inline
+: extract-keys ( seq assoc -- subassoc )
+ [ [ dupd at ] curry ] keep map>assoc ;
+
M: assoc >alist [ 2array ] { } assoc>map ;
: value-at ( value assoc -- key/f )
diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor
index b1bfc659df..9c810592a0 100644
--- a/core/generic/standard/engines/predicate/predicate.factor
+++ b/core/generic/standard/engines/predicate/predicate.factor
@@ -22,8 +22,7 @@ C: <predicate-dispatch-engine> predicate-dispatch-engine
} cond ;
: sort-methods ( assoc -- assoc' )
- [ keys sort-classes ]
- [ [ dupd at ] curry ] bi { } map>assoc ;
+ >alist [ keys sort-classes ] keep extract-keys ;
M: predicate-dispatch-engine engine>quot
methods>> clone
diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor
index 933710aaca..dc632425fe 100755
--- a/core/inference/class/class.factor
+++ b/core/inference/class/class.factor
@@ -152,16 +152,16 @@ M: pair apply-constraint
M: pair constraint-satisfied?
first constraint-satisfied? ;
-: extract-keys ( seq assoc -- newassoc )
- [ dupd at ] curry H{ } map>assoc [ nip ] assoc-filter f assoc-like ;
+: valid-keys ( seq assoc -- newassoc )
+ extract-keys [ nip ] assoc-filter f assoc-like ;
: annotate-node ( node -- )
#! Annotate the node with the currently-inferred set of
#! value classes.
dup node-values {
- [ value-intervals get extract-keys >>intervals ]
- [ value-classes get extract-keys >>classes ]
- [ value-literals get extract-keys >>literals ]
+ [ value-intervals get valid-keys >>intervals ]
+ [ value-classes get valid-keys >>classes ]
+ [ value-literals get valid-keys >>literals ]
[ 2drop ]
} cleave ;
@@ -330,7 +330,7 @@ M: #return infer-classes-around
[ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
classes= not [
fixed-point? off
- [ in-d>> value-classes get extract-keys ] keep
+ [ in-d>> value-classes get valid-keys ] keep
set-node-classes
] [ drop ] if
] [ call-next-method ] if
From f693c69c406a96ef03c33b821be9805d3bc51179 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 May 2008 17:33:31 -0500
Subject: [PATCH 07/66] Move HTML components to html.components, refactor
---
extra/html/components/components-tests.factor | 145 +++++++++++++++++
extra/html/components/components.factor | 150 ++++++++++++++++++
extra/html/elements/elements-tests.factor | 7 +-
extra/html/elements/elements.factor | 66 +++++---
extra/html/{ => streams}/authors.txt | 0
.../streams-tests.factor} | 7 +-
.../{html.factor => streams/streams.factor} | 73 +--------
extra/html/{ => streams}/summary.txt | 0
extra/html/{ => streams}/tags.txt | 0
extra/html/stylesheet.css | 4 -
extra/validators/validators.factor | 1 +
11 files changed, 345 insertions(+), 108 deletions(-)
create mode 100644 extra/html/components/components-tests.factor
create mode 100644 extra/html/components/components.factor
rename extra/html/{ => streams}/authors.txt (100%)
rename extra/html/{html-tests.factor => streams/streams-tests.factor} (89%)
rename extra/html/{html.factor => streams/streams.factor} (71%)
rename extra/html/{ => streams}/summary.txt (100%)
rename extra/html/{ => streams}/tags.txt (100%)
delete mode 100644 extra/html/stylesheet.css
diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor
new file mode 100644
index 0000000000..6ecd2b0fa6
--- /dev/null
+++ b/extra/html/components/components-tests.factor
@@ -0,0 +1,145 @@
+IN: html.components.tests
+USING: html.components tools.test kernel io.streams.string
+io.streams.null accessors ;
+
+[ ] [ blank-values ] unit-test
+
+[ ] [ 3 "hi" set-value ] unit-test
+
+[ 3 ] [ "hi" value ] unit-test
+
+TUPLE: color red green blue ;
+
+[ ] [ 1 2 3 color boa from-tuple ] unit-test
+
+[ 1 ] [ "red" value ] unit-test
+
+[ ] [ "jimmy" "red" set-value ] unit-test
+
+[ "123.5" ] [ 123.5 object>string ] unit-test
+
+[ "jimmy" ] [
+ [
+ "red" label render
+ ] with-string-writer
+] unit-test
+
+[ ] [ "<jimmy>" "red" set-value ] unit-test
+
+[ "<jimmy>" ] [
+ [
+ "red" label render
+ ] with-string-writer
+] unit-test
+
+[ "<input type='hidden' name='red' value='<jimmy>'/>" ] [
+ [
+ "red" hidden render
+ ] with-string-writer
+] unit-test
+
+[ ] [ "'jimmy'" "red" set-value ] unit-test
+
+[ "<input type='text' size='5' name='red' value=''jimmy''/>" ] [
+ [
+ "red" <field> 5 >>size render
+ ] with-string-writer
+] unit-test
+
+[ "<input type='password' size='5' name='red' value=''/>" ] [
+ [
+ "red" <password> 5 >>size render
+ ] with-string-writer
+] unit-test
+
+[ ] [
+ [
+ "green" <textarea> render
+ ] with-null-writer
+] unit-test
+
+[ ] [
+ [
+ "green" <textarea> 25 >>rows 30 >>columns render
+ ] with-null-writer
+] unit-test
+
+[ ] [ blank-values ] unit-test
+
+[ ] [ "new york" "city1" set-value ] unit-test
+
+[ ] [
+ [
+ "city1"
+ <choice>
+ { "new york" "los angeles" "chicago" } >>choices
+ render
+ ] with-null-writer
+] unit-test
+
+[ ] [ { "los angeles" "new york" } "city2" set-value ] unit-test
+
+[ ] [
+ [
+ "city2"
+ <choice>
+ { "new york" "los angeles" "chicago" } >>choices
+ t >>multiple
+ render
+ ] with-null-writer
+] unit-test
+
+[ ] [
+ [
+ "city2"
+ <choice>
+ { "new york" "los angeles" "chicago" } >>choices
+ t >>multiple
+ 5 >>size
+ render
+ ] with-null-writer
+] unit-test
+
+[ ] [ blank-values ] unit-test
+
+[ ] [ t "delivery" set-value ] unit-test
+
+[ "<input type='checkbox' name='delivery' selected='true'>Delivery</input>" ] [
+ [
+ "delivery"
+ <checkbox>
+ "Delivery" >>label
+ render
+ ] with-string-writer
+] unit-test
+
+[ ] [ f "delivery" set-value ] unit-test
+
+[ "<input type='checkbox' name='delivery'>Delivery</input>" ] [
+ [
+ "delivery"
+ <checkbox>
+ "Delivery" >>label
+ render
+ ] with-string-writer
+] unit-test
+
+SINGLETON: link-test
+
+M: link-test link-title drop "<Link Title>" ;
+
+M: link-test link-href drop "http://www.apple.com/foo&bar" ;
+
+[ ] [ link-test "link" set-value ] unit-test
+
+[ "<a href='http://www.apple.com/foo&bar'><Link Title></a>" ] [
+ [ "link" link render ] with-string-writer
+] unit-test
+
+[ ] [
+ "<html>arbitrary <b>markup</b> for the win!</html>" "html" set-value
+] unit-test
+
+[ "<html>arbitrary <b>markup</b> for the win!</html>" ] [
+ [ "html" html render ] with-string-writer
+] unit-test
diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor
new file mode 100644
index 0000000000..ef4def8ddb
--- /dev/null
+++ b/extra/html/components/components.factor
@@ -0,0 +1,150 @@
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces io math.parser assocs classes
+classes.tuple words arrays sequences splitting mirrors
+hashtables combinators continuations math strings
+fry locals calendar calendar.format xml.entities validators
+html.elements ;
+IN: html.components
+
+SYMBOL: values
+
+: value values get at ;
+
+: set-value values get set-at ;
+
+: blank-values H{ } clone values set ;
+
+: from-tuple <mirror> values set ;
+
+: values-tuple values get object>> ;
+
+: object>string ( object -- string )
+ {
+ { [ dup real? ] [ number>string ] }
+ { [ dup timestamp? ] [ timestamp>string ] }
+ { [ dup string? ] [ ] }
+ { [ dup not ] [ drop "" ] }
+ } cond ;
+
+GENERIC: render* ( value name render -- )
+
+: render ( name renderer -- )
+ over validation-messages get at [
+ [ value>> ] [ message>> ] bi
+ [ -rot render* ] dip
+ render-error
+ ] [
+ [ [ value ] keep ] dip render*
+ ] if* ;
+
+<PRIVATE
+
+: render-input ( value name type -- )
+ <input =type =name object>string =value input/> ;
+
+PRIVATE>
+
+SINGLETON: label
+
+M: label render* 2drop object>string escape-string write ;
+
+SINGLETON: hidden
+
+M: hidden render* drop "hidden" render-input ;
+
+: render-field ( value name size type -- )
+ <input
+ =type
+ [ number>string =size ] when*
+ =name
+ object>string =value
+ input/> ;
+
+TUPLE: field size ;
+
+: <field> ( -- field )
+ field new ;
+
+M: field render* size>> "text" render-field ;
+
+TUPLE: password size ;
+
+: <password> ( -- password )
+ password new ;
+
+M: password render*
+ #! Don't send passwords back to the user
+ [ drop "" ] 2dip size>> "password" render-field ;
+
+! Text areas
+TUPLE: textarea rows columns ;
+
+: <textarea> ( -- renderer )
+ textarea new ;
+
+M: textarea render*
+ <textarea
+ [ rows>> [ number>string =rows ] when* ]
+ [ columns>> [ number>string =cols ] when* ] bi
+ =name
+ textarea>
+ object>string escape-string write
+ </textarea> ;
+
+! Choice
+TUPLE: choice size choices multiple ;
+
+: <choice> ( -- choice )
+ choice new ;
+
+: render-option ( text selected? -- )
+ <option [ "true" =selected ] when option>
+ escape-string write
+ </option> ;
+
+: render-options ( options selected -- )
+ '[ dup , member? render-option ] each ;
+
+M: choice render*
+ <select
+ swap =name
+ dup size>> [ number>string =size ] when*
+ dup multiple>> [ "true" =multiple ] when
+ select>
+ [ choices>> ] [ multiple>> ] bi
+ [ swap ] [ swap 1array ] if
+ render-options
+ </select> ;
+
+! Checkboxes
+TUPLE: checkbox label ;
+
+: <checkbox> ( -- checkbox )
+ checkbox new ;
+
+M: checkbox render*
+ <input
+ "checkbox" =type
+ swap =name
+ swap [ "true" =selected ] when
+ input>
+ label>> escape-string write
+ </input> ;
+
+! Link components
+GENERIC: link-title ( obj -- string )
+GENERIC: link-href ( obj -- url )
+
+SINGLETON: link
+
+M: link render*
+ 2drop
+ <a dup link-href =href a>
+ link-title object>string escape-string write
+ </a> ;
+
+! HTML component
+SINGLETON: html
+
+M: html render* 2drop write ;
diff --git a/extra/html/elements/elements-tests.factor b/extra/html/elements/elements-tests.factor
index aa6a017540..1178deab38 100644
--- a/extra/html/elements/elements-tests.factor
+++ b/extra/html/elements/elements-tests.factor
@@ -1,8 +1,5 @@
IN: html.elements.tests
-USING: tools.test html html.elements io.streams.string ;
-
-: make-html-string
- [ with-html-stream ] with-string-writer ;
+USING: tools.test html.elements io.streams.string ;
[ "<a href='h&o'>" ]
-[ [ <a "h&o" =href a> ] make-html-string ] unit-test
+[ [ <a "h&o" =href a> ] with-string-writer ] unit-test
diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor
index 49782fa305..e5377cedf8 100644
--- a/extra/html/elements/elements.factor
+++ b/extra/html/elements/elements.factor
@@ -57,6 +57,8 @@ SYMBOL: html
: print-html ( str -- )
write-html "\n" write-html ;
+<<
+
: html-word ( name def effect -- )
#! Define 'word creating' word to allow
#! dynamically creating words.
@@ -137,30 +139,46 @@ SYMBOL: html
dup "=" prepend swap
[ write-attr ] curry attribute-effect html-word ;
+! Define some closed HTML tags
[
- ! Define some closed HTML tags
- [
- "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
- "ol" "li" "form" "a" "p" "html" "head" "body" "title"
- "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
- "script" "div" "span" "select" "option" "style" "input"
- ] [ define-closed-html-word ] each
+ "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
+ "ol" "li" "form" "a" "p" "html" "head" "body" "title"
+ "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
+ "script" "div" "span" "select" "option" "style" "input"
+] [ define-closed-html-word ] each
- ! Define some open HTML tags
- [
- "input"
- "br"
- "link"
- "img"
- ] [ define-open-html-word ] each
+! Define some open HTML tags
+[
+ "input"
+ "br"
+ "link"
+ "img"
+] [ define-open-html-word ] each
- ! Define some attributes
- [
- "method" "action" "type" "value" "name"
- "size" "href" "class" "border" "rows" "cols"
- "id" "onclick" "style" "valign" "accesskey"
- "src" "language" "colspan" "onchange" "rel"
- "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
- "media" "title" "multiple"
- ] [ define-attribute-word ] each
-] with-compilation-unit
+! Define some attributes
+[
+ "method" "action" "type" "value" "name"
+ "size" "href" "class" "border" "rows" "cols"
+ "id" "onclick" "style" "valign" "accesskey"
+ "src" "language" "colspan" "onchange" "rel"
+ "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
+ "media" "title" "multiple"
+] [ define-attribute-word ] each
+
+>>
+
+: xhtml-preamble ( -- )
+ "<?xml version=\"1.0\"?>" write-html
+ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" write-html ;
+
+: simple-page ( title quot -- )
+ #! Call the quotation, with all output going to the
+ #! body of an html page with the given title.
+ xhtml-preamble
+ <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
+ <head> <title> swap write </title> </head>
+ <body> call </body>
+ </html> ;
+
+: render-error ( message -- )
+ <span "error" =class span> escape-string write </span> ;
diff --git a/extra/html/authors.txt b/extra/html/streams/authors.txt
similarity index 100%
rename from extra/html/authors.txt
rename to extra/html/streams/authors.txt
diff --git a/extra/html/html-tests.factor b/extra/html/streams/streams-tests.factor
similarity index 89%
rename from extra/html/html-tests.factor
rename to extra/html/streams/streams-tests.factor
index 9f1ce6b689..2084c7db18 100644
--- a/extra/html/html-tests.factor
+++ b/extra/html/streams/streams-tests.factor
@@ -1,6 +1,7 @@
-USING: html http io io.streams.string io.styles kernel
-namespaces tools.test xml.writer sbufs sequences html.private ;
-IN: html.tests
+USING: html.streams html.streams.private
+io io.streams.string io.styles kernel
+namespaces tools.test xml.writer sbufs sequences ;
+IN: html.streams.tests
: make-html-string
[ with-html-stream ] with-string-writer ; inline
diff --git a/extra/html/html.factor b/extra/html/streams/streams.factor
similarity index 71%
rename from extra/html/html.factor
rename to extra/html/streams/streams.factor
index 71862b0d01..b35f383bdc 100755
--- a/extra/html/html.factor
+++ b/extra/html/streams/streams.factor
@@ -4,7 +4,7 @@ USING: generic assocs help http io io.styles io.files continuations
io.streams.string kernel math math.order math.parser namespaces
quotations assocs sequences strings words html.elements
xml.entities sbufs continuations destructors ;
-IN: html
+IN: html.streams
GENERIC: browser-link-href ( presented -- href )
@@ -192,76 +192,5 @@ M: html-stream make-cell-stream ( style stream -- stream' )
M: html-stream stream-nl ( stream -- )
dup test-last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
-! Utilities
: with-html-stream ( quot -- )
output-stream get <html-stream> swap with-output-stream* ; inline
-
-: xhtml-preamble
- "<?xml version=\"1.0\"?>" write-html
- "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">" write-html ;
-
-: html-document ( body-quot head-quot -- )
- #! head-quot is called to produce output to go
- #! in the html head portion of the document.
- #! body-quot is called to produce output to go
- #! in the html body portion of the document.
- xhtml-preamble
- <html "http://www.w3.org/1999/xhtml" =xmlns "en" =xml:lang "en" =lang html>
- <head> call </head>
- <body> call </body>
- </html> ;
-
-: default-css ( -- )
- <link
- "stylesheet" =rel "text/css" =type
- "/responder/resources/extra/html/stylesheet.css" =href
- link/> ;
-
-: simple-html-document ( title quot -- )
- swap [
- <title> write </title>
- default-css
- ] html-document ;
-
-: vertical-layout ( list -- )
- #! Given a list of HTML components, arrange them vertically.
- <table>
- [ <tr> <td> call </td> </tr> ] each
- </table> ;
-
-: horizontal-layout ( list -- )
- #! Given a list of HTML components, arrange them horizontally.
- <table>
- <tr "top" =valign tr> [ <td> call </td> ] each </tr>
- </table> ;
-
-: button ( label -- )
- #! Output an HTML submit button with the given label.
- <input "submit" =type =value input/> ;
-
-: paragraph ( str -- )
- #! Output the string as an html paragraph
- <p> write </p> ;
-
-: simple-page ( title quot -- )
- #! Call the quotation, with all output going to the
- #! body of an html page with the given title.
- <html>
- <head> <title> swap write </title> </head>
- <body> call </body>
- </html> ;
-
-: styled-page ( title stylesheet-quot quot -- )
- #! Call the quotation, with all output going to the
- #! body of an html page with the given title. stylesheet-quot
- #! is called to generate the required stylesheet.
- <html>
- <head>
- <title> rot write </title>
- swap call
- </head>
- <body> call </body>
- </html> ;
-
-: render-error ( message -- )
- <span "error" =class span> escape-string write </span> ;
diff --git a/extra/html/summary.txt b/extra/html/streams/summary.txt
similarity index 100%
rename from extra/html/summary.txt
rename to extra/html/streams/summary.txt
diff --git a/extra/html/tags.txt b/extra/html/streams/tags.txt
similarity index 100%
rename from extra/html/tags.txt
rename to extra/html/streams/tags.txt
diff --git a/extra/html/stylesheet.css b/extra/html/stylesheet.css
deleted file mode 100644
index a1afce7c9f..0000000000
--- a/extra/html/stylesheet.css
+++ /dev/null
@@ -1,4 +0,0 @@
-a:link { text-decoration: none; color: black; }
-a:visited { text-decoration: none; color: black; }
-a:active { text-decoration: none; color: black; }
-a:hover { text-decoration: underline; color: black; }
diff --git a/extra/validators/validators.factor b/extra/validators/validators.factor
index 23bda8cb6c..9d6c4bed90 100644
--- a/extra/validators/validators.factor
+++ b/extra/validators/validators.factor
@@ -56,6 +56,7 @@ IN: validators
: v-email ( str -- str )
#! From http://www.regular-expressions.info/email.html
+ 60 v-max-length
"e-mail"
R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
v-regexp ;
From a251556024462da9e36135558f256649c4102b75 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 May 2008 17:33:57 -0500
Subject: [PATCH 08/66] Add failing unit tests
---
core/classes/classes-tests.factor | 9 +++++++++
core/parser/parser-tests.factor | 7 +++++++
2 files changed, 16 insertions(+)
diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor
index bb9fbd0167..8d20da78b5 100755
--- a/core/classes/classes-tests.factor
+++ b/core/classes/classes-tests.factor
@@ -160,3 +160,12 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
[ t ] [ 3 number instance? ] unit-test
[ f ] [ 3 null instance? ] unit-test
[ t ] [ "hi" \ hi-tag instance? ] unit-test
+
+! Regression
+GENERIC: method-forget-test
+TUPLE: method-forget-class ;
+M: method-forget-class method-forget-test ;
+
+[ f ] [ \ method-forget-test "methods" assoc-empty? ] unit-test
+[ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test
+[ t ] [ \ method-forget-test "methods" assoc-empty? ] unit-test
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index 3df9dc9cb2..6f31b0ad7c 100755
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -460,3 +460,10 @@ must-fail-with
"change-combination" "parser.tests" lookup
"methods" word-prop assoc-size
] unit-test
+
+[ [ ] ] [
+ 2 [
+ "IN: classes.tests DEFER: twice-fails FORGET: twice-fails MIXIN: twice-fails"
+ <string-reader> "twice-fails-test" parse-stream
+ ] times
+] unit-test
From cee6ab6770f6aa90dbb085ba08c21e1139a0a8cf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 May 2008 17:45:00 -0500
Subject: [PATCH 09/66] Add unit test to prevent future screwups
---
core/prettyprint/prettyprint-tests.factor | 2 ++
1 file changed, 2 insertions(+)
diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor
index ed6b2f3c3c..f5ec263f11 100755
--- a/core/prettyprint/prettyprint-tests.factor
+++ b/core/prettyprint/prettyprint-tests.factor
@@ -342,3 +342,5 @@ INTERSECTION: intersection-see-test sequence number ;
[ ] [ \ compose see ] unit-test
[ ] [ \ curry see ] unit-test
+
+[ "POSTPONE: [" ] [ \ [ unparse ] unit-test
From 3a6532a9f89e91a04389d885119de255780cc4f9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 May 2008 17:45:14 -0500
Subject: [PATCH 10/66] Update html.streams usages
---
extra/farkup/farkup-tests.factor | 2 +-
extra/farkup/farkup.factor | 10 ++++------
extra/xmode/code2html/code2html.factor | 8 ++++----
3 files changed, 9 insertions(+), 11 deletions(-)
diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor
index 7176486f8e..4d235a054c 100755
--- a/extra/farkup/farkup-tests.factor
+++ b/extra/farkup/farkup-tests.factor
@@ -54,7 +54,7 @@ IN: farkup.tests
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
-[ "<div style='white-space: pre; font-family: monospace; '><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/></div>" ]
+[ "<pre><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span>\n</pre>" ]
[ "[c{int main()}]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor
index 15b7b4b72c..860fdba3af 100755
--- a/extra/farkup/farkup.factor
+++ b/extra/farkup/farkup.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
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
+splitting io.streams.string peg.parsers
sequences.deep unicode.categories ;
IN: farkup
@@ -56,11 +56,9 @@ MEMO: eq ( -- parser )
: render-code ( string mode -- string' )
>r string-lines r>
[
- [
- H{ { wrap-margin f } } [
- htmlize-lines
- ] with-nesting
- ] with-html-stream
+ <pre>
+ htmlize-lines
+ </pre>
] with-string-writer ;
: check-url ( href -- href' )
diff --git a/extra/xmode/code2html/code2html.factor b/extra/xmode/code2html/code2html.factor
index 3977f4277c..a9384ad861 100755
--- a/extra/xmode/code2html/code2html.factor
+++ b/extra/xmode/code2html/code2html.factor
@@ -1,12 +1,12 @@
USING: xmode.tokens xmode.marker xmode.catalog kernel html
html.elements io io.files sequences words io.encodings.utf8
-namespaces ;
+namespaces xml.entities ;
IN: xmode.code2html
: htmlize-tokens ( tokens -- )
[
dup token-str swap token-id [
- <span word-name =class span> write </span>
+ <span word-name =class span> escape-string write </span>
] [
write
] if*
@@ -21,7 +21,7 @@ IN: xmode.code2html
: default-stylesheet ( -- )
<style>
"resource:extra/xmode/code2html/stylesheet.css"
- utf8 file-contents write
+ utf8 file-contents escape-string write
</style> ;
: htmlize-stream ( path stream -- )
@@ -29,7 +29,7 @@ IN: xmode.code2html
<html>
<head>
default-stylesheet
- <title> dup write </title>
+ <title> dup escape-string write </title>
</head>
<body>
<pre>
From 23c0d0fc9324f91e449d096429248fcb432dce5b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 May 2008 17:45:33 -0500
Subject: [PATCH 11/66] Another html.streasm usage
---
extra/http/server/server.factor | 14 ++++++++------
1 file changed, 8 insertions(+), 6 deletions(-)
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index 4e561220f9..c1684c4ed2 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -1,10 +1,10 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces io io.timeouts strings splitting
-threads sequences prettyprint io.server logging calendar
-http html html.elements accessors math.parser combinators.lib
+threads sequences prettyprint io.server logging calendar http
+html.streams html.elements accessors math.parser combinators.lib
tools.vocabs debugger continuations random combinators
-destructors io.encodings.8-bit fry classes words ;
+destructors io.encodings.8-bit fry classes words math ;
IN: http.server
! path is a sequence of path component strings
@@ -274,9 +274,11 @@ SYMBOL: exit-continuation
] with-destructors ;
: httpd ( port -- )
- internet-server "http.server"
- latin1 [ handle-client ] with-server ;
+ dup integer? [ internet-server ] when
+ "http.server" latin1
+ [ handle-client ] with-server ;
-: httpd-main ( -- ) 8888 httpd ;
+: httpd-main ( -- )
+ 8888 httpd ;
MAIN: httpd-main
From 8327449a65a95f95139cf3bd8eeeeddf637e1a72 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 May 2008 19:16:21 -0500
Subject: [PATCH 12/66] Move templates to html vocabulary
---
extra/html/components/components-tests.factor | 10 ++-
extra/html/components/components.factor | 8 +-
.../templates}/chloe/chloe-tests.factor | 10 +--
.../templates}/chloe/chloe.factor | 78 ++++++++++-------
.../templates}/chloe/test/test1.xml | 0
.../templates}/chloe/test/test2.xml | 0
.../templates}/chloe/test/test3-aux.xml | 0
.../templates}/chloe/test/test3.xml | 0
.../templates}/chloe/test/test4.xml | 2 +-
.../templates}/chloe/test/test5.xml | 2 +-
.../templates}/chloe/test/test6.xml | 2 +-
.../templates}/chloe/test/test7.xml | 2 +-
.../templates}/fhtml/authors.txt | 0
.../templates}/fhtml/fhtml-tests.factor | 6 +-
.../templates}/fhtml/fhtml.factor | 43 +++-------
.../templates}/fhtml/test/bug.fhtml | 0
.../templates}/fhtml/test/bug.html | 0
.../templates}/fhtml/test/example.fhtml | 0
.../templates}/fhtml/test/example.html | 0
.../templates}/fhtml/test/stack.fhtml | 0
.../templates}/fhtml/test/stack.html | 0
extra/html/templates/templates.factor | 85 +++++++++++++++++++
.../http/server/templating/templating.factor | 27 ------
extra/validators/validators.factor | 7 +-
24 files changed, 169 insertions(+), 113 deletions(-)
rename extra/{http/server/templating => html/templates}/chloe/chloe-tests.factor (84%)
rename extra/{http/server/templating => html/templates}/chloe/chloe.factor (80%)
rename extra/{http/server/templating => html/templates}/chloe/test/test1.xml (100%)
rename extra/{http/server/templating => html/templates}/chloe/test/test2.xml (100%)
rename extra/{http/server/templating => html/templates}/chloe/test/test3-aux.xml (100%)
rename extra/{http/server/templating => html/templates}/chloe/test/test3.xml (100%)
rename extra/{http/server/templating => html/templates}/chloe/test/test4.xml (62%)
rename extra/{http/server/templating => html/templates}/chloe/test/test5.xml (62%)
rename extra/{http/server/templating => html/templates}/chloe/test/test6.xml (62%)
rename extra/{http/server/templating => html/templates}/chloe/test/test7.xml (62%)
rename extra/{http/server/templating => html/templates}/fhtml/authors.txt (100%)
rename extra/{http/server/templating => html/templates}/fhtml/fhtml-tests.factor (74%)
rename extra/{http/server/templating => html/templates}/fhtml/fhtml.factor (62%)
rename extra/{http/server/templating => html/templates}/fhtml/test/bug.fhtml (100%)
rename extra/{http/server/templating => html/templates}/fhtml/test/bug.html (100%)
rename extra/{http/server/templating => html/templates}/fhtml/test/example.fhtml (100%)
rename extra/{http/server/templating => html/templates}/fhtml/test/example.html (100%)
rename extra/{http/server/templating => html/templates}/fhtml/test/stack.fhtml (100%)
rename extra/{http/server/templating => html/templates}/fhtml/test/stack.html (100%)
create mode 100644 extra/html/templates/templates.factor
delete mode 100644 extra/http/server/templating/templating.factor
diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor
index 6ecd2b0fa6..0bd5410a3b 100644
--- a/extra/html/components/components-tests.factor
+++ b/extra/html/components/components-tests.factor
@@ -60,7 +60,7 @@ TUPLE: color red green blue ;
[ ] [
[
- "green" <textarea> 25 >>rows 30 >>columns render
+ "green" <textarea> 25 >>rows 30 >>cols render
] with-null-writer
] unit-test
@@ -68,11 +68,13 @@ TUPLE: color red green blue ;
[ ] [ "new york" "city1" set-value ] unit-test
+[ ] [ { "new york" "los angeles" "chicago" } "cities" set-value ] unit-test
+
[ ] [
[
"city1"
<choice>
- { "new york" "los angeles" "chicago" } >>choices
+ "cities" >>choices
render
] with-null-writer
] unit-test
@@ -83,7 +85,7 @@ TUPLE: color red green blue ;
[
"city2"
<choice>
- { "new york" "los angeles" "chicago" } >>choices
+ "cities" >>choices
t >>multiple
render
] with-null-writer
@@ -93,7 +95,7 @@ TUPLE: color red green blue ;
[
"city2"
<choice>
- { "new york" "los angeles" "chicago" } >>choices
+ "cities" >>choices
t >>multiple
5 >>size
render
diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor
index ef4def8ddb..df1d1faa72 100644
--- a/extra/html/components/components.factor
+++ b/extra/html/components/components.factor
@@ -78,7 +78,7 @@ M: password render*
[ drop "" ] 2dip size>> "password" render-field ;
! Text areas
-TUPLE: textarea rows columns ;
+TUPLE: textarea rows cols ;
: <textarea> ( -- renderer )
textarea new ;
@@ -86,14 +86,14 @@ TUPLE: textarea rows columns ;
M: textarea render*
<textarea
[ rows>> [ number>string =rows ] when* ]
- [ columns>> [ number>string =cols ] when* ] bi
+ [ cols>> [ number>string =cols ] when* ] bi
=name
textarea>
object>string escape-string write
</textarea> ;
! Choice
-TUPLE: choice size choices multiple ;
+TUPLE: choice size multiple choices ;
: <choice> ( -- choice )
choice new ;
@@ -112,7 +112,7 @@ M: choice render*
dup size>> [ number>string =size ] when*
dup multiple>> [ "true" =multiple ] when
select>
- [ choices>> ] [ multiple>> ] bi
+ [ choices>> value ] [ multiple>> ] bi
[ swap ] [ swap 1array ] if
render-options
</select> ;
diff --git a/extra/http/server/templating/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor
similarity index 84%
rename from extra/http/server/templating/chloe/chloe-tests.factor
rename to extra/html/templates/chloe/chloe-tests.factor
index 61f72a2f14..3c52153eee 100644
--- a/extra/http/server/templating/chloe/chloe-tests.factor
+++ b/extra/html/templates/chloe/chloe-tests.factor
@@ -1,8 +1,8 @@
-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
+USING: html.templates html.templates.chloe
+tools.test io.streams.string kernel sequences ascii boxes
+namespaces xml
splitting ;
-IN: http.server.templating.chloe.tests
+IN: html.templates.chloe.tests
[ f ] [ f parse-query-attr ] unit-test
@@ -26,7 +26,7 @@ IN: http.server.templating.chloe.tests
"?>" split1 nip ; inline
: test-template ( name -- template )
- "resource:extra/http/server/templating/chloe/test/"
+ "resource:extra/html/templates/chloe/test/"
swap
".xml" 3append <chloe> ;
diff --git a/extra/http/server/templating/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor
similarity index 80%
rename from extra/http/server/templating/chloe/chloe.factor
rename to extra/html/templates/chloe/chloe.factor
index c3d93f5909..a01d424eb9 100644
--- a/extra/http/server/templating/chloe/chloe.factor
+++ b/extra/html/templates/chloe/chloe.factor
@@ -3,13 +3,14 @@
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize
io io.files io.encodings.utf8 io.streams.string
-unicode.case tuple-syntax html html.elements
+unicode.case tuple-syntax mirrors fry
multiline xml xml.data xml.writer xml.utilities
+html.elements
+html.components
http.server
http.server.auth
http.server.flows
http.server.actions
-http.server.components
http.server.sessions
http.server.templating
http.server.boilerplate ;
@@ -52,8 +53,11 @@ MEMO: chloe-name ( string -- name )
: optional-attr ( tag name -- value )
chloe-name swap at ;
+: process-tag-children ( tag -- )
+ [ process-template ] each ;
+
: children>string ( tag -- string )
- [ [ process-template ] each ] with-string-writer ;
+ [ process-tag-children ] with-string-writer ;
: title-tag ( tag -- )
children>string set-title ;
@@ -89,18 +93,6 @@ MEMO: chloe-name ( string -- name )
atom-feed get value>> second write
] if ;
-: component-attr ( tag -- name )
- "component" required-attr ;
-
-: view-tag ( tag -- )
- component-attr component render-view ;
-
-: edit-tag ( tag -- )
- component-attr component render-edit ;
-
-: summary-tag ( tag -- )
- component-attr component render-summary ;
-
: parse-query-attr ( string -- assoc )
dup empty?
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
@@ -133,9 +125,6 @@ MEMO: chloe-name ( string -- name )
a>
] with-scope ;
-: process-tag-children ( tag -- )
- [ process-template ] each ;
-
: a-tag ( tag -- )
[ a-start-tag ]
[ process-tag-children ]
@@ -156,7 +145,7 @@ MEMO: chloe-name ( string -- name )
form>
] [
hidden-form-field
- "for" optional-attr [ component render-edit ] when*
+ "for" optional-attr [ hidden render ] when*
] bi
] with-scope ;
@@ -180,9 +169,9 @@ STRING: button-tag-markup
: button-tag ( tag -- )
button-tag-markup string>xml delegate
{
- [ >r tag-attrs chloe-attrs-only r> add-tag-attrs ]
- [ >r tag-attrs non-chloe-attrs-only r> "button" tag-named add-tag-attrs ]
- [ >r children>string 1array r> "button" tag-named set-tag-children ]
+ [ [ tag-attrs chloe-attrs-only ] dip add-tag-attrs ]
+ [ [ tag-attrs non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
+ [ [ children>string 1array ] dip "button" tag-named set-tag-children ]
[ nip ]
} 2cleave process-chloe-tag ;
@@ -211,27 +200,58 @@ STRING: button-tag-markup
: error-message-tag ( tag -- )
children>string render-error ;
+: validation-messages-tag ( tag -- )
+ drop render-validation-messages ;
+
+: singleton-component-tag ( tag class -- )
+ [ "name" required-attr ] dip render ;
+
+: attrs>slots ( tag tuple -- )
+ [ attrs>> ] [ <mirror> ] bi* '[ swap tag>> , set-at ] assoc-each ;
+
+: tuple-component-tag ( tag class -- )
+ [ drop "name" required-attr ]
+ [ new [ attrs>slots ] keep ]
+ 2bi render ;
+
: process-chloe-tag ( tag -- )
dup name-tag {
- { "chloe" [ [ process-template ] each ] }
+ { "chloe" [ process-tag-children ] }
+
+ ! HTML head
{ "title" [ title-tag ] }
{ "write-title" [ write-title-tag ] }
{ "style" [ style-tag ] }
{ "write-style" [ write-style-tag ] }
{ "atom" [ atom-tag ] }
{ "write-atom" [ write-atom-tag ] }
- { "view" [ view-tag ] }
- { "edit" [ edit-tag ] }
- { "summary" [ summary-tag ] }
+
+ ! HTML elements
{ "a" [ a-tag ] }
- { "form" [ form-tag ] }
{ "button" [ button-tag ] }
+
+ ! Components
+ { "label" [ label singleton-component-tag ] }
+ { "link" [ link singleton-component-tag ] }
+ { "html" [ html singleton-component-tag ] }
+
+ ! Forms
+ { "form" [ form-tag ] }
{ "error-message" [ error-message-tag ] }
- { "validation-message" [ drop render-validation-message ] }
+ { "validation-messages" [ validation-messages-tag ] }
+ { "hidden" [ hidden singleton-component-tag ] }
+ { "field" [ field tuple-component-tag ] }
+ { "password" [ password tuple-component-tag ] }
+ { "textarea" [ textarea tuple-component-tag ] }
+ { "choice" [ choice tuple-component-tag ] }
+ { "checkbox" [ checkbox tuple-component-tag ] }
+
+ ! Control flow
{ "if" [ if-tag ] }
{ "comment" [ drop ] }
{ "call-next-template" [ drop call-next-template ] }
- [ "Unknown chloe tag: " swap append throw ]
+
+ [ "Unknown chloe tag: " prepend throw ]
} case ;
: process-tag ( tag -- )
diff --git a/extra/http/server/templating/chloe/test/test1.xml b/extra/html/templates/chloe/test/test1.xml
similarity index 100%
rename from extra/http/server/templating/chloe/test/test1.xml
rename to extra/html/templates/chloe/test/test1.xml
diff --git a/extra/http/server/templating/chloe/test/test2.xml b/extra/html/templates/chloe/test/test2.xml
similarity index 100%
rename from extra/http/server/templating/chloe/test/test2.xml
rename to extra/html/templates/chloe/test/test2.xml
diff --git a/extra/http/server/templating/chloe/test/test3-aux.xml b/extra/html/templates/chloe/test/test3-aux.xml
similarity index 100%
rename from extra/http/server/templating/chloe/test/test3-aux.xml
rename to extra/html/templates/chloe/test/test3-aux.xml
diff --git a/extra/http/server/templating/chloe/test/test3.xml b/extra/html/templates/chloe/test/test3.xml
similarity index 100%
rename from extra/http/server/templating/chloe/test/test3.xml
rename to extra/html/templates/chloe/test/test3.xml
diff --git a/extra/http/server/templating/chloe/test/test4.xml b/extra/html/templates/chloe/test/test4.xml
similarity index 62%
rename from extra/http/server/templating/chloe/test/test4.xml
rename to extra/html/templates/chloe/test/test4.xml
index dd9b232d73..55612360a5 100644
--- a/extra/http/server/templating/chloe/test/test4.xml
+++ b/extra/html/templates/chloe/test/test4.xml
@@ -2,7 +2,7 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:if t:code="http.server.templating.chloe.tests:test4-aux?">
+ <t:if t:code="html.templates.chloe.tests:test4-aux?">
True
</t:if>
diff --git a/extra/http/server/templating/chloe/test/test5.xml b/extra/html/templates/chloe/test/test5.xml
similarity index 62%
rename from extra/http/server/templating/chloe/test/test5.xml
rename to extra/html/templates/chloe/test/test5.xml
index 3bd39e45bd..edcbe8f3b1 100644
--- a/extra/http/server/templating/chloe/test/test5.xml
+++ b/extra/html/templates/chloe/test/test5.xml
@@ -2,7 +2,7 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:if t:code="http.server.templating.chloe.tests:test5-aux?">
+ <t:if t:code="html.templates.chloe.tests:test5-aux?">
True
</t:if>
diff --git a/extra/http/server/templating/chloe/test/test6.xml b/extra/html/templates/chloe/test/test6.xml
similarity index 62%
rename from extra/http/server/templating/chloe/test/test6.xml
rename to extra/html/templates/chloe/test/test6.xml
index 56234a5f0d..b3f649333f 100644
--- a/extra/http/server/templating/chloe/test/test6.xml
+++ b/extra/html/templates/chloe/test/test6.xml
@@ -2,7 +2,7 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:if t:var="http.server.templating.chloe.tests:test6-aux?">
+ <t:if t:var="html.templates.chloe.tests:test6-aux?">
True
</t:if>
diff --git a/extra/http/server/templating/chloe/test/test7.xml b/extra/html/templates/chloe/test/test7.xml
similarity index 62%
rename from extra/http/server/templating/chloe/test/test7.xml
rename to extra/html/templates/chloe/test/test7.xml
index a4f8e06e7d..338595e556 100644
--- a/extra/http/server/templating/chloe/test/test7.xml
+++ b/extra/html/templates/chloe/test/test7.xml
@@ -2,7 +2,7 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:if t:var="http.server.templating.chloe.tests:test7-aux?">
+ <t:if t:var="html.templates.chloe.tests:test7-aux?">
True
</t:if>
diff --git a/extra/http/server/templating/fhtml/authors.txt b/extra/html/templates/fhtml/authors.txt
similarity index 100%
rename from extra/http/server/templating/fhtml/authors.txt
rename to extra/html/templates/fhtml/authors.txt
diff --git a/extra/http/server/templating/fhtml/fhtml-tests.factor b/extra/html/templates/fhtml/fhtml-tests.factor
similarity index 74%
rename from extra/http/server/templating/fhtml/fhtml-tests.factor
rename to extra/html/templates/fhtml/fhtml-tests.factor
index 42bec43570..43ea28fa55 100755
--- a/extra/http/server/templating/fhtml/fhtml-tests.factor
+++ b/extra/html/templates/fhtml/fhtml-tests.factor
@@ -1,10 +1,10 @@
USING: io io.files io.streams.string io.encodings.utf8
-http.server.templating http.server.templating.fhtml kernel
+html.templates html.templates.fhtml kernel
tools.test sequences parser ;
-IN: http.server.templating.fhtml.tests
+IN: html.templates.fhtml.tests
: test-template ( path -- ? )
- "resource:extra/http/server/templating/fhtml/test/"
+ "resource:extra/html/templates/fhtml/test/"
prepend
[
".fhtml" append <fhtml> [ call-template ] with-string-writer
diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/html/templates/fhtml/fhtml.factor
similarity index 62%
rename from extra/http/server/templating/fhtml/fhtml.factor
rename to extra/html/templates/fhtml/fhtml.factor
index 2cc053a0ca..74e5c37ef1 100755
--- a/extra/http/server/templating/fhtml/fhtml.factor
+++ b/extra/html/templates/fhtml/fhtml.factor
@@ -4,12 +4,10 @@
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" ;
+parser io io.files io.streams.string io.encodings.utf8
+html.elements
+html.templates ;
+IN: html.templates.fhtml
! We use a custom lexer so that %> ends a token even if not
! followed by whitespace
@@ -35,7 +33,7 @@ DEFER: <% delimiter
: found-<% ( accum lexer col -- accum )
[
over line-text>>
- >r >r column>> r> r> subseq parsed
+ [ column>> ] 2dip subseq parsed
\ write-html parsed
] 2keep 2 + >>column drop ;
@@ -62,37 +60,20 @@ DEFER: <% delimiter
: parse-template ( string -- quot )
[
- use [ clone ] change
- templating-vocab use+
+ "quiet" on
+ parser-notes off
+ "html.templates.fhtml" use+
string-lines parse-template-lines
- ] with-scope ;
+ ] with-file-vocabs ;
-: eval-template ( string -- ) parse-template call ;
-
-: html-error. ( error -- )
- <pre> error. </pre> ;
+: eval-template ( string -- )
+ parse-template call ;
TUPLE: fhtml path ;
C: <fhtml> fhtml
M: fhtml call-template* ( filename -- )
- '[
- , path>> [
- "quiet" on
- parser-notes off
- templating-vocab use+
- ! so that reload works properly
- dup source-file file set
- utf8 file-contents
- [ eval-template ] [ html-error. drop ] recover
- ] with-file-vocabs
- ] assert-depth ;
-
-! file responder integration
-: enable-fhtml ( responder -- responder )
- [ <fhtml> serve-template ]
- "application/x-factor-server-page"
- pick special>> set-at ;
+ '[ , path>> utf8 file-contents eval-template ] assert-depth ;
INSTANCE: fhtml template
diff --git a/extra/http/server/templating/fhtml/test/bug.fhtml b/extra/html/templates/fhtml/test/bug.fhtml
similarity index 100%
rename from extra/http/server/templating/fhtml/test/bug.fhtml
rename to extra/html/templates/fhtml/test/bug.fhtml
diff --git a/extra/http/server/templating/fhtml/test/bug.html b/extra/html/templates/fhtml/test/bug.html
similarity index 100%
rename from extra/http/server/templating/fhtml/test/bug.html
rename to extra/html/templates/fhtml/test/bug.html
diff --git a/extra/http/server/templating/fhtml/test/example.fhtml b/extra/html/templates/fhtml/test/example.fhtml
similarity index 100%
rename from extra/http/server/templating/fhtml/test/example.fhtml
rename to extra/html/templates/fhtml/test/example.fhtml
diff --git a/extra/http/server/templating/fhtml/test/example.html b/extra/html/templates/fhtml/test/example.html
similarity index 100%
rename from extra/http/server/templating/fhtml/test/example.html
rename to extra/html/templates/fhtml/test/example.html
diff --git a/extra/http/server/templating/fhtml/test/stack.fhtml b/extra/html/templates/fhtml/test/stack.fhtml
similarity index 100%
rename from extra/http/server/templating/fhtml/test/stack.fhtml
rename to extra/html/templates/fhtml/test/stack.fhtml
diff --git a/extra/http/server/templating/fhtml/test/stack.html b/extra/html/templates/fhtml/test/stack.html
similarity index 100%
rename from extra/http/server/templating/fhtml/test/stack.html
rename to extra/html/templates/fhtml/test/stack.html
diff --git a/extra/html/templates/templates.factor b/extra/html/templates/templates.factor
new file mode 100644
index 0000000000..ed26c9b531
--- /dev/null
+++ b/extra/html/templates/templates.factor
@@ -0,0 +1,85 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel fry io io.encodings.utf8 io.files
+debugger prettyprint continuations namespaces boxes sequences
+arrays strings html.elements io.streams.string quotations ;
+IN: html.templates
+
+MIXIN: template
+
+GENERIC: call-template* ( template -- )
+
+M: string call-template* write ;
+
+M: callable call-template* call ;
+
+M: object call-template* output-stream get stream-copy ;
+
+ERROR: template-error template error ;
+
+M: template-error error.
+ "Error while processing template " write
+ [ template>> pprint ":" print nl ]
+ [ error>> error. ]
+ bi ;
+
+: call-template ( template -- )
+ [ call-template* ] [ template-error ] recover ;
+
+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: atom-feed
+
+: set-atom-feed ( title url -- )
+ 2array atom-feed get >box ;
+
+: write-atom-feed ( -- )
+ atom-feed get value>> [
+ <link "alternate" =rel "application/atom+xml" =type
+ [ first =title ] [ second =href ] bi
+ link/>
+ ] when* ;
+
+SYMBOL: nested-template?
+
+SYMBOL: next-template
+
+: call-next-template ( -- )
+ next-template get write-html ;
+
+M: f call-template* drop call-next-template ;
+
+: with-boilerplate ( body template -- )
+ [
+ title get [ <box> title set ] unless
+ atom-feed get [ <box> atom-feed set ] unless
+ style get [ SBUF" " clone style set ] unless
+
+ [
+ [
+ nested-template? on
+ call-template
+ ] with-string-writer
+ next-template set
+ ]
+ [ call-template ]
+ bi*
+ ] with-scope ; inline
+
+: template-convert ( template output -- )
+ utf8 [ call-template ] with-file-writer ;
diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor
deleted file mode 100644
index 73f6095eae..0000000000
--- a/extra/http/server/templating/templating.factor
+++ /dev/null
@@ -1,27 +0,0 @@
-USING: accessors kernel fry io io.encodings.utf8 io.files
-http http.server debugger prettyprint continuations ;
-IN: http.server.templating
-
-MIXIN: template
-
-GENERIC: call-template* ( template -- )
-
-ERROR: template-error template error ;
-
-M: template-error error.
- "Error while processing template " write
- [ template>> pprint ":" print nl ]
- [ error>> error. ]
- bi ;
-
-: call-template ( template -- )
- [ call-template* ] [ template-error ] recover ;
-
-M: template write-response-body* call-template ;
-
-: template-convert ( template output -- )
- utf8 [ call-template ] with-file-writer ;
-
-! responder integration
-: serve-template ( template -- response )
- '[ , call-template ] <html-content> ;
diff --git a/extra/validators/validators.factor b/extra/validators/validators.factor
index 9d6c4bed90..b03cc76444 100644
--- a/extra/validators/validators.factor
+++ b/extra/validators/validators.factor
@@ -122,12 +122,7 @@ C: <validation-error> validation-error
[ swap validation-error-for f ] recover ; inline
: validate-value ( value name validators -- result )
- '[
- , at {
- { [ dup pair? ] [ first ] }
- { [ dup quotation? ] [ ] }
- } cond call
- ] validate ;
+ '[ , at call ] validate ;
: required-values ( assoc -- )
[ swap [ drop v-required ] validate drop ] assoc-each ;
From 73a25d847167120165db844b3d28f8696f4d0328 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 May 2008 19:22:31 -0500
Subject: [PATCH 13/66] Remove obsolete vocabularies
---
extra/http/server/components/code/code.factor | 20 -
.../server/components/components-tests.factor | 133 ------
.../http/server/components/components.factor | 401 ------------------
.../server/components/farkup/farkup.factor | 17 -
.../components/inspector/inspector.factor | 17 -
extra/http/server/components/test/form.fhtml | 1 -
extra/http/server/forms/forms.factor | 79 ----
.../server/validators/validators-tests.factor | 29 --
.../http/server/validators/validators.factor | 85 ----
9 files changed, 782 deletions(-)
delete mode 100644 extra/http/server/components/code/code.factor
delete mode 100755 extra/http/server/components/components-tests.factor
delete mode 100755 extra/http/server/components/components.factor
delete mode 100755 extra/http/server/components/farkup/farkup.factor
delete mode 100644 extra/http/server/components/inspector/inspector.factor
delete mode 100755 extra/http/server/components/test/form.fhtml
delete mode 100644 extra/http/server/forms/forms.factor
delete mode 100755 extra/http/server/validators/validators-tests.factor
delete mode 100755 extra/http/server/validators/validators.factor
diff --git a/extra/http/server/components/code/code.factor b/extra/http/server/components/code/code.factor
deleted file mode 100644
index 19fc8c5ca8..0000000000
--- a/extra/http/server/components/code/code.factor
+++ /dev/null
@@ -1,20 +0,0 @@
-! Copyright (C) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: splitting kernel io sequences xmode.code2html accessors
-http.server.components html xml.entities ;
-IN: http.server.components.code
-
-TUPLE: code-renderer < text-renderer mode ;
-
-: <code-renderer> ( mode -- renderer )
- code-renderer new-text-renderer
- swap >>mode ;
-
-M: code-renderer render-view*
- [
- [ string-lines ] [ mode>> value ] bi* htmlize-lines
- ] with-html-stream ;
-
-: <code> ( id mode -- component )
- swap <text>
- swap <code-renderer> >>renderer ;
diff --git a/extra/http/server/components/components-tests.factor b/extra/http/server/components/components-tests.factor
deleted file mode 100755
index ff87bb71fb..0000000000
--- a/extra/http/server/components/components-tests.factor
+++ /dev/null
@@ -1,133 +0,0 @@
-IN: http.server.components.tests
-USING: http.server.components http.server.forms
-http.server.validators namespaces tools.test kernel accessors
-tuple-syntax mirrors
-http http.server.actions http.server.templating.fhtml
-io.streams.string io.streams.null ;
-
-validation-failed? off
-
-[ 3 ] [ "3" "n" <number> validate ] unit-test
-
-[ 123 ] [
- ""
- "n" <number>
- 123 >>default
- validate
-] unit-test
-
-[ f ] [ validation-failed? get ] unit-test
-
-[ t ] [ "3x" "n" <number> validate validation-error? ] unit-test
-
-[ t ] [ validation-failed? get ] unit-test
-
-[ "" ] [ "" "email" <email> validate ] unit-test
-
-[ "slava@jedit.org" ] [ "slava@jedit.org" "email" <email> validate ] unit-test
-
-[ "slava@jedit.org" ] [
- "slava@jedit.org"
- "email" <email>
- t >>required
- validate
-] unit-test
-
-[ t ] [
- "a"
- "email" <email>
- t >>required
- validate validation-error?
-] unit-test
-
-[ t ] [ "a" "email" <email> validate validation-error? ] unit-test
-
-TUPLE: test-tuple text number more-text ;
-
-: <test-tuple> test-tuple new ;
-
-: <test-form> ( -- form )
- "test" <form>
- "resource:extra/http/server/components/test/form.fhtml" <fhtml> >>view-template
- "resource:extra/http/server/components/test/form.fhtml" <fhtml> >>edit-template
- "text" <string>
- t >>required
- add-field
- "number" <number>
- 123 >>default
- t >>required
- 0 >>min-value
- 10 >>max-value
- add-field
- "more-text" <text>
- "hi" >>default
- add-field ;
-
-[ ] [ <test-tuple> <mirror> values set <test-form> view-form write-response-body drop ] unit-test
-
-[ ] [ <test-tuple> <mirror> values set <test-form> edit-form write-response-body drop ] unit-test
-
-[ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [
- <test-tuple> from-tuple
- <test-form> set-defaults
- values-tuple
-] unit-test
-
-[
- H{
- { "text" "fdafsa" }
- { "number" "xxx" }
- { "more-text" "" }
- } params set
-
- H{ } clone values set
-
- [ t ] [ <test-form> (validate-form) ] unit-test
-
- [ "fdafsa" ] [ "text" value ] unit-test
-
- [ t ] [ "number" value validation-error? ] unit-test
-] with-scope
-
-[
- [ ] [
- "n" <number>
- 0 >>min-value
- 10 >>max-value
- "n" set
- ] unit-test
-
- [ "123" ] [
- "123" "n" get validate value>>
- ] unit-test
-
- [ ] [ "i" <integer> "i" set ] unit-test
-
- [ 3 ] [
- "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" <text> "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" <text> validate = ] unit-test
-
-[ ] [ "password" <password> "p" set ] unit-test
-
-[ ] [ "pub-date" <date> "d" set ] unit-test
diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor
deleted file mode 100755
index 7f2a5a9ce1..0000000000
--- a/extra/http/server/components/components.factor
+++ /dev/null
@@ -1,401 +0,0 @@
-! Copyright (C) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel io math.parser assocs classes
-words classes.tuple arrays sequences splitting mirrors
-hashtables fry locals combinators continuations math
-calendar.format html html.elements xml.entities
-http.server.validators ;
-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> field
-
-M: field render-view*
- drop escape-string write ;
-
-M: field render-edit*
- <input type>> =type =name =value input/> ;
-
-TUPLE: hidden < field ;
-
-: hidden ( -- renderer ) T{ hidden f "hidden" } ; inline
-
-! Component protocol
-SYMBOL: components
-
-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: component-string ( value component -- string )
-
-SYMBOL: values
-
-: value values get at ;
-
-: set-value values get set-at ;
-
-: blank-values H{ } clone values set ;
-
-: from-tuple <mirror> values set ;
-
-: values-tuple values get mirror-object ;
-
-: render-view-or-summary ( component -- value renderer )
- [ id>> value ] [ component-string ] [ renderer>> ] tri ;
-
-: render-view ( component -- )
- render-view-or-summary render-view* ;
-
-: render-summary ( component -- )
- render-view-or-summary render-summary* ;
-
-<PRIVATE
-
-: render-edit-string ( string component -- )
- [ id>> ] [ 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 )
- '[
- ,
- over empty? [
- [ default>> [ v-default ] when* ]
- [ required>> [ v-required ] when ]
- bi
- ] [ validate* ] if
- ] with-validator ;
-
-: new-component ( id class renderer -- component )
- swap new
- swap >>renderer
- swap >>id
- init ; inline
-
-! String input fields
-TUPLE: string < component one-line min-length max-length ;
-
-: new-string ( id class -- component )
- "text" <field> new-component
- t >>one-line ; inline
-
-: <string> ( id -- component )
- string new-string ;
-
-M: string validate*
- [ one-line>> [ v-one-line ] when ]
- [ min-length>> [ v-min-length ] when* ]
- [ max-length>> [ v-max-length ] when* ]
- tri ;
-
-M: string component-string
- drop ;
-
-! Username fields
-TUPLE: username < string ;
-
-M: username init
- 2 >>min-length
- 20 >>max-length ;
-
-: <username> ( id -- component )
- username new-string ;
-
-M: username validate*
- call-next-method v-one-word ;
-
-! E-mail fields
-TUPLE: email < string ;
-
-: <email> ( id -- component )
- email new-string
- 5 >>min-length
- 60 >>max-length ;
-
-M: email validate*
- call-next-method dup empty? [ v-email ] unless ;
-
-! URL fields
-TUPLE: url < string ;
-
-: <url> ( id -- component )
- url new-string
- 5 >>min-length
- 60 >>max-length ;
-
-M: url validate*
- call-next-method dup empty? [ v-url ] 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 < string ;
-
-M: password init
- 6 >>min-length
- 60 >>max-length ;
-
-: <password> ( id -- component )
- password new-string
- password-renderer >>renderer ;
-
-M: password validate*
- call-next-method v-one-word ;
-
-! Number fields
-TUPLE: number < string min-value max-value ;
-
-: <number> ( id -- component )
- number new-string ;
-
-M: number validate*
- [ v-number ] [
- [ min-value>> [ v-min-value ] when* ]
- [ max-value>> [ v-max-value ] when* ]
- bi
- ] bi* ;
-
-M: number component-string
- drop dup [ number>string ] when ;
-
-! Integer fields
-TUPLE: integer < number ;
-
-: <integer> ( id -- component )
- integer new-string ;
-
-M: integer validate*
- call-next-method v-integer ;
-
-! Simple captchas
-TUPLE: captcha < string ;
-
-: <captcha> ( id -- component )
- captcha new-string ;
-
-M: captcha validate*
- drop v-captcha ;
-
-! Text areas
-TUPLE: text-renderer rows cols ;
-
-: new-text-renderer ( class -- renderer )
- new
- 60 >>cols
- 20 >>rows ;
-
-: <text-renderer> ( -- renderer )
- text-renderer new-text-renderer ;
-
-M: text-renderer render-view*
- drop escape-string write ;
-
-M: text-renderer render-edit*
- <textarea
- [ rows>> [ number>string =rows ] when* ]
- [ cols>> [ number>string =cols ] when* ] bi
- [ =id ]
- [ =name ] bi
- textarea>
- escape-string write
- </textarea> ;
-
-TUPLE: text < string ;
-
-: new-text ( id class -- component )
- new-string
- f >>one-line
- <text-renderer> >>renderer ;
-
-: <text> ( id -- component )
- text new-text ;
-
-! HTML text component
-TUPLE: html-text-renderer < text-renderer ;
-
-: <html-text-renderer> ( -- renderer )
- html-text-renderer new-text-renderer ;
-
-M: html-text-renderer render-view*
- drop escape-string write ;
-
-TUPLE: html-text < text ;
-
-: <html-text> ( id -- component )
- html-text new-text
- <html-text-renderer> >>renderer ;
-
-! Date component
-TUPLE: date < string ;
-
-: <date> ( id -- component )
- date new-string ;
-
-M: date component-string
- drop timestamp>string ;
-
-! Link components
-
-GENERIC: link-title ( obj -- string )
-GENERIC: link-href ( obj -- url )
-
-SINGLETON: link-renderer
-
-M: link-renderer render-view*
- drop <a dup link-href =href a> link-title escape-string write </a> ;
-
-TUPLE: link < string ;
-
-: <link> ( id -- component )
- link new-string
- link-renderer >>renderer ;
-
-! List components
-SYMBOL: +plain+
-SYMBOL: +ordered+
-SYMBOL: +unordered+
-
-TUPLE: list-renderer component type ;
-
-C: <list-renderer> list-renderer
-
-: render-plain-list ( seq component quot -- )
- '[ , component>> renderer>> @ ] each ; inline
-
-: render-li-list ( seq component quot -- )
- '[ <li> @ </li> ] render-plain-list ; inline
-
-: render-ordered-list ( seq quot component -- )
- <ol> render-li-list </ol> ; inline
-
-: render-unordered-list ( seq quot component -- )
- <ul> render-li-list </ul> ; inline
-
-: render-list ( value renderer quot -- )
- over type>> {
- { +plain+ [ render-plain-list ] }
- { +ordered+ [ render-ordered-list ] }
- { +unordered+ [ render-unordered-list ] }
- } case ; inline
-
-M: list-renderer render-view*
- [ render-view* ] render-list ;
-
-M: list-renderer render-summary*
- [ render-summary* ] render-list ;
-
-TUPLE: list < component ;
-
-: <list> ( id component type -- list )
- <list-renderer> list swap new-component ;
-
-M: list component-string drop ;
-
-! Choice
-TUPLE: choice-renderer choices ;
-
-C: <choice-renderer> choice-renderer
-
-M: choice-renderer render-view*
- drop escape-string write ;
-
-: render-option ( text selected? -- )
- <option [ "true" =selected ] when option>
- escape-string write
- </option> ;
-
-: render-options ( options selected -- )
- '[ dup , member? render-option ] each ;
-
-M: choice-renderer render-edit*
- <select swap =name select>
- choices>> swap 1array render-options
- </select> ;
-
-TUPLE: choice < string ;
-
-: <choice> ( id choices -- component )
- swap choice new-string
- swap <choice-renderer> >>renderer ;
-
-! Menu
-TUPLE: menu-renderer choices size ;
-
-: <menu-renderer> ( choices -- renderer )
- 5 menu-renderer boa ;
-
-M:: menu-renderer render-edit* ( value id renderer -- )
- <select
- renderer size>> [ number>string =size ] when*
- id =name
- "true" =multiple
- select>
- renderer choices>> value render-options
- </select> ;
-
-TUPLE: menu < string ;
-
-: <menu> ( id choices -- component )
- swap menu new-string
- swap <menu-renderer> >>renderer ;
-
-! Checkboxes
-TUPLE: checkbox-renderer label ;
-
-C: <checkbox-renderer> checkbox-renderer
-
-M: checkbox-renderer render-edit*
- <input
- "checkbox" =type
- swap =id
- swap [ "true" =selected ] when
- input>
- label>> escape-string write
- </input> ;
-
-TUPLE: checkbox < string ;
-
-: <checkbox> ( id label -- component )
- checkbox swap <checkbox-renderer> new-component ;
diff --git a/extra/http/server/components/farkup/farkup.factor b/extra/http/server/components/farkup/farkup.factor
deleted file mode 100755
index 87b7170bbf..0000000000
--- a/extra/http/server/components/farkup/farkup.factor
+++ /dev/null
@@ -1,17 +0,0 @@
-! Copyright (C) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: splitting kernel io sequences farkup accessors
-http.server.components xml.entities ;
-IN: http.server.components.farkup
-
-TUPLE: farkup-renderer < text-renderer ;
-
-: <farkup-renderer> ( -- renderer )
- farkup-renderer new-text-renderer ;
-
-M: farkup-renderer render-view*
- drop string-lines "\n" join convert-farkup write ;
-
-: <farkup> ( id -- component )
- <text>
- <farkup-renderer> >>renderer ;
diff --git a/extra/http/server/components/inspector/inspector.factor b/extra/http/server/components/inspector/inspector.factor
deleted file mode 100644
index 42366b57e4..0000000000
--- a/extra/http/server/components/inspector/inspector.factor
+++ /dev/null
@@ -1,17 +0,0 @@
-! Copyright (C) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: splitting kernel io sequences inspector accessors
-http.server.components xml.entities html ;
-IN: http.server.components.inspector
-
-SINGLETON: inspector-renderer
-
-M: inspector-renderer render-view*
- drop [ describe ] with-html-stream ;
-
-TUPLE: inspector < component ;
-
-M: inspector component-string drop ;
-
-: <inspector> ( id -- component )
- inspector inspector-renderer new-component ;
diff --git a/extra/http/server/components/test/form.fhtml b/extra/http/server/components/test/form.fhtml
deleted file mode 100755
index d3f5a12faa..0000000000
--- a/extra/http/server/components/test/form.fhtml
+++ /dev/null
@@ -1 +0,0 @@
-
diff --git a/extra/http/server/forms/forms.factor b/extra/http/server/forms/forms.factor
deleted file mode 100644
index 92fb25bb16..0000000000
--- a/extra/http/server/forms/forms.factor
+++ /dev/null
@@ -1,79 +0,0 @@
-! 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 ;
-IN: http.server.forms
-
-TUPLE: form < component
-view-template edit-template summary-template
-components ;
-
-M: form init V{ } clone >>components ;
-
-: <form> ( id -- form )
- form f new-component
- dup >>renderer ;
-
-: add-field ( form component -- form )
- dup id>> pick components>> set-at ;
-
-: set-components ( form -- )
- components>> components set ;
-
-: with-form ( form quot -- )
- [ [ set-components ] [ call ] bi* ] with-scope ; inline
-
-: set-defaults ( form -- )
- [
- components get [
- swap values get [
- swap default>> or
- ] change-at
- ] assoc-each
- ] with-form ;
-
-: <form-response> ( form template -- response )
- [ components>> components set ] [ <html-content> ] bi* ;
-
-: view-form ( form -- response )
- dup view-template>> <form-response> ;
-
-: edit-form ( form -- response )
- dup edit-template>> <form-response> ;
-
-: 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 ;
-
-: render-form ( value form template -- )
- [
- [ from-tuple ]
- [ set-components ]
- [ call-template ]
- tri*
- ] with-scope ;
-
-M: form component-string drop ;
-
-M: form render-summary*
- dup summary-template>> render-form ;
-
-M: form render-view*
- dup view-template>> render-form ;
-
-M: form render-edit*
- nip dup edit-template>> render-form ;
diff --git a/extra/http/server/validators/validators-tests.factor b/extra/http/server/validators/validators-tests.factor
deleted file mode 100755
index 5e845705ab..0000000000
--- a/extra/http/server/validators/validators-tests.factor
+++ /dev/null
@@ -1,29 +0,0 @@
-IN: http.server.validators.tests
-USING: kernel sequences tools.test http.server.validators
-accessors ;
-
-[ "foo" v-number ] must-fail
-[ 123 ] [ "123" v-number ] unit-test
-
-[ "slava@factorcode.org" ] [
- "slava@factorcode.org" v-email
-] unit-test
-
-[ "slava+foo@factorcode.org" ] [
- "slava+foo@factorcode.org" v-email
-] unit-test
-
-[ "slava@factorcode.o" v-email ]
-[ "invalid e-mail" = ] must-fail-with
-
-[ "sla@@factorcode.o" v-email ]
-[ "invalid e-mail" = ] must-fail-with
-
-[ "slava@factorcodeorg" v-email ]
-[ "invalid e-mail" = ] must-fail-with
-
-[ "http://www.factorcode.org" ]
-[ "http://www.factorcode.org" v-url ] unit-test
-
-[ "http:/www.factorcode.org" v-url ]
-[ "invalid URL" = ] must-fail-with
diff --git a/extra/http/server/validators/validators.factor b/extra/http/server/validators/validators.factor
deleted file mode 100755
index 7415787c79..0000000000
--- a/extra/http/server/validators/validators.factor
+++ /dev/null
@@ -1,85 +0,0 @@
-! Copyright (C) 2006, 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel continuations sequences math namespaces sets
-math.parser assocs regexp fry unicode.categories sequences ;
-IN: http.server.validators
-
-SYMBOL: validation-failed?
-
-TUPLE: validation-error value reason ;
-
-C: <validation-error> validation-error
-
-: with-validator ( value quot -- result )
- [ validation-failed? on <validation-error> ] recover ; inline
-
-: v-default ( str def -- str )
- over empty? spin ? ;
-
-: 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
- throw
- ] [
- drop
- ] if ;
-
-: v-max-length ( str n -- str )
- over length over > [
- [ "must be no more than " % # " characters" % ] "" make
- throw
- ] [
- drop
- ] if ;
-
-: v-number ( str -- n )
- dup string>number [ ] [ "must be a number" throw ] ?if ;
-
-: v-integer ( n -- n )
- dup integer? [ "must be an integer" throw ] unless ;
-
-: v-min-value ( x n -- x )
- 2dup < [
- [ "must be at least " % # ] "" make throw
- ] [
- drop
- ] if ;
-
-: v-max-value ( x n -- x )
- 2dup > [
- [ "must be no more than " % # ] "" make throw
- ] [
- drop
- ] if ;
-
-: v-regexp ( str what regexp -- str )
- >r over r> matches?
- [ drop ] [ "invalid " prepend throw ] if ;
-
-: v-email ( str -- str )
- #! From http://www.regular-expressions.info/email.html
- "e-mail"
- R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
- v-regexp ;
-
-: v-url ( str -- str )
- "URL"
- R' (ftp|http|https)://(\w+:?\w*@)?(\S+)(:[0-9]+)?(/|/([\w#!:.?+=&%@!\-/]))?'
- v-regexp ;
-
-: v-captcha ( str -- str )
- dup empty? [ "must remain blank" throw ] unless ;
-
-: v-one-line ( str -- str )
- dup "\r\n" intersect empty?
- [ "must be a single line" throw ] unless ;
-
-: v-one-word ( str -- str )
- dup [ alpha? ] all?
- [ "must be a single word" throw ] unless ;
From 376c73c7c86e69ec84ecab4fd212f342ef16b7d5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 May 2008 22:20:27 -0500
Subject: [PATCH 14/66] Convert HTML streams to use inheritance and new
accessors, fix a bug
---
extra/html/streams/streams-tests.factor | 4 +-
extra/html/streams/streams.factor | 93 ++++++++++++-------------
2 files changed, 49 insertions(+), 48 deletions(-)
diff --git a/extra/html/streams/streams-tests.factor b/extra/html/streams/streams-tests.factor
index 2084c7db18..14f1621346 100644
--- a/extra/html/streams/streams-tests.factor
+++ b/extra/html/streams/streams-tests.factor
@@ -1,6 +1,6 @@
USING: html.streams html.streams.private
io io.streams.string io.styles kernel
-namespaces tools.test xml.writer sbufs sequences ;
+namespaces tools.test xml.writer sbufs sequences inspector ;
IN: html.streams.tests
: make-html-string
@@ -70,3 +70,5 @@ M: funky browser-link-href
] [
[ H{ } [ ] with-nesting nl ] make-html-string
] unit-test
+
+[ ] [ [ { 1 2 3 } describe ] with-html-stream ] unit-test
diff --git a/extra/html/streams/streams.factor b/extra/html/streams/streams.factor
index b35f383bdc..e3f45e4c25 100755
--- a/extra/html/streams/streams.factor
+++ b/extra/html/streams/streams.factor
@@ -1,50 +1,44 @@
-! Copyright (C) 2004, 2006 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: generic assocs help http io io.styles io.files continuations
io.streams.string kernel math math.order math.parser namespaces
quotations assocs sequences strings words html.elements
-xml.entities sbufs continuations destructors ;
+xml.entities sbufs continuations destructors accessors ;
IN: html.streams
GENERIC: browser-link-href ( presented -- href )
M: object browser-link-href drop f ;
-TUPLE: html-stream last-div? ;
+TUPLE: html-stream stream last-div ;
-! A hack: stream-nl after with-nesting or tabular-output is
-! ignored, so that HTML stream output looks like UI pane output
-: test-last-div? ( stream -- ? )
- dup html-stream-last-div?
- f rot set-html-stream-last-div? ;
+! stream-nl after with-nesting or tabular-output is
+! ignored, so that HTML stream output looks like
+! UI pane output
+: last-div? ( stream -- ? )
+ [ f ] change-last-div drop ;
: not-a-div ( stream -- stream )
- dup test-last-div? drop ; inline
+ f >>last-div ; inline
: a-div ( stream -- straem )
- t over set-html-stream-last-div? ; inline
+ t >>last-div ; inline
: <html-stream> ( stream -- stream )
- html-stream construct-delegate ;
+ f html-stream boa ;
<PRIVATE
-TUPLE: html-sub-stream style stream ;
+TUPLE: html-sub-stream < html-stream style parent ;
-: (html-sub-stream) ( style stream -- stream )
- html-sub-stream boa
- 512 <sbuf> <html-stream> over set-delegate ;
-
-: <html-sub-stream> ( style stream class -- stream )
- >r (html-sub-stream) r> construct-delegate ; inline
+: new-html-sub-stream ( style stream class -- stream )
+ new
+ 512 <sbuf> >>stream
+ swap >>parent
+ swap >>style ; inline
: end-sub-stream ( substream -- string style stream )
- dup delegate >string
- over html-sub-stream-style
- rot html-sub-stream-stream ;
-
-: delegate-write ( string -- )
- output-stream get delegate stream-write ;
+ [ stream>> >string ] [ style>> ] [ parent>> ] tri ;
: object-link-tag ( style quot -- )
presented pick at [
@@ -99,11 +93,11 @@ TUPLE: html-sub-stream style stream ;
] if ; inline
: format-html-span ( string style stream -- )
- [
- [ [ drop delegate-write ] span-tag ] object-link-tag
+ stream>> [
+ [ [ drop write ] span-tag ] object-link-tag
] with-output-stream* ;
-TUPLE: html-span-stream ;
+TUPLE: html-span-stream < html-sub-stream ;
M: html-span-stream dispose
end-sub-stream not-a-div format-html-span ;
@@ -132,11 +126,11 @@ M: html-span-stream dispose
] if ; inline
: format-html-div ( string style stream -- )
- [
- [ [ delegate-write ] div-tag ] object-link-tag
+ stream>> [
+ [ [ write ] div-tag ] object-link-tag
] with-output-stream* ;
-TUPLE: html-block-stream ;
+TUPLE: html-block-stream < html-sub-stream ;
M: html-block-stream dispose ( quot style stream -- )
end-sub-stream a-div format-html-div ;
@@ -159,38 +153,43 @@ M: html-block-stream dispose ( quot style stream -- )
PRIVATE>
! Stream protocol
-M: html-stream stream-write1 ( char stream -- )
+M: html-stream stream-flush
+ stream>> stream-flush ;
+
+M: html-stream stream-write1
>r 1string r> stream-write ;
-M: html-stream stream-write ( str stream -- )
- not-a-div >r escape-string r> delegate stream-write ;
+M: html-stream stream-write
+ not-a-div >r escape-string r> stream>> stream-write ;
-M: html-stream make-span-stream ( style stream -- stream' )
- html-span-stream <html-sub-stream> ;
-
-M: html-stream stream-format ( str style stream -- )
+M: html-stream stream-format
>r html over at [ >r escape-string r> ] unless r>
format-html-span ;
-M: html-stream make-block-stream ( style stream -- stream' )
- html-block-stream <html-sub-stream> ;
+M: html-stream stream-nl
+ dup last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
-M: html-stream stream-write-table ( grid style stream -- )
- a-div [
+M: html-stream make-span-stream
+ html-span-stream new-html-sub-stream ;
+
+M: html-stream make-block-stream
+ html-block-stream new-html-sub-stream ;
+
+M: html-stream make-cell-stream
+ html-sub-stream new-html-sub-stream ;
+
+M: html-stream stream-write-table
+ a-div stream>> [
<table dup table-attrs table> swap [
<tr> [
<td "top" =valign swap table-style =style td>
- >string write-html
+ stream>> >string write
</td>
] with each </tr>
] with each </table>
] with-output-stream* ;
-M: html-stream make-cell-stream ( style stream -- stream' )
- (html-sub-stream) ;
-
-M: html-stream stream-nl ( stream -- )
- dup test-last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
+M: html-stream dispose stream>> dispose ;
: with-html-stream ( quot -- )
output-stream get <html-stream> swap with-output-stream* ; inline
From 53857fdfee998019c90d8d8b1d126f2a0db17cc8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 May 2008 22:32:39 -0500
Subject: [PATCH 15/66] Move farkup, code, inspector components to
html.components
---
extra/html/components/components-tests.factor | 27 +++++++++++++++++--
extra/html/components/components.factor | 23 +++++++++++++++-
2 files changed, 47 insertions(+), 3 deletions(-)
diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor
index 0bd5410a3b..d09f8b6b42 100644
--- a/extra/html/components/components-tests.factor
+++ b/extra/html/components/components-tests.factor
@@ -1,6 +1,7 @@
IN: html.components.tests
-USING: html.components tools.test kernel io.streams.string
-io.streams.null accessors ;
+USING: tools.test kernel io.streams.string
+io.streams.null accessors inspector html.streams
+html.components ;
[ ] [ blank-values ] unit-test
@@ -145,3 +146,25 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ "<html>arbitrary <b>markup</b> for the win!</html>" ] [
[ "html" html render ] with-string-writer
] unit-test
+
+[ ] [ "int x = 4;" "code" set-value ] unit-test
+
+[ ] [ "java" "mode" set-value ] unit-test
+
+[ "<span class='KEYWORD3'>int</span> x <span class='OPERATOR'>=</span> <span class='DIGIT'>4</span>;\n" ] [
+ [ "code" <code> "mode" >>mode render ] with-string-writer
+] unit-test
+
+[ ] [ "-foo\n-bar" "farkup" set-value ] unit-test
+
+[ "<ul><li>foo</li><li>bar</li></ul>" ] [
+ [ "farkup" farkup render ] with-string-writer
+] unit-test
+
+[ ] [ { 1 2 3 } "object" set-value ] unit-test
+
+[ t ] [
+ [ "object" inspector render ] with-string-writer
+ [ "object" value [ describe ] with-html-stream ] with-string-writer
+ =
+] unit-test
diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor
index df1d1faa72..9c762eaa3a 100644
--- a/extra/html/components/components.factor
+++ b/extra/html/components/components.factor
@@ -4,7 +4,7 @@ USING: accessors kernel namespaces io math.parser assocs classes
classes.tuple words arrays sequences splitting mirrors
hashtables combinators continuations math strings
fry locals calendar calendar.format xml.entities validators
-html.elements ;
+html.elements html.streams xmode.code2html farkup inspector ;
IN: html.components
SYMBOL: values
@@ -144,6 +144,27 @@ M: link render*
link-title object>string escape-string write
</a> ;
+! XMode code component
+TUPLE: code mode ;
+
+: <code> ( -- code )
+ code new ;
+
+M: code render*
+ [ string-lines ] [ drop ] [ mode>> value ] tri* htmlize-lines ;
+
+! Farkup component
+SINGLETON: farkup
+
+M: farkup render*
+ 2drop string-lines "\n" join convert-farkup write ;
+
+! Inspector component
+SINGLETON: inspector
+
+M: inspector render*
+ 2drop [ describe ] with-html-stream ;
+
! HTML component
SINGLETON: html
From 6a1f38581692af69731eeefd7f4be570f0a94364 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 May 2008 22:37:55 -0500
Subject: [PATCH 16/66] Add failing unit test
---
extra/locals/locals-tests.factor | 11 +++++++++++
1 file changed, 11 insertions(+)
diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor
index c5adaa5e5e..87bc49f366 100755
--- a/extra/locals/locals-tests.factor
+++ b/extra/locals/locals-tests.factor
@@ -254,3 +254,14 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
[ 3 ] [ 1 [let | a [ ] | 3 ] ] unit-test
[ ] [ 1 2 [let | a [ ] b [ ] | ] ] unit-test
+
+:: a-word-with-locals ( a b -- ) ;
+
+: new-definition "IN: locals.tests\nUSING: math ;\n: a-word-with-locals ( -- x ) 2 3 + ;\n" ;
+
+[ ] [ new-definition eval ] unit-test
+
+[ t ] [
+ [ \ a-word-with-locals see ] with-string-writer
+ new-definition =
+] unit-test
From 9100398adfb1343506a4762dc7ec993d3c4e4e75 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 24 May 2008 01:28:48 -0500
Subject: [PATCH 17/66] Add more chloe tags, and tests
---
extra/html/components/components.factor | 13 ++++---
extra/html/templates/chloe/chloe-tests.factor | 38 ++++++++++++++++++-
extra/html/templates/chloe/chloe.factor | 16 +++++---
extra/html/templates/chloe/test/test8.xml | 27 +++++++++++++
4 files changed, 83 insertions(+), 11 deletions(-)
create mode 100644 extra/html/templates/chloe/test/test8.xml
diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor
index 9c762eaa3a..faef9ca1b5 100644
--- a/extra/html/components/components.factor
+++ b/extra/html/components/components.factor
@@ -15,6 +15,9 @@ SYMBOL: values
: blank-values H{ } clone values set ;
+: prepare-value ( name object -- value name object )
+ [ [ value ] keep ] dip ; inline
+
: from-tuple <mirror> values set ;
: values-tuple values get object>> ;
@@ -35,7 +38,7 @@ GENERIC: render* ( value name render -- )
[ -rot render* ] dip
render-error
] [
- [ [ value ] keep ] dip render*
+ prepare-value render*
] if* ;
<PRIVATE
@@ -56,7 +59,7 @@ M: hidden render* drop "hidden" render-input ;
: render-field ( value name size type -- )
<input
=type
- [ number>string =size ] when*
+ [ object>string =size ] when*
=name
object>string =value
input/> ;
@@ -85,8 +88,8 @@ TUPLE: textarea rows cols ;
M: textarea render*
<textarea
- [ rows>> [ number>string =rows ] when* ]
- [ cols>> [ number>string =cols ] when* ] bi
+ [ rows>> [ object>string =rows ] when* ]
+ [ cols>> [ object>string =cols ] when* ] bi
=name
textarea>
object>string escape-string write
@@ -109,7 +112,7 @@ TUPLE: choice size multiple choices ;
M: choice render*
<select
swap =name
- dup size>> [ number>string =size ] when*
+ dup size>> [ object>string =size ] when*
dup multiple>> [ "true" =multiple ] when
select>
[ choices>> value ] [ multiple>> ] bi
diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor
index 3c52153eee..4d8d15c581 100644
--- a/extra/html/templates/chloe/chloe-tests.factor
+++ b/extra/html/templates/chloe/chloe-tests.factor
@@ -1,6 +1,6 @@
USING: html.templates html.templates.chloe
tools.test io.streams.string kernel sequences ascii boxes
-namespaces xml
+namespaces xml html.components
splitting ;
IN: html.templates.chloe.tests
@@ -87,3 +87,39 @@ SYMBOL: test7-aux?
"test7" test-template call-template
] run-template
] unit-test
+
+[ ] [ blank-values ] unit-test
+
+[ ] [ "A label" "label" set-value ] unit-test
+
+SINGLETON: link-test
+
+M: link-test link-title drop "<Link Title>" ;
+
+M: link-test link-href drop "http://www.apple.com/foo&bar" ;
+
+[ ] [ link-test "link" set-value ] unit-test
+
+[ ] [ "int x = 5;" "code" set-value ] unit-test
+
+[ ] [ "c" "mode" set-value ] unit-test
+
+[ ] [ { 1 2 3 } "inspector" set-value ] unit-test
+
+[ ] [ "<p>a paragraph</p>" "html" set-value ] unit-test
+
+[ ] [ "sheeple" "field" set-value ] unit-test
+
+[ ] [ "a password" "password" set-value ] unit-test
+
+[ ] [ "a\nb\nc" "textarea" set-value ] unit-test
+
+[ ] [ "new york" "choice" set-value ] unit-test
+
+[ ] [ { "new york" "detroit" "minneapolis" } "choices" set-value ] unit-test
+
+[ ] [
+ [
+ "test8" test-template call-template
+ ] run-template drop
+] unit-test
diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor
index a01d424eb9..43834f896e 100644
--- a/extra/html/templates/chloe/chloe.factor
+++ b/extra/html/templates/chloe/chloe.factor
@@ -7,14 +7,13 @@ unicode.case tuple-syntax mirrors fry
multiline xml xml.data xml.writer xml.utilities
html.elements
html.components
+html.templates
http.server
http.server.auth
http.server.flows
http.server.actions
-http.server.sessions
-http.server.templating
-http.server.boilerplate ;
-IN: http.server.templating.chloe
+http.server.sessions ;
+IN: html.templates.chloe
! Chloe is Ed's favorite web designer
@@ -207,7 +206,11 @@ STRING: button-tag-markup
[ "name" required-attr ] dip render ;
: attrs>slots ( tag tuple -- )
- [ attrs>> ] [ <mirror> ] bi* '[ swap tag>> , set-at ] assoc-each ;
+ [ attrs>> ] [ <mirror> ] bi*
+ '[
+ swap tag>> dup "name" =
+ [ 2drop ] [ , set-at ] if
+ ] assoc-each ;
: tuple-component-tag ( tag class -- )
[ drop "name" required-attr ]
@@ -233,6 +236,9 @@ STRING: button-tag-markup
! Components
{ "label" [ label singleton-component-tag ] }
{ "link" [ link singleton-component-tag ] }
+ { "code" [ code tuple-component-tag ] }
+ { "farkup" [ farkup singleton-component-tag ] }
+ { "inspector" [ inspector singleton-component-tag ] }
{ "html" [ html singleton-component-tag ] }
! Forms
diff --git a/extra/html/templates/chloe/test/test8.xml b/extra/html/templates/chloe/test/test8.xml
new file mode 100644
index 0000000000..8e2ff2e8ad
--- /dev/null
+++ b/extra/html/templates/chloe/test/test8.xml
@@ -0,0 +1,27 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:label t:name="label" />
+
+ <t:link t:name="link" />
+
+ <t:code t:name="code" mode="mode" />
+
+ <t:farkup t:name="farkup" />
+
+ <t:inspector t:name="inspector" />
+
+ <t:html t:name="html" />
+
+ <t:field t:name="field" t:size="13" />
+
+ <t:password t:name="password" t:size="10" />
+
+ <t:textarea t:name="textarea" t:rows="5" t:cols="10" />
+
+ <t:choice t:name="choice" t:choices="choices" />
+
+ <t:checkbox t:name="checkbox">Checkbox</t:checkbox>
+
+</t:chloe>
From 3104cdb511537f6ba1f37925534520b6c6a0d92b Mon Sep 17 00:00:00 2001
From: Matthew Willis <matthew.willis@mac.com>
Date: Sat, 17 May 2008 17:07:40 -0700
Subject: [PATCH 18/66] Changed the unicode cairo sample to use actual unicode
instead of a byte array.
---
extra/cairo/samples/samples.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/cairo/samples/samples.factor b/extra/cairo/samples/samples.factor
index 402c3881f4..0805cd41c1 100644
--- a/extra/cairo/samples/samples.factor
+++ b/extra/cairo/samples/samples.factor
@@ -116,11 +116,11 @@ IN: cairo.samples
cr cairo_fill ;
: utf8 ( -- )
- cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
- cairo_select_font_face
+ ! cr "kochi" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
+ ! cairo_select_font_face
cr 50 cairo_set_font_size
"cairo_text_extents_t" malloc-object
- cr B{ 230 151 165 230 156 172 232 170 158 } pick cairo_text_extents
+ cr "日本語" pick cairo_text_extents
cr over
[ cairo_text_extents_t-width 2 / ]
[ cairo_text_extents_t-x_bearing ] bi +
@@ -129,7 +129,7 @@ IN: cairo.samples
[ cairo_text_extents_t-y_bearing ] bi +
128 swap - cairo_move_to
free
- cr B{ 230 151 165 230 156 172 232 170 158 } cairo_show_text
+ cr "日本語" cairo_show_text
cr 1 0.2 0.2 0.6 cairo_set_source_rgba
cr 6 cairo_set_line_width
From 06843caee91a4c9ee0a0d068e9fe024199c47d66 Mon Sep 17 00:00:00 2001
From: Matthew Willis <matthew.willis@mac.com>
Date: Sun, 18 May 2008 01:59:11 -0700
Subject: [PATCH 19/66] Fixed mistake introduced in the last patch.
---
extra/cairo/samples/samples.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/cairo/samples/samples.factor b/extra/cairo/samples/samples.factor
index 0805cd41c1..3cc63922f8 100644
--- a/extra/cairo/samples/samples.factor
+++ b/extra/cairo/samples/samples.factor
@@ -116,8 +116,8 @@ IN: cairo.samples
cr cairo_fill ;
: utf8 ( -- )
- ! cr "kochi" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
- ! cairo_select_font_face
+ cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
+ cairo_select_font_face
cr 50 cairo_set_font_size
"cairo_text_extents_t" malloc-object
cr "日本語" pick cairo_text_extents
From c64de056fbd9f7f060b17ffacb56755cbfe6dd47 Mon Sep 17 00:00:00 2001
From: Matthew Willis <matthew.willis@mac.com>
Date: Sat, 24 May 2008 12:06:59 -0700
Subject: [PATCH 20/66] First crack at pango. Try "cairo.pango.gadgets" run
---
extra/cairo/pango/gadgets/gadgets.factor | 20 +++
extra/cairo/pango/pango.factor | 175 +++++++++++++++++++++++
2 files changed, 195 insertions(+)
create mode 100644 extra/cairo/pango/gadgets/gadgets.factor
create mode 100644 extra/cairo/pango/pango.factor
diff --git a/extra/cairo/pango/gadgets/gadgets.factor b/extra/cairo/pango/gadgets/gadgets.factor
new file mode 100644
index 0000000000..780881e872
--- /dev/null
+++ b/extra/cairo/pango/gadgets/gadgets.factor
@@ -0,0 +1,20 @@
+USING: cairo.pango cairo cairo.ffi cairo.gadgets
+alien.c-types kernel math ;
+IN: cairo.pango.gadgets
+
+: (pango-gadget) ( setup show -- gadget )
+ [ drop layout-size ]
+ [ compose [ with-pango ] curry <cached-cairo> ] 2bi ;
+
+: <pango-gadget> ( quot -- gadget )
+ [ cr layout pango_cairo_show_layout ] (pango-gadget) ;
+
+USING: prettyprint sequences ui.gadgets.panes ;
+: hello-pango ( -- )
+ 50 [ 6 + ] map [
+ "Sans Bold " swap unparse append
+ [ layout-font "Hello, Pango!" layout-text ] curry
+ <pango-gadget> gadget.
+ ] each ;
+
+MAIN: hello-pango
diff --git a/extra/cairo/pango/pango.factor b/extra/cairo/pango/pango.factor
new file mode 100644
index 0000000000..789044f6e1
--- /dev/null
+++ b/extra/cairo/pango/pango.factor
@@ -0,0 +1,175 @@
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! pangocairo bindings, from pango/pangocairo.h
+
+USING: cairo.ffi alien.c-types math
+alien.syntax system combinators alien ;
+IN: cairo.pango
+
+<< "pangocairo" {
+! { [ os winnt? ] [ "libpangocairo-1.dll" ] }
+! { [ os macosx? ] [ "libpangocairo.dylib" ] }
+ { [ os unix? ] [ "libpangocairo-1.0.so" ] }
+} cond "cdecl" add-library >>
+
+LIBRARY: pangocairo
+
+TYPEDEF: void* PangoCairoFont
+TYPEDEF: void* PangoCairoFontMap
+TYPEDEF: void* PangoFontMap
+
+FUNCTION: PangoFontMap*
+pango_cairo_font_map_new ( ) ;
+
+FUNCTION: PangoFontMap*
+pango_cairo_font_map_new_for_font_type ( cairo_font_type_t fonttype ) ;
+
+FUNCTION: PangoFontMap*
+pango_cairo_font_map_get_default ( ) ;
+
+FUNCTION: cairo_font_type_t
+pango_cairo_font_map_get_font_type ( PangoCairoFontMap* fontmap ) ;
+
+FUNCTION: void
+pango_cairo_font_map_set_resolution ( PangoCairoFontMap* fontmap, double dpi ) ;
+
+FUNCTION: double
+pango_cairo_font_map_get_resolution ( PangoCairoFontMap* fontmap ) ;
+
+FUNCTION: PangoContext*
+pango_cairo_font_map_create_context ( PangoCairoFontMap* fontmap ) ;
+
+FUNCTION: cairo_scaled_font_t*
+pango_cairo_font_get_scaled_font ( PangoCairoFont* font ) ;
+
+! Update a Pango context for the current state of a cairo context
+FUNCTION: void
+pango_cairo_update_context ( cairo_t* cr, PangoContext* context ) ;
+
+FUNCTION: void
+pango_cairo_context_set_font_options ( PangoContext* context, cairo_font_options_t* options ) ;
+
+FUNCTION: cairo_font_options_t*
+pango_cairo_context_get_font_options ( PangoContext* context ) ;
+
+FUNCTION: void
+pango_cairo_context_set_resolution ( PangoContext* context, double dpi ) ;
+
+FUNCTION: double
+pango_cairo_context_get_resolution ( PangoContext* context ) ;
+
+! Convenience
+FUNCTION: PangoLayout*
+pango_cairo_create_layout ( cairo_t* cr ) ;
+
+FUNCTION: void
+pango_cairo_update_layout ( cairo_t* cr, PangoLayout* layout ) ;
+
+! Rendering
+FUNCTION: void
+pango_cairo_show_glyph_string ( cairo_t* cr, PangoFont* font, PangoGlyphString* glyphs ) ;
+
+FUNCTION: void
+pango_cairo_show_layout_line ( cairo_t* cr, PangoLayoutLine* line ) ;
+
+FUNCTION: void
+pango_cairo_show_layout ( cairo_t* cr, PangoLayout* layout ) ;
+
+FUNCTION: void
+pango_cairo_show_error_underline ( cairo_t* cr, double x, double y, double width, double height ) ;
+
+! Rendering to a path
+FUNCTION: void
+pango_cairo_glyph_string_path ( cairo_t* cr, PangoFont* font, PangoGlyphString* glyphs ) ;
+
+FUNCTION: void
+pango_cairo_layout_line_path ( cairo_t* cr, PangoLayoutLine* line ) ;
+
+FUNCTION: void
+pango_cairo_layout_path ( cairo_t* cr, PangoLayout* layout ) ;
+
+FUNCTION: void
+pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width, double height ) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Helpful functions from other parts of pango
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: PANGO_SCALE 1024 ;
+
+FUNCTION: void
+pango_layout_set_text ( PangoLayout* layout, char* text, int length ) ;
+
+FUNCTION: char*
+pango_layout_get_text ( PangoLayout* layout ) ;
+
+FUNCTION: void
+pango_layout_get_size ( PangoLayout* layout, int* width, int* height ) ;
+
+TYPEDEF: void* PangoFontDescription
+
+FUNCTION: PangoFontDescription*
+pango_font_description_from_string ( char* str ) ;
+
+FUNCTION: char*
+pango_font_description_to_string ( PangoFontDescription* desc ) ;
+
+FUNCTION: char*
+pango_font_description_to_filename ( PangoFontDescription* desc ) ;
+
+FUNCTION: void
+pango_layout_set_font_description ( PangoLayout* layout, PangoFontDescription* desc ) ;
+
+FUNCTION: PangoFontDescription*
+pango_layout_get_font_description ( PangoLayout* layout ) ;
+
+FUNCTION: void
+pango_layout_get_pixel_size ( PangoLayout* layout, int* width, int* height ) ;
+
+FUNCTION: void
+pango_font_description_free ( PangoFontDescription* desc ) ;
+
+TYPEDEF: void* gpointer
+
+FUNCTION: void
+g_object_unref ( gpointer object ) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Higher level words and combinators
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: destructors accessors namespaces kernel cairo ;
+
+TUPLE: pango-layout alien ;
+C: <pango-layout> pango-layout
+M: pango-layout dispose ( alien -- ) alien>> g_object_unref ;
+
+: layout ( -- pango-layout ) pango-layout get ;
+
+: (with-pango) ( layout quot -- )
+ >r alien>> pango-layout r> with-variable ; inline
+
+: with-pango ( quot -- )
+ cr pango_cairo_create_layout <pango-layout> swap
+ [ (with-pango) ] curry with-disposal ; inline
+
+: pango-layout-get-pixel-size ( layout -- width height )
+ 0 <int> 0 <int> [ pango_layout_get_pixel_size ] 2keep
+ [ *int ] bi@ ;
+
+: dummy-pango ( quot -- )
+ >r CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create
+ r> [ with-pango ] curry with-cairo-from-surface ; inline
+
+: layout-size ( quot -- width height )
+ [ layout pango-layout-get-pixel-size ] compose dummy-pango ; inline
+
+: layout-font ( str -- )
+ pango_font_description_from_string
+ dup zero? [ "pango: not a valid font." throw ] when
+ layout over pango_layout_set_font_description
+ pango_font_description_free ;
+
+: layout-text ( str -- )
+ layout swap -1 pango_layout_set_text ;
From dc1a423f88025e46ded88abe1db54f47e1786e87 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 24 May 2008 21:49:48 -0500
Subject: [PATCH 21/66] Document clumps
---
core/sequences/sequences.factor | 2 +-
core/splitting/splitting-docs.factor | 82 ++++++--
core/splitting/splitting.factor | 4 +-
extra/http/server/auth/admin/admin.factor | 179 ------------------
extra/http/server/auth/admin/user-list.xml | 9 -
extra/http/server/auth/admin/user-summary.xml | 9 -
extra/webapps/pastebin/paste-list.xml | 15 --
extra/webapps/pastebin/pastebin-common.xml | 31 +++
extra/webapps/pastebin/pastebin.xml | 35 ++--
.../user-admin}/edit-user.xml | 0
.../admin => webapps/user-admin}/new-user.xml | 0
extra/webapps/user-admin/user-admin.factor | 160 ++++++++++++++++
.../user-admin/user-admin.xml} | 0
extra/webapps/user-admin/user-list.xml | 13 ++
14 files changed, 289 insertions(+), 250 deletions(-)
delete mode 100644 extra/http/server/auth/admin/admin.factor
delete mode 100644 extra/http/server/auth/admin/user-list.xml
delete mode 100644 extra/http/server/auth/admin/user-summary.xml
delete mode 100644 extra/webapps/pastebin/paste-list.xml
create mode 100644 extra/webapps/pastebin/pastebin-common.xml
rename extra/{http/server/auth/admin => webapps/user-admin}/edit-user.xml (100%)
rename extra/{http/server/auth/admin => webapps/user-admin}/new-user.xml (100%)
create mode 100644 extra/webapps/user-admin/user-admin.factor
rename extra/{http/server/auth/admin/admin.xml => webapps/user-admin/user-admin.xml} (100%)
create mode 100644 extra/webapps/user-admin/user-list.xml
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index cbddfa7d28..4153430514 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -680,7 +680,7 @@ PRIVATE>
: unclip ( seq -- rest first )
[ rest ] [ first ] bi ;
-: unclip-last ( seq -- butfirst last )
+: unclip-last ( seq -- butlast last )
[ but-last ] [ peek ] bi ;
: unclip-slice ( seq -- rest first )
diff --git a/core/splitting/splitting-docs.factor b/core/splitting/splitting-docs.factor
index 5000dbf5fd..1beafc710a 100644
--- a/core/splitting/splitting-docs.factor
+++ b/core/splitting/splitting-docs.factor
@@ -1,6 +1,25 @@
USING: help.markup help.syntax sequences strings ;
IN: splitting
+ARTICLE: "groups-clumps" "Groups and clumps"
+"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
+{ $subsection groups }
+{ $subsection <groups> }
+{ $subsection <sliced-groups> }
+"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
+{ $subsection clumps }
+{ $subsection <clumps> }
+{ $subsection <sliced-clumps> }
+"The difference can be summarized as the following:"
+{ $list
+ { "With groups, the subsequences form the original sequence when concatenated:"
+ { $unchecked-example "dup n groups concat sequence= ." "t" }
+ }
+ { "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
+ { $unchecked-example "dup n clumps unclip-last >r [ first ] map r> append sequence= ." "t" }
+ }
+} ;
+
ARTICLE: "sequences-split" "Splitting sequences"
"Splitting sequences at occurrences of subsequences:"
{ $subsection ?head }
@@ -9,14 +28,9 @@ ARTICLE: "sequences-split" "Splitting sequences"
{ $subsection ?tail-slice }
{ $subsection split1 }
{ $subsection split }
-"Grouping elements:"
-{ $subsection group }
-"A virtual sequence for grouping elements:"
-{ $subsection groups }
-{ $subsection <groups> }
-{ $subsection <sliced-groups> }
"Splitting a string into lines:"
-{ $subsection string-lines } ;
+{ $subsection string-lines }
+{ $subsection "groups-clumps" } ;
ABOUT: "sequences-split"
@@ -36,19 +50,22 @@ HELP: split
{ $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ;
HELP: groups
-{ $class-description "Instances are virtual sequences whose elements are fixed-length subsequences or slices of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+{ $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
$nl
"New groups are created by calling " { $link <groups> } " and " { $link <sliced-groups> } "." }
{ $see-also group } ;
HELP: group
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
-{ $description "Splits the sequence into groups of " { $snippet "n" } " elements and collects the groups into a new array." }
-{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." } ;
+{ $description "Splits the sequence into disjoint groups of " { $snippet "n" } " elements and collects the groups into a new array." }
+{ $notes "If the sequence length is not a multiple of " { $snippet "n" } ", the final subsequence in the list will be shorter than " { $snippet "n" } " elements." }
+{ $examples
+ { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 group ." "{ { 3 1 } { 3 3 } { 7 } }" }
+} ;
HELP: <groups>
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
-{ $description "Outputs a virtual sequence whose elements are subsequences consisting of groups of " { $snippet "n" } " elements from the underlying sequence." }
+{ $description "Outputs a virtual sequence whose elements are disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples
{ $example
"USING: arrays kernel prettyprint sequences splitting ;"
@@ -58,7 +75,7 @@ HELP: <groups>
HELP: <sliced-groups>
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
-{ $description "Outputs a virtual sequence whose elements are slices consisting of groups of " { $snippet "n" } " elements from the underlying sequence." }
+{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples
{ $example
"USING: arrays kernel prettyprint sequences splitting ;"
@@ -68,7 +85,46 @@ HELP: <sliced-groups>
}
} ;
-{ group <groups> <sliced-groups> } related-words
+HELP: clumps
+{ $class-description "Instances are virtual sequences whose elements are overlapping fixed-length subsequences o an underlying sequence. Clumps are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
+$nl
+"New clumps are created by calling " { $link <clumps> } " and " { $link <sliced-clumps> } "." } ;
+
+HELP: clump
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
+{ $description "Splits the sequence into overlapping clumps of " { $snippet "n" } " elements and collects the clumps into a new array." }
+{ $errors "Throws an error if " { $snippet "n" } " is smaller than the length of the sequence." }
+{ $examples
+ { $example "USING: splitting prettyprint ;" "{ 3 1 3 3 7 } 2 clump ." "{ { 3 1 } { 1 3 } { 3 3 } { 3 7 } }" }
+} ;
+
+HELP: <clumps>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
+{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
+{ $examples
+ "Running averages:"
+ { $example
+ "USING: splitting sequences math prettyprint kernel ;"
+ "IN: scratchpad"
+ ": share-price"
+ " { 13/50 51/100 13/50 1/10 4/5 17/20 33/50 3/25 19/100 3/100 } ;"
+ ""
+ "share-price 4 <clumps> [ [ sum ] [ length ] bi / ] map ."
+ "{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }"
+ }
+} ;
+
+HELP: <sliced-clumps>
+{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
+{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } ;
+
+{ clumps groups } related-words
+
+{ clump group } related-words
+
+{ <clumps> <groups> } related-words
+
+{ <sliced-clumps> <sliced-groups> } related-words
HELP: ?head
{ $values { "seq" "a sequence" } { "begin" "a sequence" } { "newseq" "a new sequence" } { "?" "a boolean" } }
diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor
index 9f6ae75d32..62e7ef3782 100755
--- a/core/splitting/splitting.factor
+++ b/core/splitting/splitting.factor
@@ -44,7 +44,7 @@ M: sliced-groups nth group@ <slice> ;
TUPLE: clumps < abstract-groups ;
-: <clumps> ( seq n -- groups )
+: <clumps> ( seq n -- clumps )
clumps construct-groups ; inline
M: clumps length
@@ -58,7 +58,7 @@ M: clumps group@
TUPLE: sliced-clumps < groups ;
-: <sliced-clumps> ( seq n -- groups )
+: <sliced-clumps> ( seq n -- clumps )
sliced-clumps construct-groups ; inline
M: sliced-clumps nth group@ <slice> ;
diff --git a/extra/http/server/auth/admin/admin.factor b/extra/http/server/auth/admin/admin.factor
deleted file mode 100644
index 21e1a6181b..0000000000
--- a/extra/http/server/auth/admin/admin.factor
+++ /dev/null
@@ -1,179 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors namespaces combinators words
-assocs locals db.tuples arrays splitting strings qualified
-
-http.server.templating.chloe
-http.server.boilerplate
-http.server.auth.providers
-http.server.auth.providers.db
-http.server.auth.login
-http.server.auth
-http.server.forms
-http.server.components.inspector
-http.server.validators
-http.server.sessions
-http.server.actions
-http.server.crud
-http.server ;
-EXCLUDE: http.server.components => string? number? ;
-IN: http.server.auth.admin
-
-: admin-template ( name -- template )
- "resource:extra/http/server/auth/admin/" swap ".xml" 3append <chloe> ;
-
-: words>strings ( seq -- seq' )
- [ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ;
-
-: strings>words ( seq -- seq' )
- [ ":" split1 swap lookup ] map ;
-
-: <capabilities> ( id -- component )
- capabilities get words>strings <menu> ;
-
-: <new-user-form> ( -- form )
- "user" <form>
- "new-user" admin-template >>edit-template
- "username" <string> add-field
- "realname" <string> add-field
- "new-password" <password> t >>required add-field
- "verify-password" <password> t >>required add-field
- "email" <email> add-field
- "capabilities" <capabilities> add-field ;
-
-: <edit-user-form> ( -- form )
- "user" <form>
- "edit-user" admin-template >>edit-template
- "user-summary" admin-template >>summary-template
- "username" <string> hidden >>renderer add-field
- "realname" <string> add-field
- "new-password" <password> add-field
- "verify-password" <password> add-field
- "email" <email> add-field
- "profile" <inspector> add-field
- "capabilities" <capabilities> add-field ;
-
-: <user-list-form> ( -- form )
- "user-list" <form>
- "user-list" admin-template >>view-template
- "list" <edit-user-form> +unordered+ <list> add-field ;
-
-:: <new-user-action> ( form ctor next -- action )
- <action>
- [
- blank-values
-
- "username" get ctor call
-
- {
- [ username>> "username" set-value ]
- [ realname>> "realname" set-value ]
- [ email>> "email" set-value ]
- [ profile>> "profile" set-value ]
- } cleave
- ] >>init
-
- [ form edit-form ] >>display
-
- [
- blank-values
-
- form validate-form
-
- same-password-twice
-
- user new "username" value >>username select-tuple
- [ user-exists ] when
-
- "username" value <user>
- "realname" value >>realname
- "email" value >>email
- "new-password" value >>encoded-password
- H{ } clone >>profile
-
- insert-tuple
-
- next f <standard-redirect>
- ] >>submit ;
-
-:: <edit-user-action> ( form ctor next -- action )
- <action>
- { { "username" [ v-required ] } } >>get-params
-
- [
- blank-values
-
- "username" get ctor call select-tuple
-
- {
- [ username>> "username" set-value ]
- [ realname>> "realname" set-value ]
- [ email>> "email" set-value ]
- [ profile>> "profile" set-value ]
- [ capabilities>> words>strings "capabilities" set-value ]
- } cleave
- ] >>init
-
- [ form edit-form ] >>display
-
- [
- blank-values
-
- form validate-form
-
- "username" value <user> select-tuple
- "realname" value >>realname
- "email" value >>email
-
- { "new-password" "verify-password" }
- [ value empty? ] all? [
- same-password-twice
- "new-password" value >>encoded-password
- ] unless
-
- "capabilities" value {
- { [ dup string? ] [ 1array ] }
- { [ dup array? ] [ ] }
- } cond strings>words >>capabilities
-
- update-tuple
-
- next f <standard-redirect>
- ] >>submit ;
-
-:: <delete-user-action> ( ctor next -- action )
- <action>
- { { "username" [ ] } } >>post-params
-
- [
- "username" get
- [ <user> select-tuple 1 >>deleted update-tuple ]
- [ logout-all-sessions ]
- bi
-
- next f <standard-redirect>
- ] >>submit ;
-
-TUPLE: user-admin < dispatcher ;
-
-SYMBOL: can-administer-users?
-
-can-administer-users? define-capability
-
-:: <user-admin> ( -- responder )
- [let | ctor [ [ <user> ] ] |
- user-admin new-dispatcher
- <user-list-form> ctor <list-action> "" add-responder
- <new-user-form> ctor "$user-admin" <new-user-action> "new" add-responder
- <edit-user-form> ctor "$user-admin" <edit-user-action> "edit" add-responder
- ctor "$user-admin" <delete-user-action> "delete" add-responder
- <boilerplate>
- "admin" admin-template >>template
- { can-administer-users? } <protected>
- ] ;
-
-: make-admin ( username -- )
- <user>
- select-tuple
- [ can-administer-users? suffix ] change-capabilities
- update-tuple ;
diff --git a/extra/http/server/auth/admin/user-list.xml b/extra/http/server/auth/admin/user-list.xml
deleted file mode 100644
index 520b7f2512..0000000000
--- a/extra/http/server/auth/admin/user-list.xml
+++ /dev/null
@@ -1,9 +0,0 @@
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Users</t:title>
-
- <t:summary t:component="list" />
-
-</t:chloe>
diff --git a/extra/http/server/auth/admin/user-summary.xml b/extra/http/server/auth/admin/user-summary.xml
deleted file mode 100644
index c426e7c072..0000000000
--- a/extra/http/server/auth/admin/user-summary.xml
+++ /dev/null
@@ -1,9 +0,0 @@
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:a t:href="$user-admin/edit" t:query="username">
- <t:view t:component="username" />
- </t:a>
-
-</t:chloe>
diff --git a/extra/webapps/pastebin/paste-list.xml b/extra/webapps/pastebin/paste-list.xml
deleted file mode 100644
index c91aa6fc42..0000000000
--- a/extra/webapps/pastebin/paste-list.xml
+++ /dev/null
@@ -1,15 +0,0 @@
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Pastebin</t:title>
-
- <table width="100%">
- <th align="left" width="50%">Summary:</th>
- <th align="left" width="100">Paste by:</th>
- <th align="left" width="200">Date:</th>
-
- <t:summary t:component="pastes" />
- </table>
-
-</t:chloe>
diff --git a/extra/webapps/pastebin/pastebin-common.xml b/extra/webapps/pastebin/pastebin-common.xml
new file mode 100644
index 0000000000..b99cf28753
--- /dev/null
+++ b/extra/webapps/pastebin/pastebin-common.xml
@@ -0,0 +1,31 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:atom t:title="Pastebin - Atom" t:href="$pastebin/feed.xml" />
+
+ <t:style t:include="resource:extra/webapps/pastebin/pastebin.css" />
+
+ <div class="navbar">
+
+ <t:a t:href="$pastebin/list">Pastes</t:a>
+ | <t:a t:href="$pastebin/new-paste">New Paste</t:a>
+ | <t:a t:href="$pastebin/feed.xml">Atom Feed</t:a>
+
+ <t:if t:code="http.server.sessions:uid">
+
+ <t:if t:code="http.server.auth.login:allow-edit-profile?">
+ | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ </t:if>
+
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+
+ </t:if>
+
+ </div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
diff --git a/extra/webapps/pastebin/pastebin.xml b/extra/webapps/pastebin/pastebin.xml
index 7ca4c95f8e..46604598ce 100644
--- a/extra/webapps/pastebin/pastebin.xml
+++ b/extra/webapps/pastebin/pastebin.xml
@@ -2,29 +2,20 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:atom t:title="Pastebin - Atom" t:href="$pastebin/feed.xml" />
+ <t:title>Pastebin</t:title>
- <t:style t:include="resource:extra/webapps/pastebin/pastebin.css" />
+ <table width="100%">
+ <th align="left" width="50%">Summary:</th>
+ <th align="left" width="100">Paste by:</th>
+ <th align="left" width="200">Date:</th>
- <div class="navbar">
- <t:a t:href="$pastebin/list">Pastes</t:a>
- | <t:a t:href="$pastebin/new-paste">New Paste</t:a>
- | <t:a t:href="$pastebin/feed.xml">Atom Feed</t:a>
-
- <t:if t:code="http.server.sessions:uid">
-
- <t:if t:code="http.server.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
- </t:if>
-
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
-
- </t:if>
-
- </div>
-
- <h1><t:write-title /></h1>
-
- <t:call-next-template />
+ <t:each-tuple t:values="pastes">
+ <tr>
+ <td><t:a t:href="$pastebin/view-paste" t:query="id"><t:field t:name="summary" /></t:a></td>
+ <td><t:field t:name="author" /></td>
+ <td><t:field t:name="date" /></td>
+ </tr>
+ </t:each-tuple>
+ </table>
</t:chloe>
diff --git a/extra/http/server/auth/admin/edit-user.xml b/extra/webapps/user-admin/edit-user.xml
similarity index 100%
rename from extra/http/server/auth/admin/edit-user.xml
rename to extra/webapps/user-admin/edit-user.xml
diff --git a/extra/http/server/auth/admin/new-user.xml b/extra/webapps/user-admin/new-user.xml
similarity index 100%
rename from extra/http/server/auth/admin/new-user.xml
rename to extra/webapps/user-admin/new-user.xml
diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor
new file mode 100644
index 0000000000..172ab62c50
--- /dev/null
+++ b/extra/webapps/user-admin/user-admin.factor
@@ -0,0 +1,160 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences accessors namespaces combinators words
+assocs db.tuples arrays splitting strings validators
+html.elements
+html.components
+html.templates.chloe
+http.server.boilerplate
+http.server.auth.providers
+http.server.auth.providers.db
+http.server.auth.login
+http.server.auth
+http.server.sessions
+http.server.actions
+http.server.crud
+http.server ;
+IN: webapps.user-admin
+
+: admin-template ( name -- template )
+ "resource:extra/webapps/user-admin/" swap ".xml" 3append <chloe> ;
+
+: words>strings ( seq -- seq' )
+ [ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ;
+
+: strings>words ( seq -- seq' )
+ [ ":" split1 swap lookup ] map ;
+
+: <user-list-action> ( -- action )
+ <action>
+ [ f <user> select-tuples "users" set-value ] >>init
+ [ "user-list" admin-template <html-content> ] >>display ;
+
+: <new-user-action> ( -- action )
+ <action>
+ [
+ "username" param <user> {
+ [ username>> "username" set-value ]
+ [ realname>> "realname" set-value ]
+ [ email>> "email" set-value ]
+ [ profile>> "profile" set-value ]
+ } cleave
+
+ capabilities get "all-capabilities" set-value
+ ] >>init
+
+ [ "new-user" admin-template <html-content> ] >>display
+
+ [
+ {
+ { "username" [ v-username ] }
+ { "realname" [ v-one-line ] }
+ { "new-password" [ v-password ] }
+ { "verify-password" [ v-password ] }
+ { "email" [ [ v-email ] v-optional ] }
+ { "capabilities" [ ] }
+ } validate-params
+
+ same-password-twice
+
+ user new "username" value >>username select-tuple
+ [ user-exists ] when
+ ] >>validate
+
+ [
+ "username" value <user>
+ "realname" value >>realname
+ "email" value >>email
+ "new-password" value >>encoded-password
+ H{ } clone >>profile
+
+ insert-tuple
+
+ "$user-admin" f <standard-redirect>
+ ] >>submit ;
+
+: <edit-user-action> ( -- action )
+ <action>
+ [
+ { { "username" [ v-username ] } } validate-params
+
+ "username" value <user> select-tuple {
+ [ username>> "username" set-value ]
+ [ realname>> "realname" set-value ]
+ [ email>> "email" set-value ]
+ [ profile>> "profile" set-value ]
+ [ capabilities>> words>strings "capabilities" set-value ]
+ } cleave
+
+ capabilities get "all-capabilities" set-value
+ ] >>init
+
+ [ "edit-user" admin-template <html-content> ] >>display
+
+ [
+ {
+ { "username" [ v-username ] }
+ { "realname" [ v-one-line ] }
+ { "new-password" [ [ v-password ] v-optional ] }
+ { "verify-password" [ [ v-password ] v-optional ] }
+ { "email" [ [ v-email ] v-optional ] }
+ { "capabilities" [ ] }
+ } validate-params
+
+ "new-password" "verify-password"
+ [ value empty? ] both? [
+ same-password-twice
+ ] unless
+ ] >>validate
+
+ [
+ "username" value <user> select-tuple
+ "realname" value >>realname
+ "email" value >>email
+
+ "new-password" value empty? [ drop ] [
+ "new-password" value >>encoded-password
+ ] if
+
+ "capabilities" value {
+ { [ dup string? ] [ 1array ] }
+ { [ dup array? ] [ ] }
+ } cond strings>words >>capabilities
+
+ update-tuple
+
+ "$user-admin" f <standard-redirect>
+ ] >>submit ;
+
+: <delete-user-action> ( -- action )
+ <action>
+ [
+ { { "username" [ v-username ] } } validate-params
+ [ <user> select-tuple 1 >>deleted update-tuple ]
+ [ logout-all-sessions ]
+ bi
+
+ "$user-admin" f <standard-redirect>
+ ] >>submit ;
+
+TUPLE: user-admin < dispatcher ;
+
+SYMBOL: can-administer-users?
+
+can-administer-users? define-capability
+
+: <user-admin> ( -- responder )
+ user-admin new-dispatcher
+ <user-list-action> "" add-responder
+ <new-user-action> "new" add-responder
+ <edit-user-action> "edit" add-responder
+ <delete-user-action> "delete" add-responder
+ <boilerplate>
+ "admin" admin-template >>template
+ { can-administer-users? } <protected> ;
+
+: make-admin ( username -- )
+ <user>
+ select-tuple
+ [ can-administer-users? suffix ] change-capabilities
+ update-tuple ;
diff --git a/extra/http/server/auth/admin/admin.xml b/extra/webapps/user-admin/user-admin.xml
similarity index 100%
rename from extra/http/server/auth/admin/admin.xml
rename to extra/webapps/user-admin/user-admin.xml
diff --git a/extra/webapps/user-admin/user-list.xml b/extra/webapps/user-admin/user-list.xml
new file mode 100644
index 0000000000..6887308754
--- /dev/null
+++ b/extra/webapps/user-admin/user-list.xml
@@ -0,0 +1,13 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Users</t:title>
+
+ <t:each-tuple t:values="users">
+ <t:a t:href="$user-admin/edit" t:query="username">
+ <t:label t:name="username" />
+ </t:a>
+ </t:each-tuple>
+
+</t:chloe>
From 5cb13132af08a2615889fdaf0b01404905f96377 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 25 May 2008 19:44:37 -0500
Subject: [PATCH 22/66] adjoin and conjoin words added
---
core/combinators/combinators.factor | 4 ++--
core/compiler/units/units.factor | 2 +-
core/generator/fixup/fixup.factor | 4 ++--
core/sequences/sequences-docs.factor | 18 +-----------------
core/sequences/sequences-tests.factor | 4 ++--
core/sequences/sequences.factor | 2 --
core/sets/sets-docs.factor | 18 ++++++++++++++++++
core/sets/sets.factor | 12 ++++++++----
extra/multi-methods/multi-methods.factor | 2 +-
extra/trees/splay/splay-tests.factor | 2 +-
extra/ui/tools/interactor/interactor.factor | 2 +-
11 files changed, 37 insertions(+), 33 deletions(-)
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index d33edfab30..f6873429fe 100755
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -95,10 +95,10 @@ M: hashtable hashcode*
: (distribute-buckets) ( buckets pair keys -- )
dup t eq? [
- drop [ swap push-new ] curry each
+ drop [ swap adjoin ] curry each
] [
[
- >r 2dup r> hashcode pick length rem rot nth push-new
+ >r 2dup r> hashcode pick length rem rot nth adjoin
] each 2drop
] if ;
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index a31cd8de16..11c81f4097 100755
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -14,7 +14,7 @@ TUPLE: redefine-error def ;
{ { "Continue" t } } throw-restarts drop ;
: add-once ( key assoc -- )
- 2dup key? [ over redefine-error ] when dupd set-at ;
+ 2dup key? [ over redefine-error ] when conjoin ;
: (remember-definition) ( definition loc assoc -- )
>r over set-where r> add-once ;
diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor
index 06895cd8ac..b38d70fb80 100755
--- a/core/generator/fixup/fixup.factor
+++ b/core/generator/fixup/fixup.factor
@@ -102,13 +102,13 @@ M: frame-required fixup* drop ;
M: integer fixup* , ;
-: push-new* ( obj table -- n )
+: adjoin* ( obj table -- n )
2dup swap [ eq? ] curry find drop
[ 2nip ] [ dup length >r push r> ] if* ;
SYMBOL: literal-table
-: add-literal ( obj -- n ) literal-table get push-new* ;
+: add-literal ( obj -- n ) literal-table get adjoin* ;
: add-dlsym-literals ( symbol dll -- )
>r string>symbol r> 2array literal-table get push-all ;
diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index 351ba89692..2c1a3b8ab9 100755
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -191,7 +191,6 @@ $nl
"Other destructive words:"
{ $subsection move }
{ $subsection exchange }
-{ $subsection push-new }
{ $subsection copy }
{ $subsection replace-slice }
{ $see-also set-nth push pop "sequences-stacks" } ;
@@ -624,22 +623,7 @@ HELP: replace-slice
{ $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "seq" } "." }
{ $side-effects "seq" } ;
-HELP: push-new
-{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
-{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
-{ $examples
- { $example
- "USING: namespaces prettyprint sequences ;"
- "V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set"
- "\"nachos\" \"v\" get push-new"
- "\"salsa\" \"v\" get push-new"
- "\"v\" get ."
- "V{ \"beans\" \"cheese\" \"nachos\" \"salsa\" }"
- }
-}
-{ $side-effects "seq" } ;
-
-{ push push-new prefix suffix } related-words
+{ push prefix suffix } related-words
HELP: suffix
{ $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor
index 2479c125a2..0511721c18 100755
--- a/core/sequences/sequences-tests.factor
+++ b/core/sequences/sequences-tests.factor
@@ -216,10 +216,10 @@ unit-test
] unit-test
[ V{ 1 2 3 } ]
-[ 3 V{ 1 2 } clone [ push-new ] keep ] unit-test
+[ 3 V{ 1 2 } clone [ adjoin ] keep ] unit-test
[ V{ 1 2 3 } ]
-[ 3 V{ 1 3 2 } clone [ push-new ] keep ] unit-test
+[ 3 V{ 1 3 2 } clone [ adjoin ] keep ] unit-test
! erg's random tester found this one
[ SBUF" 12341234" ] [
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 4153430514..4854ff8001 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -499,8 +499,6 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: delete ( elt seq -- ) 0 0 rot (delete) nip set-length drop ;
-: push-new ( elt seq -- ) [ delete ] 2keep push ;
-
: prefix ( seq elt -- newseq )
over >r over length 1+ r> [
[ 0 swap set-nth-unsafe ] keep
diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor
index f4e2557a71..97fbc973f0 100644
--- a/core/sets/sets-docs.factor
+++ b/core/sets/sets-docs.factor
@@ -16,10 +16,28 @@ $nl
{ $subsection set= }
"A word used to implement the above:"
{ $subsection unique }
+"Adding elements to sets:"
+{ $subsection adjoin }
+{ $subsection conjoin }
{ $see-also member? memq? contains? all? "assocs-sets" } ;
ABOUT: "sets"
+HELP: adjoin
+{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
+{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
+{ $examples
+ { $example
+ "USING: namespaces prettyprint sequences ;"
+ "V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set"
+ "\"nachos\" \"v\" get adjoin"
+ "\"salsa\" \"v\" get adjoin"
+ "\"v\" get ."
+ "V{ \"beans\" \"cheese\" \"nachos\" \"salsa\" }"
+ }
+}
+{ $side-effects "seq" } ;
+
HELP: unique
{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
{ $description "Outputs a new assoc where the keys and values are equal." }
diff --git a/core/sets/sets.factor b/core/sets/sets.factor
index b0d26e0f30..5fbec9a7c8 100644
--- a/core/sets/sets.factor
+++ b/core/sets/sets.factor
@@ -3,10 +3,14 @@
USING: assocs hashtables kernel sequences vectors ;
IN: sets
+: adjoin ( elt seq -- ) [ delete ] [ push ] 2bi ;
+
+: conjoin ( elt assoc -- ) dupd set-at ;
+
: (prune) ( elt hash vec -- )
- 3dup drop key?
- [ [ drop dupd set-at ] [ nip push ] [ ] 3tri ] unless
- 3drop ; inline
+ 3dup drop key? [ 3drop ] [
+ [ drop conjoin ] [ nip push ] 3bi
+ ] if ; inline
: prune ( seq -- newseq )
[ ] [ length <hashtable> ] [ length <vector> ] tri
@@ -16,7 +20,7 @@ IN: sets
[ dup ] H{ } map>assoc ;
: (all-unique?) ( elt hash -- ? )
- 2dup key? [ 2drop f ] [ dupd set-at t ] if ;
+ 2dup key? [ 2drop f ] [ conjoin t ] if ;
: all-unique? ( seq -- ? )
dup length <hashtable> [ (all-unique?) ] curry all? ;
diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor
index 59e8049232..b1073c116d 100755
--- a/extra/multi-methods/multi-methods.factor
+++ b/extra/multi-methods/multi-methods.factor
@@ -25,7 +25,7 @@ SYMBOL: total
]
[
[ pair? ] filter
- [ keys [ hooks get push-new ] each ] keep
+ [ keys [ hooks get adjoin ] each ] keep
] bi append ;
: canonicalize-specializer-2 ( specializer -- specializer' )
diff --git a/extra/trees/splay/splay-tests.factor b/extra/trees/splay/splay-tests.factor
index 29ea2eee2d..29bc153030 100644
--- a/extra/trees/splay/splay-tests.factor
+++ b/extra/trees/splay/splay-tests.factor
@@ -8,7 +8,7 @@ IN: trees.splay.tests
100 [ drop 100 random swap at drop ] with each ;
: make-numeric-splay-tree ( n -- splay-tree )
- <splay> [ [ dupd set-at ] curry each ] keep ;
+ <splay> [ [ conjoin ] curry each ] keep ;
[ t ] [
100 make-numeric-splay-tree dup randomize-numeric-splay-tree
diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor
index 2e59363531..c28e8aec7c 100755
--- a/extra/ui/tools/interactor/interactor.factor
+++ b/extra/ui/tools/interactor/interactor.factor
@@ -76,7 +76,7 @@ M: interactor model-changed
] with-output-stream* ;
: add-interactor-history ( str interactor -- )
- over empty? [ 2drop ] [ interactor-history push-new ] if ;
+ over empty? [ 2drop ] [ interactor-history adjoin ] if ;
: interactor-continue ( obj interactor -- )
mailbox>> mailbox-put ;
From a84880d770b5e5b18c26a649bdea078e8b074ff9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 25 May 2008 19:45:21 -0500
Subject: [PATCH 23/66] Fix parameter ordering
---
extra/db/db.factor | 2 +-
extra/db/pools/pools.factor | 8 ++++----
2 files changed, 5 insertions(+), 5 deletions(-)
diff --git a/extra/db/db.factor b/extra/db/db.factor
index 9514f62cf0..4b98612069 100755
--- a/extra/db/db.factor
+++ b/extra/db/db.factor
@@ -127,7 +127,7 @@ M: nonthrowable execute-statement* ( statement type -- )
: query-map ( statement quot -- seq )
accumulator >r query-each r> { } like ; inline
-: with-db ( db seq quot -- )
+: with-db ( seq class quot -- )
>r make-db db-open db r>
[ db get swap [ drop ] prepose with-disposal ] curry with-variable ;
inline
diff --git a/extra/db/pools/pools.factor b/extra/db/pools/pools.factor
index 4d201c2edf..63153c451e 100644
--- a/extra/db/pools/pools.factor
+++ b/extra/db/pools/pools.factor
@@ -6,16 +6,16 @@ IN: db.pools
TUPLE: db-pool < pool db params ;
-: <db-pool> ( db params -- pool )
+: <db-pool> ( params db -- pool )
db-pool <pool>
- swap >>params
- swap >>db ;
+ swap >>db
+ swap >>params ;
: with-db-pool ( db params quot -- )
>r <db-pool> r> with-pool ; inline
M: db-pool make-connection ( pool -- )
- [ db>> ] [ params>> ] bi make-db db-open ;
+ [ params>> ] [ db>> ] bi make-db db-open ;
: with-pooled-db ( pool quot -- )
[ db swap with-variable ] curry with-pooled-connection ; inline
From d589ac19dd1f3b95f4fb31f6224fde66d99169d6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 26 May 2008 00:47:27 -0500
Subject: [PATCH 24/66] Reworking validation
---
extra/html/components/components-tests.factor | 10 +
extra/html/components/components.factor | 42 ++-
extra/html/templates/chloe/chloe-tests.factor | 40 ++-
extra/html/templates/chloe/chloe.factor | 28 +-
extra/html/templates/chloe/test/test10.xml | 14 +
extra/html/templates/chloe/test/test11.xml | 14 +
extra/html/templates/chloe/test/test9.xml | 11 +
extra/html/templates/templates.factor | 4 +-
extra/http/client/client.factor | 2 +-
extra/http/http-tests.factor | 2 +-
extra/http/http.factor | 32 +-
.../http/server/actions/actions-tests.factor | 10 +-
extra/http/server/actions/actions.factor | 122 ++++---
extra/http/server/auth/auth.factor | 4 +-
extra/http/server/auth/login/edit-profile.xml | 14 +-
extra/http/server/auth/login/login.factor | 329 +++++++----------
extra/http/server/auth/login/login.xml | 6 +-
extra/http/server/auth/login/recover-1.xml | 32 +-
extra/http/server/auth/login/recover-3.xml | 18 +-
extra/http/server/auth/login/register.xml | 80 ++---
.../server/auth/providers/assoc/assoc.factor | 4 +-
.../server/boilerplate/boilerplate.factor | 64 +---
extra/http/server/callbacks/callbacks.factor | 4 +-
extra/http/server/crud/crud.factor | 7 +-
extra/http/server/db/db.factor | 2 +-
extra/http/server/server-tests.factor | 6 +-
extra/http/server/server.factor | 38 +-
.../server/sessions/sessions-tests.factor | 8 +-
extra/http/server/static/static.factor | 29 +-
extra/webapps/counter/counter.factor | 23 +-
extra/webapps/counter/counter.xml | 13 +
.../factor-website/factor-website.factor | 12 +-
extra/webapps/factor-website/page.css | 20 ++
extra/webapps/pastebin/new-paste.xml | 10 +-
extra/webapps/pastebin/paste.xml | 52 ++-
extra/webapps/pastebin/pastebin-common.xml | 3 -
extra/webapps/pastebin/pastebin.factor | 332 +++++++++---------
extra/webapps/pastebin/pastebin.xml | 2 +
extra/webapps/planet/admin.xml | 14 +-
extra/webapps/planet/edit-blog.xml | 7 +-
extra/webapps/planet/mini-planet.xml | 14 +
extra/webapps/planet/new-blog.xml | 32 ++
extra/webapps/planet/planet-common.xml | 25 ++
extra/webapps/planet/planet.factor | 235 +++++++------
extra/webapps/planet/planet.xml | 50 ++-
extra/webapps/planet/postings-summary.xml | 7 -
extra/webapps/planet/postings.xml | 19 -
extra/webapps/todo/edit-todo.xml | 6 +-
extra/webapps/todo/todo-list.xml | 29 +-
extra/webapps/todo/todo.factor | 127 ++++---
extra/webapps/todo/todo.xml | 2 +-
extra/webapps/todo/view-todo.xml | 6 +-
extra/webapps/user-admin/edit-user.xml | 16 +-
extra/webapps/user-admin/new-user.xml | 14 +-
extra/webapps/user-admin/user-admin.factor | 59 ++--
extra/webapps/user-admin/user-list.xml | 16 +-
extra/xmode/catalog/catalog.factor | 12 +-
.../code2html/responder/responder.factor | 13 +-
58 files changed, 1197 insertions(+), 949 deletions(-)
create mode 100644 extra/html/templates/chloe/test/test10.xml
create mode 100644 extra/html/templates/chloe/test/test11.xml
create mode 100644 extra/html/templates/chloe/test/test9.xml
create mode 100644 extra/webapps/counter/counter.xml
create mode 100644 extra/webapps/planet/mini-planet.xml
create mode 100644 extra/webapps/planet/new-blog.xml
create mode 100644 extra/webapps/planet/planet-common.xml
delete mode 100644 extra/webapps/planet/postings-summary.xml
delete mode 100644 extra/webapps/planet/postings.xml
diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor
index d09f8b6b42..f2b0049a8e 100644
--- a/extra/html/components/components-tests.factor
+++ b/extra/html/components/components-tests.factor
@@ -168,3 +168,13 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ "object" value [ describe ] with-html-stream ] with-string-writer
=
] unit-test
+
+[ ] [ blank-values ] unit-test
+
+[ ] [
+ "factor" [
+ "concatenative" "model" set-value
+ ] nest-values
+] unit-test
+
+[ H{ { "factor" H{ { "model" "concatenative" } } } } ] [ values get ] unit-test
diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor
index faef9ca1b5..e6df343161 100644
--- a/extra/html/components/components.factor
+++ b/extra/html/components/components.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces io math.parser assocs classes
-classes.tuple words arrays sequences splitting mirrors
-hashtables combinators continuations math strings
+classes.tuple words arrays sequences sequences.lib splitting
+mirrors hashtables combinators continuations math strings
fry locals calendar calendar.format xml.entities validators
html.elements html.streams xmode.code2html farkup inspector ;
IN: html.components
@@ -18,22 +18,52 @@ SYMBOL: values
: prepare-value ( name object -- value name object )
[ [ value ] keep ] dip ; inline
-: from-tuple <mirror> values set ;
+: from-assoc ( assoc -- ) values get swap update ;
-: values-tuple values get object>> ;
+: from-tuple ( tuple -- ) <mirror> from-assoc ;
+
+: deposit-values ( destination names -- )
+ [ dup value ] H{ } map>assoc update ;
+
+: deposit-slots ( destination names -- )
+ [ <mirror> ] dip deposit-values ;
+
+: with-each-index ( seq quot -- )
+ '[
+ [
+ blank-values 1+ "index" set-value @
+ ] with-scope
+ ] each-index ; inline
+
+: with-each-value ( seq quot -- )
+ '[ "value" set-value @ ] with-each-index ; inline
+
+: with-each-assoc ( seq quot -- )
+ '[ from-assoc @ ] with-each-index ; inline
+
+: with-each-tuple ( seq quot -- )
+ '[ from-tuple @ ] with-each-index ; inline
+
+: nest-values ( name quot -- )
+ swap [
+ [
+ H{ } clone [ values set call ] keep
+ ] with-scope
+ ] dip set-value ; inline
: object>string ( object -- string )
{
{ [ dup real? ] [ number>string ] }
{ [ dup timestamp? ] [ timestamp>string ] }
{ [ dup string? ] [ ] }
+ { [ dup word? ] [ word-name ] }
{ [ dup not ] [ drop "" ] }
} cond ;
GENERIC: render* ( value name render -- )
: render ( name renderer -- )
- over validation-messages get at [
+ over named-validation-messages get at [
[ value>> ] [ message>> ] bi
[ -rot render* ] dip
render-error
@@ -103,7 +133,7 @@ TUPLE: choice size multiple choices ;
: render-option ( text selected? -- )
<option [ "true" =selected ] when option>
- escape-string write
+ object>string escape-string write
</option> ;
: render-options ( options selected -- )
diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor
index 4d8d15c581..eaa0f0dc3d 100644
--- a/extra/html/templates/chloe/chloe-tests.factor
+++ b/extra/html/templates/chloe/chloe-tests.factor
@@ -1,7 +1,7 @@
USING: html.templates html.templates.chloe
tools.test io.streams.string kernel sequences ascii boxes
namespaces xml html.components
-splitting ;
+splitting unicode.categories ;
IN: html.templates.chloe.tests
[ f ] [ f parse-query-attr ] unit-test
@@ -117,9 +117,45 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ ] [ "new york" "choice" set-value ] unit-test
[ ] [ { "new york" "detroit" "minneapolis" } "choices" set-value ] unit-test
-
+
[ ] [
[
"test8" test-template call-template
] run-template drop
] unit-test
+
+[ ] [ { 1 2 3 } "numbers" set-value ] unit-test
+
+[ "<ul><li>1</li><li>2</li><li>3</li></ul>" ] [
+ [
+ "test9" test-template call-template
+ ] run-template [ blank? not ] filter
+] unit-test
+
+TUPLE: person first-name last-name ;
+
+[ ] [
+ {
+ T{ person f "RBaxter" "Unknown" }
+ T{ person f "Doug" "Coleman" }
+ } "people" set-value
+] unit-test
+
+[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
+ [
+ "test10" test-template call-template
+ ] run-template [ blank? not ] filter
+] unit-test
+
+[ ] [
+ {
+ H{ { "first-name" "RBaxter" } { "last-name" "Unknown" } }
+ H{ { "first-name" "Doug" } { "last-name" "Coleman" } }
+ } "people" set-value
+] unit-test
+
+[ "<table><tr><td>RBaxter</td><td>Unknown</td></tr><tr><td>Doug</td><td>Coleman</td></tr></table>" ] [
+ [
+ "test11" test-template call-template
+ ] run-template [ blank? not ] filter
+] unit-test
diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor
index 43834f896e..4430e69336 100644
--- a/extra/html/templates/chloe/chloe.factor
+++ b/extra/html/templates/chloe/chloe.factor
@@ -3,7 +3,7 @@
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize
io io.files io.encodings.utf8 io.streams.string
-unicode.case tuple-syntax mirrors fry
+unicode.case tuple-syntax mirrors fry math
multiline xml xml.data xml.writer xml.utilities
html.elements
html.components
@@ -196,6 +196,27 @@ STRING: button-tag-markup
: if-tag ( tag -- )
dup if-satisfied? [ process-tag-children ] [ drop ] if ;
+: even-tag ( tag -- )
+ "index" value even? [ process-tag-children ] [ drop ] if ;
+
+: odd-tag ( tag -- )
+ "index" value odd? [ process-tag-children ] [ drop ] if ;
+
+: (each-tag) ( tag quot -- )
+ [
+ [ "values" required-attr value ] keep
+ '[ , process-tag-children ]
+ ] dip call ; inline
+
+: each-tag ( tag -- )
+ [ with-each-value ] (each-tag) ;
+
+: each-tuple-tag ( tag -- )
+ [ with-each-tuple ] (each-tag) ;
+
+: each-assoc-tag ( tag -- )
+ [ with-each-assoc ] (each-tag) ;
+
: error-message-tag ( tag -- )
children>string render-error ;
@@ -254,6 +275,11 @@ STRING: button-tag-markup
! Control flow
{ "if" [ if-tag ] }
+ { "even" [ even-tag ] }
+ { "odd" [ odd-tag ] }
+ { "each" [ each-tag ] }
+ { "each-assoc" [ each-assoc-tag ] }
+ { "each-tuple" [ each-tuple-tag ] }
{ "comment" [ drop ] }
{ "call-next-template" [ drop call-next-template ] }
diff --git a/extra/html/templates/chloe/test/test10.xml b/extra/html/templates/chloe/test/test10.xml
new file mode 100644
index 0000000000..afded9366f
--- /dev/null
+++ b/extra/html/templates/chloe/test/test10.xml
@@ -0,0 +1,14 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <table>
+ <t:each-tuple t:values="people">
+ <tr>
+ <td><t:label t:name="first-name"/></td>
+ <td><t:label t:name="last-name"/></td>
+ </tr>
+ </t:each-tuple>
+ </table>
+
+</t:chloe>
diff --git a/extra/html/templates/chloe/test/test11.xml b/extra/html/templates/chloe/test/test11.xml
new file mode 100644
index 0000000000..17e31b1a59
--- /dev/null
+++ b/extra/html/templates/chloe/test/test11.xml
@@ -0,0 +1,14 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <table>
+ <t:each-assoc t:values="people">
+ <tr>
+ <td><t:label t:name="first-name"/></td>
+ <td><t:label t:name="last-name"/></td>
+ </tr>
+ </t:each-assoc>
+ </table>
+
+</t:chloe>
diff --git a/extra/html/templates/chloe/test/test9.xml b/extra/html/templates/chloe/test/test9.xml
new file mode 100644
index 0000000000..bcfc468738
--- /dev/null
+++ b/extra/html/templates/chloe/test/test9.xml
@@ -0,0 +1,11 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <ul>
+ <t:each t:values="numbers">
+ <li><t:label t:name="value"/></li>
+ </t:each>
+ </ul>
+
+</t:chloe>
diff --git a/extra/html/templates/templates.factor b/extra/html/templates/templates.factor
index ed26c9b531..580af58ecc 100644
--- a/extra/html/templates/templates.factor
+++ b/extra/html/templates/templates.factor
@@ -19,12 +19,12 @@ ERROR: template-error template error ;
M: template-error error.
"Error while processing template " write
- [ template>> pprint ":" print nl ]
+ [ template>> short. ":" print nl ]
[ error>> error. ]
bi ;
: call-template ( template -- )
- [ call-template* ] [ template-error ] recover ;
+ [ call-template* ] [ \ template-error boa rethrow ] recover ;
SYMBOL: title
diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor
index c455c8c5f1..7b156a4b9b 100755
--- a/extra/http/client/client.factor
+++ b/extra/http/client/client.factor
@@ -93,7 +93,7 @@ M: download-failed error.
: download-to ( url file -- )
#! Downloads the contents of a URL to a file.
- >r http-get r> latin1 [ write ] with-file-writer ;
+ [ http-get ] dip latin1 [ write ] with-file-writer ;
: download ( url -- )
dup download-name download-to ;
diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor
index 89480b43ba..151d1ce84f 100755
--- a/extra/http/http-tests.factor
+++ b/extra/http/http-tests.factor
@@ -237,7 +237,7 @@ test-db [
[ ] [
[
<dispatcher>
- <action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display
+ <action> [ [ "Hi" write ] <text-content> ] >>display
<login>
<sessions>
"" add-responder
diff --git a/extra/http/http.factor b/extra/http/http.factor
index 7587cb0fe9..89c8f62d5c 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -9,7 +9,9 @@ math.parser calendar calendar.format
io io.streams.string io.encodings.utf8 io.encodings.string
io.sockets io.sockets.secure
-unicode.case unicode.categories qualified ;
+unicode.case unicode.categories qualified
+
+html.templates ;
EXCLUDE: fry => , ;
@@ -65,14 +67,14 @@ M: https protocol>string drop "https" ;
2dup length 2 - >= [
2drop
] [
- >r 1+ dup 2 + r> subseq hex> [ , ] when*
+ [ 1+ dup 2 + ] dip subseq hex> [ , ] when*
] if ;
: url-decode-% ( index str -- index str )
- 2dup url-decode-hex >r 3 + r> ;
+ 2dup url-decode-hex [ 3 + ] dip ;
: url-decode-+-or-other ( index str ch -- index str )
- dup CHAR: + = [ drop CHAR: \s ] when , >r 1+ r> ;
+ dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ;
: url-decode-iter ( index str -- )
2dup length >= [
@@ -158,7 +160,7 @@ M: https protocol>string drop "https" ;
dup [
"&" split H{ } clone [
[
- >r "=" split1 [ dup [ url-decode ] when ] bi@ swap r>
+ [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip
add-query-param
] curry each
] keep
@@ -174,7 +176,7 @@ M: https protocol>string drop "https" ;
] assoc-map
[
[
- >r url-encode r>
+ [ url-encode ] dip
[ url-encode "=" swap 3append , ] with each
] assoc-each
] { } make "&" join ;
@@ -342,7 +344,7 @@ SYMBOL: max-post-request
dup "cookie" header [ parse-cookies >>cookies ] when* ;
: parse-content-type-attributes ( string -- attributes )
- " " split harvest [ "=" split1 >r >lower r> ] { } map>assoc ;
+ " " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
: parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ;
@@ -521,18 +523,8 @@ body ;
over unparse-content-type "content-type" pick set-at
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* output-stream get stream-copy ;
-
: write-response-body ( response -- response )
- dup body>> write-response-body* ;
+ dup body>> call-template ;
M: response write-response ( respose -- )
write-response-version
@@ -547,10 +539,10 @@ M: response write-full-response ( request response -- )
swap method>> "HEAD" = [ write-response-body ] unless ;
: get-cookie ( request/response name -- cookie/f )
- >r cookies>> r> '[ , _ name>> = ] find nip ;
+ [ cookies>> ] dip '[ , _ name>> = ] find nip ;
: delete-cookie ( request/response name -- )
- over cookies>> >r get-cookie r> delete ;
+ over cookies>> [ get-cookie ] dip delete ;
: put-cookie ( request/response cookie -- request/response )
[ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
diff --git a/extra/http/server/actions/actions-tests.factor b/extra/http/server/actions/actions-tests.factor
index 5aa761603f..480cbc8e96 100755
--- a/extra/http/server/actions/actions-tests.factor
+++ b/extra/http/server/actions/actions-tests.factor
@@ -1,16 +1,10 @@
-USING: http.server.actions http.server.validators
+USING: kernel http.server.actions validators
tools.test math math.parser multiline namespaces http
io.streams.string http.server sequences splitting accessors ;
IN: http.server.actions.tests
-[
- "a" [ v-number ] { { "a" "123" } } validate-param
- [ 123 ] [ "a" get ] unit-test
-] with-scope
-
<action>
- [ "a" get "b" get + ] >>display
- { { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params
+ [ "a" param "b" param [ string>number ] bi@ + ] >>display
"action-1" set
: lf>crlf "\n" split "\r\n" join ;
diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor
index 2d73cb46a7..bcd2cbd585 100755
--- a/extra/http/server/actions/actions.factor
+++ b/extra/http/server/actions/actions.factor
@@ -1,68 +1,84 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors sequences kernel assocs combinators
-http.server http.server.validators http hashtables namespaces
-fry continuations locals boxes xml.entities html.elements io ;
+USING: accessors sequences kernel assocs combinators http.server
+validators http hashtables namespaces fry continuations locals
+boxes xml.entities html.elements html.components io arrays ;
IN: http.server.actions
SYMBOL: params
-SYMBOL: validation-message
-
-: render-validation-message ( -- )
- validation-message get value>> [
- <span "error" =class span>
- escape-string write
- </span>
- ] when* ;
-
-TUPLE: action init display submit get-params post-params ;
-
-: <action>
- action new
- [ ] >>init
- [ <400> ] >>display
- [ <400> ] >>submit ;
-
-:: validate-param ( name validator assoc -- )
- name assoc at validator with-validator name set ; inline
-
-: action-params ( validators -- error? )
- validation-failed? off
- params get '[ , validate-param ] assoc-each
- validation-failed? get ;
-
-: handle-get ( -- response )
- action get get-params>> action-params [ <400> ] [
- action get [ init>> call ] [ display>> call ] bi
+: render-validation-messages ( -- )
+ validation-messages get
+ dup empty? [ drop ] [
+ <ul "errors" =class ul>
+ [ <li> message>> escape-string write </li> ] each
+ </ul>
] if ;
-: handle-post ( -- response )
- action get post-params>> action-params
- [ <400> ] [ action get submit>> call ] if ;
+TUPLE: action init display validate submit ;
+
+: new-action ( class -- action )
+ new
+ [ ] >>init
+ [ <400> ] >>display
+ [ ] >>validate
+ [ <400> ] >>submit ;
+
+: <action> ( -- action )
+ action new-action ;
+
+: handle-get ( action -- response )
+ blank-values
+ [ init>> call ]
+ [ display>> call ]
+ bi ;
: validation-failed ( -- * )
- action get display>> call exit-with ;
+ request get method>> "POST" =
+ [ action get display>> call ] [ <400> ] if exit-with ;
-: validation-failed-with ( string -- * )
- validation-message get >box
- validation-failed ;
+: handle-post ( action -- response )
+ init-validation
+ blank-values
+ [ validate>> call ]
+ [ submit>> call ] bi ;
M: action call-responder* ( path action -- response )
+ dup action set
'[
- , [ CHAR: / = ] right-trim empty? [
- , action set
- request get
- <box> validation-message set
- [ request-params params set ]
- [
- method>> {
- { "GET" [ handle-get ] }
- { "HEAD" [ handle-get ] }
- { "POST" [ handle-post ] }
- } case
- ] bi
- ] [
- <404>
- ] if
+ , empty? [
+ init-validation
+ ,
+ request get [ request-params params set ] [ method>> ] bi
+ {
+ { "GET" [ handle-get ] }
+ { "HEAD" [ handle-get ] }
+ { "POST" [ handle-post ] }
+ } case
+ ] [ <404> ] if
] with-exit-continuation ;
+
+: param ( name -- value )
+ params get at ;
+
+: check-validation ( -- )
+ validation-failed? [ validation-failed ] when ;
+
+: validate-params ( validators -- )
+ params get swap validate-values from-assoc
+ check-validation ;
+
+: validate-integer-id ( -- )
+ { { "id" [ v-number ] } } validate-params ;
+
+TUPLE: page-action < action template ;
+
+: <page-action> ( -- page )
+ page-action new-action
+ dup '[ , template>> <html-content> ] >>display ;
+
+TUPLE: feed-action < action feed ;
+
+: <feed-action> ( -- feed )
+ feed-action new
+ dup '[ , feed>> call <feed-content> ] >>display ;
diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor
index 36fcff4b2e..4b34fbe804 100755
--- a/extra/http/server/auth/auth.factor
+++ b/extra/http/server/auth/auth.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs namespaces kernel sequences
+USING: accessors assocs namespaces kernel sequences sets
http.server
http.server.sessions
http.server.auth.providers ;
@@ -38,4 +38,4 @@ SYMBOL: capabilities
V{ } clone capabilities set-global
-: define-capability ( word -- ) capabilities get push-new ;
+: define-capability ( word -- ) capabilities get adjoin ;
diff --git a/extra/http/server/auth/login/edit-profile.xml b/extra/http/server/auth/login/edit-profile.xml
index 1eaf65fa07..855dfa8469 100644
--- a/extra/http/server/auth/login/edit-profile.xml
+++ b/extra/http/server/auth/login/edit-profile.xml
@@ -10,12 +10,12 @@
<tr>
<th class="field-label">User name:</th>
- <td><t:view t:component="username" /></td>
+ <td><t:field t:name="username" /></td>
</tr>
<tr>
<th class="field-label">Real name:</th>
- <td><t:edit t:component="realname" /></td>
+ <td><t:field t:name="realname" /></td>
</tr>
<tr>
@@ -25,7 +25,7 @@
<tr>
<th class="field-label">Current password:</th>
- <td><t:edit t:component="password" /></td>
+ <td><t:password t:name="password" /></td>
</tr>
<tr>
@@ -35,12 +35,12 @@
<tr>
<th class="field-label">New password:</th>
- <td><t:edit t:component="new-password" /></td>
+ <td><t:password t:name="new-password" /></td>
</tr>
<tr>
<th class="field-label">Verify:</th>
- <td><t:edit t:component="verify-password" /></td>
+ <td><t:password t:name="verify-password" /></td>
</tr>
<tr>
@@ -50,7 +50,7 @@
<tr>
<th class="field-label">E-mail:</th>
- <td><t:edit t:component="email" /></td>
+ <td><t:field t:name="email" /></td>
</tr>
<tr>
@@ -62,7 +62,7 @@
<p>
<input type="submit" value="Update" />
- <t:validation-message />
+ <t:validation-messages />
</p>
</t:form>
diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor
index bb77532a22..e8c9bf8608 100755
--- a/extra/http/server/auth/login/login.factor
+++ b/extra/http/server/auth/login/login.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors quotations assocs kernel splitting
combinators sequences namespaces hashtables sets
-fry arrays threads locals qualified random
+fry arrays threads qualified random validators
io
io.sockets
io.encodings.utf8
@@ -12,23 +12,22 @@ continuations
destructors
checksums
checksums.sha2
+validators
+html.components
html.elements
+html.templates
+html.templates.chloe
http
http.server
http.server.auth
http.server.auth.providers
http.server.auth.providers.db
http.server.actions
-http.server.components
http.server.flows
-http.server.forms
http.server.sessions
-http.server.boilerplate
-http.server.templating
-http.server.templating.chloe
-http.server.validators ;
-IN: http.server.auth.login
+http.server.boilerplate ;
QUALIFIED: smtp
+IN: http.server.auth.login
TUPLE: login < dispatcher users checksum ;
@@ -65,149 +64,124 @@ M: user-saver dispose
3append <chloe> ;
! ! ! Login
+: successful-login ( user -- )
+ username>> set-uid ;
-: <login-form>
- "login" <form>
- "login" login-template >>edit-template
- "username" <username>
- t >>required
- add-field
- "password" <password>
- t >>required
- add-field ;
+: login-failed ( -- * )
+ "invalid username or password" validation-error
+ validation-failed ;
-: successful-login ( user -- response )
- username>> set-uid
- "$login" end-flow ;
+: <login-action> ( -- action )
+ <action>
+ [ "login" login-template <html-content> ] >>display
-: login-failed "invalid username or password" validation-failed-with ;
+ [
+ {
+ { "username" [ v-required ] }
+ { "password" [ v-required ] }
+ } validate-params
-:: <login-action> ( -- action )
- [let | form [ <login-form> ] |
- <action>
- [ blank-values ] >>init
+ "password" value
+ "username" value check-login
+ [ successful-login ] [ login-failed ] if*
+ ] >>validate
- [ form edit-form ] >>display
-
- [
- blank-values
-
- form validate-form
-
- "password" value "username" value check-login
- [ successful-login ] [ login-failed ] if*
- ] >>submit
- ] ;
+ [ "$login" end-flow ] >>submit ;
! ! ! New user registration
-: <register-form> ( -- form )
- "register" <form>
- "register" login-template >>edit-template
- "username" <username>
- t >>required
- add-field
- "realname" <string> add-field
- "new-password" <password>
- t >>required
- add-field
- "verify-password" <password>
- t >>required
- add-field
- "email" <email> add-field
- "captcha" <captcha> add-field ;
+: user-exists ( -- * )
+ "username taken" validation-error
+ validation-failed ;
-: password-mismatch "passwords do not match" validation-failed-with ;
-
-: user-exists "username taken" validation-failed-with ;
+: password-mismatch ( -- * )
+ "passwords do not match" validation-error
+ validation-failed ;
: same-password-twice ( -- )
"new-password" value "verify-password" value =
[ password-mismatch ] unless ;
-:: <register-action> ( -- action )
- [let | form [ <register-form> ] |
- <action>
- [ blank-values ] >>init
+: <register-action> ( -- action )
+ <page-action>
+ "register" login-template >>template
- [ form edit-form ] >>display
+ [
+ {
+ { "username" [ v-username ] }
+ { "realname" [ [ v-one-line ] v-optional ] }
+ { "new-password" [ v-password ] }
+ { "verify-password" [ v-password ] }
+ { "email" [ [ v-email ] v-optional ] }
+ { "captcha" [ v-captcha ] }
+ } validate-params
- [
- blank-values
+ same-password-twice
+ ] >>validate
- form validate-form
+ [
+ "username" value <user>
+ "realname" value >>realname
+ "new-password" value >>encoded-password
+ "email" value >>email
+ H{ } clone >>profile
- same-password-twice
+ users new-user [ user-exists ] unless*
- "username" value <user>
- "realname" value >>realname
- "new-password" value >>encoded-password
- "email" value >>email
- H{ } clone >>profile
+ login get init-user-profile
- users new-user [ user-exists ] unless*
-
- successful-login
-
- login get init-user-profile
- ] >>submit
- ] ;
+ successful-login
+ ] >>submit ;
! ! ! Editing user profile
-: <edit-profile-form> ( -- form )
- "edit-profile" <form>
- "edit-profile" login-template >>edit-template
- "username" <username> add-field
- "realname" <string> add-field
- "password" <password> add-field
- "new-password" <password> add-field
- "verify-password" <password> add-field
- "email" <email> add-field ;
+: <edit-profile-action> ( -- action )
+ <action>
+ [
+ logged-in-user get
+ [ username>> "username" set-value ]
+ [ realname>> "realname" set-value ]
+ [ email>> "email" set-value ]
+ tri
+ ] >>init
-:: <edit-profile-action> ( -- action )
- [let | form [ <edit-profile-form> ] |
- <action>
- [
- blank-values
+ [ "edit-profile" login-template <html-content> ] >>display
- logged-in-user get
- [ username>> "username" set-value ]
- [ realname>> "realname" set-value ]
- [ email>> "email" set-value ]
- tri
- ] >>init
+ [
+ uid "username" set-value
- [ form edit-form ] >>display
+ {
+ { "realname" [ [ v-one-line ] v-optional ] }
+ { "password" [ ] }
+ { "new-password" [ [ v-password ] v-optional ] }
+ { "verify-password" [ [ v-password ] v-optional ] }
+ { "email" [ [ v-email ] v-optional ] }
+ } validate-params
- [
- blank-values
- uid "username" set-value
+ { "password" "new-password" "verify-password" }
+ [ value empty? not ] contains? [
+ "password" value uid check-login
+ [ "incorrect password" validation-error ] unless
- form validate-form
+ same-password-twice
+ ] when
+ ] >>validate
- logged-in-user get
+ [
+ logged-in-user get
- { "password" "new-password" "verify-password" }
- [ value empty? ] all? [
- same-password-twice
+ "new-password" value dup empty?
+ [ drop ] [ >>encoded-password ] if
- "password" value uid check-login
- [ login-failed ] unless
+ "realname" value >>realname
+ "email" value >>email
- "new-password" value >>encoded-password
- ] unless
+ t >>changed?
- "realname" value >>realname
- "email" value >>email
+ drop
- t >>changed?
-
- drop
-
- "$login" end-flow
- ] >>submit
- ] ;
+ "$login" end-flow
+ ] >>submit ;
! ! ! Password recovery
@@ -250,92 +224,61 @@ SYMBOL: lost-password-from
'[ , password-email smtp:send-email ]
"E-mail send thread" spawn drop ;
-: <recover-form-1> ( -- form )
- "register" <form>
- "recover-1" login-template >>edit-template
- "username" <username>
- t >>required
- add-field
- "email" <email>
- t >>required
- add-field
- "captcha" <captcha> add-field ;
+: <recover-action-1> ( -- action )
+ <action>
+ [ "recover-1" login-template <html-content> ] >>display
-:: <recover-action-1> ( -- action )
- [let | form [ <recover-form-1> ] |
- <action>
- [ blank-values ] >>init
+ [
+ {
+ { "username" [ v-username ] }
+ { "email" [ v-email ] }
+ { "captcha" [ v-captcha ] }
+ } validate-params
+ ] >>validate
- [ form edit-form ] >>display
+ [
+ "email" value "username" value
+ users issue-ticket [
+ send-password-email
+ ] when*
- [
- blank-values
+ "recover-2" login-template <html-content>
+ ] >>submit ;
- form validate-form
-
- "email" value "username" value
- users issue-ticket [
- send-password-email
- ] when*
-
- "recover-2" login-template serve-template
- ] >>submit
- ] ;
-
-: <recover-form-3>
- "new-password" <form>
- "recover-3" login-template >>edit-template
- "username" <username>
- hidden >>renderer
- t >>required
- add-field
- "new-password" <password>
- t >>required
- add-field
- "verify-password" <password>
- t >>required
- add-field
- "ticket" <string>
- hidden >>renderer
- t >>required
- add-field ;
-
-:: <recover-action-3> ( -- action )
- [let | form [ <recover-form-3> ] |
- <action>
- [
- { "username" [ v-required ] }
+: <recover-action-3> ( -- action )
+ <action>
+ [
+ {
+ { "username" [ v-username ] }
{ "ticket" [ v-required ] }
- ] >>get-params
+ } validate-params
+ ] >>init
- [
- [
- "username" [ get ] keep set
- "ticket" [ get ] keep set
- ] H{ } make-assoc values set
- ] >>init
+ [ "recover-3" login-template <html-content> ] >>display
- [ <recover-form-3> edit-form ] >>display
+ [
+ {
+ { "username" [ v-username ] }
+ { "ticket" [ v-required ] }
+ { "new-password" [ v-password ] }
+ { "verify-password" [ v-password ] }
+ } validate-params
- [
- blank-values
+ same-password-twice
+ ] >>validate
- form validate-form
+ [
+ "ticket" value
+ "username" value
+ users claim-ticket [
+ "new-password" value >>encoded-password
+ users update-user
- same-password-twice
-
- "ticket" value
- "username" value
- users claim-ticket [
- "new-password" value >>encoded-password
- users update-user
-
- "recover-4" login-template serve-template
- ] [
- <400>
- ] if*
- ] >>submit
- ] ;
+ "recover-4" login-template <html-content>
+ ] [
+ <400>
+ ] if*
+ ] >>submit ;
! ! ! Logout
: <logout-action> ( -- action )
diff --git a/extra/http/server/auth/login/login.xml b/extra/http/server/auth/login/login.xml
index d0a73a4d8b..545d7e0990 100644
--- a/extra/http/server/auth/login/login.xml
+++ b/extra/http/server/auth/login/login.xml
@@ -10,12 +10,12 @@
<tr>
<th class="field-label">User name:</th>
- <td><t:edit t:component="username" /></td>
+ <td><t:field t:name="username" /></td>
</tr>
<tr>
<th class="field-label">Password:</th>
- <td><t:edit t:component="password" /></td>
+ <td><t:password t:name="password" /></td>
</tr>
</table>
@@ -23,7 +23,7 @@
<p>
<input type="submit" value="Log in" />
- <t:validation-message />
+ <t:validation-messages />
</p>
diff --git a/extra/http/server/auth/login/recover-1.xml b/extra/http/server/auth/login/recover-1.xml
index 7c72181c10..21fbe6fd39 100644
--- a/extra/http/server/auth/login/recover-1.xml
+++ b/extra/http/server/auth/login/recover-1.xml
@@ -10,25 +10,25 @@
<table>
- <tr>
- <th class="field-label">User name:</th>
- <td><t:edit t:component="username" /></td>
- </tr>
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:field t:name="username" /></td>
+ </tr>
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:edit t:component="email" /></td>
- </tr>
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
- <tr>
- <th class="field-label">Captcha:</th>
- <td><t:edit t:component="captcha" /></td>
- </tr>
+ <tr>
+ <th class="field-label">Captcha:</th>
+ <td><t:field t:name="captcha" /></td>
+ </tr>
- <tr>
- <td></td>
- <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
- </tr>
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
+ </tr>
</table>
diff --git a/extra/http/server/auth/login/recover-3.xml b/extra/http/server/auth/login/recover-3.xml
index 6c60b257a8..2e412d1f18 100644
--- a/extra/http/server/auth/login/recover-3.xml
+++ b/extra/http/server/auth/login/recover-3.xml
@@ -10,29 +10,29 @@
<table>
- <t:edit t:component="username" />
- <t:edit t:component="ticket" />
+ <t:hidden t:name="username" />
+ <t:hidden t:name="ticket" />
<tr>
- <th class="field-label">Password:</th>
- <td><t:edit t:component="new-password" /></td>
+ <th class="field-label">Password:</th>
+ <td><t:password t:name="new-password" /></td>
</tr>
<tr>
- <th class="field-label">Verify password:</th>
- <td><t:edit t:component="verify-password" /></td>
+ <th class="field-label">Verify password:</th>
+ <td><t:password t:name="verify-password" /></td>
</tr>
<tr>
- <td></td>
- <td>Enter your password twice to ensure it is correct.</td>
+ <td></td>
+ <td>Enter your password twice to ensure it is correct.</td>
</tr>
</table>
<p>
<input type="submit" value="Set password" />
- <t:validation-message />
+ <t:validation-messages />
</p>
</t:form>
diff --git a/extra/http/server/auth/login/register.xml b/extra/http/server/auth/login/register.xml
index 9b45a7f087..4804410dde 100644
--- a/extra/http/server/auth/login/register.xml
+++ b/extra/http/server/auth/login/register.xml
@@ -8,55 +8,55 @@
<table>
- <tr>
- <th class="field-label">User name:</th>
- <td><t:edit t:component="username" /></td>
- </tr>
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:field t:name="username" /></td>
+ </tr>
- <tr>
- <th class="field-label">Real name:</th>
- <td><t:edit t:component="realname" /></td>
- </tr>
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:field t:name="realname" /></td>
+ </tr>
- <tr>
- <td></td>
- <td>Specifying a real name is optional.</td>
- </tr>
+ <tr>
+ <td></td>
+ <td>Specifying a real name is optional.</td>
+ </tr>
- <tr>
- <th class="field-label">Password:</th>
- <td><t:edit t:component="new-password" /></td>
- </tr>
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:password t:name="new-password" /></td>
+ </tr>
- <tr>
- <th class="field-label">Verify:</th>
- <td><t:edit t:component="verify-password" /></td>
- </tr>
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:password t:name="verify-password" /></td>
+ </tr>
- <tr>
- <td></td>
- <td>Enter your password twice to ensure it is correct.</td>
- </tr>
+ <tr>
+ <td></td>
+ <td>Enter your password twice to ensure it is correct.</td>
+ </tr>
- <tr>
- <th class="field-label">E-mail:</th>
- <td><t:edit t:component="email" /></td>
- </tr>
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:field t:name="email" /></td>
+ </tr>
- <tr>
- <td></td>
- <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
- </tr>
+ <tr>
+ <td></td>
+ <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+ </tr>
- <tr>
- <th class="field-label">Captcha:</th>
- <td><t:edit t:component="captcha" /></td>
- </tr>
+ <tr>
+ <th class="field-label">Captcha:</th>
+ <td><t:field t:name="captcha" /></td>
+ </tr>
- <tr>
- <td></td>
- <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
- </tr>
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
+ </tr>
</table>
diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/http/server/auth/providers/assoc/assoc.factor
index 54f96480bc..d6ba587aa0 100755
--- a/extra/http/server/auth/providers/assoc/assoc.factor
+++ b/extra/http/server/auth/providers/assoc/assoc.factor
@@ -15,5 +15,5 @@ M: users-in-memory get-user ( username provider -- user/f )
M: users-in-memory update-user ( user provider -- ) 2drop ;
M: users-in-memory new-user ( user provider -- user/f )
- >r dup username>> r> assoc>>
- 2dup key? [ 3drop f ] [ pick >r set-at r> ] if ;
+ [ dup username>> ] dip assoc>>
+ 2dup key? [ 3drop f ] [ pick [ set-at ] dip ] if ;
diff --git a/extra/http/server/boilerplate/boilerplate.factor b/extra/http/server/boilerplate/boilerplate.factor
index e0a4037e31..96c59edd10 100644
--- a/extra/http/server/boilerplate/boilerplate.factor
+++ b/extra/http/server/boilerplate/boilerplate.factor
@@ -1,73 +1,13 @@
! 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 arrays locals
-html.elements
-http
-http.server
-http.server.sessions
-http.server.templating ;
+USING: accessors kernel namespaces http.server html.templates
+locals ;
IN: http.server.boilerplate
TUPLE: boilerplate < filter-responder template ;
: <boilerplate> 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: atom-feed
-
-: set-atom-feed ( title url -- )
- 2array atom-feed get >box ;
-
-: write-atom-feed ( -- )
- atom-feed get value>> [
- <link "alternate" =rel "application/atom+xml" =type
- [ first =title ] [ second =href ] bi
- link/>
- ] when* ;
-
-SYMBOL: nested-template?
-
-SYMBOL: next-template
-
-: call-next-template ( -- )
- next-template get write-html ;
-
-M: f call-template* drop call-next-template ;
-
-: with-boilerplate ( body template -- )
- [
- title get [ <box> title set ] unless
- atom-feed get [ <box> atom-feed 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* ( path responder -- )
path responder call-next-method
dup content-type>> "text/html" = [
diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor
index 5325ee3b55..40ba540ac6 100755
--- a/extra/http/server/callbacks/callbacks.factor
+++ b/extra/http/server/callbacks/callbacks.factor
@@ -90,7 +90,7 @@ SYMBOL: current-show
[ restore-request store-current-show ] when* ;
: show-final ( quot -- * )
- >r redirect-to-here store-current-show r>
+ [ redirect-to-here store-current-show ] dip
call exit-with ; inline
: resuming-callback ( responder request -- id )
@@ -111,7 +111,7 @@ M: callback-responder call-responder* ( path responder -- response )
] with-exit-continuation ;
: show-page ( quot -- )
- >r redirect-to-here store-current-show r>
+ [ redirect-to-here store-current-show ] dip
[
[ ] t register-callback swap call exit-with
] callcc1 restore-request ; inline
diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor
index 28c1b02005..5fb7c15019 100755
--- a/extra/http/server/crud/crud.factor
+++ b/extra/http/server/crud/crud.factor
@@ -1,12 +1,11 @@
! 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
+accessors fry locals hashtables validators
http.server
http.server.actions
http.server.components
-http.server.forms
-http.server.validators ;
+http.server.forms ;
IN: http.server.crud
:: <view-action> ( form ctor -- action )
@@ -18,7 +17,7 @@ IN: http.server.crud
[ form view-form ] >>display ;
: <id-redirect> ( id next -- response )
- swap number>string "id" associate <standard-redirect> ;
+ swap "id" associate <standard-redirect> ;
:: <edit-action> ( form ctor next -- action )
<action>
diff --git a/extra/http/server/db/db.factor b/extra/http/server/db/db.factor
index d0bd449457..73d4c35e2c 100755
--- a/extra/http/server/db/db.factor
+++ b/extra/http/server/db/db.factor
@@ -6,7 +6,7 @@ IN: http.server.db
TUPLE: db-persistence < filter-responder pool ;
-: <db-persistence> ( responder db params -- responder' )
+: <db-persistence> ( responder params db -- responder' )
<db-pool> db-persistence boa ;
M: db-persistence call-responder*
diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor
index af27eda527..0aed425ade 100755
--- a/extra/http/server/server-tests.factor
+++ b/extra/http/server/server-tests.factor
@@ -31,7 +31,7 @@ C: <mock-responder> mock-responder
M: mock-responder call-responder*
nip
path>> on
- "text/plain" <content> ;
+ [ ] <text-content> ;
: check-dispatch ( tag path -- ? )
H{ } clone base-paths set
@@ -84,7 +84,7 @@ C: <path-check-responder> path-check-responder
M: path-check-responder call-responder*
drop
- "text/plain" <content> swap >array >>body ;
+ >array <text-content> ;
[ { "c" } ] [
H{ } clone base-paths set
@@ -125,7 +125,7 @@ C: <base-path-check-responder> base-path-check-responder
M: base-path-check-responder call-responder*
2drop
"$funny-dispatcher" resolve-base-path
- "text/plain" <content> swap >>body ;
+ <text-content> ;
[ ] [
<dispatcher>
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index c1684c4ed2..d68c66b829 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -2,9 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces io io.timeouts strings splitting
threads sequences prettyprint io.server logging calendar http
-html.streams html.elements accessors math.parser combinators.lib
-tools.vocabs debugger continuations random combinators
-destructors io.encodings.8-bit fry classes words math ;
+html.streams html.elements accessors math.parser
+combinators.lib tools.vocabs debugger continuations random
+combinators destructors io.encodings.8-bit fry classes words
+math rss json.writer ;
IN: http.server
! path is a sequence of path component strings
@@ -18,14 +19,27 @@ GENERIC: call-responder* ( path responder -- response )
{ "POST" [ post-data>> ] }
} case ;
-: <content> ( content-type -- response )
+: <content> ( body content-type -- response )
<response>
200 >>code
"Document follows" >>message
- swap >>content-type ;
+ swap >>content-type
+ swap >>body ;
-: <html-content> ( quot -- response )
- "text/html" <content> swap >>body ;
+: <text-content> ( body -- response )
+ "text/plain" <content> ;
+
+: <html-content> ( body -- response )
+ "text/html" <content> ;
+
+: <xml-content> ( body -- response )
+ "text/xml" <content> ;
+
+: <feed-content> ( feed -- response )
+ '[ , feed>xml ] "text/xml" <content> ;
+
+: <json-content> ( obj -- response )
+ '[ , >json ] "application/json" <content> ;
TUPLE: trivial-responder response ;
@@ -86,9 +100,7 @@ SYMBOL: link-hook
: resolve-base-path ( string -- string' )
"$" ?head [
[
- "/" split1 >r
- base-path [ "/" % % ] each "/" %
- r> %
+ "/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
] "" make
] when ;
@@ -115,7 +127,7 @@ SYMBOL: form-hook
request-url ;
: replace-last-component ( path with -- path' )
- >r "/" last-split1 drop "/" r> 3append ;
+ [ "/" last-split1 drop "/" ] dip 3append ;
: relative-redirect ( to query -- url )
request get clone
@@ -128,7 +140,7 @@ SYMBOL: form-hook
{
{ [ over "http://" head? ] [ link>string ] }
{ [ over "/" head? ] [ absolute-redirect ] }
- { [ over "$" head? ] [ >r resolve-base-path r> derive-url ] }
+ { [ over "$" head? ] [ [ resolve-base-path ] dip derive-url ] }
[ relative-redirect ]
} cond ;
@@ -163,7 +175,7 @@ TUPLE: dispatcher default responders ;
[ nip ] [ drop default>> ] if
] [
over first over responders>> at*
- [ >r drop rest-slice r> ] [ drop default>> ] if
+ [ [ drop rest-slice ] dip ] [ drop default>> ] if
] if ;
M: dispatcher call-responder* ( path dispatcher -- response )
diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor
index 0d98bf2150..8ea312dcb5 100755
--- a/extra/http/server/sessions/sessions-tests.factor
+++ b/extra/http/server/sessions/sessions-tests.factor
@@ -6,7 +6,7 @@ sequences db db.sqlite continuations ;
: with-session
[
- >r [ save-session-after ] [ session set ] bi r> call
+ [ [ save-session-after ] [ session set ] bi ] dip call
] with-destructors ; inline
TUPLE: foo ;
@@ -18,7 +18,7 @@ M: foo init-session* drop 0 "x" sset ;
M: foo call-responder*
2drop
"x" [ 1+ ] schange
- "text/html" <content> [ "x" sget pprint ] >>body ;
+ [ "x" sget pprint ] <html-content> ;
: url-responder-mock-test
[
@@ -44,9 +44,7 @@ M: foo call-responder*
: <exiting-action>
<action>
- [
- "text/plain" <content> exit-with
- ] >>display ;
+ [ [ ] <text-content> exit-with ] >>display ;
[ "auth-test.db" temp-file sqlite-db delete-file ] ignore-errors
diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor
index 2f7a6eb221..8c0e255e21 100755
--- a/extra/http/server/static/static.factor
+++ b/extra/http/server/static/static.factor
@@ -3,7 +3,8 @@
USING: calendar html io io.files kernel math math.order
math.parser http http.server namespaces parser sequences strings
assocs hashtables debugger http.mime sorting html.elements
-logging calendar.format accessors io.encodings.binary fry ;
+html.templates.fhtml logging calendar.format accessors
+io.encodings.binary fry ;
IN: http.server.static
! special maps mime types to quots with effect ( path -- )
@@ -60,15 +61,17 @@ TUPLE: file-responder root hook special allow-listings ;
dup <a =href a> write </a> ;
: directory. ( path -- )
- dup file-name [
- [ <h1> file-name write </h1> ]
- [
- <ul>
- directory sort-keys
- [ <li> file. </li> ] assoc-each
- </ul>
- ] bi
- ] simple-html-document ;
+ [
+ dup file-name [
+ [ <h1> file-name write </h1> ]
+ [
+ <ul>
+ directory sort-keys
+ [ <li> file. </li> ] assoc-each
+ </ul>
+ ] bi
+ ] simple-page
+ ] with-html-stream ;
: list-directory ( directory -- response )
file-responder get allow-listings>> [
@@ -99,3 +102,9 @@ M: file-responder call-responder* ( path responder -- response )
file-responder set
".." over member?
[ drop <400> ] [ "/" join serve-object ] if ;
+
+! file responder integration
+: enable-fhtml ( responder -- responder )
+ [ <fhtml> <html-content> ]
+ "application/x-factor-server-page"
+ pick special>> set-at ;
diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor
index 3cc1eb567b..04194adb29 100644
--- a/extra/webapps/counter/counter.factor
+++ b/extra/webapps/counter/counter.factor
@@ -1,26 +1,25 @@
-USING: math kernel accessors http.server http.server.actions
-http.server.sessions http.server.templating
-http.server.templating.fhtml locals ;
+USING: math kernel accessors html.components
+http.server http.server.actions
+http.server.sessions html.templates.chloe fry ;
IN: webapps.counter
SYMBOL: count
TUPLE: counter-app < dispatcher ;
-M: counter-app init-session*
- drop 0 count sset ;
+M: counter-app init-session* drop 0 count sset ;
-:: <counter-action> ( quot -- action )
- <action> [
- count quot schange
- "" f <standard-redirect>
- ] >>display ;
+: <counter-action> ( quot -- action )
+ <action>
+ swap '[ count , schange "" f <standard-redirect> ] >>submit ;
: counter-template ( -- template )
- "resource:extra/webapps/counter/counter.fhtml" <fhtml> ;
+ "resource:extra/webapps/counter/counter.xml" <chloe> ;
: <display-action> ( -- action )
- <action> [ counter-template serve-template ] >>display ;
+ <page-action>
+ [ count sget "counter" set-value ] >>init
+ counter-template >>template ;
: <counter-app> ( -- responder )
counter-app new-dispatcher
diff --git a/extra/webapps/counter/counter.xml b/extra/webapps/counter/counter.xml
new file mode 100644
index 0000000000..75e7cf3c4b
--- /dev/null
+++ b/extra/webapps/counter/counter.xml
@@ -0,0 +1,13 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+
+ <body>
+ <h1><t:label t:name="counter" /></h1>
+
+ <t:button t:action="$counter-app/inc">++</t:button>
+ <t:button t:action="$counter-app/dec">--</t:button>
+ </body>
+
+</t:chloe>
diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor
index 9b3ce57d02..1fb5d4c1a6 100644
--- a/extra/webapps/factor-website/factor-website.factor
+++ b/extra/webapps/factor-website/factor-website.factor
@@ -1,16 +1,17 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences assocs io.files io.sockets
+io.server
namespaces db db.sqlite smtp
http.server
http.server.db
http.server.flows
http.server.sessions
-http.server.auth.admin
http.server.auth.login
http.server.auth.providers.db
http.server.boilerplate
-http.server.templating.chloe
+html.templates.chloe
+webapps.user-admin
webapps.pastebin
webapps.planet
webapps.todo ;
@@ -30,12 +31,13 @@ IN: webapps.factor-website
init-annotations-table
init-blog-table
+ init-postings-table
init-todo-table
] with-db ;
: <factor-website> ( -- responder )
- <dispatcher>
+ <dispatcher>
<todo-list> "todo" add-responder
<pastebin> "pastebin" add-responder
<planet-factor> "planet" add-responder
@@ -59,7 +61,7 @@ IN: webapps.factor-website
<factor-website> main-responder set-global ;
-: start-factor-website
+: start-factor-website ( -- )
test-db start-expiring-sessions
- "planet" main-responder get responders>> at test-db start-update-task
+ test-db start-update-task
8812 httpd ;
diff --git a/extra/webapps/factor-website/page.css b/extra/webapps/factor-website/page.css
index 55721d7bef..606d574618 100644
--- a/extra/webapps/factor-website/page.css
+++ b/extra/webapps/factor-website/page.css
@@ -21,6 +21,8 @@ a:hover, .link:hover {
.error { color: #a00; }
+.errors li { color: #a00; }
+
.field-label {
text-align: right;
}
@@ -53,3 +55,21 @@ a:hover, .link:hover {
.description p:last-child {
margin-bottom: 0px;
}
+
+.description table, .description td {
+ border-color: #666;
+ border-style: solid;
+}
+
+.description table {
+ border-width: 0 0 1px 1px;
+ border-spacing: 0;
+ border-collapse: collapse;
+}
+
+.description td {
+ margin: 0;
+ padding: 4px;
+ border-width: 1px 1px 0 0;
+}
+
diff --git a/extra/webapps/pastebin/new-paste.xml b/extra/webapps/pastebin/new-paste.xml
index 86daf09aeb..1abd4d494b 100644
--- a/extra/webapps/pastebin/new-paste.xml
+++ b/extra/webapps/pastebin/new-paste.xml
@@ -7,11 +7,11 @@
<t:form t:action="$pastebin/new-paste">
<table>
- <tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
- <tr><th class="field-label">Author: </th><td><t:edit t:component="author" /></td></tr>
- <tr><th class="field-label">Mode: </th><td><t:edit t:component="mode" /></td></tr>
- <tr><th class="field-label big-field-label">Description: </th><td><t:edit t:component="contents" /></td></tr>
- <tr><th class="field-label">Captcha: </th><td><t:edit t:component="captcha" /></td></tr>
+ <tr><th class="field-label">Summary: </th><td><t:field t:name="summary" /></td></tr>
+ <tr><th class="field-label">Author: </th><td><t:field t:name="author" /></td></tr>
+ <tr><th class="field-label">Mode: </th><td><t:choice t:name="mode" t:choices="modes" /></td></tr>
+ <tr><th class="field-label big-field-label">Description: </th><td><t:textarea t:name="contents" /></td></tr>
+ <tr><th class="field-label">Captcha: </th><td><t:captcha t:name="captcha" /></td></tr>
<tr>
<td></td>
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml
index 9141ee4ef1..1f65ff6765 100644
--- a/extra/webapps/pastebin/paste.xml
+++ b/extra/webapps/pastebin/paste.xml
@@ -2,19 +2,59 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:title>Paste: <t:view t:component="summary" /></t:title>
+ <t:atom t:title="Paste - Atom" t:href="$pastebin/paste.atom" t:query="id" />
+
+ <t:title>Paste: <t:label t:name="summary" /></t:title>
<table>
- <tr><th class="field-label">Author: </th><td><t:view t:component="author" /></td></tr>
- <tr><th class="field-label">Mode: </th><td><t:view t:component="mode" /></td></tr>
- <tr><th class="field-label">Date: </th><td><t:view t:component="date" /></td></tr>
+ <tr><th class="field-label">Author: </th><td><t:label t:name="author" /></td></tr>
+ <tr><th class="field-label">Mode: </th><td><t:label t:name="mode" /></td></tr>
+ <tr><th class="field-label">Date: </th><td><t:label t:name="date" /></td></tr>
</table>
- <pre class="description"><t:view t:component="contents" /></pre>
+ <pre class="description"><t:code t:name="contents" t:mode="modes" /></pre>
<t:button t:action="$pastebin/delete-paste" t:for="id" class="link-button link">Delete Paste</t:button>
|
<t:a t:href="$pastebin/annotate" t:query="id">Annotate</t:a>
- <t:view t:component="annotations" />
+ <t:each-tuple t:values="annotations">
+
+ <h2>Annotation: <t:label t:name="summary" /></h2>
+
+ <table>
+ <tr><th class="field-label">Author: </th><td><t:label t:name="author" /></td></tr>
+ <tr><th class="field-label">Mode: </th><td><t:label t:name="mode" /></td></tr>
+ <tr><th class="field-label">Date: </th><td><t:label t:name="date" /></td></tr>
+ </table>
+
+ <pre class="description"><t:code t:name="contents" t:mode="mode"/></pre>
+
+ <t:button t:action="$pastebin/delete-annotation" t:for="aid" class="link-button link">Delete Annotation</t:button>
+
+ </t:each-tuple>
+
+ <t:bind-assoc t:name="new-annotation">
+
+ <h2>New Annotation</h2>
+
+ <t:form t:action="$pastebin/new-annotation" t:for="id">
+
+ <table>
+ <tr><th class="field-label">Summary: </th><td><t:field t:name="summary" /></td></tr>
+ <tr><th class="field-label">Author: </th><td><t:field t:name="author" /></td></tr>
+ <tr><th class="field-label">Mode: </th><td><t:choice t:name="mode" t:choices="modes" /></td></tr>
+ <tr><th class="field-label big-field-label">Description:</th><td><t:textarea t:name="contents" /></td></tr>
+ <tr><th class="field-label">Captcha: </th><td><t:captcha t:name="captcha" /></td></tr>
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
+ </tr>
+ </table>
+
+ <input type="SUBMIT" value="Done" />
+ </t:form>
+
+ </t:bind-assoc>
+
</t:chloe>
diff --git a/extra/webapps/pastebin/pastebin-common.xml b/extra/webapps/pastebin/pastebin-common.xml
index b99cf28753..f785fceb6b 100644
--- a/extra/webapps/pastebin/pastebin-common.xml
+++ b/extra/webapps/pastebin/pastebin-common.xml
@@ -2,15 +2,12 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:atom t:title="Pastebin - Atom" t:href="$pastebin/feed.xml" />
-
<t:style t:include="resource:extra/webapps/pastebin/pastebin.css" />
<div class="navbar">
<t:a t:href="$pastebin/list">Pastes</t:a>
| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
- | <t:a t:href="$pastebin/feed.xml">Atom Feed</t:a>
<t:if t:code="http.server.sessions:uid">
diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor
index 273b250695..0772181b00 100644
--- a/extra/webapps/pastebin/pastebin.factor
+++ b/extra/webapps/pastebin/pastebin.factor
@@ -1,46 +1,40 @@
+! Copyright (C) 2007, 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs sorting sequences kernel accessors
-hashtables sequences.lib locals db.types db.tuples db
-calendar calendar.format rss xml.writer
-xmode.catalog
+hashtables sequences.lib db.types db.tuples db
+calendar calendar.format math.parser rss xml.writer
+xmode.catalog validators html.components html.templates.chloe
http.server
-http.server.crud
http.server.actions
-http.server.components
-http.server.components.code
-http.server.templating.chloe
http.server.auth
http.server.auth.login
-http.server.boilerplate
-http.server.validators
-http.server.forms ;
+http.server.boilerplate ;
IN: webapps.pastebin
-: <mode> ( id -- component )
- modes keys natural-sort <choice> ;
+! ! !
+! DOMAIN MODEL
+! ! !
-: pastebin-template ( name -- template )
- "resource:extra/webapps/pastebin/" swap ".xml" 3append <chloe> ;
+TUPLE: paste id summary author mode date contents annotations ;
-TUPLE: paste id summary author mode date contents annotations captcha ;
-
-paste "PASTE"
+\ paste "PASTE"
{
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
{ "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
{ "mode" "MODE" { VARCHAR 256 } +not-null+ }
- { "date" "DATE" DATETIME +not-null+ }
+ { "date" "DATE" DATETIME +not-null+ , }
{ "contents" "CONTENTS" TEXT +not-null+ }
} define-persistent
: <paste> ( id -- paste )
- paste new
+ \ paste new
swap >>id ;
: pastes ( -- pastes )
f <paste> select-tuples ;
-TUPLE: annotation aid id summary author mode contents date captcha ;
+TUPLE: annotation aid id summary author mode contents date ;
annotation "ANNOTATION"
{
@@ -63,175 +57,165 @@ annotation "ANNOTATION"
dup id>> f <annotation> select-tuples >>annotations
] unless ;
-: <annotation-form> ( -- form )
- "annotation" <form>
- "annotation" pastebin-template >>view-template
- "id" <integer>
- hidden >>renderer
- add-field
- "aid" <integer>
- hidden >>renderer
- add-field
- "summary" <string> add-field
- "author" <string> add-field
- "mode" <mode> add-field
- "contents" "mode" <code> add-field
- "date" <date> add-field ;
+: paste ( id -- paste )
+ <paste> select-tuple fetch-annotations ;
-: <new-annotation-form> ( -- form )
- "annotation" <form>
- "new-annotation" pastebin-template >>edit-template
- "id" <integer>
- hidden >>renderer
- t >>required add-field
- "summary" <string>
- t >>required add-field
- "author" <string>
- t >>required
- add-field
- "mode" <mode>
- "factor" >>default
- t >>required
- add-field
- "contents" "mode" <code>
- t >>required add-field
- "captcha" <captcha> add-field ;
+: <id-redirect> ( id next -- response )
+ swap "id" associate <standard-redirect> ;
-: <paste-form> ( -- form )
- "paste" <form>
- "paste" pastebin-template >>view-template
- "paste-summary" pastebin-template >>summary-template
- "id" <integer>
- hidden >>renderer add-field
- "summary" <string> add-field
- "author" <string> add-field
- "mode" <mode> add-field
- "date" <date> add-field
- "contents" "mode" <code> add-field
- "annotations" <annotation-form> +plain+ <list> add-field ;
+! ! !
+! LINKS, ETC
+! ! !
-: <new-paste-form> ( -- form )
- "paste" <form>
- "new-paste" pastebin-template >>edit-template
- "summary" <string>
- t >>required add-field
- "author" <string>
- t >>required add-field
- "mode" <mode>
- "factor" >>default
- t >>required
- add-field
- "contents" "mode" <code>
- t >>required add-field
- "captcha" <captcha> add-field ;
+: pastebin-link ( -- url )
+ "$pastebin/list" f link>string ;
-: <paste-list-form> ( -- form )
- "pastebin" <form>
- "paste-list" pastebin-template >>view-template
- "pastes" <paste-form> +plain+ <list> add-field ;
+GENERIC: entity-link ( entity -- url )
-:: <paste-list-action> ( -- action )
- [let | form [ <paste-list-form> ] |
- <action>
- [
- blank-values
+M: paste entity-link
+ id>> "id" associate "$pastebin/paste" swap link>string ;
- pastes "pastes" set-value
+M: annotation entity-link
+ [ id>> "id" associate "$pastebin/paste" swap link>string ]
+ [ aid>> number>string "#" prepend ] bi
+ append ;
- form view-form
- ] >>display
- ] ;
+: pastebin-template ( name -- template )
+ "resource:extra/webapps/pastebin/" swap ".xml" 3append <chloe> ;
-:: <annotate-action> ( form ctor next -- action )
- <action>
- { { "id" [ v-number ] } } >>get-params
+! ! !
+! PASTE LIST
+! ! !
- [
- "id" get f ctor call
+: <pastebin-action> ( -- action )
+ <page-action>
+ [ pastes "pastes" set-value ] >>init
+ "pastebin" pastebin-template >>template ;
- from-tuple form set-defaults
- ] >>init
-
- [ form edit-form ] >>display
-
- [
- f f ctor call from-tuple
-
- form validate-form
-
- values-tuple insert-tuple
-
- "id" value next <id-redirect>
- ] >>submit ;
-
-: pastebin-feed-entries ( -- entries )
- pastes <reversed> 20 short head [
- [ summary>> ]
- [ "$pastebin/view-paste" swap id>> "id" associate link>string ]
- [ date>> ] tri
- f swap <entry>
+: pastebin-feed-entries ( seq -- entries )
+ <reversed> 20 short head [
+ entry new
+ swap
+ [ summary>> >>title ]
+ [ date>> >>pub-date ]
+ [ entity-link >>link ]
+ tri
] map ;
: pastebin-feed ( -- feed )
feed new
"Factor Pastebin" >>title
- "http://paste.factorcode.org" >>link
- pastebin-feed-entries >>entries ;
+ pastebin-link >>link
+ pastes pastebin-feed-entries >>entries ;
-: <feed-action> ( -- action )
- <action>
+: <pastebin-feed-action> ( -- action )
+ <feed-action> [ pastebin-feed ] >>feed ;
+
+! ! !
+! PASTES
+! ! !
+
+: <paste-action> ( -- action )
+ <page-action>
[
- "text/xml" <content>
- [ pastebin-feed feed>xml write-xml ] >>body
- ] >>display ;
+ validate-integer-id
+ "id" value paste from-tuple
-:: <view-paste-action> ( form ctor -- action )
- <action>
- { { "id" [ v-number ] } } >>get-params
-
- [ "id" get ctor call select-tuple fetch-annotations from-tuple ] >>init
-
- [ form view-form ] >>display ;
-
-:: <delete-paste-action> ( ctor next -- action )
- <action>
- { { "id" [ v-number ] } } >>post-params
-
- [
- "id" get ctor call delete-tuples
-
- "id" get f <annotation> delete-tuples
-
- next f <permanent-redirect>
- ] >>submit ;
-
-:: <delete-annotation-action> ( ctor next -- action )
- <action>
- { { "aid" [ v-number ] } } >>post-params
-
- [
- f "aid" get ctor call select-tuple
- [ delete-tuples ] [ id>> next <id-redirect> ] bi
- ] >>submit ;
-
-:: <new-paste-action> ( form ctor next -- action )
- <action>
- [
- f ctor call from-tuple
-
- form set-defaults
+ "new-annotation" [
+ mode-names "modes" set-value
+ "factor" "mode" set-value
+ ] nest-values
] >>init
- [ form edit-form ] >>display
+ "paste" pastebin-template >>template ;
+
+: paste-feed-entries ( paste -- entries )
+ fetch-annotations annotations>> pastebin-feed-entries ;
+
+: paste-feed ( paste -- feed )
+ feed new
+ swap
+ [ "Paste #" swap id>> number>string append >>title ]
+ [ entity-link >>link ]
+ [ paste-feed-entries >>entries ]
+ tri ;
+
+: <paste-feed-action> ( -- action )
+ <feed-action>
+ [ validate-integer-id ] >>init
+ [ "id" value paste annotations>> paste-feed ] >>feed ;
+
+: <new-paste-action> ( -- action )
+ <page-action>
+ [
+ "factor" "mode" set-value
+ mode-names "modes" set-value
+ ] >>init
+
+ "new-paste" pastebin-template >>template
[
- f ctor call from-tuple
+ {
+ { "summary" [ v-one-line ] }
+ { "author" [ v-one-line ] }
+ { "mode" [ v-mode ] }
+ { "contents" [ v-required ] }
+ { "captcha" [ v-captcha ] }
+ } validate-params
- form validate-form
+ f <paste>
+ now >>date
+ dup { "summary" "author" "mode" "contents" } deposit-slots
+ [ insert-tuple ]
+ [ id>> "$pastebin/paste" <id-redirect> ] bi
+ ] >>submit ;
- values-tuple insert-tuple
+: <delete-paste-action> ( -- action )
+ <action>
+ [ validate-integer-id ] >>validate
- "id" value next <id-redirect>
+ [
+ "id" value <paste> delete-tuples
+ "id" value f <annotation> delete-tuples
+ "$pastebin/list" f <permanent-redirect>
+ ] >>submit ;
+
+! ! !
+! ANNOTATIONS
+! ! !
+
+: <new-annotation-action> ( -- action )
+ <action>
+ [
+ {
+ { "summary" [ v-one-line ] }
+ { "author" [ v-one-line ] }
+ { "mode" [ v-mode ] }
+ { "contents" [ v-required ] }
+ { "captcha" [ v-captcha ] }
+ } validate-params
+ ] >>validate
+
+ [
+ f f <annotation>
+ now >>date
+ dup { "summary" "author" "mode" "contents" } deposit-slots
+ [ insert-tuple ]
+ [
+ ! Add anchor here
+ "id" value "$pastebin/paste" <id-redirect>
+ ] bi
+ ] >>submit ;
+
+: <delete-annotation-action> ( -- action )
+ <action>
+ [ { { "aid" [ v-number ] } } validate-params ] >>validate
+
+ [
+ f "aid" value <annotation> select-tuple
+ [ delete-tuples ]
+ [ id>> "$pastebin/paste" <id-redirect> ]
+ bi
] >>submit ;
TUPLE: pastebin < dispatcher ;
@@ -242,17 +226,17 @@ can-delete-pastes? define-capability
: <pastebin> ( -- responder )
pastebin new-dispatcher
- <paste-list-action> "list" add-main-responder
- <feed-action> "feed.xml" add-responder
- <paste-form> [ <paste> ] <view-paste-action> "view-paste" add-responder
- [ <paste> ] "$pastebin/list" <delete-paste-action> { can-delete-pastes? } <protected> "delete-paste" add-responder
- [ <annotation> ] "$pastebin/view-paste" <delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
- <paste-form> [ <paste> ] <view-paste-action> "$pastebin/view-paste" add-responder
- <new-paste-form> [ <paste> now >>date ] "$pastebin/view-paste" <new-paste-action> "new-paste" add-responder
- <new-annotation-form> [ <annotation> now >>date ] "$pastebin/view-paste" <annotate-action> "annotate" add-responder
+ <pastebin-action> "list" add-main-responder
+ <pastebin-feed-action> "list.atom" add-responder
+ <paste-action> "paste" add-responder
+ <paste-feed-action> "paste.atom" add-responder
+ <new-paste-action> "new-paste" add-responder
+ <delete-paste-action> { can-delete-pastes? } <protected> "delete-paste" add-responder
+ <new-annotation-action> "new-annotation" add-responder
+ <delete-annotation-action> { can-delete-pastes? } <protected> "delete-annotation" add-responder
<boilerplate>
- "pastebin" pastebin-template >>template ;
+ "pastebin-common" pastebin-template >>template ;
-: init-pastes-table paste ensure-table ;
+: init-pastes-table \ paste ensure-table ;
: init-annotations-table annotation ensure-table ;
diff --git a/extra/webapps/pastebin/pastebin.xml b/extra/webapps/pastebin/pastebin.xml
index 46604598ce..f0abd97c63 100644
--- a/extra/webapps/pastebin/pastebin.xml
+++ b/extra/webapps/pastebin/pastebin.xml
@@ -2,6 +2,8 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:atom t:title="Pastebin - Atom" t:href="$pastebin/list.atom" />
+
<t:title>Pastebin</t:title>
<table width="100%">
diff --git a/extra/webapps/planet/admin.xml b/extra/webapps/planet/admin.xml
index c79fe2efd1..4711ca4716 100644
--- a/extra/webapps/planet/admin.xml
+++ b/extra/webapps/planet/admin.xml
@@ -4,11 +4,19 @@
<t:title>Planet Factor Administration</t:title>
- <t:summary t:component="blogroll" />
+ <ul>
+ <t:each-tuple t:values="blogroll">
+ <li>
+ <t:a t:href="$planet-factor/admin/edit-blog" t:query="id">
+ <t:label t:name="name" />
+ </t:a>
+ </li>
+ </t:each-tuple>
+ </ul>
<p>
- <t:a t:href="$planet-factor/admin/edit-blog">Add Blog</t:a>
- | <t:a t:href="$planet-factor/admin/update">Update</t:a>
+ <t:a t:href="$planet-factor/admin/new-blog">Add Blog</t:a>
+ | <t:button t:action="$planet-factor/admin/update" class="link-button link">Update</t:button>
</p>
</t:chloe>
diff --git a/extra/webapps/planet/edit-blog.xml b/extra/webapps/planet/edit-blog.xml
index ebfccc47de..fd9c659f59 100644
--- a/extra/webapps/planet/edit-blog.xml
+++ b/extra/webapps/planet/edit-blog.xml
@@ -10,17 +10,17 @@
<tr>
<th class="field-label">Blog name:</th>
- <td><t:edit t:component="name" /></td>
+ <td><t:field t:name="name" /></td>
</tr>
<tr>
<th class="field-label">Home page:</th>
- <td><t:edit t:component="www-url" /></td>
+ <td><t:field t:name="www-url" /></td>
</tr>
<tr>
<th class="field-label">Feed:</th>
- <td><t:edit t:component="feed-url" /></td>
+ <td><t:field t:name="feed-url" /></td>
</tr>
</table>
@@ -30,4 +30,5 @@
</t:form>
<t:button t:action="$planet-factor/admin/delete-blog" t:for="id" class="link-button link">Delete</t:button>
+
</t:chloe>
diff --git a/extra/webapps/planet/mini-planet.xml b/extra/webapps/planet/mini-planet.xml
new file mode 100644
index 0000000000..1338463bcf
--- /dev/null
+++ b/extra/webapps/planet/mini-planet.xml
@@ -0,0 +1,14 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:each-tuple t:values="postings">
+
+ <p class="news">
+ <strong><t:view t:component="title" /></strong> <br/>
+ <t:a value="link" t:session="none" class="more">Read More...</t:a>
+ </p>
+
+ </t:each-tuple>
+
+</t:chloe>
diff --git a/extra/webapps/planet/new-blog.xml b/extra/webapps/planet/new-blog.xml
new file mode 100644
index 0000000000..4a9638da03
--- /dev/null
+++ b/extra/webapps/planet/new-blog.xml
@@ -0,0 +1,32 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit Blog</t:title>
+
+ <t:form t:action="$planet-factor/admin/new-blog">
+
+ <table>
+
+ <tr>
+ <th class="field-label">Blog name:</th>
+ <td><t:field t:name="name" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Home page:</th>
+ <td><t:field t:name="www-url" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Feed:</th>
+ <td><t:field t:name="feed-url" /></td>
+ </tr>
+
+ </table>
+
+ <input type="SUBMIT" value="Done" />
+
+ </t:form>
+
+</t:chloe>
diff --git a/extra/webapps/planet/planet-common.xml b/extra/webapps/planet/planet-common.xml
new file mode 100644
index 0000000000..29609e12ba
--- /dev/null
+++ b/extra/webapps/planet/planet-common.xml
@@ -0,0 +1,25 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:style t:include="resource:extra/webapps/planet/planet.css" />
+
+ <div class="navbar">
+ <t:a t:href="$planet-factor/list">Front Page</t:a>
+ | <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
+ | <t:a t:href="$planet-factor/admin">Admin</t:a>
+
+ <t:if t:code="http.server.sessions:uid">
+ <t:if t:code="http.server.auth.login:allow-edit-profile?">
+ | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ </t:if>
+
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ </t:if>
+ </div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
index c8aeab35a8..e3b5b17a32 100755
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -1,22 +1,18 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences sorting locals math math.order
+USING: kernel accessors sequences sorting math math.order
calendar alarms logging concurrency.combinators namespaces
-sequences.lib db.types db.tuples db fry
+sequences.lib db.types db.tuples db fry locals hashtables
+html.components html.templates.chloe
rss xml.writer
+validators
http.server
-http.server.crud
-http.server.forms
http.server.actions
http.server.boilerplate
-http.server.templating.chloe
-http.server.components
http.server.auth.login
http.server.auth ;
IN: webapps.planet
-TUPLE: planet-factor < dispatcher postings ;
-
: planet-template ( name -- template )
"resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
@@ -34,92 +30,63 @@ blog "BLOGS"
{ "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ }
} define-persistent
+! TUPLE: posting < entry id ;
+TUPLE: posting id title link description pub-date ;
+
+posting "POSTINGS"
+{
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "title" "TITLE" { VARCHAR 256 } +not-null+ }
+ { "link" "LINK" { VARCHAR 256 } +not-null+ }
+ { "description" "DESCRIPTION" TEXT +not-null+ }
+ { "pub-date" "DATE" TIMESTAMP +not-null+ }
+} define-persistent
+
: init-blog-table blog ensure-table ;
+: init-postings-table posting ensure-table ;
+
: <blog> ( id -- todo )
blog new
swap >>id ;
: blogroll ( -- seq )
- f <blog> select-tuples [ [ name>> ] compare ] sort ;
+ f <blog> select-tuples
+ [ [ name>> ] compare ] sort ;
-: <entry-form> ( -- form )
- "entry" <form>
- "entry" planet-template >>view-template
- "entry-summary" planet-template >>summary-template
- "title" <string> add-field
- "description" <html-text> add-field
- "pub-date" <date> add-field ;
+: postings ( -- seq )
+ posting new select-tuples
+ [ [ pub-date>> ] compare invert-comparison ] sort ;
-: <blog-form> ( -- form )
- "blog" <form>
- "edit-blog" planet-template >>edit-template
- "blog-admin-link" planet-template >>summary-template
- "id" <integer>
- hidden >>renderer
- add-field
- "name" <string>
- t >>required
- add-field
- "www-url" <url>
- t >>required
- add-field
- "feed-url" <url>
- t >>required
- add-field ;
+: <edit-blogroll-action> ( -- action )
+ <page-action>
+ [ blogroll "blogroll" set-value ] >>init
+ "admin" planet-template >>template ;
-: <planet-factor-form> ( -- form )
- "planet-factor" <form>
- "postings" planet-template >>view-template
- "postings-summary" planet-template >>summary-template
- "postings" <entry-form> +plain+ <list> add-field
- "blogroll" "blog" <link> +unordered+ <list> add-field ;
+: <planet-action> ( -- action )
+ <page-action>
+ [
+ blogroll "blogroll" set-value
+ postings "postings" set-value
+ ] >>init
-: <admin-form> ( -- form )
- "admin" <form>
- "admin" planet-template >>view-template
- "blogroll" <blog-form> +unordered+ <list> add-field ;
+ "planet" planet-template >>template ;
-:: <edit-blogroll-action> ( planet -- action )
- [let | form [ <admin-form> ] |
- <action>
- [
- blank-values
-
- blogroll "blogroll" set-value
-
- form view-form
- ] >>display
- ] ;
-
-:: <planet-action> ( planet -- action )
- [let | form [ <planet-factor-form> ] |
- <action>
- [
- blank-values
-
- planet postings>> "postings" set-value
- blogroll "blogroll" set-value
-
- form view-form
- ] >>display
- ] ;
-
-:: planet-feed ( planet -- feed )
+: planet-feed ( -- feed )
feed new
"Planet Factor" >>title
"http://planet.factorcode.org" >>link
- planet postings>> 16 short head >>entries ;
+ postings >>entries ;
-:: <feed-action> ( planet -- action )
- <action>
- [
- "text/xml" <content>
- [ planet planet-feed feed>xml write-xml ] >>body
- ] >>display ;
+: <planet-feed-action> ( -- action )
+ <feed-action> [ planet-feed ] >>feed ;
-: <posting> ( name entry -- entry' )
- clone [ ": " swap 3append ] change-title ;
+:: <posting> ( entry name -- entry' )
+ posting new
+ name ": " entry title>> 3append >>title
+ entry link>> >>link
+ entry description>> >>description
+ entry pub-date>> >>pub-date ;
: fetch-feed ( url -- feed )
download-feed entries>> ;
@@ -127,55 +94,101 @@ blog "BLOGS"
\ fetch-feed DEBUG add-error-logging
: fetch-blogroll ( blogroll -- entries )
- dup
- [ feed-url>> fetch-feed ] parallel-map
- [ >r name>> r> [ <posting> ] with map ] 2map concat ;
+ [ [ feed-url>> fetch-feed ] parallel-map ] [ [ name>> ] map ] bi
+ [ '[ , <posting> ] map ] 2map concat ;
: sort-entries ( entries -- entries' )
- [ [ pub-date>> ] compare ] sort <reversed> ;
+ [ [ pub-date>> ] compare invert-comparison ] sort ;
-: update-cached-postings ( planet -- )
- "webapps.planet" [
- blogroll fetch-blogroll sort-entries 8 short head
- >>postings drop
- ] with-logging ;
+: update-cached-postings ( -- )
+ blogroll fetch-blogroll sort-entries 8 short head [
+ posting new delete-tuples
+ [ insert-tuple ] each
+ ] with-transaction ;
-:: <update-action> ( planet -- action )
+: <update-action> ( -- action )
<action>
[
- planet update-cached-postings
- "" f <temporary-redirect>
- ] >>display ;
+ update-cached-postings
+ "" f <permanent-redirect>
+ ] >>submit ;
-:: <planet-factor-admin> ( planet-factor -- responder )
- [let | blog-form [ <blog-form> ]
- blog-ctor [ [ <blog> ] ] |
- <dispatcher>
- planet-factor <edit-blogroll-action> >>default
+: <delete-blog-action> ( -- action )
+ <action>
+ [ validate-integer-id ] >>validate
- planet-factor <update-action> "update" add-responder
+ [
+ "id" value <blog> delete-tuples
+ "$planet-factor/admin" f <standard-redirect>
+ ] >>submit ;
- ! Administrative CRUD
- blog-ctor "$planet-factor/admin" <delete-action> "delete-blog" add-responder
- blog-form blog-ctor "$planet-factor/admin" <edit-action> "edit-blog" add-responder
- ] ;
+: validate-blog ( -- )
+ {
+ { "name" [ v-one-line ] }
+ { "www-url" [ v-url ] }
+ { "feed-url" [ v-url ] }
+ } validate-params ;
+
+: <id-redirect> ( id next -- response )
+ swap "id" associate <standard-redirect> ;
+
+: <new-blog-action> ( -- action )
+ <page-action>
+ "new-blog" planet-template >>template
+
+ [ validate-blog ] >>validate
+
+ [
+ f <blog>
+ dup { "name" "www-url" "feed-url" } deposit-slots
+ [ insert-tuple ]
+ [ id>> "$planet-factor/admin/edit-blog" <id-redirect> ] bi
+ ] >>submit ;
+
+: <edit-blog-action> ( -- action )
+ <page-action>
+ [
+ validate-integer-id
+ "id" value <blog> select-tuple from-tuple
+ ] >>init
+
+ "edit-blog" planet-template >>template
+
+ [
+ validate-integer-id
+ validate-blog
+ ] >>validate
+
+ [
+ f <blog>
+ dup { "id" "name" "www-url" "feed-url" } deposit-slots
+ [ update-tuple ]
+ [ id>> "$planet-factor/admin" <id-redirect> ] bi
+ ] >>submit ;
+
+TUPLE: planet-factor-admin < dispatcher ;
+
+: <planet-factor-admin> ( -- responder )
+ planet-factor-admin new-dispatcher
+ <edit-blogroll-action> "blogroll" add-main-responder
+ <update-action> "update" add-responder
+ <new-blog-action> "new-blog" add-responder
+ <edit-blog-action> "edit-blog" add-responder
+ <delete-blog-action> "delete-blog" add-responder ;
SYMBOL: can-administer-planet-factor?
can-administer-planet-factor? define-capability
+TUPLE: planet-factor < dispatcher ;
+
: <planet-factor> ( -- responder )
planet-factor new-dispatcher
- dup <planet-action> "list" add-main-responder
- dup <feed-action> "feed.xml" add-responder
- dup <planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder
+ <planet-action> "list" add-main-responder
+ <feed-action> "feed.xml" add-responder
+ <planet-factor-admin> { can-administer-planet-factor? } <protected> "admin" add-responder
<boilerplate>
- "planet" planet-template >>template ;
+ "planet-common" planet-template >>template ;
-: start-update-task ( planet db seq -- )
- '[
- , , , [
- dup filter-responder? [ responder>> ] when
- update-cached-postings
- ] with-db
- ] 10 minutes every drop ;
+: start-update-task ( db params -- )
+ '[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ;
diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml
index 29609e12ba..526a9b306b 100644
--- a/extra/webapps/planet/planet.xml
+++ b/extra/webapps/planet/planet.xml
@@ -2,24 +2,44 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
- <t:style t:include="resource:extra/webapps/planet/planet.css" />
+ <t:title>Planet Factor</t:title>
- <div class="navbar">
- <t:a t:href="$planet-factor/list">Front Page</t:a>
- | <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
- | <t:a t:href="$planet-factor/admin">Admin</t:a>
+ <table width="100%" cellpadding="10">
+ <tr>
+ <td>
- <t:if t:code="http.server.sessions:uid">
- <t:if t:code="http.server.auth.login:allow-edit-profile?">
- | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
- </t:if>
-
- | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
- </t:if>
- </div>
+ <t:each-tuple t:values="postings">
- <h1><t:write-title /></h1>
+ <h2 class="posting-title">
+ <t:a t:value="link" t:session="none"><t:label t:name="title" /></t:a>
+ </h2>
- <t:call-next-template />
+ <p class="posting-body">
+ <t:html t:name="description" />
+ </p>
+
+ <p class="posting-date">
+ <t:a t:value="link" t:session="none"><t:label t:name="pub-date" /></t:a>
+ </p>
+
+ </t:each-tuple>
+
+ </td>
+
+ <td valign="top" width="25%" class="infobox">
+
+ <h2>Blogroll</h2>
+
+ <ul>
+ <t:each t:values="blogroll">
+ <li>
+ <t:link t:name="value"/>
+ </li>
+ </t:each>
+ </ul>
+
+ </td>
+ </tr>
+ </table>
</t:chloe>
diff --git a/extra/webapps/planet/postings-summary.xml b/extra/webapps/planet/postings-summary.xml
deleted file mode 100644
index 765c3a8006..0000000000
--- a/extra/webapps/planet/postings-summary.xml
+++ /dev/null
@@ -1,7 +0,0 @@
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:summary t:component="postings" />
-
-</t:chloe>
diff --git a/extra/webapps/planet/postings.xml b/extra/webapps/planet/postings.xml
deleted file mode 100644
index c2c73d7e89..0000000000
--- a/extra/webapps/planet/postings.xml
+++ /dev/null
@@ -1,19 +0,0 @@
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>Planet Factor</t:title>
-
- <table width="100%" cellpadding="10">
- <tr>
- <td> <t:view t:component="postings" /> </td>
-
- <td valign="top" width="25%" class="infobox">
- <h2>Blogroll</h2>
-
- <t:summary t:component="blogroll" />
- </td>
- </tr>
- </table>
-
-</t:chloe>
diff --git a/extra/webapps/todo/edit-todo.xml b/extra/webapps/todo/edit-todo.xml
index e1d4c40e23..0974c8ce1b 100644
--- a/extra/webapps/todo/edit-todo.xml
+++ b/extra/webapps/todo/edit-todo.xml
@@ -6,9 +6,9 @@
<t:form t:action="$todo-list/edit" t:for="id">
<table>
- <tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
- <tr><th class="field-label">Priority: </th><td><t:edit t:component="priority" /></td></tr>
- <tr><th class="field-label big-field-label">Description:</th><td><t:edit t:component="description" /></td></tr>
+ <tr><th class="field-label">Summary: </th><td><t:field t:name="summary" /></td></tr>
+ <tr><th class="field-label">Priority: </th><td><t:field t:name="priority" /></td></tr>
+ <tr><th class="field-label big-field-label">Description:</th><td><t:textarea t:name="description" t:rows="20" t:cols="60" /></td></tr>
</table>
<input type="SUBMIT" value="Done" />
diff --git a/extra/webapps/todo/todo-list.xml b/extra/webapps/todo/todo-list.xml
index 66abeafc86..845c38dbf7 100644
--- a/extra/webapps/todo/todo-list.xml
+++ b/extra/webapps/todo/todo-list.xml
@@ -5,8 +5,33 @@
<t:title>My Todo List</t:title>
<table class="todo-list">
- <tr><th>Summary</th><th>Priority</th><th>View</th><th>Edit</th></tr>
- <t:summary t:component="list" />
+
+ <tr>
+ <th>Summary</th>
+ <th>Priority</th>
+ <th>View</th>
+ <th>Edit</th>
+ </tr>
+
+ <t:each-tuple t:values="items">
+
+ <tr>
+ <td>
+ <t:label t:name="summary" />
+ </td>
+ <td>
+ <t:label t:name="priority" />
+ </td>
+ <td>
+ <t:a t:href="$todo-list/view" t:query="id">View</t:a>
+ </td>
+ <td>
+ <t:a t:href="$todo-list/edit" t:query="id">Edit</t:a>
+ </td>
+ </tr>
+
+ </t:each-tuple>
+
</table>
</t:chloe>
diff --git a/extra/webapps/todo/todo.factor b/extra/webapps/todo/todo.factor
index 8bfda1aad5..e3b174eaea 100755
--- a/extra/webapps/todo/todo.factor
+++ b/extra/webapps/todo/todo.factor
@@ -1,14 +1,11 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel locals sequences namespaces
-db db.types db.tuples
+USING: accessors kernel sequences namespaces
+db db.types db.tuples validators hashtables
+html.components
+html.templates.chloe
http.server.sessions
-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
@@ -37,44 +34,86 @@ todo "TODO"
: todo-template ( name -- template )
"resource:extra/webapps/todo/" swap ".xml" 3append <chloe> ;
-: <todo-form> ( -- form )
- "todo" <form>
- "view-todo" todo-template >>view-template
- "edit-todo" todo-template >>edit-template
- "todo-summary" todo-template >>summary-template
- "id" <integer>
- hidden >>renderer
- add-field
- "summary" <string>
- t >>required
- add-field
- "priority" <integer>
- t >>required
- 0 >>default
- 0 >>min-value
- 10 >>max-value
- add-field
- "description" <farkup>
- add-field ;
+: <view-action> ( -- action )
+ <page-action>
+ [
+ validate-integer-id
+ "id" value <todo> select-tuple from-tuple
+ ] >>init
+
+ "view-todo" todo-template >>template ;
-: <todo-list-form> ( -- form )
- "todo-list" <form>
- "todo-list" todo-template >>view-template
- "list" <todo-form> +plain+ <list>
- add-field ;
+: <id-redirect> ( id next -- response )
+ swap "id" associate <standard-redirect> ;
+
+: validate-todo ( -- )
+ {
+ { "summary" [ v-one-line ] }
+ { "priority" [ v-integer 0 v-min-value 10 v-max-value ] }
+ { "description" [ v-required ] }
+ } validate-params ;
+
+: <new-action> ( -- action )
+ <page-action>
+ [ 0 "priority" set-value ] >>init
+
+ "edit-todo" todo-template >>template
+
+ [ validate-todo ] >>validate
+
+ [
+ f <todo>
+ dup { "summary" "description" } deposit-slots
+ [ insert-tuple ]
+ [ id>> "$todo-list/view" <id-redirect> ]
+ bi
+ ] >>submit ;
+
+: <edit-action> ( -- action )
+ <page-action>
+ [
+ validate-integer-id
+ "id" value <todo> select-tuple from-tuple
+ ] >>init
+
+ "edit-todo" todo-template >>template
+
+ [
+ validate-integer-id
+ validate-todo
+ ] >>validate
+
+ [
+ f <todo>
+ dup { "id" "summary" "priority" "description" } deposit-slots
+ [ update-tuple ]
+ [ id>> "$todo-list/view" <id-redirect> ]
+ bi
+ ] >>submit ;
+
+: <delete-action> ( -- action )
+ <action>
+ [ validate-integer-id ] >>validate
+
+ [
+ "id" get <todo> delete-tuples
+ "$todo-list/list" f <standard-redirect>
+ ] >>submit ;
+
+: <list-action> ( -- action )
+ <page-action>
+ [ f <todo> select-tuples "items" set-value ] >>init
+ "todo-list" todo-template >>template ;
TUPLE: todo-list < dispatcher ;
-:: <todo-list> ( -- responder )
- [let | todo-form [ <todo-form> ]
- list-form [ <todo-list-form> ]
- ctor [ [ <todo> ] ] |
- todo-list new-dispatcher
- list-form ctor <list-action> "list" add-main-responder
- todo-form ctor <view-action> "view" add-responder
- todo-form ctor "$todo-list/view" <edit-action> "edit" add-responder
- ctor "$todo-list/list" <delete-action> "delete" add-responder
- <boilerplate>
- "todo" todo-template >>template
- f <protected>
- ] ;
+: <todo-list> ( -- responder )
+ todo-list new-dispatcher
+ <list-action> "list" add-main-responder
+ <view-action> "view" add-responder
+ <new-action> "new" add-responder
+ <edit-action> "edit" add-responder
+ <delete-action> "delete" add-responder
+ <boilerplate>
+ "todo" todo-template >>template
+ f <protected> ;
diff --git a/extra/webapps/todo/todo.xml b/extra/webapps/todo/todo.xml
index 651e29d867..39ab5cda8b 100644
--- a/extra/webapps/todo/todo.xml
+++ b/extra/webapps/todo/todo.xml
@@ -12,7 +12,7 @@
| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
</t:if>
- <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
</div>
<h1><t:write-title /></h1>
diff --git a/extra/webapps/todo/view-todo.xml b/extra/webapps/todo/view-todo.xml
index 8c90ba9056..a443528bac 100644
--- a/extra/webapps/todo/view-todo.xml
+++ b/extra/webapps/todo/view-todo.xml
@@ -5,12 +5,12 @@
<t:title>View Item</t:title>
<table>
- <tr><th class="field-label">Summary: </th><td><t:view t:component="summary" /></td></tr>
- <tr><th class="field-label">Priority: </th><td><t:view t:component="priority" /></td></tr>
+ <tr><th class="field-label">Summary: </th><td><t:label t:name="summary" /></td></tr>
+ <tr><th class="field-label">Priority: </th><td><t:label t:name="priority" /></td></tr>
</table>
<div class="description">
- <t:view t:component="description" />
+ <t:farkup t:name="description" />
</div>
<t:a t:href="$todo-list/edit" t:query="id">Edit</t:a>
diff --git a/extra/webapps/user-admin/edit-user.xml b/extra/webapps/user-admin/edit-user.xml
index 9c0fe702bb..3f9ac8d690 100644
--- a/extra/webapps/user-admin/edit-user.xml
+++ b/extra/webapps/user-admin/edit-user.xml
@@ -10,44 +10,44 @@
<tr>
<th class="field-label">User name:</th>
- <td><t:view t:component="username" /></td>
+ <td><t:label t:name="username" /></td>
</tr>
<tr>
<th class="field-label">Real name:</th>
- <td><t:edit t:component="realname" /></td>
+ <td><t:field t:name="realname" /></td>
</tr>
<tr>
<th class="field-label">New password:</th>
- <td><t:edit t:component="new-password" /></td>
+ <td><t:password t:name="new-password" /></td>
</tr>
<tr>
<th class="field-label">Verify:</th>
- <td><t:edit t:component="verify-password" /></td>
+ <td><t:password t:name="verify-password" /></td>
</tr>
<tr>
<th class="field-label">E-mail:</th>
- <td><t:edit t:component="email" /></td>
+ <td><t:field t:name="email" /></td>
</tr>
<tr>
<th class="field-label big-field-label">Capabilities:</th>
- <td><t:edit t:component="capabilities" /></td>
+ <td><t:choice t:name="capabilities" t:choices="all-capabilities" t:multiple="true" /></td>
</tr>
<tr>
<th class="field-label">Profile:</th>
- <td><t:view t:component="profile" /></td>
+ <td><t:inspector t:name="profile" /></td>
</tr>
</table>
<p>
<button type="submit" class="link-button link">Update</button>
- <t:validation-message />
+ <t:validation-messages />
</p>
</t:form>
diff --git a/extra/webapps/user-admin/new-user.xml b/extra/webapps/user-admin/new-user.xml
index 2d67639985..881dca9c16 100644
--- a/extra/webapps/user-admin/new-user.xml
+++ b/extra/webapps/user-admin/new-user.xml
@@ -10,39 +10,39 @@
<tr>
<th class="field-label">User name:</th>
- <td><t:edit t:component="username" /></td>
+ <td><t:field t:name="username" /></td>
</tr>
<tr>
<th class="field-label">Real name:</th>
- <td><t:edit t:component="realname" /></td>
+ <td><t:field t:name="realname" /></td>
</tr>
<tr>
<th class="field-label">New password:</th>
- <td><t:edit t:component="new-password" /></td>
+ <td><t:password t:name="new-password" /></td>
</tr>
<tr>
<th class="field-label">Verify:</th>
- <td><t:edit t:component="verify-password" /></td>
+ <td><t:password t:name="verify-password" /></td>
</tr>
<tr>
<th class="field-label">E-mail:</th>
- <td><t:edit t:component="email" /></td>
+ <td><t:field t:name="email" /></td>
</tr>
<tr>
<th class="field-label big-field-label">Capabilities:</th>
- <td><t:edit t:component="capabilities" /></td>
+ <td><t:choice t:name="capabilities" t:choices="all-capabilities" t:multiple="true" /></td>
</tr>
</table>
<p>
<button type="submit" class="link-button link">Create</button>
- <t:validation-message />
+ <t:validation-messages />
</p>
</t:form>
diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor
index 172ab62c50..728d5215f0 100644
--- a/extra/webapps/user-admin/user-admin.factor
+++ b/extra/webapps/user-admin/user-admin.factor
@@ -26,26 +26,22 @@ IN: webapps.user-admin
[ ":" split1 swap lookup ] map ;
: <user-list-action> ( -- action )
- <action>
+ <page-action>
[ f <user> select-tuples "users" set-value ] >>init
- [ "user-list" admin-template <html-content> ] >>display ;
+ "user-list" admin-template >>template ;
: <new-user-action> ( -- action )
- <action>
+ <page-action>
[
- "username" param <user> {
- [ username>> "username" set-value ]
- [ realname>> "realname" set-value ]
- [ email>> "email" set-value ]
- [ profile>> "profile" set-value ]
- } cleave
-
- capabilities get "all-capabilities" set-value
+ "username" param <user> from-tuple
+ capabilities get words>strings "all-capabilities" set-value
] >>init
- [ "new-user" admin-template <html-content> ] >>display
+ "new-user" admin-template >>template
[
+ capabilities get words>strings "all-capabilities" set-value
+
{
{ "username" [ v-username ] }
{ "realname" [ v-one-line ] }
@@ -72,26 +68,26 @@ IN: webapps.user-admin
"$user-admin" f <standard-redirect>
] >>submit ;
-
+
+: validate-username ( -- )
+ { { "username" [ v-username ] } } validate-params ;
+
: <edit-user-action> ( -- action )
- <action>
+ <page-action>
[
- { { "username" [ v-username ] } } validate-params
+ validate-username
- "username" value <user> select-tuple {
- [ username>> "username" set-value ]
- [ realname>> "realname" set-value ]
- [ email>> "email" set-value ]
- [ profile>> "profile" set-value ]
- [ capabilities>> words>strings "capabilities" set-value ]
- } cleave
+ "username" value <user> select-tuple
+ [ from-tuple ] [ capabilities>> words>strings "capabilities" set-value ] bi
- capabilities get "all-capabilities" set-value
+ capabilities get words>strings "all-capabilities" set-value
] >>init
- [ "edit-user" admin-template <html-content> ] >>display
+ "edit-user" admin-template >>template
[
+ capabilities get words>strings "all-capabilities" set-value
+
{
{ "username" [ v-username ] }
{ "realname" [ v-one-line ] }
@@ -102,9 +98,9 @@ IN: webapps.user-admin
} validate-params
"new-password" "verify-password"
- [ value empty? ] both? [
+ [ value empty? not ] either? [
same-password-twice
- ] unless
+ ] when
] >>validate
[
@@ -112,9 +108,9 @@ IN: webapps.user-admin
"realname" value >>realname
"email" value >>email
- "new-password" value empty? [ drop ] [
+ "new-password" value empty? [
"new-password" value >>encoded-password
- ] if
+ ] unless
"capabilities" value {
{ [ dup string? ] [ 1array ] }
@@ -129,7 +125,8 @@ IN: webapps.user-admin
: <delete-user-action> ( -- action )
<action>
[
- { { "username" [ v-username ] } } validate-params
+ validate-username
+
[ <user> select-tuple 1 >>deleted update-tuple ]
[ logout-all-sessions ]
bi
@@ -145,12 +142,12 @@ can-administer-users? define-capability
: <user-admin> ( -- responder )
user-admin new-dispatcher
- <user-list-action> "" add-responder
+ <user-list-action> "list" add-main-responder
<new-user-action> "new" add-responder
<edit-user-action> "edit" add-responder
<delete-user-action> "delete" add-responder
<boilerplate>
- "admin" admin-template >>template
+ "user-admin" admin-template >>template
{ can-administer-users? } <protected> ;
: make-admin ( username -- )
diff --git a/extra/webapps/user-admin/user-list.xml b/extra/webapps/user-admin/user-list.xml
index 6887308754..020d053e03 100644
--- a/extra/webapps/user-admin/user-list.xml
+++ b/extra/webapps/user-admin/user-list.xml
@@ -4,10 +4,16 @@
<t:title>Users</t:title>
- <t:each-tuple t:values="users">
- <t:a t:href="$user-admin/edit" t:query="username">
- <t:label t:name="username" />
- </t:a>
- </t:each-tuple>
+ <ul>
+
+ <t:each-tuple t:values="users">
+ <li>
+ <t:a t:href="$user-admin/edit" t:query="username">
+ <t:label t:name="username" />
+ </t:a>
+ </li>
+ </t:each-tuple>
+
+ </ul>
</t:chloe>
diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor
index 277439c0cd..8c6025f726 100755
--- a/extra/xmode/catalog/catalog.factor
+++ b/extra/xmode/catalog/catalog.factor
@@ -1,6 +1,6 @@
USING: xmode.loader xmode.utilities xmode.rules namespaces
strings splitting assocs sequences kernel io.files xml memoize
-words globs combinators io.encodings.utf8 ;
+words globs combinators io.encodings.utf8 sorting ;
IN: xmode.catalog
TUPLE: mode file file-name-glob first-line-glob ;
@@ -23,17 +23,15 @@ TAGS>
swap child-tags [ parse-mode-tag ] with each
] keep ;
-: load-catalog ( -- modes )
+MEMO: modes ( -- modes )
"resource:extra/xmode/modes/catalog"
file>xml parse-modes-tag ;
-: modes ( -- assoc )
- \ modes get-global [
- load-catalog dup \ modes set-global
- ] unless* ;
+MEMO: mode-names ( -- modes )
+ modes keys natural-sort ;
: reset-catalog ( -- )
- f \ modes set-global ;
+ \ modes reset-memoized ;
MEMO: (load-mode) ( name -- rule-sets )
modes at [
diff --git a/extra/xmode/code2html/responder/responder.factor b/extra/xmode/code2html/responder/responder.factor
index 7b2bdd992a..e059aeb7ff 100755
--- a/extra/xmode/code2html/responder/responder.factor
+++ b/extra/xmode/code2html/responder/responder.factor
@@ -8,14 +8,9 @@ IN: xmode.code2html.responder
: <sources> ( root -- responder )
[
drop
- "text/html" <content> swap
- [ "last-modified" set-header ]
- [
- '[
- ,
- dup file-name swap utf8
- <file-reader>
+ '[
+ , [ file-name ] keep utf8 [
[ htmlize-stream ] with-html-stream
- ] >>body
- ] bi
+ ] with-file-reader
+ ] <html-content>
] <file-responder> ;
From 8d8cb11e2a4bbbdf14458d7aea8fd451c9494b09 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 26 May 2008 00:48:02 -0500
Subject: [PATCH 25/66] More stuff
---
extra/tangle/tangle.factor | 14 ++----
extra/validators/validators-tests.factor | 61 +++++++++++++++++------
extra/validators/validators.factor | 60 +++++++++++-----------
extra/webapps/counter/counter.fhtml | 10 ----
extra/webapps/pastebin/annotation.xml | 17 -------
extra/webapps/pastebin/new-annotation.xml | 24 ---------
extra/webapps/pastebin/paste-summary.xml | 11 ----
extra/webapps/planet/blog-admin-link.xml | 7 ---
extra/webapps/todo/todo-summary.xml | 20 --------
9 files changed, 83 insertions(+), 141 deletions(-)
delete mode 100644 extra/webapps/counter/counter.fhtml
delete mode 100644 extra/webapps/pastebin/annotation.xml
delete mode 100644 extra/webapps/pastebin/new-annotation.xml
delete mode 100644 extra/webapps/pastebin/paste-summary.xml
delete mode 100644 extra/webapps/planet/blog-admin-link.xml
delete mode 100644 extra/webapps/todo/todo-summary.xml
diff --git a/extra/tangle/tangle.factor b/extra/tangle/tangle.factor
index 52c454f97f..8a4c6146de 100644
--- a/extra/tangle/tangle.factor
+++ b/extra/tangle/tangle.factor
@@ -19,11 +19,8 @@ C: <tangle> tangle
: with-tangle ( tangle quot -- )
[ [ db>> ] [ seq>> ] bi ] dip with-db ;
-: <text-response> ( text -- response )
- "text/plain" <content> swap >>body ;
-
: node-response ( id -- response )
- load-node [ node-content <text-response> ] [ <404> ] if* ;
+ load-node [ node-content <text-content> ] [ <404> ] if* ;
: display-node ( params -- response )
[
@@ -39,7 +36,7 @@ C: <tangle> tangle
: submit-node ( params -- response )
[
"node_content" swap at* [
- create-node id>> number>string <text-response>
+ create-node id>> number>string <text-content>
] [
drop <400>
] if
@@ -55,10 +52,7 @@ TUPLE: path-responder ;
C: <path-responder> path-responder
M: path-responder call-responder* ( path responder -- response )
- drop path>file [ node-content <text-response> ] [ <404> ] if* ;
-
-: <json-response> ( obj -- response )
- "application/json" <content> swap >json >>body ;
+ drop path>file [ node-content <text-content> ] [ <404> ] if* ;
TUPLE: tangle-dispatcher < dispatcher tangle ;
@@ -67,7 +61,7 @@ TUPLE: tangle-dispatcher < dispatcher tangle ;
<path-responder> >>default
"resource:extra/tangle/resources" <static> "resources" add-responder
<node-responder> "node" add-responder
- <action> [ all-node-ids <json-response> ] >>display "all" add-responder ;
+ <action> [ all-node-ids <json-content> ] >>display "all" add-responder ;
M: tangle-dispatcher call-responder* ( path dispatcher -- response )
dup tangle>> [
diff --git a/extra/validators/validators-tests.factor b/extra/validators/validators-tests.factor
index 6ed0e0363a..a981f782d3 100644
--- a/extra/validators/validators-tests.factor
+++ b/extra/validators/validators-tests.factor
@@ -1,8 +1,28 @@
IN: validators.tests
-USING: kernel sequences tools.test validators accessors ;
+USING: kernel sequences tools.test validators accessors
+namespaces assocs ;
+
+: with-validation ( quot -- messages )
+ [
+ init-validation
+ call
+ validation-messages get
+ named-validation-messages get >alist append
+ ] with-scope ; inline
+
+[ "" v-one-line ] must-fail
+[ "hello world" ] [ "hello world" v-one-line ] unit-test
+[ "hello\nworld" v-one-line ] must-fail
+
+[ "" v-one-word ] must-fail
+[ "hello" ] [ "hello" v-one-word ] unit-test
+[ "hello world" v-one-word ] must-fail
[ "foo" v-number ] must-fail
[ 123 ] [ "123" v-number ] unit-test
+[ 123 ] [ "123" v-integer ] unit-test
+
+[ "1.0" v-integer ] [ "must be an integer" = ] must-fail-with
[ "slava@factorcode.org" ] [
"slava@factorcode.org" v-email
@@ -29,13 +49,13 @@ USING: kernel sequences tools.test validators accessors ;
[ 14 V{ } ] [
[
- "14" "age" [ drop v-number 13 v-min-value 100 v-max-value ] validate
+ "14" "age" [ v-number 13 v-min-value 100 v-max-value ] validate
] with-validation
] unit-test
[ f t ] [
[
- "140" "age" [ drop v-number 13 v-min-value 100 v-max-value ] validate
+ "140" "age" [ v-number 13 v-min-value 100 v-max-value ] validate
] with-validation first
[ first "age" = ]
[ second validation-error? ]
@@ -46,25 +66,38 @@ USING: kernel sequences tools.test validators accessors ;
TUPLE: person name age ;
person {
- { "name" [ v-required ] }
+ { "name" [ ] }
{ "age" [ v-number 13 v-min-value 100 v-max-value ] }
} define-validators
-[ 14 V{ } ] [
- [
- person new dup
- { { "age" "14" } }
- deposit-slots
- age>>
- ] with-validation
-] unit-test
-
-[ t ] [
+[ t t ] [
[
{ { "age" "" } } required-values
+ validation-failed?
] with-validation first
[ first "age" = ]
[ second validation-error? ]
[ second message>> "required" = ]
tri and and
] unit-test
+
+[ H{ { "a" 123 } } f V{ } ] [
+ [
+ H{
+ { "a" "123" }
+ { "b" "c" }
+ { "c" "d" }
+ }
+ H{
+ { "a" [ v-integer ] }
+ } validate-values
+ validation-failed?
+ ] with-validation
+] unit-test
+
+[ t "foo" ] [
+ [
+ "foo" validation-error
+ validation-failed?
+ ] with-validation first message>>
+] unit-test
diff --git a/extra/validators/validators.factor b/extra/validators/validators.factor
index b03cc76444..2dcc2c04f9 100644
--- a/extra/validators/validators.factor
+++ b/extra/validators/validators.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences math namespaces sets
math.parser assocs regexp fry unicode.categories sequences
-arrays hashtables words combinators mirrors classes quotations ;
+arrays hashtables words combinators mirrors classes quotations
+xmode.catalog ;
IN: validators
: v-default ( str def -- str )
@@ -33,8 +34,8 @@ IN: validators
: v-number ( str -- n )
dup string>number [ ] [ "must be a number" throw ] ?if ;
-: v-integer ( n -- n )
- dup integer? [ "must be an integer" throw ] unless ;
+: v-integer ( str -- n )
+ v-number dup integer? [ "must be an integer" throw ] unless ;
: v-min-value ( x n -- x )
2dup < [
@@ -70,25 +71,38 @@ IN: validators
dup empty? [ "must remain blank" throw ] unless ;
: v-one-line ( str -- str )
+ v-required
dup "\r\n" intersect empty?
[ "must be a single line" throw ] unless ;
: v-one-word ( str -- str )
+ v-required
dup [ alpha? ] all?
[ "must be a single word" throw ] unless ;
-SYMBOL: validation-messages
+: v-username ( str -- str )
+ 2 v-min-length 16 v-max-length v-one-word ;
-: with-validation ( quot -- messages )
- V{ } clone [
- validation-messages rot with-variable
- ] keep ; inline
+: v-password ( str -- str )
+ 6 v-min-length 40 v-max-length v-one-line ;
+
+: v-mode ( str -- str )
+ dup mode-names member? [
+ "not a valid syntax mode" throw
+ ] unless ;
+
+SYMBOL: validation-messages
+SYMBOL: named-validation-messages
+
+: init-validation ( -- )
+ V{ } clone validation-messages set
+ H{ } clone named-validation-messages set ;
: (validation-message) ( obj -- )
validation-messages get push ;
: (validation-message-for) ( obj name -- )
- swap 2array (validation-message) ;
+ named-validation-messages get set-at ;
TUPLE: validation-message message ;
@@ -100,39 +114,29 @@ C: <validation-message> validation-message
: validation-message-for ( string name -- )
[ <validation-message> ] dip (validation-message-for) ;
-TUPLE: validation-error value message ;
+TUPLE: validation-error message value ;
C: <validation-error> validation-error
-: validation-error ( reason -- )
+: validation-error ( message -- )
f <validation-error> (validation-message) ;
-: validation-error-for ( reason value name -- )
+: validation-error-for ( message value name -- )
[ <validation-error> ] dip (validation-message-for) ;
: validation-failed? ( -- ? )
- validation-messages get [
- dup pair? [ second ] when validation-error?
- ] contains? ;
+ validation-messages get [ validation-error? ] contains?
+ named-validation-messages get [ nip validation-error? ] assoc-contains?
+ or ;
: define-validators ( class validators -- )
>hashtable "validators" set-word-prop ;
: validate ( value name quot -- result )
- [ swap validation-error-for f ] recover ; inline
-
-: validate-value ( value name validators -- result )
- '[ , at call ] validate ;
+ '[ drop @ ] [ -rot validation-error-for f ] recover ; inline
: required-values ( assoc -- )
- [ swap [ drop v-required ] validate drop ] assoc-each ;
+ [ swap [ v-required ] validate drop ] assoc-each ;
: validate-values ( assoc validators -- assoc' )
- '[ over , validate-value ] assoc-map ;
-
-: deposit-values ( destination assoc validators -- )
- validate-values update ;
-
-: deposit-slots ( tuple assoc -- )
- [ [ <mirror> ] [ class "validators" word-prop ] bi ] dip
- swap deposit-values ;
+ swap '[ [ [ dup , at ] keep ] dip validate ] assoc-map ;
diff --git a/extra/webapps/counter/counter.fhtml b/extra/webapps/counter/counter.fhtml
deleted file mode 100644
index 521096f105..0000000000
--- a/extra/webapps/counter/counter.fhtml
+++ /dev/null
@@ -1,10 +0,0 @@
-<% USING: io math.parser http.server.sessions webapps.counter ; %>
-
-<html>
- <body>
- <h1><% count sget number>string write %></h1>
-
- <a href="inc">++</a>
- <a href="dec">--</a>
- </body>
-</html>
diff --git a/extra/webapps/pastebin/annotation.xml b/extra/webapps/pastebin/annotation.xml
deleted file mode 100644
index d5b4ea8d3a..0000000000
--- a/extra/webapps/pastebin/annotation.xml
+++ /dev/null
@@ -1,17 +0,0 @@
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <h2>Annotation: <t:view t:component="summary" /></h2>
-
- <table>
- <tr><th class="field-label">Author: </th><td><t:view t:component="author" /></td></tr>
- <tr><th class="field-label">Mode: </th><td><t:view t:component="mode" /></td></tr>
- <tr><th class="field-label">Date: </th><td><t:view t:component="date" /></td></tr>
- </table>
-
- <pre class="description"><t:view t:component="contents" /></pre>
-
- <t:button t:action="$pastebin/delete-annotation" t:for="aid" class="link-button link">Delete Annotation</t:button>
-
-</t:chloe>
diff --git a/extra/webapps/pastebin/new-annotation.xml b/extra/webapps/pastebin/new-annotation.xml
deleted file mode 100644
index 5d18860977..0000000000
--- a/extra/webapps/pastebin/new-annotation.xml
+++ /dev/null
@@ -1,24 +0,0 @@
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:title>New Annotation</t:title>
-
- <t:form t:action="$pastebin/annotate" t:for="id">
-
- <table>
- <tr><th class="field-label">Summary: </th><td><t:edit t:component="summary" /></td></tr>
- <tr><th class="field-label">Author: </th><td><t:edit t:component="author" /></td></tr>
- <tr><th class="field-label">Mode: </th><td><t:edit t:component="mode" /></td></tr>
- <tr><th class="field-label big-field-label">Description:</th><td><t:edit t:component="contents" /></td></tr>
- <tr><th class="field-label">Captcha: </th><td><t:edit t:component="captcha" /></td></tr>
- <tr>
- <td></td>
- <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
- </tr>
- </table>
-
- <input type="SUBMIT" value="Done" />
- </t:form>
-
-</t:chloe>
diff --git a/extra/webapps/pastebin/paste-summary.xml b/extra/webapps/pastebin/paste-summary.xml
deleted file mode 100644
index c751b110c0..0000000000
--- a/extra/webapps/pastebin/paste-summary.xml
+++ /dev/null
@@ -1,11 +0,0 @@
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <tr>
- <td><t:a t:href="$pastebin/view-paste" t:query="id"><t:view t:component="summary" /></t:a></td>
- <td><t:view t:component="author" /></td>
- <td><t:view t:component="date" /></td>
- </tr>
-
-</t:chloe>
diff --git a/extra/webapps/planet/blog-admin-link.xml b/extra/webapps/planet/blog-admin-link.xml
deleted file mode 100644
index 8d6c890643..0000000000
--- a/extra/webapps/planet/blog-admin-link.xml
+++ /dev/null
@@ -1,7 +0,0 @@
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <t:a t:href="$planet-factor/admin/edit-blog" t:query="id"><t:view t:component="name" /></t:a>
-
-</t:chloe>
diff --git a/extra/webapps/todo/todo-summary.xml b/extra/webapps/todo/todo-summary.xml
deleted file mode 100644
index 056c9cab0a..0000000000
--- a/extra/webapps/todo/todo-summary.xml
+++ /dev/null
@@ -1,20 +0,0 @@
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
- <tr>
- <td>
- <t:view t:component="summary" />
- </td>
- <td>
- <t:view t:component="priority" />
- </td>
- <td>
- <t:a t:href="$todo-list/view" t:query="id">View</t:a>
- </td>
- <td>
- <t:a t:href="$todo-list/edit" t:query="id">Edit</t:a>
- </td>
- </tr>
-
-</t:chloe>
From 1c10cb0ff155b3cbad9c6186a92b7fcfd8920eeb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 26 May 2008 00:48:10 -0500
Subject: [PATCH 26/66] Update for word renaming
---
core/compiler/units/units.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index 11c81f4097..729cfcd179 100755
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations assocs namespaces sequences words
-vocabs definitions hashtables init ;
+vocabs definitions hashtables init sets ;
IN: compiler.units
SYMBOL: old-definitions
From b91a314f0e503de7b9a256f32506dac7b0e1fe19 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 26 May 2008 00:48:18 -0500
Subject: [PATCH 27/66] Another recursive fry fi
---
extra/fry/fry-tests.factor | 10 ++++++++++
extra/fry/fry.factor | 17 ++++++++++++-----
2 files changed, 22 insertions(+), 5 deletions(-)
diff --git a/extra/fry/fry-tests.factor b/extra/fry/fry-tests.factor
index eb59ffae4e..6d6abba23c 100755
--- a/extra/fry/fry-tests.factor
+++ b/extra/fry/fry-tests.factor
@@ -52,3 +52,13 @@ sequences ;
[ { 1 { 2 { 3 } } } ] [
1 2 3 '[ , [ , [ , 1array ] call 2array ] call 2array ] call
] unit-test
+
+{ 1 1 } [ '[ [ [ , ] ] ] ] must-infer-as
+
+[ { { { 3 } } } ] [
+ 3 '[ [ [ , 1array ] call 1array ] call 1array ] call
+] unit-test
+
+[ { { { 3 } } } ] [
+ 3 '[ [ [ , 1array ] call 1array ] call 1array ] call
+] unit-test
diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor
index 27a321ed92..4581c048fd 100755
--- a/extra/fry/fry.factor
+++ b/extra/fry/fry.factor
@@ -46,15 +46,22 @@ DEFER: (shallow-fry)
shallow-fry
] if* ;
+: fry-specifier? ( obj -- ? ) { , namespaces:, @ } member? ;
+
+: count-inputs ( quot -- n )
+ [
+ {
+ { [ dup callable? ] [ count-inputs ] }
+ { [ dup fry-specifier? ] [ drop 1 ] }
+ [ drop 0 ]
+ } cond
+ ] map sum ;
+
: fry ( quot -- quot' )
[
[
dup callable? [
- [
- [ { , namespaces:, @ } member? ] filter length
- \ , <repetition> %
- ]
- [ fry % ] bi
+ [ count-inputs \ , <repetition> % ] [ fry % ] bi
] [ namespaces:, ] if
] each
] [ ] make deep-fry ;
From 9d04629d4c304abb8d68803325042ec8283664a2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 26 May 2008 00:48:28 -0500
Subject: [PATCH 28/66] We can now parse reddit's RSS feed
---
extra/calendar/format/format-tests.factor | 12 ++++
extra/calendar/format/format.factor | 8 ++-
extra/rss/rss.factor | 78 ++++++++++++++---------
3 files changed, 65 insertions(+), 33 deletions(-)
diff --git a/extra/calendar/format/format-tests.factor b/extra/calendar/format/format-tests.factor
index f4e1669178..3efe33e265 100755
--- a/extra/calendar/format/format-tests.factor
+++ b/extra/calendar/format/format-tests.factor
@@ -50,3 +50,15 @@ IN: calendar.format.tests
"Sun May 04 07:00:00 2008 GMT" cookie-string>timestamp
timestamp>string
] unit-test
+
+[
+ T{ timestamp f
+ 2008
+ 5
+ 26
+ 0
+ 37
+ 42.12345
+ T{ duration f 0 0 0 -5 0 0 }
+ }
+] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test
diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor
index 91a034f8bd..ff1811e9d5 100755
--- a/extra/calendar/format/format.factor
+++ b/extra/calendar/format/format.factor
@@ -1,4 +1,4 @@
-USING: math math.order math.parser kernel sequences io
+USING: math math.order math.parser math.functions kernel sequences io
accessors arrays io.streams.string splitting
combinators accessors debugger
calendar calendar.format.macros ;
@@ -151,11 +151,15 @@ M: timestamp year. ( timestamp -- )
: read-hms ( -- h m s )
read-00 ":" expect read-00 ":" expect read-00 ;
+: read-rfc3339-seconds ( s -- s' ch )
+ "+-Z" read-until >r
+ [ string>number ] [ length 10 swap ^ ] bi / + r> ;
+
: (rfc3339>timestamp) ( -- timestamp )
read-ymd
"Tt" expect
read-hms
- read1 { { CHAR: . [ read-000 1000 / + read1 ] } [ ] } case
+ read1 { { CHAR: . [ read-rfc3339-seconds ] } [ ] } case
read-rfc3339-gmt-offset
<timestamp> ;
diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor
index 6e616e51a9..364c24b91f 100644
--- a/extra/rss/rss.factor
+++ b/extra/rss/rss.factor
@@ -18,51 +18,67 @@ TUPLE: entry title link description pub-date ;
C: <entry> entry
+: try-parsing-timestamp ( string -- timestamp )
+ [ rfc822>timestamp ] [ drop rfc3339>timestamp ] recover ;
+
: rss1.0-entry ( tag -- entry )
- [ "title" tag-named children>string ] keep
- [ "link" tag-named children>string ] keep
- [ "description" tag-named children>string ] keep
- f "date" "http://purl.org/dc/elements/1.1/" <name>
- tag-named dup [ children>string rfc822>timestamp ] when
- <entry> ;
+ {
+ [ "title" tag-named children>string ]
+ [ "link" tag-named children>string ]
+ [ "description" tag-named children>string ]
+ [
+ f "date" "http://purl.org/dc/elements/1.1/" <name>
+ tag-named dup [ children>string try-parsing-timestamp ] when
+ ]
+ } cleave <entry> ;
: rss1.0 ( xml -- feed )
[
"channel" tag-named
- [ "title" tag-named children>string ] keep
- "link" tag-named children>string
- ] keep
- "item" tags-named [ rss1.0-entry ] map <feed> ;
+ [ "title" tag-named children>string ]
+ [ "link" tag-named children>string ] bi
+ ] [ "item" tags-named [ rss1.0-entry ] map ] bi
+ <feed> ;
: rss2.0-entry ( tag -- entry )
- [ "title" tag-named children>string ] keep
- [ "link" tag-named ] keep
- [ "guid" tag-named dupd ? children>string ] keep
- [ "description" tag-named children>string ] keep
- "pubDate" tag-named children>string rfc822>timestamp <entry> ;
+ {
+ [ "title" tag-named children>string ]
+ [ { "link" "guid" } any-tag-named children>string ]
+ [ "description" tag-named children>string ]
+ [
+ { "date" "pubDate" } any-tag-named
+ children>string try-parsing-timestamp
+ ]
+ } cleave <entry> ;
: rss2.0 ( xml -- feed )
"channel" tag-named
- [ "title" tag-named children>string ] keep
- [ "link" tag-named children>string ] keep
- "item" tags-named [ rss2.0-entry ] map <feed> ;
+ [ "title" tag-named children>string ]
+ [ "link" tag-named children>string ]
+ [ "item" tags-named [ rss2.0-entry ] map ]
+ tri <feed> ;
: atom1.0-entry ( tag -- entry )
- [ "title" tag-named children>string ] keep
- [ "link" tag-named "href" swap at ] keep
- [
- { "content" "summary" } any-tag-named
- dup tag-children [ string? not ] contains?
- [ tag-children [ write-chunk ] with-string-writer ]
- [ children>string ] if
- ] keep
- { "published" "updated" "issued" "modified" } any-tag-named
- children>string rfc3339>timestamp <entry> ;
+ {
+ [ "title" tag-named children>string ]
+ [ "link" tag-named "href" swap at ]
+ [
+ { "content" "summary" } any-tag-named
+ dup tag-children [ string? not ] contains?
+ [ tag-children [ write-chunk ] with-string-writer ]
+ [ children>string ] if
+ ]
+ [
+ { "published" "updated" "issued" "modified" }
+ any-tag-named children>string try-parsing-timestamp
+ ]
+ } cleave <entry> ;
: atom1.0 ( xml -- feed )
- [ "title" tag-named children>string ] keep
- [ "link" tag-named "href" swap at ] keep
- "entry" tags-named [ atom1.0-entry ] map <feed> ;
+ [ "title" tag-named children>string ]
+ [ "link" tag-named "href" swap at ]
+ [ "entry" tags-named [ atom1.0-entry ] map ]
+ tri <feed> ;
: xml>feed ( xml -- feed )
dup name-tag {
From dc6af2f7bb7a1e65dcda9edd88a2019058df7b50 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 26 May 2008 00:48:37 -0500
Subject: [PATCH 29/66] Fix USING
---
extra/ui/tools/interactor/interactor.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor
index c28e8aec7c..400169908b 100755
--- a/extra/ui/tools/interactor/interactor.factor
+++ b/extra/ui/tools/interactor/interactor.factor
@@ -6,7 +6,7 @@ models namespaces parser prettyprint quotations sequences
strings threads listener classes.tuple ui.commands ui.gadgets
ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
ui.gestures definitions calendar concurrency.flags
-concurrency.mailboxes ui.tools.workspace accessors ;
+concurrency.mailboxes ui.tools.workspace accessors sets ;
IN: ui.tools.interactor
! If waiting is t, we're waiting for user input, and invoking
From be0d85180ff4fb40dba659b7f898d9b6f14c3d4c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 26 May 2008 02:54:53 -0500
Subject: [PATCH 30/66] Debugging validation
---
extra/html/components/components.factor | 13 ++++++
extra/html/templates/chloe/chloe.factor | 14 ++++++
extra/webapps/pastebin/new-paste.xml | 4 +-
extra/webapps/pastebin/paste.xml | 4 +-
extra/webapps/pastebin/pastebin.factor | 61 +++++++++++++------------
extra/webapps/pastebin/pastebin.xml | 6 +--
extra/webapps/planet/planet.factor | 13 ++++--
7 files changed, 76 insertions(+), 39 deletions(-)
diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor
index e6df343161..382636d952 100644
--- a/extra/html/components/components.factor
+++ b/extra/html/components/components.factor
@@ -44,6 +44,12 @@ SYMBOL: values
: with-each-tuple ( seq quot -- )
'[ from-tuple @ ] with-each-index ; inline
+: with-assoc-values ( assoc quot -- )
+ '[ blank-values , from-assoc @ ] with-scope ; inline
+
+: with-tuple-values ( assoc quot -- )
+ '[ blank-values , from-tuple @ ] with-scope ; inline
+
: nest-values ( name quot -- )
swap [
[
@@ -51,6 +57,13 @@ SYMBOL: values
] with-scope
] dip set-value ; inline
+: nest-tuple ( name quot -- )
+ swap [
+ [
+ H{ } clone [ <mirror> values set call ] keep
+ ] with-scope
+ ] dip set-value ; inline
+
: object>string ( object -- string )
{
{ [ dup real? ] [ number>string ] }
diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor
index 4430e69336..6790a9f666 100644
--- a/extra/html/templates/chloe/chloe.factor
+++ b/extra/html/templates/chloe/chloe.factor
@@ -217,6 +217,18 @@ STRING: button-tag-markup
: each-assoc-tag ( tag -- )
[ with-each-assoc ] (each-tag) ;
+: (bind-tag) ( tag quot -- )
+ [
+ [ "name" required-attr value ] keep
+ '[ , process-tag-children ]
+ ] dip call ; inline
+
+: bind-tuple-tag ( tag -- )
+ [ with-tuple-values ] (bind-tag) ;
+
+: bind-assoc-tag ( tag -- )
+ [ with-assoc-values ] (bind-tag) ;
+
: error-message-tag ( tag -- )
children>string render-error ;
@@ -280,6 +292,8 @@ STRING: button-tag-markup
{ "each" [ each-tag ] }
{ "each-assoc" [ each-assoc-tag ] }
{ "each-tuple" [ each-tuple-tag ] }
+ { "bind-assoc" [ bind-assoc-tag ] }
+ { "bind-tuple" [ bind-tuple-tag ] }
{ "comment" [ drop ] }
{ "call-next-template" [ drop call-next-template ] }
diff --git a/extra/webapps/pastebin/new-paste.xml b/extra/webapps/pastebin/new-paste.xml
index 1abd4d494b..6abae4895b 100644
--- a/extra/webapps/pastebin/new-paste.xml
+++ b/extra/webapps/pastebin/new-paste.xml
@@ -10,8 +10,8 @@
<tr><th class="field-label">Summary: </th><td><t:field t:name="summary" /></td></tr>
<tr><th class="field-label">Author: </th><td><t:field t:name="author" /></td></tr>
<tr><th class="field-label">Mode: </th><td><t:choice t:name="mode" t:choices="modes" /></td></tr>
- <tr><th class="field-label big-field-label">Description: </th><td><t:textarea t:name="contents" /></td></tr>
- <tr><th class="field-label">Captcha: </th><td><t:captcha t:name="captcha" /></td></tr>
+ <tr><th class="field-label big-field-label">Body: </th><td><t:textarea t:name="contents" t:rows="20" t:cols="60" /></td></tr>
+ <tr><th class="field-label">Captcha: </th><td><t:field t:name="captcha" /></td></tr>
<tr>
<td></td>
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
diff --git a/extra/webapps/pastebin/paste.xml b/extra/webapps/pastebin/paste.xml
index 1f65ff6765..57c2fdb7c2 100644
--- a/extra/webapps/pastebin/paste.xml
+++ b/extra/webapps/pastebin/paste.xml
@@ -44,8 +44,8 @@
<tr><th class="field-label">Summary: </th><td><t:field t:name="summary" /></td></tr>
<tr><th class="field-label">Author: </th><td><t:field t:name="author" /></td></tr>
<tr><th class="field-label">Mode: </th><td><t:choice t:name="mode" t:choices="modes" /></td></tr>
- <tr><th class="field-label big-field-label">Description:</th><td><t:textarea t:name="contents" /></td></tr>
- <tr><th class="field-label">Captcha: </th><td><t:captcha t:name="captcha" /></td></tr>
+ <tr><th class="field-label big-field-label">Body:</th><td><t:textarea t:name="contents" t:rows="20" t:cols="60" /></td></tr>
+ <tr><th class="field-label">Captcha: </th><td><t:field t:name="captcha" /></td></tr>
<tr>
<td></td>
<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor
index 0772181b00..9852bf47cb 100644
--- a/extra/webapps/pastebin/pastebin.factor
+++ b/extra/webapps/pastebin/pastebin.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs sorting sequences kernel accessors
-hashtables sequences.lib db.types db.tuples db
+hashtables sequences.lib db.types db.tuples db combinators
calendar calendar.format math.parser rss xml.writer
xmode.catalog validators html.components html.templates.chloe
http.server
@@ -121,7 +121,9 @@ M: annotation entity-link
validate-integer-id
"id" value paste from-tuple
+ "id" value
"new-annotation" [
+ "id" set-value
mode-names "modes" set-value
"factor" "mode" set-value
] nest-values
@@ -145,6 +147,19 @@ M: annotation entity-link
[ validate-integer-id ] >>init
[ "id" value paste annotations>> paste-feed ] >>feed ;
+: validate-paste ( -- )
+ {
+ { "summary" [ v-one-line ] }
+ { "author" [ v-one-line ] }
+ { "mode" [ v-mode ] }
+ { "contents" [ v-required ] }
+ { "captcha" [ v-captcha ] }
+ } validate-params ;
+
+: deposit-paste-slots ( tuple -- )
+ now >>date
+ { "summary" "author" "mode" "contents" } deposit-slots ;
+
: <new-paste-action> ( -- action )
<page-action>
[
@@ -155,19 +170,13 @@ M: annotation entity-link
"new-paste" pastebin-template >>template
[
- {
- { "summary" [ v-one-line ] }
- { "author" [ v-one-line ] }
- { "mode" [ v-mode ] }
- { "contents" [ v-required ] }
- { "captcha" [ v-captcha ] }
- } validate-params
+ validate-paste
f <paste>
- now >>date
- dup { "summary" "author" "mode" "contents" } deposit-slots
+ [ deposit-paste-slots ]
[ insert-tuple ]
- [ id>> "$pastebin/paste" <id-redirect> ] bi
+ [ id>> "$pastebin/paste" <id-redirect> ]
+ tri
] >>submit ;
: <delete-paste-action> ( -- action )
@@ -185,26 +194,22 @@ M: annotation entity-link
! ! !
: <new-annotation-action> ( -- action )
- <action>
- [
- {
- { "summary" [ v-one-line ] }
- { "author" [ v-one-line ] }
- { "mode" [ v-mode ] }
- { "contents" [ v-required ] }
- { "captcha" [ v-captcha ] }
- } validate-params
- ] >>validate
+ <page-action>
+ [ validate-paste ] >>validate
+
+ [ "id" param "$pastebin/paste" <id-redirect> ] >>display
[
f f <annotation>
- now >>date
- dup { "summary" "author" "mode" "contents" } deposit-slots
- [ insert-tuple ]
- [
- ! Add anchor here
- "id" value "$pastebin/paste" <id-redirect>
- ] bi
+ {
+ [ deposit-paste-slots ]
+ [ { "id" } deposit-slots ]
+ [ insert-tuple ]
+ [
+ ! Add anchor here
+ id>> "$pastebin/paste" <id-redirect>
+ ]
+ } cleave
] >>submit ;
: <delete-annotation-action> ( -- action )
diff --git a/extra/webapps/pastebin/pastebin.xml b/extra/webapps/pastebin/pastebin.xml
index f0abd97c63..9ec2cb7976 100644
--- a/extra/webapps/pastebin/pastebin.xml
+++ b/extra/webapps/pastebin/pastebin.xml
@@ -13,9 +13,9 @@
<t:each-tuple t:values="pastes">
<tr>
- <td><t:a t:href="$pastebin/view-paste" t:query="id"><t:field t:name="summary" /></t:a></td>
- <td><t:field t:name="author" /></td>
- <td><t:field t:name="date" /></td>
+ <td><t:a t:href="$pastebin/paste" t:query="id"><t:label t:name="summary" /></t:a></td>
+ <td><t:label t:name="author" /></td>
+ <td><t:label t:name="date" /></td>
</tr>
</t:each-tuple>
</table>
diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor
index e3b5b17a32..414a59f3b2 100755
--- a/extra/webapps/planet/planet.factor
+++ b/extra/webapps/planet/planet.factor
@@ -132,6 +132,9 @@ posting "POSTINGS"
: <id-redirect> ( id next -- response )
swap "id" associate <standard-redirect> ;
+: deposit-blog-slots ( blog -- )
+ { "name" "www-url" "feed-url" } deposit-slots ;
+
: <new-blog-action> ( -- action )
<page-action>
"new-blog" planet-template >>template
@@ -140,9 +143,10 @@ posting "POSTINGS"
[
f <blog>
- dup { "name" "www-url" "feed-url" } deposit-slots
+ [ deposit-blog-slots ]
[ insert-tuple ]
- [ id>> "$planet-factor/admin/edit-blog" <id-redirect> ] bi
+ [ id>> "$planet-factor/admin/edit-blog" <id-redirect> ]
+ tri
] >>submit ;
: <edit-blog-action> ( -- action )
@@ -161,9 +165,10 @@ posting "POSTINGS"
[
f <blog>
- dup { "id" "name" "www-url" "feed-url" } deposit-slots
+ [ deposit-blog-slots ]
[ update-tuple ]
- [ id>> "$planet-factor/admin" <id-redirect> ] bi
+ [ id>> "$planet-factor/admin" <id-redirect> ]
+ tri
] >>submit ;
TUPLE: planet-factor-admin < dispatcher ;
From 79d1570b35588de0e895a561b25a1e99fad1e75e Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Mon, 26 May 2008 04:35:18 -0400
Subject: [PATCH 31/66] Refactoring, cleaning up code
---
extra/lisp/lisp-tests.factor | 2 +-
extra/lisp/lisp.factor | 91 ++++++++++++++++++------------------
2 files changed, 47 insertions(+), 46 deletions(-)
diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor
index f1db203a78..0312080907 100644
--- a/extra/lisp/lisp-tests.factor
+++ b/extra/lisp/lisp-tests.factor
@@ -7,7 +7,7 @@ IN: lisp.test
[
init-env
- "#f" [ f ] lisp-define
+ "#f" [ f ] lisp-define
"#t" [ t ] lisp-define
"+" "math" "+" define-primitve
diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor
index 0f5e4b4d2e..82a331f2ca 100644
--- a/extra/lisp/lisp.factor
+++ b/extra/lisp/lisp.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg sequences arrays strings combinators.lib
namespaces combinators math bake locals locals.private accessors
-vectors syntax lisp.parser assocs parser sequences.lib words quotations ;
+vectors syntax lisp.parser assocs parser sequences.lib words quotations
+fry ;
IN: lisp
DEFER: convert-form
@@ -12,52 +13,52 @@ DEFER: lookup-var
! Functions to convert s-exps to quotations
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: convert-body ( s-exp -- quot )
- [ convert-form ] map [ ] [ compose ] reduce ; inline
+ [ ] [ convert-form compose ] reduce ; inline
: convert-if ( s-exp -- quot )
- rest [ convert-form ] map reverse first3 [ % , , if ] bake ;
-
+ rest first3 [ convert-form ] tri@ '[ @ , , if ] ;
+
: convert-begin ( s-exp -- quot )
- rest [ convert-form ] map >quotation [ , [ funcall ] each ] bake ;
-
+ rest [ convert-form ] [ ] map-as '[ , [ funcall ] each ] ;
+
: convert-cond ( s-exp -- quot )
- rest [ body>> >array [ convert-form ] map first2 swap `{ [ % funcall ] , } bake ]
- map >array [ , cond ] bake ;
-
+ rest [ body>> first2 [ convert-form ] bi@ [ '[ @ funcall ] ] dip 2array ]
+ { } map-as '[ , cond ] ;
+
: convert-general-form ( s-exp -- quot )
- unclip convert-form swap convert-body [ , % funcall ] bake ;
+ unclip convert-form swap convert-body swap '[ , @ funcall ] ;
! words for convert-lambda
<PRIVATE
: localize-body ( assoc body -- assoc newbody )
- [ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ]
+ [ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ]
[ dup s-exp? [ body>> localize-body <s-exp> ] when ] if
] map ;
-
+
: localize-lambda ( body vars -- newbody newvars )
- make-locals dup push-locals swap
- [ swap localize-body <s-exp> convert-form swap pop-locals ] dip swap ;
+ make-locals dup push-locals swap
+ [ swap localize-body <s-exp> convert-form swap pop-locals ] dip swap ;
: split-lambda ( s-exp -- body vars )
- first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline
-
+ first3 -rot nip [ body>> ] bi@ [ name>> ] map ; inline
+
: rest-lambda ( body vars -- quot )
- "&rest" swap [ remove ] [ index ] 2bi
- [ localize-lambda <lambda> ] dip
- [ , cut swap [ % , ] bake , compose ] bake ;
-
+ "&rest" swap [ index ] [ remove ] 2bi
+ localize-lambda <lambda>
+ '[ , cut '[ @ , ] , compose ] ;
+
: normal-lambda ( body vars -- quot )
- localize-lambda <lambda> [ , compose ] bake ;
+ localize-lambda <lambda> '[ , compose ] ;
PRIVATE>
-
+
: convert-lambda ( s-exp -- quot )
- split-lambda dup "&rest" swap member? [ rest-lambda ] [ normal-lambda ] if ;
-
+ split-lambda "&rest" over member? [ rest-lambda ] [ normal-lambda ] if ;
+
: convert-quoted ( s-exp -- quot )
- second [ , ] bake ;
-
+ second 1quotation ;
+
: convert-list-form ( s-exp -- quot )
- dup first dup lisp-symbol?
+ dup first dup lisp-symbol?
[ name>>
{ { "lambda" [ convert-lambda ] }
{ "quote" [ convert-quoted ] }
@@ -67,35 +68,35 @@ PRIVATE>
[ drop convert-general-form ]
} case ]
[ drop convert-general-form ] if ;
-
+
: convert-form ( lisp-form -- quot )
- { { [ dup s-exp? ] [ body>> convert-list-form ] }
- { [ dup lisp-symbol? ] [ [ , lookup-var ] bake ] }
- [ [ , ] bake ]
- } cond ;
-
+ { { [ dup s-exp? ] [ body>> convert-list-form ] }
+ { [ dup lisp-symbol? ] [ '[ , lookup-var ] ] }
+ [ 1quotation ]
+ } cond ;
+
: lisp-string>factor ( str -- quot )
- lisp-expr parse-result-ast convert-form lambda-rewrite call ;
-
+ lisp-expr parse-result-ast convert-form lambda-rewrite call ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: lisp-env
ERROR: no-such-var var ;
: init-env ( -- )
- H{ } clone lisp-env set ;
+ H{ } clone lisp-env set ;
: lisp-define ( name quot -- )
- swap lisp-env get set-at ;
-
+ swap lisp-env get set-at ;
+
: lisp-get ( name -- word )
- dup lisp-env get at [ ] [ no-such-var throw ] ?if ;
-
+ dup lisp-env get at [ ] [ no-such-var throw ] ?if ;
+
: lookup-var ( lisp-symbol -- quot )
- name>> lisp-get ;
-
+ name>> lisp-get ;
+
: funcall ( quot sym -- * )
- dup lisp-symbol? [ lookup-var ] when call ; inline
-
+ dup lisp-symbol? [ lookup-var ] when call ; inline
+
: define-primitve ( name vocab word -- )
- swap lookup [ [ , ] compose call ] bake lisp-define ;
\ No newline at end of file
+ swap lookup 1quotation '[ , compose call ] lisp-define ;
\ No newline at end of file
From a77bbfc28e8a34c804970e416a025bf3bbaed80d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 26 May 2008 05:44:33 -0500
Subject: [PATCH 32/66] Fix unit test failure
---
core/parser/parser-tests.factor | 20 +++++++++++++++++++-
1 file changed, 19 insertions(+), 1 deletion(-)
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index 6f31b0ad7c..e8199d3520 100755
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -463,7 +463,25 @@ must-fail-with
[ [ ] ] [
2 [
- "IN: classes.tests DEFER: twice-fails FORGET: twice-fails MIXIN: twice-fails"
+ "IN: parser.tests DEFER: twice-fails FORGET: twice-fails MIXIN: twice-fails"
<string-reader> "twice-fails-test" parse-stream
] times
] unit-test
+
+[ [ ] ] [
+ "IN: parser.tests : staging-problem-test-1 1 ; : staging-problem-test-2 staging-problem-test-1 ;"
+ <string-reader> "staging-problem-test" parse-stream
+] unit-test
+
+[ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test
+
+[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
+
+[ [ ] ] [
+ "IN: parser.tests << : staging-problem-test-1 1 ; >> : staging-problem-test-2 staging-problem-test-1 ;"
+ <string-reader> "staging-problem-test" parse-stream
+] unit-test
+
+[ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test
+
+[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
From 8af320a2c00133718b1e6a23684e382c5cc1442b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 26 May 2008 17:15:54 -0500
Subject: [PATCH 33/66] Improve math.functions
---
extra/math/functions/functions-tests.factor | 6 ++
extra/math/functions/functions.factor | 66 +++++++++++++--------
extra/math/libm/libm.factor | 20 +++++++
3 files changed, 67 insertions(+), 25 deletions(-)
diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor
index c9215d8de7..51879fc6c6 100755
--- a/extra/math/functions/functions-tests.factor
+++ b/extra/math/functions/functions-tests.factor
@@ -39,6 +39,12 @@ IN: math.functions.tests
[ 0.0 ] [ 0 sin ] unit-test
[ 0.0 ] [ 0 asin ] unit-test
+[ t ] [ 10 atan real? ] unit-test
+[ f ] [ 10 atanh real? ] unit-test
+
+[ t ] [ 10 asin sin 10 1.e-10 ~ ] unit-test
+[ t ] [ -1 sqrt neg dup acos cos 1.e-10 ~ ] unit-test
+
[ 100 ] [ 100 100 gcd nip ] unit-test
[ 100 ] [ 1000 100 gcd nip ] unit-test
[ 100 ] [ 100 1000 gcd nip ] unit-test
diff --git a/extra/math/functions/functions.factor b/extra/math/functions/functions.factor
index bce93fbb11..bb43e4a721 100755
--- a/extra/math/functions/functions.factor
+++ b/extra/math/functions/functions.factor
@@ -125,74 +125,90 @@ M: real absq sq ;
M: number (^)
swap >polar 3dup ^theta >r ^mag r> polar> ;
+: [-1,1]? ( x -- ? )
+ dup complex? [ drop f ] [ abs 1 <= ] if ; inline
+
+: >=1? ( x -- ? )
+ dup complex? [ drop f ] [ 1 >= ] if ; inline
+
: exp ( x -- y ) >rect swap fexp swap polar> ; inline
: log ( x -- y ) >polar swap flog swap rect> ; inline
: cos ( x -- y )
- >float-rect 2dup
- fcosh swap fcos * -rot
- fsinh swap fsin neg * rect> ; foldable
+ dup complex? [
+ >float-rect 2dup
+ fcosh swap fcos * -rot
+ fsinh swap fsin neg * rect>
+ ] [ fcos ] if ; foldable
: sec ( x -- y ) cos recip ; inline
: cosh ( x -- y )
- >float-rect 2dup
- fcos swap fcosh * -rot
- fsin swap fsinh * rect> ; foldable
+ dup complex? [
+ >float-rect 2dup
+ fcos swap fcosh * -rot
+ fsin swap fsinh * rect>
+ ] [ fcosh ] if ; foldable
: sech ( x -- y ) cosh recip ; inline
: sin ( x -- y )
- >float-rect 2dup
- fcosh swap fsin * -rot
- fsinh swap fcos * rect> ; foldable
+ dup complex? [
+ >float-rect 2dup
+ fcosh swap fsin * -rot
+ fsinh swap fcos * rect>
+ ] [ fsin ] if ; foldable
: cosec ( x -- y ) sin recip ; inline
: sinh ( x -- y )
- >float-rect 2dup
- fcos swap fsinh * -rot
- fsin swap fcosh * rect> ; foldable
+ dup complex? [
+ >float-rect 2dup
+ fcos swap fsinh * -rot
+ fsin swap fcosh * rect>
+ ] [ fsinh ] if ; foldable
: cosech ( x -- y ) sinh recip ; inline
-: tan ( x -- y ) dup sin swap cos / ; inline
+: tan ( x -- y )
+ dup complex? [ dup sin swap cos / ] [ ftan ] if ; inline
-: tanh ( x -- y ) dup sinh swap cosh / ; inline
+: tanh ( x -- y )
+ dup complex? [ dup sinh swap cosh / ] [ ftanh ] if ; inline
-: cot ( x -- y ) dup cos swap sin / ; inline
+: cot ( x -- y ) tan recip ; inline
-: coth ( x -- y ) dup cosh swap sinh / ; inline
+: coth ( x -- y ) tanh recip ; inline
-: acosh ( x -- y ) dup sq 1- sqrt + log ; inline
+: acosh ( x -- y )
+ dup >=1? [ facosh ] [ dup sq 1- sqrt + log ] if ; inline
: asech ( x -- y ) recip acosh ; inline
-: asinh ( x -- y ) dup sq 1+ sqrt + log ; inline
+: asinh ( x -- y )
+ dup complex? [ dup sq 1+ sqrt + log ] [ fasinh ] if ; inline
: acosech ( x -- y ) recip asinh ; inline
-: atanh ( x -- y ) dup 1+ swap 1- neg / log 2 / ; inline
+: atanh ( x -- y )
+ dup [-1,1]? [ fatanh ] [ dup 1+ swap 1- neg / log 2 / ] if ; inline
: acoth ( x -- y ) recip atanh ; inline
-: [-1,1]? ( x -- ? )
- dup complex? [ drop f ] [ abs 1 <= ] if ; inline
-
: i* ( x -- y ) >rect neg swap rect> ;
: -i* ( x -- y ) >rect swap neg rect> ;
: asin ( x -- y )
- dup [-1,1]? [ >float fasin ] [ i* asinh -i* ] if ; inline
+ dup [-1,1]? [ fasin ] [ i* asinh -i* ] if ; inline
: acos ( x -- y )
- dup [-1,1]? [ >float facos ] [ asin pi 2 / swap - ] if ;
+ dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ;
inline
: atan ( x -- y )
- dup [-1,1]? [ >float fatan ] [ i* atanh i* ] if ; inline
+ dup complex? [ i* atanh i* ] [ fatan ] if ; inline
: asec ( x -- y ) recip acos ; inline
diff --git a/extra/math/libm/libm.factor b/extra/math/libm/libm.factor
index 0cc402e6e5..f70c8d2a77 100644
--- a/extra/math/libm/libm.factor
+++ b/extra/math/libm/libm.factor
@@ -15,6 +15,18 @@ IN: math.libm
"double" "libm" "atan" { "double" } alien-invoke ;
foldable
+: facosh ( x -- y )
+ "double" "libm" "acosh" { "double" } alien-invoke ;
+ foldable
+
+: fasinh ( x -- y )
+ "double" "libm" "asinh" { "double" } alien-invoke ;
+ foldable
+
+: fatanh ( x -- y )
+ "double" "libm" "atanh" { "double" } alien-invoke ;
+ foldable
+
: fatan2 ( x y -- z )
"double" "libm" "atan2" { "double" "double" } alien-invoke ;
foldable
@@ -27,6 +39,10 @@ IN: math.libm
"double" "libm" "sin" { "double" } alien-invoke ;
foldable
+: ftan ( x -- y )
+ "double" "libm" "tan" { "double" } alien-invoke ;
+ foldable
+
: fcosh ( x -- y )
"double" "libm" "cosh" { "double" } alien-invoke ;
foldable
@@ -35,6 +51,10 @@ IN: math.libm
"double" "libm" "sinh" { "double" } alien-invoke ;
foldable
+: ftanh ( x -- y )
+ "double" "libm" "tanh" { "double" } alien-invoke ;
+ foldable
+
: fexp ( x -- y )
"double" "libm" "exp" { "double" } alien-invoke ;
foldable
From c3aa938869ae9f6e0b10b55ebc88c0a84ba2a249 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 26 May 2008 17:21:51 -0500
Subject: [PATCH 34/66] Another unit test
---
extra/math/functions/functions-tests.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor
index 51879fc6c6..6176c12d21 100755
--- a/extra/math/functions/functions-tests.factor
+++ b/extra/math/functions/functions-tests.factor
@@ -44,6 +44,7 @@ IN: math.functions.tests
[ t ] [ 10 asin sin 10 1.e-10 ~ ] unit-test
[ t ] [ -1 sqrt neg dup acos cos 1.e-10 ~ ] unit-test
+[ t ] [ 10 asinh sinh 10 1.e-10 ~ ] unit-test
[ 100 ] [ 100 100 gcd nip ] unit-test
[ 100 ] [ 1000 100 gcd nip ] unit-test
From 8f69fd5aa89d087c01a4c5561be8d4623053d7ed Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 27 May 2008 00:01:04 -0500
Subject: [PATCH 35/66] Fix simple links
---
extra/farkup/farkup-tests.factor | 2 +-
extra/farkup/farkup.factor | 8 ++++++--
2 files changed, 7 insertions(+), 3 deletions(-)
diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor
index 043502cd24..4abd655d62 100755
--- a/extra/farkup/farkup-tests.factor
+++ b/extra/farkup/farkup-tests.factor
@@ -67,7 +67,7 @@ IN: farkup.tests
[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
-[ "<p><a href=\"lol.com\"></a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
+[ "<p><a href=\"lol.com\">lol.com</a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[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 fad237635f..5dcfa7528e 100755
--- a/extra/farkup/farkup.factor
+++ b/extra/farkup/farkup.factor
@@ -6,6 +6,8 @@ splitting io.streams.string peg.parsers
sequences.deep unicode.categories ;
IN: farkup
+SYMBOL: relative-link-prefix
+
<PRIVATE
: delimiters ( -- string )
@@ -68,7 +70,9 @@ MEMO: eq ( -- parser )
CHAR: : over member? [
dup { "http://" "https://" "ftp://" } [ head? ] with contains?
[ drop "/" ] unless
- ] when ;
+ ] [
+ relative-link-prefix get prepend
+ ] if ;
: escape-link ( href text -- href-esc text-esc )
>r check-url escape-quoted-string r> escape-string ;
@@ -100,7 +104,7 @@ MEMO: simple-link ( -- parser )
"[[" token hide ,
[ "|]" member? not ] satisfy repeat1 ,
"]]" token hide ,
- ] seq* [ first f make-link ] action ;
+ ] seq* [ first dup make-link ] action ;
MEMO: labelled-link ( -- parser )
[
From 91d7adcbf1274971e16f53f94aa6915b70cb71b7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 27 May 2008 00:01:27 -0500
Subject: [PATCH 36/66] Comparison component
---
extra/html/components/components.factor | 9 ++++++++-
extra/html/templates/chloe/chloe.factor | 1 +
2 files changed, 9 insertions(+), 1 deletion(-)
diff --git a/extra/html/components/components.factor b/extra/html/components/components.factor
index 382636d952..efac730af6 100644
--- a/extra/html/components/components.factor
+++ b/extra/html/components/components.factor
@@ -4,7 +4,8 @@ USING: accessors kernel namespaces io math.parser assocs classes
classes.tuple words arrays sequences sequences.lib splitting
mirrors hashtables combinators continuations math strings
fry locals calendar calendar.format xml.entities validators
-html.elements html.streams xmode.code2html farkup inspector ;
+html.elements html.streams xmode.code2html farkup inspector
+lcs.diff2html ;
IN: html.components
SYMBOL: values
@@ -211,6 +212,12 @@ SINGLETON: inspector
M: inspector render*
2drop [ describe ] with-html-stream ;
+! Diff component
+SINGLETON: comparison
+
+M: comparison render*
+ 2drop htmlize-diff ;
+
! HTML component
SINGLETON: html
diff --git a/extra/html/templates/chloe/chloe.factor b/extra/html/templates/chloe/chloe.factor
index 6790a9f666..092f79bb36 100644
--- a/extra/html/templates/chloe/chloe.factor
+++ b/extra/html/templates/chloe/chloe.factor
@@ -272,6 +272,7 @@ STRING: button-tag-markup
{ "code" [ code tuple-component-tag ] }
{ "farkup" [ farkup singleton-component-tag ] }
{ "inspector" [ inspector singleton-component-tag ] }
+ { "comparison" [ comparison singleton-component-tag ] }
{ "html" [ html singleton-component-tag ] }
! Forms
From e7438f4ab6f08456994bb932e10110f0cf5ecd84 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 27 May 2008 00:01:57 -0500
Subject: [PATCH 37/66] Add support for rest urls
---
extra/http/server/actions/actions.factor | 34 +++++++++++++++---------
1 file changed, 22 insertions(+), 12 deletions(-)
diff --git a/extra/http/server/actions/actions.factor b/extra/http/server/actions/actions.factor
index bcd2cbd585..eb5b8bfe68 100755
--- a/extra/http/server/actions/actions.factor
+++ b/extra/http/server/actions/actions.factor
@@ -2,11 +2,13 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences kernel assocs combinators http.server
validators http hashtables namespaces fry continuations locals
-boxes xml.entities html.elements html.components io arrays ;
+boxes xml.entities html.elements html.components io arrays math ;
IN: http.server.actions
SYMBOL: params
+SYMBOL: rest-param
+
: render-validation-messages ( -- )
validation-messages get
dup empty? [ drop ] [
@@ -15,7 +17,7 @@ SYMBOL: params
</ul>
] if ;
-TUPLE: action init display validate submit ;
+TUPLE: action rest-param init display validate submit ;
: new-action ( class -- action )
new
@@ -43,19 +45,27 @@ TUPLE: action init display validate submit ;
[ validate>> call ]
[ submit>> call ] bi ;
+: handle-rest-param ( arg -- )
+ dup length 1 > action get rest-param>> not or
+ [ <404> exit-with ] [
+ action get rest-param>> associate rest-param set
+ ] if ;
+
M: action call-responder* ( path action -- response )
dup action set
'[
- , empty? [
- init-validation
- ,
- request get [ request-params params set ] [ method>> ] bi
- {
- { "GET" [ handle-get ] }
- { "HEAD" [ handle-get ] }
- { "POST" [ handle-post ] }
- } case
- ] [ <404> ] if
+ , dup empty? [ drop ] [ handle-rest-param ] if
+
+ init-validation
+ ,
+ request get
+ [ request-params rest-param get assoc-union params set ]
+ [ method>> ] bi
+ {
+ { "GET" [ handle-get ] }
+ { "HEAD" [ handle-get ] }
+ { "POST" [ handle-post ] }
+ } case
] with-exit-continuation ;
: param ( name -- value )
From 5f4ffa998fed0594d3529efdb339da86a3f88985 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 27 May 2008 00:02:16 -0500
Subject: [PATCH 38/66] Wiki
---
extra/lcs/diff2html/diff2html.factor | 44 +++++
.../factor-website/factor-website.factor | 9 +-
extra/webapps/factor-website/page.css | 7 +-
extra/webapps/wiki/articles.xml | 15 ++
extra/webapps/wiki/diff.xml | 35 ++++
extra/webapps/wiki/edit.xml | 20 ++
extra/webapps/wiki/revisions.xml | 48 +++++
extra/webapps/wiki/view.xml | 19 ++
extra/webapps/wiki/wiki-common.xml | 28 +++
extra/webapps/wiki/wiki.css | 25 +++
extra/webapps/wiki/wiki.factor | 175 ++++++++++++++++++
11 files changed, 421 insertions(+), 4 deletions(-)
create mode 100644 extra/lcs/diff2html/diff2html.factor
create mode 100644 extra/webapps/wiki/articles.xml
create mode 100644 extra/webapps/wiki/diff.xml
create mode 100644 extra/webapps/wiki/edit.xml
create mode 100644 extra/webapps/wiki/revisions.xml
create mode 100644 extra/webapps/wiki/view.xml
create mode 100644 extra/webapps/wiki/wiki-common.xml
create mode 100644 extra/webapps/wiki/wiki.css
create mode 100644 extra/webapps/wiki/wiki.factor
diff --git a/extra/lcs/diff2html/diff2html.factor b/extra/lcs/diff2html/diff2html.factor
new file mode 100644
index 0000000000..a8f649e2c9
--- /dev/null
+++ b/extra/lcs/diff2html/diff2html.factor
@@ -0,0 +1,44 @@
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: lcs html.elements kernel qualified ;
+FROM: accessors => item>> ;
+FROM: io => write ;
+FROM: sequences => each empty? ;
+FROM: xml.entities => escape-string ;
+IN: lcs.diff2html
+
+GENERIC: diff-line ( obj -- )
+
+: write-item ( item -- )
+ item>> dup empty? [ drop " " ] [ escape-string ] if write ;
+
+M: retain diff-line
+ <tr>
+ dup [
+ <td "retain" =class td>
+ write-item
+ </td>
+ ] bi@
+ </tr> ;
+
+M: insert diff-line
+ <tr>
+ <td> </td>
+ <td "insert" =class td>
+ write-item
+ </td>
+ </tr> ;
+
+M: delete diff-line
+ <tr>
+ <td "delete" =class td>
+ write-item
+ </td>
+ <td> </td>
+ </tr> ;
+
+: htmlize-diff ( diff -- )
+ <table "comparison" =class table>
+ <tr> <th> "Old" write </th> <th> "New" write </th> </tr>
+ [ diff-line ] each
+ </table> ;
diff --git a/extra/webapps/factor-website/factor-website.factor b/extra/webapps/factor-website/factor-website.factor
index 1fb5d4c1a6..9ad4a05492 100644
--- a/extra/webapps/factor-website/factor-website.factor
+++ b/extra/webapps/factor-website/factor-website.factor
@@ -11,10 +11,11 @@ http.server.auth.login
http.server.auth.providers.db
http.server.boilerplate
html.templates.chloe
-webapps.user-admin
webapps.pastebin
webapps.planet
-webapps.todo ;
+webapps.todo
+webapps.wiki
+webapps.user-admin ;
IN: webapps.factor-website
: test-db "resource:test.db" sqlite-db ;
@@ -34,6 +35,9 @@ IN: webapps.factor-website
init-postings-table
init-todo-table
+
+ init-articles-table
+ init-revisions-table
] with-db ;
: <factor-website> ( -- responder )
@@ -41,6 +45,7 @@ IN: webapps.factor-website
<todo-list> "todo" add-responder
<pastebin> "pastebin" add-responder
<planet-factor> "planet" add-responder
+ <wiki> "wiki" add-responder
<user-admin> "user-admin" add-responder
<login>
users-in-db >>users
diff --git a/extra/webapps/factor-website/page.css b/extra/webapps/factor-website/page.css
index 606d574618..49e26883ad 100644
--- a/extra/webapps/factor-website/page.css
+++ b/extra/webapps/factor-website/page.css
@@ -42,12 +42,15 @@ a:hover, .link:hover {
}
.description {
- border: 1px dashed #ccc;
- background-color: #f5f5f5;
padding: 5px;
color: #000;
}
+.description pre {
+ border: 1px dashed #ccc;
+ background-color: #f5f5f5;
+}
+
.description p:first-child {
margin-top: 0px;
}
diff --git a/extra/webapps/wiki/articles.xml b/extra/webapps/wiki/articles.xml
new file mode 100644
index 0000000000..a552c2618f
--- /dev/null
+++ b/extra/webapps/wiki/articles.xml
@@ -0,0 +1,15 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>All Articles</t:title>
+
+ <ul>
+ <t:each-tuple t:values="articles">
+ <li>
+ <t:a t:href="view" t:query="title"><t:label t:name="title"/></t:a>
+ </li>
+ </t:each-tuple>
+ </ul>
+
+</t:chloe>
diff --git a/extra/webapps/wiki/diff.xml b/extra/webapps/wiki/diff.xml
new file mode 100644
index 0000000000..378466f0bb
--- /dev/null
+++ b/extra/webapps/wiki/diff.xml
@@ -0,0 +1,35 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:bind-tuple t:name="old">
+ <t:title>Diff: <t:label t:name="title" /></t:title>
+ </t:bind-tuple>
+
+ <table>
+ <tr>
+ <th class="field-label">Old revision:</th>
+ <t:bind-tuple t:name="old">
+ <td>Created on <t:label t:name="date" /> by <t:label t:name="author" />.</td>
+ </t:bind-tuple>
+ </tr>
+ <tr>
+ <th class="field-label">New revision:</th>
+ <t:bind-tuple t:name="old">
+ <td>Created on <t:label t:name="date" /> by <t:label t:name="author" />.</td>
+ </t:bind-tuple>
+ </tr>
+ </table>
+
+ <t:comparison t:name="diff" />
+
+ <t:bind-tuple t:name="old">
+ <div class="navbar">
+ <t:a t:href="$wiki/view" t:query="title">Latest</t:a>
+ | <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
+ | <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
+ | <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
+ </div>
+ </t:bind-tuple>
+
+</t:chloe>
diff --git a/extra/webapps/wiki/edit.xml b/extra/webapps/wiki/edit.xml
new file mode 100644
index 0000000000..85c8490c5d
--- /dev/null
+++ b/extra/webapps/wiki/edit.xml
@@ -0,0 +1,20 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit: <t:label t:name="title" /></t:title>
+
+ <t:form t:action="$wiki/edit" t:for="title">
+
+ <p>
+ <t:textarea t:name="content" t:rows="30" t:cols="80" />
+ </p>
+
+ <p>
+ <input type="submit" value="Save" />
+ </p>
+
+ </t:form>
+
+ <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
+</t:chloe>
diff --git a/extra/webapps/wiki/revisions.xml b/extra/webapps/wiki/revisions.xml
new file mode 100644
index 0000000000..fe74191773
--- /dev/null
+++ b/extra/webapps/wiki/revisions.xml
@@ -0,0 +1,48 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Revisions of <t:label t:name="title" /></t:title>
+
+ <ul>
+ <t:each-tuple t:values="revisions">
+ <li>
+ <t:a t:href="revision" t:query="id">
+ <t:label t:name="date" /> by <t:label t:name="author" />
+ </t:a>
+ </li>
+ </t:each-tuple>
+ </ul>
+
+ <h2>View Differences</h2>
+
+ <form action="diff" method="get">
+ <table>
+ <tr>
+ <th class="field-label">Old revision:</th>
+
+ <td>
+ <select name="old-id">
+ <t:each-tuple t:values="revisions">
+ <option> <t:label t:name="id" /> </option>
+ </t:each-tuple>
+ </select>
+ </td>
+ </tr>
+ <tr>
+ <th class="field-label">New revision:</th>
+
+ <td>
+ <select name="new-id">
+ <t:each-tuple t:values="revisions">
+ <option> <t:label t:name="id" /> </option>
+ </t:each-tuple>
+ </select>
+ </td>
+ </tr>
+ </table>
+
+ <input type="submit" value="View" />
+ </form>
+
+</t:chloe>
diff --git a/extra/webapps/wiki/view.xml b/extra/webapps/wiki/view.xml
new file mode 100644
index 0000000000..c3536f374d
--- /dev/null
+++ b/extra/webapps/wiki/view.xml
@@ -0,0 +1,19 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title><t:label t:name="title" /></t:title>
+
+ <div class="description">
+ <t:farkup t:name="content" />
+ </div>
+
+ <div class="navbar">
+ <t:a t:href="$wiki/view" t:query="title">Latest</t:a>
+ | <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
+ | <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
+ | <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
+ | This revision created on <t:label t:name="date" /> by <t:label t:name="author" />.
+ </div>
+
+</t:chloe>
diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml
new file mode 100644
index 0000000000..d241f910ca
--- /dev/null
+++ b/extra/webapps/wiki/wiki-common.xml
@@ -0,0 +1,28 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:style t:include="resource:extra/webapps/wiki/wiki.css" />
+
+ <div class="navbar">
+
+ <t:a t:href="$wiki">Front Page</t:a>
+ | <t:a t:href="$wiki/articles">All Articles</t:a>
+
+ <t:if t:code="http.server.sessions:uid">
+
+ <t:if t:code="http.server.auth.login:allow-edit-profile?">
+ | <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+ </t:if>
+
+ | <t:button t:action="$login/logout" t:flow="begin" class="link-button link">Logout</t:button>
+
+ </t:if>
+
+ </div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
diff --git a/extra/webapps/wiki/wiki.css b/extra/webapps/wiki/wiki.css
new file mode 100644
index 0000000000..e737cdd898
--- /dev/null
+++ b/extra/webapps/wiki/wiki.css
@@ -0,0 +1,25 @@
+.comparison table, {
+ border-color: #666;
+ border-style: solid;
+}
+
+.comparison th {
+ border-width: 1px;
+ border-color: #666;
+ border-style: solid;
+}
+
+.comparison table {
+ border-width: 1px;
+ border-spacing: 0;
+ border-collapse: collapse;
+}
+
+
+.insert {
+ background-color: #9f9;
+}
+
+.delete {
+ background-color: #f99;
+}
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor
new file mode 100644
index 0000000000..2f281866c5
--- /dev/null
+++ b/extra/webapps/wiki/wiki.factor
@@ -0,0 +1,175 @@
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel hashtables calendar
+namespaces splitting sequences sorting math.order
+html.components
+html.templates.chloe
+http.server
+http.server.actions
+http.server.auth
+http.server.auth.login
+http.server.boilerplate
+validators
+db.types db.tuples lcs farkup ;
+IN: webapps.wiki
+
+TUPLE: article title revision ;
+
+article "ARTICLES" {
+ { "title" "TITLE" { VARCHAR 256 } +not-null+ +user-assigned-id+ }
+ ! { "AUTHOR" INTEGER +not-null+ } ! uid
+ ! { "PROTECTED" BOOLEAN +not-null+ }
+ { "revision" "REVISION" INTEGER +not-null+ } ! revision id
+} define-persistent
+
+: <article> ( title -- article ) article new swap >>title ;
+
+: init-articles-table article ensure-table ;
+
+TUPLE: revision id title author date content ;
+
+revision "REVISIONS" {
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "title" "TITLE" { VARCHAR 256 } +not-null+ } ! article id
+ { "author" "AUTHOR" { VARCHAR 256 } +not-null+ } ! uid
+ { "date" "DATE" TIMESTAMP +not-null+ }
+ { "content" "CONTENT" TEXT +not-null+ }
+} define-persistent
+
+: <revision> ( id -- revision )
+ revision new swap >>id ;
+
+: init-revisions-table revision ensure-table ;
+
+: wiki-template ( name -- template )
+ "resource:extra/webapps/wiki/" swap ".xml" 3append <chloe> ;
+
+: <title-redirect> ( title next -- response )
+ swap "title" associate <standard-redirect> ;
+
+: validate-title ( -- )
+ { { "title" [ v-one-line ] } } validate-params ;
+
+: <main-article-action> ( -- action )
+ <action>
+ [ "Front Page" "$wiki/view" <title-redirect> ] >>display ;
+
+: <view-article-action> ( -- action )
+ <action>
+ "title" >>rest-param
+
+ [
+ validate-title
+ "view?title=" relative-link-prefix set
+ ] >>init
+
+ [
+ "title" value dup <article> select-tuple [
+ revision>> <revision> select-tuple from-tuple
+ "view" wiki-template <html-content>
+ ] [
+ "$wiki/edit" <title-redirect>
+ ] ?if
+ ] >>display ;
+
+: <view-revision-action> ( -- action )
+ <page-action>
+ [
+ { { "id" [ v-integer ] } } validate-params
+ "id" value <revision>
+ select-tuple from-tuple
+ ] >>init
+
+ "view" wiki-template >>template ;
+
+: add-revision ( revision -- )
+ [ insert-tuple ]
+ [
+ dup title>> <article> select-tuple [
+ swap id>> >>revision update-tuple
+ ] [
+ [ title>> ] [ id>> ] bi article boa insert-tuple
+ ] if*
+ ] bi ;
+
+: <edit-article-action> ( -- action )
+ <page-action>
+ [
+ validate-title
+ "title" value <article> select-tuple [
+ revision>> <revision> select-tuple from-tuple
+ ] when*
+ ] >>init
+
+ "edit" wiki-template >>template
+
+ [
+ validate-title
+ { { "content" [ v-required ] } } validate-params
+
+ f <revision>
+ "title" value >>title
+ now >>date
+ logged-in-user get username>> >>author
+ "content" value >>content
+ [ add-revision ]
+ [ title>> "$wiki/view" <title-redirect> ] bi
+ ] >>submit ;
+
+: <list-revisions-action> ( -- action )
+ <page-action>
+ [
+ validate-title
+ f <revision> "title" value >>title select-tuples
+ [ [ date>> ] compare invert-comparison ] sort
+ "revisions" set-value
+ ] >>init
+
+ "revisions" wiki-template >>template ;
+
+: <delete-action> ( -- action )
+ <action>
+ [ validate-title ] >>validate
+
+ [
+ "title" value <article> delete-tuples
+ f <revision> "title" value >>title delete-tuples
+ "" f <standard-redirect>
+ ] >>submit ;
+
+: <diff-action> ( -- action )
+ <page-action>
+ [
+ {
+ { "old-id" [ v-integer ] }
+ { "new-id" [ v-integer ] }
+ } validate-params
+
+ "old-id" "new-id"
+ [ value <revision> select-tuple ] bi@
+ [ [ "old" set-value ] [ "new" set-value ] bi* ]
+ [ [ content>> string-lines ] bi@ diff "diff" set-value ]
+ 2bi
+ ] >>init
+
+ "diff" wiki-template >>template ;
+
+: <list-articles-action> ( -- action )
+ <page-action>
+ [ f <article> select-tuples "articles" set-value ] >>init
+ "articles" wiki-template >>template ;
+
+TUPLE: wiki < dispatcher ;
+
+: <wiki> ( -- dispatcher )
+ wiki new-dispatcher
+ <main-article-action> "" add-responder
+ <view-article-action> "view" add-responder
+ <view-revision-action> "revision" add-responder
+ <edit-article-action> { } <protected> "edit" add-responder
+ <list-revisions-action> "revisions" add-responder
+ <delete-action> "delete" add-responder
+ <diff-action> "diff" add-responder
+ <list-articles-action> "articles" add-responder
+ <boilerplate>
+ "wiki-common" wiki-template >>template ;
From 8278ac5b28ac80438bc8e7be2be385d30ed727bd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 27 May 2008 01:18:38 -0500
Subject: [PATCH 39/66] Various fixes
---
extra/http/server/auth/login/edit-profile.xml | 2 +-
extra/http/server/auth/login/register.xml | 2 +-
extra/validators/validators-tests.factor | 15 +++++++++++
extra/validators/validators.factor | 25 ++++++++++++++++---
extra/webapps/user-admin/user-admin.factor | 1 -
extra/webapps/wiki/wiki.factor | 4 +--
extra/xmode/code2html/code2html.factor | 2 +-
7 files changed, 41 insertions(+), 10 deletions(-)
diff --git a/extra/http/server/auth/login/edit-profile.xml b/extra/http/server/auth/login/edit-profile.xml
index 855dfa8469..6beaf5de6d 100644
--- a/extra/http/server/auth/login/edit-profile.xml
+++ b/extra/http/server/auth/login/edit-profile.xml
@@ -10,7 +10,7 @@
<tr>
<th class="field-label">User name:</th>
- <td><t:field t:name="username" /></td>
+ <td><t:label t:name="username" /></td>
</tr>
<tr>
diff --git a/extra/http/server/auth/login/register.xml b/extra/http/server/auth/login/register.xml
index 4804410dde..9815f21945 100644
--- a/extra/http/server/auth/login/register.xml
+++ b/extra/http/server/auth/login/register.xml
@@ -63,7 +63,7 @@
<p>
<input type="submit" value="Register" />
- <t:validation-message />
+ <t:validation-messages />
</p>
diff --git a/extra/validators/validators-tests.factor b/extra/validators/validators-tests.factor
index a981f782d3..7d4325cbb6 100644
--- a/extra/validators/validators-tests.factor
+++ b/extra/validators/validators-tests.factor
@@ -47,6 +47,21 @@ namespaces assocs ;
[ "http:/www.factorcode.org" v-url ]
[ "invalid URL" = ] must-fail-with
+[ 4561261212345467 ] [ "4561261212345467" v-credit-card ] unit-test
+
+[ 4561261212345467 ] [ "4561-2612-1234-5467" v-credit-card ] unit-test
+
+[ 0 ] [ "0000000000000000" v-credit-card ] unit-test
+
+[ "000000000" v-credit-card ] must-fail
+
+[ "0000000000000000000000000" v-credit-card ] must-fail
+
+[ "4561_2612_1234_5467" v-credit-card ] must-fail
+
+[ "4561-2621-1234-5467" v-credit-card ] must-fail
+
+
[ 14 V{ } ] [
[
"14" "age" [ v-number 13 v-min-value 100 v-max-value ] validate
diff --git a/extra/validators/validators.factor b/extra/validators/validators.factor
index 2dcc2c04f9..aeb2dc2f80 100644
--- a/extra/validators/validators.factor
+++ b/extra/validators/validators.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel continuations sequences math namespaces sets
-math.parser assocs regexp fry unicode.categories sequences
-arrays hashtables words combinators mirrors classes quotations
-xmode.catalog ;
+USING: kernel continuations sequences sequences.lib math
+namespaces sets math.parser math.ranges assocs regexp fry
+unicode.categories arrays hashtables words combinators mirrors
+classes quotations xmode.catalog ;
IN: validators
: v-default ( str def -- str )
@@ -91,6 +91,23 @@ IN: validators
"not a valid syntax mode" throw
] unless ;
+: luhn? ( n -- ? )
+ string>digits <reversed>
+ [ odd? [ 2 * 10 /mod + ] when ] map-index
+ sum 10 mod 0 = ;
+
+: v-credit-card ( str -- n )
+ "- " diff
+ dup CHAR: 0 CHAR: 9 [a,b] diff empty? [
+ 13 v-min-length
+ 16 v-max-length
+ dup luhn? [ string>number ] [
+ "card number check failed" throw
+ ] if
+ ] [
+ "invalid credit card number format" throw
+ ] if ;
+
SYMBOL: validation-messages
SYMBOL: named-validation-messages
diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor
index 728d5215f0..cdaf3f5ea9 100644
--- a/extra/webapps/user-admin/user-admin.factor
+++ b/extra/webapps/user-admin/user-admin.factor
@@ -12,7 +12,6 @@ http.server.auth.login
http.server.auth
http.server.sessions
http.server.actions
-http.server.crud
http.server ;
IN: webapps.user-admin
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor
index 2f281866c5..d0e1aed7ce 100644
--- a/extra/webapps/wiki/wiki.factor
+++ b/extra/webapps/wiki/wiki.factor
@@ -166,10 +166,10 @@ TUPLE: wiki < dispatcher ;
<main-article-action> "" add-responder
<view-article-action> "view" add-responder
<view-revision-action> "revision" add-responder
- <edit-article-action> { } <protected> "edit" add-responder
<list-revisions-action> "revisions" add-responder
- <delete-action> "delete" add-responder
<diff-action> "diff" add-responder
<list-articles-action> "articles" add-responder
+ <edit-article-action> { } <protected> "edit" add-responder
+ <delete-action> { } <protected> "delete" add-responder
<boilerplate>
"wiki-common" wiki-template >>template ;
diff --git a/extra/xmode/code2html/code2html.factor b/extra/xmode/code2html/code2html.factor
index a9384ad861..6eccddc94a 100755
--- a/extra/xmode/code2html/code2html.factor
+++ b/extra/xmode/code2html/code2html.factor
@@ -1,4 +1,4 @@
-USING: xmode.tokens xmode.marker xmode.catalog kernel html
+USING: xmode.tokens xmode.marker xmode.catalog kernel
html.elements io io.files sequences words io.encodings.utf8
namespaces xml.entities ;
IN: xmode.code2html
From 6edcd94b62a5d1e419a4c73cea9aeecdf33515db Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 27 May 2008 02:28:48 -0500
Subject: [PATCH 40/66] Fixes
---
extra/http/server/crud/crud.factor | 66 ------------------------------
1 file changed, 66 deletions(-)
delete mode 100755 extra/http/server/crud/crud.factor
diff --git a/extra/http/server/crud/crud.factor b/extra/http/server/crud/crud.factor
deleted file mode 100755
index 5fb7c15019..0000000000
--- a/extra/http/server/crud/crud.factor
+++ /dev/null
@@ -1,66 +0,0 @@
-! 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 validators
-http.server
-http.server.actions
-http.server.components
-http.server.forms ;
-IN: http.server.crud
-
-:: <view-action> ( form ctor -- action )
- <action>
- { { "id" [ v-number ] } } >>get-params
-
- [ "id" get ctor call select-tuple from-tuple ] >>init
-
- [ form view-form ] >>display ;
-
-: <id-redirect> ( id next -- response )
- swap "id" associate <standard-redirect> ;
-
-:: <edit-action> ( form ctor next -- action )
- <action>
- { { "id" [ [ v-number ] v-optional ] } } >>get-params
-
- [
- "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
- "id" value [ update-tuple ] [ insert-tuple ] if
-
- "id" value next <id-redirect>
- ] >>submit ;
-
-:: <delete-action> ( ctor next -- action )
- <action>
- { { "id" [ v-number ] } } >>post-params
-
- [
- "id" get ctor call delete-tuples
-
- next f <standard-redirect>
- ] >>submit ;
-
-:: <list-action> ( form ctor -- action )
- <action>
- [
- blank-values
-
- f ctor call select-tuples "list" set-value
-
- form view-form
- ] >>display ;
From fa3ab3a8b83d5aef562850c5eded83d439795190 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 27 May 2008 02:42:13 -0500
Subject: [PATCH 41/66] More fixes
---
extra/http/server/auth/login/login.factor | 8 +++----
extra/http/server/static/static.factor | 26 +++++++++++------------
2 files changed, 15 insertions(+), 19 deletions(-)
diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor
index e8c9bf8608..fd4fbab8e8 100755
--- a/extra/http/server/auth/login/login.factor
+++ b/extra/http/server/auth/login/login.factor
@@ -64,8 +64,8 @@ M: user-saver dispose
3append <chloe> ;
! ! ! Login
-: successful-login ( user -- )
- username>> set-uid ;
+: successful-login ( user -- response )
+ username>> set-uid "$login" end-flow ;
: login-failed ( -- * )
"invalid username or password" validation-error
@@ -84,9 +84,7 @@ M: user-saver dispose
"password" value
"username" value check-login
[ successful-login ] [ login-failed ] if*
- ] >>validate
-
- [ "$login" end-flow ] >>submit ;
+ ] >>submit ;
! ! ! New user registration
diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor
index 8c0e255e21..0e799fd3ad 100755
--- a/extra/http/server/static/static.factor
+++ b/extra/http/server/static/static.factor
@@ -1,10 +1,10 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: calendar html io io.files kernel math math.order
+USING: calendar io io.files kernel math math.order
math.parser http http.server namespaces parser sequences strings
assocs hashtables debugger http.mime sorting html.elements
html.templates.fhtml logging calendar.format accessors
-io.encodings.binary fry ;
+io.encodings.binary fry xml.entities ;
IN: http.server.static
! special maps mime types to quots with effect ( path -- )
@@ -58,20 +58,18 @@ TUPLE: file-responder root hook special allow-listings ;
: file. ( name dirp -- )
[ "/" append ] when
- dup <a =href a> write </a> ;
+ dup <a =href a> escape-string write </a> ;
: directory. ( path -- )
- [
- dup file-name [
- [ <h1> file-name write </h1> ]
- [
- <ul>
- directory sort-keys
- [ <li> file. </li> ] assoc-each
- </ul>
- ] bi
- ] simple-page
- ] with-html-stream ;
+ dup file-name [
+ [ <h1> file-name escape-string write </h1> ]
+ [
+ <ul>
+ directory sort-keys
+ [ <li> file. </li> ] assoc-each
+ </ul>
+ ] bi
+ ] simple-page ;
: list-directory ( directory -- response )
file-responder get allow-listings>> [
From 83e9a717f71a5113e3ddb98d9ac19760d65609c0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 27 May 2008 02:42:21 -0500
Subject: [PATCH 42/66] More wiki features
---
extra/webapps/wiki/changes.xml | 19 +++++++++++++++++++
extra/webapps/wiki/diff.xml | 4 ++--
extra/webapps/wiki/revisions.xml | 6 +++---
extra/webapps/wiki/user-edits.xml | 17 +++++++++++++++++
extra/webapps/wiki/view.xml | 2 +-
extra/webapps/wiki/wiki-common.xml | 1 +
extra/webapps/wiki/wiki.factor | 29 ++++++++++++++++++++++++++++-
7 files changed, 71 insertions(+), 7 deletions(-)
create mode 100644 extra/webapps/wiki/changes.xml
create mode 100644 extra/webapps/wiki/user-edits.xml
diff --git a/extra/webapps/wiki/changes.xml b/extra/webapps/wiki/changes.xml
new file mode 100644
index 0000000000..5efa0c045a
--- /dev/null
+++ b/extra/webapps/wiki/changes.xml
@@ -0,0 +1,19 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recent Changes</t:title>
+
+ <ul>
+ <t:each-tuple t:values="changes">
+ <li>
+ <t:a t:href="title" t:query="title"><t:label t:name="title" /></t:a>
+ on
+ <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
+ by
+ <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
+ </li>
+ </t:each-tuple>
+ </ul>
+
+</t:chloe>
diff --git a/extra/webapps/wiki/diff.xml b/extra/webapps/wiki/diff.xml
index 378466f0bb..0fb0d6bae6 100644
--- a/extra/webapps/wiki/diff.xml
+++ b/extra/webapps/wiki/diff.xml
@@ -10,13 +10,13 @@
<tr>
<th class="field-label">Old revision:</th>
<t:bind-tuple t:name="old">
- <td>Created on <t:label t:name="date" /> by <t:label t:name="author" />.</td>
+ <td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
</t:bind-tuple>
</tr>
<tr>
<th class="field-label">New revision:</th>
<t:bind-tuple t:name="old">
- <td>Created on <t:label t:name="date" /> by <t:label t:name="author" />.</td>
+ <td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
</t:bind-tuple>
</tr>
</table>
diff --git a/extra/webapps/wiki/revisions.xml b/extra/webapps/wiki/revisions.xml
index fe74191773..4b7bdadf50 100644
--- a/extra/webapps/wiki/revisions.xml
+++ b/extra/webapps/wiki/revisions.xml
@@ -7,9 +7,9 @@
<ul>
<t:each-tuple t:values="revisions">
<li>
- <t:a t:href="revision" t:query="id">
- <t:label t:name="date" /> by <t:label t:name="author" />
- </t:a>
+ <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
+ by
+ <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
</li>
</t:each-tuple>
</ul>
diff --git a/extra/webapps/wiki/user-edits.xml b/extra/webapps/wiki/user-edits.xml
new file mode 100644
index 0000000000..cf19a38370
--- /dev/null
+++ b/extra/webapps/wiki/user-edits.xml
@@ -0,0 +1,17 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edits by <t:label t:name="author" /></t:title>
+
+ <ul>
+ <t:each-tuple t:values="user-edits">
+ <li>
+ <t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
+ on
+ <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
+ </li>
+ </t:each-tuple>
+ </ul>
+
+</t:chloe>
diff --git a/extra/webapps/wiki/view.xml b/extra/webapps/wiki/view.xml
index c3536f374d..56c8b37a1d 100644
--- a/extra/webapps/wiki/view.xml
+++ b/extra/webapps/wiki/view.xml
@@ -13,7 +13,7 @@
| <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
| <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
| <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
- | This revision created on <t:label t:name="date" /> by <t:label t:name="author" />.
+ | This revision created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.
</div>
</t:chloe>
diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml
index d241f910ca..23e61e55fe 100644
--- a/extra/webapps/wiki/wiki-common.xml
+++ b/extra/webapps/wiki/wiki-common.xml
@@ -8,6 +8,7 @@
<t:a t:href="$wiki">Front Page</t:a>
| <t:a t:href="$wiki/articles">All Articles</t:a>
+ | <t:a t:href="$wiki/changes">Recent Changes</t:a>
<t:if t:code="http.server.sessions:uid">
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor
index d0e1aed7ce..344a3d40bd 100644
--- a/extra/webapps/wiki/wiki.factor
+++ b/extra/webapps/wiki/wiki.factor
@@ -127,6 +127,16 @@ revision "REVISIONS" {
"revisions" wiki-template >>template ;
+: <list-changes-action> ( -- action )
+ <page-action>
+ [
+ f <revision> select-tuples
+ [ [ date>> ] compare invert-comparison ] sort
+ "changes" set-value
+ ] >>init
+
+ "changes" wiki-template >>template ;
+
: <delete-action> ( -- action )
<action>
[ validate-title ] >>validate
@@ -156,9 +166,24 @@ revision "REVISIONS" {
: <list-articles-action> ( -- action )
<page-action>
- [ f <article> select-tuples "articles" set-value ] >>init
+ [
+ f <article> select-tuples
+ [ [ title>> ] compare ] sort
+ "articles" set-value
+ ] >>init
+
"articles" wiki-template >>template ;
+: <user-edits-action> ( -- action )
+ <page-action>
+ [
+ { { "author" [ v-username ] } } validate-params
+ f <revision> "author" value >>author
+ select-tuples "user-edits" set-value
+ ] >>init
+
+ "user-edits" wiki-template >>template ;
+
TUPLE: wiki < dispatcher ;
: <wiki> ( -- dispatcher )
@@ -167,8 +192,10 @@ TUPLE: wiki < dispatcher ;
<view-article-action> "view" add-responder
<view-revision-action> "revision" add-responder
<list-revisions-action> "revisions" add-responder
+ <user-edits-action> "user-edits" add-responder
<diff-action> "diff" add-responder
<list-articles-action> "articles" add-responder
+ <list-changes-action> "changes" add-responder
<edit-article-action> { } <protected> "edit" add-responder
<delete-action> { } <protected> "delete" add-responder
<boilerplate>
From 64a3233fad10519b8818a9b01a0e43ddcc18caf3 Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Tue, 27 May 2008 22:10:14 -0300
Subject: [PATCH 43/66] Reworked extra/irc (now in extra/irc/client)
---
extra/irc/{ => client}/authors.txt | 0
extra/irc/client/client.factor | 275 +++++++++++++++++++++++++++
extra/irc/{ => client}/summary.txt | 0
extra/irc/irc.factor | 286 -----------------------------
4 files changed, 275 insertions(+), 286 deletions(-)
rename extra/irc/{ => client}/authors.txt (100%)
create mode 100644 extra/irc/client/client.factor
rename extra/irc/{ => client}/summary.txt (100%)
delete mode 100755 extra/irc/irc.factor
diff --git a/extra/irc/authors.txt b/extra/irc/client/authors.txt
similarity index 100%
rename from extra/irc/authors.txt
rename to extra/irc/client/authors.txt
diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor
new file mode 100644
index 0000000000..19dca48e1d
--- /dev/null
+++ b/extra/irc/client/client.factor
@@ -0,0 +1,275 @@
+! Copyright (C) 2007 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators concurrency.mailboxes concurrency.futures io
+ io.encodings.8-bit io.sockets kernel namespaces sequences
+ sequences.lib splitting threads calendar classes.tuple
+ ascii assocs accessors destructors ;
+IN: irc.client
+
+! ======================================
+! Setup and running objects
+! ======================================
+
+SYMBOL: current-irc-client
+
+: irc-port 6667 ; ! Default irc port
+
+! "setup" objects
+TUPLE: irc-profile server port nickname password ;
+C: <irc-profile> irc-profile
+
+TUPLE: irc-channel-profile name password ;
+: <irc-channel-profile> ( -- irc-channel-profile ) irc-channel-profile new ;
+
+! "live" objects
+TUPLE: nick name channels log ;
+C: <nick> nick
+
+TUPLE: irc-client profile nick stream in-messages out-messages join-messages
+ listeners is-running ;
+: <irc-client> ( profile -- irc-client )
+ f V{ } clone V{ } clone <nick>
+ f <mailbox> <mailbox> <mailbox> H{ } clone f irc-client boa ;
+
+TUPLE: irc-listener in-messages out-messages ;
+: <irc-listener> ( -- irc-listener )
+ <mailbox> <mailbox> irc-listener boa ;
+
+! ======================================
+! Message objects
+! ======================================
+
+SINGLETON: irc-end ! Message used when the client isn't running anymore
+
+TUPLE: irc-message line prefix command parameters trailing timestamp ;
+TUPLE: logged-in < irc-message name ;
+TUPLE: ping < irc-message ;
+TUPLE: join < irc-message ;
+TUPLE: part < irc-message name channel ;
+TUPLE: quit < irc-message ;
+TUPLE: privmsg < irc-message name ;
+TUPLE: kick < irc-message channel who ;
+TUPLE: roomlist < irc-message channel names ;
+TUPLE: nick-in-use < irc-message asterisk name ;
+TUPLE: notice < irc-message type ;
+TUPLE: mode < irc-message name channel mode ;
+TUPLE: unhandled < irc-message ;
+
+<PRIVATE
+
+! ======================================
+! Shortcuts
+! ======================================
+
+: irc-client> ( -- irc-client ) current-irc-client get ;
+: irc-stream> ( -- stream ) irc-client> stream>> ;
+: irc-write ( s -- ) irc-stream> stream-write ;
+: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
+
+! ======================================
+! IRC client messages
+! ======================================
+
+: /NICK ( nick -- )
+ "NICK " irc-write irc-print ;
+
+: /LOGIN ( nick -- )
+ dup /NICK
+ "USER " irc-write irc-write
+ " hostname servername :irc.factor" irc-print ;
+
+: /CONNECT ( server port -- stream )
+ <inet> latin1 <client> drop ;
+
+: /JOIN ( channel password -- )
+ "JOIN " irc-write
+ [ " :" swap 3append ] when* irc-print ;
+
+: /PART ( channel text -- )
+ [ "PART " irc-write irc-write ] dip
+ " :" irc-write irc-print ;
+
+: /KICK ( channel who -- )
+ [ "KICK " irc-write irc-write ] dip
+ " " irc-write irc-print ;
+
+: /PRIVMSG ( nick line -- )
+ [ "PRIVMSG " irc-write irc-write ] dip
+ " :" irc-write irc-print ;
+
+: /ACTION ( nick line -- )
+ [ 1 , "ACTION " % % 1 , ] "" make /PRIVMSG ;
+
+: /QUIT ( text -- )
+ "QUIT :" irc-write irc-print ;
+
+: /PONG ( text -- )
+ "PONG " irc-write irc-print ;
+
+! ======================================
+! Server message handling
+! ======================================
+
+USE: prettyprint
+
+GENERIC: handle-incoming-irc ( irc-message -- )
+
+M: irc-message handle-incoming-irc ( irc-message -- )
+ . ;
+
+M: logged-in handle-incoming-irc ( logged-in -- )
+ name>> irc-client> nick>> (>>name) ;
+
+M: ping handle-incoming-irc ( ping -- )
+ trailing>> /PONG ;
+
+M: nick-in-use handle-incoming-irc ( nick-in-use -- )
+ name>> "_" append /NICK ;
+
+M: privmsg handle-incoming-irc ( privmsg -- )
+ dup name>> irc-client> listeners>> at
+ [ in-messages>> mailbox-put ] [ drop ] if* ;
+
+M: join handle-incoming-irc ( join -- )
+ irc-client> join-messages>> mailbox-put ;
+
+! ======================================
+! Client message handling
+! ======================================
+
+GENERIC: handle-outgoing-irc ( obj -- )
+
+M: privmsg handle-outgoing-irc ( privmsg -- )
+ [ name>> ] [ trailing>> ] bi /PRIVMSG ;
+
+! ======================================
+! Message parsing
+! ======================================
+
+: split-at-first ( seq separators -- before after )
+ dupd [ member? ] curry find
+ [ cut 1 tail ]
+ [ swap ]
+ if ;
+
+: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
+
+: parse-name ( string -- string )
+ remove-heading-: "!" split-at-first drop ;
+
+: split-prefix ( string -- string/f string )
+ dup ":" head?
+ [ remove-heading-: " " split1 ]
+ [ f swap ]
+ if ;
+
+: split-trailing ( string -- string string/f )
+ ":" split1 ;
+
+: string>irc-message ( string -- object )
+ dup split-prefix split-trailing
+ [ [ blank? ] trim " " split unclip swap ] dip
+ now irc-message boa ;
+
+: parse-irc-line ( string -- message )
+ string>irc-message
+ dup command>> {
+ { "PING" [ \ ping ] }
+ { "NOTICE" [ \ notice ] }
+ { "001" [ \ logged-in ] }
+ { "433" [ \ nick-in-use ] }
+ { "JOIN" [ \ join ] }
+ { "PART" [ \ part ] }
+ { "PRIVMSG" [ \ privmsg ] }
+ { "QUIT" [ \ quit ] }
+ { "MODE" [ \ mode ] }
+ { "KICK" [ \ kick ] }
+ [ drop \ unhandled ]
+ } case
+ [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ;
+
+! ======================================
+! Reader/Writer
+! ======================================
+
+: stream-readln-or-close ( stream -- str/f )
+ dup stream-readln [ nip ] [ dispose f ] if* ;
+
+: handle-reader-message ( irc-message -- )
+ irc-client> in-messages>> mailbox-put ;
+
+: handle-stream-close ( -- )
+ irc-client> f >>is-running in-messages>> irc-end swap mailbox-put ;
+
+: reader-loop ( -- )
+ irc-client> stream>> stream-readln-or-close [
+ parse-irc-line handle-reader-message
+ ] [
+ handle-stream-close
+ ] if* ;
+
+: writer-loop ( -- )
+ irc-client> out-messages>> mailbox-get handle-outgoing-irc ;
+
+! ======================================
+! Processing loops
+! ======================================
+
+: in-multiplexer-loop ( -- )
+ irc-client> in-messages>> mailbox-get handle-incoming-irc ;
+
+! FIXME: Hack, this should be handled better
+GENERIC: add-name ( name obj -- obj )
+M: object add-name nip ;
+M: privmsg add-name swap >>name ;
+
+: listener-loop ( name -- ) ! FIXME: take different values from the stack?
+ dup irc-client> listeners>> at [
+ out-messages>> mailbox-get add-name
+ irc-client> out-messages>>
+ mailbox-put
+ ] [ drop ] if* ;
+
+: spawn-irc-loop ( quot name -- )
+ [ [ irc-client> is-running>> ] compose ] dip
+ spawn-server drop ;
+
+: spawn-irc ( -- )
+ [ reader-loop ] "irc-reader-loop" spawn-irc-loop
+ [ writer-loop ] "irc-writer-loop" spawn-irc-loop
+ [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-irc-loop ;
+
+! ======================================
+! Listener join request handling
+! ======================================
+
+: make-registered-listener ( join -- listener )
+ <irc-listener> swap trailing>>
+ dup [ listener-loop ] curry "listener" spawn-irc-loop
+ [ irc-client> listeners>> set-at ] curry keep ;
+
+: make-join-future ( name -- future )
+ [ [ swap trailing>> = ] curry ! compare name with channel name
+ irc-client> join-messages>> 60 seconds rot mailbox-get-timeout?
+ make-registered-listener ]
+ curry future ;
+
+PRIVATE>
+
+: (connect-irc) ( irc-client -- )
+ [ profile>> [ server>> ] keep port>> /CONNECT ] keep
+ swap >>stream
+ t >>is-running drop ;
+
+: connect-irc ( irc-client -- )
+ dup current-irc-client [
+ [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi
+ spawn-irc
+ ] with-variable ;
+
+: listen-to ( irc-client name -- future )
+ swap current-irc-client [ [ f /JOIN ] keep make-join-future ] with-variable ;
+
+! shorcut for privmsgs, etc
+: sender>> ( obj -- string )
+ prefix>> parse-name ;
diff --git a/extra/irc/summary.txt b/extra/irc/client/summary.txt
similarity index 100%
rename from extra/irc/summary.txt
rename to extra/irc/client/summary.txt
diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor
deleted file mode 100755
index 9a278fb67f..0000000000
--- a/extra/irc/irc.factor
+++ /dev/null
@@ -1,286 +0,0 @@
-! Copyright (C) 2007 Doug Coleman, Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays calendar combinators channels concurrency.messaging fry io
- io.encodings.8-bit io.sockets kernel math namespaces sequences
- sequences.lib splitting strings threads
- continuations destructors classes.tuple ascii accessors ;
-IN: irc
-
-! utils
-: split-at-first ( seq separators -- before after )
- dupd '[ , member? ] find
- [ cut rest ]
- [ swap ]
- if ;
-
-: spawn-server-linked ( quot name -- thread )
- >r '[ , [ ] [ ] while ] r>
- spawn-linked ;
-! ---
-
-! Default irc port
-: irc-port 6667 ;
-
-! Message used when the client isn't running anymore
-SINGLETON: irc-end
-
-! "setup" objects
-TUPLE: irc-profile server port nickname password default-channels ;
-C: <irc-profile> irc-profile
-
-TUPLE: irc-channel-profile name password auto-rejoin ;
-C: <irc-channel-profile> irc-channel-profile
-
-! "live" objects
-TUPLE: nick name channels log ;
-C: <nick> nick
-
-TUPLE: irc-client profile nick stream stream-channel controller-channel
- listeners is-running ;
-: <irc-client> ( profile -- irc-client )
- f V{ } clone V{ } clone <nick>
- f <channel> <channel> V{ } clone f irc-client boa ;
-
-USE: prettyprint
-TUPLE: irc-listener channel ;
-! FIXME: spawn-server-linked con manejo de excepciones, mandar un mensaje final (ya se maneja esto al recibir mensajes del channel? )
-! tener la opción de dejar de correr un client??
-: <irc-listener> ( quot -- irc-listener )
- <channel> irc-listener boa swap
- [
- [ channel>> '[ , from ] ]
- [ '[ , curry f spawn drop ] ]
- bi* compose "irc-listener" spawn-server-linked drop
- ] [ drop ] 2bi ;
-
-! TUPLE: irc-channel name topic members log attributes ;
-! C: <irc-channel> irc-channel
-
-! the delegate of all irc messages
-TUPLE: irc-message line prefix command parameters trailing timestamp ;
-C: <irc-message> irc-message
-
-! "irc message" objects
-TUPLE: logged-in < irc-message name ;
-C: <logged-in> logged-in
-
-TUPLE: ping < irc-message ;
-C: <ping> ping
-
-TUPLE: join_ < irc-message ;
-C: <join> join_
-
-TUPLE: part < irc-message name channel ;
-C: <part> part
-
-TUPLE: quit ;
-C: <quit> quit
-
-TUPLE: privmsg < irc-message name ;
-C: <privmsg> privmsg
-
-TUPLE: kick < irc-message channel who ;
-C: <kick> kick
-
-TUPLE: roomlist < irc-message channel names ;
-C: <roomlist> roomlist
-
-TUPLE: nick-in-use < irc-message name ;
-C: <nick-in-use> nick-in-use
-
-TUPLE: notice < irc-message type ;
-C: <notice> notice
-
-TUPLE: mode < irc-message name channel mode ;
-C: <mode> mode
-
-TUPLE: unhandled < irc-message ;
-C: <unhandled> unhandled
-
-SYMBOL: irc-client
-: irc-client> ( -- irc-client ) irc-client get ;
-: irc-stream> ( -- stream ) irc-client> stream>> ;
-
-: remove-heading-: ( seq -- seq ) dup ":" head? [ rest ] when ;
-
-: parse-name ( string -- string )
- remove-heading-: "!" split-at-first drop ;
-
-: sender>> ( obj -- string )
- prefix>> parse-name ;
-
-: split-prefix ( string -- string/f string )
- dup ":" head?
- [ remove-heading-: " " split1 ]
- [ f swap ]
- if ;
-
-: split-trailing ( string -- string string/f )
- ":" split1 ;
-
-: string>irc-message ( string -- object )
- dup split-prefix split-trailing
- [ [ blank? ] trim " " split unclip swap ] dip
- now <irc-message> ;
-
-: me? ( name -- ? )
- irc-client> nick>> name>> = ;
-
-: irc-write ( s -- )
- irc-stream> stream-write ;
-
-: irc-print ( s -- )
- irc-stream> [ stream-print ] keep stream-flush ;
-
-! Irc commands
-
-: NICK ( nick -- )
- "NICK " irc-write irc-print ;
-
-: LOGIN ( nick -- )
- dup NICK
- "USER " irc-write irc-write
- " hostname servername :irc.factor" irc-print ;
-
-: CONNECT ( server port -- stream )
- <inet> latin1 <client> drop ;
-
-: JOIN ( channel password -- )
- "JOIN " irc-write
- [ " :" swap 3append ] when* irc-print ;
-
-: PART ( channel text -- )
- [ "PART " irc-write irc-write ] dip
- " :" irc-write irc-print ;
-
-: KICK ( channel who -- )
- [ "KICK " irc-write irc-write ] dip
- " " irc-write irc-print ;
-
-: PRIVMSG ( nick line -- )
- [ "PRIVMSG " irc-write irc-write ] dip
- " :" irc-write irc-print ;
-
-: SAY ( nick line -- )
- PRIVMSG ;
-
-: ACTION ( nick line -- )
- [ 1 , "ACTION " % % 1 , ] "" make PRIVMSG ;
-
-: QUIT ( text -- )
- "QUIT :" irc-write irc-print ;
-
-: join-channel ( channel-profile -- )
- [ name>> ] keep password>> JOIN ;
-
-: irc-connect ( irc-client -- )
- [ profile>> [ server>> ] keep port>> CONNECT ] keep
- swap >>stream t >>is-running drop ;
-
-GENERIC: handle-irc ( obj -- )
-
-M: object handle-irc ( obj -- )
- drop ;
-
-M: logged-in handle-irc ( obj -- )
- name>>
- irc-client> [ nick>> swap >>name drop ] keep
- profile>> default-channels>> [ join-channel ] each ;
-
-M: ping handle-irc ( obj -- )
- "PONG " irc-write
- trailing>> irc-print ;
-
-M: nick-in-use handle-irc ( obj -- )
- name>> "_" append NICK ;
-
-: parse-irc-line ( string -- message )
- string>irc-message
- dup command>> {
- { "PING" [ \ ping ] }
- { "NOTICE" [ \ notice ] }
- { "001" [ \ logged-in ] }
- { "433" [ \ nick-in-use ] }
- { "JOIN" [ \ join_ ] }
- { "PART" [ \ part ] }
- { "PRIVMSG" [ \ privmsg ] }
- { "QUIT" [ \ quit ] }
- { "MODE" [ \ mode ] }
- { "KICK" [ \ kick ] }
- [ drop \ unhandled ]
- } case
- [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ;
-
-! Reader
-: handle-reader-message ( irc-client irc-message -- )
- dup handle-irc swap stream-channel>> to ;
-
-: reader-loop ( irc-client -- )
- dup stream>> stream-readln [
- dup print parse-irc-line handle-reader-message
- ] [
- f >>is-running
- dup stream>> dispose
- irc-end over controller-channel>> to
- stream-channel>> irc-end swap to
- ] if* ;
-
-! Controller commands
-GENERIC: handle-command ( obj -- )
-
-M: object handle-command ( obj -- )
- . ;
-
-TUPLE: send-message to text ;
-C: <send-message> send-message
-M: send-message handle-command ( obj -- )
- dup to>> swap text>> SAY ;
-
-TUPLE: send-action to text ;
-C: <send-action> send-action
-M: send-action handle-command ( obj -- )
- dup to>> swap text>> ACTION ;
-
-TUPLE: send-quit text ;
-C: <send-quit> send-quit
-M: send-quit handle-command ( obj -- )
- text>> QUIT ;
-
-: irc-listen ( irc-client quot -- )
- [ listeners>> ] [ <irc-listener> ] bi* swap push ;
-
-! Controller loop
-: controller-loop ( irc-client -- )
- controller-channel>> from handle-command ;
-
-! Multiplexer
-: multiplex-message ( irc-client message -- )
- swap listeners>> [ channel>> ] map
- [ '[ , , to ] "message" spawn drop ] each-with ;
-
-: multiplexer-loop ( irc-client -- )
- dup stream-channel>> from multiplex-message ;
-
-! process looping and starting
-: (spawn-irc-loop) ( irc-client quot name -- )
- [ over >r curry r> '[ @ , is-running>> ] ] dip
- spawn-server-linked drop ;
-
-: spawn-irc-loop ( irc-client quot name -- )
- '[ , , , [ (spawn-irc-loop) receive ] [ print ] recover ]
- f spawn drop ;
-
-: spawn-irc ( irc-client -- )
- [ [ reader-loop ] "reader-loop" spawn-irc-loop ]
- [ [ controller-loop ] "controller-loop" spawn-irc-loop ]
- [ [ multiplexer-loop ] "multiplexer-loop" spawn-irc-loop ]
- tri ;
-
-: do-irc ( irc-client -- )
- irc-client [
- irc-client>
- [ irc-connect ]
- [ profile>> nickname>> LOGIN ]
- [ spawn-irc ]
- tri
- ] with-variable ;
\ No newline at end of file
From f47ee3ef181b6fe56cc41050e17f02e50b1bdd9d Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 28 May 2008 16:18:05 -0500
Subject: [PATCH 44/66] fix lists, tables
---
extra/farkup/farkup-tests.factor | 11 +++++++++++
extra/farkup/farkup.factor | 8 ++++++--
2 files changed, 17 insertions(+), 2 deletions(-)
diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor
index 9a3862d097..91cc5ec360 100755
--- a/extra/farkup/farkup-tests.factor
+++ b/extra/farkup/farkup-tests.factor
@@ -71,3 +71,14 @@ IN: farkup.tests
[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
[ ] [ "[{}]" convert-farkup drop ] unit-test
+
+[
+ "<p>Feature comparison:\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
+] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
+
+[
+ "<p>Feature comparison:\n\n<table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table></p>"
+] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
+
+[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
+[ "<ul><li>a-b</li></ul>" ] [ "-a-b" convert-farkup ] unit-test
diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor
index 98f0d0245f..47fe36b8ec 100755
--- a/extra/farkup/farkup.factor
+++ b/extra/farkup/farkup.factor
@@ -113,12 +113,14 @@ MEMO: labelled-link ( -- parser )
"]]" token hide ,
] seq* [ first2 make-link ] action ;
-MEMO: link ( -- parser ) [ image-link , simple-link , labelled-link , ] choice* ;
+MEMO: link ( -- parser )
+ [ image-link , simple-link , labelled-link , ] choice* ;
DEFER: line
MEMO: list-item ( -- parser )
[
- "-" token hide , line ,
+ "-" token hide , ! text ,
+ [ "\r\n" member? not ] satisfy repeat1 [ >string escape-string ] action ,
] seq* [ "li" surround-with-foo ] action ;
MEMO: list ( -- parser )
@@ -149,6 +151,8 @@ MEMO: code ( -- parser )
MEMO: line ( -- parser )
[
+ nl table 2seq ,
+ nl list 2seq ,
text , strong , emphasis , link ,
superscript , subscript , inline-code ,
escaped-char , delimiter , eq ,
From 8f06c94ee83d204d316c56eb37f44767dce8cdb0 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 28 May 2008 17:02:58 -0500
Subject: [PATCH 45/66] add inheritance support for db.tuples
---
extra/db/tuples/tuples-tests.factor | 19 +++++++++++++++++++
extra/db/tuples/tuples.factor | 2 +-
2 files changed, 20 insertions(+), 1 deletion(-)
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 4da82d92d6..b7c6fce933 100755
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@@ -414,6 +414,25 @@ TUPLE: does-not-persist ;
[ class \ not-persistent = ] must-fail-with
] test-postgresql
+
+TUPLE: suparclass a ;
+
+suparclass f {
+ { "id" "ID" +db-assigned-id+ }
+ { "a" "A" INTEGER }
+} define-persistent
+
+TUPLE: subbclass < suparclass b ;
+
+subbclass "SUBCLASS" {
+ { "b" "B" TEXT }
+} define-persistent
+
+: test-db-inheritance ( -- )
+ [ ] [ subbclass ensure-table ] unit-test ;
+
+[ test-db-inheritance ] test-sqlite
+
! Don't comment these out. These words must infer
\ bind-tuple must-infer
\ insert-tuple must-infer
diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index c940d121bb..0ffbd5bd47 100755
--- a/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@@ -19,7 +19,7 @@ ERROR: not-persistent ;
"db-table" word-prop [ not-persistent ] unless* ;
: db-columns ( class -- obj )
- "db-columns" word-prop ;
+ superclasses [ "db-columns" word-prop ] map concat ;
: db-relations ( class -- obj )
"db-relations" word-prop ;
From b7a6e117ec2997501b756e455509cb5915b869bb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 28 May 2008 17:04:59 -0500
Subject: [PATCH 46/66] Add no-follow option
---
extra/farkup/farkup.factor | 8 +++++++-
1 file changed, 7 insertions(+), 1 deletion(-)
diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor
index 5dcfa7528e..d58b54af37 100755
--- a/extra/farkup/farkup.factor
+++ b/extra/farkup/farkup.factor
@@ -7,6 +7,7 @@ sequences.deep unicode.categories ;
IN: farkup
SYMBOL: relative-link-prefix
+SYMBOL: link-no-follow?
<PRIVATE
@@ -79,7 +80,12 @@ MEMO: eq ( -- parser )
: make-link ( href text -- seq )
escape-link
- [ "<a href=\"" , >r , r> "\">" , [ , ] when* "</a>" , ] { } make ;
+ [
+ "<a" ,
+ " href=\"" , >r , r>
+ link-no-follow? get [ " nofollow=\"true\"" , ] when
+ "\">" , , "</a>" ,
+ ] { } make ;
: make-image-link ( href alt -- seq )
escape-link
From 0f040470d7e62c95d36475baa0001d734840dbf9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 28 May 2008 17:51:02 -0500
Subject: [PATCH 47/66] add histogram word to assocs.lib
---
extra/assocs/lib/lib.factor | 7 ++++++-
1 file changed, 6 insertions(+), 1 deletion(-)
diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor
index 7c274edb2e..c3e487a9fc 100755
--- a/extra/assocs/lib/lib.factor
+++ b/extra/assocs/lib/lib.factor
@@ -1,5 +1,5 @@
USING: arrays assocs kernel vectors sequences namespaces
-random math.parser ;
+random math.parser math fry ;
IN: assocs.lib
: ref-at ( table key -- value ) swap at ;
@@ -40,3 +40,8 @@ IN: assocs.lib
: set-at-unique ( value assoc -- key )
dup generate-key [ swap set-at ] keep ;
+
+: histogram ( assoc quot -- assoc' )
+ H{ } clone [
+ swap [ change-at ] 2curry assoc-each
+ ] keep ;
From bc1e021afd5242a39414e0aea1478065c691ff67 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 28 May 2008 18:17:58 -0500
Subject: [PATCH 48/66] Bug fixes
---
extra/http/server/callbacks/callbacks.factor | 2 +-
extra/locals/locals-tests.factor | 2 +-
extra/locals/locals.factor | 12 ++++++++++++
extra/macros/macros-tests.factor | 12 +++++++++++-
extra/macros/macros.factor | 3 +++
extra/memoize/memoize-tests.factor | 13 ++++++++++++-
extra/memoize/memoize.factor | 6 ++++++
extra/multi-methods/multi-methods.factor | 2 +-
extra/tangle/html/html.factor | 2 +-
extra/xmode/code2html/responder/responder.factor | 10 +++++-----
10 files changed, 53 insertions(+), 11 deletions(-)
diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor
index 40ba540ac6..3b819e067b 100755
--- a/extra/http/server/callbacks/callbacks.factor
+++ b/extra/http/server/callbacks/callbacks.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2004 Chris Double.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: html http http.server io kernel math namespaces
+USING: http http.server io kernel math namespaces
continuations calendar sequences assocs hashtables
accessors arrays alarms quotations combinators fry assocs.lib ;
IN: http.server.callbacks
diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor
index 87bc49f366..4e670cdac0 100755
--- a/extra/locals/locals-tests.factor
+++ b/extra/locals/locals-tests.factor
@@ -257,7 +257,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
:: a-word-with-locals ( a b -- ) ;
-: new-definition "IN: locals.tests\nUSING: math ;\n: a-word-with-locals ( -- x ) 2 3 + ;\n" ;
+: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n" ;
[ ] [ new-definition eval ] unit-test
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index af4f1a77b6..e74d0b6078 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -364,6 +364,9 @@ M: lambda-word definer drop \ :: \ ; ;
M: lambda-word definition
"lambda" word-prop body>> ;
+M: lambda-word reset-word
+ [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+
INTERSECTION: lambda-macro macro lambda-word ;
M: lambda-macro definer drop \ MACRO:: \ ; ;
@@ -371,6 +374,9 @@ M: lambda-macro definer drop \ MACRO:: \ ; ;
M: lambda-macro definition
"lambda" word-prop body>> ;
+M: lambda-macro reset-word
+ [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+
INTERSECTION: lambda-method method-body lambda-word ;
M: lambda-method definer drop \ M:: \ ; ;
@@ -378,6 +384,9 @@ M: lambda-method definer drop \ M:: \ ; ;
M: lambda-method definition
"lambda" word-prop body>> ;
+M: lambda-method reset-word
+ [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+
INTERSECTION: lambda-memoized memoized lambda-word ;
M: lambda-memoized definer drop \ MEMO:: \ ; ;
@@ -385,6 +394,9 @@ M: lambda-memoized definer drop \ MEMO:: \ ; ;
M: lambda-memoized definition
"lambda" word-prop body>> ;
+M: lambda-memoized reset-word
+ [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+
: method-stack-effect ( method -- effect )
dup "lambda" word-prop vars>>
swap "method-generic" word-prop stack-effect
diff --git a/extra/macros/macros-tests.factor b/extra/macros/macros-tests.factor
index 59a53afb70..d5011b0ecb 100644
--- a/extra/macros/macros-tests.factor
+++ b/extra/macros/macros-tests.factor
@@ -1,4 +1,14 @@
IN: macros.tests
USING: tools.test macros math kernel arrays
-vectors ;
+vectors io.streams.string prettyprint parser ;
+MACRO: see-test ( a b -- c ) + ;
+
+[ "USING: macros math ;\nIN: macros.tests\nMACRO: see-test ( a b -- c ) + ;\n" ]
+[ [ \ see-test see ] with-string-writer ]
+unit-test
+
+[ t ] [
+ "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval
+ [ \ see-test see ] with-string-writer =
+] unit-test
diff --git a/extra/macros/macros.factor b/extra/macros/macros.factor
index b242f91d3b..88bfd01fbe 100755
--- a/extra/macros/macros.factor
+++ b/extra/macros/macros.factor
@@ -23,6 +23,9 @@ M: macro definer drop \ MACRO: \ ; ;
M: macro definition "macro" word-prop ;
+M: macro reset-word
+ [ f "macro" set-word-prop ] [ call-next-method ] bi ;
+
: macro-expand ( ... word -- quot ) "macro" word-prop call ;
: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
diff --git a/extra/memoize/memoize-tests.factor b/extra/memoize/memoize-tests.factor
index 43428efbe0..c2592b38ca 100644
--- a/extra/memoize/memoize-tests.factor
+++ b/extra/memoize/memoize-tests.factor
@@ -1,6 +1,7 @@
! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel memoize tools.test parser ;
+USING: math kernel memoize tools.test parser
+prettyprint io.streams.string sequences ;
IN: memoize.tests
MEMO: fib ( m -- n )
@@ -9,3 +10,13 @@ MEMO: fib ( m -- n )
[ 89 ] [ 10 fib ] unit-test
[ "USING: kernel math memoize ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] must-fail
+
+MEMO: see-test ( a -- b ) reverse ;
+
+[ "USING: memoize sequences ;\nIN: memoize.tests\nMEMO: see-test ( a -- b ) reverse ;\n" ]
+[ [ \ see-test see ] with-string-writer ]
+unit-test
+
+[ ] [ "IN: memoize.tests : fib ;" eval ] unit-test
+
+[ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test
diff --git a/extra/memoize/memoize.factor b/extra/memoize/memoize.factor
index 4136f9eaff..7da2ee0f0d 100755
--- a/extra/memoize/memoize.factor
+++ b/extra/memoize/memoize.factor
@@ -44,8 +44,14 @@ IN: memoize
PREDICATE: memoized < word "memoize" word-prop ;
M: memoized definer drop \ MEMO: \ ; ;
+
M: memoized definition "memo-quot" word-prop ;
+M: memoized reset-word
+ [ { "memoize" "memo-quot" } reset-props ]
+ [ call-next-method ]
+ bi ;
+
: memoize-quot ( quot effect -- memo-quot )
gensym swap dupd "declared-effect" set-word-prop
dup rot define-memoized 1quotation ;
diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor
index b1073c116d..46ad6fc58e 100755
--- a/extra/multi-methods/multi-methods.factor
+++ b/extra/multi-methods/multi-methods.factor
@@ -4,7 +4,7 @@ USING: kernel math sequences vectors classes classes.algebra
combinators arrays words assocs parser namespaces definitions
prettyprint prettyprint.backend quotations arrays.lib
debugger io compiler.units kernel.private effects accessors
-hashtables sorting shuffle math.order ;
+hashtables sorting shuffle math.order sets ;
IN: multi-methods
! PART I: Converting hook specializers
diff --git a/extra/tangle/html/html.factor b/extra/tangle/html/html.factor
index fc604f4d46..2ec6b52609 100644
--- a/extra/tangle/html/html.factor
+++ b/extra/tangle/html/html.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors html html.elements io io.streams.string kernel namespaces semantic-db sequences strings tangle.path ;
+USING: accessors html.elements io io.streams.string kernel namespaces semantic-db sequences strings tangle.path ;
IN: tangle.html
TUPLE: element attributes ;
diff --git a/extra/xmode/code2html/responder/responder.factor b/extra/xmode/code2html/responder/responder.factor
index e059aeb7ff..2f56a5b819 100755
--- a/extra/xmode/code2html/responder/responder.factor
+++ b/extra/xmode/code2html/responder/responder.factor
@@ -1,16 +1,16 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.files io.encodings.utf8 namespaces http.server
-http.server.static http xmode.code2html kernel html sequences
+USING: io io.files io.encodings.utf8 namespaces http.server
+http.server.static http xmode.code2html kernel sequences
accessors fry ;
IN: xmode.code2html.responder
: <sources> ( root -- responder )
[
drop
- '[
- , [ file-name ] keep utf8 [
- [ htmlize-stream ] with-html-stream
+ dup '[
+ , utf8 [
+ , file-name input-stream get htmlize-stream
] with-file-reader
] <html-content>
] <file-responder> ;
From ec71ee094078ecf0dafdca0b6874dda9cb142568 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@173.160.255.10.in-addr.arpa>
Date: Wed, 28 May 2008 19:34:18 -0500
Subject: [PATCH 49/66] Bug fixes
---
core/classes/classes-tests.factor | 4 ++--
core/classes/tuple/tuple-tests.factor | 11 ++++++++++-
core/classes/tuple/tuple.factor | 6 ------
core/compiler/units/units.factor | 16 +++++++++++++---
core/generic/generic.factor | 16 ++++++++++------
core/parser/parser-tests.factor | 4 ++--
core/parser/parser.factor | 7 +++----
core/sequences/sequences-tests.factor | 6 ------
core/sets/sets-tests.factor | 6 ++++++
core/syntax/syntax.factor | 7 ++++---
core/words/words.factor | 4 +++-
11 files changed, 53 insertions(+), 34 deletions(-)
diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor
index 8d20da78b5..eb55b5fccd 100755
--- a/core/classes/classes-tests.factor
+++ b/core/classes/classes-tests.factor
@@ -166,6 +166,6 @@ GENERIC: method-forget-test
TUPLE: method-forget-class ;
M: method-forget-class method-forget-test ;
-[ f ] [ \ method-forget-test "methods" assoc-empty? ] unit-test
+[ f ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
[ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test
-[ t ] [ \ method-forget-test "methods" assoc-empty? ] unit-test
+[ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 0cf7ea3510..ab6c139f7b 100755
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -4,7 +4,7 @@ namespaces quotations sequences.private classes continuations
generic.standard effects classes.tuple classes.tuple.private
arrays vectors strings compiler.units accessors classes.algebra
calendar prettyprint io.streams.string splitting inspector
-columns math.order ;
+columns math.order classes.private ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
@@ -543,6 +543,7 @@ TUPLE: another-forget-accessors-test ;
! Missing error check
[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
+! Class forget messyness
TUPLE: subclass-forget-test ;
TUPLE: subclass-forget-test-1 < subclass-forget-test ;
@@ -551,6 +552,14 @@ TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
+[ H{ { subclass-forget-test-2 subclass-forget-test-2 } } ]
+[ subclass-forget-test-2 class-usages ]
+unit-test
+
+[ H{ { subclass-forget-test-3 subclass-forget-test-3 } } ]
+[ subclass-forget-test-3 class-usages ]
+unit-test
+
[ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
[ subclass-forget-test-3 new ] must-fail
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index f4054c8468..4e6ce0d2bb 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -226,12 +226,6 @@ M: tuple-class reset-class
} reset-props
] bi ;
-: reset-tuple-class ( class -- )
- [ [ reset-class ] [ update-map- ] bi ] each-subclass ;
-
-M: tuple-class forget*
- [ reset-tuple-class ] [ call-next-method ] bi ;
-
M: tuple-class rank-class drop 0 ;
M: tuple clone
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index 729cfcd179..c2e84429cf 100755
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -83,7 +83,14 @@ SYMBOL: update-tuples-hook
call-recompile-hook
call-update-tuples-hook
dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
- updated-definitions notify-definition-observers ;
+ ;
+
+: with-nested-compilation-unit ( quot -- )
+ [
+ H{ } clone changed-definitions set
+ H{ } clone outdated-tuples set
+ [ finish-compilation-unit ] [ ] cleanup
+ ] with-scope ; inline
: with-compilation-unit ( quot -- )
[
@@ -92,8 +99,11 @@ SYMBOL: update-tuples-hook
H{ } clone outdated-tuples set
<definitions> new-definitions set
<definitions> old-definitions set
- [ finish-compilation-unit ]
- [ ] cleanup
+ [
+ finish-compilation-unit
+ updated-definitions
+ notify-definition-observers
+ ] [ ] cleanup
] with-scope ; inline
: compile-call ( quot -- )
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index e446689303..b9a556e316 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -147,12 +147,16 @@ M: method-body forget*
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
M: class forget* ( class -- )
- {
- [ forget-methods ]
- [ update-map- ]
- [ reset-class ]
- [ call-next-method ]
- } cleave ;
+ [
+ class-usages [
+ drop
+ [ forget-methods ]
+ [ update-map- ]
+ [ reset-class ]
+ tri
+ ] assoc-each
+ ]
+ [ call-next-method ] bi ;
M: assoc update-methods ( assoc -- )
implementors* [ make-generic ] each ;
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index e8199d3520..37eb5f148e 100755
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -461,10 +461,10 @@ must-fail-with
"methods" word-prop assoc-size
] unit-test
-[ [ ] ] [
+[ ] [
2 [
"IN: parser.tests DEFER: twice-fails FORGET: twice-fails MIXIN: twice-fails"
- <string-reader> "twice-fails-test" parse-stream
+ <string-reader> "twice-fails-test" parse-stream drop
] times
] unit-test
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index f08ba8fbc2..3f46d1dd30 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -357,10 +357,9 @@ M: staging-violation summary
"A parsing word cannot be used in the same file it is defined in." ;
: execute-parsing ( word -- )
- new-definitions get [
- dupd first key? [ staging-violation ] when
- ] when*
- execute ;
+ [ changed-definitions get key? [ staging-violation ] when ]
+ [ execute ]
+ bi ;
: parse-step ( accum end -- accum ? )
scan-word {
diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor
index 0511721c18..81384a40c4 100755
--- a/core/sequences/sequences-tests.factor
+++ b/core/sequences/sequences-tests.factor
@@ -215,12 +215,6 @@ unit-test
3 V{ 1 2 3 4 5 6 } clone [ delete-nth ] keep
] unit-test
-[ V{ 1 2 3 } ]
-[ 3 V{ 1 2 } clone [ adjoin ] keep ] unit-test
-
-[ V{ 1 2 3 } ]
-[ 3 V{ 1 3 2 } clone [ adjoin ] keep ] unit-test
-
! erg's random tester found this one
[ SBUF" 12341234" ] [
9 <sbuf> dup "1234" swap push-all dup dup swap push-all
diff --git a/core/sets/sets-tests.factor b/core/sets/sets-tests.factor
index 86ee100da5..b6e6443afa 100644
--- a/core/sets/sets-tests.factor
+++ b/core/sets/sets-tests.factor
@@ -15,3 +15,9 @@ IN: sets.tests
[ V{ } ] [ { } { } union ] unit-test
[ V{ 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test
+
+[ V{ 1 2 3 } ]
+[ 3 V{ 1 2 } clone [ adjoin ] keep ] unit-test
+
+[ V{ 1 2 3 } ]
+[ 3 V{ 1 3 2 } clone [ adjoin ] keep ] unit-test
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 2410185b18..7ed79f77f1 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -101,7 +101,7 @@ IN: bootstrap.syntax
"DEFER:" [
scan in get create
- dup old-definitions get first delete-at
+ dup old-definitions get [ delete-at ] with each
set-word
] define-syntax
@@ -189,8 +189,9 @@ IN: bootstrap.syntax
"MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
"<<" [
- [ \ >> parse-until >quotation ] with-compilation-unit
- call
+ [
+ \ >> parse-until >quotation
+ ] with-nested-compilation-unit call
] define-syntax
"call-next-method" [
diff --git a/core/words/words.factor b/core/words/words.factor
index 5812516912..5549f98010 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -175,7 +175,9 @@ PRIVATE>
: define-symbol ( word -- )
dup [ ] curry define-inline ;
-: reset-word ( word -- )
+GENERIC: reset-word ( word -- )
+
+M: word reset-word
{
"unannotated-def"
"parsing" "inline" "foldable" "flushable"
From 8bff6eba523455165baf6c5c0a696dc0646b319e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@173.160.255.10.in-addr.arpa>
Date: Wed, 28 May 2008 19:43:01 -0500
Subject: [PATCH 50/66] Fix silly DEFER: error
---
core/parser/parser-tests.factor | 2 ++
core/parser/parser.factor | 2 +-
core/syntax/syntax.factor | 2 +-
3 files changed, 4 insertions(+), 2 deletions(-)
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index 37eb5f148e..df6c9dadc5 100755
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -485,3 +485,5 @@ must-fail-with
[ t ] [ "staging-problem-test-1" "parser.tests" lookup >boolean ] unit-test
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
+
+[ "DEFER: blah" eval ] [ error>> no-current-vocab? ] must-fail-with
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 3f46d1dd30..46e93753b5 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -236,7 +236,7 @@ PREDICATE: unexpected-eof < unexpected
ERROR: no-current-vocab ;
M: no-current-vocab summary ( obj -- )
- drop "Current vocabulary is f, use IN:" ;
+ drop "Not in a vocabulary; IN: form required" ;
: current-vocab ( -- str )
in get [ no-current-vocab ] unless* ;
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 7ed79f77f1..27c8609a99 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -100,7 +100,7 @@ IN: bootstrap.syntax
] define-syntax
"DEFER:" [
- scan in get create
+ scan current-vocab create
dup old-definitions get [ delete-at ] with each
set-word
] define-syntax
From 73b0e07277b5b6f3f1d3d78dfea280bee8cd0a8a Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 28 May 2008 21:44:02 -0500
Subject: [PATCH 51/66] combinators.lib: Add || variants
---
extra/combinators/lib/lib.factor | 13 +++++++++++++
1 file changed, 13 insertions(+)
diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor
index 4c4a988935..2c7f2bbb03 100755
--- a/extra/combinators/lib/lib.factor
+++ b/extra/combinators/lib/lib.factor
@@ -77,8 +77,21 @@ MACRO: <--&& ( quots -- )
[ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit
[ 2nip ] append ;
+! or
+
MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
+MACRO: 0|| ( quots -- ? ) [ [ t ] ] f short-circuit ;
+
+MACRO: 1|| ( quots -- ? )
+ [ [ dup ] prepend [ t ] ] f short-circuit [ nip ] append ;
+
+MACRO: 2|| ( quots -- ? )
+ [ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
+
+MACRO: 3|| ( quots -- ? )
+ [ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! ifte
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From ce4f8871bf5464495d400440d585bc85d713fd82 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 28 May 2008 23:08:54 -0500
Subject: [PATCH 52/66] dns: Add support for AAAA records
---
extra/dns/dns.factor | 13 ++++++++++++-
1 file changed, 12 insertions(+), 1 deletion(-)
diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor
index 560db69bb2..f10bdea0bf 100644
--- a/extra/dns/dns.factor
+++ b/extra/dns/dns.factor
@@ -38,7 +38,7 @@ TUPLE: message
! TYPE
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ;
+SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT AAAA ;
: type-table ( -- table )
{
@@ -58,6 +58,7 @@ SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT ;
{ MINFO 14 }
{ MX 15 }
{ TXT 16 }
+ { AAAA 28 }
} ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -126,6 +127,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
: ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ;
+: ipv6->ba ( ip -- ba ) ":" split [ 16 base> ] map [ 2 >be ] map concat ;
+
: label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -330,6 +333,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
: get-ip ( ba i -- ip ) dup 4 + subseq >array [ number>string ] map "." join ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-ipv6 ( ba i -- ip )
+ dup 16 + subseq 2 group [ be> 16 >base ] map ":" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: get-rdata ( ba i type -- rdata )
{
{ CNAME [ get-name ] }
@@ -338,6 +348,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
{ MX [ get-mx ] }
{ SOA [ get-soa ] }
{ A [ get-ip ] }
+ { AAAA [ get-ipv6 ] }
}
case ;
From e14a9ec0fb35bc16a51cba6de45de4dbb71377ad Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 28 May 2008 23:09:19 -0500
Subject: [PATCH 53/66] dns.cache: cache-get* word
---
extra/dns/cache/cache.factor | 11 ++++++++++-
1 file changed, 10 insertions(+), 1 deletion(-)
diff --git a/extra/dns/cache/cache.factor b/extra/dns/cache/cache.factor
index 75bbf9de9d..aeba35f29d 100644
--- a/extra/dns/cache/cache.factor
+++ b/extra/dns/cache/cache.factor
@@ -68,7 +68,7 @@ SYMBOL: NX
: expired? ( entry -- ? ) time>> time->ttl 0 <= ;
-: cache-get ( query -- result )
+: cache-get* ( query -- rrs/NX/f )
dup table-get ! query result
{
{ [ dup f = ] [ 2drop f ] } ! not in the cache
@@ -80,6 +80,15 @@ SYMBOL: NX
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ERROR: name-error name ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cache-get ( query -- rrs/f )
+ dup cache-get* dup NX = [ drop name>> name-error ] [ nip ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: rr->entry ( rr -- entry )
[ ttl>> ttl->time ] [ rdata>> {1} >vector ] bi entry boa ;
From 5a2ff64c3f0768829920aaae1eced721e54557d6 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Wed, 28 May 2008 23:12:01 -0500
Subject: [PATCH 54/66] Add dns.recursive for recursive queries
---
extra/dns/recursive/recursive.factor | 182 +++++++++++++++++++++++++++
1 file changed, 182 insertions(+)
create mode 100644 extra/dns/recursive/recursive.factor
diff --git a/extra/dns/recursive/recursive.factor b/extra/dns/recursive/recursive.factor
new file mode 100644
index 0000000000..6fe8ec96da
--- /dev/null
+++ b/extra/dns/recursive/recursive.factor
@@ -0,0 +1,182 @@
+
+USING: kernel continuations
+ combinators
+ sequences
+ random
+ unicode.case
+ accessors symbols
+ combinators.lib combinators.cleave
+ newfx
+ dns dns.cache ;
+
+IN: dns.recursive
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: root-dns-servers ( -- servers )
+ {
+ "192.5.5.241"
+ "192.112.36.4"
+ "128.63.2.53"
+ "192.36.148.17"
+ "192.58.128.30"
+ "193.0.14.129"
+ "199.7.83.42"
+ "202.12.27.33"
+ "198.41.0.4"
+ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cache-message ( message -- message )
+ dup dup rcode>> NAME-ERROR =
+ [
+ [ question-section>> 1st ]
+ [ authority-section>> [ type>> SOA = ] filter random ttl>> ]
+ bi
+ cache-nx
+ ]
+ [
+ {
+ [ answer-section>> cache-add-rrs ]
+ [ authority-section>> cache-add-rrs ]
+ [ additional-section>> cache-add-rrs ]
+ }
+ cleave
+ ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: query->message ( query -- message ) <query-message> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {name-type-class} ( obj -- seq )
+ [ name>> >lower ] [ type>> ] [ class>> ] tri {3} ;
+
+: rr=query? ( rr query -- ? ) [ {name-type-class} ] bi@ = ;
+
+: rr-filter ( rrs query -- rrs ) [ rr=query? ] curry filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: message-query ( message -- query ) question-section>> 1st ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: answer-hits ( message -- rrs )
+ [ answer-section>> ] [ message-query ] bi rr-filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name-hits ( message -- rrs )
+ [ answer-section>> ] [ message-query clone A >>type ] bi rr-filter ;
+
+: cname-hits ( message -- rrs )
+ [ answer-section>> ] [ message-query clone CNAME >>type ] bi rr-filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: authority-hits ( message -- rrs )
+ authority-section>> [ type>> NS = ] filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOLS: ANSWERED NO-NAME-SERVERS UNCLASSIFIED ;
+
+: classify-message ( message -- symbol )
+ {
+ { [ dup rcode>> NAME-ERROR = ] [ drop NAME-ERROR ] }
+ { [ dup rcode>> SERVER-FAILURE = ] [ drop SERVER-FAILURE ] }
+ { [ dup answer-hits empty? not ] [ drop ANSWERED ] }
+ { [ dup cname-hits empty? not ] [ drop CNAME ] }
+ { [ dup authority-hits empty? ] [ drop NO-NAME-SERVERS ] }
+ { [ t ] [ drop UNCLASSIFIED ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: name->ip
+
+! : name->ip/f ( name -- ip/f ) [ name->ip ] [ drop f ] recover ;
+
+! : extract-ns-ips ( message -- ips )
+! authority-hits [ rdata>> name->ip/f ] map [ ] filter ;
+
+: extract-ns-ips ( message -- ips )
+ authority-hits [ rdata>> name->ip ] map [ ] filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: recursive-query ( query servers -- message )
+ dup random ! query servers server
+ pick query->message 0 >>rd ! query servers server message
+ over ask-server ! query servers server message
+ cache-message ! query servers server message
+ dup classify-message ! query servers server message sym
+ {
+ { NAME-ERROR [ -roll 3drop ] }
+ { ANSWERED [ -roll 3drop ] }
+ { CNAME [ -roll 3drop ] }
+ { NO-NAME-SERVERS [ -roll 3drop ] }
+ {
+ SERVER-FAILURE
+ [
+ -roll ! message query servers server
+ remove ! message query servers
+ dup empty?
+ [ 2drop ]
+ [ rot drop recursive-query ]
+ if
+ ]
+ }
+ [ ! query servers server message sym
+ drop nip nip ! query message
+ extract-ns-ips ! query ips
+ recursive-query
+ ]
+ }
+ case ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: canonical/cache ( name -- name )
+ dup CNAME IN query boa cache-get dup [ nip 1st rdata>> ] [ drop ] if ;
+
+: name->ip/cache ( name -- ip/f )
+ canonical/cache
+ A IN query boa cache-get dup [ random rdata>> ] [ ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name-hits? ( message -- message ? ) dup name-hits empty? not ;
+: cname-hits? ( message -- message ? ) dup cname-hits empty? not ;
+
+: name->ip/server ( name -- ip-or-f )
+ A IN query boa root-dns-servers recursive-query ! message
+ {
+ { [ name-hits? ] [ name-hits random rdata>> ] }
+ { [ cname-hits? ] [ cname-hits random rdata>> name->ip ] }
+ { [ t ] [ drop f ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : name->ip ( name -- ip )
+! { [ name->ip/cache ] [ name->ip/server ] [ name-error ] } 1|| ;
+
+: name->ip ( name -- ip )
+ dup name->ip/cache dup
+ [ nip ]
+ [
+ drop dup name->ip/server dup
+ [ nip ]
+ [ drop name-error ]
+ if
+ ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From cf587c054dd35e9ce41480cf39c7567745be0df4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 29 May 2008 02:40:32 -0500
Subject: [PATCH 55/66] Tweak font rendering to avoid roundoff error
---
extra/opengl/opengl.factor | 4 +-
extra/ui/freetype/freetype.factor | 126 +++++++++++++++++-------------
2 files changed, 74 insertions(+), 56 deletions(-)
diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor
index a6e76cdc9e..79470131f3 100755
--- a/extra/opengl/opengl.factor
+++ b/extra/opengl/opengl.factor
@@ -203,9 +203,7 @@ TUPLE: sprite loc dim dim2 dlist texture ;
dup sprite-loc gl-translate
GL_TEXTURE_2D over sprite-texture glBindTexture
init-texture
- GL_QUADS [ dup sprite-dim2 four-sides ] do-state
- dup sprite-dim { 1 0 } v*
- swap sprite-loc v- gl-translate
+ GL_QUADS [ sprite-dim2 four-sides ] do-state
GL_TEXTURE_2D 0 glBindTexture ;
: rect-vertices ( lower-left upper-right -- )
diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor
index 1c83bc9713..be4f2ba8ae 100755
--- a/extra/ui/freetype/freetype.factor
+++ b/extra/ui/freetype/freetype.factor
@@ -3,7 +3,8 @@
USING: alien alien.accessors alien.c-types arrays io kernel libc
math math.vectors namespaces opengl opengl.gl prettyprint assocs
sequences io.files io.styles continuations freetype
-ui.gadgets.worlds ui.render ui.backend byte-arrays ;
+ui.gadgets.worlds ui.render ui.backend byte-arrays accessors
+locals ;
IN: ui.freetype
@@ -41,8 +42,8 @@ M: font hashcode* drop font hashcode* ;
] bind ;
M: freetype-renderer free-fonts ( world -- )
- dup world-handle select-gl-context
- world-fonts [ nip second free-sprites ] assoc-each ;
+ [ handle>> select-gl-context ]
+ [ fonts>> [ nip second free-sprites ] assoc-each ] bi ;
: ttf-name ( font style -- name )
2array H{
@@ -67,7 +68,7 @@ M: freetype-renderer free-fonts ( world -- )
#! We use FT_New_Memory_Face, not FT_New_Face, since
#! FT_New_Face only takes an ASCII path name and causes
#! problems on localized versions of Windows
- freetype -rot 0 f <void*> [
+ [ freetype ] 2dip 0 f <void*> [
FT_New_Memory_Face freetype-error
] keep *void* ;
@@ -85,29 +86,29 @@ SYMBOL: dpi
: font-units>pixels ( n font -- n )
face-size face-size-y-scale FT_MulFix ;
-: init-ascent ( font face -- )
- dup face-y-max swap font-units>pixels swap set-font-ascent ;
+: init-ascent ( font face -- font )
+ dup face-y-max swap font-units>pixels >>ascent ; inline
-: init-descent ( font face -- )
- dup face-y-min swap font-units>pixels swap set-font-descent ;
+: init-descent ( font face -- font )
+ dup face-y-min swap font-units>pixels >>descent ; inline
-: init-font ( font -- )
- dup font-handle 2dup init-ascent dupd init-descent
- dup font-ascent over font-descent - ft-ceil
- swap set-font-height ;
+: init-font ( font -- font )
+ dup handle>> init-ascent
+ dup handle>> init-descent
+ dup [ ascent>> ] [ descent>> ] bi - ft-ceil >>height ; inline
+
+: set-char-size ( handle size -- )
+ 0 swap 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ;
: <font> ( handle -- font )
- H{ } clone
- { set-font-handle set-font-widths } font construct
- dup init-font ;
-
-: (open-font) ( font -- open-font )
- first3 >r open-face dup 0 r> 6 shift
- dpi get-global dpi get-global FT_Set_Char_Size
- freetype-error <font> ;
+ font new
+ H{ } clone >>widths
+ over first2 open-face >>handle
+ dup handle>> rot third set-char-size
+ init-font ;
M: freetype-renderer open-font ( font -- open-font )
- freetype drop open-fonts get [ (open-font) ] cache ;
+ freetype drop open-fonts get [ <font> ] cache ;
: load-glyph ( font char -- glyph )
>r font-handle dup r> 0 FT_Load_Char
@@ -132,30 +133,36 @@ M: freetype-renderer string-height ( open-font string -- h )
load-glyph dup
FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
-: copy-pixel ( bit tex -- bit tex )
- 255 f pick set-alien-unsigned-1 1+
- f pick alien-unsigned-1
- f pick set-alien-unsigned-1 >r 1+ r> 1+ ;
+:: copy-pixel ( i j bitmap texture -- i j )
+ 255 tex j set-alien-unsigned-1
+ i bitmap alien-unsigned-1 j 1 + texture set-alien-unsigned-1
+ i 1 + j 2 + ; inline
-: (copy-row) ( bit tex bitend texend -- bitend texend )
- >r pick over >= [
- 2nip r>
- ] [
- >r copy-pixel r> r> (copy-row)
- ] if ;
+: (copy-row) ( i j bitmap texture end -- )
+ i end < [
+ i j bitmap texture copy-pixel
+ i j bitmap texture end (copy-row)
+ ] when ; inline
-: copy-row ( bit tex width width2 -- bitend texend width width2 )
- [ pick + >r pick + r> (copy-row) ] 2keep ;
+: copy-row ( i j bitmap texture width width2 -- i j )
+ i j bitmap texture i width + (copy-row)
+ i width +
+ j width2 + ; inline
-: copy-bitmap ( glyph texture -- )
- over glyph-bitmap-rows >r
- over glyph-bitmap-width dup next-power-of-2 2 *
- >r >r >r glyph-bitmap-buffer alien-address r> r> r> r>
- [ copy-row ] times 2drop 2drop ;
+:: copy-bitmap ( glyph texture -- )
+ [let* | texture [ texture alien-address ]
+ bitmap [ glyph glyph-bitmap-buffer alien-address ]
+ rows [ glyph glyph-bitmap-rows ]
+ width [ glyph glyph-bitmap-width ]
+ width2 [ width next-power-of-2 2 * ] |
+ 0 0
+ rows [ bitmap texture width width2 copy-row ] times
+ 2drop
+ ] ;
: bitmap>texture ( glyph sprite -- id )
tuck sprite-size2 * 2 * [
- alien-address [ copy-bitmap ] keep <alien> gray-texture
+ [ copy-bitmap ] keep gray-texture
] with-malloc ;
: glyph-texture-loc ( glyph font -- loc )
@@ -163,34 +170,47 @@ M: freetype-renderer string-height ( open-font string -- h )
font-ascent swap glyph-hori-bearing-y - ft-floor 2array ;
: glyph-texture-size ( glyph -- dim )
- dup glyph-bitmap-width next-power-of-2
- swap glyph-bitmap-rows next-power-of-2 2array ;
+ [ glyph-bitmap-width next-power-of-2 ]
+ [ glyph-bitmap-rows next-power-of-2 ]
+ bi 2array ;
-: <char-sprite> ( font char -- sprite )
+: <char-sprite> ( open-font char -- sprite )
over >r render-glyph dup r> glyph-texture-loc
over glyph-size pick glyph-texture-size <sprite>
[ bitmap>texture ] keep [ init-sprite ] keep ;
-: draw-char ( open-font char sprites -- )
- [ dupd <char-sprite> ] cache nip
- sprite-dlist glCallList ;
+:: char-sprite ( open-font sprites char -- sprite )
+ char sprites [ open-font swap <char-sprite> ] cache ;
-: (draw-string) ( open-font sprites string loc -- )
+: draw-char ( open-font sprites char loc -- )
+ GL_MODELVIEW [
+ 0 0 glTranslated
+ char-sprite sprite-dlist glCallList
+ ] do-matrix ;
+
+: char-widths ( open-font string -- widths )
+ [ char-width ] with { } map-as ;
+
+: scan-sums ( seq -- seq' )
+ 0 [ + ] accumulate nip ;
+
+:: (draw-string) ( open-font sprites string loc -- )
GL_TEXTURE_2D [
- [
- [ >r 2dup r> swap draw-char ] each 2drop
+ loc [
+ string open-font string char-widths scan-sums [
+ [ open-font sprites ] 2dip draw-char
+ ] 2each
] with-translation
] do-enabled ;
-: font-sprites ( open-font world -- pair )
- world-fonts [ open-font H{ } clone 2array ] cache ;
+: font-sprites ( font world -- open-font sprites )
+ world-fonts [ open-font H{ } clone 2array ] cache first2 ;
M: freetype-renderer draw-string ( font string loc -- )
- >r >r world get font-sprites first2 r> r> (draw-string) ;
+ >r >r world get font-sprites r> r> (draw-string) ;
: run-char-widths ( open-font string -- widths )
- [ char-width ] with { } map-as
- dup 0 [ + ] accumulate nip swap 2 v/n v+ ;
+ char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
M: freetype-renderer x>offset ( x open-font string -- n )
dup >r run-char-widths [ <= ] with find drop
From d57c66690da5a85fc9a8b74235906b460f68622c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 29 May 2008 02:47:30 -0500
Subject: [PATCH 56/66] Fix errors reported by builder
---
core/sets/sets-docs.factor | 2 +-
extra/html/components/components-tests.factor | 2 +-
extra/tangle/html/html-tests.factor | 2 +-
extra/trees/splay/splay-tests.factor | 2 +-
4 files changed, 4 insertions(+), 4 deletions(-)
diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor
index 97fbc973f0..205d4d34bf 100644
--- a/core/sets/sets-docs.factor
+++ b/core/sets/sets-docs.factor
@@ -28,7 +28,7 @@ HELP: adjoin
{ $description "Removes all elements equal to " { $snippet "elt" } ", and adds " { $snippet "elt" } " at the end of the sequence." }
{ $examples
{ $example
- "USING: namespaces prettyprint sequences ;"
+ "USING: namespaces prettyprint sets ;"
"V{ \"beans\" \"salsa\" \"cheese\" } \"v\" set"
"\"nachos\" \"v\" get adjoin"
"\"salsa\" \"v\" get adjoin"
diff --git a/extra/html/components/components-tests.factor b/extra/html/components/components-tests.factor
index f2b0049a8e..1a0f849a8f 100644
--- a/extra/html/components/components-tests.factor
+++ b/extra/html/components/components-tests.factor
@@ -1,7 +1,7 @@
IN: html.components.tests
USING: tools.test kernel io.streams.string
io.streams.null accessors inspector html.streams
-html.components ;
+html.components namespaces ;
[ ] [ blank-values ] unit-test
diff --git a/extra/tangle/html/html-tests.factor b/extra/tangle/html/html-tests.factor
index 8e7d8c24e1..88ad748400 100644
--- a/extra/tangle/html/html-tests.factor
+++ b/extra/tangle/html/html-tests.factor
@@ -1,4 +1,4 @@
-USING: html kernel semantic-db tangle.html tools.test ;
+USING: kernel semantic-db tangle.html tools.test ;
IN: tangle.html.tests
[ "test" ] [ "test" >html ] unit-test
diff --git a/extra/trees/splay/splay-tests.factor b/extra/trees/splay/splay-tests.factor
index 29bc153030..e54e3cd538 100644
--- a/extra/trees/splay/splay-tests.factor
+++ b/extra/trees/splay/splay-tests.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2005 Mackenzie Straight.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test trees.splay math namespaces assocs
-sequences random ;
+sequences random sets ;
IN: trees.splay.tests
: randomize-numeric-splay-tree ( splay-tree -- )
From 41c845cf738aef558821b7d4d4b94cd973d86da0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 29 May 2008 02:51:16 -0500
Subject: [PATCH 57/66] Encoding issue?
---
extra/unicode/collation/collation-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/unicode/collation/collation-tests.factor b/extra/unicode/collation/collation-tests.factor
index c9d6cb808f..b4a54bb11d 100755
--- a/extra/unicode/collation/collation-tests.factor
+++ b/extra/unicode/collation/collation-tests.factor
@@ -20,7 +20,7 @@ IN: unicode.collation.tests
[ execute ] 2with each ;
[ f f f f ] [ "hello" "hi" test-equality ] unit-test
-[ t f f f ] [ "hello" "h�llo" test-equality ] unit-test
+[ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test
[ t t f f ] [ "hello" "HELLO" test-equality ] unit-test
[ t t t f ] [ "hello" "h e l l o." test-equality ] unit-test
[ t t t t ] [ "hello" "\0hello\0" test-equality ] unit-test
From 21fcc8a542a6a5574866684ab354fff7f32c0539 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 29 May 2008 03:17:36 -0500
Subject: [PATCH 58/66] Oops
---
extra/ui/freetype/freetype.factor | 13 ++++++-------
1 file changed, 6 insertions(+), 7 deletions(-)
diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor
index be4f2ba8ae..3512bbf670 100755
--- a/extra/ui/freetype/freetype.factor
+++ b/extra/ui/freetype/freetype.factor
@@ -134,24 +134,23 @@ M: freetype-renderer string-height ( open-font string -- h )
FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
:: copy-pixel ( i j bitmap texture -- i j )
- 255 tex j set-alien-unsigned-1
- i bitmap alien-unsigned-1 j 1 + texture set-alien-unsigned-1
+ 255 j texture set-char-nth
+ i bitmap char-nth j 1 + texture set-char-nth
i 1 + j 2 + ; inline
-: (copy-row) ( i j bitmap texture end -- )
+:: (copy-row) ( i j bitmap texture end -- )
i end < [
i j bitmap texture copy-pixel
- i j bitmap texture end (copy-row)
+ bitmap texture end (copy-row)
] when ; inline
-: copy-row ( i j bitmap texture width width2 -- i j )
+:: copy-row ( i j bitmap texture width width2 -- i j )
i j bitmap texture i width + (copy-row)
i width +
j width2 + ; inline
:: copy-bitmap ( glyph texture -- )
- [let* | texture [ texture alien-address ]
- bitmap [ glyph glyph-bitmap-buffer alien-address ]
+ [let* | bitmap [ glyph glyph-bitmap-buffer ]
rows [ glyph glyph-bitmap-rows ]
width [ glyph glyph-bitmap-width ]
width2 [ width next-power-of-2 2 * ] |
From 05c3c82e3c0bce204686a30c8c68a0e6dafe5f65 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 29 May 2008 05:17:13 -0500
Subject: [PATCH 59/66] newfx: index
---
extra/newfx/newfx.factor | 5 +++++
1 file changed, 5 insertions(+)
diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor
index abe0449d06..e017dc4b2b 100644
--- a/extra/newfx/newfx.factor
+++ b/extra/newfx/newfx.factor
@@ -170,6 +170,11 @@ METHOD: as-mutate { object object assoc } set-at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: index ( seq obj -- i ) swap sequences:index ;
+: index-of ( obj seq -- i ) sequences:index ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: 1st 0 at ;
: 2nd 1 at ;
: 3rd 2 at ;
From 188fab8f003cac11a5d0df17469e688ba2907552 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 29 May 2008 05:17:30 -0500
Subject: [PATCH 60/66] dns: move some words to dns
---
extra/dns/cache/cache.factor | 28 ++++++++++++++++++++++++++++
extra/dns/dns.factor | 7 ++++++-
2 files changed, 34 insertions(+), 1 deletion(-)
diff --git a/extra/dns/cache/cache.factor b/extra/dns/cache/cache.factor
index aeba35f29d..4167c7b16e 100644
--- a/extra/dns/cache/cache.factor
+++ b/extra/dns/cache/cache.factor
@@ -119,3 +119,31 @@ ERROR: name-error name ;
: cache-add-rr ( rr -- ) [ rr->query ] [ ] bi cache-add ;
: cache-add-rrs ( rrs -- ) [ cache-add-rr ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! cache-name-error
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: message-soa ( message -- rr/soa )
+ authority-section>> [ type>> SOA = ] filter 1st ;
+
+: cache-name-error ( message -- message )
+ dup
+ [ message-query ] [ message-soa ttl>> ] bi
+ cache-nx ;
+
+: cache-message-records ( message -- message )
+ dup
+ {
+ [ answer-section>> cache-add-rrs ]
+ [ authority-section>> cache-add-rrs ]
+ [ additional-section>> cache-add-rrs ]
+ }
+ cleave ;
+
+: cache-message ( message -- message )
+ dup rcode>> NAME-ERROR = [ cache-name-error ] when
+ cache-message-records ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor
index f10bdea0bf..9404ccdad1 100644
--- a/extra/dns/dns.factor
+++ b/extra/dns/dns.factor
@@ -470,4 +470,9 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
: ask ( message -- message ) dns-server ask-server ;
-: <query-message> ( query -- message ) <message> swap {1} >>question-section ;
\ No newline at end of file
+: query->message ( query -- message ) <message> swap {1} >>question-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: message-query ( message -- query ) question-section>> 1st ;
+
From a109d10b3df78961f596f9f1c68b199ffda473e0 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 29 May 2008 05:17:55 -0500
Subject: [PATCH 61/66] dns.recursive: Try out an optimized name->ip/server
---
extra/dns/recursive/recursive.factor | 67 +++++++++++++++-------------
1 file changed, 35 insertions(+), 32 deletions(-)
diff --git a/extra/dns/recursive/recursive.factor b/extra/dns/recursive/recursive.factor
index 6fe8ec96da..3a74667845 100644
--- a/extra/dns/recursive/recursive.factor
+++ b/extra/dns/recursive/recursive.factor
@@ -2,6 +2,7 @@
USING: kernel continuations
combinators
sequences
+ math
random
unicode.case
accessors symbols
@@ -28,30 +29,6 @@ IN: dns.recursive
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: cache-message ( message -- message )
- dup dup rcode>> NAME-ERROR =
- [
- [ question-section>> 1st ]
- [ authority-section>> [ type>> SOA = ] filter random ttl>> ]
- bi
- cache-nx
- ]
- [
- {
- [ answer-section>> cache-add-rrs ]
- [ authority-section>> cache-add-rrs ]
- [ additional-section>> cache-add-rrs ]
- }
- cleave
- ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: query->message ( query -- message ) <query-message> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: {name-type-class} ( obj -- seq )
[ name>> >lower ] [ type>> ] [ class>> ] tri {3} ;
@@ -61,10 +38,6 @@ IN: dns.recursive
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: message-query ( message -- query ) question-section>> 1st ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: answer-hits ( message -- rrs )
[ answer-section>> ] [ message-query ] bi rr-filter ;
@@ -110,7 +83,7 @@ DEFER: name->ip
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: recursive-query ( query servers -- message )
+: (recursive-query) ( query servers -- message )
dup random ! query servers server
pick query->message 0 >>rd ! query servers server message
over ask-server ! query servers server message
@@ -128,20 +101,39 @@ DEFER: name->ip
remove ! message query servers
dup empty?
[ 2drop ]
- [ rot drop recursive-query ]
+ [ rot drop (recursive-query) ]
if
]
}
[ ! query servers server message sym
drop nip nip ! query message
extract-ns-ips ! query ips
- recursive-query
+ (recursive-query)
]
}
case ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: cdr-name ( name -- name ) dup CHAR: . index 1+ tail ;
+
+: cache-get-ns ( name -- seq/f ) NS IN query boa cache-get ;
+
+: name->servers ( name -- servers )
+ {
+ { [ dup "" = ] [ drop root-dns-servers ] }
+ { [ dup cache-get-ns ] [ cache-get-ns [ rdata>> name->ip ] map ] }
+ { [ t ] [ cdr-name name->servers ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: recursive-query ( query -- message )
+ dup name>> name->servers (recursive-query) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: canonical/cache ( name -- name )
dup CNAME IN query boa cache-get dup [ nip 1st rdata>> ] [ drop ] if ;
@@ -154,8 +146,19 @@ DEFER: name->ip
: name-hits? ( message -- message ? ) dup name-hits empty? not ;
: cname-hits? ( message -- message ? ) dup cname-hits empty? not ;
+! : name->ip/server ( name -- ip-or-f )
+! A IN query boa root-dns-servers recursive-query ! message
+! {
+! { [ name-hits? ] [ name-hits random rdata>> ] }
+! { [ cname-hits? ] [ cname-hits random rdata>> name->ip ] }
+! { [ t ] [ drop f ] }
+! }
+! cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: name->ip/server ( name -- ip-or-f )
- A IN query boa root-dns-servers recursive-query ! message
+ A IN query boa recursive-query ! message
{
{ [ name-hits? ] [ name-hits random rdata>> ] }
{ [ cname-hits? ] [ cname-hits random rdata>> name->ip ] }
From 3bd5144f2030284c9e38e7f373880d765519d2f8 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 29 May 2008 10:11:12 -0500
Subject: [PATCH 62/66] dns.resolver: minor fix
---
extra/dns/resolver/resolver.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/dns/resolver/resolver.factor b/extra/dns/resolver/resolver.factor
index c8a9f22d08..7e0f6b4190 100644
--- a/extra/dns/resolver/resolver.factor
+++ b/extra/dns/resolver/resolver.factor
@@ -62,7 +62,7 @@ IN: dns.resolver
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: canonical/server ( name -- name )
- dup CNAME IN query boa <query-message> ask* answer-section>>
+ dup CNAME IN query boa query->message ask* answer-section>>
[ type>> CNAME = ] filter dup empty? not
[ nip 1st rdata>> ]
[ drop ]
From a8cdb2226d7b78e12e02336f619fcef2f26440b3 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 29 May 2008 10:11:54 -0500
Subject: [PATCH 63/66] dns.resolver: another fix
---
extra/dns/resolver/resolver.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/dns/resolver/resolver.factor b/extra/dns/resolver/resolver.factor
index 7e0f6b4190..38fe59dc41 100644
--- a/extra/dns/resolver/resolver.factor
+++ b/extra/dns/resolver/resolver.factor
@@ -70,7 +70,7 @@ IN: dns.resolver
: name->ip/server ( name -- ip )
canonical/server
- dup A IN query boa <query-message> ask* answer-section>>
+ dup A IN query boa query->message ask* answer-section>>
[ type>> A = ] filter dup empty? not
[ nip random rdata>> ]
[ 2drop f ]
From 5e9b59160845320c60f21e54d80e713fc5be30e0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 29 May 2008 17:32:59 -0500
Subject: [PATCH 64/66] Fix file-responder breakage
---
extra/http/server/static/static.factor | 18 ++++++++----------
1 file changed, 8 insertions(+), 10 deletions(-)
diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor
index 0e799fd3ad..8814004589 100755
--- a/extra/http/server/static/static.factor
+++ b/extra/http/server/static/static.factor
@@ -4,7 +4,7 @@ USING: calendar io io.files kernel math math.order
math.parser http http.server namespaces parser sequences strings
assocs hashtables debugger http.mime sorting html.elements
html.templates.fhtml logging calendar.format accessors
-io.encodings.binary fry xml.entities ;
+io.encodings.binary fry xml.entities destructors ;
IN: http.server.static
! special maps mime types to quots with effect ( path -- )
@@ -29,16 +29,14 @@ TUPLE: file-responder root hook special allow-listings ;
swap >>root
H{ } clone >>special ;
+: (serve-static) ( path mime-type -- response )
+ [ [ binary <file-reader> &dispose ] dip <content> ]
+ [ drop file-info [ size>> ] [ modified>> ] bi ] 2bi
+ [ "content-length" set-header ]
+ [ "last-modified" set-header ] bi* ;
+
: <static> ( root -- responder )
- [
- <content>
- swap [
- file-info
- [ size>> "content-length" set-header ]
- [ modified>> "last-modified" set-header ] bi
- ]
- [ '[ , binary <file-reader> output-stream get stream-copy ] >>body ] bi
- ] <file-responder> ;
+ [ (serve-static) ] <file-responder> ;
: serve-static ( filename mime-type -- response )
over modified-since?
From c525d0057d78cc3d23d146648e9293649790f851 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 29 May 2008 17:33:05 -0500
Subject: [PATCH 65/66] Help lint fix
---
extra/ui/freetype/freetype-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/ui/freetype/freetype-docs.factor b/extra/ui/freetype/freetype-docs.factor
index f463a7c0e7..855df9f564 100755
--- a/extra/ui/freetype/freetype-docs.factor
+++ b/extra/ui/freetype/freetype-docs.factor
@@ -38,7 +38,7 @@ HELP: render-glyph
{ $description "Renders a character and outputs a pointer to the bitmap." } ;
HELP: <char-sprite>
-{ $values { "font" font } { "char" "a non-negative integer" } { "sprite" sprite } }
+{ $values { "open-font" font } { "char" "a non-negative integer" } { "sprite" sprite } }
{ $description "Renders a character to an OpenGL texture and records a display list which draws a quad with this texture. This word allocates native resources which must be freed by " { $link free-sprites } "." } ;
HELP: (draw-string)
From 4ef0ff1ca15a5b7db3807b3725bc09c247d457c6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 29 May 2008 17:33:11 -0500
Subject: [PATCH 66/66] Remove unnecessary padding
---
vm/code_gc.h | 3 ---
1 file changed, 3 deletions(-)
diff --git a/vm/code_gc.h b/vm/code_gc.h
index 658dc990ae..ecc9f697f5 100644
--- a/vm/code_gc.h
+++ b/vm/code_gc.h
@@ -17,9 +17,6 @@ typedef struct _F_BLOCK
/* Used during compaction */
struct _F_BLOCK *forwarding;
-
- /* Alignment padding */
- CELL padding[4];
} F_BLOCK;
typedef struct {