{ +foreign-id+ { f f "references" } }
+ { +on-update+ { f f "on update" } }
{ +on-delete+ { f f "on delete" } }
{ +restrict+ { f f "restrict" } }
{ +cascade+ { f f "cascade" } }
[ " or " 0% ] [ dupd where ] interleave drop
] in-parens ;
+M: NULL where ( spec obj -- )
+ drop column-name>> 0% " is NULL" 0% ;
+
: object-where ( spec obj -- )
over column-name>> 0% " = " 0% bind# ;
{ +random-id+ { "integer" "integer" f } }
{ +foreign-id+ { "integer" "integer" "references" } }
+ { +on-update+ { f f "on update" } }
{ +on-delete+ { f f "on delete" } }
{ +restrict+ { f f "restrict" } }
{ +cascade+ { f f "cascade" } }
"Now we've created a book. Let's save it to the database."
{ $code <" USING: db db.sqlite fry io.files ;
: with-book-tutorial ( quot -- )
- '[ "book-tutorial.db" temp-file sqlite-db _ with-db ] call ;
+ '[ "book-tutorial.db" temp-file <sqlite-db> _ with-db ] call ;
[
book recreate-table
T{ exam } select-tuples
] unit-test
- [ 4 ] [ T{ exam } count-tuples ] unit-test ;
+ [ 4 ] [ T{ exam } count-tuples ] unit-test
+
+ [ ] [ T{ exam { score 10 } } insert-tuple ] unit-test
+
+ [ 10 ]
+ [ T{ exam { name NULL } } select-tuples first score>> ] unit-test ;
TUPLE: bignum-test id m n o ;
: <bignum-test> ( m n o -- obj )
UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
-+foreign-id+ +has-many+ +on-delete+ +restrict+ +cascade+ +set-null+
-+set-default+ ;
++foreign-id+ +has-many+ +on-update+ +on-delete+ +restrict+ +cascade+
++set-null+ +set-default+ ;
SYMBOL: IGNORE
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
-SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
+SINGLETONS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
FACTOR-BLOB NULL URL ;
"The Factor " { $snippet "Makefile" } " builds the Factor VM both as an executable and a library. The library can be used by other applications. File names for the library on various operating systems:"
{ $table
{ "OS" "Library name" "Shared?" }
- { "Windows XP/Vista" { $snippet "factor-nt.dll" } "Yes" }
- { "Windows CE" { $snippet "factor-ce.dll" } "Yes" }
+ { "Windows XP/Vista" { $snippet "factor.dll" } "Yes" }
+ ! { "Windows CE" { $snippet "factor-ce.dll" } "Yes" }
{ "Mac OS X" { $snippet "libfactor.dylib" } "Yes" }
{ "Other Unix" { $snippet "libfactor.a" } "No" }
}
--- /dev/null
+
+USING: kernel parser lexer locals.private ;
+
+IN: bind-in
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ->
+ "[" parse-tokens make-locals dup push-locals
+ \ ] (parse-lambda) <lambda>
+ parsed-lambda
+ \ call parsed ; parsing
\ No newline at end of file
--- /dev/null
+
+USING: kernel assocs locals combinators
+ math math.functions system unicode.case ;
+
+IN: dns.cache.nx
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: nx-cache ( -- table ) H{ } ;
+
+: nx-cache-at ( name -- time ) >lower nx-cache at ;
+: nx-cache-delete-at ( name -- ) >lower nx-cache delete-at ;
+: nx-cache-set-at ( time name -- ) >lower nx-cache set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: now ( -- seconds ) millis 1000.0 / round >integer ;
+
+:: non-existent-name? ( NAME -- ? )
+ [let | TIME [ NAME nx-cache-at ] |
+ {
+ { [ TIME f = ] [ f ] }
+ { [ TIME now <= ] [ NAME nx-cache-delete-at f ] }
+ { [ t ] [ t ] }
+ }
+ cond
+ ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: cache-non-existent-name ( NAME TTL -- )
+ [let | TIME [ TTL now + ] | TIME NAME nx-cache-set-at ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: kernel sequences assocs sets locals combinators
+ accessors system math math.functions unicode.case prettyprint
+ combinators.cleave dns ;
+
+IN: dns.cache.rr
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <entry> time data ;
+
+: now ( -- seconds ) millis 1000.0 / round >integer ;
+
+: expired? ( <entry> -- ? ) time>> now <= ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-cache-key ( obj -- key )
+ { [ name>> >lower ] [ type>> unparse ] [ class>> unparse ] } 1arr " " join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cache ( -- table ) H{ } ;
+
+: cache-at ( obj -- ent ) make-cache-key cache at ;
+: cache-delete ( obj -- ) make-cache-key cache delete-at ;
+: cache-set-at ( ent obj -- ) make-cache-key cache set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: cache-get ( OBJ -- rrs/f )
+ [let | ENT [ OBJ cache-at ] |
+ {
+ { [ ENT f = ] [ f ] }
+ { [ ENT expired? ] [ OBJ cache-delete f ] }
+ {
+ [ t ]
+ [
+ [let | NAME [ OBJ name>> ]
+ TYPE [ OBJ type>> ]
+ CLASS [ OBJ class>> ]
+ TTL [ now ENT time>> - ] |
+ ENT data>>
+ [| RDATA | T{ rr f NAME TYPE CLASS TTL RDATA } ]
+ map
+ ]
+ ]
+ }
+ }
+ cond
+ ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: cache-add ( RR -- )
+ [let | ENT [ RR cache-at ]
+ TIME [ RR ttl>> now + ]
+ RDATA [ RR rdata>> ] |
+ {
+ { [ ENT f = ] [ T{ <entry> f TIME V{ RDATA } } RR cache-set-at ] }
+ { [ ENT expired? ] [ RR cache-delete RR cache-add ] }
+ { [ t ] [ TIME ENT (>>time) RDATA ENT data>> adjoin ] }
+ }
+ cond
+ ] ;
\ No newline at end of file
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2008 Alex Chapman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: boxes hats kernel namespaces symbols tools.test ;
+IN: hats.tests
+
+SYMBOLS: lion giraffe elephant rabbit ;
+
+! caps
+[ rabbit ] [ rabbit <cap> out ] unit-test
+[ rabbit ] [ f <cap> rabbit in out ] unit-test
+[ rabbit ] [ rabbit <cap> take ] unit-test
+[ f ] [ rabbit <cap> empty-hat out ] unit-test
+[ rabbit f ] [ rabbit <cap> [ take ] keep out ] unit-test
+[ rabbit t ] [ rabbit <cap> [ take ] keep empty-hat? ] unit-test
+[ lion ] [ rabbit <cap> [ drop lion ] change-hat out ] unit-test
+
+! bowlers
+[ giraffe ] [ [ giraffe rabbit set rabbit <bowler> out ] with-scope ] unit-test
+
+[ rabbit ]
+[
+ [
+ lion rabbit set [
+ rabbit rabbit set rabbit <bowler> out
+ ] with-scope
+ ] with-scope
+] unit-test
+
+[ rabbit ] [
+ rabbit <bowler>
+ [
+ lion rabbit set [
+ rabbit rabbit set out
+ ] with-scope
+ ] with-scope
+] unit-test
+
+[ elephant ] [
+ rabbit <bowler>
+ [
+ elephant rabbit set [
+ rabbit rabbit set
+ ] with-scope
+ out
+ ] with-scope
+] unit-test
+
+[ rabbit ] [
+ rabbit <bowler>
+ [
+ elephant in [
+ rabbit in out
+ ] with-scope
+ ] with-scope
+] unit-test
+
+[ elephant ] [
+ rabbit <bowler>
+ [
+ elephant in [
+ rabbit in
+ ] with-scope
+ out
+ ] with-scope
+] unit-test
+
+! Top Hats
+[ lion ] [ lion rabbit set-global rabbit <top-hat> out ] unit-test
+[ giraffe ] [ rabbit <top-hat> giraffe in out ] unit-test
+
+! Tuple hats
+TUPLE: foo bar ;
+C: <foo> foo
+
+: test-tuple ( -- tuple )
+ rabbit <foo> ;
+
+: test-slot-hat ( -- slot-hat )
+ test-tuple 2 <slot-hat> ; ! hack!
+
+[ rabbit ] [ test-slot-hat out ] unit-test
+[ lion ] [ test-slot-hat lion in out ] unit-test
+
+! Boxes as hats
+[ rabbit ] [ <box> rabbit in out ] unit-test
+[ <box> rabbit in lion in ] must-fail
+[ <box> out ] must-fail
--- /dev/null
+! Copyright (C) 2008 Alex Chapman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors boxes kernel namespaces ;
+IN: hats
+
+! Bullwinkle: Hey Rocky, watch me pull a rabbit out of my hat!
+! Rocky: But that trick never works!
+! Bullwinkle: This time for sure!
+
+! hat protocol
+MIXIN: hat
+
+GENERIC: out ( hat -- object )
+GENERIC: (in) ( object hat -- )
+
+: in ( hat object -- hat ) over (in) ; inline
+: empty-hat? ( hat -- ? ) out not ; inline
+: empty-hat ( hat -- hat ) f in ; inline
+: take ( hat -- object ) dup out f rot (in) ; inline
+: change-hat ( hat quot -- hat )
+ over >r >r out r> call r> swap in ; inline
+
+! caps (the simplest of hats)
+TUPLE: cap object ;
+C: <cap> cap
+M: cap out ( cap -- object ) object>> ;
+M: cap (in) ( object cap -- ) (>>object) ;
+INSTANCE: cap hat
+
+! bowlers (dynamic variable hats)
+TUPLE: bowler variable ;
+C: <bowler> bowler
+M: bowler out ( bowler -- object ) variable>> get ;
+M: bowler (in) ( object bowler -- ) variable>> set ;
+INSTANCE: bowler hat
+
+! Top Hats (global variable hats)
+TUPLE: top-hat variable ;
+C: <top-hat> top-hat
+M: top-hat out ( top-hat -- object ) variable>> get-global ;
+M: top-hat (in) ( object top-hat -- ) variable>> set-global ;
+INSTANCE: top-hat hat
+
+USE: slots.private
+! Slot hats
+TUPLE: slot-hat tuple slot ;
+C: <slot-hat> slot-hat
+: >slot-hat< ( slot-hat -- tuple slot ) [ tuple>> ] [ slot>> ] bi ; inline
+M: slot-hat out ( slot-hat -- object ) >slot-hat< slot ;
+M: slot-hat (in) ( object slot-hat -- ) >slot-hat< set-slot ;
+INSTANCE: slot-hat hat
+
+! Put a box on your head
+M: box out ( box -- object ) box> ;
+M: box (in) ( object box -- ) >box ;
+INSTANCE: box hat
+
--- /dev/null
+A protocol for getting and setting
! Deployment example
USING: db.sqlite furnace.alloy namespaces http.server ;
-: calculator-db ( -- params db ) "calculator.db" sqlite-db ;
+: calculator-db ( -- db ) "calculator.db" <sqlite-db> ;
: run-calculator ( -- )
<calculator>
! Deployment example
USING: db.sqlite furnace.alloy namespaces ;
-: counter-db ( -- params db ) "counter.db" sqlite-db ;
+: counter-db ( -- db ) "counter.db" <sqlite-db> ;
: run-counter ( -- )
<counter-app>