Merge branch 'experimental' into maintenance
commit
583353651f
|
@ -0,0 +1 @@
|
|||
One-time and recurring events
|
|
@ -0,0 +1 @@
|
|||
Defining multiple words with the same name
|
|
@ -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"
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Fast searching of sorted arrays
|
|
@ -26,7 +26,6 @@ IN: bootstrap.image
|
|||
"x86.32"
|
||||
"x86.64"
|
||||
"linux-ppc" "macosx-ppc"
|
||||
! "arm"
|
||||
} ;
|
||||
|
||||
<PRIVATE
|
||||
|
@ -412,14 +411,14 @@ M: quotation '
|
|||
all-words [ emit-word ] each ;
|
||||
|
||||
: emit-global ( -- )
|
||||
[
|
||||
{
|
||||
dictionary source-files builtins
|
||||
update-map implementors-map class<=-cache
|
||||
class-not-cache classes-intersect-cache class-and-cache
|
||||
class-or-cache
|
||||
} [ dup get swap bootstrap-word set ] each
|
||||
] H{ } make-assoc
|
||||
{
|
||||
dictionary source-files builtins
|
||||
update-map implementors-map
|
||||
} [ [ bootstrap-word ] [ get ] bi ] H{ } map>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 ;
|
||||
|
||||
|
|
|
@ -13,4 +13,4 @@ IN: bootstrap.random
|
|||
[
|
||||
[ 32 random-bits ] with-system-random
|
||||
<mersenne-twister> random-generator set-global
|
||||
] "generator.random" add-init-hook
|
||||
] "bootstrap.random" add-init-hook
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
An abstraction for enforcing a mutual-exclusion invariant
|
|
@ -21,8 +21,8 @@ HELP: <date>
|
|||
{ $description "Returns a timestamp object representing the start of the specified day in your current timezone." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"2010 12 25 <date> ."
|
||||
"T{ timestamp\n { year 2010 }\n { month 12 }\n { day 25 }\n { gmt-offset T{ duration { hour -5 } } }\n}"
|
||||
"2010 12 25 <date> >gmt midnight ."
|
||||
"T{ timestamp { year 2010 } { month 12 } { day 25 } }"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -1 +1 @@
|
|||
extensions
|
||||
concurrency
|
||||
|
|
|
@ -1 +1 @@
|
|||
extensions
|
||||
concurrency
|
||||
|
|
|
@ -43,7 +43,7 @@ HELP: push-growing-circular
|
|||
{ "elt" object } { "circular" circular } }
|
||||
{ $description "Pushes an element onto a " { $link growing-circular } " object." } ;
|
||||
|
||||
ARTICLE: "circular" "circular"
|
||||
ARTICLE: "circular" "Circular sequences"
|
||||
"The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl
|
||||
"Creating a new circular object:"
|
||||
{ $subsection <circular> }
|
||||
|
|
|
@ -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: -> }
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Colors as a first-class data type
|
|
@ -64,7 +64,7 @@ HELP: n||-rewrite
|
|||
{ "quot" quotation } }
|
||||
{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each OR quotation." } ;
|
||||
|
||||
ARTICLE: "combinators.short-circuit" "combinators.short-circuit"
|
||||
ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
|
||||
"The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl
|
||||
"AND combinators:"
|
||||
{ $subsection 0&& }
|
||||
|
|
|
@ -27,8 +27,9 @@ HELP: ||
|
|||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "combinators.short-circuit.smart" "combinators.short-circuit.smart"
|
||||
"The " { $vocab-link "combinators.short-circuit.smart" } " vocabulary infers the number of inputs that the sequence of quotations takes." $nl
|
||||
ARTICLE: "combinators.short-circuit.smart" "Smart short-circuit combinators"
|
||||
"The " { $vocab-link "combinators.short-circuit.smart" } " vocabulary is similar to " { $vocab-link "combinators.short-circuit" } " except the combinators here infer the number of inputs that the sequence of quotations takes."
|
||||
$nl
|
||||
"Generalized AND:"
|
||||
{ $subsection && }
|
||||
"Generalized OR:"
|
||||
|
|
|
@ -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? }
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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>> \ <tuple-boa> eq? [
|
||||
dup in-d>> peek node-value-info
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
concurrency
|
|
@ -0,0 +1 @@
|
|||
concurrency
|
|
@ -0,0 +1 @@
|
|||
concurrency
|
|
@ -1,2 +1,2 @@
|
|||
concurrency
|
||||
enterprise
|
||||
extensions
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
concurrency
|
|
@ -0,0 +1 @@
|
|||
concurrency
|
|
@ -0,0 +1 @@
|
|||
concurrency
|
|
@ -0,0 +1 @@
|
|||
concurrency
|
|
@ -0,0 +1 @@
|
|||
concurrency
|
|
@ -0,0 +1 @@
|
|||
concurrency
|
|
@ -0,0 +1 @@
|
|||
concurrency
|
|
@ -0,0 +1 @@
|
|||
concurrency
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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"
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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 <insert-db-assigned-statement> ( 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 <insert-user-assigned-statement> ( 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 ;
|
||||
|
|
|
@ -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
|
||||
<simple-statement> 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
|
||||
[ <simple-statement> 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 <update-tuple-statement> ( 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 <delete-tuples-statement> ( tuple table -- sql )
|
||||
[
|
||||
|
@ -141,34 +148,30 @@ M: db <delete-tuples-statement> ( tuple table -- sql )
|
|||
M: db <select-by-slots-statement> ( 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 <select-by-slots-statement> ( tuple class -- statement )
|
|||
[ offset>> [ do-offset ] [ drop ] if* ]
|
||||
} 2cleave ;
|
||||
|
||||
M: db <query> ( tuple class query -- tuple )
|
||||
[ <select-by-slots-statement> ] dip make-query ;
|
||||
M: db query>statement ( query -- tuple )
|
||||
[ tuple>> dup class ] keep
|
||||
[ <select-by-slots-statement> ] 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>
|
||||
<simple-statement> maybe-make-retryable do-select ;
|
||||
|
||||
M: db <count-statement> ( tuple class groups -- statement )
|
||||
\ query new
|
||||
swap >>group
|
||||
M: db <count-statement> ( 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 -- )
|
||||
[
|
||||
|
|
|
@ -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 -- )
|
||||
{ } { } <simple-statement> 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 ;
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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" <user-assigned-person> 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 ;
|
||||
: <bignum-test> ( 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 ] [
|
||||
<query>
|
||||
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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
<PRIVATE
|
||||
! returns a sequence of prepared-statements
|
||||
HOOK: create-sql-statement db ( class -- object )
|
||||
HOOK: drop-sql-statement db ( class -- object )
|
||||
|
@ -42,19 +16,20 @@ HOOK: <insert-user-assigned-statement> db ( class -- object )
|
|||
HOOK: <update-tuple-statement> db ( class -- object )
|
||||
HOOK: <delete-tuples-statement> db ( tuple class -- object )
|
||||
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
|
||||
TUPLE: query group order offset limit ;
|
||||
HOOK: <query> db ( tuple class query -- statement' )
|
||||
HOOK: <count-statement> db ( tuple class groups -- n )
|
||||
HOOK: <count-statement> 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>> [ <insert-db-assigned-statement> ] cache
|
||||
[ bind-tuple ] 2keep insert-tuple-set-key ;
|
||||
|
||||
: insert-user-assigned-statement ( tuple -- )
|
||||
dup class
|
||||
db get insert-statements>> [ <insert-user-assigned-statement> ] 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 ) \ query new ;
|
||||
|
||||
GENERIC: >query ( object -- query )
|
||||
|
||||
M: query >query clone ;
|
||||
|
||||
M: tuple >query <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>> [ <insert-db-assigned-statement> ] cache
|
||||
[ bind-tuple ] 2keep insert-tuple* ;
|
||||
|
||||
: insert-user-assigned-statement ( tuple -- )
|
||||
dup class
|
||||
db get insert-statements>> [ <insert-user-assigned-statement> ] 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 <query> do-select ;
|
||||
|
||||
: select-tuples ( tuple -- tuples )
|
||||
dup dup class <select-by-slots-statement> do-select ;
|
||||
|
||||
: select-tuple ( tuple -- tuple/f )
|
||||
dup dup class \ query new 1 >>limit <query> do-select
|
||||
: 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> <count-statement> do-count
|
||||
: count-tuples ( query/tuple -- n )
|
||||
>query [ tuple>> ] [ <count-statement> ] bi do-count
|
||||
dup length 1 =
|
||||
[ first first string>number ] [ [ first string>number ] map ] if ;
|
||||
|
|
|
@ -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: <low-level-binding>
|
|||
{ $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"
|
||||
|
|
|
@ -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> 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' )
|
||||
[ <mirror> [ 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
|
||||
: <sql-spec> ( 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 <sql-spec> ;
|
||||
|
||||
: 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 ;
|
||||
|
|
|
@ -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" ;
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
|
@ -0,0 +1,13 @@
|
|||
USING: definitions io.launcher kernel math math.parser parser
|
||||
namespaces prettyprint editors make ;
|
||||
|
||||
IN: editors.macvim
|
||||
|
||||
: macvim-location ( file line -- )
|
||||
drop
|
||||
[ "open" , "-a" , "MacVim", , ] { } make
|
||||
try-process ;
|
||||
|
||||
[ macvim-location ] edit-hook set-global
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
MacVim editor integration
|
|
@ -0,0 +1 @@
|
|||
unportable
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
|
@ -0,0 +1 @@
|
|||
TextEdit editor integration
|
|
@ -0,0 +1 @@
|
|||
unportable
|
|
@ -0,0 +1,13 @@
|
|||
USING: definitions io.launcher kernel math math.parser parser
|
||||
namespaces prettyprint editors make ;
|
||||
|
||||
IN: editors.textedit
|
||||
|
||||
: textedit-location ( file line -- )
|
||||
drop
|
||||
[ "open" , "-a" , "TextEdit", , ] { } make
|
||||
try-process ;
|
||||
|
||||
[ textedit-location ] edit-hook set-global
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1 @@
|
|||
Ad-hoc evaluation of strings of code
|
|
@ -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" } ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
[ "<p>a-b</p>" ] [ "a-b" convert-farkup ] unit-test
|
||||
|
@ -37,22 +35,30 @@ link-no-follow? off
|
|||
|
||||
[ "<ul><li>foo</li>\n</ul><p>bar\n</p>" ] [ "-foo\nbar\n" convert-farkup ] unit-test
|
||||
|
||||
[ "<ol><li>a-b</li></ol>" ] [ "#a-b" convert-farkup ] unit-test
|
||||
[ "<ol><li>foo</li></ol>" ] [ "#foo" convert-farkup ] unit-test
|
||||
[ "<ol><li>foo</li>\n</ol>" ] [ "#foo\n" convert-farkup ] unit-test
|
||||
[ "<ol><li>foo</li>\n<li>bar</li></ol>" ] [ "#foo\n#bar" convert-farkup ] unit-test
|
||||
[ "<ol><li>foo</li>\n<li>bar</li>\n</ol>" ] [ "#foo\n#bar\n" convert-farkup ] unit-test
|
||||
|
||||
[ "<ol><li>foo</li>\n</ol><p>bar\n</p>" ] [ "#foo\nbar\n" convert-farkup ] unit-test
|
||||
|
||||
|
||||
[ "\n\n" ] [ "\n\n" convert-farkup ] unit-test
|
||||
[ "\n\n" ] [ "\r\n\r\n" convert-farkup ] unit-test
|
||||
[ "\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
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\r\rbar" convert-farkup ] unit-test
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\r\r\nbar" convert-farkup ] unit-test
|
||||
[ "<p>foo\n</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
|
||||
[ "<p>foo\n</p><p>bar</p>" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
|
||||
[ "<p>foo\n</p><p>bar</p>" ] [ "foo\r\rbar" convert-farkup ] unit-test
|
||||
[ "<p>foo\n</p><p>bar</p>" ] [ "foo\r\r\nbar" convert-farkup ] unit-test
|
||||
|
||||
[ "\n<p>bar\n</p>" ] [ "\nbar\n" convert-farkup ] unit-test
|
||||
[ "\n<p>bar\n</p>" ] [ "\rbar\r" convert-farkup ] unit-test
|
||||
[ "\n<p>bar\n</p>" ] [ "\r\nbar\r\n" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>foo</p><p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
|
||||
[ "<p>foo\n</p><p>bar</p>" ] [ "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
|
||||
|
||||
[
|
||||
"<p>Feature comparison:</p><table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table>"
|
||||
"<p>Feature comparison:\n</p><table><tr><td>a</td><td>Factor</td><td>Java</td><td>Lisp</td></tr><tr><td>Coolness</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Badass</td><td>Yes</td><td>No</td><td>No</td></tr><tr><td>Enterprise</td><td>Yes</td><td>Yes</td><td>No</td></tr><tr><td>Kosher</td><td>Yes</td><td>No</td><td>Yes</td></tr></table>"
|
||||
] [ "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
|
||||
|
||||
[ "<p><a href='a'>a</a> <a href='b'>c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test
|
||||
|
||||
[ "<p><a href='C%2b%2b'>C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
|
||||
|
||||
[ "<p><foo></p>" ] [ "<foo>" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>asdf\n<ul><li>lol</li>\n<li>haha</li></ul></p>" ] [ "asdf\n-lol\n-haha" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>asdf\n</p><ul><li>lol</li>\n<li>haha</li></ul>" ]
|
||||
[ "asdf\n\n-lol\n-haha" convert-farkup ] unit-test
|
||||
|
||||
[ "<hr/>" ] [ "___" convert-farkup ] unit-test
|
||||
[ "<hr/>\n" ] [ "___\n" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>before:\n<pre><span class='OPERATOR'>{</span> <span class='DIGIT'>1</span> <span class='DIGIT'>2</span> <span class='DIGIT'>3</span> <span class='OPERATOR'>}</span> <span class='DIGIT'>1</span> tail\n</pre></p>" ]
|
||||
[ "before:\n[factor{{ 1 2 3 } 1 tail}]" convert-farkup ] unit-test
|
||||
|
||||
[ "<p><a href='Factor'>Factor</a>-rific!</p>" ]
|
||||
[ "[[Factor]]-rific!" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>[ factor { 1 2 3 }]</p>" ]
|
||||
[ "[ factor { 1 2 3 }]" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>paragraph\n<hr/></p>" ]
|
||||
[ "paragraph\n___" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>paragraph\n a ___ b</p>" ]
|
||||
[ "paragraph\n a ___ b" convert-farkup ] unit-test
|
||||
|
||||
[ "\n<ul><li> a</li>\n</ul><hr/>" ]
|
||||
[ "\n- a\n___" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>hello_world how are you today?\n<ul><li> hello_world how are you today?</li></ul></p>" ]
|
||||
[ "hello_world how are you today?\n- hello_world how are you today?" convert-farkup ] unit-test
|
||||
|
|
|
@ -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
|
||||
[ <a =href link-no-follow? get [ "true" =nofollow ] when a> ]
|
||||
[ <a url-encode =href link-no-follow? get [ "true" =nofollow ] when a> ]
|
||||
[ write </a> ]
|
||||
bi* ;
|
||||
|
||||
|
@ -146,7 +181,7 @@ stand-alone
|
|||
<strong> "Images are not allowed" write </strong>
|
||||
] [
|
||||
escape-link
|
||||
[ <img =src ] [ [ =alt ] unless-empty img/> ] bi*
|
||||
[ <img url-encode =src ] [ [ =alt ] unless-empty img/> ] bi*
|
||||
] if ;
|
||||
|
||||
: render-code ( string mode -- string' )
|
||||
|
@ -161,31 +196,33 @@ GENERIC: (write-farkup) ( farkup -- )
|
|||
: <foo.> ( string -- ) <foo> write ;
|
||||
: </foo.> ( string -- ) </foo> write ;
|
||||
: in-tag. ( obj quot string -- ) [ <foo.> call ] keep </foo.> ; 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 <hr/> ;
|
||||
M: line-break (write-farkup) drop <br/> 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 ;
|
||||
|
|
|
@ -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
|
|||
</ul>
|
||||
] 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
|
||||
<redirect>
|
||||
<continue-conversation>
|
||||
] [ <400> ] if*
|
||||
exit-with ;
|
||||
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1 @@
|
|||
Actions and form validation
|
|
@ -0,0 +1 @@
|
|||
web
|
|
@ -3,6 +3,7 @@
|
|||
USING: kernel sequences db.tuples alarms calendar db fry
|
||||
furnace.db
|
||||
furnace.cache
|
||||
furnace.asides
|
||||
furnace.referrer
|
||||
furnace.sessions
|
||||
furnace.conversations
|
||||
|
@ -10,20 +11,24 @@ furnace.auth.providers
|
|||
furnace.auth.login.permits ;
|
||||
IN: furnace.alloy
|
||||
|
||||
: <alloy> ( responder db params -- responder' )
|
||||
'[
|
||||
<conversations>
|
||||
<sessions>
|
||||
_ _ <db-persistence>
|
||||
<check-form-submissions>
|
||||
] call ;
|
||||
|
||||
: state-classes { session conversation permit } ; inline
|
||||
: state-classes { session aside conversation permit } ; inline
|
||||
|
||||
: init-furnace-tables ( -- )
|
||||
state-classes ensure-tables
|
||||
user ensure-table ;
|
||||
|
||||
: <alloy> ( responder db params -- responder' )
|
||||
[ [ init-furnace-tables ] with-db ]
|
||||
[
|
||||
[
|
||||
<asides>
|
||||
<conversations>
|
||||
<sessions>
|
||||
] 2dip
|
||||
<db-persistence>
|
||||
<check-form-submissions>
|
||||
] 2bi ;
|
||||
|
||||
: start-expiring ( db params -- )
|
||||
'[
|
||||
_ _ [ state-classes [ expire-state ] each ] with-db
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1 @@
|
|||
Convenience responder combines several features
|
|
@ -0,0 +1 @@
|
|||
web
|
|
@ -0,0 +1,111 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces assocs kernel sequences accessors hashtables
|
||||
urls db.types db.tuples math.parser fry logging combinators
|
||||
html.templates.chloe.syntax
|
||||
http http.server http.server.filters http.server.redirection
|
||||
furnace
|
||||
furnace.cache
|
||||
furnace.sessions
|
||||
furnace.redirection ;
|
||||
IN: furnace.asides
|
||||
|
||||
TUPLE: aside < server-state
|
||||
session method url post-data ;
|
||||
|
||||
: <aside> ( id -- aside )
|
||||
aside new-server-state ;
|
||||
|
||||
aside "ASIDES" {
|
||||
{ "session" "SESSION" BIG-INTEGER +not-null+ }
|
||||
{ "method" "METHOD" { VARCHAR 10 } }
|
||||
{ "url" "URL" URL }
|
||||
{ "post-data" "POST_DATA" FACTOR-BLOB }
|
||||
} define-persistent
|
||||
|
||||
: aside-id-key "__a" ;
|
||||
|
||||
TUPLE: asides < server-state-manager ;
|
||||
|
||||
: <asides> ( responder -- responder' )
|
||||
asides new-server-state-manager ;
|
||||
|
||||
SYMBOL: aside-id
|
||||
|
||||
: get-aside ( id -- aside )
|
||||
dup [ aside get-state ] when check-session ;
|
||||
|
||||
: request-aside-id ( request -- id )
|
||||
aside-id-key swap request-params at string>number ;
|
||||
|
||||
: request-aside ( request -- aside )
|
||||
request-aside-id get-aside ;
|
||||
|
||||
: set-aside ( aside -- )
|
||||
[ id>> aside-id set ] when* ;
|
||||
|
||||
: init-asides ( asides -- )
|
||||
asides set
|
||||
request get request-aside-id
|
||||
get-aside
|
||||
set-aside ;
|
||||
|
||||
M: asides call-responder*
|
||||
[ init-asides ] [ asides set ] [ call-next-method ] tri ;
|
||||
|
||||
: touch-aside ( aside -- )
|
||||
asides get touch-state ;
|
||||
|
||||
: begin-aside ( url -- )
|
||||
f <aside>
|
||||
swap >>url
|
||||
session get id>> >>session
|
||||
request get method>> >>method
|
||||
request get post-data>> >>post-data
|
||||
[ touch-aside ] [ insert-tuple ] [ set-aside ] tri ;
|
||||
|
||||
: end-aside-post ( aside -- response )
|
||||
[ url>> ] [ post-data>> ] bi
|
||||
request [
|
||||
clone
|
||||
swap >>post-data
|
||||
over >>url
|
||||
] change
|
||||
[ url set ] [ path>> split-path ] bi
|
||||
asides get responder>> call-responder ;
|
||||
|
||||
\ end-aside-post DEBUG add-input-logging
|
||||
|
||||
ERROR: end-aside-in-get-error ;
|
||||
|
||||
: move-on ( id -- response )
|
||||
post-request? [ end-aside-in-get-error ] unless
|
||||
dup method>> {
|
||||
{ "GET" [ url>> <redirect> ] }
|
||||
{ "HEAD" [ url>> <redirect> ] }
|
||||
{ "POST" [ end-aside-post ] }
|
||||
} case ;
|
||||
|
||||
: end-aside ( default -- response )
|
||||
aside-id get aside-id off get-aside [ move-on ] [ <redirect> ] ?if ;
|
||||
|
||||
M: asides link-attr ( tag -- )
|
||||
drop
|
||||
"aside" optional-attr {
|
||||
{ "none" [ aside-id off ] }
|
||||
{ "begin" [ url get begin-aside ] }
|
||||
{ "current" [ ] }
|
||||
{ f [ ] }
|
||||
} case ;
|
||||
|
||||
M: asides modify-query ( query asides -- query' )
|
||||
drop
|
||||
aside-id get [
|
||||
aside-id-key associate assoc-union
|
||||
] when* ;
|
||||
|
||||
M: asides modify-form ( asides -- )
|
||||
drop
|
||||
aside-id get
|
||||
aside-id-key
|
||||
hidden-form-field ;
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1 @@
|
|||
Asides start an interaction which can return to the original page
|
|
@ -0,0 +1 @@
|
|||
web
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors assocs namespaces kernel sequences sets
|
||||
destructors combinators fry logging
|
||||
io.encodings.utf8 io.encodings.string io.binary random
|
||||
checksums checksums.sha2
|
||||
checksums checksums.sha2 urls
|
||||
html.forms
|
||||
http.server
|
||||
http.server.filters
|
||||
|
@ -60,6 +60,10 @@ TUPLE: realm < dispatcher name users checksum secure ;
|
|||
|
||||
GENERIC: login-required* ( description capabilities realm -- response )
|
||||
|
||||
GENERIC: user-registered ( user realm -- response )
|
||||
|
||||
M: object user-registered 2drop URL" $realm" <redirect> ;
|
||||
|
||||
GENERIC: init-realm ( realm -- )
|
||||
|
||||
GENERIC: logged-in-username ( realm -- username )
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1 @@
|
|||
Basic client authentication
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs namespaces accessors db db.tuples urls
|
||||
http.server.dispatchers
|
||||
furnace.conversations
|
||||
furnace.asides
|
||||
furnace.actions
|
||||
furnace.auth
|
||||
furnace.auth.providers ;
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Allow users to deactivate their accounts
|
|
@ -0,0 +1 @@
|
|||
web
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -3,8 +3,8 @@
|
|||
USING: kernel accessors namespaces sequences assocs
|
||||
validators urls html.forms http.server.dispatchers
|
||||
furnace.auth
|
||||
furnace.actions
|
||||
furnace.conversations ;
|
||||
furnace.asides
|
||||
furnace.actions ;
|
||||
IN: furnace.auth.features.edit-profile
|
||||
|
||||
: <edit-profile-action> ( -- action )
|
||||
|
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
<t:title>Edit Profile</t:title>
|
||||
|
||||
<t:form t:action="$realm/edit-profile">
|
||||
<t:form t:action="$realm/edit-profile" autocomplete="off">
|
||||
|
||||
<table>
|
||||
|
||||
|
@ -61,7 +61,7 @@
|
|||
</table>
|
||||
|
||||
<p>
|
||||
<input type="submit" value="Update" />
|
||||
<button>Update</button>
|
||||
<t:validation-messages />
|
||||
</p>
|
||||
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Allow users to edit account info
|
|
@ -0,0 +1 @@
|
|||
web
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -32,7 +32,7 @@
|
|||
|
||||
</table>
|
||||
|
||||
<input type="submit" value="Recover password" />
|
||||
<button>Recover password</button>
|
||||
|
||||
</t:form>
|
||||
|
||||
|
|
|
@ -31,7 +31,7 @@
|
|||
</table>
|
||||
|
||||
<p>
|
||||
<input type="submit" value="Set password" />
|
||||
<button>Set password</button>
|
||||
<t:validation-messages />
|
||||
</p>
|
||||
|
||||
|
|
|
@ -19,7 +19,7 @@ SYMBOL: lost-password-from
|
|||
[ username>> "username" set-query-param ]
|
||||
[ ticket>> "ticket" set-query-param ]
|
||||
bi
|
||||
adjust-url relative-to-request ;
|
||||
adjust-url ;
|
||||
|
||||
: password-email ( user -- email )
|
||||
<email>
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Allow users to receive a new password
|
|
@ -0,0 +1 @@
|
|||
web
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
<t:title>New User Registration</t:title>
|
||||
|
||||
<t:form t:action="register">
|
||||
<t:form t:action="register" autocomplete="off">
|
||||
|
||||
<table>
|
||||
|
||||
|
@ -62,7 +62,7 @@
|
|||
|
||||
<p>
|
||||
|
||||
<input type="submit" value="Register" />
|
||||
<button>Register</button>
|
||||
<t:validation-messages />
|
||||
|
||||
</p>
|
||||
|
|
|
@ -33,8 +33,7 @@ IN: furnace.auth.features.registration
|
|||
users new-user [ user-exists ] unless*
|
||||
|
||||
realm get init-user-profile
|
||||
|
||||
URL" $realm" <redirect>
|
||||
realm get user-registered
|
||||
] >>submit
|
||||
<auth-boilerplate>
|
||||
<secure-realm-only> ;
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Allow new users to register from the login page
|
|
@ -0,0 +1 @@
|
|||
web
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -5,6 +5,7 @@ calendar validators urls logging html.forms
|
|||
http http.server http.server.dispatchers
|
||||
furnace
|
||||
furnace.auth
|
||||
furnace.asides
|
||||
furnace.actions
|
||||
furnace.sessions
|
||||
furnace.utilities
|
||||
|
@ -93,9 +94,18 @@ SYMBOL: capabilities
|
|||
[ logout ] >>submit ;
|
||||
|
||||
M: login-realm login-required* ( description capabilities login -- response )
|
||||
begin-aside
|
||||
[ description cset ] [ capabilities cset ] [ drop ] tri*
|
||||
URL" $realm/login" >secure-url <redirect> ;
|
||||
begin-conversation
|
||||
[ description cset ] [ capabilities cset ] [ secure>> ] tri*
|
||||
[
|
||||
url get >secure-url begin-aside
|
||||
URL" $realm/login" >secure-url <continue-conversation>
|
||||
] [
|
||||
url get begin-aside
|
||||
URL" $realm/login" <continue-conversation>
|
||||
] if ;
|
||||
|
||||
M: login-realm user-registered ( user realm -- )
|
||||
drop successful-login ;
|
||||
|
||||
: <login-realm> ( responder name -- auth )
|
||||
login-realm new-realm
|
||||
|
|
|
@ -35,7 +35,7 @@
|
|||
|
||||
<p>
|
||||
|
||||
<input type="submit" value="Log in" />
|
||||
<button>Log in</button>
|
||||
<t:validation-messages />
|
||||
|
||||
</p>
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -0,0 +1 @@
|
|||
web
|
|
@ -0,0 +1 @@
|
|||
Login page authentication
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue