steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Bruno Deferrari 2008-09-28 22:23:10 -03:00
parent 6e09d7cb63 dbf72ef148
commit 6ce09999de
203 changed files with 2601 additions and 1077 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
basis/calendar/format/format-tests.factor
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

8
basis/calendar/format/format.factor
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

159
basis/db/db-docs.factor
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"

7
basis/db/db.factor
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 -- )

50
basis/db/postgresql/postgresql.factor
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 ;

38
basis/db/queries/queries.factor
View File

@ -3,7 +3,7 @@
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 ;
destructors continuations db.tuples.private ;
IN: db.queries
GENERIC: where ( specs obj -- )
@ -46,13 +46,18 @@ M: retryable execute-statement* ( statement type -- )
[ db-columns ] [ db-table ] bi ;
: query-make ( class quot -- )
>r sql-props r>
[ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake
[ sql-props ] dip
[ 0 sql-counter rot with-variable ] curry
{ "" { } { } } nmake
<simple-statement> maybe-make-retryable ; 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 +126,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 )
[
@ -177,7 +181,8 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
[ offset>> [ do-offset ] [ drop ] if* ]
} 2cleave ;
M: db make-query ( tuple class query -- tuple )
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
@ -194,9 +199,8 @@ M: db make-query ( tuple class query -- tuple )
>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* ;

60
basis/db/sqlite/sqlite.factor
View File

@ -5,7 +5,7 @@ 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 ;
IN: db.sqlite
TUPLE: sqlite-db < db path ;
@ -88,7 +88,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 +114,20 @@ 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%
" " 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 +168,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 +203,9 @@ M: sqlite-db persistent-table ( -- assoc )
{ random-generator { f f f } }
} ;
M: sqlite-db compound ( str seq -- str' )
M: sqlite-db compound ( string seq -- new-string )
over {
{ "default" [ first number>string join-space ] }
[ 2drop ]
{ "references" [ >reference-string ] }
[ 2drop ]
} case ;

43
basis/db/tuples/tuples-docs.factor
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"

107
basis/db/tuples/tuples-tests.factor
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 ;
@ -177,34 +188,55 @@ TUPLE: annotation n paste-id summary author mode contents ;
{ "channel" "CHANNEL" TEXT }
{ "mode" "MODE" TEXT }
{ "contents" "CONTENTS" TEXT }
{ "date" "DATE" TIMESTAMP }
{ "timestamp" "DATE" TIMESTAMP }
{ "annotations" { +has-many+ annotation } }
} define-persistent
annotation "ANNOTATION"
{
{ "n" "ID" +db-assigned-id+ }
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } }
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" }
+on-delete+ +cascade+ }
{ "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
: test-paste-schema ( -- )
[ ] [ db-assigned-paste-schema ] unit-test
[ ] [ 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
: test-sqlite ( quot -- )
[ ] swap '[ "tuples-test.db" temp-file sqlite-db _ with-db ] unit-test ;
[ ] [
paste new
"summary1" >>summary
"erg" >>author
"#lol" >>channel
"contents1" >>contents
now >>timestamp
insert-tuple
] unit-test
: test-postgresql ( quot -- )
[ ] swap '[ { "localhost" "postgres" "foob" "factor-test" } postgresql-db _ with-db ] unit-test ;
[ ] [
annotation new
1 >>paste-id
"annotation1" >>summary
"erg" >>author
"annotation contents" >>contents
insert-tuple
] unit-test
[ ] [
] unit-test
;
[ test-paste-schema ] test-sqlite
[ test-paste-schema ] test-postgresql
: test-repeated-insert
[ ] [ person ensure-table ] unit-test
@ -357,7 +389,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 )
@ -513,14 +545,39 @@ string-encoding-test "STRING_ENCODING_TEST" {
: test-queries ( -- )
[ ] [ exam ensure-table ] unit-test
! [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test
! [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test
! [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
! [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
[ ] [ 10 [ random-exam insert-tuple ] times ] unit-test
! [ ] [ T{ exam { name "Kenny" } } >query ] unit-test
! [ ] [ query ] 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 ;
: test-db ( -- )
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 ;

140
basis/db/tuples/tuples.factor
View File

@ -3,19 +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 sets ;
destructors mirrors sets db.types ;
IN: db.tuples
TUPLE: query tuple group order offset limit ;
: <query> ( -- query ) \ query new ;
GENERIC: >query ( object -- query )
M: query >query ;
M: tuple >query <query> swap >>tuple ;
<PRIVATE
! returns a sequence of prepared-statements
HOOK: create-sql-statement db ( class -- object )
HOOK: drop-sql-statement db ( class -- object )
@ -25,42 +16,10 @@ 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 )
HOOK: <count-statement> db ( tuple class groups -- statement )
HOOK: make-query db ( tuple class query -- statement )
HOOK: <count-statement> db ( query -- statement )
HOOK: query>statement db ( query -- statement )
HOOK: insert-tuple* db ( tuple statement -- )
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 ;
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 ;
HOOK: insert-tuple-set-key db ( tuple statement -- )
SYMBOL: sql-counter
: next-sql-counter ( -- str )
@ -70,9 +29,7 @@ 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 )
@ -93,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 ;
@ -105,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?
@ -135,26 +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 make-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 make-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 ;

78
basis/db/types/types-docs.factor
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"

77
basis/db/types/types.factor
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,51 @@ 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+ ;
: offset-of-slot ( string tuple -- n )
class superclasses [ "slots" word-prop ] map concat
slot-named 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 +78,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 ;
@ -86,18 +115,22 @@ 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 +159,8 @@ 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>> ;
: 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 [ slot-name>> = ] with find nip
column-name>> paren append ;

2
basis/debugger/debugger.factor
View File

@ -323,3 +323,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" ;

33
basis/farkup/farkup-tests.factor
View File

@ -49,16 +49,16 @@ link-no-follow? off
[ "\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
@ -113,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
[
@ -131,7 +131,26 @@ link-no-follow? off
[ "<p>asdf\n<ul><li>lol</li>\n<li>haha</li></ul></p>" ] [ "asdf\n-lol\n-haha" convert-farkup ] unit-test
[ "<p>asdf</p><ul><li>lol</li>\n<li>haha</li></ul>" ] [ "asdf\n\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

35
basis/farkup/farkup.factor
View File

@ -2,7 +2,7 @@
! 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
sequences sequences.deep strings xml.entities
vectors splitting xmode.code2html urls ;
IN: farkup
@ -38,7 +38,7 @@ TUPLE: line ;
EBNF: parse-farkup
nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
2nl = nl nl
whitespace = " " | "\t" | nl
heading1 = "=" (!("=" | nl).)+ "="
=> [[ second >string heading1 boa ]]
@ -52,6 +52,10 @@ heading3 = "===" (!("=" | nl).)+ "==="
heading4 = "====" (!("=" | nl).)+ "===="
=> [[ second >string heading4 boa ]]
heading = heading4 | heading3 | heading2 | heading1
strong = "*" (!("*" | nl).)+ "*"
=> [[ second >string strong boa ]]
@ -67,8 +71,6 @@ subscript = "~" (!("~" | nl).)+ "~"
inline-code = "%" (!("%" | nl).)+ "%"
=> [[ second >string inline-code boa ]]
escaped-char = "\" . => [[ second 1string ]]
link-content = (!("|"|"]").)+
image-link = "[[image:" link-content "|" link-content "]]"
@ -84,11 +86,14 @@ 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 = '*' | '_' | '^' | '~' | '%' | '\' | '['
cell = (!(inline-delimiter | '|' | nl).)+
@ -104,12 +109,14 @@ table = ((table-row nl => [[ first ]] )+ table-row? | table-row)
text = (!(nl | code | heading | inline-delimiter | table ).)+
=> [[ >string ]]
paragraph-item = (table | list | text | inline-tag | inline-delimiter)+
paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]]
| (paragraph-item nl)+ paragraph-item?
paragraph-nl-item = nl (list | line)?
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 = (cell | inline-tag)*
ordered-list-item = '#' list-item
@ -124,22 +131,26 @@ unordered-list = ((unordered-list-item nl)+ unordered-list-item? | unordered-lis
list = ordered-list | unordered-list
line = '___'
=> [[ drop line new ]]
code = '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]"
named-code
= '[' (!('{' | whitespace | '[').)+ '{' (!("}]").)+ "}]"
=> [[ [ second >string ] [ fourth >string ] bi code boa ]]
simple-code
= "[{" (!("}]").)+ "}]"
=> [[ second f swap code boa ]]
code = named-code | simple-code
stand-alone
= (line | 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' )

1
basis/furnace/actions/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/furnace/actions/summary.txt Normal file
View File

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

1
basis/furnace/alloy/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/furnace/alloy/summary.txt Normal file
View File

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

1
basis/furnace/asides/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/furnace/asides/summary.txt Normal file
View File

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

1
basis/furnace/auth/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/furnace/auth/basic/summary.txt Normal file
View File

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

1
basis/furnace/auth/features/deactivate-user/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/furnace/auth/features/deactivate-user/summary.txt Normal file
View File

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

1
basis/furnace/auth/features/edit-profile/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

4
basis/furnace/auth/features/edit-profile/edit-profile.xml
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>

1
basis/furnace/auth/features/edit-profile/summary.txt Normal file
View File

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

1
basis/furnace/auth/features/recover-password/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

2
basis/furnace/auth/features/recover-password/recover-1.xml
View File

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

2
basis/furnace/auth/features/recover-password/recover-3.xml
View File

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

1
basis/furnace/auth/features/recover-password/summary.txt Normal file
View File

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

1
basis/furnace/auth/features/registration/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

4
basis/furnace/auth/features/registration/register.xml
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>

1
basis/furnace/auth/features/registration/summary.txt Normal file
View File

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

1
basis/furnace/auth/login/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

2
basis/furnace/auth/login/login.xml
View File

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

1
basis/furnace/auth/login/permits/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/furnace/auth/login/summary.txt Normal file
View File

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

1
basis/furnace/auth/providers/assoc/summary.txt Normal file
View File

@ -0,0 +1 @@
Look up user credentials in an assoc object

1
basis/furnace/auth/providers/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/furnace/auth/providers/db/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/furnace/auth/providers/db/summary.txt Normal file
View File

@ -0,0 +1 @@
Look up user credentials in the database

1
basis/furnace/auth/providers/null/summary.txt Normal file
View File

@ -0,0 +1 @@
Refuse all authentication requests

1
basis/furnace/auth/providers/summary.txt Normal file
View File

@ -0,0 +1 @@
Pluggable authentication backends

1
basis/furnace/auth/summary.txt Normal file
View File

@ -0,0 +1 @@
Authentication

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

@ -0,0 +1 @@
Slava Pestov

1
basis/furnace/boilerplate/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/furnace/boilerplate/summary.txt Normal file
View File

@ -0,0 +1 @@
Adding common headers/footers to pages

1
basis/furnace/cache/authors.txt vendored Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/furnace/cache/summary.txt vendored Normal file
View File

@ -0,0 +1 @@
Shared code for storing session state in the database

1
basis/furnace/chloe-tags/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

2
basis/furnace/chloe-tags/chloe-tags.factor
View File

@ -42,7 +42,7 @@ IN: furnace.chloe-tags
: compile-a-url ( tag -- )
{
[ "href" required-attr compile-attr ]
[ "href" optional-attr compile-attr ]
[ "rest" optional-attr compile-attr ]
[ "query" optional-attr compile-attr ]
[ "value" optional-attr compile-attr ]

1
basis/furnace/chloe-tags/summary.txt Normal file
View File

@ -0,0 +1 @@
Furnace-specific Chloe tags

1
basis/furnace/conversations/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/furnace/conversations/summary.txt Normal file
View File

@ -0,0 +1 @@
Retaining state between form submissions and redirects

1
basis/furnace/db/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/furnace/db/summary.txt Normal file
View File

@ -0,0 +1 @@
Database connection pooling

1
basis/furnace/json/summary.txt Normal file
View File

@ -0,0 +1 @@
Sending JSON responses to the client

1
basis/furnace/redirection/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/furnace/redirection/summary.txt Normal file
View File

@ -0,0 +1 @@
Various forms of URL redirection

1
basis/furnace/referrer/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/furnace/referrer/summary.txt Normal file
View File

@ -0,0 +1 @@
Referrer checking

1
basis/furnace/scopes/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/furnace/scopes/summary.txt Normal file
View File

@ -0,0 +1 @@
Shared code for storing scopes in the database

1
basis/furnace/sessions/authors.txt
View File

@ -1 +1,2 @@
Doug Coleman
Slava Pestov

1
basis/furnace/sessions/summary.txt Normal file
View File

@ -0,0 +1 @@
Session management

1
basis/furnace/syndication/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/furnace/syndication/summary.txt Normal file
View File

@ -0,0 +1 @@
Atom feed syndication

1
basis/furnace/utilities/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
basis/furnace/utilities/summary.txt Normal file
View File

@ -0,0 +1 @@
Odds and ends

4
basis/html/templates/fhtml/fhtml-docs.factor
View File

@ -1,7 +1,9 @@
IN: html.templates.fhtml
USING: help.markup help.syntax ;
HELP: <fhtml> ;
HELP: <fhtml> ( path -- fhtml )
{ $values { "path" "a pathname string" } { "fhtml" fhtml } }
{ $description "Creates an FHTML template descriptor." } ;
ARTICLE: "html.templates.fhtml" "FHTML templates"
"The " { $vocab-link "html.templates.fhtml" } " vocabulary implements a templating engine which mixes markup with Factor code."

93
basis/http/client/client-docs.factor Normal file
View File

@ -0,0 +1,93 @@
USING: http help.markup help.syntax io.files io.streams.string
io.encodings.8-bit io.encodings.binary kernel strings urls
byte-arrays strings assocs sequences ;
IN: http.client
HELP: download-failed
{ $error-description "Thrown by " { $link http-request } " if the server returns a status code other than 200. The " { $slot "response" } " and " { $slot "body" } " slots can be inspected for the underlying cause of the problem." } ;
HELP: too-many-redirects
{ $error-description "Thrown by " { $link http-request } " if the server returns a chain of than " { $link max-redirects } " redirections." } ;
HELP: <get-request>
{ $values { "url" "a " { $link url } " or " { $link string } } { "request" request } }
{ $description "Constructs an HTTP GET request for retrieving the URL." }
{ $notes "The request can be passed on to " { $link http-request } ", possibly after cookies and headers are set." } ;
HELP: <post-request>
{ $values { "post-data" object } { "url" "a " { $link url } " or " { $link string } } { "request" request } }
{ $description "Constructs an HTTP POST request for submitting post data to the URL." }
{ $notes "The request can be passed on to " { $link http-request } ", possibly after cookies and headers are set." } ;
HELP: download
{ $values { "url" "a " { $link url } " or " { $link string } } }
{ $description "Downloads the contents of the URL to a file in the " { $link current-directory } " having the same file name." }
{ $errors "Throws an error if the HTTP request fails." } ;
HELP: download-to
{ $values { "url" "a " { $link url } " or " { $link string } } { "file" "a pathname string" } }
{ $description "Downloads the contents of the URL to a file with the given pathname." }
{ $errors "Throws an error if the HTTP request fails." } ;
HELP: http-get
{ $values { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } }
{ $description "Downloads the contents of a URL." }
{ $errors "Throws an error if the HTTP request fails." } ;
HELP: http-post
{ $values { "post-data" object } { "url" "a " { $link url } " or " { $link string } } { "response" response } { "data" sequence } }
{ $description "Submits a form at a URL." }
{ $errors "Throws an error if the HTTP request fails." } ;
HELP: http-request
{ $values { "request" request } { "response" response } { "data" sequence } }
{ $description "Sends an HTTP request to an HTTP server, and reads the response." }
{ $errors "Throws an error if the HTTP request fails." } ;
ARTICLE: "http.client.get" "GET requests with the HTTP client"
"Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:"
{ $subsection http-get }
"Utilities to retrieve a " { $link url } " and save the contents to a file:"
{ $subsection download }
{ $subsection download-to }
"Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:"
{ $subsection <get-request> }
{ $subsection http-request } ;
ARTICLE: "http.client.post" "POST requests with the HTTP client"
"As with GET requests, there is a high-level word which takes a " { $link url } " and a lower-level word which constructs an HTTP request object which can be passed to " { $link http-request } ":"
{ $subsection http-post }
{ $subsection <post-request> }
"Both words take a post data parameter, which can be one of the following:"
{ $list
{ "a " { $link byte-array } " or " { $link string } " is sent the server without further encoding" }
{ "an " { $link assoc } " is interpreted as a series of form parameters, which are encoded with " { $link assoc>query } }
{ { $link f } " denotes that there is no post data" }
} ;
ARTICLE: "http.client.encoding" "Character encodings and the HTTP client"
"The " { $link http-request } ", " { $link http-get } " and " { $link http-post } " words output a sequence containing data that was sent by the server."
$nl
"If the server specifies a " { $snippet "content-type" } " header with a character encoding, the HTTP client decodes the data using this character encoding, and the sequence will be a string."
$nl
"If no encoding was specified but the MIME type is a text type, the " { $link latin1 } " encoding is assumed, and the sequence will be a string."
$nl
"For any other MIME type, the " { $link binary } " encoding is assumed, and thus the data is returned literally in a byte array." ;
ARTICLE: "http.client.errors" "HTTP client errors"
"HTTP operations may fail for one of two reasons. The first is an I/O error resulting from a network problem; a name server lookup failure, or a refused connection. The second is a protocol-level error returned by the server. There are two such errors:"
{ $subsection download-failed }
{ $subsection too-many-redirects } ;
ARTICLE: "http.client" "HTTP client"
"The " { $vocab-link "http.client" } " vocabulary implements an HTTP and HTTPS client on top of " { $link "http" } "."
$nl
"There are two primary usage patterns, data retrieval with GET requests and form submission with POST requests:"
{ $subsection "http.client.get" }
{ $subsection "http.client.post" }
"More esoteric use-cases, for example HTTP methods other than the above, are accomodated by constructing an empty request object with " { $link <request> } " and filling everything in by hand."
{ $subsection "http.client.encoding" }
{ $subsection "http.client.errors" }
{ $see-also "urls" } ;
ABOUT: "http.client"

2
basis/http/client/client.factor
View File

@ -33,7 +33,7 @@ IN: http.client
[ content-type>> "content-type" pick set-at ]
bi
] when*
over cookies>> f like [ unparse-cookie "cookie" pick set-at ] when*
over cookies>> [ unparse-cookie "cookie" pick set-at ] unless-empty
write-header ;
GENERIC: >post-data ( object -- post-data )

166
basis/http/http-docs.factor Normal file
View File

@ -0,0 +1,166 @@
USING: assocs help.markup help.syntax io.streams.string sequences strings present math kernel byte-arrays urls
calendar ;
IN: http
HELP: <request>
{ $values { "request" request } }
{ $description "Creates an empty request." } ;
HELP: request
{ $description "An HTTP request."
$nl
"Instances contain the following slots:"
{ $table
{ { $slot "method" } { "The HTTP method as a " { $link string } ". The most frequently-used HTTP methods are " { $snippet "GET" } ", " { $snippet "HEAD" } " and " { $snippet "POST" } "." } }
{ { $slot "url" } { "The " { $link url } " being requested" } }
{ { $slot "version" } { "The HTTP version. Default is " { $snippet "1.1" } " and should not be changed without good reason." } }
{ { $slot "header" } { "An assoc of HTTP header values. See " { $link "http.headers" } } }
{ { $slot "post-data" } { "See " { $link "http.post-data" } } }
{ { $slot "cookies" } { "A sequence of HTTP cookies. See " { $link "http.cookies" } } }
} } ;
HELP: <response>
{ $values { "response" response } }
{ $description "Creates an empty response." } ;
HELP: response
{ $class-description "An HTTP response."
$nl
"Instances contain the following slots:"
{ $table
{ { $slot "version" } { "The HTTP version. Default is " { $snippet "1.1" } " and should not be changed without good reason." } }
{ { $slot "code" } { "HTTP status code, an " { $link integer } ". Examples are 200 for success, 404 for file not found, and so on." } }
{ { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be ``Success'', for example." } }
{ { $slot "header" } { "An assoc of HTTP header values. See " { $link "http.headers" } } }
{ { $slot "cookies" } { "A sequence of HTTP cookies. See " { $link "http.cookies" } } }
{ { $slot "content-type" } { "an HTTP content type" } }
{ { $slot "content-charset" } { "an encoding descriptor. See " { $link "io.encodings" } } }
{ { $slot "body" } { "an HTTP response body" } }
} } ;
HELP: <raw-response>
{ $values { "response" raw-response } }
{ $description "Creates an empty raw response." } ;
HELP: raw-response
{ $class-description "A minimal HTTP response used by webapps which need full control over all output sent to the client. Most webapps can use " { $link response } " instead."
$nl
"Instances contain the following slots:"
{ $table
{ { $slot "version" } { "The HTTP version. Default is " { $snippet "1.1" } " and should not be changed without good reason." } }
{ { $slot "code" } { "HTTP status code, an " { $link integer } ". Examples are 200 for success, 404 for file not found, and so on." } }
{ { $slot "message" } { "HTTP status message, only displayed to the user. If the status code is 200, the status message might be ``Success'', for example." } }
{ { $slot "body" } { "an HTTP response body" } }
} } ;
HELP: <cookie>
{ $values { "value" object } { "name" string } { "cookie" cookie } }
{ $description "Creates a cookie with the specified name and value. The value can be any object supported by the " { $link present } " word." } ;
HELP: cookie
{ $class-description
"An HTTP cookie."
$nl
"Instances contain a number of slots which correspond exactly to the fields of a cookie in the cookie specification:"
{ $table
{ { $slot "name" } { "The cookie name, a " { $link string } } }
{ { $slot "value" } { "The cookie value, an object supported by " { $link present } } }
{ { $slot "comment" } { "A " { $link string } } }
{ { $slot "path" } { "The pathname prefix where the cookie is valid, a " { $link string } } }
{ { $slot "domain" } { "The domain name where the cookie is valid, a " { $link string } } }
{ { $slot "expires" } { "The expiry time, a " { $link timestamp } " or " { $link f } " for a session cookie" } }
{ { $slot "max-age" } { "The expiry duration, a " { $link duration } " or " { $link f } " for a session cookie" } }
{ { $slot "http-only" } { "If set to a true value, JavaScript code cannot see the cookie" } }
{ { $slot "secure" } { "If set to a true value, the cookie is only sent for " { $snippet "https" } " protocol connections" } }
}
"Only one of " { $snippet "expires" } " and " { $snippet "max-age" } " can be set; the latter is preferred and is supported by all modern browsers." } ;
HELP: delete-cookie
{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "name" string } }
{ $description "Deletes a cookie from a request or response." }
{ $side-effects "request/response" } ;
HELP: get-cookie
{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "name" string } { "cookie/f" "a " { $link cookie } " or " { $link f } } }
{ $description "Gets a named cookie from a request or response." } ;
HELP: put-cookie
{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "cookie" cookie } }
{ $description "Stores a cookie in a request or response." }
{ $side-effects "request/response" } ;
HELP: <post-data>
{ $values { "raw" byte-array } { "content-type" "a MIME type string" } { "post-data" post-data } }
{ $description "Creates a new " { $link post-data } "." } ;
HELP: header
{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "key" string } { "value" string } }
{ $description "Obtains an HTTP header value from a request or response." } ;
HELP: post-data
{ $class-description "HTTP POST data passed in a POST request."
$nl
"Instances contain the following slots:"
{ $table
{ { $slot "raw" } { "The raw bytes of the POST data" } }
{ { $slot "content" } { "The POST data. This can be in a higher-level form, such as an assoc of POST parameters, a string, or an XML document" } }
{ { $slot "content-type" } "A MIME type" }
} } ;
HELP: set-header
{ $values { "request/response" "a " { $link request } " or a " { $link response } } { "value" object } { "key" string } }
{ $description "Stores a value into the HTTP header of a request or response. The value can be any object supported by " { $link present } "." }
{ $notes "This word always returns the same object that was input. This allows for a ``pipeline'' coding style, where several header parameters are set in a row." }
{ $side-effects "request/response" } ;
ARTICLE: "http.cookies" "HTTP cookies"
"Every " { $link request } " and " { $link response } " instance can contain cookies."
$nl
"The " { $vocab-link "furnace.sessions" } " vocabulary implements session management using cookies, thus the most common use case can be taken care of without working with cookies directly."
$nl
"The class of cookies:"
{ $subsection cookie }
"Creating cookies:"
{ $subsection <cookie> }
"Getting, adding, and deleting cookies in " { $link request } " and " { $link response } " objects:"
{ $subsection get-cookie }
{ $subsection put-cookie }
{ $subsection delete-cookie } ;
ARTICLE: "http.headers" "HTTP headers"
"Every " { $link request } " and " { $link response } " has a set of HTTP headers stored in the " { $slot "header" } " slot. Header names are normalized to lower-case when a request or response is being parsed."
{ $subsection header }
{ $subsection set-header } ;
ARTICLE: "http.post-data" "HTTP post data"
"Every " { $link request } " where the " { $slot "method" } " slot is " { $snippet "POST" } " can contain post data."
{ $subsection post-data }
{ $subsection <post-data> } ;
ARTICLE: "http.requests" "HTTP requests"
"HTTP requests:"
{ $subsection request }
{ $subsection <request> }
"Requests can contain form submissions:"
{ $subsection "http.post-data" } ;
ARTICLE: "http.responses" "HTTP responses"
"HTTP responses:"
{ $subsection response }
{ $subsection <response> }
"Raw responses only contain a status line, with no header. They are used by webapps which need full control over the HTTP response, for example " { $vocab-link "http.server.cgi" } ":"
{ $subsection raw-response }
{ $subsection <raw-response> } ;
ARTICLE: "http" "HTTP protocol objects"
"The " { $vocab-link "http" } " vocabulary contains data types shared by " { $vocab-link "http.client" } " and " { $vocab-link "http.server" } "."
$nl
"The HTTP client sends an HTTP request to the server and receives an HTTP response back. The HTTP server receives HTTP requests from clients and sends HTTP responses back."
{ $subsection "http.requests" }
{ $subsection "http.responses" }
"Both requests and responses support some common functionality:"
{ $subsection "http.headers" }
{ $subsection "http.cookies" }
{ $see-also "urls" } ;
ABOUT: "http"

2
basis/http/http-tests.factor
View File

@ -257,7 +257,7 @@ test-db [
"" add-responder
add-quit-action
<dispatcher>
<action> "a" add-main-responder
<action> "" add-responder
"d" add-responder
test-db <db-persistence>
main-responder set

6
basis/http/http.factor
View File

@ -3,15 +3,13 @@
USING: accessors kernel combinators math namespaces make
assocs sequences splitting sorting sets debugger
strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format present
math.parser calendar calendar.format present urls logging
io io.encodings io.encodings.iana io.encodings.binary
io.encodings.8-bit
unicode.case unicode.categories qualified
urls
http.parsers ;
EXCLUDE: fry => , ;
@ -98,6 +96,8 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
drop
] { } make ;
\ parse-cookie DEBUG add-input-logging
: check-cookie-string ( string -- string' )
dup "=;'\"\r\n" intersect empty?
[ "Bad cookie name or value" throw ] unless ;

4
basis/http/parsers/parsers.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit math math.order math.parser
kernel sequences sequences.deep peg peg.parsers assocs arrays
hashtables strings unicode.case namespaces make ascii ;
hashtables strings unicode.case namespaces make ascii logging ;
IN: http.parsers
: except ( quot -- parser )
@ -61,6 +61,8 @@ PEG: parse-request-line ( string -- triple )
'space' ,
] seq* just ;
\ parse-request-line DEBUG add-input-logging
: 'text' ( -- parser )
[ ctl? ] except ;

17
basis/http/server/cgi/cgi-docs.factor Normal file
View File

@ -0,0 +1,17 @@
USING: help.markup help.syntax http.server.static multiline ;
IN: http.server.cgi
HELP: enable-cgi
{ $values { "responder" file-responder } }
{ $description "Enables the responder to serve " { $snippet ".cgi" } " scripts by executing them as per the CGI specification." }
{ $examples
{ $code
<" <dispatcher>
"/var/www/cgi/" <static> enable-cgi "cgi-bin" add-responder" ">
}
}
{ $side-effects "responder" } ;
ARTICLE: "http.server.cgi" "Serving CGI scripts"
"The " { $vocab-link "http.server.cgi" } " implements CGI support. It is used in conjunction with a " { $link <static> } " responder."
{ $subsection enable-cgi } ;

91
basis/http/server/dispatchers/dispatchers-docs.factor Normal file
View File

@ -0,0 +1,91 @@
! Copyright (C) 2008 Your name.
! See http://factorcode.org/license.txt for BSD license.
USING: classes help.markup help.syntax io.streams.string
multiline ;
IN: http.server.dispatchers
HELP: new-dispatcher
{ $values { "class" class } { "dispatcher" dispatcher } }
{ $description "Creates a new instance of a subclass of " { $link dispatcher } "." } ;
HELP: dispatcher
{ $description "The class of dispatchers. May be subclassed, in which case subclasses should be constructed by calling " { $link new-dispatcher } "." } ;
HELP: <dispatcher>
{ $values { "dispatcher" dispatcher } }
{ $description "Creates a new pathname dispatcher." } ;
HELP: vhost-dispatcher
{ $description "The class of virtual host dispatchers." } ;
HELP: <vhost-dispatcher>
{ $values { "dispatcher" vhost-dispatcher } }
{ $description "Creates a new virtual host dispatcher." } ;
HELP: add-responder
{ $values
{ "dispatcher" dispatcher } { "responder" "a responder" } { "path" "a pathname string or hostname" } }
{ $description "Adds a responder to a dispatcher." }
{ $notes "The " { $snippet "path" } " parameter is interpreted differently depending on the dispatcher type." }
{ $side-effects "dispatcher" } ;
ARTICLE: "http.server.dispatchers.example" "HTTP dispatcher examples"
{ $heading "Simple pathname dispatcher" }
{ $code
<" <dispatcher>
<new-action> "new" add-responder
<edit-action> "edit" add-responder
<delete-action> "delete" add-responder
<list-action> "" add-responder
main-responder set-global">
}
"In the above example, visiting any URL other than " { $snippet "/new" } ", " { $snippet "/edit" } ", " { $snippet "/delete" } ", or " { $snippet "/" } " will result in a 404 error."
{ $heading "Another pathname dispatcher" }
"On the other hand, suppose we wanted to route all unrecognized paths to a ``view'' action:"
{ $code
<" <dispatcher>
<new-action> "new" add-responder
<edit-action> "edit" add-responder
<delete-action> "delete" add-responder
<view-action> >>default
main-responder set-global">
}
"The " { $slot "default" } " slot holds a responder to which all unrecognized paths are sent to."
{ $heading "Dispatcher subclassing example" }
{ $code
<" TUPLE: golf-courses < dispatcher ;
: <golf-courses> ( -- golf-courses )
golf-courses new-dispatcher ;
<golf-courses>
<new-action> "new" add-responder
<edit-action> "edit" add-responder
<delete-action> "delete" add-responder
<list-action> "" add-responder
main-responder set-global">
}
"The action templates can now emit links to responder-relative URLs prefixed by " { $snippet "$golf-courses/" } "."
{ $heading "Virtual hosting example" }
{ $code
<" <vhost-dispatcher>
<casino> "concatenative-casino.com" add-responder
<dating> "raptor-dating.com" add-responder
main-responder set-global">
}
"Note that the virtual host dispatcher strips off a " { $snippet "www." } " prefix, so " { $snippet "www.concatenative-casino.com" } " would be routed to the " { $snippet "<casino>" } " responder instead of receiving a 404." ;
ARTICLE: "http.server.dispatchers" "HTTP dispatchers and virtual hosting"
"The " { $vocab-link "http.server.dispatchers" } " vocabulary implements two responders which route HTTP requests to one or more child responders."
{ $subsection "http.server.dispatchers.example" }
"Pathname dispatchers implement a directory hierarchy where each subdirectory is its own responder:"
{ $subsection dispatcher }
{ $subsection <dispatcher> }
"Virtual host dispatchers dispatch each virtual host to a different responder:"
{ $subsection vhost-dispatcher }
{ $subsection <vhost-dispatcher> }
"Adding responders to dispatchers:"
{ $subsection add-responder }
"The " { $slot "default" } " slot holds a responder which receives all unrecognized URLs. By default, it responds with 404 messages." ;
ABOUT: "http.server.dispatchers"

12
basis/http/server/filters/filters-docs.factor Normal file
View File

@ -0,0 +1,12 @@
USING: help.markup help.syntax http.server ;
IN: http.server.filters
HELP: filter-responder
{ $description "The class of filter responders. This class is intended to be subclassed." } ;
ARTICLE: "http.server.filters" "HTTP responder filters"
"The " { $vocab-link "http.server.filters" } " vocabulary implements the common pattern where one responder wraps another, doing some processing before calling the wrapped responder."
{ $subsection filter-responder }
"To use it, simply subclass " { $link filter-responder } ", and call " { $link POSTPONE: call-next-method } " from your " { $link call-responder* } " method to pass control to the wrapped responder." ;
ABOUT: "http.server.filters"

26
basis/http/server/redirection/redirection-docs.factor Normal file
View File

@ -0,0 +1,26 @@
USING: help.markup help.syntax urls strings http ;
IN: http.server.redirection
HELP: relative-to-request
{ $values { "url" "a " { $link url } " or " { $link string } } { "url'" "a " { $link url } " or " { $link string } } }
{ $description "If the input is a relative " { $link url } ", makes it an absolute URL by resolving it to the current request's URL. If the input is a string, does nothing." } ;
HELP: <permanent-redirect>
{ $values { "url" "a " { $link url } " or " { $link string } } { "response" response } }
{ $description "Redirects to the user to the URL after applying " { $link relative-to-request } "." }
{ $notes "This redirect type should always be used with POST requests, and with GET requests in cases where the new URL always supercedes the old one. This is due to browsers caching the new URL with permanent redirects." } ;
HELP: <temporary-redirect>
{ $values { "url" "a " { $link url } " or " { $link string } } { "response" response } }
{ $description "Redirects to the user to the URL after applying " { $link relative-to-request } "." }
{ $notes "This redirect type should be used with GET requests where the new URL does not always supercede the old one. Use from POST requests with care, since this will cause the browser to resubmit the form to the new URL." } ;
ARTICLE: "http.server.redirection" "HTTP responder redirection"
"The " { $vocab-link "http.server.redirection" } " defines some " { $link response } " types which redirect the user's client to a new page."
{ $subsection <permanent-redirect> }
{ $subsection <temporary-redirect> }
"A utility used by the above:"
{ $subsection relative-to-request }
"The " { $vocab-link "furnace.redirection" } " vocabulary provides a higher-level implementation of this. The " { $vocab-link "furnace.conversations" } " vocabulary allows state to be maintained between redirects." ;
ABOUT: "http.server.redirection"

24
basis/http/server/remapping/remapping-docs.factor Normal file
View File

@ -0,0 +1,24 @@
USING: help.markup help.syntax ;
IN: http.server.remapping
HELP: port-remapping
{ $var-description "An assoc mapping port numbers that the HTTP server listens on to external port numbers presented to the user." } ;
ARTICLE: "http.server.remapping" "HTTP server port remapping"
"On Unix systems, non-root processes cannot bind to sockets on port numbers under 1024. Since running an HTTP server as root is a potential security risk, a typical setup runs an HTTP server under an ordinary user account, set up to listen on a higher port number such as 8080. Then, the HTTP port is redirected to 8080. On Linux, this might be done using commands such as the following:"
{ $code
"echo 1 > /proc/sys/net/ipv4/ip_forward"
"iptables -t nat -F"
"iptables -A PREROUTING -t nat -i eth0 -p tcp --dport 443 -j DNAT --to :8443"
"iptables -A PREROUTING -t nat -i eth0 -p tcp --dport 80 -j DNAT --to :8080"
}
"However, the HTTP server is unaware of the forwarding, and still believes that it is listening on port 8080 and 8443, respectively. This can be a problem if a responder wishes to redirect the user to a secure page; they will be sent to port 8443 and not 443 as one would expect."
$nl
"The " { $vocab-link "http.server.remapping" } " vocabulary defines a variable which may store an assoc of port mappings:"
{ $subsection port-remapping }
"For example, with the above setup, we would set it as follows:"
{ $code
"{ { 8080 80 } { 8443 443 } } port-remapping set-global"
} ;
ABOUT: "http.server.remapping"

29
basis/http/server/responses/responses-docs.factor Normal file
View File

@ -0,0 +1,29 @@
USING: help.markup help.syntax io.streams.string strings
http math ;
IN: http.server.responses
HELP: <content>
{ $values { "body" "a response body" } { "content-type" string } { "response" response } }
{ $description "Creates a successful HTTP response which sends a response body with the specified content type to the client." } ;
HELP: <trivial-response>
{ $values { "code" integer } { "message" string } { "response" response } }
{ $description "Creates an HTTP error response." }
{ $examples
{ $code
"USE: http.server.responses"
"415 \"Unsupported Media Type\" <trivial-response>"
}
} ;
ARTICLE: "http.server.responses" "Canned HTTP responses"
"The " { $vocab-link "http.server.responses" } " vocabulary provides constructors for a few useful " { $link response } " objects."
{ $subsection <content> }
{ $subsection <304> }
{ $subsection <403> }
{ $subsection <400> }
{ $subsection <404> }
"New error responses like the above can be created for other error codes too:"
{ $subsection <trivial-response> } ;
ABOUT: "http.server.responses"

101
basis/http/server/server-docs.factor Normal file
View File

@ -0,0 +1,101 @@
USING: help.markup help.syntax io.streams.string quotations strings urls http tools.vocabs math io.servers.connection ;
IN: http.server
HELP: trivial-responder
{ $description "The class of trivial responders, which output the same response for every request. New instances are created by calling " { $link <trivial-responder> } "." } ;
HELP: <trivial-responder> ( response -- responder )
{ $values { "response" response } { "responder" trivial-responder } }
{ $description "Creates a new trivial responder which outputs the same response for every request." } ;
HELP: benchmark?
{ $var-description "If set to a true value, the HTTP server will log the time taken to process each request." } ;
HELP: call-responder
{ $values
{ "path" "a sequence of strings" } { "responder" "a responder" }
{ "response" response } }
{ $description "Calls a responder." } ;
HELP: call-responder*
{ $values
{ "path" "a sequence of strings" } { "responder" "a responder" }
{ "response" response } }
{ $contract "Processes an HTTP request and returns a response." }
{ $notes "When this word is called, various dynamic variables are set; see " { $link "http.server.requests" } "." } ;
HELP: development?
{ $var-description "If set to a true value, the HTTP server will call " { $link refresh-all } " on each request, and error pages will contain stack traces." } ;
HELP: main-responder
{ $var-description "The responder which will handle HTTP requests." } ;
HELP: post-request?
{ $values { "?" "a boolean" } }
{ $description "Outputs if the current request is a POST request.s" } ;
HELP: responder-nesting
{ $description "A sequence of " { $snippet "{ path responder }" } " pairs." } ;
HELP: http-server
{ $class-description "The class of HTTP servers. New instances are created by calling " { $link <http-server> } "." } ;
HELP: <http-server>
{ $values { "server" http-server } }
{ $description "Creates a new HTTP server with default parameters." } ;
HELP: httpd
{ $values { "port" integer } }
{ $description "Starts an HTTP server on the specified port number." }
{ $notes "For more flexibility, use " { $link <http-server> } " and fill in the tuple slots before calling " { $link start-server } "." } ;
HELP: http-insomniac
{ $description "Starts a thread which rotates the logs and e-mails a summary of HTTP requests every 24 hours. See " { $link "logging.insomniac" } "." } ;
ARTICLE: "http.server.requests" "HTTP request variables"
"The following variables are set by the HTTP server at the beginning of a request."
{ $subsection request }
{ $subsection url }
{ $subsection post-request? }
{ $subsection responder-nesting }
"Additional vocabularies may be set by vocabularies such as " { $vocab-link "html.forms" } " and " { $vocab-link "furnace.sessions" } "." ;
ARTICLE: "http.server.responders" "HTTP server responders"
"The HTTP server dispatches requests to a main responder:"
{ $subsection main-responder }
"The main responder may in turn dispatch it a subordinate dispatcher, and so on."
$nl
"Responders process requests and output " { $link "http.responses" } "; concretely are instances of classes which implement a generic word:"
{ $subsection call-responder* }
"To actually call a subordinate responder, use the following word instead:"
{ $subsection call-responder }
"A simple implementation of a responder which always outputs the same response:"
{ $subsection trivial-responder }
{ $subsection <trivial-responder> }
{ $vocab-subsection "Furnace actions" "furnace.actions" }
"In particular, writing new responders by hand is rarely necessary, because in most cases it is easier to use " { $vocab-link "furnace.actions" } " instead." ;
ARTICLE: "http.server.variables" "HTTP server variables"
"The following global variables control the behavior of the HTTP server. Both are off by default."
{ $subsection development? }
{ $subsection benchmark? } ;
ARTICLE: "http.server" "HTTP server"
"The " { $vocab-link "http.server" } " vocabulary implements an HTTP and HTTPS server on top of " { $vocab-link "io.servers.connection" } "."
{ $subsection "http.server.responders" }
{ $subsection "http.server.requests" }
"Various types of responders are defined in other vocabularies:"
{ $subsection "http.server.dispatchers" }
{ $subsection "http.server.filters" }
"Useful canned responses:"
{ $subsection "http.server.responses" }
{ $subsection "http.server.redirection" }
"Configuration:"
{ $subsection "http.server.variables" }
{ $subsection "http.server.remapping" }
"Features:"
{ $subsection "http.server.static" }
{ $subsection "http.server.cgi" }
"The " { $vocab-link "furnace" } " framework implements high-level abstractions which make developing web applications much easier than writing responders by hand." ;
ABOUT: "http.server"

8
basis/http/server/server.factor
View File

@ -255,3 +255,11 @@ M: http-server handle-client*
: http-insomniac ( -- )
"http.server" { "httpd-hit" } schedule-insomniac ;
USE: vocabs.loader
"http.server.filters" require
"http.server.dispatchers" require
"http.server.redirection" require
"http.server.static" require
"http.server.cgi" require

37
basis/http/server/static/static-docs.factor Normal file
View File

@ -0,0 +1,37 @@
! Copyright (C) 2008 Your name.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string ;
IN: http.server.static
HELP: <file-responder>
{ $values { "root" "a pathname string" } { "hook" "a quotation with stack effect " { $snippet "( path mime-type -- response )" } } { "responder" file-responder } }
{ $description "Creates a file responder which serves content from " { $snippet "path" } " by using the hook to generate a response." } ;
HELP: <static>
{ $values
{ "root" "a pathname string" }
{ "responder" file-responder } }
{ $description "Creates a file responder which serves content from " { $snippet "path" } "." } ;
HELP: enable-fhtml
{ $values { "responder" file-responder } }
{ $description "Enables the responder to serve " { $snippet ".fhtml" } " files by running them." }
{ $notes "See " { $link "html.templates.fhtml" } "." }
{ $side-effects "responder" } ;
ARTICLE: "http.server.static" "Serving static content"
"The " { $vocab-link "http.server.static" } " vocabulary implements a responder for serving static files."
{ $subsection <static> }
"The static responder does not serve directory listings by default, as a security measure. Directory listings can be enabled by storing a true value in the " { $slot "allow-listings" } " slot."
$nl
"The static responder can be extended for dynamic content by associating quotations with MIME types in the hashtable stored in the " { $slot "special" } " slot. The quotations have stack effect " { $snippet "( path -- )" } "."
$nl
"A utility word uses the above feature to enable server-side " { $snippet ".fhtml" } " scripts, allowing a development style much like PHP:"
{ $subsection enable-fhtml }
"This feature is also used by " { $vocab-link "http.server.cgi" } " to run " { $snippet ".cgi" } " files."
$nl
"It is also possible to override the hook used when serving static files to the client:"
{ $subsection <file-responder> }
"The default just sends the file's contents with the request; " { $vocab-link "xmode.code2html.responder" } " provides an alternate hook which sends a syntax-highlighted version of the file." ;
ABOUT: "http.server.static"

1
basis/http/server/static/static.factor
View File

@ -12,7 +12,6 @@ http.server.responses
http.server.redirection ;
IN: http.server.static
! special maps mime types to quots with effect ( path -- )
TUPLE: file-responder root hook special allow-listings ;
: modified-since? ( filename -- ? )

2
basis/io/encodings/iana/iana.factor
View File

@ -59,4 +59,4 @@ PRIVATE>
PRIVATE>
"resource:basis/io/encodings/iana/character-sets"
ascii <file-reader> make-n>e \ n>e-table set-value
ascii <file-reader> make-n>e to: n>e-table

8
basis/io/servers/connection/connection.factor
View File

@ -78,6 +78,8 @@ M: threaded-server handle-client* handler>> call ;
[ timeout>> timeouts ] [ handle-client* ] bi
] with-stream ;
\ handle-client ERROR add-error-logging
: thread-name ( server-name addrspec -- string )
unparse-short " connection from " swap 3append ;
@ -119,9 +121,9 @@ PRIVATE>
dup secure-config>> [
dup threaded-server [
dup name>> [
listen-on [
start-accept-loop
] parallel-each
[ listen-on [ start-accept-loop ] parallel-each ]
[ ready>> raise-flag ]
bi
] with-logging
] with-variable
] with-secure-context ;

2
basis/io/unix/sockets/secure/secure.factor
View File

@ -27,8 +27,10 @@ M: ssl-handle handle-fd file>> handle-fd ;
{
{ SSL_ERROR_NONE [ 2drop f ] }
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
{ SSL_ERROR_WANT_ACCEPT [ 2drop +input+ ] }
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
{ SSL_ERROR_SYSCALL [ syscall-error ] }
{ SSL_ERROR_ZERO_RETURN [ (ssl-error) ] }
{ SSL_ERROR_SSL [ (ssl-error) ] }
} case ;

4
basis/locals/locals-docs.factor
View File

@ -31,7 +31,7 @@ HELP: [let
} ;
HELP: [let*
{ $syntax "[let* | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" }
{ $syntax "[let* | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" }
{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated sequentially, and may refer to previous bindings from the same " { $link POSTPONE: [let* } " form; for Lisp programmers, this means that " { $link POSTPONE: [let* } " is equivalent to the Lisp " { $snippet "let*" } ", not " { $snippet "let" } "." }
{ $examples
{ $example
@ -85,7 +85,7 @@ HELP: MEMO::
{ POSTPONE: MEMO: POSTPONE: MEMO:: } related-words
ARTICLE: "locals-mutable" "Mutable locals"
"In the list of bindings supplied to " { $link POSTPONE: :: } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [| } ", a mutable binding may be introduced by suffixing its named with " { $snippet "!" } ". Mutable bindings are read by giving their name as usual; the suffix is not part of the binding's name. To write to a mutable binding, use the binding's with the " { $snippet "!" } " suffix."
"In the list of bindings supplied to " { $link POSTPONE: :: } ", " { $link POSTPONE: [let } ", " { $link POSTPONE: [let* } " or " { $link POSTPONE: [| } ", a mutable binding may be introduced by suffixing its named with " { $snippet "!" } ". Mutable bindings are read by giving their name as usual; the suffix is not part of the binding's name. To write to a mutable binding, use the binding's with the " { $snippet "!" } " suffix."
$nl
"Here is a example word which outputs a pair of quotations which increment and decrement an internal counter, and then return the new value. The quotations are closed over the counter and each invocation of the word yields new quotations with their unique internal counter:"
{ $code

13
basis/locals/locals-tests.factor
View File

@ -1,7 +1,7 @@
USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit
combinators.short-circuit.smart ;
combinators.short-circuit.smart math.order ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
@ -331,4 +331,13 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
[ T{ slice f 0 3 "abc" } ]
[ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test
{ 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
{ 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
:: compare-case ( obj1 obj2 lt-quot eq-quot gt-quot -- )
obj1 obj2 <=> {
{ +lt+ [ lt-quot call ] }
{ +eq+ [ eq-quot call ] }
{ +gt+ [ gt-quot call ] }
} case ; inline
[ [ ] [ ] [ ] compare-case ] must-infer

4
basis/macros/expander/expander-tests.factor
View File

@ -1,9 +1,11 @@
IN: macros.expander.tests
USING: macros.expander tools.test math combinators.short-circuit
kernel ;
kernel combinators ;
[ t ] [ 20 [ { [ integer? ] [ even? ] [ 10 > ] } 1&& ] expand-macros call ] unit-test
[ f ] [ 15 [ { [ integer? ] [ even? ] [ 10 > ] } 1&& ] expand-macros call ] unit-test
[ f ] [ 5.0 [ { [ integer? ] [ even? ] [ 10 > ] } 1&& ] expand-macros call ] unit-test
[ [ no-case ] ] [ [ { } case ] expand-macros ] unit-test

4
basis/macros/expander/expander.factor
View File

@ -33,8 +33,8 @@ M: wrapper expand-macros* wrapped>> literal ;
stack get pop >quotation end (expand-macros) ;
: expand-macro? ( word -- quot ? )
dup [ "macro" word-prop ] [ "transform-quot" word-prop ] bi or dup [
swap [ stack-effect in>> length ] [ "transform-n" word-prop ] bi or
dup [ "transform-quot" word-prop ] [ "macro" word-prop ] bi or dup [
swap [ "transform-n" word-prop ] [ stack-effect in>> length ] bi or
stack get length <=
] [ 2drop f f ] if ;

8
basis/math/ranges/ranges-docs.factor
View File

@ -4,7 +4,7 @@ IN: math.ranges
ARTICLE: "ranges" "Ranges"
"A " { $emphasis "range" } " is a virtual sequence with real number elements "
"ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "."
"ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } ". Ascending as well as descending ranges are supported."
$nl
"The class of ranges:"
{ $subsection range }
@ -19,9 +19,9 @@ $nl
"Creating general ranges:"
{ $subsection <range> }
"Ranges are most frequently used with sequence combinators as a means of iterating over integers. For example,"
{ $code
"3 10 [a,b] [ sqrt ] map"
}
{ $code "3 10 [a,b] [ sqrt ] map" }
"Computing the factorial of 100 with a descending range:"
{ $code "100 1 [a,b] product" }
"A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link change-each } "." ;
ABOUT: "ranges"

4
basis/models/range/range-tests.factor
View File

@ -31,6 +31,6 @@ tools.test models.range ;
! should be able to move by a page of 10
[ 10 ] [
setup-range 10 over set-range-page-value
1 over move-by-page range-value
setup-range 10 over set-range-page-value
1 over move-by-page range-value
] unit-test

5
basis/multiline/multiline-tests.factor
View File

@ -10,4 +10,7 @@ bar
[ "foo\nbar\n" ] [ test-it ] unit-test
[ "foo\nbar\n" ] [ <" foo
bar
"> ] unit-test
"> ] unit-test
[ "hello\nworld" ] [ <" hello
world"> ] unit-test

2
basis/multiline/multiline.factor
View File

@ -38,7 +38,7 @@ PRIVATE>
: parse-multiline-string ( end-text -- str )
[
lexer get [ swap (parse-multiline-string) ] change-column drop
] "" make rest-slice but-last ;
] "" make rest ;
: <"
"\">" parse-multiline-string parsed ; parsing

13
basis/present/present-docs.factor Normal file
View File

@ -0,0 +1,13 @@
IN: present
USING: help.markup help.syntax kernel strings ;
ARTICLE: "present" "Converting objects to human-readable strings"
"A word for converting an object into a human-readable string:"
{ $subsection present } ;
HELP: present
{ $values { "object" object } { "string" string } }
{ $contract "Outputs a human-readable string from an object." }
{ $notes "New methods can be defined by user code. Most often, this is done so that the object can be used with various words in the " { $link "html.components" } " or " { $link "urls" } " vocabularies." } ;
ABOUT: "present"

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