Merge branch 'master' of git://factorcode.org/git/factor
Bruno Deferrari
commit
35bb362668
|
|
@ -0,0 +1 @@
|
|||
One-time and recurring events
|
||||
|
|
@ -0,0 +1 @@
|
|||
Defining multiple words with the same name
|
||||
|
|
@ -0,0 +1 @@
|
|||
Fast searching of sorted arrays
|
||||
|
|
@ -0,0 +1 @@
|
|||
An abstraction for enforcing a mutual-exclusion invariant
|
||||
|
|
@ -43,7 +43,7 @@ HELP: push-growing-circular
|
|||
{ "elt" object } { "circular" circular } }
|
||||
{ $description "Pushes an element onto a " { $link growing-circular } " object." } ;
|
||||
|
||||
ARTICLE: "circular" "circular"
|
||||
ARTICLE: "circular" "Circular sequences"
|
||||
"The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl
|
||||
"Creating a new circular object:"
|
||||
{ $subsection <circular> }
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Colors as a first-class data type
|
||||
|
|
@ -64,7 +64,7 @@ HELP: n||-rewrite
|
|||
{ "quot" quotation } }
|
||||
{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each OR quotation." } ;
|
||||
|
||||
ARTICLE: "combinators.short-circuit" "combinators.short-circuit"
|
||||
ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
|
||||
"The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl
|
||||
"AND combinators:"
|
||||
{ $subsection 0&& }
|
||||
|
|
|
|||
|
|
@ -27,8 +27,9 @@ HELP: ||
|
|||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "combinators.short-circuit.smart" "combinators.short-circuit.smart"
|
||||
"The " { $vocab-link "combinators.short-circuit.smart" } " vocabulary infers the number of inputs that the sequence of quotations takes." $nl
|
||||
ARTICLE: "combinators.short-circuit.smart" "Smart short-circuit combinators"
|
||||
"The " { $vocab-link "combinators.short-circuit.smart" } " vocabulary is similar to " { $vocab-link "combinators.short-circuit" } " except the combinators here infer the number of inputs that the sequence of quotations takes."
|
||||
$nl
|
||||
"Generalized AND:"
|
||||
{ $subsection && }
|
||||
"Generalized OR:"
|
||||
|
|
|
|||
|
|
@ -168,7 +168,7 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
|
|||
number>string " limit " swap 3append
|
||||
] curry change-sql drop ;
|
||||
|
||||
: make-query ( tuple query -- tuple' )
|
||||
: make-query* ( tuple query -- tuple' )
|
||||
dupd
|
||||
{
|
||||
[ group>> [ drop ] [ do-group ] if-empty ]
|
||||
|
|
@ -177,8 +177,8 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
|
|||
[ offset>> [ do-offset ] [ drop ] if* ]
|
||||
} 2cleave ;
|
||||
|
||||
M: db <query> ( tuple class query -- tuple )
|
||||
[ <select-by-slots-statement> ] dip make-query ;
|
||||
M: db make-query ( tuple class query -- tuple )
|
||||
[ <select-by-slots-statement> ] dip make-query* ;
|
||||
|
||||
! select ID, NAME, SCORE from EXAM limit 1 offset 3
|
||||
|
||||
|
|
@ -198,7 +198,7 @@ M: db <count-statement> ( tuple class groups -- statement )
|
|||
\ query new
|
||||
swap >>group
|
||||
[ [ "select count(*) from " 0% 0% where-clause ] query-make ]
|
||||
dip make-query ;
|
||||
dip make-query* ;
|
||||
|
||||
: create-index ( index-name table-name columns -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -236,6 +236,17 @@ TUPLE: exam id name score ;
|
|||
exam boa ;
|
||||
|
||||
: test-intervals ( -- )
|
||||
[
|
||||
exam "EXAM"
|
||||
{
|
||||
{ "idd" "ID" +db-assigned-id+ }
|
||||
{ "named" "NAME" TEXT }
|
||||
{ "score" "SCORE" INTEGER }
|
||||
} define-persistent
|
||||
] [
|
||||
seq>> { "idd" "named" } =
|
||||
] must-fail-with
|
||||
|
||||
exam "EXAM"
|
||||
{
|
||||
{ "id" "ID" +db-assigned-id+ }
|
||||
|
|
@ -499,3 +510,17 @@ string-encoding-test "STRING_ENCODING_TEST" {
|
|||
\ ensure-table must-infer
|
||||
\ create-table must-infer
|
||||
\ drop-table must-infer
|
||||
|
||||
: test-queries ( -- )
|
||||
[ ] [ exam ensure-table ] unit-test
|
||||
! [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test
|
||||
! [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test
|
||||
! [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
|
||||
! [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
|
||||
[ ] [ 10 [ random-exam insert-tuple ] times ] unit-test
|
||||
! [ ] [ T{ exam { name "Kenny" } } >query ] unit-test
|
||||
! [ ] [ query ] unit-test
|
||||
;
|
||||
|
||||
: test-db ( -- )
|
||||
"tuples-test.db" temp-file sqlite-db make-db db-open db set ;
|
||||
|
|
|
|||
|
|
@ -3,11 +3,44 @@
|
|||
USING: arrays assocs classes db kernel namespaces
|
||||
classes.tuple words sequences slots math accessors
|
||||
math.parser io prettyprint db.types continuations
|
||||
destructors mirrors ;
|
||||
destructors mirrors sets ;
|
||||
IN: db.tuples
|
||||
|
||||
TUPLE: query tuple group order offset limit ;
|
||||
|
||||
: <query> ( -- query ) \ query new ;
|
||||
|
||||
GENERIC: >query ( object -- query )
|
||||
|
||||
M: query >query ;
|
||||
|
||||
M: tuple >query <query> swap >>tuple ;
|
||||
|
||||
! returns a sequence of prepared-statements
|
||||
HOOK: create-sql-statement db ( class -- object )
|
||||
HOOK: drop-sql-statement db ( class -- object )
|
||||
|
||||
HOOK: <insert-db-assigned-statement> db ( class -- object )
|
||||
HOOK: <insert-user-assigned-statement> db ( class -- object )
|
||||
HOOK: <update-tuple-statement> db ( class -- object )
|
||||
HOOK: <delete-tuples-statement> db ( tuple class -- object )
|
||||
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
|
||||
HOOK: <count-statement> db ( tuple class groups -- statement )
|
||||
HOOK: make-query db ( tuple class query -- statement )
|
||||
|
||||
HOOK: insert-tuple* db ( tuple statement -- )
|
||||
|
||||
ERROR: no-slots-named class seq ;
|
||||
: check-columns ( class columns -- )
|
||||
tuck
|
||||
[ [ first ] map ]
|
||||
[ all-slots [ name>> ] map ] bi* diff
|
||||
[ drop ] [ no-slots-named ] if-empty ;
|
||||
|
||||
: define-persistent ( class table columns -- )
|
||||
>r dupd "db-table" set-word-prop dup r>
|
||||
pick dupd
|
||||
check-columns
|
||||
[ dupd "db-table" set-word-prop dup ] dip
|
||||
[ relation? ] partition swapd
|
||||
dupd [ spec>tuple ] with map
|
||||
"db-columns" set-word-prop
|
||||
|
|
@ -33,21 +66,6 @@ SYMBOL: sql-counter
|
|||
: next-sql-counter ( -- str )
|
||||
sql-counter [ inc ] [ get ] bi number>string ;
|
||||
|
||||
! returns a sequence of prepared-statements
|
||||
HOOK: create-sql-statement db ( class -- object )
|
||||
HOOK: drop-sql-statement db ( class -- object )
|
||||
|
||||
HOOK: <insert-db-assigned-statement> db ( class -- object )
|
||||
HOOK: <insert-user-assigned-statement> db ( class -- object )
|
||||
HOOK: <update-tuple-statement> db ( class -- object )
|
||||
HOOK: <delete-tuples-statement> db ( tuple class -- object )
|
||||
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
|
||||
TUPLE: query group order offset limit ;
|
||||
HOOK: <query> db ( tuple class query -- statement' )
|
||||
HOOK: <count-statement> db ( tuple class groups -- n )
|
||||
|
||||
HOOK: insert-tuple* db ( tuple statement -- )
|
||||
|
||||
GENERIC: eval-generator ( singleton -- object )
|
||||
|
||||
: resulting-tuple ( exemplar-tuple row out-params -- tuple )
|
||||
|
|
@ -121,13 +139,14 @@ GENERIC: eval-generator ( singleton -- object )
|
|||
[ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
|
||||
|
||||
: query ( tuple query -- tuples )
|
||||
[ dup dup class ] dip <query> do-select ;
|
||||
[ dup dup class ] dip make-query do-select ;
|
||||
|
||||
|
||||
: select-tuples ( tuple -- tuples )
|
||||
dup dup class <select-by-slots-statement> do-select ;
|
||||
|
||||
: select-tuple ( tuple -- tuple/f )
|
||||
dup dup class \ query new 1 >>limit <query> do-select
|
||||
dup dup class \ query new 1 >>limit make-query do-select
|
||||
[ f ] [ first ] if-empty ;
|
||||
|
||||
: do-count ( exemplar-tuple statement -- tuples )
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
USING: definitions io.launcher kernel math math.parser parser
|
||||
namespaces prettyprint editors make ;
|
||||
|
||||
IN: editors.macvim
|
||||
|
||||
: macvim-location ( file line -- )
|
||||
drop
|
||||
[ "open" , "-a" , "MacVim", , ] { } make
|
||||
try-process ;
|
||||
|
||||
[ macvim-location ] edit-hook set-global
|
||||
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
MacVim editor integration
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
||||
|
|
@ -0,0 +1 @@
|
|||
TextEdit editor integration
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
USING: definitions io.launcher kernel math math.parser parser
|
||||
namespaces prettyprint editors make ;
|
||||
|
||||
IN: editors.textedit
|
||||
|
||||
: textedit-location ( file line -- )
|
||||
drop
|
||||
[ "open" , "-a" , "TextEdit", , ] { } make
|
||||
try-process ;
|
||||
|
||||
[ textedit-location ] edit-hook set-global
|
||||
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1 @@
|
|||
Ad-hoc evaluation of strings of code
|
||||
|
|
@ -30,7 +30,8 @@ ARTICLE: "farkup-ast" "Farkup syntax tree nodes"
|
|||
{ $subsection inline-code }
|
||||
{ $subsection paragraph }
|
||||
{ $subsection list-item }
|
||||
{ $subsection list }
|
||||
{ $subsection unordered-list }
|
||||
{ $subsection ordered-list }
|
||||
{ $subsection table }
|
||||
{ $subsection table-row }
|
||||
{ $subsection link }
|
||||
|
|
|
|||
|
|
@ -35,6 +35,14 @@ link-no-follow? off
|
|||
|
||||
[ "<ul><li>foo</li>\n</ul><p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
|
||||
|
||||
[ "<ol><li>a-b</li></ol>" ] [ "#a-b" convert-farkup ] unit-test
|
||||
[ "<ol><li>foo</li></ol>" ] [ "#foo" convert-farkup ] unit-test
|
||||
[ "<ol><li>foo</li>\n</ol>" ] [ "#foo\n" convert-farkup ] unit-test
|
||||
[ "<ol><li>foo</li>\n<li>bar</li></ol>" ] [ "#foo\n#bar" convert-farkup ] unit-test
|
||||
[ "<ol><li>foo</li>\n<li>bar</li>\n</ol>" ] [ "#foo\n#bar\n" convert-farkup ] unit-test
|
||||
|
||||
[ "<ol><li>foo</li>\n</ol><p>bar\n</p>" ] [ "#foo\nbar\n" convert-farkup ] unit-test
|
||||
|
||||
|
||||
[ "\n\n" ] [ "\n\n" convert-farkup ] unit-test
|
||||
[ "\n\n" ] [ "\r\n\r\n" convert-farkup ] unit-test
|
||||
|
|
@ -120,3 +128,10 @@ link-no-follow? off
|
|||
[ "<p><a href='C%2b%2b'>C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
|
||||
|
||||
[ "<p><foo></p>" ] [ "<foo>" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>asdf\n<ul><li>lol</li>\n<li>haha</li></ul></p>" ] [ "asdf\n-lol\n-haha" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>asdf</p><ul><li>lol</li>\n<li>haha</li></ul>" ] [ "asdf\n\n-lol\n-haha" convert-farkup ] unit-test
|
||||
|
||||
[ "<hr/>" ] [ "___" convert-farkup ] unit-test
|
||||
[ "<hr/>\n" ] [ "___\n" convert-farkup ] unit-test
|
||||
|
|
|
|||
|
|
@ -21,12 +21,14 @@ TUPLE: subscript child ;
|
|||
TUPLE: inline-code child ;
|
||||
TUPLE: paragraph child ;
|
||||
TUPLE: list-item child ;
|
||||
TUPLE: list child ;
|
||||
TUPLE: unordered-list child ;
|
||||
TUPLE: ordered-list child ;
|
||||
TUPLE: table child ;
|
||||
TUPLE: table-row child ;
|
||||
TUPLE: link href text ;
|
||||
TUPLE: image href text ;
|
||||
TUPLE: code mode string ;
|
||||
TUPLE: line ;
|
||||
|
||||
: absolute-url? ( string -- ? )
|
||||
{ "http://" "https://" "ftp://" } [ head? ] with contains? ;
|
||||
|
|
@ -102,16 +104,28 @@ table = ((table-row nl => [[ first ]] )+ table-row? | table-row)
|
|||
text = (!(nl | code | heading | inline-delimiter | table ).)+
|
||||
=> [[ >string ]]
|
||||
|
||||
paragraph-item = (table | text | inline-tag | inline-delimiter)+
|
||||
paragraph-item = (table | list | text | inline-tag | inline-delimiter)+
|
||||
paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]]
|
||||
| (paragraph-item nl)+ paragraph-item?
|
||||
| paragraph-item)
|
||||
=> [[ paragraph boa ]]
|
||||
|
||||
list-item = '-' (cell | inline-tag)*
|
||||
list-item = (cell | inline-tag)*
|
||||
|
||||
ordered-list-item = '#' list-item
|
||||
=> [[ second list-item boa ]]
|
||||
list = ((list-item nl)+ list-item? | list-item)
|
||||
=> [[ list boa ]]
|
||||
ordered-list = ((ordered-list-item nl)+ ordered-list-item? | ordered-list-item)
|
||||
=> [[ ordered-list boa ]]
|
||||
|
||||
unordered-list-item = '-' list-item
|
||||
=> [[ second list-item boa ]]
|
||||
unordered-list = ((unordered-list-item nl)+ unordered-list-item? | unordered-list-item)
|
||||
=> [[ unordered-list boa ]]
|
||||
|
||||
list = ordered-list | unordered-list
|
||||
|
||||
line = '___'
|
||||
=> [[ drop line new ]]
|
||||
|
||||
code = '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]"
|
||||
=> [[ [ second >string ] [ fourth >string ] bi code boa ]]
|
||||
|
|
@ -121,7 +135,7 @@ simple-code
|
|||
=> [[ second f swap code boa ]]
|
||||
|
||||
stand-alone
|
||||
= (code | simple-code | heading | list | table | paragraph | nl)*
|
||||
= (line | code | simple-code | heading | list | table | paragraph | nl)*
|
||||
;EBNF
|
||||
|
||||
|
||||
|
|
@ -177,11 +191,13 @@ M: superscript (write-farkup) [ child>> (write-farkup) ] "sup" in-tag. ;
|
|||
M: subscript (write-farkup) [ child>> (write-farkup) ] "sub" in-tag. ;
|
||||
M: inline-code (write-farkup) [ child>> (write-farkup) ] "code" in-tag. ;
|
||||
M: list-item (write-farkup) [ child>> (write-farkup) ] "li" in-tag. ;
|
||||
M: list (write-farkup) [ child>> (write-farkup) ] "ul" in-tag. ;
|
||||
M: unordered-list (write-farkup) [ child>> (write-farkup) ] "ul" in-tag. ;
|
||||
M: ordered-list (write-farkup) [ child>> (write-farkup) ] "ol" in-tag. ;
|
||||
M: paragraph (write-farkup) [ child>> (write-farkup) ] "p" in-tag. ;
|
||||
M: link (write-farkup) [ href>> ] [ text>> ] bi write-link ;
|
||||
M: image (write-farkup) [ href>> ] [ text>> ] bi write-image-link ;
|
||||
M: code (write-farkup) [ string>> ] [ mode>> ] bi render-code ;
|
||||
M: line (write-farkup) drop <hr/> ;
|
||||
M: table-row (write-farkup) ( obj -- )
|
||||
child>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
|
||||
M: table (write-farkup) [ child>> (write-farkup) ] "table" in-tag. ;
|
||||
|
|
|
|||
|
|
@ -86,7 +86,7 @@ TUPLE: action rest authorize init display validate submit ;
|
|||
begin-conversation
|
||||
nested-forms-key param " " split harvest nested-forms cset
|
||||
form get form cset
|
||||
<redirect>
|
||||
<continue-conversation>
|
||||
] [ <400> ] if*
|
||||
exit-with ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
USING: kernel sequences db.tuples alarms calendar db fry
|
||||
furnace.db
|
||||
furnace.cache
|
||||
furnace.asides
|
||||
furnace.referrer
|
||||
furnace.sessions
|
||||
furnace.conversations
|
||||
|
|
@ -10,20 +11,24 @@ furnace.auth.providers
|
|||
furnace.auth.login.permits ;
|
||||
IN: furnace.alloy
|
||||
|
||||
: <alloy> ( responder db params -- responder' )
|
||||
'[
|
||||
<conversations>
|
||||
<sessions>
|
||||
_ _ <db-persistence>
|
||||
<check-form-submissions>
|
||||
] call ;
|
||||
|
||||
: state-classes { session conversation permit } ; inline
|
||||
: state-classes { session aside conversation permit } ; inline
|
||||
|
||||
: init-furnace-tables ( -- )
|
||||
state-classes ensure-tables
|
||||
user ensure-table ;
|
||||
|
||||
: <alloy> ( responder db params -- responder' )
|
||||
[ [ init-furnace-tables ] with-db ]
|
||||
[
|
||||
[
|
||||
<asides>
|
||||
<conversations>
|
||||
<sessions>
|
||||
] 2dip
|
||||
<db-persistence>
|
||||
<check-form-submissions>
|
||||
] 2bi ;
|
||||
|
||||
: start-expiring ( db params -- )
|
||||
'[
|
||||
_ _ [ state-classes [ expire-state ] each ] with-db
|
||||
|
|
|
|||
|
|
@ -0,0 +1,111 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces assocs kernel sequences accessors hashtables
|
||||
urls db.types db.tuples math.parser fry logging combinators
|
||||
html.templates.chloe.syntax
|
||||
http http.server http.server.filters http.server.redirection
|
||||
furnace
|
||||
furnace.cache
|
||||
furnace.sessions
|
||||
furnace.redirection ;
|
||||
IN: furnace.asides
|
||||
|
||||
TUPLE: aside < server-state
|
||||
session method url post-data ;
|
||||
|
||||
: <aside> ( id -- aside )
|
||||
aside new-server-state ;
|
||||
|
||||
aside "ASIDES" {
|
||||
{ "session" "SESSION" BIG-INTEGER +not-null+ }
|
||||
{ "method" "METHOD" { VARCHAR 10 } }
|
||||
{ "url" "URL" URL }
|
||||
{ "post-data" "POST_DATA" FACTOR-BLOB }
|
||||
} define-persistent
|
||||
|
||||
: aside-id-key "__a" ;
|
||||
|
||||
TUPLE: asides < server-state-manager ;
|
||||
|
||||
: <asides> ( responder -- responder' )
|
||||
asides new-server-state-manager ;
|
||||
|
||||
SYMBOL: aside-id
|
||||
|
||||
: get-aside ( id -- aside )
|
||||
dup [ aside get-state ] when check-session ;
|
||||
|
||||
: request-aside-id ( request -- id )
|
||||
aside-id-key swap request-params at string>number ;
|
||||
|
||||
: request-aside ( request -- aside )
|
||||
request-aside-id get-aside ;
|
||||
|
||||
: set-aside ( aside -- )
|
||||
[ id>> aside-id set ] when* ;
|
||||
|
||||
: init-asides ( asides -- )
|
||||
asides set
|
||||
request get request-aside-id
|
||||
get-aside
|
||||
set-aside ;
|
||||
|
||||
M: asides call-responder*
|
||||
[ init-asides ] [ asides set ] [ call-next-method ] tri ;
|
||||
|
||||
: touch-aside ( aside -- )
|
||||
asides get touch-state ;
|
||||
|
||||
: begin-aside ( url -- )
|
||||
f <aside>
|
||||
swap >>url
|
||||
session get id>> >>session
|
||||
request get method>> >>method
|
||||
request get post-data>> >>post-data
|
||||
[ touch-aside ] [ insert-tuple ] [ set-aside ] tri ;
|
||||
|
||||
: end-aside-post ( aside -- response )
|
||||
[ url>> ] [ post-data>> ] bi
|
||||
request [
|
||||
clone
|
||||
swap >>post-data
|
||||
over >>url
|
||||
] change
|
||||
[ url set ] [ path>> split-path ] bi
|
||||
asides get responder>> call-responder ;
|
||||
|
||||
\ end-aside-post DEBUG add-input-logging
|
||||
|
||||
ERROR: end-aside-in-get-error ;
|
||||
|
||||
: move-on ( id -- response )
|
||||
post-request? [ end-aside-in-get-error ] unless
|
||||
dup method>> {
|
||||
{ "GET" [ url>> <redirect> ] }
|
||||
{ "HEAD" [ url>> <redirect> ] }
|
||||
{ "POST" [ end-aside-post ] }
|
||||
} case ;
|
||||
|
||||
: end-aside ( default -- response )
|
||||
aside-id get aside-id off get-aside [ move-on ] [ <redirect> ] ?if ;
|
||||
|
||||
M: asides link-attr ( tag -- )
|
||||
drop
|
||||
"aside" optional-attr {
|
||||
{ "none" [ aside-id off ] }
|
||||
{ "begin" [ url get begin-aside ] }
|
||||
{ "current" [ ] }
|
||||
{ f [ ] }
|
||||
} case ;
|
||||
|
||||
M: asides modify-query ( query asides -- query' )
|
||||
drop
|
||||
aside-id get [
|
||||
aside-id-key associate assoc-union
|
||||
] when* ;
|
||||
|
||||
M: asides modify-form ( asides -- )
|
||||
drop
|
||||
aside-id get
|
||||
aside-id-key
|
||||
hidden-form-field ;
|
||||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors assocs namespaces kernel sequences sets
|
||||
destructors combinators fry logging
|
||||
io.encodings.utf8 io.encodings.string io.binary random
|
||||
checksums checksums.sha2
|
||||
checksums checksums.sha2 urls
|
||||
html.forms
|
||||
http.server
|
||||
http.server.filters
|
||||
|
|
@ -60,6 +60,10 @@ TUPLE: realm < dispatcher name users checksum secure ;
|
|||
|
||||
GENERIC: login-required* ( description capabilities realm -- response )
|
||||
|
||||
GENERIC: user-registered ( user realm -- response )
|
||||
|
||||
M: object user-registered 2drop URL" $realm" <redirect> ;
|
||||
|
||||
GENERIC: init-realm ( realm -- )
|
||||
|
||||
GENERIC: logged-in-username ( realm -- username )
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs namespaces accessors db db.tuples urls
|
||||
http.server.dispatchers
|
||||
furnace.conversations
|
||||
furnace.asides
|
||||
furnace.actions
|
||||
furnace.auth
|
||||
furnace.auth.providers ;
|
||||
|
|
|
|||
|
|
@ -3,8 +3,8 @@
|
|||
USING: kernel accessors namespaces sequences assocs
|
||||
validators urls html.forms http.server.dispatchers
|
||||
furnace.auth
|
||||
furnace.actions
|
||||
furnace.conversations ;
|
||||
furnace.asides
|
||||
furnace.actions ;
|
||||
IN: furnace.auth.features.edit-profile
|
||||
|
||||
: <edit-profile-action> ( -- action )
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ SYMBOL: lost-password-from
|
|||
[ username>> "username" set-query-param ]
|
||||
[ ticket>> "ticket" set-query-param ]
|
||||
bi
|
||||
adjust-url relative-to-request ;
|
||||
adjust-url ;
|
||||
|
||||
: password-email ( user -- email )
|
||||
<email>
|
||||
|
|
|
|||
|
|
@ -33,8 +33,7 @@ IN: furnace.auth.features.registration
|
|||
users new-user [ user-exists ] unless*
|
||||
|
||||
realm get init-user-profile
|
||||
|
||||
URL" $realm" <redirect>
|
||||
realm get user-registered
|
||||
] >>submit
|
||||
<auth-boilerplate>
|
||||
<secure-realm-only> ;
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@ calendar validators urls logging html.forms
|
|||
http http.server http.server.dispatchers
|
||||
furnace
|
||||
furnace.auth
|
||||
furnace.asides
|
||||
furnace.actions
|
||||
furnace.sessions
|
||||
furnace.utilities
|
||||
|
|
@ -93,9 +94,18 @@ SYMBOL: capabilities
|
|||
[ logout ] >>submit ;
|
||||
|
||||
M: login-realm login-required* ( description capabilities login -- response )
|
||||
begin-aside
|
||||
[ description cset ] [ capabilities cset ] [ drop ] tri*
|
||||
URL" $realm/login" >secure-url <redirect> ;
|
||||
begin-conversation
|
||||
[ description cset ] [ capabilities cset ] [ secure>> ] tri*
|
||||
[
|
||||
url get >secure-url begin-aside
|
||||
URL" $realm/login" >secure-url <continue-conversation>
|
||||
] [
|
||||
url get begin-aside
|
||||
URL" $realm/login" <continue-conversation>
|
||||
] if ;
|
||||
|
||||
M: login-realm user-registered ( user realm -- )
|
||||
drop successful-login ;
|
||||
|
||||
: <login-realm> ( responder name -- auth )
|
||||
login-realm new-realm
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ IN: furnace.chloe-tags
|
|||
<url>
|
||||
swap parse-query-attr >>query
|
||||
-rot a-url-path >>path
|
||||
adjust-url relative-to-request
|
||||
adjust-url
|
||||
] if ;
|
||||
|
||||
: compile-a-url ( tag -- )
|
||||
|
|
@ -72,9 +72,11 @@ CHLOE: a
|
|||
|
||||
: compile-hidden-form-fields ( for -- )
|
||||
'[
|
||||
_ [ "," split [ hidden render ] each ] when*
|
||||
nested-forms get " " join f like nested-forms-key hidden-form-field
|
||||
[ modify-form ] each-responder
|
||||
<div "display: none;" =style div>
|
||||
_ [ "," split [ hidden render ] each ] when*
|
||||
nested-forms get " " join f like nested-forms-key hidden-form-field
|
||||
[ modify-form ] each-responder
|
||||
</div>
|
||||
] [code] ;
|
||||
|
||||
: compile-form-attrs ( method action attrs -- )
|
||||
|
|
@ -109,7 +111,7 @@ CHLOE: form
|
|||
|
||||
STRING: button-tag-markup
|
||||
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
|
||||
<button type="submit"></button>
|
||||
<div style="display: inline;"><button type="submit"></button></div>
|
||||
</t:form>
|
||||
;
|
||||
|
||||
|
|
@ -120,7 +122,7 @@ CHLOE: button
|
|||
button-tag-markup string>xml body>>
|
||||
{
|
||||
[ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
|
||||
[ [ attrs>> non-chloe-attrs-only ] dip "button" tag-named add-tag-attrs ]
|
||||
[ [ children>> ] dip "button" tag-named (>>children) ]
|
||||
[ [ attrs>> non-chloe-attrs-only ] dip "button" deep-tag-named add-tag-attrs ]
|
||||
[ [ children>> ] dip "button" deep-tag-named (>>children) ]
|
||||
[ nip ]
|
||||
} 2cleave compile-chloe-tag ;
|
||||
|
|
|
|||
|
|
@ -11,18 +11,13 @@ furnace.sessions
|
|||
furnace.redirection ;
|
||||
IN: furnace.conversations
|
||||
|
||||
TUPLE: conversation < scope
|
||||
session
|
||||
method url post-data ;
|
||||
TUPLE: conversation < scope session ;
|
||||
|
||||
: <conversation> ( id -- aside )
|
||||
: <conversation> ( id -- conversation )
|
||||
conversation new-server-state ;
|
||||
|
||||
conversation "CONVERSATIONS" {
|
||||
{ "session" "SESSION" BIG-INTEGER +not-null+ }
|
||||
{ "method" "METHOD" { VARCHAR 10 } }
|
||||
{ "url" "URL" URL }
|
||||
{ "post-data" "POST_DATA" FACTOR-BLOB }
|
||||
} define-persistent
|
||||
|
||||
: conversation-id-key "__c" ;
|
||||
|
|
@ -46,8 +41,7 @@ SYMBOL: conversation-id
|
|||
conversation get scope-change ; inline
|
||||
|
||||
: get-conversation ( id -- conversation )
|
||||
dup [ conversation get-state ] when
|
||||
dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
|
||||
dup [ conversation get-state ] when check-session ;
|
||||
|
||||
: request-conversation-id ( request -- id )
|
||||
conversation-id-key swap request-params at string>number ;
|
||||
|
|
@ -88,22 +82,21 @@ M: conversations call-responder*
|
|||
: add-conversation ( conversation -- )
|
||||
[ touch-conversation ] [ insert-tuple ] bi ;
|
||||
|
||||
: begin-conversation* ( -- conversation )
|
||||
empty-conversastion dup add-conversation ;
|
||||
|
||||
: begin-conversation ( -- )
|
||||
conversation get [
|
||||
begin-conversation*
|
||||
set-conversation
|
||||
empty-conversastion
|
||||
[ add-conversation ]
|
||||
[ set-conversation ] bi
|
||||
] unless ;
|
||||
|
||||
: end-conversation ( -- )
|
||||
conversation off
|
||||
conversation-id off ;
|
||||
|
||||
: <conversation-redirect> ( url seq -- response )
|
||||
begin-conversation
|
||||
[ [ get ] keep cset ] each
|
||||
: <continue-conversation> ( url -- response )
|
||||
conversation-id get
|
||||
conversation-id-key
|
||||
set-query-param
|
||||
<redirect> ;
|
||||
|
||||
: restore-conversation ( seq -- )
|
||||
|
|
@ -114,64 +107,6 @@ M: conversations call-responder*
|
|||
bi
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: begin-aside ( -- )
|
||||
begin-conversation
|
||||
conversation get
|
||||
request get
|
||||
[ method>> >>method ]
|
||||
[ url>> >>url ]
|
||||
[ post-data>> >>post-data ]
|
||||
tri
|
||||
touch-conversation ;
|
||||
|
||||
: end-aside-post ( aside -- response )
|
||||
request [
|
||||
clone
|
||||
over post-data>> >>post-data
|
||||
over url>> >>url
|
||||
] change
|
||||
[ url>> url set ]
|
||||
[ url>> path>> split-path ] bi
|
||||
conversations get responder>> call-responder ;
|
||||
|
||||
\ end-aside-post DEBUG add-input-logging
|
||||
|
||||
ERROR: end-aside-in-get-error ;
|
||||
|
||||
: move-on ( id -- response )
|
||||
post-request? [ end-aside-in-get-error ] unless
|
||||
dup method>> {
|
||||
{ "GET" [ url>> <redirect> ] }
|
||||
{ "HEAD" [ url>> <redirect> ] }
|
||||
{ "POST" [ end-aside-post ] }
|
||||
} case ;
|
||||
|
||||
: get-aside ( id -- conversation )
|
||||
get-conversation dup [ dup method>> [ drop f ] unless ] when ;
|
||||
|
||||
: end-aside* ( url id -- response )
|
||||
get-aside [ move-on ] [ <redirect> ] ?if ;
|
||||
|
||||
: end-aside ( default -- response )
|
||||
conversation-id get
|
||||
end-conversation
|
||||
end-aside* ;
|
||||
|
||||
M: conversations link-attr ( tag -- )
|
||||
drop
|
||||
"aside" optional-attr {
|
||||
{ "none" [ conversation-id off ] }
|
||||
{ "begin" [ begin-aside ] }
|
||||
{ "current" [ ] }
|
||||
{ f [ ] }
|
||||
} case ;
|
||||
|
||||
M: conversations modify-query ( query conversations -- query' )
|
||||
drop
|
||||
conversation-id get [
|
||||
conversation-id-key associate assoc-union
|
||||
] when* ;
|
||||
|
||||
M: conversations modify-form ( conversations -- )
|
||||
drop
|
||||
conversation-id get
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: furnace.tests
|
||||
USING: http.server.dispatchers http.server.responses
|
||||
USING: http http.server.dispatchers http.server.responses
|
||||
http.server furnace tools.test kernel namespaces accessors
|
||||
io.streams.string ;
|
||||
io.streams.string urls ;
|
||||
TUPLE: funny-dispatcher < dispatcher ;
|
||||
|
||||
: <funny-dispatcher> funny-dispatcher new-dispatcher ;
|
||||
|
|
@ -33,3 +33,9 @@ M: base-path-check-responder call-responder*
|
|||
[ "<input type='hidden' name='foo' value='&&&'/>" ]
|
||||
[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
|
||||
unit-test
|
||||
|
||||
[ f ] [ <request> request [ referrer ] with-variable ] unit-test
|
||||
|
||||
[ t ] [ URL" http://foo" dup url [ same-host? ] with-variable ] unit-test
|
||||
|
||||
[ f ] [ f URL" http://foo" url [ same-host? ] with-variable ] unit-test
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: namespaces make assocs sequences kernel classes splitting
|
|||
vocabs.loader accessors strings combinators arrays
|
||||
continuations present fry
|
||||
urls html.elements
|
||||
http http.server http.server.redirection ;
|
||||
http http.server http.server.redirection http.server.remapping ;
|
||||
IN: furnace
|
||||
|
||||
: nested-responders ( -- seq )
|
||||
|
|
@ -37,6 +37,10 @@ GENERIC: modify-query ( query responder -- query' )
|
|||
|
||||
M: object modify-query drop ;
|
||||
|
||||
GENERIC: modify-redirect-query ( query responder -- query' )
|
||||
|
||||
M: object modify-redirect-query drop ;
|
||||
|
||||
GENERIC: adjust-url ( url -- url' )
|
||||
|
||||
M: url adjust-url
|
||||
|
|
@ -47,6 +51,14 @@ M: url adjust-url
|
|||
|
||||
M: string adjust-url ;
|
||||
|
||||
GENERIC: adjust-redirect-url ( url -- url' )
|
||||
|
||||
M: url adjust-redirect-url
|
||||
adjust-url
|
||||
[ [ modify-redirect-query ] each-responder ] change-query ;
|
||||
|
||||
M: string adjust-redirect-url ;
|
||||
|
||||
GENERIC: link-attr ( tag responder -- )
|
||||
|
||||
M: object link-attr 2drop ;
|
||||
|
|
@ -77,16 +89,23 @@ M: object modify-form drop ;
|
|||
] }
|
||||
} case ;
|
||||
|
||||
: referrer ( -- referrer )
|
||||
: referrer ( -- referrer/f )
|
||||
#! Typo is intentional, its in the HTTP spec!
|
||||
"referer" request get header>> at >url ;
|
||||
"referer" request get header>> at
|
||||
dup [ >url ensure-port [ remap-port ] change-port ] when ;
|
||||
|
||||
: user-agent ( -- user-agent )
|
||||
"user-agent" request get header>> at "" or ;
|
||||
|
||||
: same-host? ( url -- ? )
|
||||
url get
|
||||
[ [ protocol>> ] [ host>> ] [ port>> ] tri 3array ] bi@ = ;
|
||||
dup [
|
||||
url get [
|
||||
[ protocol>> ]
|
||||
[ host>> ]
|
||||
[ port>> remap-port ]
|
||||
tri 3array
|
||||
] bi@ =
|
||||
] when ;
|
||||
|
||||
: cookie-client-state ( key request -- value/f )
|
||||
swap get-cookie dup [ value>> ] when ;
|
||||
|
|
|
|||
|
|
@ -1,13 +1,12 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors combinators namespaces fry
|
||||
io.servers.connection urls http http.server
|
||||
http.server.redirection http.server.responses
|
||||
http.server.filters furnace ;
|
||||
USING: kernel accessors combinators namespaces fry urls http
|
||||
http.server http.server.redirection http.server.responses
|
||||
http.server.remapping http.server.filters furnace ;
|
||||
IN: furnace.redirection
|
||||
|
||||
: <redirect> ( url -- response )
|
||||
adjust-url request get method>> {
|
||||
adjust-redirect-url request get method>> {
|
||||
{ "GET" [ <temporary-redirect> ] }
|
||||
{ "HEAD" [ <temporary-redirect> ] }
|
||||
{ "POST" [ <permanent-redirect> ] }
|
||||
|
|
@ -16,7 +15,7 @@ IN: furnace.redirection
|
|||
: >secure-url ( url -- url' )
|
||||
clone
|
||||
"https" >>protocol
|
||||
secure-port >>port ;
|
||||
secure-http-port >>port ;
|
||||
|
||||
: <secure-redirect> ( url -- response )
|
||||
>secure-url <redirect> ;
|
||||
|
|
|
|||
|
|
@ -14,4 +14,4 @@ M: referrer-check call-responder*
|
|||
[ 2drop 403 "Bad referrer" <trivial-response> ] if ;
|
||||
|
||||
: <check-form-submissions> ( responder -- responder' )
|
||||
[ same-host? post-request? not or ] <referrer-check> ;
|
||||
[ post-request? [ same-host? ] [ drop t ] if ] <referrer-check> ;
|
||||
|
|
|
|||
|
|
@ -107,3 +107,8 @@ M: sessions call-responder* ( path responder -- response )
|
|||
sessions set
|
||||
request-session [ begin-session ] unless*
|
||||
existing-session put-session-cookie ;
|
||||
|
||||
SLOT: session
|
||||
|
||||
: check-session ( state/f -- state/f )
|
||||
dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ M: object >entry
|
|||
: process-entries ( seq -- seq' )
|
||||
20 short head-slice [
|
||||
>entry clone
|
||||
[ adjust-url relative-to-request ] change-url
|
||||
[ adjust-url ] change-url
|
||||
] map ;
|
||||
|
||||
: <feed-content> ( body -- response )
|
||||
|
|
@ -46,7 +46,7 @@ TUPLE: feed-action < action title url entries ;
|
|||
feed new
|
||||
_
|
||||
[ title>> call >>title ]
|
||||
[ url>> call adjust-url relative-to-request >>url ]
|
||||
[ url>> call adjust-url >>url ]
|
||||
[ entries>> call process-entries >>entries ]
|
||||
tri
|
||||
<feed-content>
|
||||
|
|
|
|||
|
|
@ -0,0 +1,4 @@
|
|||
Chris Double
|
||||
Doug Coleman
|
||||
Eduardo Cavazos
|
||||
Slava Pestov
|
||||
|
|
@ -0,0 +1 @@
|
|||
Generalized stack shufflers and combinators to arbitrary numbers of inputs
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,105 @@
|
|||
! Copyright (C) 2008 Your name.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax io.streams.string kernel strings
|
||||
urls lcs inspector present io ;
|
||||
IN: html.components
|
||||
|
||||
HELP: checkbox
|
||||
{ $class-description "Checkbox components render a boolean value. The " { $slot "label" } " slot must be set to a string." } ;
|
||||
|
||||
HELP: choice
|
||||
{ $class-description "Choice components render a popup menu or list box with either single or multiple selection."
|
||||
$nl
|
||||
"The " { $slot "multiple" } " slot determines whether multiple elements may be selected at once; if this is set to a true value, then the component value must be a sequence of strings, otherwise it must be a single string."
|
||||
$nl
|
||||
"The " { $slot "size" } " slot determines the number of items visible at one time; if neither this nor " { $slot "multiple" } " is set, the component is rendered as a popup menu rather than a list."
|
||||
$nl
|
||||
"The " { $slot "choices" } " slot determines all possible choices which may be selected. It names a value, rather than storing the choices directly." } ;
|
||||
|
||||
HELP: code
|
||||
{ $class-description "Code components render string value with the " { $vocab-link "xmode.code2html" } " syntax highlighting vocabulary. The " { $slot "mode" } " slot names a value holding an XMode mode name." } ;
|
||||
|
||||
HELP: field
|
||||
{ $class-description "Field components display a one-line editor for a string value. The " { $slot "size" } " slot determines the maximum displayed width of the field." } ;
|
||||
|
||||
HELP: password
|
||||
{ $class-description "Password field components display a one-line editor which obscures the user's input. The " { $slot "size" } " slot determines the maximum displayed width of the field. Unlike other components, on failed validation, the contents of a password field are not sent back to the client. This is a security feature, intended to avoid revealing the password to potential snoopers who use the " { $strong "View Source" } " feature." } ;
|
||||
|
||||
HELP: textarea
|
||||
{ $class-description "Text area components display a multi-line editor for a string value. The " { $slot "rows" } " and " { $slot "cols" } " properties determine the size of the text area." } ;
|
||||
|
||||
HELP: link
|
||||
{ $description "Link components render a link to an object stored at a value, with the link title and URL determined by the " { $link link-title } " and " { $link link-href } " generic words." } ;
|
||||
|
||||
HELP: link-title
|
||||
{ $values { "obj" object } { "string" string } }
|
||||
{ $description "Outputs the title to render for a link to the object." } ;
|
||||
|
||||
HELP: link-href
|
||||
{ $values { "obj" object } { "url" "a " { $link string } " or " { $link url } } }
|
||||
{ $description "Outputs the URL to render for a link to the object." } ;
|
||||
|
||||
ARTICLE: "html.components.links" "Link components"
|
||||
"Link components render a link to an object."
|
||||
{ $subsection link }
|
||||
"The link title and URL are determined by passing the object to a pair of generic words:"
|
||||
{ $subsection link-title }
|
||||
{ $subsection link-href }
|
||||
"The generic words provide methods on the " { $link string } " and " { $link url } " classes which treat the object as a URL. New methods can be defined for rendering links to custom data types." ;
|
||||
|
||||
HELP: comparison
|
||||
{ $description "Comparison components render diffs output by the " { $link diff } " word." } ;
|
||||
|
||||
HELP: farkup
|
||||
{ $description "Farkup components render " { $link "farkup" } "." } ;
|
||||
|
||||
HELP: hidden
|
||||
{ $description "Hidden components render as a hidden form field. For example, a page for editing a weblog post might contain a hidden field with the post ID." } ;
|
||||
|
||||
HELP: html
|
||||
{ $description "HTML components render HTML verbatim, without any escaping. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ;
|
||||
|
||||
HELP: inspector
|
||||
{ $description "Inspector components render an arbitrary object by passing it to the " { $link describe } " word." } ;
|
||||
|
||||
HELP: label
|
||||
{ $description "Label components render an object as a piece of text by passing it to the " { $link present } " word." } ;
|
||||
|
||||
HELP: render
|
||||
{ $values { "name" "a value name" } { "renderer" "a component renderer" } }
|
||||
{ $description "Renders an HTML component to the " { $link output-stream } "." } ;
|
||||
|
||||
HELP: render*
|
||||
{ $values { "value" "a value" } { "name" "a value name" } { "renderer" "a component renderer" } }
|
||||
{ $contract "Renders an HTML component to the " { $link output-stream } "." } ;
|
||||
|
||||
ARTICLE: "html.components" "HTML components"
|
||||
"The " { $vocab-link "html.components" } " vocabulary provides various HTML form components."
|
||||
$nl
|
||||
"Most web applications can use the " { $vocab-link "html.templates.chloe" } " templating framework instead of using this vocabulary directly. Where maximum flexibility is required, this vocabulary can be used together with the " { $vocab-link "html.templates.fhtml" } " templating framework."
|
||||
$nl
|
||||
"Rendering components:"
|
||||
{ $subsection render }
|
||||
"Components render a named value, and the name of the value is passed in every time the component is rendered, rather than being associated with the component itself. Named values are taken from the current HTML form (see " { $link "html.forms" } ")."
|
||||
$nl
|
||||
"Component come in two varieties: singletons and tuples. Components with no configuration are singletons; they do not have to instantiated, rather the class word represents the component. Tuple components have to be instantiated and offer configuration options."
|
||||
$nl
|
||||
"Singleton components:"
|
||||
{ $subsection hidden }
|
||||
{ $subsection link }
|
||||
{ $subsection inspector }
|
||||
{ $subsection comparison }
|
||||
{ $subsection html }
|
||||
"Tuple components:"
|
||||
{ $subsection field }
|
||||
{ $subsection password }
|
||||
{ $subsection textarea }
|
||||
{ $subsection choice }
|
||||
{ $subsection checkbox }
|
||||
{ $subsection code }
|
||||
{ $subsection farkup }
|
||||
"Creating custom components:"
|
||||
{ $subsection render* }
|
||||
"Custom components can emit HTML using the " { $vocab-link "html.elements" } " vocabulary." ;
|
||||
|
||||
ABOUT: "html.components"
|
||||
|
|
@ -144,19 +144,25 @@ M: code render*
|
|||
[ string-lines ] [ drop ] [ mode>> value ] tri* htmlize-lines ;
|
||||
|
||||
! Farkup component
|
||||
TUPLE: farkup no-follow disable-images ;
|
||||
TUPLE: farkup no-follow disable-images parsed ;
|
||||
|
||||
: <farkup> ( -- farkup )
|
||||
farkup new ;
|
||||
|
||||
: string>boolean ( string -- boolean )
|
||||
{
|
||||
{ "true" [ t ] }
|
||||
{ "false" [ f ] }
|
||||
{ f [ f ] }
|
||||
} case ;
|
||||
|
||||
M: farkup render*
|
||||
[
|
||||
nip
|
||||
[ no-follow>> [ string>boolean link-no-follow? set ] when* ]
|
||||
[ disable-images>> [ string>boolean disable-images? set ] when* ] bi
|
||||
drop string-lines "\n" join write-farkup
|
||||
[ disable-images>> [ string>boolean disable-images? set ] when* ]
|
||||
[ parsed>> string>boolean [ (write-farkup) ] [ write-farkup ] if ]
|
||||
tri
|
||||
] with-scope ;
|
||||
|
||||
! Inspector component
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
HTML components for form rendering and validation
|
||||
|
|
@ -0,0 +1 @@
|
|||
web
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
IN: html.elements
|
||||
USING: help.markup help.syntax io present ;
|
||||
|
||||
ARTICLE: "html.elements" "HTML elements"
|
||||
"The " { $vocab-link "html.elements" } " vocabulary provides words for writing HTML tags to the " { $link output-stream } " with a familiar look and feel in the code."
|
||||
$nl
|
||||
"HTML tags can be used in a number of different ways. The simplest is a tag with no attributes:"
|
||||
{ $code "<p> \"someoutput\" write </p>" }
|
||||
"In the above, " { $link <p> } " will output the opening tag with no attributes. and " { $link </p> } " will output the closing tag."
|
||||
{ $code "<p \"red\" =class p> \"someoutput\" write </p>" }
|
||||
"This time the opening tag does not have the '>'. Any attribute words used between the calls to " { $link <p } " and " { $link p> } " will write an attribute whose value is the top of the stack. Attribute values can be any object supported by the " { $link present } " word."
|
||||
$nl
|
||||
"Values for attributes can be used directly without any stack operations. Assuming we have a string on the stack, all three of the below will output a link:"
|
||||
{ $code "<a =href a> \"Click me\" write </a>" }
|
||||
{ $code "<a \"http://\" prepend =href a> \"click\" write </a>" }
|
||||
{ $code "<a [ \"http://\" % % ] \"\" make =href a> \"click\" write </a>" }
|
||||
"Tags that have no ``closing'' equivalent have a trailing " { $snippet "tag/>" } " form:"
|
||||
{ $code "<input \"text\" =type \"name\" =name 20 =size input/>" }
|
||||
"For the full list of HTML tags and attributes, consult the word list for the " { $vocab-link "html.elements" } " vocabulary. In addition to HTML tag and attribute words, a few utilities are provided."
|
||||
$nl
|
||||
"Writing unescaped HTML to " { $vocab-link "html.streams" } ":"
|
||||
{ $subsection write-html }
|
||||
{ $subsection print-html }
|
||||
"Writing some common HTML patterns:"
|
||||
{ $subsection xhtml-preamble }
|
||||
{ $subsection simple-page }
|
||||
{ $subsection render-error } ;
|
||||
|
||||
ABOUT: "html.elements"
|
||||
|
|
@ -9,45 +9,6 @@ urls math math.parser combinators present fry ;
|
|||
|
||||
IN: html.elements
|
||||
|
||||
! These words are used to provide a means of writing
|
||||
! formatted HTML to standard output with a familiar 'html' look
|
||||
! and feel in the code.
|
||||
!
|
||||
! HTML tags can be used in a number of different ways. The highest
|
||||
! level involves a similar syntax to HTML:
|
||||
!
|
||||
! <p> "someoutput" write </p>
|
||||
!
|
||||
! <p> will output the opening tag and </p> will output the closing
|
||||
! tag with no attributes.
|
||||
!
|
||||
! <p "red" =class p> "someoutput" write </p>
|
||||
!
|
||||
! This time the opening tag does not have the '>'. It pushes
|
||||
! a namespace on the stack to hold the attributes and values.
|
||||
! Any attribute words used will store the attribute and values
|
||||
! in that namespace. Before the attribute word should come the
|
||||
! value of that attribute.
|
||||
! The finishing word will print out the operning tag including
|
||||
! attributes.
|
||||
! Any writes after this will appear after the opening tag.
|
||||
!
|
||||
! Values for attributes can be used directly without any stack
|
||||
! operations:
|
||||
!
|
||||
! (url -- )
|
||||
! <a =href a> "Click me" write </a>
|
||||
!
|
||||
! (url -- )
|
||||
! <a "http://" prepend =href a> "click" write </a>
|
||||
!
|
||||
! (url -- )
|
||||
! <a [ "http://" % % ] "" make =href a> "click" write </a>
|
||||
!
|
||||
! Tags that have no 'closing' equivalent have a trailing tag/> form:
|
||||
!
|
||||
! <input "text" =type "name" =name "20" =size input/>
|
||||
|
||||
SYMBOL: html
|
||||
|
||||
: write-html ( str -- )
|
||||
|
|
@ -149,6 +110,7 @@ SYMBOL: html
|
|||
[
|
||||
"input"
|
||||
"br"
|
||||
"hr"
|
||||
"link"
|
||||
"img"
|
||||
] [ define-open-html-word ] each
|
||||
|
|
@ -169,7 +131,7 @@ SYMBOL: html
|
|||
|
||||
: 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 ;
|
||||
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">" write-html ;
|
||||
|
||||
: simple-page ( title quot -- )
|
||||
#! Call the quotation, with all output going to the
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Rendering HTML with a familiar look and feel
|
||||
|
|
@ -0,0 +1 @@
|
|||
web
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,125 @@
|
|||
IN: html.forms
|
||||
USING: help.markup help.syntax strings quotations kernel assocs ;
|
||||
|
||||
HELP: <form>
|
||||
{ $values { "form" form } }
|
||||
{ $description "Creates a new form. Usually " { $link with-form } " is used instead." } ;
|
||||
|
||||
HELP: form
|
||||
{ $var-description "Variable holding current form. Bound by " { $link with-form } ", " { $link nest-form } " and " { $link begin-form } "." }
|
||||
{ $class-description "The class of HTML forms. New instances are created by " { $link <form> } "." } ;
|
||||
|
||||
HELP: with-form
|
||||
{ $values { "name" string } { "quot" quotation } }
|
||||
{ $description "Runs the quotation in a new dynamic scope with the " { $link form } " variable rebound to the form stored in the value named " { $snippet "name" } "." } ;
|
||||
|
||||
HELP: nest-form
|
||||
{ $values { "name" string } { "quot" quotation } }
|
||||
{ $description "Runs the quotation in a new dynamic scope with the " { $link form } " variable rebound to a new form, which is subsequently stored in the value named " { $snippet "name" } "." }
|
||||
{ $examples
|
||||
"The " { $vocab-link "webapps.pastebin" } " uses a form to display pastes; inside this form it nests another form for creating annotations, and fills in some default values for new annotations:"
|
||||
{ $code
|
||||
"<page-action>"
|
||||
" ["
|
||||
" validate-integer-id"
|
||||
" \"id\" value paste from-object"
|
||||
""
|
||||
" \"id\" value"
|
||||
" \"new-annotation\" ["
|
||||
" \"parent\" set-value"
|
||||
" mode-names \"modes\" set-value"
|
||||
" \"factor\" \"mode\" set-value"
|
||||
" ] nest-form"
|
||||
" ] >>init"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: begin-form
|
||||
{ $description "Begins a new form." } ;
|
||||
|
||||
HELP: value
|
||||
{ $values { "name" string } { "value" object } }
|
||||
{ $description "Gets a form value. This word is used to get form field values after validation." } ;
|
||||
|
||||
HELP: set-value
|
||||
{ $values { "value" object } { "name" string } }
|
||||
{ $description "Sets a form value. This word is used to preset form field values before rendering." } ;
|
||||
|
||||
HELP: from-object
|
||||
{ $values { "object" object } }
|
||||
{ $description "Sets the current form's values to the object's slot values." }
|
||||
{ $examples
|
||||
"Here is a typical action implementation, which selects a golf course object from the database with the ID specified in the HTTP request, and renders a form with values from this object:"
|
||||
{ $code
|
||||
"<page-action>"
|
||||
""
|
||||
" ["
|
||||
" validate-integer-id"
|
||||
" \"id\" value <golf-course>"
|
||||
" select-tuple from-object"
|
||||
" ] >>init"
|
||||
""
|
||||
" { golf \"view-course\" } >>template"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: to-object
|
||||
{ $values { "destination" object } { "names" "a sequence of value names" } }
|
||||
{ $description "Stores the given sequence of form values into the slots of the object having the same names. This word is used to extract form field values after validation." } ;
|
||||
|
||||
HELP: with-each-value
|
||||
{ $values { "name" string } { "quot" quotation } }
|
||||
{ $description "Calls the quotation with each element of the value named " { $snippet "name" } "; the value must be a sequence. The quotation is called in a new dynamic scope with the " { $snippet "index" } " and " { $snippet "value" } " values set to the one-based index, and the sequence element in question, respectively." }
|
||||
{ $notes "This word is used to implement the " { $snippet "t:each" } " tag of the " { $vocab-link "html.templates.chloe" } " templating system. It can also be called directly from " { $vocab-link "html.templates.fhtml" } " templates." } ;
|
||||
|
||||
HELP: with-each-object
|
||||
{ $description "Calls the quotation with each element of the value named " { $snippet "name" } "; the value must be a sequence. The quotation is called in a new dynamic scope where the object's slots become named values, as if " { $link from-object } " was called." }
|
||||
{ $notes "This word is used to implement the " { $snippet "t:bind-each" } " tag of the " { $vocab-link "html.templates.chloe" } " templating system. It can also be called directly from " { $vocab-link "html.templates.fhtml" } " templates." } ;
|
||||
|
||||
HELP: validation-failed?
|
||||
{ $values { "?" "a boolean" } }
|
||||
{ $description "Tests if validation of the current form failed." } ;
|
||||
|
||||
HELP: validate-values
|
||||
{ $values { "assoc" assoc } { "validators" "an assoc mapping value names to quotations" } }
|
||||
{ $description "Validates values in the assoc by looking up the corresponding validation quotation, and storing the results in named values of the current form." } ;
|
||||
|
||||
ARTICLE: "html.forms.forms" "HTML form infrastructure"
|
||||
"The below words are used to implement the " { $vocab-link "furnace.actions" } " vocabulary. Calling them directly is rarely necessary."
|
||||
$nl
|
||||
"Creating a new form:"
|
||||
{ $subsection <form> }
|
||||
"Variable holding current form:"
|
||||
{ $subsection form }
|
||||
"Working with forms:"
|
||||
{ $subsection with-form }
|
||||
{ $subsection begin-form }
|
||||
"Validation:"
|
||||
{ $subsection validation-error }
|
||||
{ $subsection validation-failed? }
|
||||
{ $subsection validate-values } ;
|
||||
|
||||
ARTICLE: "html.forms.values" "HTML form values"
|
||||
"Form values are a central concept in the Furnace framework. Web actions primarily concern themselves with validating values, marshalling values to a database, and setting values for display in a form."
|
||||
$nl
|
||||
"Getting and setting values:"
|
||||
{ $subsection value }
|
||||
{ $subsection set-value }
|
||||
{ $subsection from-object }
|
||||
{ $subsection to-object }
|
||||
"Iterating over values; these words are used by " { $vocab-link "html.templates.chloe" } " to implement the " { $snippet "t:each" } " and " { $snippet "t:bind-each" } " tags:"
|
||||
{ $subsection with-each-value }
|
||||
{ $subsection with-each-object }
|
||||
"Nesting a form inside another form as a value:"
|
||||
{ $subsection nest-form } ;
|
||||
|
||||
ARTICLE: "html.forms" "HTML forms"
|
||||
"The " { $vocab-link "html.forms" } " vocabulary implements support for rendering and validating HTML forms. The definition of a " { $emphasis "form" } " is a bit more general than the content of an " { $snippet "<form>" } " tag. Namely, a page which displays a database record without offering any editing capability is considered a form too; it consists entirely of read-only components."
|
||||
$nl
|
||||
"This vocabulary is an integral part of the " { $vocab-link "furnace" } " web framework. The " { $vocab-link "html.templates.chloe" } " vocabulary uses the HTML form words to implement various template tags. The words are also often used directly from web action implementations."
|
||||
$nl
|
||||
"This vocabulary can be used without either the Furnace framework or the HTTP server; for example, as part of a static HTML generation tool."
|
||||
{ $subsection "html.forms.forms" }
|
||||
{ $subsection "html.forms.values" } ;
|
||||
|
||||
ABOUT: "html.forms"
|
||||
|
|
@ -102,5 +102,5 @@ C: <validation-error> validation-error
|
|||
dup validation-error? [ form get t >>validation-failed drop ] when
|
||||
swap set-value ;
|
||||
|
||||
: validate-values ( assoc validators -- assoc' )
|
||||
: validate-values ( assoc validators -- )
|
||||
swap '[ [ dup _ at ] dip validate-value ] assoc-each ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
HTML form rendering and validation
|
||||
|
|
@ -0,0 +1 @@
|
|||
web
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
IN: html.streams
|
||||
USING: help.markup help.syntax kernel strings io io.styles
|
||||
quotations ;
|
||||
|
||||
HELP: browser-link-href
|
||||
{ $values { "presented" object } { "href" string } }
|
||||
{ $contract "Outputs a link to a page displaying a presentation of the given object. This word is called when " { $link write-object } " is called on " { $link html-stream } " instances." } ;
|
||||
|
||||
HELP: html-stream
|
||||
{ $class-description "A formatted output stream which emits HTML markup." } ;
|
||||
|
||||
HELP: <html-stream>
|
||||
{ $values { "stream" "an output stream" } { "html-stream" html-stream } }
|
||||
{ $description "Creates a new formatted output stream which emits HTML markup on " { $snippet "stream" } "." } ;
|
||||
|
||||
HELP: with-html-stream
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an " { $link html-stream } " wrapping the current " { $link output-stream } "." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"[ \"Hello\" { { font-style bold } } format nl ] with-html-stream"
|
||||
"<span style='font-style: normal; font-weight: bold; '>Hello</span><br/>"
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "html.streams" "HTML streams"
|
||||
"The " { $vocab-link "html.streams" } " vocabulary provides a stream which implements " { $link "styles" } " by writing HTML markup to the wrapped stream."
|
||||
{ $subsection html-stream }
|
||||
{ $subsection <html-stream> }
|
||||
{ $subsection with-html-stream } ;
|
||||
|
||||
ABOUT: "html.streams"
|
||||
|
|
@ -25,7 +25,7 @@ TUPLE: html-stream stream last-div ;
|
|||
: a-div ( stream -- straem )
|
||||
t >>last-div ; inline
|
||||
|
||||
: <html-stream> ( stream -- stream )
|
||||
: <html-stream> ( stream -- html-stream )
|
||||
f html-stream boa ;
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
HTML reader, writer and utilities
|
||||
HTML implementation of formatted output stream protocol
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,284 @@
|
|||
IN: html.templates.chloe
|
||||
USING: help.markup help.syntax html.components html.forms
|
||||
html.templates html.templates.chloe.syntax
|
||||
html.templates.chloe.compiler html.templates.chloe.components
|
||||
math xml.data strings quotations namespaces ;
|
||||
|
||||
HELP: <chloe> ( path -- template )
|
||||
{ $values { "path" "a pathname string without the trailing " { $snippet ".xml" } " extension" } { "template" chloe } }
|
||||
{ $description "Creates a new Chloe template object which can be passed to " { $link call-template } "." } ;
|
||||
|
||||
HELP: required-attr
|
||||
{ $values { "tag" tag } { "name" string } { "value" string } }
|
||||
{ $description "Extracts an attribute from a tag." }
|
||||
{ $errors "Throws an error if the attribute is not specified." } ;
|
||||
|
||||
HELP: optional-attr
|
||||
{ $values { "tag" tag } { "name" string } { "value" "a " { $link string } " or " { $link f } } }
|
||||
{ $description "Extracts an attribute from a tag." }
|
||||
{ $notes "Outputs " { $link f } " if the attribute is not specified." } ;
|
||||
|
||||
HELP: compile-attr
|
||||
{ $values { "value" "an attribute value" } }
|
||||
{ $description "Compiles code which pushes an attribute value previously extracted by " { $link required-attr } " or " { $link optional-attr } " on the stack. If the attribute value begins with " { $snippet "@" } ", compiles into code which pushes the a form value." } ;
|
||||
|
||||
HELP: CHLOE:
|
||||
{ $syntax "name definition... ;" }
|
||||
{ $values { "name" "the tag name" } { "definition" "a quotation with stack effect " { $snippet "( tag -- )" } } }
|
||||
{ $description "Defines compilation semantics for the Chloe tag named " { $snippet "tag" } ". The definition body receives a " { $link tag } " on the stack." } ;
|
||||
|
||||
HELP: CHLOE-SINGLETON:
|
||||
{ $syntax "CHLOE-SINGLETON: name" }
|
||||
{ $description "Defines a Chloe tag named " { $snippet "name" } " rendering an HTML component with singleton class word " { $snippet "name" } ". See " { $link "html.components" } "." } ;
|
||||
|
||||
HELP: CHLOE-TUPLE:
|
||||
{ $syntax "CHLOE-TUPLE: name" }
|
||||
{ $description "Defines a Chloe tag named " { $snippet "name" } " rendering an HTML component with tuple class word " { $snippet "name" } ". See " { $link "html.components" } "." } ;
|
||||
|
||||
HELP: reset-cache
|
||||
{ $description "Resets the compiled template cache. Chloe automatically recompiles templates when their file changes on disk, however other when redefining Chloe tags or words which they call, the cache may have to be reset manually for the changes to take effect." } ;
|
||||
|
||||
HELP: tag-stack
|
||||
{ $var-description "During template compilation, holds the current nesting of XML element names. Can be used from " { $link POSTPONE: CHLOE: } " definitions to make a custom tag behave differently depending on how it is nested." } ;
|
||||
|
||||
HELP: [write]
|
||||
{ $values { "string" string } }
|
||||
{ $description "Compiles code which writes the string when the template is called." } ;
|
||||
|
||||
HELP: [code]
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Compiles the quotation. It will be called when the template is called." } ;
|
||||
|
||||
HELP: process-children
|
||||
{ $values { "tag" tag } { "quot" "a quotation with stack effect " { $snippet "( compiled-tag -- )" } } }
|
||||
{ $description "Compiles the tag. The quotation will be applied to the resulting quotation when the template is called." }
|
||||
{ $examples "See " { $link "html.templates.chloe.extend.tags.example" } " for an example which uses this word to implement a custom control flow tag." } ;
|
||||
|
||||
HELP: compile-children>string
|
||||
{ $values { "tag" tag } }
|
||||
{ $description "Compiles the tag so that the output it generates is written to a string, which is pushed on the stack when the template runs. A subsequent " { $link [code] } " call must be made with a quotation which consumes the string." } ;
|
||||
|
||||
HELP: compile-with-scope
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Calls the quotation and wraps any output it compiles in a " { $link with-scope } " form." } ;
|
||||
|
||||
ARTICLE: "html.templates.chloe.tags.component" "Component Chloe tags"
|
||||
"The following Chloe tags correspond exactly to " { $link "html.components" } ". Singleton component tags do not allow any attributes. Attributes of tuple component tags are mapped to tuple slot values of the component instance."
|
||||
{ $table
|
||||
{ "Tag" "Component class" }
|
||||
{ { $snippet "t:checkbox" } { $link checkbox } }
|
||||
{ { $snippet "t:choice" } { $link choice } }
|
||||
{ { $snippet "t:code" } { $link code } }
|
||||
{ { $snippet "t:comparison" } { $link comparison } }
|
||||
{ { $snippet "t:farkup" } { $link farkup } }
|
||||
{ { $snippet "t:field" } { $link field } }
|
||||
{ { $snippet "t:hidden" } { $link hidden } }
|
||||
{ { $snippet "t:html" } { $link html } }
|
||||
{ { $snippet "t:inspector" } { $link inspector } }
|
||||
{ { $snippet "t:label" } { $link label } }
|
||||
{ { $snippet "t:link" } { $link link } }
|
||||
{ { $snippet "t:password" } { $link password } }
|
||||
{ { $snippet "t:textarea" } { $link textarea } }
|
||||
} ;
|
||||
|
||||
ARTICLE: "html.templates.chloe.tags.boilerplate" "Boilerplate Chloe tags"
|
||||
"The following Chloe tags interface with the HTML templating " { $link "html.templates.boilerplate" } "."
|
||||
$nl
|
||||
"The tags marked with (*) are only available if the " { $vocab-link "furnace.chloe-tags" } " vocabulary is loaded."
|
||||
{ $table
|
||||
{ { $snippet "t:title" } "Sets the title from a child template" }
|
||||
{ { $snippet "t:write-title" } "Renders the child's title from a master template" }
|
||||
{ { $snippet "t:style" } "Adds CSS markup from a child template" }
|
||||
{ { $snippet "t:write-style" } "Renders the children's CSS from a master template" }
|
||||
{ { $snippet "t:atom" } "Adds an Atom feed link from a child template (*)" }
|
||||
{ { $snippet "t:write-atom" } "Renders the children's list of Atom feed links (*)" }
|
||||
{ { $snippet "t:call-next-template" } "Calls the child template from a master template" }
|
||||
} ;
|
||||
|
||||
ARTICLE: "html.templates.chloe.tags.control" "Control-flow Chloe tags"
|
||||
"While most control flow and logic should be embedded in the web actions themselves and not in the template, Chloe templates do support a minimal amount of control flow."
|
||||
{ $table
|
||||
{ { $snippet "t:comment" } "All markup within a comment tag is ignored by the compiler." }
|
||||
{ { $snippet "t:bind" } { "Renders child content bound to a nested form named by the " { $snippet "t:name" } " attribute. See " { $link with-form } "." } }
|
||||
{ { $snippet "t:each" } { "Renders child content once for each element of the sequence in the value named by the " { $snippet "t:name" } " attribute. The sequence element and index are bound to the " { $snippet "value" } " and " { $snippet "index" } " values, respectively. See " { $link with-each-value } "." } }
|
||||
{ { $snippet "t:bind-each" } { "Renders child content once for each element of the sequence in the value named by the " { $snippet "t:name" } " attribute. The sequence element's slots are bound to values. See " { $link with-each-object } "." } }
|
||||
{ { $snippet "t:even" } { "Only valid inside a " { $snippet "t:each" } " or " { $snippet "t:bind-each" } ". Only renders child content if the " { $snippet "index" } " value is even." } }
|
||||
{ { $snippet "t:odd" } "As above, but only if the index value is odd." }
|
||||
{ { $snippet "t:if" } { "Renders child content if a boolean condition evaluates to true. The condition value is determined by the " { $snippet "t:code" } " or " { $snippet "t:value" } " attribute, exactly one of which must be specified. The former is a string of the form " { $snippet "vocabulary:word" } " denoting a word to execute with stack effect " { $snippet "( -- ? )" } ". The latter is a value name." } }
|
||||
} ;
|
||||
|
||||
ARTICLE: "html.templates.chloe.tags.form" "Chloe link and form tags"
|
||||
"The following tags are only available if the " { $vocab-link "furnace.chloe-tags" } " vocabulary is loaded."
|
||||
{ $table
|
||||
{ { $snippet "t:a" } { "Renders a link; extends the standard XHTML " { $snippet "a" } " tag by providing some integration with other web framework features. The following attributes are supported:"
|
||||
{ $list
|
||||
{ { $snippet "href" } " - a URL. If it begins with " { $snippet "$" } ", then it is interpreted as a responder-relative path." }
|
||||
{ { $snippet "rest" } " - a value to add at the end of the URL." }
|
||||
{ { $snippet "query" } " - a comma-separated list of value names defined in the current form which are to be passed to the link as query parameters." }
|
||||
{ { $snippet "value" } " - a value name holding a URL. If this attribute is specified, it overrides all others." }
|
||||
}
|
||||
"Any attributes not in the Chloe XML namespace are passed on to the generated " { $snippet "a" } " tag."
|
||||
$nl
|
||||
"An example:"
|
||||
{ $code
|
||||
"<t:a t:href=\"$wiki/view/\""
|
||||
" t:rest=\"title\""
|
||||
" class=\"small-link\">"
|
||||
" View"
|
||||
"</t:a>"
|
||||
}
|
||||
"The above might render as"
|
||||
{ $code
|
||||
"<a href=\"http://mysite.org/wiki/view/Factor\""
|
||||
" class=\"small-link\">"
|
||||
" View"
|
||||
"s</a>"
|
||||
}
|
||||
} }
|
||||
{ { $snippet "t:form" } {
|
||||
"Renders a form; extends the standard XHTML " { $snippet "form" } " tag by providing some integration with other web framework features, for example by adding hidden fields for authentication credentials and session management allowing those features to work with form submission transparently. The following attributes are supported:"
|
||||
{ $list
|
||||
{ { $snippet "t:method" } " - just like the " { $snippet "method" } " attribute of an HTML " { $snippet "form" } " tag, this can equal " { $snippet "get" } " or " { $snippet "post" } ". Unlike the HTML tag, the default is " { $snippet "post" } "." }
|
||||
{ { $snippet "t:action" } " - a URL. If it begins with " { $snippet "$" } ", then it is interpreted as a responder-relative path." }
|
||||
{ { $snippet "t:for" } " - a comma-separated list of form values which are to be inserted in the form as hidden fields. Other than being more concise, this is equivalent to nesting a series of " { $snippet "t:hidden" } " tags inside the form." }
|
||||
}
|
||||
"Any attributes not in the Chloe XML namespace are passed on to the generated " { $snippet "form" } " tag."
|
||||
} }
|
||||
{ { $snippet "t:button" } {
|
||||
"Shorthand for a form with a single button, whose label is the text child of the " { $snippet "t:button" } " tag. Attributes are processed as with the " { $snippet "t:form" } " tag, with the exception that any attributes not in the Chloe XML namespace are passed on to the generated " { $snippet "button" } " tag, rather than the " { $snippet "form" } " tag surrounding it."
|
||||
$nl
|
||||
"An example:"
|
||||
{ $code
|
||||
"<t:button t:method=\"POST\""
|
||||
" t:action=\"$wiki/delete\""
|
||||
" t:for=\"id\">"
|
||||
" class=\"link-button\""
|
||||
" Delete"
|
||||
"</t:button>"
|
||||
}
|
||||
} }
|
||||
} ;
|
||||
|
||||
ARTICLE: "html.templates.chloe.tags" "Standard Chloe tags"
|
||||
"A Chloe template is an XML file with a mix of standard XHTML and Chloe tags."
|
||||
$nl
|
||||
"XHTML tags are rendered verbatim, except attribute values which begin with " { $snippet "@" } " are replaced with the corresponding " { $link "html.forms.values" } "."
|
||||
$nl
|
||||
"Chloe tags are defined in the " { $snippet "http://factorcode.org/chloe/1.0" } " namespace; by convention, it is bound with a prefix of " { $snippet "t" } ". The top-level tag must always be the " { $snippet "t:chloe" } " tag. A typical Chloe template looks like so:"
|
||||
{ $code
|
||||
"<?xml version=\"1.0\"?>"
|
||||
""
|
||||
"<t:chloe xmlns:t=\"http://factorcode.org/chloe/1.0\">"
|
||||
" ..."
|
||||
"</t:chloe>"
|
||||
}
|
||||
{ $subsection "html.templates.chloe.tags.component" }
|
||||
{ $subsection "html.templates.chloe.tags.boilerplate" }
|
||||
{ $subsection "html.templates.chloe.tags.control" }
|
||||
{ $subsection "html.templates.chloe.tags.form" } ;
|
||||
|
||||
ARTICLE: "html.templates.chloe.extend" "Extending Chloe"
|
||||
"The " { $vocab-link "html.templates.chloe.syntax" } " and " { $vocab-link "html.templates.chloe.compiler" } " vocabularies contain the heart of the Chloe implementation."
|
||||
$nl
|
||||
"Chloe is implemented as a compiler which converts XML templates into Factor quotations. The template only has to be parsed and compiled once, and not on every HTTP request. This helps improve performance and memory usage."
|
||||
$nl
|
||||
"These vocabularies provide various hooks by which Chloe can be extended. First of all, new " { $link "html.components" } " can be wired in. If further flexibility is needed, entirely new tags can be defined by hooking into the Chloe compiler."
|
||||
{ $subsection "html.templates.chloe.extend.components" }
|
||||
{ $subsection "html.templates.chloe.extend.tags" } ;
|
||||
|
||||
ARTICLE: "html.templates.chloe.extend.tags" "Extending Chloe with custom tags"
|
||||
"Syntax for defining custom tags:"
|
||||
{ $subsection POSTPONE: CHLOE: }
|
||||
"A number of compiler words can be used from the " { $link POSTPONE: CHLOE: } " body to emit compiled template code."
|
||||
$nl
|
||||
"Extracting attributes from the XML tag:"
|
||||
{ $subsection required-attr }
|
||||
{ $subsection optional-attr }
|
||||
{ $subsection compile-attr }
|
||||
"Examining tag nesting:"
|
||||
{ $subsection tag-stack }
|
||||
"Generating code for printing strings and calling quotations:"
|
||||
{ $subsection [write] }
|
||||
{ $subsection [code] }
|
||||
"Generating code from child elements:"
|
||||
{ $subsection process-children }
|
||||
{ $subsection compile-children>string }
|
||||
{ $subsection compile-with-scope }
|
||||
"Examples which illustrate some of the above:"
|
||||
{ $subsection "html.templates.chloe.extend.tags.example" } ;
|
||||
|
||||
ARTICLE: "html.templates.chloe.extend.tags.example" "Examples of custom Chloe tags"
|
||||
"As a first example, let's develop a custom Chloe tag which simply renders a random number. The tag will be used as follows:"
|
||||
{ $code
|
||||
"<t:random t:min='10' t:max='20' t:generator='system' />"
|
||||
}
|
||||
"The " { $snippet "t:min" } " and " { $snippet "t:max" } " parameters are required, and " { $snippet "t:generator" } ", which can equal one of " { $snippet "default" } ", " { $snippet "system" } " or " { $snippet "secure" } ", is optional, with the default being " { $snippet "default" } "."
|
||||
$nl
|
||||
"Here is the " { $link POSTPONE: USING: } " form that we need for the below code to work:"
|
||||
{ $code
|
||||
"USING: combinators kernel math.parser math.ranges random"
|
||||
"html.templates.chloe.compiler html.templates.chloe.syntax ;"
|
||||
}
|
||||
"We write a word which extracts the relevant attributes from an XML tag:"
|
||||
{ $code
|
||||
": random-attrs ( tag -- min max generator )"
|
||||
" [ \"min\" required-attr string>number ]"
|
||||
" [ \"max\" required-attr string>number ]"
|
||||
" [ \"generator\" optional-attr ]"
|
||||
" tri ;"
|
||||
}
|
||||
"Next, we convert a random generator name into a random generator object:"
|
||||
{ $code
|
||||
": string>random-generator ( string -- generator )"
|
||||
" {"
|
||||
" { \"default\" [ random-generator ] }"
|
||||
" { \"system\" [ system-random-generator ] }"
|
||||
" { \"secure\" [ secure-random-generator ] }"
|
||||
" } case ;"
|
||||
}
|
||||
"Finally, we can write our Chloe tag:"
|
||||
{ $code
|
||||
"CHLOE: random"
|
||||
" random-attrs string>random-generator"
|
||||
" '["
|
||||
" _ _ _"
|
||||
" [ [a,b] random present write ]"
|
||||
" with-random-generator"
|
||||
" ] [code] ;"
|
||||
}
|
||||
"For the second example, let's develop a Chloe tag which repeatedly renders its child several times, where the number comes from a form value. The tag will be used as follows:"
|
||||
{ $code
|
||||
"<t:repeat t:times='n'>Hello world.<br /></t:repeat>"
|
||||
}
|
||||
"This time, we cannot simply extract the " { $snippet "t:times" } " attribute at compile time since its value cannot be determined then. Instead, we execute " { $link compile-attr } " to generate code which pushes the value of that attribute on the stack. We then use " { $link process-children } " to compile child elements as a nested quotation which we apply " { $link times } " to."
|
||||
{ $code
|
||||
"CHLOE: repeat"
|
||||
" [ \"times\" required-attr compile-attr ]"
|
||||
" [ [ times ] process-children ]"
|
||||
" bi ;"
|
||||
} ;
|
||||
|
||||
ARTICLE: "html.templates.chloe.extend.components.example" "An example of a custom Chloe component"
|
||||
"As an example, let's develop a custom Chloe component which renders an image stored in a form value. Since the component does not require any configuration, we can define a singleton class:"
|
||||
{ $code "SINGLETON: image" }
|
||||
"Now we define a method on the " { $link render* } " generic word which renders the image using " { $vocab-link "html.elements" } ":"
|
||||
{ $code "M: image render* 2drop <img =src img/> ;" }
|
||||
"Finally, we can define a Chloe component:"
|
||||
{ $code "CHLOE-SINGLETON: image" }
|
||||
"We can use it as follows, assuming the current form has a value named " { $snippet "image" } ":"
|
||||
{ $code "<t:image t:name='image' />" } ;
|
||||
|
||||
ARTICLE: "html.templates.chloe.extend.components" "Extending Chloe with custom components"
|
||||
"Custom HTML components implementing the " { $link render* } " word can be wired up with Chloe using the following syntax from " { $vocab-link "html.templates.chloe.components" } ":"
|
||||
{ $subsection POSTPONE: CHLOE-SINGLETON: }
|
||||
{ $subsection POSTPONE: CHLOE-TUPLE: }
|
||||
{ $subsection "html.templates.chloe.extend.components.example" } ;
|
||||
|
||||
ARTICLE: "html.templates.chloe" "Chloe templates"
|
||||
"The " { $vocab-link "html.templates.chloe" } " vocabulary implements an XHTML templating engine. Unlike " { $vocab-link "html.templates.fhtml" } ", Chloe templates are always well-formed XML, and no Factor code can be embedded in them, enforcing proper separation of concerns. Chloe templates can be edited using standard XML editing tools; they are less flexible than FHTML, but often simpler as a result."
|
||||
{ $subsection <chloe> }
|
||||
{ $subsection reset-cache }
|
||||
{ $subsection "html.templates.chloe.tags" }
|
||||
{ $subsection "html.templates.chloe.extend" } ;
|
||||
|
||||
ABOUT: "html.templates.chloe"
|
||||
|
|
@ -134,7 +134,7 @@ TUPLE: person first-name last-name ;
|
|||
|
||||
[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
|
||||
|
||||
[ "<form method='post' action='foo'><input type='hidden' name='__n' value='a'/></form>" ] [
|
||||
[ "<form method='post' action='foo'><div style='display: none;'><input type='hidden' name='__n' value='a'/></div></form>" ] [
|
||||
[
|
||||
"test10" test-template call-template
|
||||
] run-template
|
||||
|
|
|
|||
|
|
@ -37,7 +37,11 @@ CHLOE: style
|
|||
] ?if ;
|
||||
|
||||
CHLOE: write-style
|
||||
drop [ <style> write-style </style> ] [code] ;
|
||||
drop [
|
||||
<style "text/css" =type style>
|
||||
write-style
|
||||
</style>
|
||||
] [code] ;
|
||||
|
||||
CHLOE: even
|
||||
[ "index" value even? swap when ] process-children ;
|
||||
|
|
|
|||
|
|
@ -123,8 +123,8 @@ DEFER: compile-element
|
|||
|
||||
: compile-prologue ( xml -- )
|
||||
[
|
||||
[ before>> compile-chunk ]
|
||||
[ prolog>> [ write-prolog ] [code-with] ]
|
||||
[ before>> compile-chunk ]
|
||||
bi
|
||||
] compile-quot
|
||||
[ if-not-nested ] [code] ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
XHTML templating engine with extensible compiler and separation of concerns
|
||||
|
|
@ -0,0 +1 @@
|
|||
web
|
||||
|
|
@ -1,2 +1,2 @@
|
|||
Slava Pestov
|
||||
Matthew Willis
|
||||
Alex Chapman
|
||||
|
|
|
|||
|
|
@ -0,0 +1,14 @@
|
|||
IN: html.templates.fhtml
|
||||
USING: help.markup help.syntax ;
|
||||
|
||||
HELP: <fhtml> ;
|
||||
|
||||
ARTICLE: "html.templates.fhtml" "FHTML templates"
|
||||
"The " { $vocab-link "html.templates.fhtml" } " vocabulary implements a templating engine which mixes markup with Factor code."
|
||||
$nl
|
||||
"FHTML provides an alternative to " { $vocab-link "html.templates.chloe" } " for situations where complex logic must be embedded in the presentation layer of a web application. While this is discouraged for larger applications, it is useful for prototyping as well as simpler applications."
|
||||
$nl
|
||||
"The entire syntax of an FHTML template can be summarized as thus: text outside of " { $snippet "<%" } " and " { $snippet "%>" } " is rendered literally. Text inside " { $snippet "<%" } " and " { $snippet "%>" } " is interpreted as Factor source code."
|
||||
{ $subsection <fhtml> } ;
|
||||
|
||||
ABOUT: "html.templates.fhtml"
|
||||
|
|
@ -0,0 +1 @@
|
|||
Simple templating engine mixing Factor code with content
|
||||
|
|
@ -0,0 +1 @@
|
|||
web
|
||||
|
|
@ -0,0 +1 @@
|
|||
HTML templating engine interface
|
||||
|
|
@ -0,0 +1 @@
|
|||
web
|
||||
|
|
@ -0,0 +1,89 @@
|
|||
IN: html.templates
|
||||
USING: help.markup help.syntax io strings quotations xml.data
|
||||
continuations urls ;
|
||||
|
||||
HELP: template
|
||||
{ $class-description "The class of HTML templates." } ;
|
||||
|
||||
HELP: call-template*
|
||||
{ $values { "template" template } }
|
||||
{ $contract "Writes a template to " { $link output-stream } ", possibly using " { $vocab-link "html.forms" } " state."
|
||||
$nl
|
||||
"In addition to methods added by other vocabularies, this generic word has methods on the following classes:"
|
||||
{ $list
|
||||
{ { $link string } " - the simplest type of template; simply written to " { $link output-stream } }
|
||||
{ { $link callable } " - a custom quotation, called to yield output" }
|
||||
{ { $link xml } " - written to " { $link output-stream } }
|
||||
{ "an input stream - copied to " { $link output-stream } }
|
||||
} } ;
|
||||
|
||||
HELP: call-template
|
||||
{ $values { "template" template } }
|
||||
{ $description "Writes a template to " { $link output-stream } ", possibly using " { $vocab-link "html.forms" } " state."
|
||||
$nl
|
||||
"This word calls " { $link call-template* } ", wrapping it in a " { $link recover } " form which improves error reporting by combining the underlying error with the template object." } ;
|
||||
|
||||
HELP: set-title
|
||||
{ $values { "string" string } }
|
||||
{ $description "Sets the title of the current page. This is usually called by child templates, and a master template calls " { $link write-title } "." } ;
|
||||
|
||||
HELP: write-title
|
||||
{ $values { "string" string } }
|
||||
{ $description "Writes the title of the current page, previously set by " { $link set-title } ". This is usually called by a master template after rendering a child template." } ;
|
||||
|
||||
HELP: add-style
|
||||
{ $values { "string" string } }
|
||||
{ $description "Adds some CSS markup to the CSS stylesheet of a master template. Usually called by child templates which need to insert CSS style information in the " { $snippet "<head>" } " tag of the resulting HTML page." } ;
|
||||
|
||||
HELP: write-style
|
||||
{ $description "Writes a CSS stylesheet assembled from " { $link add-style } " calls by child templates. Usually called by the master template to emit a CSS style in the " { $snippet "<head>" } " tag of the resulting HTML page." } ;
|
||||
|
||||
HELP: add-atom-feed
|
||||
{ $values { "title" string } { "url" "a " { $link string } " or " { $link url } } }
|
||||
{ $description "Adds an Atom feed link to the list of feeds in a master template. Usually called by child templates which need to insert an Atom feed link information in the " { $snippet "<head>" } " tag of the resulting HTML page." } ;
|
||||
|
||||
HELP: write-atom-feeds
|
||||
{ $description "Writes a list of Atom feed links assembled from " { $link add-atom-feed } " calls by child templates. Usually called by the master template to emit a list of Atom feed links in the " { $snippet "<head>" } " tag of the resulting HTML page." } ;
|
||||
|
||||
HELP: nested-template?
|
||||
{ $var-description "Set to a true value if the current call to " { $link call-template } " is nested inside a " { $link with-boilerplate } " and will therefore appear as part of another template. In this case, XML processing instructions and document type declarations should be omitted." } ;
|
||||
|
||||
HELP: call-next-template
|
||||
{ $description "Calls the next innermost child template from a master template. This is used to implement the " { $snippet "t:call-next-template" } " tag in the " { $vocab-link "html.templates.chloe" } " templating engine." } ;
|
||||
|
||||
HELP: with-boilerplate
|
||||
{ $values { "child" template } { "master" template } }
|
||||
{ $description "Calls the child template, storing its output in a string, then calls the master template. The master template may call " { $link call-next-template } " to insert the output of the child template at any point; both templates may also use the master/child interface words documented in " { $link "html.templates.boilerplate" } "." } ;
|
||||
|
||||
HELP: template-convert
|
||||
{ $values { "template" template } { "output" "a pathname string" } }
|
||||
{ $description "Calls the template and writes its output to a file with UTF8 encoding." } ;
|
||||
|
||||
ARTICLE: "html.templates.boilerplate" "Boilerplate support"
|
||||
"The following words define the interface between a templating engine and the " { $vocab-link "furnace.boilerplate" } " vocabulary."
|
||||
$nl
|
||||
"The master/child template interface follows a pattern where for each concept there is a word called by the child to store an entity, and another word to write the entity out; this solves the problem where certain HTML tags, such as " { $snippet "<title>" } " and " { $snippet "<link>" } " must appear inside the " { $snippet "<head>" } " tag, even though those tags are usually precisely those that the child template will want to set."
|
||||
{ $subsection set-title }
|
||||
{ $subsection write-title }
|
||||
{ $subsection add-style }
|
||||
{ $subsection write-style }
|
||||
{ $subsection add-atom-feed }
|
||||
{ $subsection write-atom-feeds }
|
||||
"Processing a master template with a child:"
|
||||
{ $subsection with-boilerplate }
|
||||
{ $subsection call-next-template } ;
|
||||
|
||||
ARTICLE: "html.templates" "HTML template interface"
|
||||
"The " { $vocab-link "html.templates" } " vocabulary implements an abstract interface to HTML templating engines. The " { $vocab-link "html.templates.fhtml" } " and " { $vocab-link "html.templates.chloe" } " vocabularies are two implementations of this."
|
||||
$nl
|
||||
"An HTML template is an instance of a mixin:"
|
||||
{ $subsection template }
|
||||
"HTML templates must also implement a method on a generic word:"
|
||||
{ $subsection call-template* }
|
||||
"Calling an HTML template:"
|
||||
{ $subsection call-template }
|
||||
"Usually HTML templates are invoked dynamically by the Furnace web framework and HTTP server. They can also be used in static HTML generation tools:"
|
||||
{ $subsection template-convert }
|
||||
{ $subsection "html.templates.boilerplate" } ;
|
||||
|
||||
ABOUT: "html.templates"
|
||||
|
|
@ -67,7 +67,7 @@ SYMBOL: next-template
|
|||
|
||||
M: f call-template* drop call-next-template ;
|
||||
|
||||
: with-boilerplate ( body template -- )
|
||||
: with-boilerplate ( child master -- )
|
||||
[
|
||||
title [ <box> or ] change
|
||||
style [ SBUF" " clone or ] change
|
||||
|
|
|
|||
|
|
@ -15,35 +15,39 @@ namespaces tools.test present kernel ;
|
|||
>>url
|
||||
request set
|
||||
|
||||
[ "http://www.apple.com:80/xxx/bar" ] [
|
||||
[ "http://www.apple.com/xxx/bar" ] [
|
||||
<url> relative-to-request present
|
||||
] unit-test
|
||||
|
||||
[ "http://www.apple.com:80/xxx/baz" ] [
|
||||
[ "http://www.apple.com/xxx/baz" ] [
|
||||
<url> "baz" >>path relative-to-request present
|
||||
] unit-test
|
||||
|
||||
[ "http://www.apple.com:80/xxx/baz?c=d" ] [
|
||||
[ "http://www.apple.com/xxx/baz?c=d" ] [
|
||||
<url> "baz" >>path { { "c" "d" } } >>query relative-to-request present
|
||||
] unit-test
|
||||
|
||||
[ "http://www.apple.com:80/xxx/bar?c=d" ] [
|
||||
[ "http://www.apple.com/xxx/bar?c=d" ] [
|
||||
<url> { { "c" "d" } } >>query relative-to-request present
|
||||
] unit-test
|
||||
|
||||
[ "http://www.apple.com:80/flip" ] [
|
||||
[ "http://www.apple.com/flip" ] [
|
||||
<url> "/flip" >>path relative-to-request present
|
||||
] unit-test
|
||||
|
||||
[ "http://www.apple.com:80/flip?c=d" ] [
|
||||
[ "http://www.apple.com/flip?c=d" ] [
|
||||
<url> "/flip" >>path { { "c" "d" } } >>query relative-to-request present
|
||||
] unit-test
|
||||
|
||||
[ "http://www.jedit.org:80/" ] [
|
||||
[ "http://www.jedit.org/" ] [
|
||||
"http://www.jedit.org" >url relative-to-request present
|
||||
] unit-test
|
||||
|
||||
[ "http://www.jedit.org:80/?a=b" ] [
|
||||
[ "http://www.jedit.org/?a=b" ] [
|
||||
"http://www.jedit.org" >url { { "a" "b" } } >>query relative-to-request present
|
||||
] unit-test
|
||||
|
||||
[ "http://www.jedit.org:1234/?a=b" ] [
|
||||
"http://www.jedit.org:1234" >url { { "a" "b" } } >>query relative-to-request present
|
||||
] unit-test
|
||||
] with-scope
|
||||
|
|
|
|||
|
|
@ -0,0 +1,12 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces assocs kernel io.servers.connection ;
|
||||
IN: http.server.remapping
|
||||
|
||||
SYMBOL: port-remapping
|
||||
|
||||
: remap-port ( n -- n' )
|
||||
[ port-remapping get at ] keep or ;
|
||||
|
||||
: secure-http-port ( -- n )
|
||||
secure-port remap-port ;
|
||||
|
|
@ -18,6 +18,7 @@ fry logging logging.insomniac calendar urls
|
|||
http
|
||||
http.parsers
|
||||
http.server.responses
|
||||
http.server.remapping
|
||||
html.templates
|
||||
html.elements
|
||||
html.streams ;
|
||||
|
|
@ -198,19 +199,20 @@ LOG: httpd-header NOTICE
|
|||
[
|
||||
local-address get
|
||||
[ secure? "https" "http" ? >>protocol ]
|
||||
[ port>> '[ _ or ] change-port ]
|
||||
[ port>> remap-port '[ _ or ] change-port ]
|
||||
bi
|
||||
] change-url drop ;
|
||||
|
||||
: valid-request? ( request -- ? )
|
||||
url>> port>> local-address get port>> = ;
|
||||
url>> port>> remap-port
|
||||
local-address get port>> remap-port = ;
|
||||
|
||||
: do-request ( request -- response )
|
||||
'[
|
||||
_
|
||||
{
|
||||
[ init-request ]
|
||||
[ prepare-request ]
|
||||
[ init-request ]
|
||||
[ log-request ]
|
||||
[ dup valid-request? [ dispatch-request ] [ drop <400> ] if ]
|
||||
} cleave
|
||||
|
|
|
|||
|
|
@ -2,10 +2,10 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: continuations destructors kernel math math.parser
|
||||
namespaces parser sequences strings prettyprint debugger
|
||||
quotations combinators logging calendar assocs
|
||||
quotations combinators logging calendar assocs present
|
||||
fry accessors arrays io io.sockets io.encodings.ascii
|
||||
io.sockets.secure io.files io.streams.duplex io.timeouts
|
||||
io.encodings threads concurrency.combinators
|
||||
io.encodings threads make concurrency.combinators
|
||||
concurrency.semaphores concurrency.flags
|
||||
combinators.short-circuit ;
|
||||
IN: io.servers.connection
|
||||
|
|
@ -56,11 +56,17 @@ GENERIC: handle-client* ( threaded-server -- )
|
|||
[ secure>> >secure ] [ insecure>> >insecure ] bi
|
||||
[ resolve-host ] bi@ append ;
|
||||
|
||||
LOG: accepted-connection NOTICE
|
||||
: accepted-connection ( remote local -- )
|
||||
[
|
||||
[ "remote: " % present % ", " % ]
|
||||
[ "local: " % present % ]
|
||||
bi*
|
||||
] "" make
|
||||
\ accepted-connection NOTICE log-message ;
|
||||
|
||||
: log-connection ( remote local -- )
|
||||
[ accepted-connection ]
|
||||
[ [ remote-address set ] [ local-address set ] bi* ]
|
||||
[ 2array accepted-connection ]
|
||||
2bi ;
|
||||
|
||||
M: threaded-server handle-client* handler>> call ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel symbols namespaces continuations
|
||||
destructors io.sockets sequences summary calendar delegate
|
||||
system vocabs.loader combinators ;
|
||||
system vocabs.loader combinators present ;
|
||||
IN: io.sockets.secure
|
||||
|
||||
SYMBOL: secure-socket-timeout
|
||||
|
|
@ -43,6 +43,8 @@ TUPLE: secure addrspec ;
|
|||
|
||||
C: <secure> secure
|
||||
|
||||
M: secure present addrspec>> present " (secure)" append ;
|
||||
|
||||
CONSULT: inet secure addrspec>> ;
|
||||
|
||||
M: secure resolve-host ( secure -- seq )
|
||||
|
|
|
|||
|
|
@ -5,8 +5,8 @@ USING: generic kernel io.backend namespaces continuations
|
|||
sequences arrays io.encodings io.ports io.streams.duplex
|
||||
io.encodings.ascii alien.strings io.binary accessors destructors
|
||||
classes debugger byte-arrays system combinators parser
|
||||
alien.c-types math.parser splitting grouping
|
||||
math assocs summary system vocabs.loader combinators ;
|
||||
alien.c-types math.parser splitting grouping math assocs summary
|
||||
system vocabs.loader combinators present ;
|
||||
IN: io.sockets
|
||||
|
||||
<< {
|
||||
|
|
@ -40,7 +40,14 @@ TUPLE: local path ;
|
|||
: <local> ( path -- addrspec )
|
||||
normalize-path local boa ;
|
||||
|
||||
TUPLE: inet4 host port ;
|
||||
M: local present path>> "Unix domain socket: " prepend ;
|
||||
|
||||
TUPLE: abstract-inet host port ;
|
||||
|
||||
M: abstract-inet present
|
||||
[ host>> ":" ] [ port>> number>string ] bi 3append ;
|
||||
|
||||
TUPLE: inet4 < abstract-inet ;
|
||||
|
||||
C: <inet4> inet4
|
||||
|
||||
|
|
@ -81,7 +88,7 @@ M: inet4 parse-sockaddr
|
|||
>r dup sockaddr-in-addr <uint> r> inet-ntop
|
||||
swap sockaddr-in-port ntohs <inet4> ;
|
||||
|
||||
TUPLE: inet6 host port ;
|
||||
TUPLE: inet6 < abstract-inet ;
|
||||
|
||||
C: <inet6> inet6
|
||||
|
||||
|
|
@ -255,7 +262,7 @@ HOOK: addrinfo-error io-backend ( n -- )
|
|||
|
||||
GENERIC: resolve-host ( addrspec -- seq )
|
||||
|
||||
TUPLE: inet host port ;
|
||||
TUPLE: inet < abstract-inet ;
|
||||
|
||||
C: <inet> inet
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Generalization of make for constructing several sequences simultaneously
|
||||
|
|
@ -0,0 +1 @@
|
|||
collections
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1 @@
|
|||
Generic word for converting objects to strings for human consumption
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
Doug Coleman
|
||||
Slava Pestov
|
||||
|
|
@ -0,0 +1 @@
|
|||
Random number generator protocol and implementations
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -25,7 +25,7 @@ IN: regexp.dfa
|
|||
|
||||
: find-transitions ( seq1 regexp -- seq2 )
|
||||
nfa-table>> transitions>>
|
||||
[ at keys ] curry map concat
|
||||
[ at keys ] curry gather
|
||||
eps swap remove ;
|
||||
|
||||
: add-todo-state ( state regexp -- )
|
||||
|
|
@ -68,12 +68,16 @@ IN: regexp.dfa
|
|||
1vector >>new-states drop ;
|
||||
|
||||
: set-traversal-flags ( regexp -- )
|
||||
[ dfa-table>> transitions>> keys ]
|
||||
dup
|
||||
[ nfa-traversal-flags>> ]
|
||||
bi 2drop ;
|
||||
[ dfa-table>> transitions>> keys ] bi
|
||||
[ tuck [ swap at ] with map concat ] with H{ } map>assoc
|
||||
>>dfa-traversal-flags drop ;
|
||||
|
||||
: construct-dfa ( regexp -- )
|
||||
[ set-initial-state ]
|
||||
[ new-transitions ]
|
||||
[ set-final-states ] tri ;
|
||||
! [ set-traversal-flags ] quad ;
|
||||
{
|
||||
[ set-initial-state ]
|
||||
[ new-transitions ]
|
||||
[ set-final-states ]
|
||||
[ set-traversal-flags ]
|
||||
} cleave ;
|
||||
|
|
@ -14,6 +14,8 @@ SINGLETON: eps
|
|||
MIXIN: traversal-flag
|
||||
SINGLETON: lookahead-on INSTANCE: lookahead-on traversal-flag
|
||||
SINGLETON: lookahead-off INSTANCE: lookahead-off traversal-flag
|
||||
SINGLETON: lookbehind-on INSTANCE: lookbehind-on traversal-flag
|
||||
SINGLETON: lookbehind-off INSTANCE: lookbehind-off traversal-flag
|
||||
SINGLETON: capture-group-on INSTANCE: capture-group-on traversal-flag
|
||||
SINGLETON: capture-group-off INSTANCE: capture-group-off traversal-flag
|
||||
|
||||
|
|
@ -119,7 +121,12 @@ M: character-class-range nfa-node ( node -- )
|
|||
class-transition add-simple-entry ;
|
||||
|
||||
M: capture-group nfa-node ( node -- )
|
||||
term>> nfa-node ;
|
||||
eps literal-transition add-simple-entry
|
||||
capture-group-on add-traversal-flag
|
||||
term>> nfa-node
|
||||
eps literal-transition add-simple-entry
|
||||
capture-group-off add-traversal-flag
|
||||
2 [ concatenate-nodes ] times ;
|
||||
|
||||
! xyzzy
|
||||
M: non-capture-group nfa-node ( node -- )
|
||||
|
|
@ -143,6 +150,14 @@ M: lookahead nfa-node ( node -- )
|
|||
lookahead-off add-traversal-flag
|
||||
2 [ concatenate-nodes ] times ;
|
||||
|
||||
M: lookbehind nfa-node ( node -- )
|
||||
eps literal-transition add-simple-entry
|
||||
lookbehind-on add-traversal-flag
|
||||
term>> nfa-node
|
||||
eps literal-transition add-simple-entry
|
||||
lookbehind-off add-traversal-flag
|
||||
2 [ concatenate-nodes ] times ;
|
||||
|
||||
: construct-nfa ( regexp -- )
|
||||
[
|
||||
reset-regexp
|
||||
|
|
@ -1,10 +1,10 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs combinators io io.streams.string
|
||||
kernel math math.parser multi-methods namespaces qualified sets
|
||||
kernel math math.parser namespaces qualified sets
|
||||
quotations sequences splitting symbols vectors math.order
|
||||
unicode.categories strings regexp.backend regexp.utils
|
||||
unicode.case ;
|
||||
unicode.case words ;
|
||||
IN: regexp.parser
|
||||
|
||||
FROM: math.ranges => [a,b] ;
|
||||
|
|
@ -25,11 +25,21 @@ TUPLE: reluctant-kleene-star term ; INSTANCE: reluctant-kleene-star node
|
|||
TUPLE: negation term ; INSTANCE: negation node
|
||||
TUPLE: constant char ; INSTANCE: constant node
|
||||
TUPLE: range from to ; INSTANCE: range node
|
||||
|
||||
MIXIN: parentheses-group
|
||||
TUPLE: lookahead term ; INSTANCE: lookahead node
|
||||
INSTANCE: lookahead parentheses-group
|
||||
TUPLE: lookbehind term ; INSTANCE: lookbehind node
|
||||
INSTANCE: lookbehind parentheses-group
|
||||
TUPLE: capture-group term ; INSTANCE: capture-group node
|
||||
INSTANCE: capture-group parentheses-group
|
||||
TUPLE: non-capture-group term ; INSTANCE: non-capture-group node
|
||||
INSTANCE: non-capture-group parentheses-group
|
||||
TUPLE: independent-group term ; INSTANCE: independent-group node ! atomic group
|
||||
INSTANCE: independent-group parentheses-group
|
||||
TUPLE: comment-group term ; INSTANCE: comment-group node
|
||||
INSTANCE: comment-group parentheses-group
|
||||
|
||||
TUPLE: character-class-range from to ; INSTANCE: character-class-range node
|
||||
SINGLETON: epsilon INSTANCE: epsilon node
|
||||
SINGLETON: any-char INSTANCE: any-char node
|
||||
|
|
@ -98,25 +108,6 @@ left-parenthesis pipe caret dash ;
|
|||
|
||||
ERROR: unmatched-parentheses ;
|
||||
|
||||
: make-positive-lookahead ( string -- )
|
||||
lookahead boa push-stack ;
|
||||
|
||||
: make-negative-lookahead ( string -- )
|
||||
<negation> lookahead boa push-stack ;
|
||||
|
||||
: make-independent-group ( string -- )
|
||||
#! no backtracking
|
||||
independent-group boa push-stack ;
|
||||
|
||||
: make-positive-lookbehind ( string -- )
|
||||
lookbehind boa push-stack ;
|
||||
|
||||
: make-negative-lookbehind ( string -- )
|
||||
<negation> lookbehind boa push-stack ;
|
||||
|
||||
: make-non-capturing-group ( string -- )
|
||||
non-capture-group boa push-stack ;
|
||||
|
||||
ERROR: bad-option ch ;
|
||||
|
||||
: option ( ch -- singleton )
|
||||
|
|
@ -141,35 +132,35 @@ ERROR: bad-option ch ;
|
|||
: parse-options ( string -- )
|
||||
"-" split1 [ t (parse-options) ] [ f (parse-options) ] bi* ;
|
||||
|
||||
DEFER: (parse-regexp)
|
||||
: parse-special-group ( -- )
|
||||
beginning-of-group push-stack
|
||||
(parse-regexp) pop-stack make-non-capturing-group ;
|
||||
|
||||
ERROR: bad-special-group string ;
|
||||
|
||||
DEFER: nested-parse-regexp
|
||||
DEFER: (parse-regexp)
|
||||
: nested-parse-regexp ( token ? -- )
|
||||
[ push-stack (parse-regexp) pop-stack ] dip
|
||||
[ <negation> ] when pop-stack boa push-stack ;
|
||||
|
||||
! non-capturing groups
|
||||
: (parse-special-group) ( -- )
|
||||
read1 {
|
||||
{ [ dup CHAR: # = ]
|
||||
[ drop nested-parse-regexp pop-stack drop ] }
|
||||
{ [ dup CHAR: # = ] ! comment
|
||||
[ drop comment-group f nested-parse-regexp pop-stack drop ] }
|
||||
{ [ dup CHAR: : = ]
|
||||
[ drop nested-parse-regexp pop-stack make-non-capturing-group ] }
|
||||
[ drop non-capture-group f nested-parse-regexp ] }
|
||||
{ [ dup CHAR: = = ]
|
||||
[ drop nested-parse-regexp pop-stack make-positive-lookahead ] }
|
||||
[ drop lookahead f nested-parse-regexp ] }
|
||||
{ [ dup CHAR: ! = ]
|
||||
[ drop nested-parse-regexp pop-stack make-negative-lookahead ] }
|
||||
[ drop lookahead t nested-parse-regexp ] }
|
||||
{ [ dup CHAR: > = ]
|
||||
[ drop nested-parse-regexp pop-stack make-independent-group ] }
|
||||
[ drop non-capture-group f nested-parse-regexp ] }
|
||||
{ [ dup CHAR: < = peek1 CHAR: = = and ]
|
||||
[ drop drop1 nested-parse-regexp pop-stack make-positive-lookbehind ] }
|
||||
[ drop drop1 lookbehind f nested-parse-regexp ] }
|
||||
{ [ dup CHAR: < = peek1 CHAR: ! = and ]
|
||||
[ drop drop1 nested-parse-regexp pop-stack make-negative-lookbehind ] }
|
||||
[ drop drop1 lookbehind t nested-parse-regexp ] }
|
||||
[
|
||||
":)" read-until
|
||||
[ swap prefix ] dip
|
||||
{
|
||||
{ CHAR: : [ parse-options parse-special-group ] }
|
||||
{ CHAR: : [ parse-options non-capture-group f nested-parse-regexp ] }
|
||||
{ CHAR: ) [ parse-options ] }
|
||||
[ drop bad-special-group ]
|
||||
} case
|
||||
|
|
@ -179,7 +170,7 @@ DEFER: nested-parse-regexp
|
|||
: handle-left-parenthesis ( -- )
|
||||
peek1 CHAR: ? =
|
||||
[ drop1 (parse-special-group) ]
|
||||
[ nested-parse-regexp ] if ;
|
||||
[ capture-group f nested-parse-regexp ] if ;
|
||||
|
||||
: handle-dot ( -- ) any-char push-stack ;
|
||||
: handle-pipe ( -- ) pipe push-stack ;
|
||||
|
|
@ -239,8 +230,18 @@ ERROR: invalid-range a b ;
|
|||
[ [ nip at-most-n ] [ at-least-n ] if* ] if
|
||||
] [ drop 0 max exactly-n ] if ;
|
||||
|
||||
SINGLETON: beginning-of-input
|
||||
SINGLETON: end-of-input
|
||||
|
||||
! : beginning-of-input ( -- obj )
|
||||
: handle-front-anchor ( -- ) front-anchor push-stack ;
|
||||
: handle-back-anchor ( -- ) back-anchor push-stack ;
|
||||
: end-of-line ( -- obj )
|
||||
end-of-input
|
||||
CHAR: \r <constant>
|
||||
CHAR: \n <constant>
|
||||
2dup 2array <concatenation> 4array <alternation> lookahead boa ;
|
||||
|
||||
: handle-back-anchor ( -- ) end-of-line push-stack ;
|
||||
|
||||
ERROR: bad-character-class obj ;
|
||||
ERROR: expected-posix-class ;
|
||||
|
|
@ -286,6 +287,8 @@ ERROR: unrecognized-escape char ;
|
|||
read1
|
||||
{
|
||||
{ CHAR: \ [ CHAR: \ <constant> ] }
|
||||
{ CHAR: ^ [ CHAR: ^ <constant> ] }
|
||||
{ CHAR: $ [ CHAR: $ <constant> ] }
|
||||
{ CHAR: - [ CHAR: - <constant> ] }
|
||||
{ CHAR: { [ CHAR: { <constant> ] }
|
||||
{ CHAR: } [ CHAR: } <constant> ] }
|
||||
|
|
@ -298,7 +301,6 @@ ERROR: unrecognized-escape char ;
|
|||
{ CHAR: + [ CHAR: + <constant> ] }
|
||||
{ CHAR: ? [ CHAR: ? <constant> ] }
|
||||
{ CHAR: . [ CHAR: . <constant> ] }
|
||||
! xyzzy
|
||||
{ CHAR: : [ CHAR: : <constant> ] }
|
||||
{ CHAR: t [ CHAR: \t <constant> ] }
|
||||
{ CHAR: n [ CHAR: \n <constant> ] }
|
||||
|
|
@ -306,8 +308,6 @@ ERROR: unrecognized-escape char ;
|
|||
{ CHAR: f [ HEX: c <constant> ] }
|
||||
{ CHAR: a [ HEX: 7 <constant> ] }
|
||||
{ CHAR: e [ HEX: 1b <constant> ] }
|
||||
{ CHAR: $ [ CHAR: $ <constant> ] }
|
||||
{ CHAR: ^ [ CHAR: ^ <constant> ] }
|
||||
|
||||
{ CHAR: d [ digit-class ] }
|
||||
{ CHAR: D [ digit-class <negation> ] }
|
||||
|
|
@ -329,16 +329,16 @@ ERROR: unrecognized-escape char ;
|
|||
! { CHAR: G [ end of previous match ] }
|
||||
! { CHAR: Z [ handle-end-of-input ] }
|
||||
! { CHAR: z [ handle-end-of-input ] } ! except for terminator
|
||||
! xyzzy
|
||||
{ CHAR: 1 [ CHAR: 1 <constant> ] }
|
||||
{ CHAR: 2 [ CHAR: 2 <constant> ] }
|
||||
{ CHAR: 3 [ CHAR: 3 <constant> ] }
|
||||
{ CHAR: 4 [ CHAR: 4 <constant> ] }
|
||||
{ CHAR: 5 [ CHAR: 5 <constant> ] }
|
||||
{ CHAR: 6 [ CHAR: 6 <constant> ] }
|
||||
{ CHAR: 7 [ CHAR: 7 <constant> ] }
|
||||
{ CHAR: 8 [ CHAR: 8 <constant> ] }
|
||||
{ CHAR: 9 [ CHAR: 9 <constant> ] }
|
||||
|
||||
! { CHAR: 1 [ CHAR: 1 <constant> ] }
|
||||
! { CHAR: 2 [ CHAR: 2 <constant> ] }
|
||||
! { CHAR: 3 [ CHAR: 3 <constant> ] }
|
||||
! { CHAR: 4 [ CHAR: 4 <constant> ] }
|
||||
! { CHAR: 5 [ CHAR: 5 <constant> ] }
|
||||
! { CHAR: 6 [ CHAR: 6 <constant> ] }
|
||||
! { CHAR: 7 [ CHAR: 7 <constant> ] }
|
||||
! { CHAR: 8 [ CHAR: 8 <constant> ] }
|
||||
! { CHAR: 9 [ CHAR: 9 <constant> ] }
|
||||
|
||||
{ CHAR: Q [ parse-escaped-literals ] }
|
||||
[ unrecognized-escape ]
|
||||
|
|
@ -408,15 +408,17 @@ DEFER: handle-left-bracket
|
|||
[ first|concatenation ] map first|alternation ;
|
||||
|
||||
: handle-right-parenthesis ( -- )
|
||||
stack beginning-of-group over last-index cut rest
|
||||
[ current-regexp get swap >>stack drop ]
|
||||
[ finish-regexp-parse <capture-group> push-stack ] bi* ;
|
||||
stack dup [ parentheses-group "members" word-prop member? ] find-last -rot cut rest
|
||||
[ [ push ] keep current-regexp get (>>stack) ]
|
||||
[ finish-regexp-parse push-stack ] bi* ;
|
||||
|
||||
: nested-parse-regexp ( -- )
|
||||
beginning-of-group push-stack (parse-regexp) ;
|
||||
|
||||
: ((parse-regexp)) ( token -- ? )
|
||||
: parse-regexp-token ( token -- ? )
|
||||
{
|
||||
! todo: only match these at beginning/end of regexp
|
||||
{ CHAR: ^ [ handle-front-anchor t ] }
|
||||
{ CHAR: $ [ handle-back-anchor t ] }
|
||||
|
||||
{ CHAR: . [ handle-dot t ] }
|
||||
{ CHAR: ( [ handle-left-parenthesis t ] }
|
||||
{ CHAR: ) [ handle-right-parenthesis f ] }
|
||||
|
|
@ -426,14 +428,12 @@ DEFER: handle-left-bracket
|
|||
{ CHAR: + [ handle-plus t ] }
|
||||
{ CHAR: { [ handle-left-brace t ] }
|
||||
{ CHAR: [ [ handle-left-bracket t ] }
|
||||
{ CHAR: ^ [ handle-front-anchor t ] }
|
||||
{ CHAR: $ [ handle-back-anchor t ] }
|
||||
{ CHAR: \ [ handle-escape t ] }
|
||||
[ <constant> push-stack t ]
|
||||
} case ;
|
||||
|
||||
: (parse-regexp) ( -- )
|
||||
read1 [ ((parse-regexp)) [ (parse-regexp) ] when ] when* ;
|
||||
read1 [ parse-regexp-token [ (parse-regexp) ] when ] when* ;
|
||||
|
||||
: parse-regexp ( regexp -- )
|
||||
dup current-regexp [
|
||||
|
|
@ -251,8 +251,8 @@ IN: regexp-tests
|
|||
! [ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
|
||||
! [ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
|
||||
|
||||
! [ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-head ] unit-test
|
||||
! [ f ] [ "foobxr" "foo(?=bar)" <regexp> match-head ] unit-test
|
||||
[ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-head ] unit-test
|
||||
[ f ] [ "foobxr" "foo(?=bar)" <regexp> match-head ] unit-test
|
||||
|
||||
! [ f ] [ "foobxr" "foo\\z" <regexp> match-head ] unit-test
|
||||
! [ 3 ] [ "foo" "foo\\z" <regexp> match-head ] unit-test
|
||||
|
|
@ -285,3 +285,50 @@ IN: regexp-tests
|
|||
! 2. (A)
|
||||
! 3. (B(C))
|
||||
! 4. (C)
|
||||
|
||||
! clear "a(?=b*)" <regexp> "ab" over match
|
||||
! clear "a(?=b*c)" <regexp> "abbbbbc" over match
|
||||
! clear "a(?=b*)" <regexp> "ab" over match
|
||||
|
||||
! clear "^a" <regexp> "a" over match
|
||||
! clear "^a" <regexp> "\na" over match
|
||||
! clear "^a" <regexp> "\r\na" over match
|
||||
! clear "^a" <regexp> "\ra" over match
|
||||
|
||||
! clear "a$" <regexp> "a" over match
|
||||
! clear "a$" <regexp> "a\n" over match
|
||||
! clear "a$" <regexp> "a\r" over match
|
||||
! clear "a$" <regexp> "a\r\n" over match
|
||||
|
||||
! "(az)(?<=b)" <regexp> "baz" over first-match
|
||||
! "a(?<=b*)" <regexp> "cbaz" over first-match
|
||||
! "a(?<=b)" <regexp> "baz" over first-match
|
||||
|
||||
! "a(?<!b)" <regexp> "baz" over first-match
|
||||
! "a(?<!b)" <regexp> "caz" over first-match
|
||||
|
||||
! "a(?=bcdefg)bcd" <regexp> "abcdefg" over first-match
|
||||
! "a(?#bcdefg)bcd" <regexp> "abcdefg" over first-match
|
||||
! "a(?:bcdefg)" <regexp> "abcdefg" over first-match
|
||||
|
||||
[ { 0 1 } ] [ "ac" "a(?!b)" <regexp> first-match ] unit-test
|
||||
[ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test
|
||||
|
||||
! "a(?<=b)" <regexp> "caba" over first-match
|
||||
|
||||
[ { 0 1 } ] [ "ab" "a(?=b)(?=b)" <regexp> first-match ] unit-test
|
||||
[ { 1 2 } ] [ "ba" "a(?<=b)(?<=b)" <regexp> first-match ] unit-test
|
||||
[ { 1 2 } ] [ "cab" "a(?=b)(?<=c)" <regexp> first-match ] unit-test
|
||||
|
||||
! capture group 1: "aaaa" 2: ""
|
||||
! "aaaa" "(a*)(a*)" <regexp> match*
|
||||
! "aaaa" "(a*)(a+)" <regexp> match*
|
||||
|
||||
[ { 0 2 } ] [ "ab" "(a|ab)(bc)?" <regexp> first-match ] unit-test
|
||||
[ { 0 3 } ] [ "abc" "(a|ab)(bc)?" <regexp> first-match ] unit-test
|
||||
|
||||
[ { 0 2 } ] [ "ab" "(ab|a)(bc)?" <regexp> first-match ] unit-test
|
||||
[ { 0 3 } ] [ "abc" "(ab|a)(bc)?" <regexp> first-match ] unit-test
|
||||
|
||||
[ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test
|
||||
|
||||
|
|
@ -1,10 +1,9 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators kernel math math.ranges
|
||||
sequences regexp.backend regexp.utils memoize sets
|
||||
regexp.parser regexp.nfa regexp.dfa regexp.traversal
|
||||
regexp.transition-tables assocs prettyprint.backend
|
||||
make lexer namespaces parser ;
|
||||
USING: accessors combinators kernel math math.ranges sequences
|
||||
sets assocs prettyprint.backend make lexer namespaces parser
|
||||
arrays fry regexp.backend regexp.utils regexp.parser regexp.nfa
|
||||
regexp.dfa regexp.traversal regexp.transition-tables ;
|
||||
IN: regexp
|
||||
|
||||
: default-regexp ( string -- regexp )
|
||||
|
|
@ -29,6 +28,9 @@ IN: regexp
|
|||
: match ( string regexp -- pair )
|
||||
<dfa-traverser> do-match return-match ;
|
||||
|
||||
: match* ( string regexp -- pair )
|
||||
<dfa-traverser> do-match [ return-match ] [ captured-groups>> ] bi ;
|
||||
|
||||
: matches? ( string regexp -- ? )
|
||||
dupd match
|
||||
[ [ length ] [ length>> 1- ] bi* = ] [ drop f ] if* ;
|
||||
|
|
@ -47,6 +49,33 @@ IN: regexp
|
|||
[ 3drop drop f f ] [ drop [ 1+ ] dip match-range ] if
|
||||
] if ;
|
||||
|
||||
: first-match ( string regexp -- pair/f )
|
||||
0 swap match-range dup [ 2array ] [ 2drop f ] if ;
|
||||
|
||||
: re-cut ( string regexp -- end/f start )
|
||||
dupd first-match
|
||||
[ [ second tail-slice ] [ first head ] 2bi ]
|
||||
[ "" like f swap ]
|
||||
if* ;
|
||||
|
||||
: re-split ( string regexp -- seq )
|
||||
[ dup ] swap '[ _ re-cut ] [ ] produce nip ;
|
||||
|
||||
: re-replace ( string regexp replacement -- result )
|
||||
[ re-split ] dip join ;
|
||||
|
||||
: next-match ( string regexp -- end/f match/f )
|
||||
dupd first-match dup
|
||||
[ [ second tail-slice ] keep ]
|
||||
[ 2drop f f ]
|
||||
if ;
|
||||
|
||||
: all-matches ( string regexp -- seq )
|
||||
[ dup ] swap '[ _ next-match ] [ ] produce nip ;
|
||||
|
||||
: count-matches ( string regexp -- n )
|
||||
all-matches length 1- ;
|
||||
|
||||
: initial-option ( regexp option -- regexp' )
|
||||
over options>> conjoin ;
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue