diff --git a/basis/alarms/summary.txt b/basis/alarms/summary.txt new file mode 100644 index 0000000000..f6e12238fa --- /dev/null +++ b/basis/alarms/summary.txt @@ -0,0 +1 @@ +One-time and recurring events diff --git a/basis/alias/summary.txt b/basis/alias/summary.txt new file mode 100644 index 0000000000..15690a7b9b --- /dev/null +++ b/basis/alias/summary.txt @@ -0,0 +1 @@ +Defining multiple words with the same name diff --git a/basis/ascii/ascii-docs.factor b/basis/ascii/ascii-docs.factor index 75af8a7102..6af697cf89 100755 --- a/basis/ascii/ascii-docs.factor +++ b/basis/ascii/ascii-docs.factor @@ -46,6 +46,6 @@ ARTICLE: "ascii" "ASCII character classes" { $subsection printable? } { $subsection control? } { $subsection quotable? } -"Modern applications should use Unicode 5.0 instead (" { $vocab-link "unicode" } ")." ; +"Modern applications should use Unicode 5.0 instead (" { $vocab-link "unicode.categories" } ")." ; ABOUT: "ascii" diff --git a/basis/binary-search/summary.txt b/basis/binary-search/summary.txt new file mode 100644 index 0000000000..c4fd4f2774 --- /dev/null +++ b/basis/binary-search/summary.txt @@ -0,0 +1 @@ +Fast searching of sorted arrays diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 9284728a7a..db8e8c8ec0 100755 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -26,7 +26,6 @@ IN: bootstrap.image "x86.32" "x86.64" "linux-ppc" "macosx-ppc" - ! "arm" } ; assoc + { + class<=-cache class-not-cache classes-intersect-cache + class-and-cache class-or-cache next-method-quot-cache + } [ H{ } clone ] H{ } map>assoc assoc-union bootstrap-global set bootstrap-global emit-userenv ; diff --git a/basis/bootstrap/random/random.factor b/basis/bootstrap/random/random.factor index 3782d517cf..f6527cdda1 100755 --- a/basis/bootstrap/random/random.factor +++ b/basis/bootstrap/random/random.factor @@ -13,4 +13,4 @@ IN: bootstrap.random [ [ 32 random-bits ] with-system-random random-generator set-global -] "generator.random" add-init-hook +] "bootstrap.random" add-init-hook diff --git a/basis/boxes/summary.txt b/basis/boxes/summary.txt new file mode 100644 index 0000000000..44c1352e36 --- /dev/null +++ b/basis/boxes/summary.txt @@ -0,0 +1 @@ +An abstraction for enforcing a mutual-exclusion invariant diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 62ff4ad517..c3d84fc783 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -21,8 +21,8 @@ HELP: { $description "Returns a timestamp object representing the start of the specified day in your current timezone." } { $examples { $example "USING: calendar prettyprint ;" - "2010 12 25 ." - "T{ timestamp\n { year 2010 }\n { month 12 }\n { day 25 }\n { gmt-offset T{ duration { hour -5 } } }\n}" + "2010 12 25 >gmt midnight ." + "T{ timestamp { year 2010 } { month 12 } { day 25 } }" } } ; diff --git a/basis/calendar/format/format-tests.factor b/basis/calendar/format/format-tests.factor index c433a118c2..81930cdf49 100755 --- a/basis/calendar/format/format-tests.factor +++ b/basis/calendar/format/format-tests.factor @@ -62,3 +62,15 @@ IN: calendar.format.tests T{ duration f 0 0 0 -5 0 0 } } ] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test + +[ + T{ timestamp + { year 2008 } + { month 10 } + { day 2 } + { hour 23 } + { minute 59 } + { second 59 } + { gmt-offset T{ duration f 0 0 0 0 0 0 } } + } +] [ "Thursday, 02-Oct-2008 23:59:59 GMT" cookie-string>timestamp ] unit-test diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index bfe438fae1..b15da42409 100755 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -201,9 +201,13 @@ ERROR: invalid-timestamp-format ; : rfc822>timestamp ( str -- timestamp ) [ (rfc822>timestamp) ] with-string-reader ; +: check-day-name ( str -- ) + [ day-abbreviations3 member? ] [ day-names member? ] bi or + check-timestamp drop ; + : (cookie-string>timestamp-1) ( -- timestamp ) timestamp new - "," read-token day-abbreviations3 member? check-timestamp drop + "," read-token check-day-name read1 CHAR: \s assert= "-" read-token checked-number >>day "-" read-token month-abbreviations index 1+ check-timestamp >>month @@ -218,7 +222,7 @@ ERROR: invalid-timestamp-format ; : (cookie-string>timestamp-2) ( -- timestamp ) timestamp new - read-sp day-abbreviations3 member? check-timestamp drop + read-sp check-day-name read-sp month-abbreviations index 1+ check-timestamp >>month read-sp checked-number >>day ":" read-token checked-number >>hour diff --git a/basis/channels/remote/tags.txt b/basis/channels/remote/tags.txt index f4274299b1..ce745d18c6 100644 --- a/basis/channels/remote/tags.txt +++ b/basis/channels/remote/tags.txt @@ -1 +1 @@ -extensions +concurrency diff --git a/basis/channels/tags.txt b/basis/channels/tags.txt index f4274299b1..ce745d18c6 100644 --- a/basis/channels/tags.txt +++ b/basis/channels/tags.txt @@ -1 +1 @@ -extensions +concurrency diff --git a/basis/circular/circular-docs.factor b/basis/circular/circular-docs.factor index 362d41c9de..c7af57c1fe 100644 --- a/basis/circular/circular-docs.factor +++ b/basis/circular/circular-docs.factor @@ -43,7 +43,7 @@ HELP: push-growing-circular { "elt" object } { "circular" circular } } { $description "Pushes an element onto a " { $link growing-circular } " object." } ; -ARTICLE: "circular" "circular" +ARTICLE: "circular" "Circular sequences" "The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl "Creating a new circular object:" { $subsection } diff --git a/basis/cocoa/cocoa-docs.factor b/basis/cocoa/cocoa-docs.factor index 01b0809f37..a971288251 100644 --- a/basis/cocoa/cocoa-docs.factor +++ b/basis/cocoa/cocoa-docs.factor @@ -19,7 +19,7 @@ HELP: SUPER-> ARTICLE: "objc-calling" "Calling Objective C code" "Before an Objective C class can be used, it must be imported; by default, a small set of common classes are imported automatically, but additional classes can be imported as needed." { $subsection import-objc-class } -"Every imported Objective C class has as corresponding class word in the " { $vocab-link "objc-classes" } " vocabulary. Class words push the class object in the stack, allowing class methods to be invoked." +"Every imported Objective C class has as corresponding class word in the " { $vocab-link "cocoa.classes" } " vocabulary. Class words push the class object in the stack, allowing class methods to be invoked." $nl "Messages can be sent to classes and instances using a pair of parsing words:" { $subsection POSTPONE: -> } diff --git a/basis/colors/summary.txt b/basis/colors/summary.txt new file mode 100644 index 0000000000..a90b1aaf76 --- /dev/null +++ b/basis/colors/summary.txt @@ -0,0 +1 @@ +Colors as a first-class data type diff --git a/basis/combinators/short-circuit/short-circuit-docs.factor b/basis/combinators/short-circuit/short-circuit-docs.factor index 058291d022..54fc3aac43 100644 --- a/basis/combinators/short-circuit/short-circuit-docs.factor +++ b/basis/combinators/short-circuit/short-circuit-docs.factor @@ -64,7 +64,7 @@ HELP: n||-rewrite { "quot" quotation } } { $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each OR quotation." } ; -ARTICLE: "combinators.short-circuit" "combinators.short-circuit" +ARTICLE: "combinators.short-circuit" "Short-circuit combinators" "The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl "AND combinators:" { $subsection 0&& } diff --git a/basis/combinators/short-circuit/smart/smart-docs.factor b/basis/combinators/short-circuit/smart/smart-docs.factor index abf3ff0eef..34abde15b6 100644 --- a/basis/combinators/short-circuit/smart/smart-docs.factor +++ b/basis/combinators/short-circuit/smart/smart-docs.factor @@ -27,8 +27,9 @@ HELP: || } } ; -ARTICLE: "combinators.short-circuit.smart" "combinators.short-circuit.smart" -"The " { $vocab-link "combinators.short-circuit.smart" } " vocabulary infers the number of inputs that the sequence of quotations takes." $nl +ARTICLE: "combinators.short-circuit.smart" "Smart short-circuit combinators" +"The " { $vocab-link "combinators.short-circuit.smart" } " vocabulary is similar to " { $vocab-link "combinators.short-circuit" } " except the combinators here infer the number of inputs that the sequence of quotations takes." +$nl "Generalized AND:" { $subsection && } "Generalized OR:" diff --git a/basis/compiler/generator/generator-docs.factor b/basis/compiler/generator/generator-docs.factor index 45238ab00a..5d485b13d4 100755 --- a/basis/compiler/generator/generator-docs.factor +++ b/basis/compiler/generator/generator-docs.factor @@ -4,7 +4,7 @@ kernel vectors arrays effects sequences ; IN: compiler.generator ARTICLE: "generator" "Compiled code generator" -"Most of the words in the " { $vocab-link "generator" } " vocabulary are internal to the compiler and user code has no reason to call them." +"Most of the words in the " { $vocab-link "compiler.generator" } " vocabulary are internal to the compiler and user code has no reason to call them." $nl "Debugging information can be enabled or disabled; this hook is used by " { $link "tools.deploy" } ":" { $subsection compiled-stack-traces? } diff --git a/basis/compiler/intrinsics/intrinsics.factor b/basis/compiler/intrinsics/intrinsics.factor index b995e6d737..471c05ee59 100644 --- a/basis/compiler/intrinsics/intrinsics.factor +++ b/basis/compiler/intrinsics/intrinsics.factor @@ -4,20 +4,42 @@ USING: kernel classes.tuple classes.tuple.private math arrays byte-arrays words stack-checker.known-words ; IN: compiler.intrinsics -: (tuple) ( layout -- tuple ) - "BUG: missing (tuple) intrinsic" throw ; +ERROR: missing-intrinsic ; + +: (tuple) ( n -- tuple ) missing-intrinsic ; \ (tuple) { tuple-layout } { tuple } define-primitive \ (tuple) make-flushable -: (array) ( n -- array ) - "BUG: missing (array) intrinsic" throw ; +: (array) ( n -- array ) missing-intrinsic ; \ (array) { integer } { array } define-primitive \ (array) make-flushable -: (byte-array) ( n -- byte-array ) - "BUG: missing (byte-array) intrinsic" throw ; +: (byte-array) ( n -- byte-array ) missing-intrinsic ; \ (byte-array) { integer } { byte-array } define-primitive \ (byte-array) make-flushable + +: (ratio) ( -- ratio ) missing-intrinsic ; + +\ (ratio) { } { ratio } define-primitive +\ (ratio) make-flushable + +: (complex) ( -- complex ) missing-intrinsic ; + +\ (complex) { } { complex } define-primitive +\ (complex) make-flushable + +: (wrapper) ( -- wrapper ) missing-intrinsic ; + +\ (wrapper) { } { wrapper } define-primitive +\ (wrapper) make-flushable + +: (set-slot) ( val obj n -- ) missing-intrinsic ; + +\ (set-slot) { object object fixnum } { } define-primitive + +: (write-barrier) ( obj -- ) missing-intrinsic ; + +\ (write-barrier) { object } { } define-primitive diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 0891a6629c..5f8de4eb49 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -298,6 +298,12 @@ SYMBOL: value-infos : node-output-infos ( node -- seq ) dup out-d>> [ node-value-info ] with map ; +: first-literal ( #call -- obj ) + dup in-d>> first node-value-info literal>> ; + +: last-literal ( #call -- obj ) + dup out-d>> peek node-value-info literal>> ; + : immutable-tuple-boa? ( #call -- ? ) dup word>> \ eq? [ dup in-d>> peek node-value-info diff --git a/basis/concurrency/combinators/tags.txt b/basis/concurrency/combinators/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/combinators/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/conditions/tags.txt b/basis/concurrency/conditions/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/conditions/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/count-downs/tags.txt b/basis/concurrency/count-downs/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/count-downs/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/distributed/tags.txt b/basis/concurrency/distributed/tags.txt index 50cfa263f6..b7861c6689 100644 --- a/basis/concurrency/distributed/tags.txt +++ b/basis/concurrency/distributed/tags.txt @@ -1,2 +1,2 @@ +concurrency enterprise -extensions diff --git a/basis/concurrency/exchangers/tags.txt b/basis/concurrency/exchangers/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/exchangers/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/flags/tags.txt b/basis/concurrency/flags/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/flags/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/futures/tags.txt b/basis/concurrency/futures/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/futures/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/locks/tags.txt b/basis/concurrency/locks/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/locks/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/mailboxes/tags.txt b/basis/concurrency/mailboxes/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/mailboxes/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/messaging/tags.txt b/basis/concurrency/messaging/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/messaging/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/promises/tags.txt b/basis/concurrency/promises/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/promises/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/concurrency/semaphores/tags.txt b/basis/concurrency/semaphores/tags.txt new file mode 100644 index 0000000000..ce745d18c6 --- /dev/null +++ b/basis/concurrency/semaphores/tags.txt @@ -0,0 +1 @@ +concurrency diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index bb21391f0a..6bec4b23c0 100644 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -3,13 +3,10 @@ USING: alien alien.c-types alien.strings alien.syntax kernel math sequences namespaces make assocs init accessors continuations combinators core-foundation -core-foundation.run-loop io.encodings.utf8 destructors ; +core-foundation.run-loop core-foundation.run-loop.thread +io.encodings.utf8 destructors ; IN: core-foundation.fsevents -! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! -! FSEventStream API, Leopard only ! -! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! - : kFSEventStreamCreateFlagUseCFTypes 2 ; inline : kFSEventStreamCreateFlagWatchRoot 4 ; inline diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 5ffcafbbaf..e30cc2eb60 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -35,5 +35,3 @@ FUNCTION: SInt32 CFRunLoopRunInMode ( : start-run-loop-thread ( -- ) [ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ; - -[ start-run-loop-thread ] "core-foundation.run-loop" add-init-hook diff --git a/basis/core-foundation/run-loop/thread/thread.factor b/basis/core-foundation/run-loop/thread/thread.factor new file mode 100644 index 0000000000..326226ec0e --- /dev/null +++ b/basis/core-foundation/run-loop/thread/thread.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: init core-foundation.run-loop ; +IN: core-foundation.run-loop.thread + +! Load this vocabulary if you need a run loop running. + +[ start-run-loop-thread ] "core-foundation.run-loop.thread" add-init-hook diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index f8e3956b3e..74b72b8789 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: classes kernel help.markup help.syntax sequences -alien assocs strings math multiline ; +alien assocs strings math multiline quotations ; IN: db HELP: db @@ -45,7 +45,22 @@ HELP: prepared-statement { $description } ; HELP: result-set -{ $description } ; +{ $description "An object encapsulating a raw SQL result object. There are two ways in which a result set can be accessed, but they are specific to the database backend in use." + { $subsection "db-random-access-result-set" } + { $subsection "db-sequential-result-set" } +} ; + +HELP: init-result-set +{ $values + { "result-set" result-set } } +{ $description "" } ; + +HELP: new-result-set +{ $values + { "query" "a query" } { "handle" alien } { "class" class } + { "result-set" result-set } } +{ $description "Creates a new " { $link result-set } " object of type " { $snippet "class" } "." } ; + HELP: new-statement { $values { "sql" string } { "in" sequence } { "out" sequence } { "class" class } { "statement" statement } } @@ -81,7 +96,7 @@ HELP: query-results { $values { "query" object } { "result-set" result-set } } -{ $description "" } ; +{ $description "Returns a " { $link result-set } " object representing the reults of a SQL query." } ; HELP: #rows { $values { "result-set" result-set } { "n" integer } } @@ -95,36 +110,126 @@ HELP: row-column { $values { "result-set" result-set } { "column" integer } { "obj" object } } -{ $description "" } ; +{ $description "Returns the value indexed by " { $snippet "column" } " in the current row of a " { $link result-set } "." } ; HELP: row-column-typed { $values { "result-set" result-set } { "column" integer } { "sql" "sql" } } -{ $description "" } ; +{ $description "Returns the value indexed by " { $snippet "column" } " in the current row of a " { $link result-set } " and converts the result based on a type stored in the " { $link result-set } "'s " { $slot "out-params" } "." } ; HELP: advance-row { $values { "result-set" result-set } } -; +{ $description "Advanced the pointer to an underlying SQL result set stored in a " { $link result-set } " object." } ; HELP: more-rows? { $values { "result-set" result-set } { "?" "a boolean" } } -; +{ $description "Returns true if the " { $link result-set } " has more rows to traverse." } ; HELP: execute-statement* { $values { "statement" statement } { "type" object } } { $description } ; +HELP: execute-one-statement +{ $values + { "statement" null } } +{ $description "" } ; + HELP: execute-statement { $values { "statement" statement } } -{ $description } ; +{ $description "" } ; -ARTICLE: "db" "Low-level database library" + + + + + +HELP: begin-transaction +{ $description "Begins a new transaction. User code should make use of the " { $link with-transaction } " combinator." } ; + +HELP: bind-statement +{ $values + { "obj" object } { "statement" null } } +{ $description "" } ; + +HELP: commit-transaction +{ $description "Commits a transaction. User code should make use of the " { $link with-transaction } " combinator." } ; + +HELP: default-query +{ $values + { "query" null } + { "result-set" null } } +{ $description "" } ; + +HELP: in-transaction +{ $description "A variable that is set true when a transaction is in progress." } ; + +HELP: in-transaction? +{ $values + { "?" "a boolean" } } +{ $description "Returns true if there is currently a transaction in progress in this scope." } ; + +HELP: query-each +{ $values + { "statement" null } { "quot" quotation } } +{ $description "" } ; + +HELP: query-map +{ $values + { "statement" null } { "quot" quotation } + { "seq" sequence } } +{ $description "" } ; + +HELP: rollback-transaction +{ $description "Rolls back a transaction; no data is committed to the database. User code should make use of the " { $link with-transaction } " combinator." } ; + +HELP: sql-command +{ $values + { "sql" string } } +{ $description "Executes a SQL string using the databse in the " { $link db } " symbol." } ; + +HELP: sql-query +{ $values + { "sql" string } + { "rows" "an array of arrays of strings" } } +{ $description "Runs a SQL query of raw text in the database in the " { $link db } " symbol. Each row is returned as an array of strings; no type-conversions are done on the resulting data." } ; + +{ sql-command sql-query } related-words + +HELP: sql-row +{ $values + { "result-set" result-set } + { "seq" sequence } } +{ $description "Returns the current row in a " { $link result-set } " as an array of strings." } ; + +HELP: sql-row-typed +{ $values + { "result-set" result-set } + { "seq" sequence } } +{ $description "Returns the current row in a " { $link result-set } " as an array of typed Factor objects." } ; + +{ sql-row sql-row-typed } related-words + +HELP: with-db +{ $values + { "seq" sequence } { "class" class } { "quot" quotation } } +{ $description "Calls the quotation with a database bound to the " { $link db } " symbol. The database called is based on the " { $snippet "class" } " with the " } ; + +HELP: with-transaction +{ $values + { "quot" quotation } } +{ $description "" } ; + +ARTICLE: "db" "Database library" { $subsection "db-custom-database-combinators" } { $subsection "db-protocol" } +{ $subsection "db-result-sets" } { $subsection "db-lowlevel-tutorial" } "Higher-level database:" { $vocab-subsection "Database types" "db.types" } { $vocab-subsection "High-level tuple/database integration" "db.tuples" } +! { $subsection "db-tuples" } +! { $subsection "db-tuples-protocol" } +! { $subsection "db-tuples-tutorial" } "Supported database backends:" { $vocab-subsection "SQLite" "db.sqlite" } { $vocab-subsection "PostgreSQL" "db.postgresql" } @@ -132,6 +237,40 @@ ARTICLE: "db" "Low-level database library" { $subsection "db-porting-the-library" } ; +ARTICLE: "db-random-access-result-set" "Random access result sets" +"Random-access result sets do not have to be traversed in order. For instance, PostgreSQL's result set object can be accessed as a matrix with i,j coordinates." +$nl +"Databases which work in this way must provide methods for the following traversal words:" +{ $subsection #rows } +{ $subsection #columns } +{ $subsection row-column } +{ $subsection row-column-typed } ; + +ARTICLE: "db-sequential-result-set" "Sequential result sets" +"Sequential result sets can be iterated one element after the next. SQLite's result sets offer this method of traversal." +$nl +"Databases which work in this way must provide methods for the following traversal words:" +{ $subsection more-rows? } +{ $subsection advance-row } +{ $subsection row-column } +{ $subsection row-column-typed } ; + +ARTICLE: "db-result-sets" "Result sets" +"Result sets are the encapsulated, database-specific results from a SQL query." +$nl +"Two possible protocols for iterating over result sets exist:" +{ $subsection "db-random-access-result-set" } +{ $subsection "db-sequential-result-set" } +"Query the number of rows or columns:" +{ $subsection #rows } +{ $subsection #columns } +"Traversing a result set:" +{ $subsection advance-row } +{ $subsection more-rows? } +"Pulling out a single row of results:" +{ $subsection row-column } +{ $subsection row-column-typed } ; + ARTICLE: "db-protocol" "Low-level database protocol" "The high-level protocol (see " { $vocab-link "db.tuples" } ") uses this low-level protocol for executing statements and queries." ; @@ -144,7 +283,6 @@ ARTICLE: "db-porting-the-library" "Porting the database library" "This section is not yet written." ; - ARTICLE: "db-custom-database-combinators" "Custom database combinators" "Every database library requires some effort on the programmer's part to initialize and open a database. SQLite uses files on your harddisk, so a simple pathname is all the setup required. With PostgreSQL, you log in to a networked server as a user on a specfic port." $nl @@ -155,7 +293,6 @@ USING: db.sqlite db io.files ; { "my-database.db" temp-file } sqlite-db rot with-db ; "> } - ; ABOUT: "db" diff --git a/basis/db/db.factor b/basis/db/db.factor index eac22a2999..87bf21d261 100755 --- a/basis/db/db.factor +++ b/basis/db/db.factor @@ -80,11 +80,14 @@ GENERIC: execute-statement* ( statement type -- ) M: object execute-statement* ( statement type -- ) drop query-results dispose ; +: execute-one-statement ( statement -- ) + dup type>> execute-statement* ; + : execute-statement ( statement -- ) dup sequence? [ - [ execute-statement ] each + [ execute-one-statement ] each ] [ - dup type>> execute-statement* + execute-one-statement ] if ; : bind-statement ( obj statement -- ) diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index 38fa4cc715..28548d1260 100755 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -5,7 +5,7 @@ kernel math math.parser namespaces make prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi db.tuples db.types tools.annotations math.ranges combinators classes locals words tools.walker -nmake accessors random db.queries destructors ; +nmake accessors random db.queries destructors db.tuples.private ; USE: tools.walker IN: db.postgresql @@ -37,8 +37,7 @@ M: postgresql-db db-open ( db -- db ) M: postgresql-db dispose ( db -- ) handle>> PQfinish ; -M: postgresql-statement bind-statement* ( statement -- ) - drop ; +M: postgresql-statement bind-statement* ( statement -- ) drop ; GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding ) @@ -67,11 +66,11 @@ M: postgresql-result-set #columns ( result-set -- n ) [ handle>> ] [ n>> ] bi ; M: postgresql-result-set row-column ( result-set column -- object ) - >r result-handle-n r> pq-get-string ; + [ result-handle-n ] dip pq-get-string ; M: postgresql-result-set row-column-typed ( result-set column -- object ) dup pick out-params>> nth type>> - >r >r result-handle-n r> r> postgresql-column-typed ; + [ result-handle-n ] 2dip postgresql-column-typed ; M: postgresql-statement query-results ( query -- result-set ) dup bind-params>> [ @@ -126,13 +125,20 @@ M: postgresql-db bind# ( spec object -- ) : create-table-sql ( class -- statement ) [ + dupd "create table " 0% 0% "(" 0% [ ", " 0% ] [ dup column-name>> 0% " " 0% dup type>> lookup-create-type 0% modifiers 0% - ] interleave ");" 0% + ] interleave + + ", " 0% + find-primary-key + "primary key(" 0% + [ "," 0% ] [ column-name>> 0% ] interleave + "));" 0% ] query-make ; : create-function-sql ( class -- statement ) @@ -160,8 +166,7 @@ M: postgresql-db bind# ( spec object -- ) M: postgresql-db create-sql-statement ( class -- seq ) [ [ create-table-sql , ] keep - dup db-columns find-primary-key db-assigned-id-spec? - [ create-function-sql , ] [ drop ] if + dup db-assigned? [ create-function-sql , ] [ drop ] if ] { } make ; : drop-function-sql ( class -- statement ) @@ -181,15 +186,14 @@ M: postgresql-db create-sql-statement ( class -- seq ) M: postgresql-db drop-sql-statement ( class -- seq ) [ [ drop-table-sql , ] keep - dup db-columns find-primary-key db-assigned-id-spec? - [ drop-function-sql , ] [ drop ] if + dup db-assigned? [ drop-function-sql , ] [ drop ] if ] { } make ; M: postgresql-db ( class -- statement ) [ "select add_" 0% 0% "(" 0% - dup find-primary-key 2, + dup find-primary-key first 2, remove-id [ ", " 0% ] [ bind% ] interleave ");" 0% @@ -218,14 +222,23 @@ M: postgresql-db ( class -- statement ) ");" 0% ] query-make ; -M: postgresql-db insert-tuple* ( tuple statement -- ) +M: postgresql-db insert-tuple-set-key ( tuple statement -- ) query-modify-tuple ; M: postgresql-db persistent-table ( -- hashtable ) H{ - { +db-assigned-id+ { "integer" "serial primary key" f } } - { +user-assigned-id+ { f f "primary key" } } - { +random-id+ { "bigint" "bigint primary key" f } } + { +db-assigned-id+ { "integer" "serial" f } } + { +user-assigned-id+ { f f f } } + { +random-id+ { "bigint" "bigint" f } } + + { +foreign-id+ { f f "references" } } + + { +on-delete+ { f f "on delete" } } + { +restrict+ { f f "restrict" } } + { +cascade+ { f f "cascade" } } + { +set-null+ { f f "set null" } } + { +set-default+ { f f "set default" } } + { TEXT { "text" "text" f } } { VARCHAR { "varchar" "varchar" f } } { INTEGER { "integer" "integer" f } } @@ -240,7 +253,6 @@ M: postgresql-db persistent-table ( -- hashtable ) { BLOB { "bytea" "bytea" f } } { FACTOR-BLOB { "bytea" "bytea" f } } { URL { "varchar" "varchar" f } } - { +foreign-id+ { f f "references" } } { +autoincrement+ { f f "autoincrement" } } { +unique+ { f f "unique" } } { +default+ { f f "default" } } @@ -256,10 +268,6 @@ M: postgresql-db compound ( string object -- string' ) over { { "default" [ first number>string join-space ] } { "varchar" [ first number>string paren append ] } - { "references" [ - first2 >r [ unparse join-space ] keep db-columns r> - swap [ slot-name>> = ] with find nip - column-name>> paren append - ] } + { "references" [ >reference-string ] } [ drop no-compound-found ] } case ; diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index 89c28b5262..0b206cea8f 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel math namespaces make sequences random strings math.parser math.intervals combinators math.bitwise -nmake db db.tuples db.types db.sql classes words shuffle arrays -destructors continuations ; +nmake db db.tuples db.types classes words shuffle arrays +destructors continuations db.tuples.private prettyprint ; IN: db.queries GENERIC: where ( specs obj -- ) @@ -45,14 +45,22 @@ M: retryable execute-statement* ( statement type -- ) : sql-props ( class -- columns table ) [ db-columns ] [ db-table ] bi ; -: query-make ( class quot -- ) - >r sql-props r> - [ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake - maybe-make-retryable ; inline +: query-make ( class quot -- statements ) + #! query, input, outputs, secondary queries + over unparse "table" set + [ sql-props ] dip + [ 0 sql-counter rot with-variable ] curry + { "" { } { } { } } nmake + [ maybe-make-retryable ] dip + [ [ 1array ] dip append ] unless-empty ; inline : where-primary-key% ( specs -- ) " where " 0% - find-primary-key dup column-name>> 0% " = " 0% bind% ; + find-primary-key [ + " and " 0% + ] [ + dup column-name>> 0% " = " 0% bind% + ] interleave ; M: db ( class -- statement ) [ @@ -121,16 +129,15 @@ M: string where ( spec obj -- ) object-where ; dup double-infinite-interval? [ drop f ] when ] with filter ; -: where-clause ( tuple specs -- ) - dupd filter-slots [ - drop +: many-where ( tuple seq -- ) + " where " 0% [ + " and " 0% ] [ - " where " 0% [ - " and " 0% - ] [ - 2dup slot-name>> swap get-slot-named where - ] interleave drop - ] if-empty ; + 2dup slot-name>> swap get-slot-named where + ] interleave drop ; + +: where-clause ( tuple specs -- ) + dupd filter-slots [ drop ] [ many-where ] if-empty ; M: db ( tuple table -- sql ) [ @@ -141,34 +148,30 @@ M: db ( tuple table -- sql ) M: db ( tuple class -- statement ) [ "select " 0% - over [ ", " 0% ] + [ dupd filter-ignores ] dip + over + [ ", " 0% ] [ dup column-name>> 0% 2, ] interleave - " from " 0% 0% where-clause ] query-make ; +: splice ( string1 string2 string3 -- string ) + swap 3append ; + : do-group ( tuple groups -- ) - [ - ", " join " group by " swap 3append - ] curry change-sql drop ; + [ ", " join " group by " splice ] curry change-sql drop ; : do-order ( tuple order -- ) - [ - ", " join " order by " swap 3append - ] curry change-sql drop ; + [ ", " join " order by " splice ] curry change-sql drop ; : do-offset ( tuple n -- ) - [ - number>string " offset " swap 3append - ] curry change-sql drop ; + [ number>string " offset " splice ] curry change-sql drop ; : do-limit ( tuple n -- ) - [ - number>string " limit " swap 3append - ] curry change-sql drop ; + [ number>string " limit " splice ] curry change-sql drop ; -: make-query ( tuple query -- tuple' ) +: make-query* ( tuple query -- tuple' ) dupd { [ group>> [ drop ] [ do-group ] if-empty ] @@ -177,28 +180,16 @@ M: db ( tuple class -- statement ) [ offset>> [ do-offset ] [ drop ] if* ] } 2cleave ; -M: db ( tuple class query -- tuple ) - [ ] dip make-query ; +M: db query>statement ( query -- tuple ) + [ tuple>> dup class ] keep + [ ] dip make-query* ; ! select ID, NAME, SCORE from EXAM limit 1 offset 3 -: select-tuples* ( tuple -- statement ) - dup - [ - select 0, - dup class db-columns [ ", " 0, ] - [ dup column-name>> 0, 2, ] interleave - from 0, - class name>> 0, - ] { { } { } { } } nmake - >r >r parse-sql 4drop r> r> - maybe-make-retryable do-select ; - -M: db ( tuple class groups -- statement ) - \ query new - swap >>group +M: db ( query -- statement ) + [ tuple>> dup class ] keep [ [ "select count(*) from " 0% 0% where-clause ] query-make ] - dip make-query ; + dip make-query* ; : create-index ( index-name table-name columns -- ) [ diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 1eb9b566d3..dfd9fab08c 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -5,7 +5,8 @@ io.files kernel math math.parser namespaces prettyprint sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators math.intervals io nmake accessors vectors math.ranges random -math.bitwise db.queries destructors ; +math.bitwise db.queries destructors db.tuples.private interpolate +io.streams.string multiline make ; IN: db.sqlite TUPLE: sqlite-db < db path ; @@ -88,7 +89,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- ) db get handle>> sqlite3_last_insert_rowid dup zero? [ "last-id failed" throw ] when ; -M: sqlite-db insert-tuple* ( tuple statement -- ) +M: sqlite-db insert-tuple-set-key ( tuple statement -- ) execute-statement last-insert-id swap set-primary-key ; M: sqlite-result-set #columns ( result-set -- n ) @@ -114,13 +115,21 @@ M: sqlite-statement query-results ( query -- result-set ) M: sqlite-db create-sql-statement ( class -- statement ) [ + dupd "create table " 0% 0% "(" 0% [ ", " 0% ] [ - dup column-name>> 0% + dup "sql-spec" set + dup column-name>> [ "table-id" set ] [ 0% ] bi " " 0% dup type>> lookup-create-type 0% modifiers 0% - ] interleave ");" 0% + ] interleave + + ", " 0% + find-primary-key + "primary key(" 0% + [ "," 0% ] [ column-name>> 0% ] interleave + "));" 0% ] query-make ; M: sqlite-db drop-sql-statement ( class -- statement ) @@ -161,23 +170,31 @@ M: sqlite-db bind% ( spec -- ) M: sqlite-db persistent-table ( -- assoc ) H{ - { +db-assigned-id+ { "integer primary key" "integer primary key" "primary key" } } - { +user-assigned-id+ { f f "primary key" } } - { +random-id+ { "integer primary key" "integer primary key" "primary key" } } - { INTEGER { "integer" "integer" "primary key" } } - { BIG-INTEGER { "bigint" "bigint" } } - { SIGNED-BIG-INTEGER { "bigint" "bigint" } } - { UNSIGNED-BIG-INTEGER { "bigint" "bigint" } } - { TEXT { "text" "text" } } - { VARCHAR { "text" "text" } } - { DATE { "date" "date" } } - { TIME { "time" "time" } } - { DATETIME { "datetime" "datetime" } } - { TIMESTAMP { "timestamp" "timestamp" } } - { DOUBLE { "real" "real" } } - { BLOB { "blob" "blob" } } - { FACTOR-BLOB { "blob" "blob" } } - { URL { "text" "text" } } + { +db-assigned-id+ { "integer" "integer" f } } + { +user-assigned-id+ { f f f } } + { +random-id+ { "integer" "integer" f } } + { +foreign-id+ { "integer" "integer" "references" } } + + { +on-delete+ { f f "on delete" } } + { +restrict+ { f f "restrict" } } + { +cascade+ { f f "cascade" } } + { +set-null+ { f f "set null" } } + { +set-default+ { f f "set default" } } + + { INTEGER { "integer" "integer" f } } + { BIG-INTEGER { "bigint" "bigint" f } } + { SIGNED-BIG-INTEGER { "bigint" "bigint" f } } + { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } } + { TEXT { "text" "text" f } } + { VARCHAR { "text" "text" f } } + { DATE { "date" "date" f } } + { TIME { "time" "time" f } } + { DATETIME { "datetime" "datetime" f } } + { TIMESTAMP { "timestamp" "timestamp" f } } + { DOUBLE { "real" "real" f } } + { BLOB { "blob" "blob" f } } + { FACTOR-BLOB { "blob" "blob" f } } + { URL { "text" "text" f } } { +autoincrement+ { f f "autoincrement" } } { +unique+ { f f "unique" } } { +default+ { f f "default" } } @@ -188,8 +205,110 @@ M: sqlite-db persistent-table ( -- assoc ) { random-generator { f f f } } } ; -M: sqlite-db compound ( str seq -- str' ) +: insert-trigger ( -- string ) + [ + <" + CREATE TRIGGER fki_${table}_${foreign-table}_id + BEFORE INSERT ON ${table} + FOR EACH ROW BEGIN + SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') + WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + END; + "> interpolate + ] with-string-writer ; + +: insert-trigger-not-null ( -- string ) + [ + <" + CREATE TRIGGER fki_${table}_${foreign-table}_id + BEFORE INSERT ON ${table} + FOR EACH ROW BEGIN + SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') + WHERE NEW.${foreign-table-id} IS NOT NULL + AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + END; + "> interpolate + ] with-string-writer ; + +: update-trigger ( -- string ) + [ + <" + CREATE TRIGGER fku_${table}_${foreign-table}_id + BEFORE UPDATE ON ${table} + FOR EACH ROW BEGIN + SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') + WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + END; + "> interpolate + ] with-string-writer ; + +: update-trigger-not-null ( -- string ) + [ + <" + CREATE TRIGGER fku_${table}_${foreign-table}_id + BEFORE UPDATE ON ${table} + FOR EACH ROW BEGIN + SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') + WHERE NEW.${foreign-table-id} IS NOT NULL + AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + END; + "> interpolate + ] with-string-writer ; + +: delete-trigger-restrict ( -- string ) + [ + <" + CREATE TRIGGER fkd_${table}_${foreign-table}_id + BEFORE DELETE ON ${foreign-table} + FOR EACH ROW BEGIN + SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"') + WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL; + END; + "> interpolate + ] with-string-writer ; + +: delete-trigger-cascade ( -- string ) + [ + <" + CREATE TRIGGER fkd_${table}_${foreign-table}_id + BEFORE DELETE ON ${foreign-table} + FOR EACH ROW BEGIN + DELETE from ${table} WHERE ${table-id} = OLD.${foreign-table-id}; + END; + "> interpolate + ] with-string-writer ; + +: can-be-null? ( -- ? ) + "sql-spec" get modifiers>> [ +not-null+ = ] contains? not ; + +: delete-cascade? ( -- ? ) + "sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ; + +: sqlite-trigger, ( string -- ) + { } { } 3, ; + +: create-sqlite-triggers ( -- ) + can-be-null? [ + insert-trigger sqlite-trigger, + update-trigger sqlite-trigger, + ] [ + insert-trigger-not-null sqlite-trigger, + update-trigger-not-null sqlite-trigger, + ] if + delete-cascade? [ + delete-trigger-cascade sqlite-trigger, + ] [ + delete-trigger-restrict sqlite-trigger, + ] if ; + +M: sqlite-db compound ( string seq -- new-string ) over { { "default" [ first number>string join-space ] } - [ 2drop ] + { "references" [ + [ >reference-string ] keep + first2 [ "foreign-table" set ] + [ "foreign-table-id" set ] bi* + create-sqlite-triggers + ] } + [ 2drop ] } case ; diff --git a/basis/db/tuples/tuples-docs.factor b/basis/db/tuples/tuples-docs.factor index 26ecec0365..d7ee3a5ad2 100644 --- a/basis/db/tuples/tuples-docs.factor +++ b/basis/db/tuples/tuples-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: classes help.markup help.syntax io.streams.string kernel -quotations sequences strings multiline math ; +quotations sequences strings multiline math db.types ; IN: db.tuples HELP: define-persistent @@ -11,7 +11,18 @@ HELP: define-persistent { $list { "a slot name from the " { $snippet "tuple class" } } { "the name of a database column that maps to the slot" } { "a database type (see " { $link "db.types" } ")" } -} } ; +} "Throws an error if the slot name (column one from each row) is not a slot in the tuple or its superclases." } +{ $examples + { $unchecked-example "USING: db.tuples db.types ;" + "TUPLE: boat id year name ;" + "boat \"BOAT\" {" + " { \"id\" \"ID\" +db-assigned-id+ }" + " { \"year\" \"YEAR\" INTEGER }" + " { \"name\" \"NAME\" TEXT }" + "} define-persistent" + "" + } +} ; HELP: create-table { $values @@ -64,36 +75,35 @@ HELP: delete-tuples HELP: select-tuple { $values - { "tuple" tuple } + { "query/tuple" tuple } { "tuple/f" "a tuple or f" } } { $description "A SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". Returns a single tuple from the database if it matches the query constructed from the exemplar tuple." } ; HELP: select-tuples { $values - { "tuple" tuple } + { "query/tuple" tuple } { "tuples" "an array of tuples" } } { $description "A SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". Returns a multiple tuples from the database that match the query constructed from the exemplar tuple." } ; HELP: count-tuples { $values - { "tuple" tuple } { "groups" "an array of slots to group by" } + { "query/tuple" tuple } { "n" integer } } -{ $description "" } ; +{ $description "Returns the number of items that would be returned if the query were a select query. Counting the tuples with this word is more efficient than calling " { $link length } " on the result of " { $link select-tuples } "." } ; + +{ select-tuple select-tuples count-tuples } related-words -HELP: query -{ $values - { "tuple" tuple } { "query" query } - { "tuples" "a sequence of tuples" } } -{ $description "Allows for queries with group by, order by, limit, and offset clauses. " } ; -{ select-tuple select-tuples count-tuples query } related-words ARTICLE: "db-tuples" "High-level tuple/database integration" "Start with a tutorial:" { $subsection "db-tuples-tutorial" } +"Database types supported:" +{ $subsection "db.types" } "Useful words:" { $subsection "db-tuples-words" } - +"For porting db.tuples to other databases:" +{ $subsection "db-tuples-protocol" } ; ARTICLE: "db-tuples-words" "High-level tuple/database words" @@ -115,12 +125,9 @@ ARTICLE: "db-tuples-words" "High-level tuple/database words" "Querying tuples:" { $subsection select-tuple } { $subsection select-tuples } -{ $subsection count-tuples } -"Advanced querying of tuples:" -{ $subsection query } ; +{ $subsection count-tuples } ; - -ARTICLE: "db-tuples-protocol" "High-level tuple/database protocol" +ARTICLE: "db-tuples-protocol" "Tuple database protocol" ; ARTICLE: "db-tuples-tutorial" "Tuple database tutorial" diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 67e46f9e18..6114c7ebe1 100755 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -4,9 +4,20 @@ USING: io.files kernel tools.test db db.tuples classes db.types continuations namespaces math math.ranges prettyprint calendar sequences db.sqlite math.intervals db.postgresql accessors random math.bitwise -math.ranges strings urls fry ; +math.ranges strings urls fry db.tuples.private ; IN: db.tuples.tests +: test-sqlite ( quot -- ) + [ ] swap '[ + "tuples-test.db" temp-file sqlite-db _ with-db + ] unit-test ; + +: test-postgresql ( quot -- ) + [ ] swap '[ + { "localhost" "postgres" "foob" "factor-test" } + postgresql-db _ with-db + ] unit-test ; + TUPLE: person the-id the-name the-number the-real ts date time blob factor-blob url ; @@ -165,46 +176,124 @@ SYMBOL: person4 T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } } f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" person4 set ; + TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: annotation n paste-id summary author mode contents ; -: db-assigned-paste-schema ( -- ) - paste "PASTE" - { - { "n" "ID" +db-assigned-id+ } - { "summary" "SUMMARY" TEXT } - { "author" "AUTHOR" TEXT } - { "channel" "CHANNEL" TEXT } - { "mode" "MODE" TEXT } - { "contents" "CONTENTS" TEXT } - { "date" "DATE" TIMESTAMP } - { "annotations" { +has-many+ annotation } } - } define-persistent +paste "PASTE" +{ + { "n" "ID" +db-assigned-id+ } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "channel" "CHANNEL" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + { "timestamp" "DATE" TIMESTAMP } + { "annotations" { +has-many+ annotation } } +} define-persistent +: annotation-schema-foreign-key ( -- ) annotation "ANNOTATION" { { "n" "ID" +db-assigned-id+ } - { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } } + { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } } { "summary" "SUMMARY" TEXT } { "author" "AUTHOR" TEXT } { "mode" "MODE" TEXT } { "contents" "CONTENTS" TEXT } } define-persistent ; -! { "localhost" "postgres" "" "factor-test" } postgresql-db [ - ! [ paste drop-table ] [ drop ] recover - ! [ annotation drop-table ] [ drop ] recover - ! [ paste drop-table ] [ drop ] recover - ! [ annotation drop-table ] [ drop ] recover - ! [ ] [ paste create-table ] unit-test - ! [ ] [ annotation create-table ] unit-test -! ] with-db +: annotation-schema-foreign-key-not-null ( -- ) + annotation "ANNOTATION" + { + { "n" "ID" +db-assigned-id+ } + { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } +not-null+ } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + } define-persistent ; -: test-sqlite ( quot -- ) - [ ] swap '[ "tuples-test.db" temp-file sqlite-db _ with-db ] unit-test ; +: annotation-schema-cascade ( -- ) + annotation "ANNOTATION" + { + { "n" "ID" +db-assigned-id+ } + { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } + +on-delete+ +cascade+ } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + } define-persistent ; -: test-postgresql ( quot -- ) - [ ] swap '[ { "localhost" "postgres" "foob" "factor-test" } postgresql-db _ with-db ] unit-test ; +: annotation-schema-restrict ( -- ) + annotation "ANNOTATION" + { + { "n" "ID" +db-assigned-id+ } + { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + } define-persistent ; + +: test-paste-schema ( -- ) + [ ] [ paste ensure-table ] unit-test + [ ] [ annotation ensure-table ] unit-test + [ ] [ annotation drop-table ] unit-test + [ ] [ paste drop-table ] unit-test + [ ] [ paste create-table ] unit-test + [ ] [ annotation create-table ] unit-test + + [ ] [ + paste new + "summary1" >>summary + "erg" >>author + "#lol" >>channel + "contents1" >>contents + now >>timestamp + insert-tuple + ] unit-test + + [ ] [ + annotation new + 1 >>paste-id + "annotation1" >>summary + "erg" >>author + "annotation contents" >>contents + insert-tuple + ] unit-test ; + +: test-foreign-key ( -- ) + [ ] [ annotation-schema-foreign-key ] unit-test + test-paste-schema + [ paste new 1 >>n delete-tuples ] must-fail ; + +: test-foreign-key-not-null ( -- ) + [ ] [ annotation-schema-foreign-key-not-null ] unit-test + test-paste-schema + [ paste new 1 >>n delete-tuples ] must-fail ; + +: test-cascade ( -- ) + [ ] [ annotation-schema-cascade ] unit-test + test-paste-schema + [ ] [ paste new 1 >>n delete-tuples ] unit-test + [ 0 ] [ paste new select-tuples length ] unit-test ; + +: test-restrict ( -- ) + [ ] [ annotation-schema-restrict ] unit-test + test-paste-schema + [ paste new 1 >>n delete-tuples ] must-fail ; + +[ test-foreign-key ] test-sqlite +[ test-foreign-key-not-null ] test-sqlite +[ test-cascade ] test-sqlite +[ test-restrict ] test-sqlite + +[ test-foreign-key ] test-postgresql +[ test-foreign-key-not-null ] test-postgresql +[ test-cascade ] test-postgresql +[ test-restrict ] test-postgresql : test-repeated-insert [ ] [ person ensure-table ] unit-test @@ -236,6 +325,17 @@ TUPLE: exam id name score ; exam boa ; : test-intervals ( -- ) + [ + exam "EXAM" + { + { "idd" "ID" +db-assigned-id+ } + { "named" "NAME" TEXT } + { "score" "SCORE" INTEGER } + } define-persistent + ] [ + seq>> { "idd" "named" } = + ] must-fail-with + exam "EXAM" { { "id" "ID" +db-assigned-id+ } @@ -250,6 +350,16 @@ TUPLE: exam id name score ; [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test + [ 4 ] + [ T{ exam { name IGNORE } { score IGNORE } } select-tuples length ] unit-test + + [ f ] + [ T{ exam { name IGNORE } { score IGNORE } } select-tuples first score>> ] unit-test + + ! FIXME + ! [ f ] + ! [ T{ exam { name IGNORE } { score IGNORE } { id IGNORE } } select-tuples first score>> ] unit-test + [ { T{ exam f 3 "Kenny" 60 } @@ -346,7 +456,7 @@ TUPLE: exam id name score ; T{ exam } select-tuples ] unit-test - [ 4 ] [ T{ exam } f count-tuples ] unit-test ; + [ 4 ] [ T{ exam } count-tuples ] unit-test ; TUPLE: bignum-test id m n o ; : ( m n o -- obj ) @@ -499,3 +609,42 @@ string-encoding-test "STRING_ENCODING_TEST" { \ ensure-table must-infer \ create-table must-infer \ drop-table must-infer + +: test-queries ( -- ) + [ ] [ exam ensure-table ] unit-test + [ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test + [ 5 ] [ + + T{ exam { score T{ interval { from { 0 t } } { to { 100 t } } } } } + >>tuple + 5 >>limit select-tuples length + ] unit-test ; + +TUPLE: compound-foo a b c ; + +compound-foo "COMPOUND_FOO" +{ + { "a" "A" INTEGER +user-assigned-id+ } + { "b" "B" INTEGER +user-assigned-id+ } + { "c" "C" INTEGER } +} define-persistent + +: test-compound-primary-key ( -- ) + [ ] [ compound-foo ensure-table ] unit-test + [ ] [ compound-foo drop-table ] unit-test + [ ] [ compound-foo create-table ] unit-test + [ ] [ 1 2 3 compound-foo boa insert-tuple ] unit-test + [ 1 2 3 compound-foo boa insert-tuple ] must-fail + [ ] [ 2 3 4 compound-foo boa insert-tuple ] unit-test + [ T{ compound-foo { a 2 } { b 3 } { c 4 } } ] + [ compound-foo new 4 >>c select-tuple ] unit-test ; + +[ test-compound-primary-key ] test-sqlite +[ test-compound-primary-key ] test-postgresql + +: sqlite-test-db ( -- ) + "tuples-test.db" temp-file sqlite-db make-db db-open db set ; + +: postgresql-test-db ( -- ) + { "localhost" "postgres" "foob" "factor-test" } postgresql-db + make-db db-open db set ; diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor index 3c3bae3adc..7f567697d2 100755 --- a/basis/db/tuples/tuples.factor +++ b/basis/db/tuples/tuples.factor @@ -3,36 +3,10 @@ USING: arrays assocs classes db kernel namespaces classes.tuple words sequences slots math accessors math.parser io prettyprint db.types continuations -destructors mirrors ; +destructors mirrors sets db.types ; IN: db.tuples -: define-persistent ( class table columns -- ) - >r dupd "db-table" set-word-prop dup r> - [ relation? ] partition swapd - dupd [ spec>tuple ] with map - "db-columns" set-word-prop - "db-relations" set-word-prop ; - -ERROR: not-persistent class ; - -: db-table ( class -- object ) - dup "db-table" word-prop [ ] [ not-persistent ] ?if ; - -: db-columns ( class -- object ) - superclasses [ "db-columns" word-prop ] map concat ; - -: db-relations ( class -- object ) - "db-relations" word-prop ; - -: set-primary-key ( key tuple -- ) - [ - class db-columns find-primary-key slot-name>> - ] keep set-slot-named ; - -SYMBOL: sql-counter -: next-sql-counter ( -- str ) - sql-counter [ inc ] [ get ] bi number>string ; - + db ( class -- object ) HOOK: db ( class -- object ) HOOK: db ( tuple class -- object ) HOOK: db ( tuple class -- tuple ) -TUPLE: query group order offset limit ; -HOOK: db ( tuple class query -- statement' ) -HOOK: db ( tuple class groups -- n ) +HOOK: db ( query -- statement ) +HOOK: query>statement db ( query -- statement ) -HOOK: insert-tuple* db ( tuple statement -- ) +HOOK: insert-tuple-set-key db ( tuple statement -- ) + +SYMBOL: sql-counter +: next-sql-counter ( -- str ) + sql-counter [ inc ] [ get ] bi number>string ; GENERIC: eval-generator ( singleton -- object ) : resulting-tuple ( exemplar-tuple row out-params -- tuple ) rot class new [ - [ - [ slot-name>> ] dip set-slot-named - ] curry 2each + [ [ slot-name>> ] dip set-slot-named ] curry 2each ] keep ; : query-tuples ( exemplar-tuple statement -- seq ) @@ -75,6 +50,51 @@ GENERIC: eval-generator ( singleton -- object ) with-disposal ] if ; inline +: insert-db-assigned-statement ( tuple -- ) + dup class + db get insert-statements>> [ ] cache + [ bind-tuple ] 2keep insert-tuple-set-key ; + +: insert-user-assigned-statement ( tuple -- ) + dup class + db get insert-statements>> [ ] cache + [ bind-tuple ] keep execute-statement ; + +: do-select ( exemplar-tuple statement -- tuples ) + [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ; + +: do-count ( exemplar-tuple statement -- tuples ) + [ [ bind-tuple ] [ nip default-query ] 2bi ] with-disposal ; +PRIVATE> + + +! High level +ERROR: no-slots-named class seq ; +: check-columns ( class columns -- ) + tuck + [ [ first ] map ] + [ all-slots [ name>> ] map ] bi* diff + [ drop ] [ no-slots-named ] if-empty ; + +: define-persistent ( class table columns -- ) + pick dupd + check-columns + [ dupd "db-table" set-word-prop dup ] dip + [ relation? ] partition swapd + dupd [ spec>tuple ] with map + "db-columns" set-word-prop + "db-relations" set-word-prop ; + +TUPLE: query tuple group order offset limit ; + +: ( -- query ) \ query new ; + +GENERIC: >query ( object -- query ) + +M: query >query clone ; + +M: tuple >query swap >>tuple ; + : create-table ( class -- ) create-sql-statement [ execute-statement ] with-disposals ; @@ -87,21 +107,9 @@ GENERIC: eval-generator ( singleton -- object ) ] curry ignore-errors ] [ create-table ] bi ; -: ensure-table ( class -- ) - [ create-table ] curry ignore-errors ; +: ensure-table ( class -- ) [ create-table ] curry ignore-errors ; -: ensure-tables ( classes -- ) - [ ensure-table ] each ; - -: insert-db-assigned-statement ( tuple -- ) - dup class - db get insert-statements>> [ ] cache - [ bind-tuple ] 2keep insert-tuple* ; - -: insert-user-assigned-statement ( tuple -- ) - dup class - db get insert-statements>> [ ] cache - [ bind-tuple ] keep execute-statement ; +: ensure-tables ( classes -- ) [ ensure-table ] each ; : insert-tuple ( tuple -- ) dup class db-columns find-primary-key db-assigned-id-spec? @@ -117,25 +125,14 @@ GENERIC: eval-generator ( singleton -- object ) [ bind-tuple ] keep execute-statement ] with-disposal ; -: do-select ( exemplar-tuple statement -- tuples ) - [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ; +: select-tuples ( query/tuple -- tuples ) + >query [ tuple>> ] [ query>statement ] bi do-select ; -: query ( tuple query -- tuples ) - [ dup dup class ] dip do-select ; - -: select-tuples ( tuple -- tuples ) - dup dup class do-select ; - -: select-tuple ( tuple -- tuple/f ) - dup dup class \ query new 1 >>limit do-select +: select-tuple ( query/tuple -- tuple/f ) + >query 1 >>limit [ tuple>> ] [ query>statement ] bi do-select [ f ] [ first ] if-empty ; -: do-count ( exemplar-tuple statement -- tuples ) - [ - [ bind-tuple ] [ nip default-query ] 2bi - ] with-disposal ; - -: count-tuples ( tuple groups -- n ) - >r dup dup class r> do-count +: count-tuples ( query/tuple -- n ) + >query [ tuple>> ] [ ] bi do-count dup length 1 = [ first first string>number ] [ [ first string>number ] map ] if ; diff --git a/basis/db/types/types-docs.factor b/basis/db/types/types-docs.factor index 9300a68f2e..401bbbc4d7 100644 --- a/basis/db/types/types-docs.factor +++ b/basis/db/types/types-docs.factor @@ -1,14 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: classes hashtables help.markup help.syntax io.streams.string kernel sequences strings ; +USING: classes hashtables help.markup help.syntax io.streams.string +kernel sequences strings math ; IN: db.types -HELP: (lookup-type) -{ $values - { "obj" object } - { "string" string } } -{ $description "" } ; - HELP: +autoincrement+ { $description "" } ; @@ -55,7 +50,7 @@ HELP: { $description "" } ; HELP: BIG-INTEGER -{ $description "A 64-bit integer." } ; +{ $description "A 64-bit integer. Whether this number is signed or unsigned depends on the database backend." } ; HELP: BLOB { $description "A serialized Factor object. The database library automatically serializes the object for a SQL insert or update and deserializes it on a tuple query." } ; @@ -73,13 +68,13 @@ HELP: DOUBLE { $description "Corresponds to Factor's 64bit floating-point numbers." } ; HELP: FACTOR-BLOB -{ $description "" } ; +{ $description "A serialized Factor object." } ; HELP: INTEGER -{ $description "" } ; +{ $description "A small integer, at least 32 bits in length. Whether this number is signed or unsigned depends on the database backend." } ; HELP: NULL -{ $description "" } ; +{ $description "The SQL null type." } ; HELP: REAL { $description "" } ; @@ -94,22 +89,24 @@ HELP: TIME { $description "" } ; HELP: TIMESTAMP -{ $description "" } ; +{ $description "A Factor timestamp." } ; HELP: UNSIGNED-BIG-INTEGER -{ $description "" } ; +{ $description "For portability, if a number is known to be 64bit, then this datatype may be used. Some databases, like SQLite, cannot store arbitrary bignums as BIGINT types. If storing arbitrary bignums, use " { $link FACTOR-BLOB } "." } ; + +{ INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER } related-words HELP: URL -{ $description "" } ; +{ $description "A Factor " { $link "urls" } " object." } ; HELP: VARCHAR -{ $description "" } ; +{ $description "The SQL varchar type. This type can take an integer as an argument." } ; -HELP: assigned-id-spec? +HELP: user-assigned-id-spec? { $values - { "spec" null } + { "specs" "a sequence of sql specs" } { "?" "a boolean" } } -{ $description "" } ; +{ $description "Tests if any of the sql specs has the type " { $link +user-assigned-id+ } "." } ; HELP: bind# { $values @@ -129,24 +126,25 @@ HELP: compound HELP: db-assigned-id-spec? { $values - { "spec" null } + { "specs" "a sequence of sql specs" } { "?" "a boolean" } } -{ $description "" } ; +{ $description "Tests if any of the sql specs has the type " { $link +db-assigned-id+ } "." } ; HELP: find-primary-key { $values - { "specs" null } - { "obj" object } } -{ $description "" } ; + { "specs" "a sequence of sql-specs" } + { "seq" "a sequence of sql-specs" } } +{ $description "Returns the rows from the sql-specs array that are part of the primary key. Composite primary keys are supported, so this word must return a sequence." } +{ $notes "This is a low-level word." } ; HELP: generator-bind { $description "" } ; HELP: get-slot-named { $values - { "name" null } { "obj" object } - { "value" null } } -{ $description "" } ; + { "name" "a slot name" } { "tuple" tuple } + { "value" "the value stored in the slot" } } +{ $description "Returns the value stored in a tuple slot, where the tuple slot is a string." } ; HELP: join-space { $values @@ -185,30 +183,20 @@ HELP: modifiers { $description "" } ; HELP: no-sql-type -{ $description "" } ; +{ $values + { "type" "a sql type" } } +{ $description "Throws an error containing a sql type that is unsupported or the result of a typo." } ; HELP: normalize-spec { $values { "spec" null } } { $description "" } ; -HELP: number>string* -{ $values - { "n/string" null } - { "string" string } } -{ $description "" } ; - HELP: offset-of-slot { $values - { "string" string } { "obj" object } - { "n" null } } -{ $description "" } ; - -HELP: paren -{ $values - { "string" string } - { "new-string" null } } -{ $description "" } ; + { "string" string } { "tuple" tuple } + { "n" integer } } +{ $description "Returns the offset of a tuple slot accessed by name." } ; HELP: persistent-table { $values @@ -264,7 +252,8 @@ HELP: sql-spec { $description "" } ; HELP: unknown-modifier -{ $description "" } ; +{ $values { "modifier" string } } +{ $description "Throws an error containing an unknown sql modifier." } ; ARTICLE: "db.types" "Database types" "The " { $vocab-link "db.types" } " vocabulary maps Factor types to database types." $nl @@ -294,7 +283,6 @@ ARTICLE: "db.types" "Database types" { $subsection BLOB } { $subsection FACTOR-BLOB } "Factor URLs:" -{ $subsection URL } -; +{ $subsection URL } ; ABOUT: "db.types" diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index 476d82a1e2..ac9e3397f8 100755 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs db kernel math math.parser -sequences continuations sequences.deep +sequences continuations sequences.deep prettyprint words namespaces slots slots.private classes mirrors classes.tuple combinators calendar.format symbols classes.singleton accessors quotations random ; @@ -22,22 +22,59 @@ SINGLETON: random-id-generator TUPLE: low-level-binding value ; C: low-level-binding -SINGLETON: +db-assigned-id+ -SINGLETON: +user-assigned-id+ -SINGLETON: +random-id+ +SINGLETONS: +db-assigned-id+ +user-assigned-id+ +random-id+ ; UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ; SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ -+foreign-id+ +has-many+ ; ++foreign-id+ +has-many+ +on-delete+ +restrict+ +cascade+ +set-null+ ++set-default+ ; + +SYMBOL: IGNORE + +: filter-ignores ( tuple specs -- specs' ) + [ [ nip IGNORE = ] assoc-filter keys ] dip + [ slot-name>> swap member? not ] with filter ; + +ERROR: no-slot ; + +: offset-of-slot ( string tuple -- n ) + class superclasses [ "slots" word-prop ] map concat + slot-named dup [ no-slot ] unless offset>> ; + +: get-slot-named ( name tuple -- value ) + tuck offset-of-slot slot ; + +: set-slot-named ( value name obj -- ) + tuck offset-of-slot set-slot ; + +ERROR: not-persistent class ; + +: db-table ( class -- object ) + dup "db-table" word-prop [ ] [ not-persistent ] ?if ; + +: db-columns ( class -- object ) + superclasses [ "db-columns" word-prop ] map concat ; + +: db-relations ( class -- object ) + "db-relations" word-prop ; + +: find-primary-key ( specs -- seq ) + [ primary-key>> ] filter ; + +: set-primary-key ( value tuple -- ) + [ + class db-columns + find-primary-key first slot-name>> + ] keep set-slot-named ; : primary-key? ( spec -- ? ) primary-key>> +primary-key+? ; -: db-assigned-id-spec? ( spec -- ? ) - primary-key>> +db-assigned-id+? ; +: db-assigned-id-spec? ( specs -- ? ) + [ primary-key>> +db-assigned-id+? ] contains? ; -: assigned-id-spec? ( spec -- ? ) - primary-key>> +user-assigned-id+? ; +: user-assigned-id-spec? ( specs -- ? ) + [ primary-key>> +user-assigned-id+? ] contains? ; : normalize-spec ( spec -- ) dup type>> dup +primary-key+? [ @@ -49,8 +86,8 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ [ >>primary-key drop ] [ drop ] if* ] if ; -: find-primary-key ( specs -- obj ) - [ primary-key>> ] find nip ; +: db-assigned? ( class -- ? ) + db-columns find-primary-key db-assigned-id-spec? ; : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; @@ -58,16 +95,17 @@ SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL URL ; -: spec>tuple ( class spec -- tuple ) - 3 f pad-right - [ first3 ] keep 3 tail +: ( class slot-name column-name type modifiers -- sql-spec ) sql-spec new swap >>modifiers swap >>type swap >>column-name swap >>slot-name swap >>class - dup normalize-spec ; + dup normalize-spec ; + +: spec>tuple ( class spec -- tuple ) + 3 f pad-right [ first3 ] keep 3 tail ; : number>string* ( n/string -- string ) dup number? [ number>string ] when ; @@ -86,18 +124,21 @@ FACTOR-BLOB NULL URL ; ! PostgreSQL Types: ! http://developer.postgresql.org/pgdocs/postgres/datatype.html -ERROR: unknown-modifier ; +: ?at ( obj assoc -- value/obj ? ) + dupd at* [ [ nip ] [ drop ] if ] keep ; + +ERROR: unknown-modifier modifier ; : lookup-modifier ( obj -- string ) { { [ dup array? ] [ unclip lookup-modifier swap compound ] } - [ persistent-table at* [ unknown-modifier ] unless third ] + [ persistent-table ?at [ unknown-modifier ] unless third ] } cond ; -ERROR: no-sql-type ; +ERROR: no-sql-type type ; : (lookup-type) ( obj -- string ) - persistent-table at* [ no-sql-type ] unless ; + persistent-table ?at [ no-sql-type ] unless ; : lookup-type ( obj -- string ) dup array? [ @@ -126,12 +167,11 @@ ERROR: no-sql-type ; HOOK: bind% db ( spec -- ) HOOK: bind# db ( spec obj -- ) -: offset-of-slot ( string obj -- n ) - class superclasses [ "slots" word-prop ] map concat - slot-named offset>> ; +ERROR: no-column column ; -: get-slot-named ( name obj -- value ) - tuck offset-of-slot slot ; - -: set-slot-named ( value name obj -- ) - tuck offset-of-slot set-slot ; +: >reference-string ( string pair -- string ) + first2 + [ [ unparse join-space ] [ db-columns ] bi ] dip + swap [ column-name>> = ] with find nip + [ no-column ] unless* + column-name>> paren append ; diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index b7fd34c5be..ec93a01c19 100755 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -22,6 +22,9 @@ M: tuple error-help class ; M: string error. print ; +: :error ( -- ) + error get error. ; + : :s ( -- ) error-continuation get data>> stack. ; @@ -323,3 +326,5 @@ M: bad-effect summary drop "Bad stack effect declaration" ; M: bad-escape summary drop "Bad escape code" ; + +M: bad-literal-tuple summary drop "Bad literal tuple" ; diff --git a/basis/editors/macvim/authors.txt b/basis/editors/macvim/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/basis/editors/macvim/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/basis/editors/macvim/macvim.factor b/basis/editors/macvim/macvim.factor new file mode 100755 index 0000000000..b5f864dcd0 --- /dev/null +++ b/basis/editors/macvim/macvim.factor @@ -0,0 +1,13 @@ +USING: definitions io.launcher kernel math math.parser parser +namespaces prettyprint editors make ; + +IN: editors.macvim + +: macvim-location ( file line -- ) + drop + [ "open" , "-a" , "MacVim", , ] { } make + try-process ; + +[ macvim-location ] edit-hook set-global + + diff --git a/basis/editors/macvim/summary.txt b/basis/editors/macvim/summary.txt new file mode 100644 index 0000000000..894d635b47 --- /dev/null +++ b/basis/editors/macvim/summary.txt @@ -0,0 +1 @@ +MacVim editor integration diff --git a/basis/editors/macvim/tags.txt b/basis/editors/macvim/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/macvim/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/textedit/authors.txt b/basis/editors/textedit/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/basis/editors/textedit/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/basis/editors/textedit/summary.txt b/basis/editors/textedit/summary.txt new file mode 100644 index 0000000000..1d72d10db0 --- /dev/null +++ b/basis/editors/textedit/summary.txt @@ -0,0 +1 @@ +TextEdit editor integration diff --git a/basis/editors/textedit/tags.txt b/basis/editors/textedit/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/textedit/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/editors/textedit/textedit.factor b/basis/editors/textedit/textedit.factor new file mode 100755 index 0000000000..6942e24534 --- /dev/null +++ b/basis/editors/textedit/textedit.factor @@ -0,0 +1,13 @@ +USING: definitions io.launcher kernel math math.parser parser +namespaces prettyprint editors make ; + +IN: editors.textedit + +: textedit-location ( file line -- ) + drop + [ "open" , "-a" , "TextEdit", , ] { } make + try-process ; + +[ textedit-location ] edit-hook set-global + + diff --git a/basis/eval/authors.txt b/basis/eval/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/eval/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/eval/summary.txt b/basis/eval/summary.txt new file mode 100644 index 0000000000..679f074e90 --- /dev/null +++ b/basis/eval/summary.txt @@ -0,0 +1 @@ +Ad-hoc evaluation of strings of code diff --git a/basis/farkup/farkup-docs.factor b/basis/farkup/farkup-docs.factor index f2d53d2362..8e7270cc01 100644 --- a/basis/farkup/farkup-docs.factor +++ b/basis/farkup/farkup-docs.factor @@ -9,7 +9,7 @@ HELP: write-farkup { $values { "string" string } } { $description "Parse a Farkup string and writes the resulting HTML to " { $link output-stream } "." } ; -HELP: farkup ( string -- farkup ) +HELP: parse-farkup ( string -- farkup ) { $values { "string" string } { "farkup" "a Farkup syntax tree node" } } { $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ; @@ -18,7 +18,7 @@ HELP: (write-farkup) { $description "Writes a Farkup syntax tree as HTML on " { $link output-stream } "." } ; ARTICLE: "farkup-ast" "Farkup syntax tree nodes" -"The " { $link farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "." +"The " { $link parse-farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "." { $subsection heading1 } { $subsection heading2 } { $subsection heading3 } @@ -30,7 +30,8 @@ ARTICLE: "farkup-ast" "Farkup syntax tree nodes" { $subsection inline-code } { $subsection paragraph } { $subsection list-item } -{ $subsection list } +{ $subsection unordered-list } +{ $subsection ordered-list } { $subsection table } { $subsection table-row } { $subsection link } @@ -44,7 +45,7 @@ $nl { $subsection convert-farkup } { $subsection write-farkup } "The syntax tree of a piece of Farkup can also be inspected and modified:" -{ $subsection farkup } +{ $subsection parse-farkup } { $subsection (write-farkup) } { $subsection "farkup-ast" } ; diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index e25fa34960..27911a8d13 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -11,13 +11,11 @@ link-no-follow? off [ "Baz" ] [ "Baz" simple-link-title ] unit-test [ ] [ - "abcd-*strong*\nasdifj\nweouh23ouh23" - "paragraph" \ farkup rule parse drop + "abcd-*strong*\nasdifj\nweouh23ouh23" parse-farkup drop ] unit-test [ ] [ - "abcd-*strong*\nasdifj\nweouh23ouh23\n" - "paragraph" \ farkup rule parse drop + "abcd-*strong*\nasdifj\nweouh23ouh23\n" parse-farkup drop ] unit-test [ "

a-b

" ] [ "a-b" convert-farkup ] unit-test @@ -37,22 +35,30 @@ link-no-follow? off [ "
  • foo
    • \n

bar\n

" ] [ "-foo\nbar\n" convert-farkup ] unit-test +[ "
  1. a-b
" ] [ "#a-b" convert-farkup ] unit-test +[ "
  1. foo
" ] [ "#foo" convert-farkup ] unit-test +[ "
  1. foo
    2. \n
" ] [ "#foo\n" convert-farkup ] unit-test +[ "
  1. foo
    2. \n
  2. bar
" ] [ "#foo\n#bar" convert-farkup ] unit-test +[ "
  1. foo
    2. \n
  2. bar
    3. \n
" ] [ "#foo\n#bar\n" convert-farkup ] unit-test + +[ "
  1. foo
    2. \n

bar\n

" ] [ "#foo\nbar\n" convert-farkup ] unit-test + [ "\n\n" ] [ "\n\n" convert-farkup ] unit-test [ "\n\n" ] [ "\r\n\r\n" convert-farkup ] unit-test [ "\n\n\n\n" ] [ "\r\r\r\r" convert-farkup ] unit-test [ "\n\n\n" ] [ "\r\r\r" convert-farkup ] unit-test [ "\n\n\n" ] [ "\n\n\n" convert-farkup ] unit-test -[ "

foo

bar

" ] [ "foo\n\nbar" convert-farkup ] unit-test -[ "

foo

bar

" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test -[ "

foo

bar

" ] [ "foo\r\rbar" convert-farkup ] unit-test -[ "

foo

bar

" ] [ "foo\r\r\nbar" convert-farkup ] unit-test +[ "

foo\n

bar

" ] [ "foo\n\nbar" convert-farkup ] unit-test +[ "

foo\n

bar

" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test +[ "

foo\n

bar

" ] [ "foo\r\rbar" convert-farkup ] unit-test +[ "

foo\n

bar

" ] [ "foo\r\r\nbar" convert-farkup ] unit-test [ "\n

bar\n

" ] [ "\nbar\n" convert-farkup ] unit-test [ "\n

bar\n

" ] [ "\rbar\r" convert-farkup ] unit-test [ "\n

bar\n

" ] [ "\r\nbar\r\n" convert-farkup ] unit-test -[ "

foo

bar

" ] [ "foo\n\n\nbar" convert-farkup ] unit-test +[ "

foo\n

bar

" ] [ "foo\n\n\nbar" convert-farkup ] unit-test [ "" ] [ "" convert-farkup ] unit-test @@ -107,7 +113,7 @@ link-no-follow? off ] [ "Feature comparison:\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test [ - "

Feature comparison:

aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes
" + "

Feature comparison:\n

aFactorJavaLisp
CoolnessYesNoNo
BadassYesNoNo
EnterpriseYesYesNo
KosherYesNoYes
" ] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test [ @@ -118,3 +124,36 @@ link-no-follow? off ] unit-test [ "

a c

" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test + +[ "

C++

" ] [ "[[C++]]" convert-farkup ] unit-test + +[ "

<foo>

" ] [ "" convert-farkup ] unit-test + +[ "

asdf\n

  • lol
    • \n
  • haha

" ] [ "asdf\n-lol\n-haha" convert-farkup ] unit-test + +[ "

asdf\n

  • lol
    • \n
  • haha
" ] + [ "asdf\n\n-lol\n-haha" convert-farkup ] unit-test + +[ "
" ] [ "___" convert-farkup ] unit-test +[ "
\n" ] [ "___\n" convert-farkup ] unit-test + +[ "

before:\n

{ 1 2 3 } 1 tail\n

" ] +[ "before:\n[factor{{ 1 2 3 } 1 tail}]" convert-farkup ] unit-test + +[ "

Factor-rific!

" ] +[ "[[Factor]]-rific!" convert-farkup ] unit-test + +[ "

[ factor { 1 2 3 }]

" ] +[ "[ factor { 1 2 3 }]" convert-farkup ] unit-test + +[ "

paragraph\n

" ] +[ "paragraph\n___" convert-farkup ] unit-test + +[ "

paragraph\n a ___ b

" ] +[ "paragraph\n a ___ b" convert-farkup ] unit-test + +[ "\n
  • a
    • \n
" ] +[ "\n- a\n___" convert-farkup ] unit-test + +[ "

hello_world how are you today?\n

  • hello_world how are you today?

" ] +[ "hello_world how are you today?\n- hello_world how are you today?" convert-farkup ] unit-test diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index 4d6ac127ad..21e3c05d04 100644 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -1,32 +1,36 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators html.elements io io.streams.string -kernel math memoize namespaces peg peg.ebnf prettyprint -sequences sequences.deep strings xml.entities vectors splitting -xmode.code2html ; +USING: accessors arrays combinators html.elements io +io.streams.string kernel math namespaces peg peg.ebnf +sequences sequences.deep strings xml.entities +vectors splitting xmode.code2html urls.encoding ; IN: farkup SYMBOL: relative-link-prefix SYMBOL: disable-images? SYMBOL: link-no-follow? +SYMBOL: line-breaks? -TUPLE: heading1 obj ; -TUPLE: heading2 obj ; -TUPLE: heading3 obj ; -TUPLE: heading4 obj ; -TUPLE: strong obj ; -TUPLE: emphasis obj ; -TUPLE: superscript obj ; -TUPLE: subscript obj ; -TUPLE: inline-code obj ; -TUPLE: paragraph obj ; -TUPLE: list-item obj ; -TUPLE: list obj ; -TUPLE: table obj ; -TUPLE: table-row obj ; +TUPLE: heading1 child ; +TUPLE: heading2 child ; +TUPLE: heading3 child ; +TUPLE: heading4 child ; +TUPLE: strong child ; +TUPLE: emphasis child ; +TUPLE: superscript child ; +TUPLE: subscript child ; +TUPLE: inline-code child ; +TUPLE: paragraph child ; +TUPLE: list-item child ; +TUPLE: unordered-list child ; +TUPLE: ordered-list child ; +TUPLE: table child ; +TUPLE: table-row child ; TUPLE: link href text ; TUPLE: image href text ; TUPLE: code mode string ; +TUPLE: line ; +TUPLE: line-break ; : absolute-url? ( string -- ? ) { "http://" "https://" "ftp://" } [ head? ] with contains? ; @@ -34,9 +38,9 @@ TUPLE: code mode string ; : simple-link-title ( string -- string' ) dup absolute-url? [ "/" last-split1 swap or ] unless ; -EBNF: farkup +EBNF: parse-farkup nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]] -2nl = nl nl +whitespace = " " | "\t" | nl heading1 = "=" (!("=" | nl).)+ "=" => [[ second >string heading1 boa ]] @@ -50,6 +54,10 @@ heading3 = "===" (!("=" | nl).)+ "===" heading4 = "====" (!("=" | nl).)+ "====" => [[ second >string heading4 boa ]] +heading = heading4 | heading3 | heading2 | heading1 + + + strong = "*" (!("*" | nl).)+ "*" => [[ second >string strong boa ]] @@ -65,8 +73,6 @@ subscript = "~" (!("~" | nl).)+ "~" inline-code = "%" (!("%" | nl).)+ "%" => [[ second >string inline-code boa ]] -escaped-char = "\" . => [[ second ]] - link-content = (!("|"|"]").)+ image-link = "[[image:" link-content "|" link-content "]]" @@ -82,44 +88,73 @@ labelled-link = "[[" link-content "|" link-content "]]" link = image-link | labelled-link | simple-link -heading = heading4 | heading3 | heading2 | heading1 +escaped-char = "\" . + => [[ second 1string ]] inline-tag = strong | emphasis | superscript | subscript | inline-code | link | escaped-char + + inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '[' -table-column = (list | (!(nl | inline-delimiter | '|').)+ | inline-tag | inline-delimiter ) '|' +cell = (!(inline-delimiter | '|' | nl).)+ + => [[ >string ]] + +table-column = (list | cell | inline-tag | inline-delimiter ) '|' => [[ first ]] table-row = "|" (table-column)+ => [[ second table-row boa ]] table = ((table-row nl => [[ first ]] )+ table-row? | table-row) => [[ table boa ]] -paragraph-item = ( table | (!(nl | code | heading | inline-delimiter | table ).) | inline-tag | inline-delimiter)+ -paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]] - | (paragraph-item nl)+ paragraph-item? +text = (!(nl | code | heading | inline-delimiter | table ).)+ + => [[ >string ]] + +paragraph-nl-item = nl list + | nl line + | nl => [[ line-breaks? get [ drop line-break new ] when ]] +paragraph-item = (table | code | text | inline-tag | inline-delimiter)+ +paragraph = ((paragraph-item paragraph-nl-item)+ nl+ => [[ first ]] + | (paragraph-item paragraph-nl-item)+ paragraph-item? | paragraph-item) => [[ paragraph boa ]] - -list-item = '-' ((!(inline-delimiter | nl).)+ | inline-tag)* - => [[ second list-item boa ]] -list = ((list-item nl)+ list-item? | list-item) - => [[ list boa ]] -code = '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]" + +list-item = (cell | inline-tag | inline-delimiter)* + +ordered-list-item = '#' list-item + => [[ second list-item boa ]] +ordered-list = ((ordered-list-item nl)+ ordered-list-item? | ordered-list-item) + => [[ ordered-list boa ]] + +unordered-list-item = '-' list-item + => [[ second list-item boa ]] +unordered-list = ((unordered-list-item nl)+ unordered-list-item? | unordered-list-item) + => [[ unordered-list boa ]] + +list = ordered-list | unordered-list + + +line = '___' + => [[ drop line new ]] + + +named-code + = '[' (!('{' | whitespace | '[').)+ '{' (!("}]").)+ "}]" => [[ [ second >string ] [ fourth >string ] bi code boa ]] simple-code = "[{" (!("}]").)+ "}]" => [[ second f swap code boa ]] +code = named-code | simple-code + + stand-alone - = (code | simple-code | heading | list | table | paragraph | nl)* + = (line | code | heading | list | table | paragraph | nl)* ;EBNF - - : invalid-url "javascript:alert('Invalid URL in farkup');" ; : check-url ( href -- href' ) @@ -136,7 +171,7 @@ stand-alone : write-link ( href text -- ) escape-link - [ ] + [ ] [ write ] bi* ; @@ -146,7 +181,7 @@ stand-alone "Images are not allowed" write ] [ escape-link - [ ] bi* + [ ] bi* ] if ; : render-code ( string mode -- string' ) @@ -161,31 +196,33 @@ GENERIC: (write-farkup) ( farkup -- ) : ( string -- ) write ; : ( string -- ) write ; : in-tag. ( obj quot string -- ) [ call ] keep ; inline -M: heading1 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h1" in-tag. ; -M: heading2 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h2" in-tag. ; -M: heading3 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h3" in-tag. ; -M: heading4 (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "h4" in-tag. ; -M: strong (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "strong" in-tag. ; -M: emphasis (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "em" in-tag. ; -M: superscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sup" in-tag. ; -M: subscript (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "sub" in-tag. ; -M: inline-code (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "code" in-tag. ; -M: list-item (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "li" in-tag. ; -M: list (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "ul" in-tag. ; -M: paragraph (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "p" in-tag. ; -M: link (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-link ; -M: image (write-farkup) ( obj -- ) [ href>> ] [ text>> ] bi write-image-link ; -M: code (write-farkup) ( obj -- ) [ string>> ] [ mode>> ] bi render-code ; +M: heading1 (write-farkup) [ child>> (write-farkup) ] "h1" in-tag. ; +M: heading2 (write-farkup) [ child>> (write-farkup) ] "h2" in-tag. ; +M: heading3 (write-farkup) [ child>> (write-farkup) ] "h3" in-tag. ; +M: heading4 (write-farkup) [ child>> (write-farkup) ] "h4" in-tag. ; +M: strong (write-farkup) [ child>> (write-farkup) ] "strong" in-tag. ; +M: emphasis (write-farkup) [ child>> (write-farkup) ] "em" in-tag. ; +M: superscript (write-farkup) [ child>> (write-farkup) ] "sup" in-tag. ; +M: subscript (write-farkup) [ child>> (write-farkup) ] "sub" in-tag. ; +M: inline-code (write-farkup) [ child>> (write-farkup) ] "code" in-tag. ; +M: list-item (write-farkup) [ child>> (write-farkup) ] "li" in-tag. ; +M: unordered-list (write-farkup) [ child>> (write-farkup) ] "ul" in-tag. ; +M: ordered-list (write-farkup) [ child>> (write-farkup) ] "ol" in-tag. ; +M: paragraph (write-farkup) [ child>> (write-farkup) ] "p" in-tag. ; +M: link (write-farkup) [ href>> ] [ text>> ] bi write-link ; +M: image (write-farkup) [ href>> ] [ text>> ] bi write-image-link ; +M: code (write-farkup) [ string>> ] [ mode>> ] bi render-code ; +M: line (write-farkup) drop
; +M: line-break (write-farkup) drop
nl ; M: table-row (write-farkup) ( obj -- ) - obj>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ; -M: table (write-farkup) ( obj -- ) [ obj>> (write-farkup) ] "table" in-tag. ; -M: fixnum (write-farkup) ( obj -- ) write1 ; -M: string (write-farkup) ( obj -- ) write ; -M: vector (write-farkup) ( obj -- ) [ (write-farkup) ] each ; -M: f (write-farkup) ( obj -- ) drop ; + child>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ; +M: table (write-farkup) [ child>> (write-farkup) ] "table" in-tag. ; +M: string (write-farkup) escape-string write ; +M: vector (write-farkup) [ (write-farkup) ] each ; +M: f (write-farkup) drop ; : write-farkup ( string -- ) - farkup (write-farkup) ; + parse-farkup (write-farkup) ; : convert-farkup ( string -- string' ) - farkup [ (write-farkup) ] with-string-writer ; + parse-farkup [ (write-farkup) ] with-string-writer ; diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index cce098f208..7505b3c612 100755 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -14,7 +14,8 @@ html.elements html.components html.components html.templates.chloe -html.templates.chloe.syntax ; +html.templates.chloe.syntax +html.templates.chloe.compiler ; IN: furnace.actions SYMBOL: params @@ -29,7 +30,8 @@ SYMBOL: rest ] unless-empty ; -CHLOE: validation-messages drop render-validation-messages ; +CHLOE: validation-messages + drop [ render-validation-messages ] [code] ; TUPLE: action rest authorize init display validate submit ; @@ -77,14 +79,14 @@ TUPLE: action rest authorize init display validate submit ; : revalidate-url ( -- url/f ) revalidate-url-key param - dup [ >url [ same-host? ] keep and ] when ; + dup [ >url ensure-port [ same-host? ] keep and ] when ; : validation-failed ( -- * ) post-request? revalidate-url and [ begin-conversation nested-forms-key param " " split harvest nested-forms cset form get form cset - + ] [ <400> ] if* exit-with ; diff --git a/basis/furnace/actions/authors.txt b/basis/furnace/actions/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/furnace/actions/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/furnace/actions/summary.txt b/basis/furnace/actions/summary.txt new file mode 100644 index 0000000000..53b775adda --- /dev/null +++ b/basis/furnace/actions/summary.txt @@ -0,0 +1 @@ +Actions and form validation diff --git a/basis/furnace/actions/tags.txt b/basis/furnace/actions/tags.txt new file mode 100644 index 0000000000..c0772185a0 --- /dev/null +++ b/basis/furnace/actions/tags.txt @@ -0,0 +1 @@ +web diff --git a/basis/furnace/alloy/alloy.factor b/basis/furnace/alloy/alloy.factor index 6f5f6fdbf6..decee690a3 100644 --- a/basis/furnace/alloy/alloy.factor +++ b/basis/furnace/alloy/alloy.factor @@ -3,6 +3,7 @@ USING: kernel sequences db.tuples alarms calendar db fry furnace.db furnace.cache +furnace.asides furnace.referrer furnace.sessions furnace.conversations @@ -10,20 +11,24 @@ furnace.auth.providers furnace.auth.login.permits ; IN: furnace.alloy -: ( responder db params -- responder' ) - '[ - - - _ _ - - ] call ; - -: state-classes { session conversation permit } ; inline +: state-classes { session aside conversation permit } ; inline : init-furnace-tables ( -- ) state-classes ensure-tables user ensure-table ; +: ( responder db params -- responder' ) + [ [ init-furnace-tables ] with-db ] + [ + [ + + + + ] 2dip + + + ] 2bi ; + : start-expiring ( db params -- ) '[ _ _ [ state-classes [ expire-state ] each ] with-db diff --git a/basis/furnace/alloy/authors.txt b/basis/furnace/alloy/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/furnace/alloy/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/furnace/alloy/summary.txt b/basis/furnace/alloy/summary.txt new file mode 100644 index 0000000000..7bad952903 --- /dev/null +++ b/basis/furnace/alloy/summary.txt @@ -0,0 +1 @@ +Convenience responder combines several features diff --git a/basis/furnace/alloy/tags.txt b/basis/furnace/alloy/tags.txt new file mode 100644 index 0000000000..c0772185a0 --- /dev/null +++ b/basis/furnace/alloy/tags.txt @@ -0,0 +1 @@ +web diff --git a/basis/furnace/asides/asides.factor b/basis/furnace/asides/asides.factor new file mode 100644 index 0000000000..6d4196cf0b --- /dev/null +++ b/basis/furnace/asides/asides.factor @@ -0,0 +1,111 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces assocs kernel sequences accessors hashtables +urls db.types db.tuples math.parser fry logging combinators +html.templates.chloe.syntax +http http.server http.server.filters http.server.redirection +furnace +furnace.cache +furnace.sessions +furnace.redirection ; +IN: furnace.asides + +TUPLE: aside < server-state +session method url post-data ; + +: