Merge branch 'experimental' into maintenance

db4
Alex Chapman 2008-10-02 15:02:38 +10:00
commit 583353651f
508 changed files with 8671 additions and 2307 deletions

1
basis/alarms/summary.txt Normal file
View File

@ -0,0 +1 @@
One-time and recurring events

1
basis/alias/summary.txt Normal file
View File

@ -0,0 +1 @@
Defining multiple words with the same name

View File

@ -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"

View File

@ -0,0 +1 @@
Fast searching of sorted arrays

View File

@ -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 ;

View File

@ -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

1
basis/boxes/summary.txt Normal file
View File

@ -0,0 +1 @@
An abstraction for enforcing a mutual-exclusion invariant

View File

@ -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 } }"
}
} ;

View File

@ -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

View File

@ -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

View File

@ -1 +1 @@
extensions
concurrency

View File

@ -1 +1 @@
extensions
concurrency

View File

@ -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> }

View File

@ -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: -> }

1
basis/colors/summary.txt Normal file
View File

@ -0,0 +1 @@
Colors as a first-class data type

View File

@ -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&& }

View File

@ -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:"

View File

@ -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? }

View File

@ -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

View File

@ -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

View File

@ -0,0 +1 @@
concurrency

View File

@ -0,0 +1 @@
concurrency

View File

@ -0,0 +1 @@
concurrency

View File

@ -1,2 +1,2 @@
concurrency
enterprise
extensions

View File

@ -0,0 +1 @@
concurrency

View File

@ -0,0 +1 @@
concurrency

View File

@ -0,0 +1 @@
concurrency

View File

@ -0,0 +1 @@
concurrency

View File

@ -0,0 +1 @@
concurrency

View File

@ -0,0 +1 @@
concurrency

View File

@ -0,0 +1 @@
concurrency

View File

@ -0,0 +1 @@
concurrency

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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"

View File

@ -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 -- )

View File

@ -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 ;

View File

@ -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 -- )
[

View File

@ -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 ;

View File

@ -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"

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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"

View File

@ -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 ;

View File

@ -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" ;

View File

@ -0,0 +1 @@
John Benediktsson

View File

@ -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

View File

@ -0,0 +1 @@
MacVim editor integration

View File

@ -0,0 +1 @@
unportable

View File

@ -0,0 +1 @@
John Benediktsson

View File

@ -0,0 +1 @@
TextEdit editor integration

View File

@ -0,0 +1 @@
unportable

View File

@ -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

1
basis/eval/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/eval/summary.txt Normal file
View File

@ -0,0 +1 @@
Ad-hoc evaluation of strings of code

View File

@ -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" } ;

View File

@ -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>&lt;foo&gt;</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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1 @@
Actions and form validation

View File

@ -0,0 +1 @@
web

View File

@ -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

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1 @@
Convenience responder combines several features

View File

@ -0,0 +1 @@
web

View File

@ -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 ;

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1 @@
Asides start an interaction which can return to the original page

View File

@ -0,0 +1 @@
web

View File

@ -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 )

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1 @@
Basic client authentication

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -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 ;

View File

@ -0,0 +1 @@
Allow users to deactivate their accounts

View File

@ -0,0 +1 @@
web

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -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 )

View File

@ -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>

View File

@ -0,0 +1 @@
Allow users to edit account info

View File

@ -0,0 +1 @@
web

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -32,7 +32,7 @@
</table>
<input type="submit" value="Recover password" />
<button>Recover password</button>
</t:form>

View File

@ -31,7 +31,7 @@
</table>
<p>
<input type="submit" value="Set password" />
<button>Set password</button>
<t:validation-messages />
</p>

View File

@ -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>

View File

@ -0,0 +1 @@
Allow users to receive a new password

View File

@ -0,0 +1 @@
web

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -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>

View File

@ -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> ;

View File

@ -0,0 +1 @@
Allow new users to register from the login page

View File

@ -0,0 +1 @@
web

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -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

View File

@ -35,7 +35,7 @@
<p>
<input type="submit" value="Log in" />
<button>Log in</button>
<t:validation-messages />
</p>

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1 @@
web

View File

@ -0,0 +1 @@
Login page authentication

Some files were not shown because too many files have changed in this diff Show More