Merge branch 'master' of git://factorcode.org/git/factor
Aaron Schaefer
commit
db20629a0f
|
|
@ -56,3 +56,7 @@ TYPEDEF: uchar* MyLPBYTE
|
|||
] must-fail
|
||||
|
||||
[ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test
|
||||
|
||||
os windows? cpu x86.64? and [
|
||||
[ -2147467259 ] [ 2147500037 <long> *long ] unit-test
|
||||
] when
|
||||
|
|
|
|||
|
|
@ -18,4 +18,4 @@ SYMBOL: bytes-read
|
|||
] "" make 64 group ;
|
||||
|
||||
: update-old-new ( old new -- )
|
||||
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
|
||||
[ [ get ] bi@ w+ dup ] 2keep [ set ] bi@ ; inline
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ IN: checksums.md5
|
|||
SYMBOLS: a b c d old-a old-b old-c old-d ;
|
||||
|
||||
: T ( N -- Y )
|
||||
sin abs 4294967296 * >bignum ; foldable
|
||||
sin abs 4294967296 * >integer ; foldable
|
||||
|
||||
: initialize-md5 ( -- )
|
||||
0 bytes-read set
|
||||
|
|
|
|||
|
|
@ -3,9 +3,13 @@ locals generalizations macros fry ;
|
|||
IN: combinators.short-circuit
|
||||
|
||||
MACRO:: n&& ( quots n -- quot )
|
||||
[ f ]
|
||||
quots [| q | { [ drop n ndup q call dup not ] [ drop n ndrop f ] } ] map
|
||||
[ n nnip ] suffix 1array
|
||||
[ f ] quots [| q |
|
||||
n
|
||||
[ q '[ drop _ ndup @ dup not ] ]
|
||||
[ '[ drop _ ndrop f ] ]
|
||||
bi 2array
|
||||
] map
|
||||
n '[ _ nnip ] suffix 1array
|
||||
[ cond ] 3append ;
|
||||
|
||||
MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ;
|
||||
|
|
@ -14,10 +18,13 @@ MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
|
|||
MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
|
||||
|
||||
MACRO:: n|| ( quots n -- quot )
|
||||
[ f ]
|
||||
quots
|
||||
[| q | { [ drop n ndup q call dup ] [ n nnip ] } ] map
|
||||
{ [ drop n ndrop t ] [ f ] } suffix 1array
|
||||
[ f ] quots [| q |
|
||||
n
|
||||
[ q '[ drop _ ndup @ dup ] ]
|
||||
[ '[ _ nnip ] ]
|
||||
bi 2array
|
||||
] map
|
||||
n '[ drop _ ndrop t ] [ f ] 2array suffix 1array
|
||||
[ cond ] 3append ;
|
||||
|
||||
MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ;
|
||||
|
|
|
|||
|
|
@ -23,6 +23,6 @@ M: x86.64 dummy-fp-params? t ;
|
|||
<<
|
||||
"longlong" "ptrdiff_t" typedef
|
||||
"longlong" "intptr_t" typedef
|
||||
"int" "long" typedef
|
||||
"uint" "ulong" typedef
|
||||
"int" c-type "long" define-primitive-type
|
||||
"uint" c-type "ulong" define-primitive-type
|
||||
>>
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors parser generic kernel classes classes.tuple
|
||||
words slots assocs sequences arrays vectors definitions
|
||||
prettyprint math hashtables sets macros namespaces make ;
|
||||
prettyprint math hashtables sets generalizations namespaces make ;
|
||||
IN: delegate
|
||||
|
||||
: protocol-words ( protocol -- words )
|
||||
|
|
@ -25,15 +25,7 @@ M: tuple-class group-words
|
|||
|
||||
: consult-method ( word class quot -- )
|
||||
[ drop swap first create-method ]
|
||||
[
|
||||
nip
|
||||
[
|
||||
over second saver %
|
||||
%
|
||||
dup second restorer %
|
||||
first ,
|
||||
] [ ] make
|
||||
] 3bi
|
||||
[ nip [ , dup second , \ ndip , first , ] [ ] make ] 3bi
|
||||
define ;
|
||||
|
||||
: change-word-prop ( word prop quot -- )
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ io arrays math boxes splitting urls
|
|||
xml.entities
|
||||
http.server
|
||||
http.server.responses
|
||||
furnace
|
||||
furnace.utilities
|
||||
furnace.redirection
|
||||
furnace.conversations
|
||||
html.forms
|
||||
|
|
|
|||
|
|
@ -4,9 +4,9 @@ USING: namespaces assocs kernel sequences accessors hashtables
|
|||
urls db.types db.tuples math.parser fry logging combinators
|
||||
html.templates.chloe.syntax
|
||||
http http.server http.server.filters http.server.redirection
|
||||
furnace
|
||||
furnace.cache
|
||||
furnace.sessions
|
||||
furnace.utilities
|
||||
furnace.redirection ;
|
||||
IN: furnace.asides
|
||||
|
||||
|
|
|
|||
|
|
@ -8,8 +8,8 @@ html.forms
|
|||
http.server
|
||||
http.server.filters
|
||||
http.server.dispatchers
|
||||
furnace
|
||||
furnace.actions
|
||||
furnace.utilities
|
||||
furnace.redirection
|
||||
furnace.boilerplate
|
||||
furnace.auth.providers
|
||||
|
|
|
|||
|
|
@ -1,11 +1,10 @@
|
|||
! Copyright (c) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces make accessors kernel assocs arrays io.sockets
|
||||
threads fry urls smtp validators html.forms present
|
||||
http http.server.responses http.server.redirection
|
||||
http.server.dispatchers
|
||||
furnace furnace.actions furnace.auth furnace.auth.providers
|
||||
furnace.redirection ;
|
||||
threads fry urls smtp validators html.forms present http
|
||||
http.server.responses http.server.redirection
|
||||
http.server.dispatchers furnace.actions furnace.auth
|
||||
furnace.auth.providers furnace.redirection furnace.utilities ;
|
||||
IN: furnace.auth.features.recover-password
|
||||
|
||||
SYMBOL: lost-password-from
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel namespaces validators html.forms urls
|
||||
http.server.dispatchers
|
||||
furnace furnace.auth furnace.auth.providers furnace.actions
|
||||
furnace.auth furnace.auth.providers furnace.actions
|
||||
furnace.redirection ;
|
||||
IN: furnace.auth.features.registration
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,6 @@
|
|||
USING: kernel accessors namespaces sequences math.parser
|
||||
calendar validators urls logging html.forms
|
||||
http http.server http.server.dispatchers
|
||||
furnace
|
||||
furnace.auth
|
||||
furnace.asides
|
||||
furnace.actions
|
||||
|
|
|
|||
|
|
@ -1,12 +1,13 @@
|
|||
! Copyright (c) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel math.order namespaces furnace combinators.short-circuit
|
||||
USING: accessors kernel math.order namespaces combinators.short-circuit
|
||||
html.forms
|
||||
html.templates
|
||||
html.templates.chloe
|
||||
locals
|
||||
http.server
|
||||
http.server.filters ;
|
||||
http.server.filters
|
||||
furnace.utilities ;
|
||||
IN: furnace.boilerplate
|
||||
|
||||
TUPLE: boilerplate < filter-responder template init ;
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ http
|
|||
http.server
|
||||
http.server.redirection
|
||||
http.server.responses
|
||||
furnace ;
|
||||
furnace.utilities ;
|
||||
QUALIFIED-WITH: assocs a
|
||||
IN: furnace.chloe-tags
|
||||
|
||||
|
|
|
|||
|
|
@ -4,10 +4,10 @@ USING: namespaces assocs kernel sequences accessors hashtables
|
|||
urls db.types db.tuples math.parser fry logging combinators
|
||||
html.templates.chloe.syntax
|
||||
http http.server http.server.filters http.server.redirection
|
||||
furnace
|
||||
furnace.cache
|
||||
furnace.scopes
|
||||
furnace.sessions
|
||||
furnace.utilities
|
||||
furnace.redirection ;
|
||||
IN: furnace.conversations
|
||||
|
||||
|
|
|
|||
|
|
@ -2,129 +2,6 @@ USING: assocs help.markup help.syntax kernel
|
|||
quotations sequences strings urls xml.data http ;
|
||||
IN: furnace
|
||||
|
||||
HELP: adjust-redirect-url
|
||||
{ $values { "url" url } { "url'" url } }
|
||||
{ $description "Adjusts a redirection URL by filtering the URL's query parameters through the " { $link modify-redirect-query } " generic word on every responder involved in handling the current request." } ;
|
||||
|
||||
HELP: adjust-url
|
||||
{ $values { "url" url } { "url'" url } }
|
||||
{ $description "Adjusts a link URL by filtering the URL's query parameters through the " { $link modify-query } " generic word on every responder involved in handling the current request." } ;
|
||||
|
||||
HELP: client-state
|
||||
{ $values { "key" string } { "value/f" { $maybe string } } }
|
||||
{ $description "Looks up a cookie (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." }
|
||||
{ $notes "This word is used by session management, conversation scope and asides." } ;
|
||||
|
||||
HELP: each-responder
|
||||
{ $values { "quot" { $quotation "( responder -- )" } } }
|
||||
{ $description "Applies the quotation to each responder involved in processing the current request." } ;
|
||||
|
||||
HELP: hidden-form-field
|
||||
{ $values { "value" string } { "name" string } }
|
||||
{ $description "Renders an HTML hidden form field tag." }
|
||||
{ $notes "This word is used by session management, conversation scope and asides." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: furnace io ;"
|
||||
"\"bar\" \"foo\" hidden-form-field nl"
|
||||
"<input type='hidden' name='foo' value='bar'/>"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: link-attr
|
||||
{ $values { "tag" tag } { "responder" "a responder" } }
|
||||
{ $contract "Modifies an XHTML " { $snippet "a" } " tag." }
|
||||
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
|
||||
{ $examples "Conversation scope adds attributes to link tags." } ;
|
||||
|
||||
HELP: modify-form
|
||||
{ $values { "responder" "a responder" } }
|
||||
{ $contract "Emits hidden form fields using " { $link hidden-form-field } "." }
|
||||
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
|
||||
{ $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ;
|
||||
|
||||
HELP: modify-query
|
||||
{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } }
|
||||
{ $contract "Modifies the query parameters of a URL destined to be displayed as a link." }
|
||||
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
|
||||
{ $examples "Asides add query parameters to URLs." } ;
|
||||
|
||||
HELP: modify-redirect-query
|
||||
{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } }
|
||||
{ $contract "Modifies the query parameters of a URL destined to be used with a redirect." }
|
||||
{ $notes "This word is called by " { $link "furnace.redirection" } "." }
|
||||
{ $examples "Conversation scope and asides add query parameters to redirect URLs." } ;
|
||||
|
||||
HELP: nested-responders
|
||||
{ $values { "seq" "a sequence of responders" } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: referrer
|
||||
{ $values { "referrer/f" { $maybe string } } }
|
||||
{ $description "Outputs the current request's referrer URL." } ;
|
||||
|
||||
HELP: request-params
|
||||
{ $values { "request" request } { "assoc" assoc } }
|
||||
{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ;
|
||||
|
||||
HELP: resolve-base-path
|
||||
{ $values { "string" string } { "string'" string } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: resolve-template-path
|
||||
{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: same-host?
|
||||
{ $values { "url" url } { "?" "a boolean" } }
|
||||
{ $description "Tests if the given URL is located on the same host as the URL of the current request." } ;
|
||||
|
||||
HELP: user-agent
|
||||
{ $values { "user-agent" { $maybe string } } }
|
||||
{ $description "Outputs the user agent reported by the client for the current request." } ;
|
||||
|
||||
HELP: vocab-path
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: exit-with
|
||||
{ $values { "value" object } }
|
||||
{ $description "Exits from an outer " { $link with-exit-continuation } "." } ;
|
||||
|
||||
HELP: with-exit-continuation
|
||||
{ $values { "quot" { $quotation { "( -- value )" } } } { "value" "a value returned by the quotation or an " { $link exit-with } " invocation" } }
|
||||
{ $description "Runs a quotation with the " { $link exit-continuation } " variable bound. Calling " { $link exit-with } " in the quotation will immediately return." }
|
||||
{ $notes "Furnace actions and authentication realms wrap their execution in this combinator, allowing form validation failures and login requests, respectively, to immediately return an HTTP response to the client without running any more responder code." } ;
|
||||
|
||||
ARTICLE: "furnace.extension-points" "Furnace extension points"
|
||||
"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the stateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used."
|
||||
$nl
|
||||
"Responders can implement methods on the following generic words:"
|
||||
{ $subsection modify-query }
|
||||
{ $subsection modify-redirect-query }
|
||||
{ $subsection link-attr }
|
||||
{ $subsection modify-form }
|
||||
"Presentation-level code can call the following words:"
|
||||
{ $subsection adjust-url }
|
||||
{ $subsection adjust-redirect-url } ;
|
||||
|
||||
ARTICLE: "furnace.misc" "Miscellaneous Furnace features"
|
||||
"Inspecting the chain of responders handling the current request:"
|
||||
{ $subsection nested-responders }
|
||||
{ $subsection each-responder }
|
||||
{ $subsection resolve-base-path }
|
||||
"Vocabulary root-relative resources:"
|
||||
{ $subsection vocab-path }
|
||||
{ $subsection resolve-template-path }
|
||||
"Early return from a responder:"
|
||||
{ $subsection with-exit-continuation }
|
||||
{ $subsection exit-with }
|
||||
"Other useful words:"
|
||||
{ $subsection hidden-form-field }
|
||||
{ $subsection request-params }
|
||||
{ $subsection client-state }
|
||||
{ $subsection user-agent } ;
|
||||
|
||||
ARTICLE: "furnace.persistence" "Furnace persistence layer"
|
||||
{ $subsection "furnace.db" }
|
||||
"Server-side state:"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: furnace.tests
|
||||
USING: http http.server.dispatchers http.server.responses
|
||||
http.server furnace tools.test kernel namespaces accessors
|
||||
io.streams.string urls ;
|
||||
http.server furnace furnace.utilities tools.test kernel
|
||||
namespaces accessors io.streams.string urls ;
|
||||
TUPLE: funny-dispatcher < dispatcher ;
|
||||
|
||||
: <funny-dispatcher> funny-dispatcher new-dispatcher ;
|
||||
|
|
|
|||
|
|
@ -1,133 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces make assocs sequences kernel classes splitting
|
||||
vocabs.loader accessors strings combinators arrays
|
||||
continuations present fry
|
||||
urls html.elements
|
||||
http http.server http.server.redirection http.server.remapping ;
|
||||
IN: furnace
|
||||
|
||||
: nested-responders ( -- seq )
|
||||
responder-nesting get values ;
|
||||
|
||||
: each-responder ( quot -- )
|
||||
nested-responders swap each ; inline
|
||||
|
||||
: base-path ( string -- pair )
|
||||
dup responder-nesting get
|
||||
[ second class superclasses [ name>> = ] with contains? ] with find nip
|
||||
[ first ] [ "No such responder: " swap append throw ] ?if ;
|
||||
|
||||
: resolve-base-path ( string -- string' )
|
||||
"$" ?head [
|
||||
[
|
||||
"/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
|
||||
] "" make
|
||||
] when ;
|
||||
|
||||
: vocab-path ( vocab -- path )
|
||||
dup vocab-dir vocab-append-path ;
|
||||
|
||||
: resolve-template-path ( pair -- path )
|
||||
[
|
||||
first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi*
|
||||
] "" make ;
|
||||
|
||||
GENERIC: modify-query ( query responder -- query' )
|
||||
|
||||
M: object modify-query drop ;
|
||||
|
||||
GENERIC: modify-redirect-query ( query responder -- query' )
|
||||
|
||||
M: object modify-redirect-query drop ;
|
||||
|
||||
GENERIC: adjust-url ( url -- url' )
|
||||
|
||||
M: url adjust-url
|
||||
clone
|
||||
[ [ modify-query ] each-responder ] change-query
|
||||
[ resolve-base-path ] change-path
|
||||
relative-to-request ;
|
||||
|
||||
M: string adjust-url ;
|
||||
|
||||
GENERIC: adjust-redirect-url ( url -- url' )
|
||||
|
||||
M: url adjust-redirect-url
|
||||
adjust-url
|
||||
[ [ modify-redirect-query ] each-responder ] change-query ;
|
||||
|
||||
M: string adjust-redirect-url ;
|
||||
|
||||
GENERIC: link-attr ( tag responder -- )
|
||||
|
||||
M: object link-attr 2drop ;
|
||||
|
||||
GENERIC: modify-form ( responder -- )
|
||||
|
||||
M: object modify-form drop ;
|
||||
|
||||
: hidden-form-field ( value name -- )
|
||||
over [
|
||||
<input
|
||||
"hidden" =type
|
||||
=name
|
||||
present =value
|
||||
input/>
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: nested-forms-key "__n" ;
|
||||
|
||||
: request-params ( request -- assoc )
|
||||
dup method>> {
|
||||
{ "GET" [ url>> query>> ] }
|
||||
{ "HEAD" [ url>> query>> ] }
|
||||
{ "POST" [
|
||||
post-data>>
|
||||
dup content-type>> "application/x-www-form-urlencoded" =
|
||||
[ content>> ] [ drop f ] if
|
||||
] }
|
||||
} case ;
|
||||
|
||||
: referrer ( -- referrer/f )
|
||||
#! Typo is intentional, it's in the HTTP spec!
|
||||
"referer" request get header>> at
|
||||
dup [ >url ensure-port [ remap-port ] change-port ] when ;
|
||||
|
||||
: user-agent ( -- user-agent )
|
||||
"user-agent" request get header>> at "" or ;
|
||||
|
||||
: same-host? ( url -- ? )
|
||||
dup [
|
||||
url get [
|
||||
[ protocol>> ]
|
||||
[ host>> ]
|
||||
[ port>> remap-port ]
|
||||
tri 3array
|
||||
] bi@ =
|
||||
] when ;
|
||||
|
||||
: cookie-client-state ( key request -- value/f )
|
||||
swap get-cookie dup [ value>> ] when ;
|
||||
|
||||
: post-client-state ( key request -- value/f )
|
||||
request-params at ;
|
||||
|
||||
: client-state ( key -- value/f )
|
||||
request get dup method>> {
|
||||
{ "GET" [ cookie-client-state ] }
|
||||
{ "HEAD" [ cookie-client-state ] }
|
||||
{ "POST" [ post-client-state ] }
|
||||
} case ;
|
||||
|
||||
SYMBOL: exit-continuation
|
||||
|
||||
: exit-with ( value -- )
|
||||
exit-continuation get continue-with ;
|
||||
|
||||
: with-exit-continuation ( quot -- value )
|
||||
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
|
||||
|
||||
USE: vocabs.loader
|
||||
"furnace.actions" require
|
||||
"furnace.alloy" require
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors combinators namespaces fry urls http
|
||||
http.server http.server.redirection http.server.responses
|
||||
http.server.remapping http.server.filters furnace ;
|
||||
http.server.remapping http.server.filters furnace.utilities ;
|
||||
IN: furnace.redirection
|
||||
|
||||
: <redirect> ( url -- response )
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.markup help.syntax io.streams.string
|
||||
furnace ;
|
||||
furnace.utilities ;
|
||||
IN: furnace.referrer
|
||||
|
||||
HELP: <check-form-submissions>
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel http.server http.server.filters
|
||||
http.server.responses furnace ;
|
||||
http.server.responses furnace.utilities ;
|
||||
IN: furnace.referrer
|
||||
|
||||
TUPLE: referrer-check < filter-responder quot ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@ USING: tools.test http furnace.sessions furnace.actions
|
|||
http.server http.server.responses math namespaces make kernel
|
||||
accessors io.sockets io.servers.connection prettyprint
|
||||
io.streams.string io.files splitting destructors sequences db
|
||||
db.tuples db.sqlite continuations urls math.parser furnace ;
|
||||
db.tuples db.sqlite continuations urls math.parser furnace
|
||||
furnace.utilities ;
|
||||
|
||||
: with-session
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,13 +1,11 @@
|
|||
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs kernel math.intervals math.parser namespaces
|
||||
strings random accessors quotations hashtables sequences continuations
|
||||
fry calendar combinators combinators.short-circuit destructors alarms
|
||||
io.servers.connection
|
||||
db db.tuples db.types
|
||||
strings random accessors quotations hashtables sequences
|
||||
continuations fry calendar combinators combinators.short-circuit
|
||||
destructors alarms io.servers.connection db db.tuples db.types
|
||||
http http.server http.server.dispatchers http.server.filters
|
||||
html.elements
|
||||
furnace furnace.cache furnace.scopes ;
|
||||
html.elements furnace.cache furnace.scopes furnace.utilities ;
|
||||
IN: furnace.sessions
|
||||
|
||||
TUPLE: session < scope user-agent client ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences fry
|
||||
combinators syndication
|
||||
http.server.responses http.server.redirection
|
||||
furnace furnace.actions ;
|
||||
USING: accessors kernel sequences fry combinators syndication
|
||||
http.server.responses http.server.redirection furnace.actions
|
||||
furnace.utilities ;
|
||||
IN: furnace.syndication
|
||||
|
||||
GENERIC: feed-entry-title ( object -- string )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,126 @@
|
|||
USING: assocs help.markup help.syntax kernel
|
||||
quotations sequences strings urls xml.data http ;
|
||||
IN: furnace.utilities
|
||||
|
||||
HELP: adjust-redirect-url
|
||||
{ $values { "url" url } { "url'" url } }
|
||||
{ $description "Adjusts a redirection URL by filtering the URL's query parameters through the " { $link modify-redirect-query } " generic word on every responder involved in handling the current request." } ;
|
||||
|
||||
HELP: adjust-url
|
||||
{ $values { "url" url } { "url'" url } }
|
||||
{ $description "Adjusts a link URL by filtering the URL's query parameters through the " { $link modify-query } " generic word on every responder involved in handling the current request." } ;
|
||||
|
||||
HELP: client-state
|
||||
{ $values { "key" string } { "value/f" { $maybe string } } }
|
||||
{ $description "Looks up a cookie (if the current request is a GET or HEAD request) or a POST parameter (if the current request is a POST request)." }
|
||||
{ $notes "This word is used by session management, conversation scope and asides." } ;
|
||||
|
||||
HELP: each-responder
|
||||
{ $values { "quot" { $quotation "( responder -- )" } } }
|
||||
{ $description "Applies the quotation to each responder involved in processing the current request." } ;
|
||||
|
||||
HELP: hidden-form-field
|
||||
{ $values { "value" string } { "name" string } }
|
||||
{ $description "Renders an HTML hidden form field tag." }
|
||||
{ $notes "This word is used by session management, conversation scope and asides." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: furnace.utilities io ;"
|
||||
"\"bar\" \"foo\" hidden-form-field nl"
|
||||
"<input type='hidden' name='foo' value='bar'/>"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: link-attr
|
||||
{ $values { "tag" tag } { "responder" "a responder" } }
|
||||
{ $contract "Modifies an XHTML " { $snippet "a" } " tag." }
|
||||
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
|
||||
{ $examples "Conversation scope adds attributes to link tags." } ;
|
||||
|
||||
HELP: modify-form
|
||||
{ $values { "responder" "a responder" } }
|
||||
{ $contract "Emits hidden form fields using " { $link hidden-form-field } "." }
|
||||
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
|
||||
{ $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ;
|
||||
|
||||
HELP: modify-query
|
||||
{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } }
|
||||
{ $contract "Modifies the query parameters of a URL destined to be displayed as a link." }
|
||||
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
|
||||
{ $examples "Asides add query parameters to URLs." } ;
|
||||
|
||||
HELP: modify-redirect-query
|
||||
{ $values { "query" assoc } { "responder" "a responder" } { "query'" assoc } }
|
||||
{ $contract "Modifies the query parameters of a URL destined to be used with a redirect." }
|
||||
{ $notes "This word is called by " { $link "furnace.redirection" } "." }
|
||||
{ $examples "Conversation scope and asides add query parameters to redirect URLs." } ;
|
||||
|
||||
HELP: nested-responders
|
||||
{ $values { "seq" "a sequence of responders" } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: referrer
|
||||
{ $values { "referrer/f" { $maybe string } } }
|
||||
{ $description "Outputs the current request's referrer URL." } ;
|
||||
|
||||
HELP: request-params
|
||||
{ $values { "request" request } { "assoc" assoc } }
|
||||
{ $description "Outputs the query parameters (if the current request is a GET or HEAD request) or the POST parameters (if the current request is a POST request)." } ;
|
||||
|
||||
HELP: resolve-base-path
|
||||
{ $values { "string" string } { "string'" string } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: resolve-template-path
|
||||
{ $values { "pair" "a pair with shape " { $snippet "{ class string }" } } { "path" "a pathname string" } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: same-host?
|
||||
{ $values { "url" url } { "?" "a boolean" } }
|
||||
{ $description "Tests if the given URL is located on the same host as the URL of the current request." } ;
|
||||
|
||||
HELP: user-agent
|
||||
{ $values { "user-agent" { $maybe string } } }
|
||||
{ $description "Outputs the user agent reported by the client for the current request." } ;
|
||||
|
||||
HELP: vocab-path
|
||||
{ $values { "vocab" "a vocabulary specifier" } { "path" "a pathname string" } }
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: exit-with
|
||||
{ $values { "value" object } }
|
||||
{ $description "Exits from an outer " { $link with-exit-continuation } "." } ;
|
||||
|
||||
HELP: with-exit-continuation
|
||||
{ $values { "quot" { $quotation { "( -- value )" } } } { "value" "a value returned by the quotation or an " { $link exit-with } " invocation" } }
|
||||
{ $description "Runs a quotation with the " { $link exit-continuation } " variable bound. Calling " { $link exit-with } " in the quotation will immediately return." }
|
||||
{ $notes "Furnace actions and authentication realms wrap their execution in this combinator, allowing form validation failures and login requests, respectively, to immediately return an HTTP response to the client without running any more responder code." } ;
|
||||
|
||||
ARTICLE: "furnace.extension-points" "Furnace extension points"
|
||||
"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the stateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used."
|
||||
$nl
|
||||
"Responders can implement methods on the following generic words:"
|
||||
{ $subsection modify-query }
|
||||
{ $subsection modify-redirect-query }
|
||||
{ $subsection link-attr }
|
||||
{ $subsection modify-form }
|
||||
"Presentation-level code can call the following words:"
|
||||
{ $subsection adjust-url }
|
||||
{ $subsection adjust-redirect-url } ;
|
||||
|
||||
ARTICLE: "furnace.misc" "Miscellaneous Furnace features"
|
||||
"Inspecting the chain of responders handling the current request:"
|
||||
{ $subsection nested-responders }
|
||||
{ $subsection each-responder }
|
||||
{ $subsection resolve-base-path }
|
||||
"Vocabulary root-relative resources:"
|
||||
{ $subsection vocab-path }
|
||||
{ $subsection resolve-template-path }
|
||||
"Early return from a responder:"
|
||||
{ $subsection with-exit-continuation }
|
||||
{ $subsection exit-with }
|
||||
"Other useful words:"
|
||||
{ $subsection hidden-form-field }
|
||||
{ $subsection request-params }
|
||||
{ $subsection client-state }
|
||||
{ $subsection user-agent } ;
|
||||
|
|
@ -1,6 +1,9 @@
|
|||
! Copyright (c) 2008 Slava Pestov
|
||||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors words kernel sequences splitting ;
|
||||
USING: namespaces make assocs sequences kernel classes splitting
|
||||
words vocabs.loader accessors strings combinators arrays
|
||||
continuations present fry urls html.elements http http.server
|
||||
http.server.redirection http.server.remapping ;
|
||||
IN: furnace.utilities
|
||||
|
||||
: word>string ( word -- string )
|
||||
|
|
@ -17,3 +20,124 @@ ERROR: no-such-word name vocab ;
|
|||
|
||||
: strings>words ( seq -- seq' )
|
||||
[ string>word ] map ;
|
||||
|
||||
: nested-responders ( -- seq )
|
||||
responder-nesting get values ;
|
||||
|
||||
: each-responder ( quot -- )
|
||||
nested-responders swap each ; inline
|
||||
|
||||
: base-path ( string -- pair )
|
||||
dup responder-nesting get
|
||||
[ second class superclasses [ name>> = ] with contains? ] with find nip
|
||||
[ first ] [ "No such responder: " swap append throw ] ?if ;
|
||||
|
||||
: resolve-base-path ( string -- string' )
|
||||
"$" ?head [
|
||||
[
|
||||
"/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
|
||||
] "" make
|
||||
] when ;
|
||||
|
||||
: vocab-path ( vocab -- path )
|
||||
dup vocab-dir vocab-append-path ;
|
||||
|
||||
: resolve-template-path ( pair -- path )
|
||||
[
|
||||
first2 [ vocabulary>> vocab-path % ] [ "/" % % ] bi*
|
||||
] "" make ;
|
||||
|
||||
GENERIC: modify-query ( query responder -- query' )
|
||||
|
||||
M: object modify-query drop ;
|
||||
|
||||
GENERIC: modify-redirect-query ( query responder -- query' )
|
||||
|
||||
M: object modify-redirect-query drop ;
|
||||
|
||||
GENERIC: adjust-url ( url -- url' )
|
||||
|
||||
M: url adjust-url
|
||||
clone
|
||||
[ [ modify-query ] each-responder ] change-query
|
||||
[ resolve-base-path ] change-path
|
||||
relative-to-request ;
|
||||
|
||||
M: string adjust-url ;
|
||||
|
||||
GENERIC: adjust-redirect-url ( url -- url' )
|
||||
|
||||
M: url adjust-redirect-url
|
||||
adjust-url
|
||||
[ [ modify-redirect-query ] each-responder ] change-query ;
|
||||
|
||||
M: string adjust-redirect-url ;
|
||||
|
||||
GENERIC: link-attr ( tag responder -- )
|
||||
|
||||
M: object link-attr 2drop ;
|
||||
|
||||
GENERIC: modify-form ( responder -- )
|
||||
|
||||
M: object modify-form drop ;
|
||||
|
||||
: hidden-form-field ( value name -- )
|
||||
over [
|
||||
<input
|
||||
"hidden" =type
|
||||
=name
|
||||
present =value
|
||||
input/>
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: nested-forms-key "__n" ;
|
||||
|
||||
: request-params ( request -- assoc )
|
||||
dup method>> {
|
||||
{ "GET" [ url>> query>> ] }
|
||||
{ "HEAD" [ url>> query>> ] }
|
||||
{ "POST" [
|
||||
post-data>>
|
||||
dup content-type>> "application/x-www-form-urlencoded" =
|
||||
[ content>> ] [ drop f ] if
|
||||
] }
|
||||
} case ;
|
||||
|
||||
: referrer ( -- referrer/f )
|
||||
#! Typo is intentional, it's in the HTTP spec!
|
||||
"referer" request get header>> at
|
||||
dup [ >url ensure-port [ remap-port ] change-port ] when ;
|
||||
|
||||
: user-agent ( -- user-agent )
|
||||
"user-agent" request get header>> at "" or ;
|
||||
|
||||
: same-host? ( url -- ? )
|
||||
dup [
|
||||
url get [
|
||||
[ protocol>> ]
|
||||
[ host>> ]
|
||||
[ port>> remap-port ]
|
||||
tri 3array
|
||||
] bi@ =
|
||||
] when ;
|
||||
|
||||
: cookie-client-state ( key request -- value/f )
|
||||
swap get-cookie dup [ value>> ] when ;
|
||||
|
||||
: post-client-state ( key request -- value/f )
|
||||
request-params at ;
|
||||
|
||||
: client-state ( key -- value/f )
|
||||
request get dup method>> {
|
||||
{ "GET" [ cookie-client-state ] }
|
||||
{ "HEAD" [ cookie-client-state ] }
|
||||
{ "POST" [ post-client-state ] }
|
||||
} case ;
|
||||
|
||||
SYMBOL: exit-continuation
|
||||
|
||||
: exit-with ( value -- )
|
||||
exit-continuation get continue-with ;
|
||||
|
||||
: with-exit-continuation ( quot -- value )
|
||||
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,18 @@
|
|||
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo
|
||||
! Cavazos, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences sequences.private namespaces math
|
||||
math.ranges combinators macros quotations fry arrays ;
|
||||
USING: kernel sequences sequences.private math math.ranges
|
||||
combinators macros quotations fry ;
|
||||
IN: generalizations
|
||||
|
||||
<<
|
||||
|
||||
: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
|
||||
|
||||
: repeat ( n obj quot -- ) swapd times ; inline
|
||||
|
||||
>>
|
||||
|
||||
MACRO: nsequence ( n seq -- quot )
|
||||
[
|
||||
[ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
|
||||
|
|
@ -22,39 +30,38 @@ MACRO: firstn ( n -- )
|
|||
bi prefix '[ _ cleave ]
|
||||
] if ;
|
||||
|
||||
MACRO: npick ( n -- )
|
||||
1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;
|
||||
MACRO: npick ( n -- quot )
|
||||
1- [ dup ] [ '[ _ dip swap ] ] repeat ;
|
||||
|
||||
MACRO: ndup ( n -- )
|
||||
dup '[ _ npick ] n*quot ;
|
||||
|
||||
MACRO: nrot ( n -- )
|
||||
1- dup saver swap [ r> swap ] n*quot append ;
|
||||
1- [ ] [ '[ _ dip swap ] ] repeat ;
|
||||
|
||||
MACRO: -nrot ( n -- )
|
||||
1- dup [ swap >r ] n*quot swap restorer append ;
|
||||
1- [ ] [ '[ swap _ dip ] ] repeat ;
|
||||
|
||||
MACRO: ndrop ( n -- )
|
||||
[ drop ] n*quot ;
|
||||
|
||||
: nnip ( n -- )
|
||||
swap >r ndrop r> ; inline
|
||||
MACRO: nnip ( n -- )
|
||||
'[ [ _ ndrop ] dip ] ;
|
||||
|
||||
MACRO: ntuck ( n -- )
|
||||
2 + [ dupd -nrot ] curry ;
|
||||
2 + '[ dup _ -nrot ] ;
|
||||
|
||||
MACRO: nrev ( n -- quot )
|
||||
1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ;
|
||||
|
||||
MACRO: ndip ( quot n -- )
|
||||
dup saver -rot restorer 3append ;
|
||||
[ '[ _ dip ] ] times ;
|
||||
|
||||
MACRO: nslip ( n -- )
|
||||
dup saver [ call ] rot restorer 3append ;
|
||||
'[ [ call ] _ ndip ] ;
|
||||
|
||||
MACRO: nkeep ( n -- )
|
||||
[ ] [ 1+ ] [ ] tri
|
||||
'[ [ _ ndup ] dip _ -nrot _ nslip ] ;
|
||||
MACRO: nkeep ( quot n -- )
|
||||
tuck '[ _ ndup _ _ ndip ] ;
|
||||
|
||||
MACRO: ncurry ( n -- )
|
||||
[ curry ] n*quot ;
|
||||
|
|
@ -64,5 +71,5 @@ MACRO: nwith ( n -- )
|
|||
|
||||
MACRO: napply ( n -- )
|
||||
2 [a,b]
|
||||
[ [ 1- ] keep '[ _ ntuck _ nslip ] ]
|
||||
[ [ 1- ] [ ] bi '[ _ ntuck _ nslip ] ]
|
||||
map concat >quotation [ call ] append ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: http http.server http.client tools.test multiline
|
|||
io.streams.string io.encodings.utf8 io.encodings.8-bit
|
||||
io.encodings.binary io.encodings.string kernel arrays splitting
|
||||
sequences assocs io.sockets db db.sqlite continuations urls
|
||||
hashtables accessors ;
|
||||
hashtables accessors namespaces ;
|
||||
IN: http.tests
|
||||
|
||||
[ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test
|
||||
|
|
@ -11,6 +11,12 @@ IN: http.tests
|
|||
|
||||
[ "application/octet-stream" binary ] [ "application/octet-stream" parse-content-type ] unit-test
|
||||
|
||||
[ { } ] [ "" parse-cookie ] unit-test
|
||||
[ { } ] [ "" parse-set-cookie ] unit-test
|
||||
|
||||
! Make sure that totally invalid cookies don't confuse us
|
||||
[ { } ] [ "hello world; how are you" parse-cookie ] unit-test
|
||||
|
||||
: lf>crlf "\n" split "\r\n" join ;
|
||||
|
||||
STRING: read-request-test-1
|
||||
|
|
@ -126,6 +132,7 @@ content-type: text/html; charset=UTF-8
|
|||
;
|
||||
|
||||
read-response-test-1' 1array [
|
||||
URL" http://localhost/" url set
|
||||
read-response-test-1 lf>crlf
|
||||
[ read-response ] with-string-reader
|
||||
[ write-response ] with-string-writer
|
||||
|
|
|
|||
|
|
@ -142,16 +142,15 @@ PEG: parse-header-line ( string -- pair )
|
|||
'space' ,
|
||||
'attr' ,
|
||||
'space' ,
|
||||
[ "=" token , 'space' , 'value' , ] seq* [ peek ] action
|
||||
epsilon [ drop f ] action
|
||||
2choice ,
|
||||
[ "=" token , 'space' , 'value' , ] seq* [ peek ] action optional ,
|
||||
'space' ,
|
||||
] seq* ;
|
||||
|
||||
: 'av-pairs' ( -- parser )
|
||||
'av-pair' ";" token list-of optional ;
|
||||
|
||||
PEG: (parse-set-cookie) ( string -- alist ) 'av-pairs' just ;
|
||||
PEG: (parse-set-cookie) ( string -- alist )
|
||||
'av-pairs' just [ sift ] action ;
|
||||
|
||||
: 'cookie-value' ( -- parser )
|
||||
[
|
||||
|
|
@ -162,7 +161,10 @@ PEG: (parse-set-cookie) ( string -- alist ) 'av-pairs' just ;
|
|||
'space' ,
|
||||
'value' ,
|
||||
'space' ,
|
||||
] seq* ;
|
||||
] seq*
|
||||
[ ";,=" member? not ] satisfy repeat1 [ drop f ] action
|
||||
2choice ;
|
||||
|
||||
PEG: (parse-cookie) ( string -- alist )
|
||||
'cookie-value' [ ";," member? ] satisfy list-of optional just ;
|
||||
'cookie-value' [ ";," member? ] satisfy list-of
|
||||
optional just [ sift ] action ;
|
||||
|
|
|
|||
|
|
@ -418,6 +418,19 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
|
|||
[ "USE: locals [let | a" eval ] [ error>> unexpected-eof? ] must-fail-with
|
||||
[ "USE: locals [|" eval ] [ error>> unexpected-eof? ] must-fail-with
|
||||
|
||||
[ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
|
||||
[ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
|
||||
|
||||
:: FAILdog-1 ( -- b ) { [| c | c ] } ;
|
||||
|
||||
\ FAILdog-1 must-infer
|
||||
|
||||
:: FAILdog-2 ( a -- b ) a { [| c | c ] } cond ;
|
||||
|
||||
\ FAILdog-2 must-infer
|
||||
|
||||
[ 3 ] [ 3 [| a | \ a ] call ] unit-test
|
||||
|
||||
! :: wlet-&&-test ( a -- ? )
|
||||
! [wlet | is-integer? [ a integer? ]
|
||||
! is-even? [ a even? ]
|
||||
|
|
|
|||
|
|
@ -206,6 +206,8 @@ M: array rewrite-literal? [ rewrite-literal? ] contains? ;
|
|||
|
||||
M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
|
||||
|
||||
M: wrapper rewrite-literal? drop t ;
|
||||
|
||||
M: hashtable rewrite-literal? drop t ;
|
||||
|
||||
M: vector rewrite-literal? drop t ;
|
||||
|
|
@ -235,12 +237,17 @@ M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
|
|||
M: tuple rewrite-element
|
||||
[ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
|
||||
|
||||
M: lambda rewrite-element local-rewrite* ;
|
||||
|
||||
M: local rewrite-element , ;
|
||||
|
||||
M: local-reader rewrite-element , ;
|
||||
|
||||
M: word rewrite-element literalize , ;
|
||||
|
||||
M: wrapper rewrite-element
|
||||
dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ;
|
||||
|
||||
M: object rewrite-element , ;
|
||||
|
||||
M: array local-rewrite* rewrite-element ;
|
||||
|
|
@ -251,8 +258,10 @@ M: tuple local-rewrite* rewrite-element ;
|
|||
|
||||
M: hashtable local-rewrite* rewrite-element ;
|
||||
|
||||
M: wrapper local-rewrite* rewrite-element ;
|
||||
|
||||
M: word local-rewrite*
|
||||
dup { >r r> } memq?
|
||||
dup { >r r> load-locals get-local drop-locals } memq?
|
||||
[ >r/r>-in-lambda-error ] [ call-next-method ] if ;
|
||||
|
||||
M: object lambda-rewrite* , ;
|
||||
|
|
@ -350,10 +359,15 @@ M: wlet local-rewrite*
|
|||
word [ over "declared-effect" set-word-prop ] when*
|
||||
in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
|
||||
|
||||
ERROR: bad-lambda-rewrite output ;
|
||||
|
||||
M: bad-lambda-rewrite summary
|
||||
drop "You have found a bug in locals. Please report." ;
|
||||
|
||||
: parse-locals-definition ( word -- word quot )
|
||||
"(" expect parse-locals \ ; (parse-lambda) <lambda>
|
||||
2dup "lambda" set-word-prop
|
||||
lambda-rewrite first ;
|
||||
lambda-rewrite dup length 1 = [ first ] [ bad-lambda-rewrite ] if ;
|
||||
|
||||
: (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
|
||||
|
||||
|
|
|
|||
|
|
@ -22,9 +22,3 @@ M: macro definition "macro" word-prop ;
|
|||
|
||||
M: macro reset-word
|
||||
[ call-next-method ] [ f "macro" set-word-prop ] bi ;
|
||||
|
||||
: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
|
||||
|
||||
: saver ( n -- quot ) \ >r <repetition> >quotation ;
|
||||
|
||||
: restorer ( n -- quot ) \ r> <repetition> >quotation ;
|
||||
|
|
|
|||
|
|
@ -23,17 +23,12 @@ IN: math.bitwise
|
|||
|
||||
: bitroll ( x s w -- y )
|
||||
[ wrap ] keep
|
||||
[ shift-mod ]
|
||||
[ [ - ] keep shift-mod ] 3bi bitor ; inline
|
||||
[ shift-mod ] [ [ - ] keep shift-mod ] 3bi bitor ; inline
|
||||
|
||||
: bitroll-32 ( n s -- n' ) 32 bitroll ; inline
|
||||
|
||||
HINTS: bitroll-32 bignum fixnum ;
|
||||
|
||||
: bitroll-64 ( n s -- n' ) 64 bitroll ; inline
|
||||
|
||||
HINTS: bitroll-64 bignum fixnum ;
|
||||
|
||||
! 32-bit arithmetic
|
||||
: w+ ( int int -- int ) + 32 bits ; inline
|
||||
: w- ( int int -- int ) - 32 bits ; inline
|
||||
|
|
|
|||
|
|
@ -71,18 +71,22 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
line-vertices GL_LINES 0 2 glDrawArrays ;
|
||||
|
||||
: (rect-vertices) ( dim -- vertices )
|
||||
#! We use GL_LINE_STRIP with a duplicated first vertex
|
||||
#! instead of GL_LINE_LOOP to work around a bug in Apple's
|
||||
#! X3100 driver.
|
||||
{
|
||||
[ drop 0.5 0.5 ]
|
||||
[ first 0.3 - 0.5 ]
|
||||
[ [ first 0.3 - ] [ second 0.3 - ] bi ]
|
||||
[ second 0.3 - 0.5 swap ]
|
||||
} cleave 8 narray >c-float-array ;
|
||||
[ drop 0.5 0.5 ]
|
||||
} cleave 10 narray >c-float-array ;
|
||||
|
||||
: rect-vertices ( dim -- )
|
||||
(rect-vertices) gl-vertex-pointer ;
|
||||
|
||||
: (gl-rect) ( -- )
|
||||
GL_LINE_LOOP 0 4 glDrawArrays ;
|
||||
GL_LINE_STRIP 0 5 glDrawArrays ;
|
||||
|
||||
: gl-rect ( dim -- )
|
||||
rect-vertices (gl-rect) ;
|
||||
|
|
@ -119,7 +123,16 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
: circle-points ( loc dim steps -- points )
|
||||
circle-steps unit-circle adjust-points scale-points ;
|
||||
|
||||
: close-path ( points -- points' )
|
||||
dup first suffix ;
|
||||
|
||||
: circle-vertices ( loc dim steps -- vertices )
|
||||
#! We use GL_LINE_STRIP with a duplicated first vertex
|
||||
#! instead of GL_LINE_LOOP to work around a bug in Apple's
|
||||
#! X3100 driver.
|
||||
circle-points close-path concat >c-float-array ;
|
||||
|
||||
: fill-circle-vertices ( loc dim steps -- vertices )
|
||||
circle-points concat >c-float-array ;
|
||||
|
||||
: (gen-gl-object) ( quot -- id )
|
||||
|
|
|
|||
|
|
@ -177,7 +177,7 @@ PRIVATE>
|
|||
|
||||
M: radio-paint recompute-pen
|
||||
swap dim>>
|
||||
[ { 4 4 } swap { 9 9 } v- circle-steps circle-vertices >>interior-vertices ]
|
||||
[ { 4 4 } swap { 9 9 } v- circle-steps fill-circle-vertices >>interior-vertices ]
|
||||
[ { 1 1 } swap { 3 3 } v- circle-steps circle-vertices >>boundary-vertices ] bi
|
||||
drop ;
|
||||
|
||||
|
|
@ -194,7 +194,7 @@ M: radio-paint draw-interior
|
|||
|
||||
M: radio-paint draw-boundary
|
||||
[ (radio-paint) ] [ boundary-vertices>> gl-vertex-pointer ] bi
|
||||
GL_LINE_LOOP 0 circle-steps glDrawArrays ;
|
||||
GL_LINE_STRIP 0 circle-steps 1+ glDrawArrays ;
|
||||
|
||||
:: radio-knob-theme ( gadget -- gadget )
|
||||
[let | radio-paint [ black <radio-paint> ] |
|
||||
|
|
|
|||
|
|
@ -12,8 +12,7 @@ TUPLE: canvas < gadget dlist ;
|
|||
|
||||
: delete-canvas-dlist ( canvas -- )
|
||||
[ find-gl-context ]
|
||||
[ dlist>> [ delete-dlist ] when* ]
|
||||
[ f >>dlist drop ] tri ;
|
||||
[ [ [ delete-dlist ] when* f ] change-dlist drop ] bi ;
|
||||
|
||||
: make-canvas-dlist ( canvas quot -- dlist )
|
||||
[ drop ] [ GL_COMPILE swap make-dlist ] 2bi
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays documents io kernel math models
|
||||
namespaces make opengl opengl.gl sequences strings io.styles
|
||||
math.vectors sorting colors combinators assocs math.order fry
|
||||
calendar alarms ui.clipboards ui.commands ui.gadgets
|
||||
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
|
||||
ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.wrappers
|
||||
ui.render ui.gestures math.geometry.rect ;
|
||||
namespaces locals fry make opengl opengl.gl sequences strings
|
||||
io.styles math.vectors sorting colors combinators assocs
|
||||
math.order fry calendar alarms ui.clipboards ui.commands
|
||||
ui.gadgets ui.gadgets.borders ui.gadgets.buttons
|
||||
ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.theme
|
||||
ui.gadgets.wrappers ui.render ui.gestures math.geometry.rect ;
|
||||
IN: ui.gadgets.editors
|
||||
|
||||
TUPLE: editor < gadget
|
||||
|
|
@ -104,14 +104,20 @@ M: editor ungraft*
|
|||
editor-font* "" string-height ;
|
||||
|
||||
: y>line ( y editor -- line# )
|
||||
[ line-height / >fixnum ] keep model>> validate-line ;
|
||||
line-height / >fixnum ;
|
||||
|
||||
: point>loc ( point editor -- loc )
|
||||
[
|
||||
[ first2 ] dip tuck y>line dup ,
|
||||
[ dup editor-font* ] dip
|
||||
rot editor-line x>offset ,
|
||||
] { } make ;
|
||||
:: point>loc ( point editor -- loc )
|
||||
point second editor y>line {
|
||||
{ [ dup 0 < ] [ drop { 0 0 } ] }
|
||||
{ [ dup editor model>> last-line# > ] [ drop editor model>> doc-end ] }
|
||||
[| n |
|
||||
n
|
||||
point first
|
||||
editor editor-font*
|
||||
n editor editor-line
|
||||
x>offset 2array
|
||||
]
|
||||
} cond ;
|
||||
|
||||
: clicked-loc ( editor -- loc )
|
||||
[ hand-rel ] keep point>loc ;
|
||||
|
|
@ -141,8 +147,8 @@ M: editor ungraft*
|
|||
line-height * ;
|
||||
|
||||
: caret-loc ( editor -- loc )
|
||||
[ editor-caret* ] keep 2dup loc>x
|
||||
rot first rot line>y 2array ;
|
||||
[ editor-caret* ] keep
|
||||
[ loc>x ] [ [ first ] dip line>y ] 2bi 2array ;
|
||||
|
||||
: caret-dim ( editor -- dim )
|
||||
line-height 0 swap 2array ;
|
||||
|
|
@ -175,12 +181,16 @@ M: editor ungraft*
|
|||
[ font>> ] dip { 0 0 } draw-string ;
|
||||
|
||||
: first-visible-line ( editor -- n )
|
||||
clip get rect-loc second origin get second -
|
||||
swap y>line ;
|
||||
[
|
||||
[ clip get rect-loc second origin get second - ] dip
|
||||
y>line
|
||||
] keep model>> validate-line ;
|
||||
|
||||
: last-visible-line ( editor -- n )
|
||||
clip get rect-extent nip second origin get second -
|
||||
swap y>line 1+ ;
|
||||
[
|
||||
[ clip get rect-extent nip second origin get second - ] dip
|
||||
y>line
|
||||
] keep model>> validate-line 1+ ;
|
||||
|
||||
: with-editor ( editor quot -- )
|
||||
[
|
||||
|
|
@ -193,9 +203,8 @@ M: editor ungraft*
|
|||
] with-scope ; inline
|
||||
|
||||
: visible-lines ( editor -- seq )
|
||||
\ first-visible-line get
|
||||
\ last-visible-line get
|
||||
rot control-value <slice> ;
|
||||
[ \ first-visible-line get \ last-visible-line get ] dip
|
||||
control-value <slice> ;
|
||||
|
||||
: with-editor-translation ( n quot -- )
|
||||
[ line-translation origin get v+ ] dip with-translation ;
|
||||
|
|
@ -313,9 +322,9 @@ M: editor gadget-text* editor-string % ;
|
|||
: editor-cut ( editor clipboard -- )
|
||||
dupd gadget-copy remove-selection ;
|
||||
|
||||
: delete/backspace ( elt editor quot -- )
|
||||
: delete/backspace ( editor quot -- )
|
||||
over gadget-selection? [
|
||||
drop nip remove-selection
|
||||
drop remove-selection
|
||||
] [
|
||||
[ [ [ editor-caret* ] [ model>> ] bi ] dip call ]
|
||||
[ drop model>> ]
|
||||
|
|
@ -323,19 +332,19 @@ M: editor gadget-text* editor-string % ;
|
|||
] if ; inline
|
||||
|
||||
: editor-delete ( editor elt -- )
|
||||
swap [ over [ rot next-elt ] dip swap ] delete/backspace ;
|
||||
'[ dupd _ next-elt ] delete/backspace ;
|
||||
|
||||
: editor-backspace ( editor elt -- )
|
||||
swap [ over [ rot prev-elt ] dip ] delete/backspace ;
|
||||
'[ over [ _ prev-elt ] dip ] delete/backspace ;
|
||||
|
||||
: editor-select-prev ( editor elt -- )
|
||||
swap [ rot prev-elt ] change-caret ;
|
||||
'[ _ prev-elt ] change-caret ;
|
||||
|
||||
: editor-prev ( editor elt -- )
|
||||
dupd editor-select-prev mark>caret ;
|
||||
|
||||
: editor-select-next ( editor elt -- )
|
||||
swap [ rot next-elt ] change-caret ;
|
||||
'[ _ next-elt ] change-caret ;
|
||||
|
||||
: editor-next ( editor elt -- )
|
||||
dupd editor-select-next mark>caret ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,17 @@
|
|||
USING: accessors kernel namespaces tools.test ui.gadgets
|
||||
ui.gadgets.frames ui.gadgets.grids ui.gadgets.labels ;
|
||||
IN: ui.gadgets.frames.tests
|
||||
USING: ui.gadgets.frames ui.gadgets tools.test ;
|
||||
|
||||
[ ] [ <frame> layout ] unit-test
|
||||
|
||||
[ t ] [
|
||||
<frame>
|
||||
"Hello world" <label> @top grid-add
|
||||
"Hello world" <label> @center grid-add
|
||||
dup pref-dim "dim1" set
|
||||
{ 1000 1000 } >>dim
|
||||
dup layout*
|
||||
dup pref-dim "dim2" set
|
||||
drop
|
||||
"dim1" get "dim2" get =
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,15 +1,17 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic kernel math namespaces sequences words
|
||||
splitting grouping math.vectors ui.gadgets.grids ui.gadgets
|
||||
math.geometry.rect ;
|
||||
USING: accessors arrays generic kernel math namespaces sequences
|
||||
words splitting grouping math.vectors ui.gadgets.grids
|
||||
ui.gadgets math.geometry.rect ;
|
||||
IN: ui.gadgets.frames
|
||||
|
||||
! A frame arranges gadgets in a 3x3 grid, where the center
|
||||
! gadgets gets left-over space.
|
||||
TUPLE: frame < grid ;
|
||||
TUPLE: glue < gadget ;
|
||||
|
||||
: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
|
||||
M: glue pref-dim* drop { 0 0 } ;
|
||||
|
||||
: <glue> ( -- glue ) glue new-gadget ;
|
||||
|
||||
: <frame-grid> ( -- grid ) 9 [ <glue> ] replicate 3 group ;
|
||||
|
||||
: @center 1 1 ; inline
|
||||
: @left 0 1 ; inline
|
||||
|
|
@ -22,13 +24,15 @@ TUPLE: frame < grid ;
|
|||
: @bottom-left 0 2 ; inline
|
||||
: @bottom-right 2 2 ; inline
|
||||
|
||||
TUPLE: frame < grid ;
|
||||
|
||||
: new-frame ( class -- frame )
|
||||
<frame-grid> swap new-grid ; inline
|
||||
|
||||
: <frame> ( -- frame )
|
||||
frame new-frame ;
|
||||
|
||||
: (fill-center) ( n vec -- )
|
||||
: (fill-center) ( dim vec -- )
|
||||
[ [ first ] [ third ] bi v+ [v-] ] keep set-second ;
|
||||
|
||||
: fill-center ( dim horiz vert -- )
|
||||
|
|
@ -36,4 +40,4 @@ TUPLE: frame < grid ;
|
|||
|
||||
M: frame layout*
|
||||
dup compute-grid
|
||||
[ [ rect-dim ] 2dip fill-center ] [ grid-layout ] 3bi ;
|
||||
[ [ dim>> ] 2dip fill-center ] [ grid-layout ] 3bi ;
|
||||
|
|
|
|||
|
|
@ -46,7 +46,6 @@ M: menu-glass layout* gadget-child prefer ;
|
|||
faint-boundary ;
|
||||
|
||||
: <commands-menu> ( hook target commands -- gadget )
|
||||
<filled-pile>
|
||||
-roll
|
||||
[ <filled-pile> ] 3dip
|
||||
[ <menu-item> add-gadget ] with with each
|
||||
5 <border> menu-theme ;
|
||||
|
|
|
|||
|
|
@ -168,24 +168,29 @@ M: gradient draw-interior
|
|||
} cleave ;
|
||||
|
||||
! Polygon pen
|
||||
TUPLE: polygon color vertex-array count ;
|
||||
TUPLE: polygon color
|
||||
interior-vertices
|
||||
interior-count
|
||||
boundary-vertices
|
||||
boundary-count ;
|
||||
|
||||
: <polygon> ( color points -- polygon )
|
||||
[ concat >c-float-array ] [ length ] bi polygon boa ;
|
||||
|
||||
: draw-polygon ( polygon mode -- )
|
||||
swap
|
||||
[ color>> gl-color ]
|
||||
[ vertex-array>> gl-vertex-pointer ]
|
||||
[ 0 swap count>> glDrawArrays ]
|
||||
tri ;
|
||||
dup close-path [ [ concat >c-float-array ] [ length ] bi ] bi@
|
||||
polygon boa ;
|
||||
|
||||
M: polygon draw-boundary
|
||||
GL_LINE_LOOP draw-polygon drop ;
|
||||
nip
|
||||
[ color>> gl-color ]
|
||||
[ boundary-vertices>> gl-vertex-pointer ]
|
||||
[ [ GL_LINE_STRIP 0 ] dip boundary-count>> glDrawArrays ]
|
||||
tri ;
|
||||
|
||||
M: polygon draw-interior
|
||||
dup count>> 2 > GL_POLYGON GL_LINES ?
|
||||
draw-polygon drop ;
|
||||
nip
|
||||
[ color>> gl-color ]
|
||||
[ interior-vertices>> gl-vertex-pointer ]
|
||||
[ [ GL_POLYGON 0 ] dip interior-count>> glDrawArrays ]
|
||||
tri ;
|
||||
|
||||
: arrow-up { { 3 0 } { 6 6 } { 0 6 } } ;
|
||||
: arrow-right { { 0 0 } { 6 3 } { 0 6 } } ;
|
||||
|
|
|
|||
|
|
@ -6,9 +6,9 @@ listener debugger threads boxes concurrency.flags math arrays
|
|||
generic accessors combinators assocs fry ui.commands ui.gadgets
|
||||
ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes
|
||||
ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.packs
|
||||
ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations
|
||||
ui.tools.browser ui.tools.interactor ui.tools.inspector
|
||||
ui.tools.workspace ;
|
||||
ui.gadgets.tracks ui.gadgets.borders ui.gadgets.frames
|
||||
ui.gadgets.grids ui.gestures ui.operations ui.tools.browser
|
||||
ui.tools.interactor ui.tools.inspector ui.tools.workspace ;
|
||||
IN: ui.tools.listener
|
||||
|
||||
TUPLE: listener-gadget < track input output ;
|
||||
|
|
@ -153,9 +153,9 @@ M: engine-word word-completion-string
|
|||
dup <listener-input> >>input ;
|
||||
|
||||
: <listener-scroller> ( listener -- scroller )
|
||||
<filled-pile>
|
||||
over output>> add-gadget
|
||||
swap input>> add-gadget
|
||||
<frame>
|
||||
over output>> @top grid-add
|
||||
swap input>> @center grid-add
|
||||
<scroller> ;
|
||||
|
||||
: <listener-gadget> ( -- gadget )
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors namespaces make sequences kernel math arrays io
|
||||
ui.gadgets generic combinators ;
|
||||
|
|
@ -7,7 +7,7 @@ IN: ui.traverse
|
|||
TUPLE: node value children ;
|
||||
|
||||
: traverse-step ( path gadget -- path' gadget' )
|
||||
>r unclip r> children>> ?nth ;
|
||||
[ unclip ] dip children>> ?nth ;
|
||||
|
||||
: make-node ( quot -- ) { } make node boa , ; inline
|
||||
|
||||
|
|
@ -43,7 +43,7 @@ TUPLE: node value children ;
|
|||
traverse-step traverse-from-path ;
|
||||
|
||||
: (traverse-middle) ( frompath topath gadget -- )
|
||||
>r >r first 1+ r> first r> children>> <slice> % ;
|
||||
[ first 1+ ] [ first ] [ children>> ] tri* <slice> % ;
|
||||
|
||||
: traverse-post ( topath gadget -- )
|
||||
traverse-step traverse-to-path ;
|
||||
|
|
@ -59,8 +59,8 @@ TUPLE: node value children ;
|
|||
DEFER: (gadget-subtree)
|
||||
|
||||
: traverse-child ( frompath topath gadget -- )
|
||||
dup -roll [
|
||||
>r >r rest-slice r> r> traverse-step (gadget-subtree)
|
||||
[ -rot ] keep [
|
||||
[ rest-slice ] 2dip traverse-step (gadget-subtree)
|
||||
] make-node ;
|
||||
|
||||
: (gadget-subtree) ( frompath topath gadget -- )
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ windows.user32 windows.opengl32 windows.messages windows.types
|
|||
windows.nt windows threads libc combinators
|
||||
combinators.short-circuit continuations command-line shuffle
|
||||
opengl ui.render ascii math.bitwise locals symbols accessors
|
||||
math.geometry.rect math.order ascii ;
|
||||
math.geometry.rect math.order ascii calendar ;
|
||||
IN: ui.windows
|
||||
|
||||
SINGLETON: windows-ui-backend
|
||||
|
|
@ -472,7 +472,7 @@ M: windows-ui-backend do-events
|
|||
"MSG" malloc-object msg-obj set-global
|
||||
"Factor-window" utf16n malloc-string class-name-ptr set-global
|
||||
register-wndclassex drop
|
||||
GetDoubleClickTime double-click-timeout set-global ;
|
||||
GetDoubleClickTime milliseconds double-click-timeout set-global ;
|
||||
|
||||
: cleanup-win32-ui ( -- )
|
||||
class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
|
||||
|
|
|
|||
|
|
@ -45,7 +45,7 @@ ERROR: no-cond ;
|
|||
[ rot \ if 3array append [ ] like ] assoc-each ;
|
||||
|
||||
: cond>quot ( assoc -- quot )
|
||||
[ dup callable? [ [ t ] swap 2array ] when ] map
|
||||
[ dup pair? [ [ t ] swap 2array ] unless ] map
|
||||
reverse [ no-cond ] swap alist>quot ;
|
||||
|
||||
! case
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ ERROR: not-in-a-method-error ;
|
|||
SYMBOL: current-method
|
||||
|
||||
: with-method-definition ( method quot -- )
|
||||
[ dup current-method ] dip with-variable ; inline
|
||||
over current-method set call current-method off ; inline
|
||||
|
||||
: (M:) ( method def -- )
|
||||
CREATE-METHOD [ parse-definition ] with-method-definition ;
|
||||
|
|
|
|||
|
|
@ -15,9 +15,11 @@ IN: mason.common
|
|||
|
||||
:: upload-safely ( local username host remote -- )
|
||||
[let* | temp [ remote ".incomplete" append ]
|
||||
scp-remote [ { username "@" host ":" temp } concat ] |
|
||||
{ "scp" local scp-remote } short-running-process
|
||||
{ "ssh" host "-l" username "mv" temp remote } short-running-process
|
||||
scp-remote [ { username "@" host ":" temp } concat ]
|
||||
scp [ scp-command get ]
|
||||
ssh [ ssh-command get ] |
|
||||
{ scp local scp-remote } short-running-process
|
||||
{ ssh host "-l" username "mv" temp remote } short-running-process
|
||||
] ;
|
||||
|
||||
: eval-file ( file -- obj )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: system io.files namespaces kernel accessors ;
|
||||
USING: system io.files namespaces kernel accessors assocs ;
|
||||
IN: mason.config
|
||||
|
||||
! (Optional) Location for build directories
|
||||
|
|
@ -77,3 +77,10 @@ SYMBOL: upload-username
|
|||
|
||||
! Directory with binary packages.
|
||||
SYMBOL: upload-directory
|
||||
|
||||
! Optional: override ssh and scp command names
|
||||
SYMBOL: scp-command
|
||||
scp-command global [ "scp" or ] change-at
|
||||
|
||||
SYMBOL: ssh-command
|
||||
ssh-command global [ "ssh" or ] change-at
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ USING: mason.release.branch mason.config tools.test namespaces ;
|
|||
|
||||
[ { "scp" "boot.unix-x86.64.image" "joe@blah.com:/stuff/clean/netbsd-x86-64" } ] [
|
||||
[
|
||||
"scp" scp-command set
|
||||
"joe" image-username set
|
||||
"blah.com" image-host set
|
||||
"/stuff/clean" image-directory set
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces sequences prettyprint io.files
|
||||
io.launcher make
|
||||
mason.common mason.platform mason.config ;
|
||||
io.launcher make mason.common mason.platform mason.config ;
|
||||
IN: mason.release.branch
|
||||
|
||||
: branch-name ( -- string ) "clean-" platform append ;
|
||||
|
|
@ -25,7 +24,7 @@ IN: mason.release.branch
|
|||
|
||||
: upload-clean-image-cmd ( -- args )
|
||||
[
|
||||
"scp" ,
|
||||
scp-command get ,
|
||||
boot-image-name ,
|
||||
[
|
||||
image-username get % "@" %
|
||||
|
|
|
|||
|
|
@ -4,7 +4,8 @@
|
|||
USING: math.ranges sequences random accessors combinators.lib
|
||||
kernel namespaces fry db.types db.tuples urls validators
|
||||
html.components html.forms http http.server.dispatchers furnace
|
||||
furnace.actions furnace.boilerplate furnace.redirection ;
|
||||
furnace.actions furnace.boilerplate furnace.redirection
|
||||
furnace.utilities ;
|
||||
IN: webapps.wee-url
|
||||
|
||||
TUPLE: wee-url < dispatcher ;
|
||||
|
|
|
|||
|
|
@ -7,8 +7,8 @@ syndication farkup
|
|||
html.components html.forms
|
||||
http.server
|
||||
http.server.dispatchers
|
||||
furnace
|
||||
furnace.actions
|
||||
furnace.utilities
|
||||
furnace.redirection
|
||||
furnace.auth
|
||||
furnace.auth.login
|
||||
|
|
|
|||
|
|
@ -109,49 +109,47 @@ buffer."
|
|||
:group 'factor
|
||||
:group 'faces)
|
||||
|
||||
(defsubst factor--face (face) `((t ,(face-attr-construct face))))
|
||||
|
||||
(defface factor-font-lock-parsing-word (factor--face font-lock-keyword-face)
|
||||
(defface factor-font-lock-parsing-word (face-default-spec font-lock-keyword-face)
|
||||
"Face for parsing words."
|
||||
:group 'factor-faces)
|
||||
|
||||
(defface factor-font-lock-comment (factor--face font-lock-comment-face)
|
||||
(defface factor-font-lock-comment (face-default-spec font-lock-comment-face)
|
||||
"Face for comments."
|
||||
:group 'factor-faces)
|
||||
|
||||
(defface factor-font-lock-string (factor--face font-lock-string-face)
|
||||
(defface factor-font-lock-string (face-default-spec font-lock-string-face)
|
||||
"Face for strings."
|
||||
:group 'factor-faces)
|
||||
|
||||
(defface factor-font-lock-stack-effect (factor--face font-lock-comment-face)
|
||||
(defface factor-font-lock-stack-effect (face-default-spec font-lock-comment-face)
|
||||
"Face for stack effect specifications."
|
||||
:group 'factor-faces)
|
||||
|
||||
(defface factor-font-lock-word-definition (factor--face font-lock-function-name-face)
|
||||
(defface factor-font-lock-word-definition (face-default-spec font-lock-function-name-face)
|
||||
"Face for word, generic or method being defined."
|
||||
:group 'factor-faces)
|
||||
|
||||
(defface factor-font-lock-symbol-definition (factor--face font-lock-variable-name-face)
|
||||
(defface factor-font-lock-symbol-definition (face-default-spec font-lock-variable-name-face)
|
||||
"Face for name of symbol being defined."
|
||||
:group 'factor-faces)
|
||||
|
||||
(defface factor-font-lock-vocabulary-name (factor--face font-lock-constant-face)
|
||||
(defface factor-font-lock-vocabulary-name (face-default-spec font-lock-constant-face)
|
||||
"Face for names of vocabularies in USE or USING."
|
||||
:group 'factor-faces)
|
||||
|
||||
(defface factor-font-lock-type-definition (factor--face font-lock-type-face)
|
||||
(defface factor-font-lock-type-definition (face-default-spec font-lock-type-face)
|
||||
"Face for type (tuple) names."
|
||||
:group 'factor-faces)
|
||||
|
||||
(defface factor-font-lock-constructor (factor--face font-lock-type-face)
|
||||
(defface factor-font-lock-constructor (face-default-spec font-lock-type-face)
|
||||
"Face for constructors (<foo>)."
|
||||
:group 'factor-faces)
|
||||
|
||||
(defface factor-font-lock-setter-word (factor--face font-lock-function-name-face)
|
||||
(defface factor-font-lock-setter-word (face-default-spec font-lock-function-name-face)
|
||||
"Face for setter words (>>foo)."
|
||||
:group 'factor-faces)
|
||||
|
||||
(defface factor-font-lock-parsing-word (factor--face font-lock-keyword-face)
|
||||
(defface factor-font-lock-parsing-word (face-default-spec font-lock-keyword-face)
|
||||
"Face for parsing words."
|
||||
:group 'factor-faces)
|
||||
|
||||
|
|
@ -162,10 +160,6 @@ buffer."
|
|||
|
||||
;;; Factor mode font lock:
|
||||
|
||||
(defconst factor--regexp-word-start
|
||||
(let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M")))
|
||||
(format "^\\(%s\\)\\(:\\) " (mapconcat 'identity sws "\\|"))))
|
||||
|
||||
(defconst factor--parsing-words
|
||||
'("{" "}" "^:" "^::" ";" "<<" "<PRIVATE" ">>"
|
||||
"BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{"
|
||||
|
|
@ -204,7 +198,7 @@ buffer."
|
|||
(defconst factor--regex-using-line "^USING: +\\([^;]*\\);")
|
||||
(defconst factor--regex-use-line "^USE: +\\(.*\\)$")
|
||||
|
||||
(defconst factor-font-lock-keywords
|
||||
(defconst factor--font-lock-keywords
|
||||
`(("( .* )" . 'factor-font-lock-stack-effect)
|
||||
("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
|
||||
,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)")
|
||||
|
|
@ -224,6 +218,10 @@ buffer."
|
|||
|
||||
;;; Factor mode syntax:
|
||||
|
||||
(defconst factor--regexp-word-start
|
||||
(let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M")))
|
||||
(format "^\\(%s\\)\\(:\\) " (regexp-opt sws))))
|
||||
|
||||
(defconst factor--font-lock-syntactic-keywords
|
||||
`(("^\\(:\\)\\(:\\)" (1 ".") (2 "(;"))
|
||||
(,factor--regexp-word-start (2 "(;"))
|
||||
|
|
@ -323,7 +321,7 @@ buffer."
|
|||
"PRIVATE>" "<PRIVATE" "SYMBOL:" "USE:"))))
|
||||
|
||||
(defsubst factor--at-begin-of-def ()
|
||||
(looking-at "\\([^ ]\\|^\\)+:"))
|
||||
(looking-at factor--regexp-word-start))
|
||||
|
||||
(defsubst factor--looking-at-emptiness ()
|
||||
(looking-at "^[ \t]*$"))
|
||||
|
|
@ -502,17 +500,25 @@ buffer."
|
|||
(use-local-map factor-mode-map)
|
||||
(setq major-mode 'factor-mode)
|
||||
(setq mode-name "Factor")
|
||||
;; Font locking
|
||||
(set (make-local-variable 'comment-start) "! ")
|
||||
(set (make-local-variable 'parse-sexp-lookup-properties) t)
|
||||
(set (make-local-variable 'font-lock-comment-face) 'factor-font-lock-comment)
|
||||
(set (make-local-variable 'font-lock-string-face) 'factor-font-lock-string)
|
||||
(set (make-local-variable 'font-lock-defaults)
|
||||
`(factor-font-lock-keywords
|
||||
`(factor--font-lock-keywords
|
||||
nil nil nil nil
|
||||
(font-lock-syntactic-keywords . ,factor--font-lock-syntactic-keywords)))
|
||||
|
||||
(set-syntax-table factor-mode-syntax-table)
|
||||
;; Defun navigation
|
||||
(setq defun-prompt-regexp "[^ :]+")
|
||||
(set (make-local-variable 'open-paren-in-column-0-is-defun-start) t)
|
||||
;; Indentation
|
||||
(set (make-local-variable 'indent-line-function) 'factor--indent-line)
|
||||
(setq factor-indent-width (factor--guess-indent-width))
|
||||
(setq indent-tabs-mode nil)
|
||||
|
||||
(run-hooks 'factor-mode-hook))
|
||||
|
||||
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
|
||||
|
|
@ -568,6 +574,7 @@ buffer."
|
|||
"Generic word contract"
|
||||
"Inputs and outputs"
|
||||
"Parent topics:"
|
||||
"See also"
|
||||
"Syntax"
|
||||
"Vocabulary"
|
||||
"Warning"
|
||||
|
|
@ -578,7 +585,7 @@ buffer."
|
|||
|
||||
(defconst factor--help-font-lock-keywords
|
||||
`((,factor--help-headlines-regexp . 'factor-font-lock-help-mode-headlines)
|
||||
,@factor-font-lock-keywords))
|
||||
,@factor--font-lock-keywords))
|
||||
|
||||
(defun factor-help-mode ()
|
||||
"Major mode for displaying Factor help messages.
|
||||
|
|
@ -591,6 +598,7 @@ buffer."
|
|||
(set (make-local-variable 'font-lock-defaults)
|
||||
'(factor--help-font-lock-keywords t nil nil nil))
|
||||
(set (make-local-variable 'comint-redirect-subvert-readonly) t)
|
||||
(set (make-local-variable 'comint-redirect-echo-input) nil)
|
||||
(set (make-local-variable 'view-no-disable-on-exit) t)
|
||||
(view-mode)
|
||||
(setq view-exit-action
|
||||
|
|
@ -602,11 +610,11 @@ buffer."
|
|||
(run-mode-hooks 'factor-help-mode-hook))
|
||||
|
||||
(defun factor--listener-help-buffer ()
|
||||
(set-buffer (get-buffer-create "*factor-help*"))
|
||||
(with-current-buffer (get-buffer-create "*factor-help*")
|
||||
(let ((inhibit-read-only t))
|
||||
(delete-region (point-min) (point-max)))
|
||||
(factor-help-mode)
|
||||
(current-buffer))
|
||||
(current-buffer)))
|
||||
|
||||
(defvar factor--help-history nil)
|
||||
|
||||
|
|
@ -622,7 +630,8 @@ buffer."
|
|||
(hb (factor--listener-help-buffer))
|
||||
(proc (factor--listener-process)))
|
||||
(comint-redirect-send-command-to-process cmd hb proc nil)
|
||||
(pop-to-buffer hb)))
|
||||
(pop-to-buffer hb)
|
||||
(beginning-of-buffer hb)))
|
||||
|
||||
(defun factor-see ()
|
||||
(interactive)
|
||||
|
|
@ -643,13 +652,12 @@ vocabularies which have been modified on disk."
|
|||
|
||||
;;; Key bindings:
|
||||
|
||||
(defmacro factor--define-key (key cmd &optional both)
|
||||
(let ((m (gensym))
|
||||
(ms '(factor-mode-map)))
|
||||
(when both (push 'factor-help-mode-map ms))
|
||||
`(dolist (,m (list ,@ms))
|
||||
(define-key ,m [(control ?c) ,key] ,cmd)
|
||||
(define-key ,m [(control ?c) (control ,key)] ,cmd))))
|
||||
(defun factor--define-key (key cmd &optional both)
|
||||
(let ((ms (list factor-mode-map)))
|
||||
(when both (push factor-help-mode-map ms))
|
||||
(dolist (m ms)
|
||||
(define-key m (vector '(control ?c) key) cmd)
|
||||
(define-key m (vector '(control ?c) `(control ,key)) cmd))))
|
||||
|
||||
(factor--define-key ?f 'factor-run-file)
|
||||
(factor--define-key ?r 'factor-send-region)
|
||||
|
|
@ -662,7 +670,6 @@ vocabularies which have been modified on disk."
|
|||
(define-key factor-mode-map "\C-ch" 'factor-help)
|
||||
(define-key factor-help-mode-map "\C-ch" 'factor-help)
|
||||
(define-key factor-mode-map "\C-m" 'newline-and-indent)
|
||||
(define-key factor-mode-map [tab] 'indent-for-tab-command)
|
||||
|
||||
(define-key factor-listener-mode-map [f8] 'factor-refresh-all)
|
||||
|
||||
|
|
|
|||
|
|
@ -885,12 +885,13 @@ void garbage_collection(CELL gen,
|
|||
/* collect objects referenced from older generations */
|
||||
collect_cards();
|
||||
|
||||
if(collecting_gen != TENURED)
|
||||
{
|
||||
/* don't scan code heap unless it has pointers to this
|
||||
generation or younger */
|
||||
if(collecting_gen >= last_code_heap_scan)
|
||||
{
|
||||
if(collecting_gen != TENURED)
|
||||
{
|
||||
|
||||
/* if we are doing code GC, then we will copy over
|
||||
literals from any code block which gets marked as live.
|
||||
if we are not doing code GC, just consider all literals
|
||||
|
|
@ -898,13 +899,13 @@ void garbage_collection(CELL gen,
|
|||
code_heap_scans++;
|
||||
|
||||
collect_literals();
|
||||
}
|
||||
|
||||
if(collecting_accumulation_gen_p())
|
||||
last_code_heap_scan = collecting_gen;
|
||||
else
|
||||
last_code_heap_scan = collecting_gen + 1;
|
||||
}
|
||||
}
|
||||
|
||||
collect_next_loop(scan,&newspace->here);
|
||||
|
||||
|
|
|
|||
|
|
@ -25,6 +25,14 @@ NS_ENDHANDLER
|
|||
|
||||
void early_init(void)
|
||||
{
|
||||
SInt32 version;
|
||||
Gestalt(gestaltSystemVersion,&version);
|
||||
if(version <= 0x1050)
|
||||
{
|
||||
printf("Factor requires Mac OS X 10.5 or later.\n");
|
||||
exit(1);
|
||||
}
|
||||
|
||||
[[NSAutoreleasePool alloc] init];
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue