Merge branch 'master' of factorcode.org:/git/factor
commit
8c6c4a8f4e
|
@ -150,6 +150,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
||||||
: value-at ( value assoc -- key/f )
|
: value-at ( value assoc -- key/f )
|
||||||
swap [ = nip ] curry assoc-find 2drop ;
|
swap [ = nip ] curry assoc-find 2drop ;
|
||||||
|
|
||||||
|
: push-at ( value key assoc -- )
|
||||||
|
[ ?push ] change-at ;
|
||||||
|
|
||||||
: zip ( keys values -- alist )
|
: zip ( keys values -- alist )
|
||||||
2array flip ; inline
|
2array flip ; inline
|
||||||
|
|
||||||
|
|
|
@ -38,7 +38,7 @@ IN: bit-arrays.tests
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
100 [
|
100 [
|
||||||
drop 100 [ drop 2 random zero? ] map
|
drop 100 [ 2 random zero? ] replicate
|
||||||
dup >bit-array >array =
|
dup >bit-array >array =
|
||||||
] all?
|
] all?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
|
@ -204,7 +204,7 @@ UNION: z1 b1 c1 ;
|
||||||
|
|
||||||
10 [
|
10 [
|
||||||
[ ] [
|
[ ] [
|
||||||
20 [ drop random-op ] map >quotation
|
20 [ random-op ] [ ] replicate-as
|
||||||
[ infer effect-in [ random-class ] times ] keep
|
[ infer effect-in [ random-class ] times ] keep
|
||||||
call
|
call
|
||||||
drop
|
drop
|
||||||
|
@ -238,8 +238,8 @@ UNION: z1 b1 c1 ;
|
||||||
|
|
||||||
20 [
|
20 [
|
||||||
[ t ] [
|
[ t ] [
|
||||||
20 [ drop random-boolean-op ] [ ] map-as dup .
|
20 [ random-boolean-op ] [ ] replicate-as dup .
|
||||||
[ infer effect-in [ drop random-boolean ] map dup . ] keep
|
[ infer effect-in [ random-boolean ] replicate dup . ] keep
|
||||||
|
|
||||||
[ >r [ ] each r> call ] 2keep
|
[ >r [ ] each r> call ] 2keep
|
||||||
|
|
||||||
|
|
|
@ -10,3 +10,5 @@ IN: grouping.tests
|
||||||
2 over set-length
|
2 over set-length
|
||||||
>array
|
>array
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test
|
||||||
|
|
|
@ -56,7 +56,7 @@ M: clumps set-length
|
||||||
M: clumps group@
|
M: clumps group@
|
||||||
[ n>> over + ] [ seq>> ] bi ;
|
[ n>> over + ] [ seq>> ] bi ;
|
||||||
|
|
||||||
TUPLE: sliced-clumps < groups ;
|
TUPLE: sliced-clumps < clumps ;
|
||||||
|
|
||||||
: <sliced-clumps> ( seq n -- clumps )
|
: <sliced-clumps> ( seq n -- clumps )
|
||||||
sliced-clumps new-groups ; inline
|
sliced-clumps new-groups ; inline
|
||||||
|
|
|
@ -80,7 +80,7 @@ M: object value-literal \ literal-expected inference-warning ;
|
||||||
1 #drop node,
|
1 #drop node,
|
||||||
pop-d dup value-literal >r value-recursion r> ;
|
pop-d dup value-literal >r value-recursion r> ;
|
||||||
|
|
||||||
: value-vector ( n -- vector ) [ drop <computed> ] V{ } map-as ;
|
: value-vector ( n -- vector ) [ <computed> ] V{ } replicate-as ;
|
||||||
|
|
||||||
: add-inputs ( seq stack -- n stack )
|
: add-inputs ( seq stack -- n stack )
|
||||||
tuck [ length ] bi@ - dup 0 >
|
tuck [ length ] bi@ - dup 0 >
|
||||||
|
@ -162,7 +162,7 @@ TUPLE: too-many-r> ;
|
||||||
dup ensure-values
|
dup ensure-values
|
||||||
#>r
|
#>r
|
||||||
over 0 pick node-inputs
|
over 0 pick node-inputs
|
||||||
over [ drop pop-d ] map reverse [ push-r ] each
|
over [ pop-d ] replicate reverse [ push-r ] each
|
||||||
0 pick pick node-outputs
|
0 pick pick node-outputs
|
||||||
node,
|
node,
|
||||||
drop ;
|
drop ;
|
||||||
|
@ -171,7 +171,7 @@ TUPLE: too-many-r> ;
|
||||||
dup check-r>
|
dup check-r>
|
||||||
#r>
|
#r>
|
||||||
0 pick pick node-inputs
|
0 pick pick node-inputs
|
||||||
over [ drop pop-r ] map reverse [ push-d ] each
|
over [ pop-r ] replicate reverse [ push-d ] each
|
||||||
over 0 pick node-outputs
|
over 0 pick node-outputs
|
||||||
node,
|
node,
|
||||||
drop ;
|
drop ;
|
||||||
|
|
|
@ -13,7 +13,7 @@ SYMBOL: def-use
|
||||||
used-by empty? ;
|
used-by empty? ;
|
||||||
|
|
||||||
: uses-values ( node seq -- )
|
: uses-values ( node seq -- )
|
||||||
[ def-use get [ ?push ] change-at ] with each ;
|
[ def-use get push-at ] with each ;
|
||||||
|
|
||||||
: defs-values ( seq -- )
|
: defs-values ( seq -- )
|
||||||
#! If there is no value, set it to a new empty vector,
|
#! If there is no value, set it to a new empty vector,
|
||||||
|
@ -132,5 +132,4 @@ M: #r> kill-node*
|
||||||
#! degree of accuracy; the new values should be marked as
|
#! degree of accuracy; the new values should be marked as
|
||||||
#! having _some_ usage, so that flushing doesn't erronously
|
#! having _some_ usage, so that flushing doesn't erronously
|
||||||
#! flush them away.
|
#! flush them away.
|
||||||
nest-def-use keys
|
nest-def-use keys def-use get [ t -rot push-at ] curry each ;
|
||||||
def-use get [ [ t swap ?push ] change-at ] curry each ;
|
|
||||||
|
|
|
@ -117,14 +117,18 @@ $nl
|
||||||
{ $subsection parse-tokens } ;
|
{ $subsection parse-tokens } ;
|
||||||
|
|
||||||
ARTICLE: "parsing-words" "Parsing words"
|
ARTICLE: "parsing-words" "Parsing words"
|
||||||
"The Factor parser is follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately."
|
"The Factor parser follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately."
|
||||||
$nl
|
$nl
|
||||||
"Parsing words are marked by suffixing the definition with a " { $link POSTPONE: parsing } " declaration. Here is the simplest possible parsing word; it prints a greeting at parse time:"
|
"Parsing words are marked by suffixing the definition with a " { $link POSTPONE: parsing } " declaration. Here is the simplest possible parsing word; it prints a greeting at parse time:"
|
||||||
{ $code ": hello \"Hello world\" print ; parsing" }
|
{ $code ": hello \"Hello world\" print ; parsing" }
|
||||||
"Parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser. Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can."
|
"Parsing words must not pop or push items from the stack; however, they are permitted to access the accumulator vector supplied by the parser at the top of the stack. That is, parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser."
|
||||||
|
$nl
|
||||||
|
"Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can."
|
||||||
|
$nl
|
||||||
|
"Because of the stack restriction, parsing words cannot pass data to other words by leaving values on the stack; instead, use " { $link parsed } " to add the data to the parse tree so that it can be evaluated later."
|
||||||
$nl
|
$nl
|
||||||
"Parsing words cannot be called from the same source file where they are defined, because new definitions are only compiled at the end of the source file. An attempt to use a parsing word in its own source file raises an error:"
|
"Parsing words cannot be called from the same source file where they are defined, because new definitions are only compiled at the end of the source file. An attempt to use a parsing word in its own source file raises an error:"
|
||||||
{ $link staging-violation }
|
{ $subsection staging-violation }
|
||||||
"Tools for implementing parsing words:"
|
"Tools for implementing parsing words:"
|
||||||
{ $subsection "reading-ahead" }
|
{ $subsection "reading-ahead" }
|
||||||
{ $subsection "parsing-word-nest" }
|
{ $subsection "parsing-word-nest" }
|
||||||
|
|
|
@ -361,6 +361,12 @@ PRIVATE>
|
||||||
: map ( seq quot -- newseq )
|
: map ( seq quot -- newseq )
|
||||||
over map-as ; inline
|
over map-as ; inline
|
||||||
|
|
||||||
|
: replicate ( seq quot -- newseq )
|
||||||
|
[ drop ] prepose map ; inline
|
||||||
|
|
||||||
|
: replicate-as ( seq quot exemplar -- newseq )
|
||||||
|
>r [ drop ] prepose r> map-as ; inline
|
||||||
|
|
||||||
: change-each ( seq quot -- )
|
: change-each ( seq quot -- )
|
||||||
over map-into ; inline
|
over map-into ; inline
|
||||||
|
|
||||||
|
|
|
@ -11,7 +11,7 @@ unit-test
|
||||||
[ t ] [
|
[ t ] [
|
||||||
100 [
|
100 [
|
||||||
drop
|
drop
|
||||||
100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ before=? ] monotonic?
|
100 [ 20 random [ 1000 random ] replicate ] replicate natural-sort [ before=? ] monotonic?
|
||||||
] all?
|
] all?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
|
@ -98,7 +98,7 @@ unit-test
|
||||||
[ ] [
|
[ ] [
|
||||||
[
|
[
|
||||||
4 [
|
4 [
|
||||||
100 [ drop "obdurak" clone ] map
|
100 [ "obdurak" clone ] replicate
|
||||||
gc
|
gc
|
||||||
dup [
|
dup [
|
||||||
1234 0 rot set-string-nth
|
1234 0 rot set-string-nth
|
||||||
|
|
|
@ -26,7 +26,7 @@ IN: vectors.tests
|
||||||
[ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test
|
[ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
100 [ drop 100 random ] map >vector
|
100 [ 100 random ] V{ } map-as
|
||||||
dup >array >vector =
|
dup >array >vector =
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
|
@ -17,9 +17,6 @@ IN: assocs.lib
|
||||||
: replace-at ( assoc value key -- assoc )
|
: replace-at ( assoc value key -- assoc )
|
||||||
>r >r dup r> 1vector r> rot set-at ;
|
>r >r dup r> 1vector r> rot set-at ;
|
||||||
|
|
||||||
: insert-at ( value key assoc -- )
|
|
||||||
[ ?push ] change-at ;
|
|
||||||
|
|
||||||
: peek-at* ( assoc key -- obj ? )
|
: peek-at* ( assoc key -- obj ? )
|
||||||
swap at* dup [ >r peek r> ] when ;
|
swap at* dup [ >r peek r> ] when ;
|
||||||
|
|
||||||
|
@ -32,7 +29,7 @@ IN: assocs.lib
|
||||||
: multi-assoc-each ( assoc quot -- )
|
: multi-assoc-each ( assoc quot -- )
|
||||||
[ with each ] curry assoc-each ; inline
|
[ with each ] curry assoc-each ; inline
|
||||||
|
|
||||||
: insert ( value variable -- ) namespace insert-at ;
|
: insert ( value variable -- ) namespace push-at ;
|
||||||
|
|
||||||
: generate-key ( assoc -- str )
|
: generate-key ( assoc -- str )
|
||||||
>r 32 random-bits >hex r>
|
>r 32 random-bits >hex r>
|
||||||
|
|
|
@ -24,7 +24,7 @@ M: color-preview model-changed
|
||||||
[ [ 256 /f ] map 1 suffix <solid> ] <filter> ;
|
[ [ 256 /f ] map 1 suffix <solid> ] <filter> ;
|
||||||
|
|
||||||
: <color-sliders> ( -- model gadget )
|
: <color-sliders> ( -- model gadget )
|
||||||
3 [ drop 0 0 0 255 <range> ] map
|
3 [ 0 0 0 255 <range> ] replicate
|
||||||
dup [ range-model ] map <compose>
|
dup [ range-model ] map <compose>
|
||||||
swap [ [ <color-slider> gadget, ] each ] make-filled-pile ;
|
swap [ [ <color-slider> gadget, ] each ] make-filled-pile ;
|
||||||
|
|
||||||
|
|
|
@ -195,3 +195,12 @@ M: db <count-statement> ( tuple class groups -- statement )
|
||||||
] { { } { } { } } nmake
|
] { { } { } { } } nmake
|
||||||
>r >r parse-sql 4drop r> r>
|
>r >r parse-sql 4drop r> r>
|
||||||
<simple-statement> maybe-make-retryable do-select ;
|
<simple-statement> maybe-make-retryable do-select ;
|
||||||
|
|
||||||
|
: create-index ( index-name table-name columns -- )
|
||||||
|
[
|
||||||
|
>r >r "create index " % % r> " on " % % r> "(" %
|
||||||
|
"," join % ")" %
|
||||||
|
] "" make sql-command ;
|
||||||
|
|
||||||
|
: drop-index ( index-name -- )
|
||||||
|
[ "drop index " % % ] "" make sql-command ;
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2007 Daniel Ehrenberg
|
! Copyright (C) 2007 Daniel Ehrenberg
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: parser generic kernel classes words slots assocs
|
USING: parser generic kernel classes words slots assocs
|
||||||
sequences arrays vectors definitions prettyprint combinators.lib
|
sequences arrays vectors definitions prettyprint
|
||||||
math hashtables sets ;
|
math hashtables sets macros namespaces ;
|
||||||
IN: delegate
|
IN: delegate
|
||||||
|
|
||||||
: protocol-words ( protocol -- words )
|
: protocol-words ( protocol -- words )
|
||||||
|
@ -23,7 +23,15 @@ M: tuple-class group-words
|
||||||
|
|
||||||
: consult-method ( word class quot -- )
|
: consult-method ( word class quot -- )
|
||||||
[ drop swap first create-method ]
|
[ drop swap first create-method ]
|
||||||
[ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi
|
[
|
||||||
|
nip
|
||||||
|
[
|
||||||
|
over second saver %
|
||||||
|
%
|
||||||
|
dup second restorer %
|
||||||
|
first ,
|
||||||
|
] [ ] make
|
||||||
|
] 3bi
|
||||||
define ;
|
define ;
|
||||||
|
|
||||||
: change-word-prop ( word prop quot -- )
|
: change-word-prop ( word prop quot -- )
|
||||||
|
|
|
@ -29,14 +29,10 @@ SYMBOL: rest
|
||||||
|
|
||||||
CHLOE: validation-messages drop render-validation-messages ;
|
CHLOE: validation-messages drop render-validation-messages ;
|
||||||
|
|
||||||
TUPLE: action rest init display validate submit ;
|
TUPLE: action rest authorize init display validate submit ;
|
||||||
|
|
||||||
: new-action ( class -- action )
|
: new-action ( class -- action )
|
||||||
new
|
new [ ] >>init [ ] >>validate [ ] >>authorize ; inline
|
||||||
[ ] >>init
|
|
||||||
[ <400> ] >>display
|
|
||||||
[ ] >>validate
|
|
||||||
[ <400> ] >>submit ;
|
|
||||||
|
|
||||||
: <action> ( -- action )
|
: <action> ( -- action )
|
||||||
action new-action ;
|
action new-action ;
|
||||||
|
@ -46,18 +42,28 @@ TUPLE: action rest init display validate submit ;
|
||||||
|
|
||||||
: handle-get ( action -- response )
|
: handle-get ( action -- response )
|
||||||
'[
|
'[
|
||||||
,
|
, dup display>> [
|
||||||
[ init>> call ]
|
{
|
||||||
[ drop flashed-variables restore-flash ]
|
[ init>> call ]
|
||||||
[ display>> call ]
|
[ authorize>> call ]
|
||||||
tri
|
[ drop flashed-variables restore-flash ]
|
||||||
|
[ display>> call ]
|
||||||
|
} cleave
|
||||||
|
] [ drop <400> ] if
|
||||||
] with-exit-continuation ;
|
] with-exit-continuation ;
|
||||||
|
|
||||||
: validation-failed ( -- * )
|
: validation-failed ( -- * )
|
||||||
request get method>> "POST" = [ f ] [ <400> ] if exit-with ;
|
request get method>> "POST" = [ f ] [ <400> ] if exit-with ;
|
||||||
|
|
||||||
: (handle-post) ( action -- response )
|
: (handle-post) ( action -- response )
|
||||||
[ validate>> call ] [ submit>> call ] bi ;
|
'[
|
||||||
|
, dup submit>> [
|
||||||
|
[ validate>> call ]
|
||||||
|
[ authorize>> call ]
|
||||||
|
[ submit>> call ]
|
||||||
|
tri
|
||||||
|
] [ drop <400> ] if
|
||||||
|
] with-exit-continuation ;
|
||||||
|
|
||||||
: param ( name -- value )
|
: param ( name -- value )
|
||||||
params get at ;
|
params get at ;
|
||||||
|
|
|
@ -49,6 +49,10 @@ TUPLE: login < dispatcher users checksum ;
|
||||||
|
|
||||||
TUPLE: protected < filter-responder description capabilities ;
|
TUPLE: protected < filter-responder description capabilities ;
|
||||||
|
|
||||||
|
: <protected> ( responder -- protected )
|
||||||
|
protected new
|
||||||
|
swap >>responder ;
|
||||||
|
|
||||||
: users ( -- provider )
|
: users ( -- provider )
|
||||||
login get users>> ;
|
login get users>> ;
|
||||||
|
|
||||||
|
@ -85,13 +89,17 @@ M: user-saver dispose
|
||||||
"invalid username or password" validation-error
|
"invalid username or password" validation-error
|
||||||
validation-failed ;
|
validation-failed ;
|
||||||
|
|
||||||
|
SYMBOL: description
|
||||||
|
SYMBOL: capabilities
|
||||||
|
|
||||||
|
: flashed-variables { description capabilities } ;
|
||||||
|
|
||||||
: <login-action> ( -- action )
|
: <login-action> ( -- action )
|
||||||
<page-action>
|
<page-action>
|
||||||
[
|
[
|
||||||
protected fget [
|
flashed-variables restore-flash
|
||||||
[ description>> "description" set-value ]
|
description get "description" set-value
|
||||||
[ capabilities>> words>strings "capabilities" set-value ] bi
|
capabilities get words>strings "capabilities" set-value
|
||||||
] when*
|
|
||||||
] >>init
|
] >>init
|
||||||
|
|
||||||
{ login "login" } >>template
|
{ login "login" } >>template
|
||||||
|
@ -200,7 +208,10 @@ M: user-saver dispose
|
||||||
drop
|
drop
|
||||||
|
|
||||||
URL" $login" end-aside
|
URL" $login" end-aside
|
||||||
] >>submit ;
|
] >>submit
|
||||||
|
|
||||||
|
<protected>
|
||||||
|
"edit your profile" >>description ;
|
||||||
|
|
||||||
! ! ! Password recovery
|
! ! ! Password recovery
|
||||||
|
|
||||||
|
@ -316,32 +327,36 @@ SYMBOL: lost-password-from
|
||||||
] >>submit ;
|
] >>submit ;
|
||||||
|
|
||||||
! ! ! Authentication logic
|
! ! ! Authentication logic
|
||||||
: <protected> ( responder -- protected )
|
|
||||||
protected new
|
|
||||||
swap >>responder ;
|
|
||||||
|
|
||||||
: show-login-page ( -- response )
|
: show-login-page ( -- response )
|
||||||
begin-aside
|
begin-aside
|
||||||
URL" $login/login" { protected } <flash-redirect> ;
|
protected get description>> description set
|
||||||
|
protected get capabilities>> capabilities set
|
||||||
|
URL" $login/login" flashed-variables <flash-redirect> ;
|
||||||
|
|
||||||
: check-capabilities ( responder user -- ? )
|
: login-required ( -- * )
|
||||||
[ capabilities>> ] bi@ subset? ;
|
show-login-page exit-with ;
|
||||||
|
|
||||||
|
: have-capability? ( capability -- ? )
|
||||||
|
logged-in-user get capabilities>> member? ;
|
||||||
|
|
||||||
|
: check-capabilities ( responder user/f -- ? )
|
||||||
|
dup [ [ capabilities>> ] bi@ subset? ] [ 2drop f ] if ;
|
||||||
|
|
||||||
M: protected call-responder* ( path responder -- response )
|
M: protected call-responder* ( path responder -- response )
|
||||||
dup protected set
|
dup protected set
|
||||||
uid dup [
|
dup logged-in-user get check-capabilities
|
||||||
users get-user 2dup check-capabilities [
|
[ call-next-method ] [ 2drop show-login-page ] if ;
|
||||||
[ logged-in-user set ] [ save-user-after ] bi
|
|
||||||
call-next-method
|
: init-user ( -- )
|
||||||
] [
|
uid [
|
||||||
3drop show-login-page
|
users get-user
|
||||||
] if
|
[ logged-in-user set ]
|
||||||
] [
|
[ save-user-after ] bi
|
||||||
3drop show-login-page
|
] when* ;
|
||||||
] if ;
|
|
||||||
|
|
||||||
M: login call-responder* ( path responder -- response )
|
M: login call-responder* ( path responder -- response )
|
||||||
dup login set
|
dup login set
|
||||||
|
init-user
|
||||||
call-next-method ;
|
call-next-method ;
|
||||||
|
|
||||||
: <login-boilerplate> ( responder -- responder' )
|
: <login-boilerplate> ( responder -- responder' )
|
||||||
|
@ -359,10 +374,7 @@ M: login call-responder* ( path responder -- response )
|
||||||
! ! ! Configuration
|
! ! ! Configuration
|
||||||
|
|
||||||
: allow-edit-profile ( login -- login )
|
: allow-edit-profile ( login -- login )
|
||||||
<edit-profile-action> <protected>
|
<edit-profile-action> <login-boilerplate> "edit-profile" add-responder ;
|
||||||
"edit your profile" >>description
|
|
||||||
<login-boilerplate>
|
|
||||||
"edit-profile" add-responder ;
|
|
||||||
|
|
||||||
: allow-registration ( login -- login )
|
: allow-registration ( login -- login )
|
||||||
<register-action> <login-boilerplate>
|
<register-action> <login-boilerplate>
|
||||||
|
|
|
@ -97,15 +97,22 @@ SYMBOL: exit-continuation
|
||||||
dup empty?
|
dup empty?
|
||||||
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
|
[ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
|
||||||
|
|
||||||
CHLOE: atom
|
: a-url-path ( tag -- string )
|
||||||
[ children>string ]
|
[ "href" required-attr ] [ "rest" optional-attr value ] bi
|
||||||
[ "href" required-attr ]
|
[ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
|
||||||
[ "query" optional-attr parse-query-attr ] tri
|
|
||||||
<url>
|
: a-url ( tag -- url )
|
||||||
swap >>query
|
dup "value" optional-attr
|
||||||
swap >>path
|
[ value ] [
|
||||||
adjust-url relative-to-request
|
<url>
|
||||||
add-atom-feed ;
|
swap
|
||||||
|
[ a-url-path >>path ]
|
||||||
|
[ "query" optional-attr parse-query-attr >>query ]
|
||||||
|
bi
|
||||||
|
adjust-url relative-to-request
|
||||||
|
] ?if ;
|
||||||
|
|
||||||
|
CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ;
|
||||||
|
|
||||||
CHLOE: write-atom drop write-atom-feeds ;
|
CHLOE: write-atom drop write-atom-feeds ;
|
||||||
|
|
||||||
|
@ -114,23 +121,11 @@ GENERIC: link-attr ( tag responder -- )
|
||||||
M: object link-attr 2drop ;
|
M: object link-attr 2drop ;
|
||||||
|
|
||||||
: link-attrs ( tag -- )
|
: link-attrs ( tag -- )
|
||||||
|
#! Side-effects current namespace.
|
||||||
'[ , _ link-attr ] each-responder ;
|
'[ , _ link-attr ] each-responder ;
|
||||||
|
|
||||||
: a-start-tag ( tag -- )
|
: a-start-tag ( tag -- )
|
||||||
[
|
[ <a [ link-attrs ] [ a-url =href ] bi a> ] with-scope ;
|
||||||
<a
|
|
||||||
dup link-attrs
|
|
||||||
dup "value" optional-attr [ value f ] [
|
|
||||||
[ "href" required-attr ]
|
|
||||||
[ "query" optional-attr parse-query-attr ]
|
|
||||||
bi
|
|
||||||
] ?if
|
|
||||||
<url>
|
|
||||||
swap >>query
|
|
||||||
swap >>path
|
|
||||||
adjust-url relative-to-request =href
|
|
||||||
a>
|
|
||||||
] with-scope ;
|
|
||||||
|
|
||||||
CHLOE: a
|
CHLOE: a
|
||||||
[ a-start-tag ]
|
[ a-start-tag ]
|
||||||
|
@ -158,11 +153,12 @@ CHLOE: a
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
<form
|
<form
|
||||||
"POST" =method
|
{
|
||||||
[ link-attrs ]
|
[ link-attrs ]
|
||||||
[ "action" required-attr resolve-base-path =action ]
|
[ "method" optional-attr "post" or =method ]
|
||||||
[ tag-attrs non-chloe-attrs-only print-attrs ]
|
[ "action" required-attr resolve-base-path =action ]
|
||||||
tri
|
[ tag-attrs non-chloe-attrs-only print-attrs ]
|
||||||
|
} cleave
|
||||||
form>
|
form>
|
||||||
]
|
]
|
||||||
[ form-magic ] bi
|
[ form-magic ] bi
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2007 Alex Chapman All Rights Reserved.
|
! Copyright (C) 2007 Alex Chapman All Rights Reserved.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: assocs assocs.lib kernel gap-buffer generic trees trees.avl math
|
USING: assocs kernel gap-buffer generic trees trees.avl math
|
||||||
sequences quotations ;
|
sequences quotations ;
|
||||||
IN: gap-buffer.cursortree
|
IN: gap-buffer.cursortree
|
||||||
|
|
||||||
|
@ -21,7 +21,7 @@ TUPLE: right-cursor ;
|
||||||
|
|
||||||
: cursor-index ( cursor -- i ) cursor-i ;
|
: cursor-index ( cursor -- i ) cursor-i ;
|
||||||
|
|
||||||
: add-cursor ( cursortree cursor -- ) dup cursor-index rot insert-at ;
|
: add-cursor ( cursortree cursor -- ) dup cursor-index rot push-at ;
|
||||||
|
|
||||||
: remove-cursor ( cursortree cursor -- )
|
: remove-cursor ( cursortree cursor -- )
|
||||||
tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ;
|
tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ;
|
||||||
|
|
|
@ -114,7 +114,7 @@ M: help-error error.
|
||||||
H{ } clone [
|
H{ } clone [
|
||||||
[
|
[
|
||||||
>r >r dup >link where dup
|
>r >r dup >link where dup
|
||||||
[ first r> at r> [ ?push ] change-at ]
|
[ first r> at r> push-at ]
|
||||||
[ r> r> 2drop 2drop ]
|
[ r> r> 2drop 2drop ]
|
||||||
if
|
if
|
||||||
] 2curry each
|
] 2curry each
|
||||||
|
|
|
@ -151,7 +151,7 @@ TUPLE: person first-name last-name ;
|
||||||
|
|
||||||
[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
|
[ ] [ 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'><input type='hidden' name='__n' value='a'/></form>" ] [
|
||||||
[
|
[
|
||||||
"test10" test-template call-template
|
"test10" test-template call-template
|
||||||
] run-template
|
] run-template
|
||||||
|
|
|
@ -7,7 +7,7 @@ IN: http.tests
|
||||||
: lf>crlf "\n" split "\r\n" join ;
|
: lf>crlf "\n" split "\r\n" join ;
|
||||||
|
|
||||||
STRING: read-request-test-1
|
STRING: read-request-test-1
|
||||||
POST http://foo/bar HTTP/1.1
|
POST /bar HTTP/1.1
|
||||||
Some-Header: 1
|
Some-Header: 1
|
||||||
Some-Header: 2
|
Some-Header: 2
|
||||||
Content-Length: 4
|
Content-Length: 4
|
||||||
|
@ -18,7 +18,7 @@ blah
|
||||||
|
|
||||||
[
|
[
|
||||||
TUPLE{ request
|
TUPLE{ request
|
||||||
url: TUPLE{ url protocol: "http" port: 80 path: "/bar" }
|
url: TUPLE{ url path: "/bar" }
|
||||||
method: "POST"
|
method: "POST"
|
||||||
version: "1.1"
|
version: "1.1"
|
||||||
header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } }
|
header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } }
|
||||||
|
@ -49,14 +49,14 @@ read-request-test-1' 1array [
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
STRING: read-request-test-2
|
STRING: read-request-test-2
|
||||||
HEAD http://foo/bar HTTP/1.1
|
HEAD /bar HTTP/1.1
|
||||||
Host: www.sex.com
|
Host: www.sex.com
|
||||||
|
|
||||||
;
|
;
|
||||||
|
|
||||||
[
|
[
|
||||||
TUPLE{ request
|
TUPLE{ request
|
||||||
url: TUPLE{ url protocol: "http" port: 80 host: "www.sex.com" path: "/bar" }
|
url: TUPLE{ url host: "www.sex.com" path: "/bar" }
|
||||||
method: "HEAD"
|
method: "HEAD"
|
||||||
version: "1.1"
|
version: "1.1"
|
||||||
header: H{ { "host" "www.sex.com" } }
|
header: H{ { "host" "www.sex.com" } }
|
||||||
|
|
|
@ -6,8 +6,7 @@ assocs sequences splitting sorting sets debugger
|
||||||
strings vectors hashtables quotations arrays byte-arrays
|
strings vectors hashtables quotations arrays byte-arrays
|
||||||
math.parser calendar calendar.format present
|
math.parser calendar calendar.format present
|
||||||
|
|
||||||
io io.server io.sockets.secure
|
io io.encodings.iana io.encodings.binary io.encodings.8-bit
|
||||||
io.encodings.iana io.encodings.binary io.encodings.8-bit
|
|
||||||
|
|
||||||
unicode.case unicode.categories qualified
|
unicode.case unicode.categories qualified
|
||||||
|
|
||||||
|
@ -142,7 +141,6 @@ cookies ;
|
||||||
request new
|
request new
|
||||||
"1.1" >>version
|
"1.1" >>version
|
||||||
<url>
|
<url>
|
||||||
"http" >>protocol
|
|
||||||
H{ } clone >>query
|
H{ } clone >>query
|
||||||
>>url
|
>>url
|
||||||
H{ } clone >>header
|
H{ } clone >>header
|
||||||
|
@ -202,7 +200,6 @@ TUPLE: post-data raw content content-type ;
|
||||||
: extract-host ( request -- request )
|
: extract-host ( request -- request )
|
||||||
[ ] [ url>> ] [ "host" header parse-host ] tri
|
[ ] [ url>> ] [ "host" header parse-host ] tri
|
||||||
[ >>host ] [ >>port ] bi*
|
[ >>host ] [ >>port ] bi*
|
||||||
ensure-port
|
|
||||||
drop ;
|
drop ;
|
||||||
|
|
||||||
: extract-cookies ( request -- request )
|
: extract-cookies ( request -- request )
|
||||||
|
@ -214,9 +211,6 @@ TUPLE: post-data raw content content-type ;
|
||||||
: parse-content-type ( content-type -- type encoding )
|
: parse-content-type ( content-type -- type encoding )
|
||||||
";" split1 parse-content-type-attributes "charset" swap at ;
|
";" split1 parse-content-type-attributes "charset" swap at ;
|
||||||
|
|
||||||
: detect-protocol ( request -- request )
|
|
||||||
dup url>> remote-address get secure? "https" "http" ? >>protocol drop ;
|
|
||||||
|
|
||||||
: read-request ( -- request )
|
: read-request ( -- request )
|
||||||
<request>
|
<request>
|
||||||
read-method
|
read-method
|
||||||
|
@ -224,7 +218,6 @@ TUPLE: post-data raw content content-type ;
|
||||||
read-request-version
|
read-request-version
|
||||||
read-request-header
|
read-request-header
|
||||||
read-post-data
|
read-post-data
|
||||||
detect-protocol
|
|
||||||
extract-host
|
extract-host
|
||||||
extract-cookies ;
|
extract-cookies ;
|
||||||
|
|
||||||
|
|
|
@ -1,10 +1,14 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel accessors combinators namespaces
|
USING: kernel accessors combinators namespaces strings
|
||||||
logging urls http http.server http.server.responses ;
|
logging urls http http.server http.server.responses ;
|
||||||
IN: http.server.redirection
|
IN: http.server.redirection
|
||||||
|
|
||||||
: relative-to-request ( url -- url' )
|
GENERIC: relative-to-request ( url -- url' )
|
||||||
|
|
||||||
|
M: string relative-to-request ;
|
||||||
|
|
||||||
|
M: url relative-to-request
|
||||||
request get url>>
|
request get url>>
|
||||||
clone
|
clone
|
||||||
f >>query
|
f >>query
|
||||||
|
|
|
@ -2,16 +2,18 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel accessors sequences arrays namespaces splitting
|
USING: kernel accessors sequences arrays namespaces splitting
|
||||||
vocabs.loader destructors assocs debugger continuations
|
vocabs.loader destructors assocs debugger continuations
|
||||||
tools.vocabs math
|
combinators tools.vocabs math
|
||||||
io
|
io
|
||||||
io.server
|
io.server
|
||||||
|
io.sockets
|
||||||
|
io.sockets.secure
|
||||||
io.encodings
|
io.encodings
|
||||||
io.encodings.utf8
|
io.encodings.utf8
|
||||||
io.encodings.ascii
|
io.encodings.ascii
|
||||||
io.encodings.binary
|
io.encodings.binary
|
||||||
io.streams.limited
|
io.streams.limited
|
||||||
io.timeouts
|
io.timeouts
|
||||||
fry logging calendar
|
fry logging calendar urls
|
||||||
http
|
http
|
||||||
http.server.responses
|
http.server.responses
|
||||||
html.elements
|
html.elements
|
||||||
|
@ -66,7 +68,7 @@ main-responder global [ <404> <trivial-responder> or ] change-at
|
||||||
[
|
[
|
||||||
utf8 [
|
utf8 [
|
||||||
development-mode get
|
development-mode get
|
||||||
[ http-error. ] [ drop "Response error" throw ] if
|
[ http-error. ] [ drop "Response error" rethrow ] if
|
||||||
] with-encoded-output
|
] with-encoded-output
|
||||||
] recover
|
] recover
|
||||||
] if
|
] if
|
||||||
|
@ -88,12 +90,26 @@ LOG: httpd-hit NOTICE
|
||||||
: dispatch-request ( request -- response )
|
: dispatch-request ( request -- response )
|
||||||
url>> path>> split-path main-responder get call-responder ;
|
url>> path>> split-path main-responder get call-responder ;
|
||||||
|
|
||||||
|
: prepare-request ( request -- request )
|
||||||
|
[
|
||||||
|
local-address get
|
||||||
|
[ secure? "https" "http" ? >>protocol ]
|
||||||
|
[ port>> '[ , or ] change-port ]
|
||||||
|
bi
|
||||||
|
] change-url ;
|
||||||
|
|
||||||
|
: valid-request? ( request -- ? )
|
||||||
|
url>> port>> local-address get port>> = ;
|
||||||
|
|
||||||
: do-request ( request -- response )
|
: do-request ( request -- response )
|
||||||
'[
|
'[
|
||||||
,
|
,
|
||||||
[ init-request ]
|
{
|
||||||
[ log-request ]
|
[ init-request ]
|
||||||
[ dispatch-request ] tri
|
[ prepare-request ]
|
||||||
|
[ log-request ]
|
||||||
|
[ dup valid-request? [ dispatch-request ] [ drop <400> ] if ]
|
||||||
|
} cleave
|
||||||
] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
|
] [ [ \ do-request log-error ] [ <500> ] bi ] recover ;
|
||||||
|
|
||||||
: ?refresh-all ( -- )
|
: ?refresh-all ( -- )
|
||||||
|
|
|
@ -15,7 +15,7 @@ IN: io.files.unique
|
||||||
[ 10 random CHAR: 0 + ] [ random-letter ] if ;
|
[ 10 random CHAR: 0 + ] [ random-letter ] if ;
|
||||||
|
|
||||||
: random-name ( n -- string )
|
: random-name ( n -- string )
|
||||||
[ drop random-ch ] "" map-as ;
|
[ random-ch ] "" replicate-as ;
|
||||||
|
|
||||||
: unique-length ( -- n ) 10 ; inline
|
: unique-length ( -- n ) 10 ; inline
|
||||||
: unique-retries ( -- n ) 10 ; inline
|
: unique-retries ( -- n ) 10 ; inline
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: io.encodings io.backend io.ports io.streams.duplex
|
USING: io.encodings io.backend io.ports io.streams.duplex
|
||||||
io splitting grouping sequences sequences.lib namespaces kernel
|
io splitting grouping sequences namespaces kernel
|
||||||
destructors math concurrency.combinators accessors
|
destructors math concurrency.combinators accessors
|
||||||
arrays continuations quotations ;
|
arrays continuations quotations ;
|
||||||
IN: io.pipes
|
IN: io.pipes
|
||||||
|
|
|
@ -10,7 +10,7 @@ TUPLE: pool connections disposed expired ;
|
||||||
dup check-disposed
|
dup check-disposed
|
||||||
dup expired>> expired? [
|
dup expired>> expired? [
|
||||||
ALIEN: 31337 >>expired
|
ALIEN: 31337 >>expired
|
||||||
connections>> [ delete-all ] [ dispose-each ] bi
|
connections>> delete-all
|
||||||
] [ drop ] if ;
|
] [ drop ] if ;
|
||||||
|
|
||||||
: <pool> ( class -- pool )
|
: <pool> ( class -- pool )
|
||||||
|
@ -34,6 +34,7 @@ GENERIC: make-connection ( pool -- conn )
|
||||||
dup check-pool [ make-connection ] keep return-connection ;
|
dup check-pool [ make-connection ] keep return-connection ;
|
||||||
|
|
||||||
: acquire-connection ( pool -- conn )
|
: acquire-connection ( pool -- conn )
|
||||||
|
dup check-pool
|
||||||
[ dup connections>> empty? ] [ dup new-connection ] [ ] while
|
[ dup connections>> empty? ] [ dup new-connection ] [ ] while
|
||||||
connections>> pop ;
|
connections>> pop ;
|
||||||
|
|
||||||
|
|
|
@ -2,6 +2,6 @@ IN: io.server.tests
|
||||||
USING: tools.test io.server io.server.private kernel ;
|
USING: tools.test io.server io.server.private kernel ;
|
||||||
|
|
||||||
{ 2 0 } [ [ ] server-loop ] must-infer-as
|
{ 2 0 } [ [ ] server-loop ] must-infer-as
|
||||||
{ 2 0 } [ [ ] with-connection ] must-infer-as
|
{ 3 0 } [ [ ] with-connection ] must-infer-as
|
||||||
{ 1 0 } [ [ ] swap datagram-loop ] must-infer-as
|
{ 1 0 } [ [ ] swap datagram-loop ] must-infer-as
|
||||||
{ 2 0 } [ [ ] with-datagrams ] must-infer-as
|
{ 2 0 } [ [ ] with-datagrams ] must-infer-as
|
||||||
|
|
|
@ -4,7 +4,7 @@ USING: io io.sockets io.sockets.secure io.files
|
||||||
io.streams.duplex logging continuations destructors kernel math
|
io.streams.duplex logging continuations destructors kernel math
|
||||||
math.parser namespaces parser sequences strings prettyprint
|
math.parser namespaces parser sequences strings prettyprint
|
||||||
debugger quotations calendar threads concurrency.combinators
|
debugger quotations calendar threads concurrency.combinators
|
||||||
assocs fry ;
|
assocs fry accessors ;
|
||||||
IN: io.server
|
IN: io.server
|
||||||
|
|
||||||
SYMBOL: servers
|
SYMBOL: servers
|
||||||
|
@ -15,9 +15,10 @@ SYMBOL: remote-address
|
||||||
|
|
||||||
LOG: accepted-connection NOTICE
|
LOG: accepted-connection NOTICE
|
||||||
|
|
||||||
: with-connection ( client remote quot -- )
|
: with-connection ( client remote local quot -- )
|
||||||
'[
|
'[
|
||||||
, [ remote-address set ] [ accepted-connection ] bi
|
, [ remote-address set ] [ accepted-connection ] bi
|
||||||
|
, local-address set
|
||||||
@
|
@
|
||||||
] with-stream ; inline
|
] with-stream ; inline
|
||||||
|
|
||||||
|
@ -25,7 +26,8 @@ LOG: accepted-connection NOTICE
|
||||||
|
|
||||||
: accept-loop ( server quot -- )
|
: accept-loop ( server quot -- )
|
||||||
[
|
[
|
||||||
>r accept r> '[ , , , with-connection ] "Client" spawn drop
|
[ [ accept ] [ addr>> ] bi ] dip
|
||||||
|
'[ , , , , with-connection ] "Client" spawn drop
|
||||||
] 2keep accept-loop ; inline
|
] 2keep accept-loop ; inline
|
||||||
|
|
||||||
: server-loop ( addrspec encoding quot -- )
|
: server-loop ( addrspec encoding quot -- )
|
||||||
|
@ -59,7 +61,7 @@ LOG: received-datagram NOTICE
|
||||||
|
|
||||||
: datagram-loop ( quot datagram -- )
|
: datagram-loop ( quot datagram -- )
|
||||||
[
|
[
|
||||||
[ receive dup received-datagram >r swap call r> ] keep
|
[ receive dup received-datagram [ swap call ] dip ] keep
|
||||||
pick [ send ] [ 3drop ] if
|
pick [ send ] [ 3drop ] if
|
||||||
] 2keep datagram-loop ; inline
|
] 2keep datagram-loop ; inline
|
||||||
|
|
||||||
|
|
|
@ -5,9 +5,6 @@ io.encodings.private io.timeouts debugger inspector listener
|
||||||
accessors delegate delegate.protocols ;
|
accessors delegate delegate.protocols ;
|
||||||
IN: io.streams.duplex
|
IN: io.streams.duplex
|
||||||
|
|
||||||
! We ensure that the stream can only be closed once, to preserve
|
|
||||||
! integrity of duplex I/O ports.
|
|
||||||
|
|
||||||
TUPLE: duplex-stream in out ;
|
TUPLE: duplex-stream in out ;
|
||||||
|
|
||||||
C: <duplex-stream> duplex-stream
|
C: <duplex-stream> duplex-stream
|
||||||
|
|
|
@ -44,14 +44,11 @@ TUPLE: mx fd reads writes ;
|
||||||
|
|
||||||
GENERIC: add-input-callback ( thread fd mx -- )
|
GENERIC: add-input-callback ( thread fd mx -- )
|
||||||
|
|
||||||
: add-callback ( thread fd assoc -- )
|
M: mx add-input-callback reads>> push-at ;
|
||||||
[ ?push ] change-at ;
|
|
||||||
|
|
||||||
M: mx add-input-callback reads>> add-callback ;
|
|
||||||
|
|
||||||
GENERIC: add-output-callback ( thread fd mx -- )
|
GENERIC: add-output-callback ( thread fd mx -- )
|
||||||
|
|
||||||
M: mx add-output-callback writes>> add-callback ;
|
M: mx add-output-callback writes>> push-at ;
|
||||||
|
|
||||||
GENERIC: remove-input-callbacks ( fd mx -- callbacks )
|
GENERIC: remove-input-callbacks ( fd mx -- callbacks )
|
||||||
|
|
||||||
|
|
|
@ -142,7 +142,7 @@ DEFER: (d)
|
||||||
|
|
||||||
! Computing a basis
|
! Computing a basis
|
||||||
: graded ( seq -- seq )
|
: graded ( seq -- seq )
|
||||||
dup 0 [ length max ] reduce 1+ [ drop V{ } clone ] map
|
dup 0 [ length max ] reduce 1+ [ V{ } clone ] replicate
|
||||||
[ dup length pick nth push ] reduce ;
|
[ dup length pick nth push ] reduce ;
|
||||||
|
|
||||||
: nth-basis-elt ( generators n -- elt )
|
: nth-basis-elt ( generators n -- elt )
|
||||||
|
|
|
@ -2,6 +2,10 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: tools.test lcs ;
|
USING: tools.test lcs ;
|
||||||
|
|
||||||
|
\ lcs must-infer
|
||||||
|
\ diff must-infer
|
||||||
|
\ levenshtein must-infer
|
||||||
|
|
||||||
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
|
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
|
||||||
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
|
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
|
||||||
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
|
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
|
||||||
|
|
|
@ -63,15 +63,19 @@ TUPLE: trace-state old new table i j ;
|
||||||
[ 1- ] change-i [ 1- ] change-j ;
|
[ 1- ] change-i [ 1- ] change-j ;
|
||||||
|
|
||||||
: inserted? ( state -- ? )
|
: inserted? ( state -- ? )
|
||||||
[ j>> 0 > ]
|
{
|
||||||
[ [ i>> zero? ] [ top-beats-side? ] or? ] and? ;
|
[ j>> 0 > ]
|
||||||
|
[ { [ i>> zero? ] [ top-beats-side? ] } 1|| ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
: do-insert ( state -- state )
|
: do-insert ( state -- state )
|
||||||
dup new-nth insert boa , [ 1- ] change-j ;
|
dup new-nth insert boa , [ 1- ] change-j ;
|
||||||
|
|
||||||
: deleted? ( state -- ? )
|
: deleted? ( state -- ? )
|
||||||
[ i>> 0 > ]
|
{
|
||||||
[ [ j>> zero? ] [ top-beats-side? not ] or? ] and? ;
|
[ i>> 0 > ]
|
||||||
|
[ { [ j>> zero? ] [ top-beats-side? not ] } 1|| ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
: do-delete ( state -- state )
|
: do-delete ( state -- state )
|
||||||
dup old-nth delete boa , [ 1- ] change-i ;
|
dup old-nth delete boa , [ 1- ] change-i ;
|
||||||
|
|
|
@ -17,9 +17,6 @@ IN: project-euler.150
|
||||||
: partial-sum-infimum ( seq -- seq )
|
: partial-sum-infimum ( seq -- seq )
|
||||||
0 0 rot [ (partial-sum-infimum) ] each drop ; inline
|
0 0 rot [ (partial-sum-infimum) ] each drop ; inline
|
||||||
|
|
||||||
: generate ( n quot -- seq )
|
|
||||||
[ drop ] prepose map ; inline
|
|
||||||
|
|
||||||
: map-infimum ( seq quot -- min )
|
: map-infimum ( seq quot -- min )
|
||||||
[ min ] compose 0 swap reduce ; inline
|
[ min ] compose 0 swap reduce ; inline
|
||||||
|
|
||||||
|
@ -30,7 +27,7 @@ IN: project-euler.150
|
||||||
615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
|
615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
|
||||||
|
|
||||||
: sums-triangle ( -- seq )
|
: sums-triangle ( -- seq )
|
||||||
0 1000 [ 1+ [ next ] generate partial-sums ] map nip ;
|
0 1000 [ 1+ [ next ] replicate partial-sums ] map nip ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
|
|
@ -131,10 +131,6 @@ MACRO: firstn ( n -- )
|
||||||
[ find drop [ head-slice ] when* ] curry
|
[ find drop [ head-slice ] when* ] curry
|
||||||
[ dup ] prepose keep like ;
|
[ dup ] prepose keep like ;
|
||||||
|
|
||||||
: replicate ( seq quot -- newseq )
|
|
||||||
#! quot: ( -- obj )
|
|
||||||
[ drop ] prepose map ; inline
|
|
||||||
|
|
||||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
@ -244,20 +240,6 @@ PRIVATE>
|
||||||
: short ( seq n -- seq n' )
|
: short ( seq n -- seq n' )
|
||||||
over length min ; inline
|
over length min ; inline
|
||||||
|
|
||||||
<PRIVATE
|
|
||||||
:: insert ( seq quot n -- )
|
|
||||||
n zero? [
|
|
||||||
n n 1- [ seq nth quot call ] bi@ >= [
|
|
||||||
n n 1- seq exchange
|
|
||||||
seq quot n 1- insert
|
|
||||||
] unless
|
|
||||||
] unless ; inline
|
|
||||||
PRIVATE>
|
|
||||||
|
|
||||||
: insertion-sort ( seq quot -- )
|
|
||||||
! quot is a transformation on elements
|
|
||||||
over length [ insert ] 2with each ; inline
|
|
||||||
|
|
||||||
: if-seq ( seq quot1 quot2 -- )
|
: if-seq ( seq quot1 quot2 -- )
|
||||||
[ f like ] 2dip if* ; inline
|
[ f like ] 2dip if* ; inline
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Daniel Ehrenberg
|
|
@ -0,0 +1,16 @@
|
||||||
|
USING: locals sequences kernel math ;
|
||||||
|
IN: sorting.insertion
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
:: insert ( seq quot n -- )
|
||||||
|
n zero? [
|
||||||
|
n n 1- [ seq nth quot call ] bi@ >= [
|
||||||
|
n n 1- seq exchange
|
||||||
|
seq quot n 1- insert
|
||||||
|
] unless
|
||||||
|
] unless ; inline
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: insertion-sort ( seq quot -- )
|
||||||
|
! quot is a transformation on elements
|
||||||
|
over length [ insert ] with with each ; inline
|
|
@ -0,0 +1 @@
|
||||||
|
Insertion sort
|
|
@ -0,0 +1 @@
|
||||||
|
collections
|
|
@ -144,7 +144,7 @@ M: not-enough-characters summary ( obj -- str )
|
||||||
] if next ;
|
] if next ;
|
||||||
|
|
||||||
: expect-string ( string -- )
|
: expect-string ( string -- )
|
||||||
dup [ drop get-char next ] map 2dup =
|
dup [ get-char next ] replicate 2dup =
|
||||||
[ 2drop ] [ expected ] if ;
|
[ 2drop ] [ expected ] if ;
|
||||||
|
|
||||||
: init-parser ( -- )
|
: init-parser ( -- )
|
||||||
|
|
|
@ -5,4 +5,4 @@ IN: temporary
|
||||||
[ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test
|
[ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test
|
||||||
[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test
|
[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test
|
||||||
[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ] [ alphanumeric-chars "" like ] unit-test
|
[ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ] [ alphanumeric-chars "" like ] unit-test
|
||||||
[ t ] [ 100 [ drop random-alphanumeric-char ] map alphanumeric-chars [ member? ] curry all? ] unit-test
|
[ t ] [ 100 [ random-alphanumeric-char ] replicate alphanumeric-chars [ member? ] curry all? ] unit-test
|
||||||
|
|
|
@ -30,5 +30,4 @@ IN: strings.lib
|
||||||
alphanumeric-chars random ;
|
alphanumeric-chars random ;
|
||||||
|
|
||||||
: random-alphanumeric-string ( length -- str )
|
: random-alphanumeric-string ( length -- str )
|
||||||
[ drop random-alphanumeric-char ] map "" like ;
|
[ random-alphanumeric-char ] "" replicate-as ;
|
||||||
|
|
||||||
|
|
|
@ -8,7 +8,7 @@ IN: ui.gadgets.frames
|
||||||
! gadgets gets left-over space.
|
! gadgets gets left-over space.
|
||||||
TUPLE: frame ;
|
TUPLE: frame ;
|
||||||
|
|
||||||
: <frame-grid> ( -- grid ) 9 [ drop <gadget> ] map 3 group ;
|
: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
|
||||||
|
|
||||||
: @center 1 1 ;
|
: @center 1 1 ;
|
||||||
: @left 0 1 ;
|
: @left 0 1 ;
|
||||||
|
|
|
@ -23,8 +23,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ;
|
||||||
|
|
||||||
CATEGORY: (extend) Me Mn ;
|
CATEGORY: (extend) Me Mn ;
|
||||||
: extend? ( ch -- ? )
|
: extend? ( ch -- ? )
|
||||||
[ (extend)? ]
|
{ [ (extend)? ] [ "Other_Grapheme_Extend" property? ] } 1|| ;
|
||||||
[ "Other_Grapheme_Extend" property? ] or? ;
|
|
||||||
|
|
||||||
: grapheme-class ( ch -- class )
|
: grapheme-class ( ch -- class )
|
||||||
{
|
{
|
||||||
|
@ -35,7 +34,7 @@ CATEGORY: (extend) Me Mn ;
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: init-grapheme-table ( -- table )
|
: init-grapheme-table ( -- table )
|
||||||
graphemes [ drop graphemes f <array> ] map ;
|
graphemes [ graphemes f <array> ] replicate ;
|
||||||
|
|
||||||
SYMBOL: table
|
SYMBOL: table
|
||||||
|
|
||||||
|
|
|
@ -58,8 +58,7 @@ ducet insert-helpers
|
||||||
HEX: 7FFF bitand HEX: 8000 bitor 0 0 f weight boa ;
|
HEX: 7FFF bitand HEX: 8000 bitor 0 0 f weight boa ;
|
||||||
|
|
||||||
: illegal? ( char -- ? )
|
: illegal? ( char -- ? )
|
||||||
[ "Noncharacter_Code_Point" property? ]
|
{ [ "Noncharacter_Code_Point" property? ] [ category "Cs" = ] } 1|| ;
|
||||||
[ category "Cs" = ] or? ;
|
|
||||||
|
|
||||||
: derive-weight ( char -- weights )
|
: derive-weight ( char -- weights )
|
||||||
first dup illegal?
|
first dup illegal?
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
USING: assocs math kernel sequences io.files hashtables
|
USING: assocs math kernel sequences io.files hashtables
|
||||||
quotations splitting grouping arrays math.parser hash2 math.order
|
quotations splitting grouping arrays math.parser hash2 math.order
|
||||||
byte-arrays words namespaces words compiler.units parser
|
byte-arrays words namespaces words compiler.units parser
|
||||||
io.encodings.ascii values interval-maps ascii sets assocs.lib
|
io.encodings.ascii values interval-maps ascii sets
|
||||||
combinators.lib combinators locals math.ranges sorting ;
|
combinators.lib combinators locals math.ranges sorting ;
|
||||||
IN: unicode.data
|
IN: unicode.data
|
||||||
|
|
||||||
|
@ -62,7 +62,7 @@ VALUE: properties
|
||||||
dup [ swap (chain-decomposed) ] curry assoc-map ;
|
dup [ swap (chain-decomposed) ] curry assoc-map ;
|
||||||
|
|
||||||
: first* ( seq -- ? )
|
: first* ( seq -- ? )
|
||||||
second [ empty? ] [ first ] or? ;
|
second { [ empty? ] [ first ] } 1|| ;
|
||||||
|
|
||||||
: (process-decomposed) ( data -- alist )
|
: (process-decomposed) ( data -- alist )
|
||||||
5 swap (process-data)
|
5 swap (process-data)
|
||||||
|
@ -107,7 +107,7 @@ VALUE: properties
|
||||||
|
|
||||||
:: fill-ranges ( table -- table )
|
:: fill-ranges ( table -- table )
|
||||||
name-map >alist sort-values keys
|
name-map >alist sort-values keys
|
||||||
[ [ "first>" tail? ] [ "last>" tail? ] or? ] filter
|
[ { [ "first>" tail? ] [ "last>" tail? ] } 1|| ] filter
|
||||||
2 group [
|
2 group [
|
||||||
[ name>char ] bi@ [ [a,b] ] [ table ?nth ] bi
|
[ name>char ] bi@ [ [a,b] ] [ table ?nth ] bi
|
||||||
[ swap table ?set-nth ] curry each
|
[ swap table ?set-nth ] curry each
|
||||||
|
@ -151,7 +151,7 @@ C: <code-point> code-point
|
||||||
|
|
||||||
: properties>intervals ( properties -- assoc[str,interval] )
|
: properties>intervals ( properties -- assoc[str,interval] )
|
||||||
dup values prune [ f ] H{ } map>assoc
|
dup values prune [ f ] H{ } map>assoc
|
||||||
[ [ insert-at ] curry assoc-each ] keep
|
[ [ push-at ] curry assoc-each ] keep
|
||||||
[ <interval-set> ] assoc-map ;
|
[ <interval-set> ] assoc-map ;
|
||||||
|
|
||||||
: load-properties ( -- assoc )
|
: load-properties ( -- assoc )
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
USING: sequences namespaces unicode.data kernel math arrays
|
USING: sequences namespaces unicode.data kernel math arrays
|
||||||
locals combinators.lib sequences.lib combinators.lib ;
|
locals combinators.lib sorting.insertion combinators.lib ;
|
||||||
IN: unicode.normalize
|
IN: unicode.normalize
|
||||||
|
|
||||||
! Conjoining Jamo behavior
|
! Conjoining Jamo behavior
|
||||||
|
|
|
@ -1,24 +1,33 @@
|
||||||
! Copyright (C) 2008 Slava Pestov
|
! Copyright (C) 2008 Slava Pestov
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel accessors sequences sorting math.order math.parser
|
USING: kernel accessors sequences sorting math.order math.parser
|
||||||
urls validators html.components db.types db.tuples calendar
|
urls validators html.components db db.types db.tuples calendar
|
||||||
http.server.dispatchers
|
present http.server.dispatchers
|
||||||
furnace furnace.actions furnace.auth.login furnace.boilerplate
|
furnace
|
||||||
furnace.sessions furnace.syndication ;
|
furnace.actions
|
||||||
|
furnace.auth
|
||||||
|
furnace.auth.login
|
||||||
|
furnace.boilerplate
|
||||||
|
furnace.sessions
|
||||||
|
furnace.syndication ;
|
||||||
IN: webapps.blogs
|
IN: webapps.blogs
|
||||||
|
|
||||||
TUPLE: blogs < dispatcher ;
|
TUPLE: blogs < dispatcher ;
|
||||||
|
|
||||||
|
SYMBOL: can-administer-blogs?
|
||||||
|
|
||||||
|
can-administer-blogs? define-capability
|
||||||
|
|
||||||
: view-post-url ( id -- url )
|
: view-post-url ( id -- url )
|
||||||
number>string "$blogs/post/" prepend >url ;
|
present "$blogs/post/" prepend >url ;
|
||||||
|
|
||||||
: view-comment-url ( parent id -- url )
|
: view-comment-url ( parent id -- url )
|
||||||
[ view-post-url ] dip >>anchor ;
|
[ view-post-url ] dip >>anchor ;
|
||||||
|
|
||||||
: list-posts-url ( -- url )
|
: list-posts-url ( -- url )
|
||||||
URL" $blogs/" ;
|
"$blogs/" >url ;
|
||||||
|
|
||||||
: user-posts-url ( author -- url )
|
: posts-by-url ( author -- url )
|
||||||
"$blogs/by/" prepend >url ;
|
"$blogs/by/" prepend >url ;
|
||||||
|
|
||||||
TUPLE: entity id author date content ;
|
TUPLE: entity id author date content ;
|
||||||
|
@ -39,7 +48,7 @@ M: entity feed-entry-date date>> ;
|
||||||
TUPLE: post < entity title comments ;
|
TUPLE: post < entity title comments ;
|
||||||
|
|
||||||
M: post feed-entry-title
|
M: post feed-entry-title
|
||||||
[ author>> ] [ drop ": " ] [ title>> ] tri 3append ;
|
[ author>> ] [ title>> ] bi ": " swap 3append ;
|
||||||
|
|
||||||
M: post entity-url
|
M: post entity-url
|
||||||
id>> view-post-url ;
|
id>> view-post-url ;
|
||||||
|
@ -79,19 +88,16 @@ M: comment entity-url
|
||||||
[ [ date>> ] compare invert-comparison ] sort ;
|
[ [ date>> ] compare invert-comparison ] sort ;
|
||||||
|
|
||||||
: validate-author ( -- )
|
: validate-author ( -- )
|
||||||
{ { "author" [ [ v-username ] v-optional ] } } validate-params ;
|
{ { "author" [ v-username ] } } validate-params ;
|
||||||
|
|
||||||
: list-posts ( -- posts )
|
: list-posts ( -- posts )
|
||||||
f <post> "author" value >>author
|
f <post> "author" value >>author
|
||||||
select-tuples [ dup id>> f <comment> count-tuples >>comments ] map
|
select-tuples [ dup id>> f <comment> f count-tuples >>comments ] map
|
||||||
reverse-chronological-order ;
|
reverse-chronological-order ;
|
||||||
|
|
||||||
: <list-posts-action> ( -- action )
|
: <list-posts-action> ( -- action )
|
||||||
<page-action>
|
<page-action>
|
||||||
[
|
[ list-posts "posts" set-value ] >>init
|
||||||
list-posts "posts" set-value
|
|
||||||
] >>init
|
|
||||||
|
|
||||||
{ blogs "list-posts" } >>template ;
|
{ blogs "list-posts" } >>template ;
|
||||||
|
|
||||||
: <list-posts-feed-action> ( -- action )
|
: <list-posts-feed-action> ( -- action )
|
||||||
|
@ -100,21 +106,24 @@ M: comment entity-url
|
||||||
[ list-posts ] >>entries
|
[ list-posts ] >>entries
|
||||||
[ list-posts-url ] >>url ;
|
[ list-posts-url ] >>url ;
|
||||||
|
|
||||||
: <user-posts-action> ( -- action )
|
: <posts-by-action> ( -- action )
|
||||||
<page-action>
|
<page-action>
|
||||||
|
|
||||||
"author" >>rest
|
"author" >>rest
|
||||||
|
|
||||||
[
|
[
|
||||||
validate-author
|
validate-author
|
||||||
list-posts "posts" set-value
|
list-posts "posts" set-value
|
||||||
] >>init
|
] >>init
|
||||||
{ blogs "user-posts" } >>template ;
|
|
||||||
|
|
||||||
: <user-posts-feed-action> ( -- action )
|
{ blogs "posts-by" } >>template ;
|
||||||
|
|
||||||
|
: <posts-by-feed-action> ( -- action )
|
||||||
<feed-action>
|
<feed-action>
|
||||||
[ validate-author ] >>init
|
[ validate-author ] >>init
|
||||||
[ "Recent Posts by " "author" value append ] >>title
|
[ "Recent Posts by " "author" value append ] >>title
|
||||||
[ list-posts ] >>entries
|
[ list-posts ] >>entries
|
||||||
[ "author" value user-posts-url ] >>url ;
|
[ "author" value posts-by-url ] >>url ;
|
||||||
|
|
||||||
: <post-feed-action> ( -- action )
|
: <post-feed-action> ( -- action )
|
||||||
<feed-action>
|
<feed-action>
|
||||||
|
@ -125,6 +134,7 @@ M: comment entity-url
|
||||||
|
|
||||||
: <view-post-action> ( -- action )
|
: <view-post-action> ( -- action )
|
||||||
<page-action>
|
<page-action>
|
||||||
|
|
||||||
"id" >>rest
|
"id" >>rest
|
||||||
|
|
||||||
[
|
[
|
||||||
|
@ -147,6 +157,7 @@ M: comment entity-url
|
||||||
|
|
||||||
: <new-post-action> ( -- action )
|
: <new-post-action> ( -- action )
|
||||||
<page-action>
|
<page-action>
|
||||||
|
|
||||||
[
|
[
|
||||||
validate-post
|
validate-post
|
||||||
uid "author" set-value
|
uid "author" set-value
|
||||||
|
@ -160,38 +171,76 @@ M: comment entity-url
|
||||||
[ insert-tuple ] [ entity-url <redirect> ] bi
|
[ insert-tuple ] [ entity-url <redirect> ] bi
|
||||||
] >>submit
|
] >>submit
|
||||||
|
|
||||||
{ blogs "new-post" } >>template ;
|
{ blogs "new-post" } >>template
|
||||||
|
|
||||||
|
<protected>
|
||||||
|
"make a new blog post" >>description ;
|
||||||
|
|
||||||
|
: authorize-author ( author -- )
|
||||||
|
uid = can-administer-blogs? have-capability? or
|
||||||
|
[ login-required ] unless ;
|
||||||
|
|
||||||
|
: do-post-action ( -- )
|
||||||
|
validate-integer-id
|
||||||
|
"id" value <post> select-tuple from-object ;
|
||||||
|
|
||||||
: <edit-post-action> ( -- action )
|
: <edit-post-action> ( -- action )
|
||||||
<page-action>
|
<page-action>
|
||||||
[
|
|
||||||
validate-integer-id
|
"id" >>rest
|
||||||
"id" value <post> select-tuple from-object
|
|
||||||
] >>init
|
[ do-post-action ] >>init
|
||||||
|
|
||||||
|
[ do-post-action validate-post ] >>validate
|
||||||
|
|
||||||
|
[ "author" value authorize-author ] >>authorize
|
||||||
|
|
||||||
[
|
[
|
||||||
validate-integer-id
|
"id" value <post>
|
||||||
validate-post
|
dup { "title" "author" "date" "content" } deposit-slots
|
||||||
] >>validate
|
|
||||||
|
|
||||||
[
|
|
||||||
"id" value <post> select-tuple
|
|
||||||
dup { "title" "content" } deposit-slots
|
|
||||||
[ update-tuple ] [ entity-url <redirect> ] bi
|
[ update-tuple ] [ entity-url <redirect> ] bi
|
||||||
] >>submit
|
] >>submit
|
||||||
|
|
||||||
{ blogs "edit-post" } >>template ;
|
{ blogs "edit-post" } >>template
|
||||||
|
|
||||||
|
<protected>
|
||||||
|
"edit a blog post" >>description ;
|
||||||
|
|
||||||
|
: delete-post ( id -- )
|
||||||
|
[ <post> delete-tuples ] [ f <comment> delete-tuples ] bi ;
|
||||||
|
|
||||||
: <delete-post-action> ( -- action )
|
: <delete-post-action> ( -- action )
|
||||||
<action>
|
<action>
|
||||||
|
|
||||||
|
[ do-post-action ] >>validate
|
||||||
|
|
||||||
|
[ "author" value authorize-author ] >>authorize
|
||||||
|
|
||||||
[
|
[
|
||||||
validate-integer-id
|
[ "id" value delete-post ] with-transaction
|
||||||
{ { "author" [ v-username ] } } validate-params
|
"author" value posts-by-url <redirect>
|
||||||
] >>validate
|
] >>submit
|
||||||
|
|
||||||
|
<protected>
|
||||||
|
"delete a blog post" >>description ;
|
||||||
|
|
||||||
|
: <delete-author-action> ( -- action )
|
||||||
|
<action>
|
||||||
|
|
||||||
|
[ validate-author ] >>validate
|
||||||
|
|
||||||
|
[ "author" value authorize-author ] >>authorize
|
||||||
|
|
||||||
[
|
[
|
||||||
"id" value <post> delete-tuples
|
[
|
||||||
"author" value user-posts-url <redirect>
|
f <post> "author" value >>author select-tuples [ id>> delete-post ] each
|
||||||
] >>submit ;
|
f f <comment> "author" value >>author delete-tuples
|
||||||
|
] with-transaction
|
||||||
|
"author" value posts-by-url <redirect>
|
||||||
|
] >>submit
|
||||||
|
|
||||||
|
<protected>
|
||||||
|
"delete a blog post" >>description ;
|
||||||
|
|
||||||
: validate-comment ( -- )
|
: validate-comment ( -- )
|
||||||
{
|
{
|
||||||
|
@ -213,41 +262,44 @@ M: comment entity-url
|
||||||
uid >>author
|
uid >>author
|
||||||
now >>date
|
now >>date
|
||||||
[ insert-tuple ] [ entity-url <redirect> ] bi
|
[ insert-tuple ] [ entity-url <redirect> ] bi
|
||||||
] >>submit ;
|
] >>submit
|
||||||
|
|
||||||
|
<protected>
|
||||||
|
"make a comment" >>description ;
|
||||||
|
|
||||||
: <delete-comment-action> ( -- action )
|
: <delete-comment-action> ( -- action )
|
||||||
<action>
|
<action>
|
||||||
|
|
||||||
[
|
[
|
||||||
validate-integer-id
|
validate-integer-id
|
||||||
{ { "parent" [ v-integer ] } } validate-params
|
{ { "parent" [ v-integer ] } } validate-params
|
||||||
] >>validate
|
] >>validate
|
||||||
|
|
||||||
|
[
|
||||||
|
"parent" value <post> select-tuple
|
||||||
|
author>> authorize-author
|
||||||
|
] >>authorize
|
||||||
|
|
||||||
[
|
[
|
||||||
f "id" value <comment> delete-tuples
|
f "id" value <comment> delete-tuples
|
||||||
"parent" value view-post-url <redirect>
|
"parent" value view-post-url <redirect>
|
||||||
] >>submit ;
|
] >>submit
|
||||||
|
|
||||||
|
<protected>
|
||||||
|
"delete a comment" >>description ;
|
||||||
|
|
||||||
: <blogs> ( -- dispatcher )
|
: <blogs> ( -- dispatcher )
|
||||||
blogs new-dispatcher
|
blogs new-dispatcher
|
||||||
<list-posts-action> "" add-responder
|
<list-posts-action> "" add-responder
|
||||||
<list-posts-feed-action> "posts.atom" add-responder
|
<list-posts-feed-action> "posts.atom" add-responder
|
||||||
<user-posts-action> "by" add-responder
|
<posts-by-action> "by" add-responder
|
||||||
<user-posts-feed-action> "by.atom" add-responder
|
<posts-by-feed-action> "by.atom" add-responder
|
||||||
<view-post-action> "post" add-responder
|
<view-post-action> "post" add-responder
|
||||||
<post-feed-action> "post.atom" add-responder
|
<post-feed-action> "post.atom" add-responder
|
||||||
<new-post-action> <protected>
|
<new-post-action> "new-post" add-responder
|
||||||
"make a new blog post" >>description
|
<edit-post-action> "edit-post" add-responder
|
||||||
"new-post" add-responder
|
<delete-post-action> "delete-post" add-responder
|
||||||
<edit-post-action> <protected>
|
<new-comment-action> "new-comment" add-responder
|
||||||
"edit a blog post" >>description
|
<delete-comment-action> "delete-comment" add-responder
|
||||||
"edit-post" add-responder
|
|
||||||
<delete-post-action> <protected>
|
|
||||||
"delete a blog post" >>description
|
|
||||||
"delete-post" add-responder
|
|
||||||
<new-comment-action> <protected>
|
|
||||||
"make a comment" >>description
|
|
||||||
"new-comment" add-responder
|
|
||||||
<delete-comment-action> <protected>
|
|
||||||
"delete a comment" >>description
|
|
||||||
"delete-comment" add-responder
|
|
||||||
<boilerplate>
|
<boilerplate>
|
||||||
{ blogs "blogs-common" } >>template ;
|
{ blogs "blogs-common" } >>template ;
|
||||||
|
|
|
@ -15,13 +15,13 @@
|
||||||
|
|
||||||
<div class="posting-footer">
|
<div class="posting-footer">
|
||||||
Post by
|
Post by
|
||||||
<t:a t:href="$blogs/" t:query="author">
|
<t:a t:href="$blogs/by" t:rest="author">
|
||||||
<t:label t:name="author" />
|
<t:label t:name="author" />
|
||||||
</t:a>
|
</t:a>
|
||||||
on
|
on
|
||||||
<t:label t:name="date" />
|
<t:label t:name="date" />
|
||||||
|
|
|
|
||||||
<t:a t:href="$blogs/post" t:for="id">View Post</t:a>
|
<t:a t:href="$blogs/post" t:rest="id">View Post</t:a>
|
||||||
|
|
|
|
||||||
<t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
|
<t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
|
||||||
</div>
|
</div>
|
||||||
|
|
|
@ -7,7 +7,7 @@
|
||||||
<t:bind-each t:name="posts">
|
<t:bind-each t:name="posts">
|
||||||
|
|
||||||
<h2 class="post-title">
|
<h2 class="post-title">
|
||||||
<t:a t:href="$blogs/post" t:query="id">
|
<t:a t:href="$blogs/post" t:rest="id">
|
||||||
<t:label t:name="title" />
|
<t:label t:name="title" />
|
||||||
</t:a>
|
</t:a>
|
||||||
</h2>
|
</h2>
|
||||||
|
@ -18,13 +18,13 @@
|
||||||
|
|
||||||
<div class="posting-footer">
|
<div class="posting-footer">
|
||||||
Post by
|
Post by
|
||||||
<t:a t:href="$blogs/by" t:query="author">
|
<t:a t:href="$blogs/by" t:rest="author">
|
||||||
<t:label t:name="author" />
|
<t:label t:name="author" />
|
||||||
</t:a>
|
</t:a>
|
||||||
on
|
on
|
||||||
<t:label t:name="date" />
|
<t:label t:name="date" />
|
||||||
|
|
|
|
||||||
<t:a t:href="$blogs/post" t:query="id">
|
<t:a t:href="$blogs/post" t:rest="id">
|
||||||
<t:label t:name="comments" />
|
<t:label t:name="comments" />
|
||||||
comments.
|
comments.
|
||||||
</t:a>
|
</t:a>
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
|
|
||||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
<t:atom t:href="$blogs/by" t:query="author">
|
<t:atom t:href="$blogs/by" t:rest="author">
|
||||||
Recent Posts by <t:label t:name="author" />
|
Recent Posts by <t:label t:name="author" />
|
||||||
</t:atom>
|
</t:atom>
|
||||||
|
|
||||||
|
@ -13,7 +13,7 @@
|
||||||
<t:bind-each t:name="posts">
|
<t:bind-each t:name="posts">
|
||||||
|
|
||||||
<h2 class="post-title">
|
<h2 class="post-title">
|
||||||
<t:a t:href="$blogs/post" t:query="id">
|
<t:a t:href="$blogs/post" t:rest="id">
|
||||||
<t:label t:name="title" />
|
<t:label t:name="title" />
|
||||||
</t:a>
|
</t:a>
|
||||||
</h2>
|
</h2>
|
||||||
|
@ -24,13 +24,13 @@
|
||||||
|
|
||||||
<div class="posting-footer">
|
<div class="posting-footer">
|
||||||
Post by
|
Post by
|
||||||
<t:a t:href="$blogs/by" t:query="author">
|
<t:a t:href="$blogs/by" t:rest="author">
|
||||||
<t:label t:name="author" />
|
<t:label t:name="author" />
|
||||||
</t:a>
|
</t:a>
|
||||||
on
|
on
|
||||||
<t:label t:name="date" />
|
<t:label t:name="date" />
|
||||||
|
|
|
|
||||||
<t:a t:href="$blogs/post" t:query="id">
|
<t:a t:href="$blogs/post" t:rest="id">
|
||||||
<t:label t:name="comments" />
|
<t:label t:name="comments" />
|
||||||
comments.
|
comments.
|
||||||
</t:a>
|
</t:a>
|
|
@ -2,11 +2,11 @@
|
||||||
|
|
||||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
<t:atom t:href="$blogs/post.atom" t:query="id">
|
<t:atom t:href="$blogs/post.atom" t:rest="id">
|
||||||
<t:label t:name="author" />: <t:label t:name="title" />
|
<t:label t:name="author" />: <t:label t:name="title" />
|
||||||
</t:atom>
|
</t:atom>
|
||||||
|
|
||||||
<t:atom t:href="$blogs/by.atom" t:query="author">
|
<t:atom t:href="$blogs/by.atom" t:rest="author">
|
||||||
Recent Posts by <t:label t:name="author" />
|
Recent Posts by <t:label t:name="author" />
|
||||||
</t:atom>
|
</t:atom>
|
||||||
|
|
||||||
|
@ -18,13 +18,13 @@
|
||||||
|
|
||||||
<div class="posting-footer">
|
<div class="posting-footer">
|
||||||
Post by
|
Post by
|
||||||
<t:a t:href="$blogs/" t:query="author">
|
<t:a t:href="$blogs/" t:rest="author">
|
||||||
<t:label t:name="author" />
|
<t:label t:name="author" />
|
||||||
</t:a>
|
</t:a>
|
||||||
on
|
on
|
||||||
<t:label t:name="date" />
|
<t:label t:name="date" />
|
||||||
|
|
|
|
||||||
<t:a t:href="$blogs/edit-post" t:query="id">Edit Post</t:a>
|
<t:a t:href="$blogs/edit-post" t:rest="id">Edit Post</t:a>
|
||||||
|
|
|
|
||||||
<t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
|
<t:button t:action="$blogs/delete-post" t:for="id,author" class="link-button link">Delete Post</t:button>
|
||||||
</div>
|
</div>
|
||||||
|
@ -33,7 +33,7 @@
|
||||||
<hr/>
|
<hr/>
|
||||||
|
|
||||||
<p class="comment-header">
|
<p class="comment-header">
|
||||||
Comment by <t:label t:name="author" /> on <t:label t:name="date" />:
|
<a name="@id">Comment by <t:label t:name="author" /> on <t:label t:name="date" />:</a>
|
||||||
</p>
|
</p>
|
||||||
|
|
||||||
<p class="posting-body">
|
<p class="posting-body">
|
||||||
|
|
|
@ -19,6 +19,10 @@ IN: webapps.pastebin
|
||||||
|
|
||||||
TUPLE: pastebin < dispatcher ;
|
TUPLE: pastebin < dispatcher ;
|
||||||
|
|
||||||
|
SYMBOL: can-delete-pastes?
|
||||||
|
|
||||||
|
can-delete-pastes? define-capability
|
||||||
|
|
||||||
! ! !
|
! ! !
|
||||||
! DOMAIN MODEL
|
! DOMAIN MODEL
|
||||||
! ! !
|
! ! !
|
||||||
|
@ -170,13 +174,20 @@ M: annotation entity-url
|
||||||
|
|
||||||
: <delete-paste-action> ( -- action )
|
: <delete-paste-action> ( -- action )
|
||||||
<action>
|
<action>
|
||||||
|
|
||||||
[ validate-integer-id ] >>validate
|
[ validate-integer-id ] >>validate
|
||||||
|
|
||||||
[
|
[
|
||||||
"id" value <paste> delete-tuples
|
[
|
||||||
"id" value f <annotation> delete-tuples
|
"id" value <paste> delete-tuples
|
||||||
|
"id" value f <annotation> delete-tuples
|
||||||
|
] with-transaction
|
||||||
URL" $pastebin/list" <redirect>
|
URL" $pastebin/list" <redirect>
|
||||||
] >>submit ;
|
] >>submit
|
||||||
|
|
||||||
|
<protected>
|
||||||
|
"delete pastes" >>description
|
||||||
|
{ can-delete-pastes? } >>capabilities ;
|
||||||
|
|
||||||
! ! !
|
! ! !
|
||||||
! ANNOTATIONS
|
! ANNOTATIONS
|
||||||
|
@ -199,6 +210,7 @@ M: annotation entity-url
|
||||||
|
|
||||||
: <delete-annotation-action> ( -- action )
|
: <delete-annotation-action> ( -- action )
|
||||||
<action>
|
<action>
|
||||||
|
|
||||||
[ { { "id" [ v-number ] } } validate-params ] >>validate
|
[ { { "id" [ v-number ] } } validate-params ] >>validate
|
||||||
|
|
||||||
[
|
[
|
||||||
|
@ -206,11 +218,11 @@ M: annotation entity-url
|
||||||
[ delete-tuples ]
|
[ delete-tuples ]
|
||||||
[ parent>> paste-url <redirect> ]
|
[ parent>> paste-url <redirect> ]
|
||||||
bi
|
bi
|
||||||
] >>submit ;
|
] >>submit
|
||||||
|
|
||||||
SYMBOL: can-delete-pastes?
|
<protected>
|
||||||
|
"delete annotations" >>description
|
||||||
can-delete-pastes? define-capability
|
{ can-delete-pastes? } >>capabilities ;
|
||||||
|
|
||||||
: <pastebin> ( -- responder )
|
: <pastebin> ( -- responder )
|
||||||
pastebin new-dispatcher
|
pastebin new-dispatcher
|
||||||
|
@ -219,13 +231,9 @@ can-delete-pastes? define-capability
|
||||||
<paste-action> "paste" add-responder
|
<paste-action> "paste" add-responder
|
||||||
<paste-feed-action> "paste.atom" add-responder
|
<paste-feed-action> "paste.atom" add-responder
|
||||||
<new-paste-action> "new-paste" add-responder
|
<new-paste-action> "new-paste" add-responder
|
||||||
<delete-paste-action> <protected>
|
<delete-paste-action> "delete-paste" add-responder
|
||||||
"delete pastes" >>description
|
|
||||||
{ can-delete-pastes? } >>capabilities "delete-paste" add-responder
|
|
||||||
<new-annotation-action> "new-annotation" add-responder
|
<new-annotation-action> "new-annotation" add-responder
|
||||||
<delete-annotation-action> <protected>
|
<delete-annotation-action> "delete-annotation" add-responder
|
||||||
"delete annotations" >>description
|
|
||||||
{ can-delete-pastes? } >>capabilities "delete-annotation" add-responder
|
|
||||||
<boilerplate>
|
<boilerplate>
|
||||||
{ pastebin "pastebin-common" } >>template ;
|
{ pastebin "pastebin-common" } >>template ;
|
||||||
|
|
||||||
|
|
|
@ -18,6 +18,10 @@ IN: webapps.planet
|
||||||
|
|
||||||
TUPLE: planet-factor < dispatcher ;
|
TUPLE: planet-factor < dispatcher ;
|
||||||
|
|
||||||
|
SYMBOL: can-administer-planet-factor?
|
||||||
|
|
||||||
|
can-administer-planet-factor? define-capability
|
||||||
|
|
||||||
TUPLE: planet-factor-admin < dispatcher ;
|
TUPLE: planet-factor-admin < dispatcher ;
|
||||||
|
|
||||||
TUPLE: blog id name www-url feed-url ;
|
TUPLE: blog id name www-url feed-url ;
|
||||||
|
@ -30,8 +34,8 @@ blog "BLOGS"
|
||||||
{
|
{
|
||||||
{ "id" "ID" INTEGER +db-assigned-id+ }
|
{ "id" "ID" INTEGER +db-assigned-id+ }
|
||||||
{ "name" "NAME" { VARCHAR 256 } +not-null+ }
|
{ "name" "NAME" { VARCHAR 256 } +not-null+ }
|
||||||
{ "www-url" "WWWURL" { VARCHAR 256 } +not-null+ }
|
{ "www-url" "WWWURL" URL +not-null+ }
|
||||||
{ "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ }
|
{ "feed-url" "FEEDURL" URL +not-null+ }
|
||||||
} define-persistent
|
} define-persistent
|
||||||
|
|
||||||
TUPLE: posting < entry id ;
|
TUPLE: posting < entry id ;
|
||||||
|
@ -40,7 +44,7 @@ posting "POSTINGS"
|
||||||
{
|
{
|
||||||
{ "id" "ID" INTEGER +db-assigned-id+ }
|
{ "id" "ID" INTEGER +db-assigned-id+ }
|
||||||
{ "title" "TITLE" { VARCHAR 256 } +not-null+ }
|
{ "title" "TITLE" { VARCHAR 256 } +not-null+ }
|
||||||
{ "url" "LINK" { VARCHAR 256 } +not-null+ }
|
{ "url" "LINK" URL +not-null+ }
|
||||||
{ "description" "DESCRIPTION" TEXT +not-null+ }
|
{ "description" "DESCRIPTION" TEXT +not-null+ }
|
||||||
{ "date" "DATE" TIMESTAMP +not-null+ }
|
{ "date" "DATE" TIMESTAMP +not-null+ }
|
||||||
} define-persistent
|
} define-persistent
|
||||||
|
@ -134,6 +138,7 @@ posting "POSTINGS"
|
||||||
|
|
||||||
: <new-blog-action> ( -- action )
|
: <new-blog-action> ( -- action )
|
||||||
<page-action>
|
<page-action>
|
||||||
|
|
||||||
{ planet-factor "new-blog" } >>template
|
{ planet-factor "new-blog" } >>template
|
||||||
|
|
||||||
[ validate-blog ] >>validate
|
[ validate-blog ] >>validate
|
||||||
|
@ -150,9 +155,10 @@ posting "POSTINGS"
|
||||||
]
|
]
|
||||||
tri
|
tri
|
||||||
] >>submit ;
|
] >>submit ;
|
||||||
|
|
||||||
: <edit-blog-action> ( -- action )
|
: <edit-blog-action> ( -- action )
|
||||||
<page-action>
|
<page-action>
|
||||||
|
|
||||||
[
|
[
|
||||||
validate-integer-id
|
validate-integer-id
|
||||||
"id" value <blog> select-tuple from-object
|
"id" value <blog> select-tuple from-object
|
||||||
|
@ -184,20 +190,16 @@ posting "POSTINGS"
|
||||||
<update-action> "update" add-responder
|
<update-action> "update" add-responder
|
||||||
<new-blog-action> "new-blog" add-responder
|
<new-blog-action> "new-blog" add-responder
|
||||||
<edit-blog-action> "edit-blog" add-responder
|
<edit-blog-action> "edit-blog" add-responder
|
||||||
<delete-blog-action> "delete-blog" add-responder ;
|
<delete-blog-action> "delete-blog" add-responder
|
||||||
|
<protected>
|
||||||
SYMBOL: can-administer-planet-factor?
|
"administer Planet Factor" >>description
|
||||||
|
{ can-administer-planet-factor? } >>capabilities ;
|
||||||
can-administer-planet-factor? define-capability
|
|
||||||
|
|
||||||
: <planet-factor> ( -- responder )
|
: <planet-factor> ( -- responder )
|
||||||
planet-factor new-dispatcher
|
planet-factor new-dispatcher
|
||||||
<planet-action> "list" add-main-responder
|
<planet-action> "list" add-main-responder
|
||||||
<planet-feed-action> "feed.xml" add-responder
|
<planet-feed-action> "feed.xml" add-responder
|
||||||
<planet-factor-admin> <protected>
|
<planet-factor-admin> "admin" add-responder
|
||||||
"administer Planet Factor" >>description
|
|
||||||
{ can-administer-planet-factor? } >>capabilities
|
|
||||||
"admin" add-responder
|
|
||||||
<boilerplate>
|
<boilerplate>
|
||||||
{ planet-factor "planet-common" } >>template ;
|
{ planet-factor "planet-common" } >>template ;
|
||||||
|
|
||||||
|
|
|
@ -26,7 +26,7 @@ short-url "SHORT_URLS" {
|
||||||
3append ; foldable
|
3append ; foldable
|
||||||
|
|
||||||
: random-url ( -- string )
|
: random-url ( -- string )
|
||||||
1 6 [a,b] random [ drop letter-bank random ] "" map-as ;
|
1 6 [a,b] random [ letter-bank random ] "" replicate-as ;
|
||||||
|
|
||||||
: insert-short-url ( short-url -- short-url )
|
: insert-short-url ( short-url -- short-url )
|
||||||
'[ , dup random-url >>short insert-tuple ] 10 retry ;
|
'[ , dup random-url >>short insert-tuple ] 10 retry ;
|
||||||
|
|
|
@ -7,7 +7,7 @@
|
||||||
<ul>
|
<ul>
|
||||||
<t:bind-each t:name="articles">
|
<t:bind-each t:name="articles">
|
||||||
<li>
|
<li>
|
||||||
<t:a t:href="view" t:query="title"><t:label t:name="title"/></t:a>
|
<t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title"/></t:a>
|
||||||
</li>
|
</li>
|
||||||
</t:bind-each>
|
</t:bind-each>
|
||||||
</ul>
|
</ul>
|
||||||
|
|
|
@ -4,16 +4,26 @@
|
||||||
|
|
||||||
<t:title>Recent Changes</t:title>
|
<t:title>Recent Changes</t:title>
|
||||||
|
|
||||||
<ul>
|
<div class="revisions">
|
||||||
<t:bind-each t:name="changes">
|
|
||||||
<li>
|
<table>
|
||||||
<t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
|
|
||||||
on
|
<tr>
|
||||||
<t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
|
<th>Article</th>
|
||||||
by
|
<th>Date</th>
|
||||||
<t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>
|
<th>By</th>
|
||||||
</li>
|
</tr>
|
||||||
</t:bind-each>
|
|
||||||
</ul>
|
<t:bind-each t:name="changes">
|
||||||
|
<tr>
|
||||||
|
<td><t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title" /></t:a></td>
|
||||||
|
<td><t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a></td>
|
||||||
|
<td><t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a></td>
|
||||||
|
</tr>
|
||||||
|
</t:bind-each>
|
||||||
|
|
||||||
|
</table>
|
||||||
|
|
||||||
|
</div>
|
||||||
|
|
||||||
</t:chloe>
|
</t:chloe>
|
||||||
|
|
|
@ -8,13 +8,13 @@
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">Old revision:</th>
|
<th class="field-label">Old revision:</th>
|
||||||
<t:bind t:name="old">
|
<t:bind t:name="old">
|
||||||
<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
|
<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</td>
|
||||||
</t:bind>
|
</t:bind>
|
||||||
</tr>
|
</tr>
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">New revision:</th>
|
<th class="field-label">New revision:</th>
|
||||||
<t:bind t:name="old">
|
<t:bind t:name="old">
|
||||||
<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</td>
|
<td>Created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</td>
|
||||||
</t:bind>
|
</t:bind>
|
||||||
</tr>
|
</tr>
|
||||||
</table>
|
</table>
|
||||||
|
|
|
@ -2,16 +2,16 @@
|
||||||
|
|
||||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
<t:atom t:href="$wiki/revisions.atom" t:query="title">
|
<t:atom t:href="$wiki/revisions.atom" t:rest="title">
|
||||||
Revisions of <t:label t:name="title" />
|
Revisions of <t:label t:name="title" />
|
||||||
</t:atom>
|
</t:atom>
|
||||||
|
|
||||||
<t:call-next-template />
|
<t:call-next-template />
|
||||||
|
|
||||||
<div class="navbar">
|
<div class="navbar">
|
||||||
<t:a t:href="$wiki/view" t:query="title">Latest</t:a>
|
<t:a t:href="$wiki/view" t:rest="title">Latest</t:a>
|
||||||
| <t:a t:href="$wiki/revisions" t:query="title">Revisions</t:a>
|
| <t:a t:href="$wiki/revisions" t:rest="title">Revisions</t:a>
|
||||||
| <t:a t:href="$wiki/edit" t:query="title">Edit</t:a>
|
| <t:a t:href="$wiki/edit" t:rest="title">Edit</t:a>
|
||||||
| <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
|
| <t:button t:action="$wiki/delete" t:for="title" class="link-button link">Delete</t:button>
|
||||||
</div>
|
</div>
|
||||||
|
|
||||||
|
|
|
@ -8,14 +8,14 @@
|
||||||
<table>
|
<table>
|
||||||
<tr>
|
<tr>
|
||||||
<th>Revision</th>
|
<th>Revision</th>
|
||||||
<th>Author</th>
|
<th>By</th>
|
||||||
<th>Rollback</th>
|
<th>Rollback</th>
|
||||||
</tr>
|
</tr>
|
||||||
|
|
||||||
<t:bind-each t:name="revisions">
|
<t:bind-each t:name="revisions">
|
||||||
<tr>
|
<tr>
|
||||||
<td> <t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a> </td>
|
<td> <t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a> </td>
|
||||||
<td> <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a> </td>
|
<td> <t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a> </td>
|
||||||
<td> <t:button t:action="rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
|
<td> <t:button t:action="rollback" t:for="id" class="link link-button">Rollback</t:button> </td>
|
||||||
</tr>
|
</tr>
|
||||||
</t:bind-each>
|
</t:bind-each>
|
||||||
|
@ -24,7 +24,7 @@
|
||||||
|
|
||||||
<h2>View Differences</h2>
|
<h2>View Differences</h2>
|
||||||
|
|
||||||
<form action="diff" method="get">
|
<t:form t:action="$wiki/diff" t:method="get">
|
||||||
<table>
|
<table>
|
||||||
<tr>
|
<tr>
|
||||||
<th class="field-label">Old revision:</th>
|
<th class="field-label">Old revision:</th>
|
||||||
|
@ -51,6 +51,6 @@
|
||||||
</table>
|
</table>
|
||||||
|
|
||||||
<input type="submit" value="View" />
|
<input type="submit" value="View" />
|
||||||
</form>
|
</t:form>
|
||||||
|
|
||||||
</t:chloe>
|
</t:chloe>
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
|
|
||||||
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
|
||||||
|
|
||||||
<t:atom t:href="$wiki/user-edits.atom" t:query="author">
|
<t:atom t:href="$wiki/user-edits.atom" t:rest="author">
|
||||||
Edits by <t:label t:name="author" />
|
Edits by <t:label t:name="author" />
|
||||||
</t:atom>
|
</t:atom>
|
||||||
|
|
||||||
|
@ -11,9 +11,9 @@
|
||||||
<ul>
|
<ul>
|
||||||
<t:bind-each t:name="user-edits">
|
<t:bind-each t:name="user-edits">
|
||||||
<li>
|
<li>
|
||||||
<t:a t:href="view" t:query="title"><t:label t:name="title" /></t:a>
|
<t:a t:href="$wiki/view" t:rest="title"><t:label t:name="title" /></t:a>
|
||||||
on
|
on
|
||||||
<t:a t:href="revision" t:query="id"><t:label t:name="date" /></t:a>
|
<t:a t:href="$wiki/revision" t:rest="id"><t:label t:name="date" /></t:a>
|
||||||
</li>
|
</li>
|
||||||
</t:bind-each>
|
</t:bind-each>
|
||||||
</ul>
|
</ul>
|
||||||
|
|
|
@ -8,6 +8,6 @@
|
||||||
<t:farkup t:name="content" />
|
<t:farkup t:name="content" />
|
||||||
</div>
|
</div>
|
||||||
|
|
||||||
<p><em>This revision created on <t:label t:name="date" /> by <t:a t:href="user-edits" t:query="author"><t:label t:name="author" /></t:a>.</em></p>
|
<p><em>This revision created on <t:label t:name="date" /> by <t:a t:href="$wiki/user-edits" t:rest="author"><t:label t:name="author" /></t:a>.</em></p>
|
||||||
|
|
||||||
</t:chloe>
|
</t:chloe>
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Slava Pestov
|
! Copyright (C) 2008 Slava Pestov
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors kernel hashtables calendar
|
USING: accessors kernel hashtables calendar
|
||||||
namespaces splitting sequences sorting math.order
|
namespaces splitting sequences sorting math.order present
|
||||||
html.components syndication
|
html.components syndication
|
||||||
http.server
|
http.server
|
||||||
http.server.dispatchers
|
http.server.dispatchers
|
||||||
|
@ -15,23 +15,26 @@ validators
|
||||||
db.types db.tuples lcs farkup urls ;
|
db.types db.tuples lcs farkup urls ;
|
||||||
IN: webapps.wiki
|
IN: webapps.wiki
|
||||||
|
|
||||||
: view-url ( title -- url )
|
: wiki-url ( rest path -- url )
|
||||||
"$wiki/view/" prepend >url ;
|
[ "$wiki/" % % "/" % % ] "" make
|
||||||
|
<url> swap >>path ;
|
||||||
|
|
||||||
: edit-url ( title -- url )
|
: view-url ( title -- url ) "view" wiki-url ;
|
||||||
"$wiki/edit" >url swap "title" set-query-param ;
|
|
||||||
|
|
||||||
: revisions-url ( title -- url )
|
: edit-url ( title -- url ) "edit" wiki-url ;
|
||||||
"$wiki/revisions" >url swap "title" set-query-param ;
|
|
||||||
|
|
||||||
: revision-url ( id -- url )
|
: revisions-url ( title -- url ) "revisions" wiki-url ;
|
||||||
"$wiki/revision" >url swap "id" set-query-param ;
|
|
||||||
|
|
||||||
: user-edits-url ( author -- url )
|
: revision-url ( id -- url ) "revision" wiki-url ;
|
||||||
"$wiki/user-edits" >url swap "author" set-query-param ;
|
|
||||||
|
: user-edits-url ( author -- url ) "user-edits" wiki-url ;
|
||||||
|
|
||||||
TUPLE: wiki < dispatcher ;
|
TUPLE: wiki < dispatcher ;
|
||||||
|
|
||||||
|
SYMBOL: can-delete-wiki-articles?
|
||||||
|
|
||||||
|
can-delete-wiki-articles? define-capability
|
||||||
|
|
||||||
TUPLE: article title revision ;
|
TUPLE: article title revision ;
|
||||||
|
|
||||||
article "ARTICLES" {
|
article "ARTICLES" {
|
||||||
|
@ -82,11 +85,11 @@ M: revision feed-entry-url id>> revision-url ;
|
||||||
|
|
||||||
: <view-article-action> ( -- action )
|
: <view-article-action> ( -- action )
|
||||||
<action>
|
<action>
|
||||||
|
|
||||||
"title" >>rest
|
"title" >>rest
|
||||||
|
|
||||||
[
|
[
|
||||||
validate-title
|
validate-title
|
||||||
"view?title=" relative-link-prefix set
|
|
||||||
] >>init
|
] >>init
|
||||||
|
|
||||||
[
|
[
|
||||||
|
@ -100,11 +103,14 @@ M: revision feed-entry-url id>> revision-url ;
|
||||||
|
|
||||||
: <view-revision-action> ( -- action )
|
: <view-revision-action> ( -- action )
|
||||||
<page-action>
|
<page-action>
|
||||||
|
|
||||||
|
"id" >>rest
|
||||||
|
|
||||||
[
|
[
|
||||||
validate-integer-id
|
validate-integer-id
|
||||||
"id" value <revision>
|
"id" value <revision>
|
||||||
select-tuple from-object
|
select-tuple from-object
|
||||||
"view?title=" relative-link-prefix set
|
URL" $wiki/view/" adjust-url present relative-link-prefix set
|
||||||
] >>init
|
] >>init
|
||||||
|
|
||||||
{ wiki "view" } >>template ;
|
{ wiki "view" } >>template ;
|
||||||
|
@ -121,6 +127,9 @@ M: revision feed-entry-url id>> revision-url ;
|
||||||
|
|
||||||
: <edit-article-action> ( -- action )
|
: <edit-article-action> ( -- action )
|
||||||
<page-action>
|
<page-action>
|
||||||
|
|
||||||
|
"title" >>rest
|
||||||
|
|
||||||
[
|
[
|
||||||
validate-title
|
validate-title
|
||||||
"title" value <article> select-tuple [
|
"title" value <article> select-tuple [
|
||||||
|
@ -129,7 +138,7 @@ M: revision feed-entry-url id>> revision-url ;
|
||||||
] >>init
|
] >>init
|
||||||
|
|
||||||
{ wiki "edit" } >>template
|
{ wiki "edit" } >>template
|
||||||
|
|
||||||
[
|
[
|
||||||
validate-title
|
validate-title
|
||||||
{ { "content" [ v-required ] } } validate-params
|
{ { "content" [ v-required ] } } validate-params
|
||||||
|
@ -140,7 +149,10 @@ M: revision feed-entry-url id>> revision-url ;
|
||||||
logged-in-user get username>> >>author
|
logged-in-user get username>> >>author
|
||||||
"content" value >>content
|
"content" value >>content
|
||||||
[ add-revision ] [ title>> view-url <redirect> ] bi
|
[ add-revision ] [ title>> view-url <redirect> ] bi
|
||||||
] >>submit ;
|
] >>submit
|
||||||
|
|
||||||
|
<protected>
|
||||||
|
"edit wiki articles" >>description ;
|
||||||
|
|
||||||
: list-revisions ( -- seq )
|
: list-revisions ( -- seq )
|
||||||
f <revision> "title" value >>title select-tuples
|
f <revision> "title" value >>title select-tuples
|
||||||
|
@ -148,21 +160,32 @@ M: revision feed-entry-url id>> revision-url ;
|
||||||
|
|
||||||
: <list-revisions-action> ( -- action )
|
: <list-revisions-action> ( -- action )
|
||||||
<page-action>
|
<page-action>
|
||||||
|
|
||||||
|
"title" >>rest
|
||||||
|
|
||||||
[
|
[
|
||||||
validate-title
|
validate-title
|
||||||
list-revisions "revisions" set-value
|
list-revisions "revisions" set-value
|
||||||
] >>init
|
] >>init
|
||||||
|
|
||||||
{ wiki "revisions" } >>template ;
|
{ wiki "revisions" } >>template ;
|
||||||
|
|
||||||
: <list-revisions-feed-action> ( -- action )
|
: <list-revisions-feed-action> ( -- action )
|
||||||
<feed-action>
|
<feed-action>
|
||||||
|
|
||||||
|
"title" >>rest
|
||||||
|
|
||||||
[ validate-title ] >>init
|
[ validate-title ] >>init
|
||||||
|
|
||||||
[ "Revisions of " "title" value append ] >>title
|
[ "Revisions of " "title" value append ] >>title
|
||||||
|
|
||||||
[ "title" value revisions-url ] >>url
|
[ "title" value revisions-url ] >>url
|
||||||
|
|
||||||
[ list-revisions ] >>entries ;
|
[ list-revisions ] >>entries ;
|
||||||
|
|
||||||
: <rollback-action> ( -- action )
|
: <rollback-action> ( -- action )
|
||||||
<action>
|
<action>
|
||||||
|
|
||||||
[ validate-integer-id ] >>validate
|
[ validate-integer-id ] >>validate
|
||||||
|
|
||||||
[
|
[
|
||||||
|
@ -171,13 +194,12 @@ M: revision feed-entry-url id>> revision-url ;
|
||||||
] >>submit ;
|
] >>submit ;
|
||||||
|
|
||||||
: list-changes ( -- seq )
|
: list-changes ( -- seq )
|
||||||
"id" value <revision> select-tuples
|
f <revision> select-tuples
|
||||||
reverse-chronological-order ;
|
reverse-chronological-order ;
|
||||||
|
|
||||||
: <list-changes-action> ( -- action )
|
: <list-changes-action> ( -- action )
|
||||||
<page-action>
|
<page-action>
|
||||||
[ list-changes "changes" set-value ] >>init
|
[ list-changes "changes" set-value ] >>init
|
||||||
|
|
||||||
{ wiki "changes" } >>template ;
|
{ wiki "changes" } >>template ;
|
||||||
|
|
||||||
: <list-changes-feed-action> ( -- action )
|
: <list-changes-feed-action> ( -- action )
|
||||||
|
@ -188,13 +210,18 @@ M: revision feed-entry-url id>> revision-url ;
|
||||||
|
|
||||||
: <delete-action> ( -- action )
|
: <delete-action> ( -- action )
|
||||||
<action>
|
<action>
|
||||||
|
|
||||||
[ validate-title ] >>validate
|
[ validate-title ] >>validate
|
||||||
|
|
||||||
[
|
[
|
||||||
"title" value <article> delete-tuples
|
"title" value <article> delete-tuples
|
||||||
f <revision> "title" value >>title delete-tuples
|
f <revision> "title" value >>title delete-tuples
|
||||||
URL" $wiki" <redirect>
|
URL" $wiki" <redirect>
|
||||||
] >>submit ;
|
] >>submit
|
||||||
|
|
||||||
|
<protected>
|
||||||
|
"delete wiki articles" >>description
|
||||||
|
{ can-delete-wiki-articles? } >>capabilities ;
|
||||||
|
|
||||||
: <diff-action> ( -- action )
|
: <diff-action> ( -- action )
|
||||||
<page-action>
|
<page-action>
|
||||||
|
@ -218,6 +245,7 @@ M: revision feed-entry-url id>> revision-url ;
|
||||||
|
|
||||||
: <list-articles-action> ( -- action )
|
: <list-articles-action> ( -- action )
|
||||||
<page-action>
|
<page-action>
|
||||||
|
|
||||||
[
|
[
|
||||||
f <article> select-tuples
|
f <article> select-tuples
|
||||||
[ [ title>> ] compare ] sort
|
[ [ title>> ] compare ] sort
|
||||||
|
@ -232,23 +260,24 @@ M: revision feed-entry-url id>> revision-url ;
|
||||||
|
|
||||||
: <user-edits-action> ( -- action )
|
: <user-edits-action> ( -- action )
|
||||||
<page-action>
|
<page-action>
|
||||||
|
|
||||||
|
"author" >>rest
|
||||||
|
|
||||||
[
|
[
|
||||||
validate-author
|
validate-author
|
||||||
list-user-edits "user-edits" set-value
|
list-user-edits "user-edits" set-value
|
||||||
] >>init
|
] >>init
|
||||||
|
|
||||||
{ wiki "user-edits" } >>template ;
|
{ wiki "user-edits" } >>template ;
|
||||||
|
|
||||||
: <user-edits-feed-action> ( -- action )
|
: <user-edits-feed-action> ( -- action )
|
||||||
<feed-action>
|
<feed-action>
|
||||||
|
"author" >>rest
|
||||||
[ validate-author ] >>init
|
[ validate-author ] >>init
|
||||||
[ "Edits by " "author" value append ] >>title
|
[ "Edits by " "author" value append ] >>title
|
||||||
[ "author" value user-edits-url ] >>url
|
[ "author" value user-edits-url ] >>url
|
||||||
[ list-user-edits ] >>entries ;
|
[ list-user-edits ] >>entries ;
|
||||||
|
|
||||||
SYMBOL: can-delete-wiki-articles?
|
|
||||||
|
|
||||||
can-delete-wiki-articles? define-capability
|
|
||||||
|
|
||||||
: <article-boilerplate> ( responder -- responder' )
|
: <article-boilerplate> ( responder -- responder' )
|
||||||
<boilerplate>
|
<boilerplate>
|
||||||
{ wiki "page-common" } >>template ;
|
{ wiki "page-common" } >>template ;
|
||||||
|
@ -261,18 +290,13 @@ can-delete-wiki-articles? define-capability
|
||||||
<list-revisions-action> <article-boilerplate> "revisions" add-responder
|
<list-revisions-action> <article-boilerplate> "revisions" add-responder
|
||||||
<list-revisions-feed-action> "revisions.atom" add-responder
|
<list-revisions-feed-action> "revisions.atom" add-responder
|
||||||
<diff-action> <article-boilerplate> "diff" add-responder
|
<diff-action> <article-boilerplate> "diff" add-responder
|
||||||
<edit-article-action> <article-boilerplate> <protected>
|
<edit-article-action> <article-boilerplate> "edit" add-responder
|
||||||
"edit wiki articles" >>description
|
|
||||||
"edit" add-responder
|
|
||||||
<rollback-action> "rollback" add-responder
|
<rollback-action> "rollback" add-responder
|
||||||
<user-edits-action> "user-edits" add-responder
|
<user-edits-action> "user-edits" add-responder
|
||||||
<list-articles-action> "articles" add-responder
|
<list-articles-action> "articles" add-responder
|
||||||
<list-changes-action> "changes" add-responder
|
<list-changes-action> "changes" add-responder
|
||||||
<user-edits-feed-action> "user-edits.atom" add-responder
|
<user-edits-feed-action> "user-edits.atom" add-responder
|
||||||
<list-changes-feed-action> "changes.atom" add-responder
|
<list-changes-feed-action> "changes.atom" add-responder
|
||||||
<delete-action> <protected>
|
<delete-action> "delete" add-responder
|
||||||
"delete wiki articles" >>description
|
|
||||||
{ can-delete-wiki-articles? } >>capabilities
|
|
||||||
"delete" add-responder
|
|
||||||
<boilerplate>
|
<boilerplate>
|
||||||
{ wiki "wiki-common" } >>template ;
|
{ wiki "wiki-common" } >>template ;
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
USING: alien alien.c-types windows.com.syntax windows.ole32
|
USING: alien alien.c-types windows.com.syntax windows.ole32
|
||||||
windows.types continuations kernel alien.syntax ;
|
windows.types continuations kernel alien.syntax libc ;
|
||||||
IN: windows.com
|
IN: windows.com
|
||||||
|
|
||||||
LIBRARY: ole32
|
LIBRARY: ole32
|
||||||
|
@ -27,9 +27,9 @@ COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}
|
||||||
HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;
|
HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;
|
||||||
|
|
||||||
: com-query-interface ( interface iid -- interface' )
|
: com-query-interface ( interface iid -- interface' )
|
||||||
f <void*>
|
"void*" heap-size [
|
||||||
[ IUnknown::QueryInterface ole32-error ] keep
|
[ IUnknown::QueryInterface ole32-error ] keep *void*
|
||||||
*void* ;
|
] with-malloc ;
|
||||||
|
|
||||||
: com-add-ref ( interface -- interface )
|
: com-add-ref ( interface -- interface )
|
||||||
[ IUnknown::AddRef drop ] keep ; inline
|
[ IUnknown::AddRef drop ] keep ; inline
|
||||||
|
|
|
@ -1,11 +1,12 @@
|
||||||
USING: alien alien.c-types windows.com.syntax
|
USING: alien alien.c-types windows.com.syntax
|
||||||
windows.com.syntax.private windows.com continuations kernel
|
windows.com.syntax.private windows.com continuations kernel
|
||||||
sequences.lib namespaces windows.ole32 libc
|
sequences.lib namespaces windows.ole32 libc vocabs
|
||||||
assocs accessors arrays sequences quotations combinators
|
assocs accessors arrays sequences quotations combinators
|
||||||
math combinators.lib words compiler.units destructors ;
|
math combinators.lib words compiler.units destructors fry
|
||||||
|
math.parser ;
|
||||||
IN: windows.com.wrapper
|
IN: windows.com.wrapper
|
||||||
|
|
||||||
TUPLE: com-wrapper vtbls freed? ;
|
TUPLE: com-wrapper vtbls disposed ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
|
@ -14,6 +15,16 @@ SYMBOL: +wrapped-objects+
|
||||||
[ H{ } +wrapped-objects+ set-global ]
|
[ H{ } +wrapped-objects+ set-global ]
|
||||||
unless
|
unless
|
||||||
|
|
||||||
|
SYMBOL: +vtbl-counter+
|
||||||
|
+vtbl-counter+ get-global
|
||||||
|
[ 0 +vtbl-counter+ set-global ]
|
||||||
|
unless
|
||||||
|
|
||||||
|
"windows.com.wrapper.callbacks" create-vocab drop
|
||||||
|
|
||||||
|
: (next-vtbl-counter) ( -- n )
|
||||||
|
+vtbl-counter+ [ 1+ dup ] change ;
|
||||||
|
|
||||||
: com-unwrap ( wrapped -- object )
|
: com-unwrap ( wrapped -- object )
|
||||||
+wrapped-objects+ get-global at*
|
+wrapped-objects+ get-global at*
|
||||||
[ "invalid COM wrapping pointer" throw ] unless ;
|
[ "invalid COM wrapping pointer" throw ] unless ;
|
||||||
|
@ -22,34 +33,38 @@ unless
|
||||||
[ +wrapped-objects+ get-global delete-at ] keep
|
[ +wrapped-objects+ get-global delete-at ] keep
|
||||||
free ;
|
free ;
|
||||||
|
|
||||||
: (make-query-interface) ( interfaces -- quot )
|
: (query-interface-cases) ( interfaces -- cases )
|
||||||
[
|
[
|
||||||
[ swap 16 memory>byte-array ] %
|
[ find-com-interface-definition family-tree [ iid>> ] map ] dip
|
||||||
|
1quotation [ 2array ] curry map
|
||||||
|
] map-index concat
|
||||||
|
[ drop f ] suffix ;
|
||||||
|
|
||||||
|
: (make-query-interface) ( interfaces -- quot )
|
||||||
|
(query-interface-cases)
|
||||||
|
'[
|
||||||
|
swap 16 memory>byte-array
|
||||||
|
, case
|
||||||
[
|
[
|
||||||
>r find-com-interface-definition family-tree
|
"void*" heap-size * rot <displaced-alien> com-add-ref
|
||||||
r> 1quotation [ >r iid>> r> 2array ] curry map
|
0 rot set-void*-nth S_OK
|
||||||
] map-index concat
|
] [ nip f 0 rot set-void*-nth E_NOINTERFACE ] if*
|
||||||
[ drop f ] suffix ,
|
] ;
|
||||||
\ case ,
|
|
||||||
"void*" heap-size
|
|
||||||
[ * rot <displaced-alien> com-add-ref 0 rot set-void*-nth S_OK ]
|
|
||||||
curry ,
|
|
||||||
[ nip f 0 rot set-void*-nth E_NOINTERFACE ] ,
|
|
||||||
\ if* ,
|
|
||||||
] [ ] make ;
|
|
||||||
|
|
||||||
: (make-add-ref) ( interfaces -- quot )
|
: (make-add-ref) ( interfaces -- quot )
|
||||||
length "void*" heap-size * [ swap <displaced-alien>
|
length "void*" heap-size * '[
|
||||||
|
, swap <displaced-alien>
|
||||||
0 over ulong-nth
|
0 over ulong-nth
|
||||||
1+ [ 0 rot set-ulong-nth ] keep
|
1+ [ 0 rot set-ulong-nth ] keep
|
||||||
] curry ;
|
] ;
|
||||||
|
|
||||||
: (make-release) ( interfaces -- quot )
|
: (make-release) ( interfaces -- quot )
|
||||||
length "void*" heap-size * [ over <displaced-alien>
|
length "void*" heap-size * '[
|
||||||
|
, over <displaced-alien>
|
||||||
0 over ulong-nth
|
0 over ulong-nth
|
||||||
1- [ 0 rot set-ulong-nth ] keep
|
1- [ 0 rot set-ulong-nth ] keep
|
||||||
dup zero? [ swap (free-wrapped-object) ] [ nip ] if
|
dup zero? [ swap (free-wrapped-object) ] [ nip ] if
|
||||||
] curry ;
|
] ;
|
||||||
|
|
||||||
: (make-iunknown-methods) ( interfaces -- quots )
|
: (make-iunknown-methods) ( interfaces -- quots )
|
||||||
[ (make-query-interface) ]
|
[ (make-query-interface) ]
|
||||||
|
@ -60,32 +75,48 @@ unless
|
||||||
: (thunk) ( n -- quot )
|
: (thunk) ( n -- quot )
|
||||||
dup 0 =
|
dup 0 =
|
||||||
[ drop [ ] ]
|
[ drop [ ] ]
|
||||||
[ "void*" heap-size neg * [ swap <displaced-alien> ] curry ]
|
[ "void*" heap-size neg * '[ , swap <displaced-alien> ] ]
|
||||||
if ;
|
if ;
|
||||||
|
|
||||||
: (thunked-quots) ( quots iunknown-methods thunk -- quots' )
|
: (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s )
|
||||||
[ [ swap 2array ] curry map swap ] keep
|
[ '[ , '[ @ com-unwrap ] [ swap 2array ] curry map ] ]
|
||||||
[ com-unwrap ] compose [ swap 2array ] curry map append ;
|
[ '[ , [ swap 2array ] curry map ] ] bi bi*
|
||||||
|
swap append ;
|
||||||
|
|
||||||
: compile-alien-callback ( return parameters abi quot -- alien )
|
: compile-alien-callback ( word return parameters abi quot -- alien )
|
||||||
[ alien-callback ] 4 ncurry
|
[ alien-callback ] 4 ncurry
|
||||||
[ gensym [ swap (( -- alien )) define-declared ] keep ]
|
[ [ (( -- alien )) define-declared ] pick slip ]
|
||||||
with-compilation-unit
|
with-compilation-unit
|
||||||
execute ;
|
execute ;
|
||||||
|
|
||||||
: (make-vtbl) ( interface-name quots iunknown-methods n -- )
|
: (byte-array-to-malloced-buffer) ( byte-array -- alien )
|
||||||
|
[ byte-length malloc ] [ over byte-array>memory ] bi ;
|
||||||
|
|
||||||
|
: (callback-word) ( function-name interface-name counter -- word )
|
||||||
|
[ "::" rot 3append "-callback-" ] dip number>string 3append
|
||||||
|
"windows.com.wrapper.callbacks" create ;
|
||||||
|
|
||||||
|
: (finish-thunk) ( param-count thunk quot -- thunked-quot )
|
||||||
|
[ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ]
|
||||||
|
dip compose ;
|
||||||
|
|
||||||
|
: (make-vtbl) ( interface-name quots iunknown-methods n -- vtbl )
|
||||||
(thunk) (thunked-quots)
|
(thunk) (thunked-quots)
|
||||||
swap find-com-interface-definition family-tree-functions [
|
swap [ find-com-interface-definition family-tree-functions ]
|
||||||
[ return>> ] [ parameters>> [ first ] map ] bi
|
keep (next-vtbl-counter) '[
|
||||||
dup length 1- roll [
|
swap [
|
||||||
first dup empty?
|
[ name>> , , (callback-word) ]
|
||||||
[ 2drop [ ] ]
|
[ return>> ] [
|
||||||
[ swap [ ndip ] 2curry ]
|
parameters>>
|
||||||
if
|
[ [ first ] map ]
|
||||||
] [ second ] bi compose
|
[ length ] bi
|
||||||
|
] tri
|
||||||
|
] [
|
||||||
|
first2 (finish-thunk)
|
||||||
|
] bi*
|
||||||
"stdcall" swap compile-alien-callback
|
"stdcall" swap compile-alien-callback
|
||||||
] 2map >c-void*-array [ byte-length malloc ] keep
|
] 2map >c-void*-array
|
||||||
over byte-array>memory ;
|
(byte-array-to-malloced-buffer) ;
|
||||||
|
|
||||||
: (make-vtbls) ( implementations -- vtbls )
|
: (make-vtbls) ( implementations -- vtbls )
|
||||||
dup [ first ] map (make-iunknown-methods)
|
dup [ first ] map (make-iunknown-methods)
|
||||||
|
@ -102,11 +133,10 @@ PRIVATE>
|
||||||
: <com-wrapper> ( implementations -- wrapper )
|
: <com-wrapper> ( implementations -- wrapper )
|
||||||
(make-vtbls) f com-wrapper boa ;
|
(make-vtbls) f com-wrapper boa ;
|
||||||
|
|
||||||
M: com-wrapper dispose
|
M: com-wrapper dispose*
|
||||||
t >>freed?
|
|
||||||
vtbls>> [ free ] each ;
|
vtbls>> [ free ] each ;
|
||||||
|
|
||||||
: com-wrap ( object wrapper -- wrapped-object )
|
: com-wrap ( object wrapper -- wrapped-object )
|
||||||
dup (malloc-wrapped-object) >r vtbls>> r>
|
[ vtbls>> ] [ (malloc-wrapped-object) ] bi
|
||||||
[ [ set-void*-nth ] curry each-index ] keep
|
[ [ set-void*-nth ] curry each-index ] keep
|
||||||
[ +wrapped-objects+ get-global set-at ] keep ;
|
[ +wrapped-objects+ get-global set-at ] keep ;
|
||||||
|
|
|
@ -42,7 +42,7 @@ MEMO: standard-rule-set ( id -- ruleset )
|
||||||
rule-set-imports push ;
|
rule-set-imports push ;
|
||||||
|
|
||||||
: inverted-index ( hashes key index -- )
|
: inverted-index ( hashes key index -- )
|
||||||
[ swapd [ ?push ] change-at ] 2curry each ;
|
[ swapd push-at ] 2curry each ;
|
||||||
|
|
||||||
: ?push-all ( seq1 seq2 -- seq1+seq2 )
|
: ?push-all ( seq1 seq2 -- seq1+seq2 )
|
||||||
[
|
[
|
||||||
|
|
Loading…
Reference in New Issue