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

db4
John Benediktsson 2008-09-25 11:31:50 -07:00
commit 901288a835
36 changed files with 919 additions and 211 deletions

View File

@ -62,3 +62,15 @@ IN: calendar.format.tests
T{ duration f 0 0 0 -5 0 0 } T{ duration f 0 0 0 -5 0 0 }
} }
] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test ] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test
[
T{ timestamp
{ year 2008 }
{ month 10 }
{ day 2 }
{ hour 23 }
{ minute 59 }
{ second 59 }
{ gmt-offset T{ duration f 0 0 0 0 0 0 } }
}
] [ "Thursday, 02-Oct-2008 23:59:59 GMT" cookie-string>timestamp ] unit-test

View File

@ -201,9 +201,13 @@ ERROR: invalid-timestamp-format ;
: rfc822>timestamp ( str -- timestamp ) : rfc822>timestamp ( str -- timestamp )
[ (rfc822>timestamp) ] with-string-reader ; [ (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 ) : (cookie-string>timestamp-1) ( -- timestamp )
timestamp new timestamp new
"," read-token day-abbreviations3 member? check-timestamp drop "," read-token check-day-name
read1 CHAR: \s assert= read1 CHAR: \s assert=
"-" read-token checked-number >>day "-" read-token checked-number >>day
"-" read-token month-abbreviations index 1+ check-timestamp >>month "-" read-token month-abbreviations index 1+ check-timestamp >>month
@ -218,7 +222,7 @@ ERROR: invalid-timestamp-format ;
: (cookie-string>timestamp-2) ( -- timestamp ) : (cookie-string>timestamp-2) ( -- timestamp )
timestamp new 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 month-abbreviations index 1+ check-timestamp >>month
read-sp checked-number >>day read-sp checked-number >>day
":" read-token checked-number >>hour ":" read-token checked-number >>hour

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: classes kernel help.markup help.syntax sequences USING: classes kernel help.markup help.syntax sequences
alien assocs strings math multiline ; alien assocs strings math multiline quotations ;
IN: db IN: db
HELP: db HELP: db
@ -45,7 +45,22 @@ HELP: prepared-statement
{ $description } ; { $description } ;
HELP: result-set 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 HELP: new-statement
{ $values { "sql" string } { "in" sequence } { "out" sequence } { "class" class } { "statement" statement } } { $values { "sql" string } { "in" sequence } { "out" sequence } { "class" class } { "statement" statement } }
@ -81,7 +96,7 @@ HELP: query-results
{ $values { "query" object } { $values { "query" object }
{ "result-set" result-set } { "result-set" result-set }
} }
{ $description "" } ; { $description "Returns a " { $link result-set } " object representing the reults of a SQL query." } ;
HELP: #rows HELP: #rows
{ $values { "result-set" result-set } { "n" integer } } { $values { "result-set" result-set } { "n" integer } }
@ -95,36 +110,126 @@ HELP: row-column
{ $values { "result-set" result-set } { "column" integer } { $values { "result-set" result-set } { "column" integer }
{ "obj" object } { "obj" object }
} }
{ $description "" } ; { $description "Returns the value indexed by " { $snippet "column" } " in the current row of a " { $link result-set } "." } ;
HELP: row-column-typed HELP: row-column-typed
{ $values { "result-set" result-set } { "column" integer } { $values { "result-set" result-set } { "column" integer }
{ "sql" "sql" } } { "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 HELP: advance-row
{ $values { "result-set" result-set } } { $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? HELP: more-rows?
{ $values { "result-set" result-set } { "?" "a boolean" } } { $values { "result-set" result-set } { "?" "a boolean" } }
; { $description "Returns true if the " { $link result-set } " has more rows to traverse." } ;
HELP: execute-statement* HELP: execute-statement*
{ $values { "statement" statement } { "type" object } } { $values { "statement" statement } { "type" object } }
{ $description } ; { $description } ;
HELP: execute-one-statement
{ $values
{ "statement" null } }
{ $description "" } ;
HELP: execute-statement HELP: execute-statement
{ $values { "statement" 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-custom-database-combinators" }
{ $subsection "db-protocol" } { $subsection "db-protocol" }
{ $subsection "db-result-sets" }
{ $subsection "db-lowlevel-tutorial" } { $subsection "db-lowlevel-tutorial" }
"Higher-level database:" "Higher-level database:"
{ $vocab-subsection "Database types" "db.types" } { $vocab-subsection "Database types" "db.types" }
{ $vocab-subsection "High-level tuple/database integration" "db.tuples" } { $vocab-subsection "High-level tuple/database integration" "db.tuples" }
! { $subsection "db-tuples" }
! { $subsection "db-tuples-protocol" }
! { $subsection "db-tuples-tutorial" }
"Supported database backends:" "Supported database backends:"
{ $vocab-subsection "SQLite" "db.sqlite" } { $vocab-subsection "SQLite" "db.sqlite" }
{ $vocab-subsection "PostgreSQL" "db.postgresql" } { $vocab-subsection "PostgreSQL" "db.postgresql" }
@ -132,6 +237,40 @@ ARTICLE: "db" "Low-level database library"
{ $subsection "db-porting-the-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" 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." "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." "This section is not yet written."
; ;
ARTICLE: "db-custom-database-combinators" "Custom database combinators" 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 "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 ; { "my-database.db" temp-file } sqlite-db rot with-db ;
"> } "> }
; ;
ABOUT: "db" ABOUT: "db"

View File

@ -80,11 +80,14 @@ GENERIC: execute-statement* ( statement type -- )
M: object execute-statement* ( statement type -- ) M: object execute-statement* ( statement type -- )
drop query-results dispose ; drop query-results dispose ;
: execute-one-statement ( statement -- )
dup type>> execute-statement* ;
: execute-statement ( statement -- ) : execute-statement ( statement -- )
dup sequence? [ dup sequence? [
[ execute-statement ] each [ execute-one-statement ] each
] [ ] [
dup type>> execute-statement* execute-one-statement
] if ; ] if ;
: bind-statement ( obj statement -- ) : bind-statement ( obj statement -- )

View File

@ -5,7 +5,7 @@ kernel math math.parser namespaces make prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges db.tuples db.types tools.annotations math.ranges
combinators classes locals words tools.walker combinators classes locals words tools.walker
nmake accessors random db.queries destructors ; nmake accessors random db.queries destructors db.tuples.private ;
USE: tools.walker USE: tools.walker
IN: db.postgresql IN: db.postgresql

View File

@ -3,7 +3,7 @@
USING: accessors kernel math namespaces make sequences random USING: accessors kernel math namespaces make sequences random
strings math.parser math.intervals combinators math.bitwise strings math.parser math.intervals combinators math.bitwise
nmake db db.tuples db.types db.sql classes words shuffle arrays nmake db db.tuples db.types db.sql classes words shuffle arrays
destructors continuations ; destructors continuations db.tuples.private ;
IN: db.queries IN: db.queries
GENERIC: where ( specs obj -- ) GENERIC: where ( specs obj -- )
@ -177,7 +177,8 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
[ offset>> [ do-offset ] [ drop ] if* ] [ offset>> [ do-offset ] [ drop ] if* ]
} 2cleave ; } 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-by-slots-statement> ] dip make-query* ;
! select ID, NAME, SCORE from EXAM limit 1 offset 3 ! select ID, NAME, SCORE from EXAM limit 1 offset 3
@ -194,9 +195,8 @@ M: db make-query ( tuple class query -- tuple )
>r >r parse-sql 4drop r> r> >r >r parse-sql 4drop r> r>
<simple-statement> maybe-make-retryable do-select ; <simple-statement> maybe-make-retryable do-select ;
M: db <count-statement> ( tuple class groups -- statement ) M: db <count-statement> ( query -- statement )
\ query new [ tuple>> dup class ] keep
swap >>group
[ [ "select count(*) from " 0% 0% where-clause ] query-make ] [ [ "select count(*) from " 0% 0% where-clause ] query-make ]
dip make-query* ; dip make-query* ;

View File

@ -5,7 +5,7 @@ io.files kernel math math.parser namespaces prettyprint
sequences strings classes.tuple alien.c-types continuations sequences strings classes.tuple alien.c-types continuations
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
math.intervals io nmake accessors vectors math.ranges random 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 IN: db.sqlite
TUPLE: sqlite-db < db path ; TUPLE: sqlite-db < db path ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: classes help.markup help.syntax io.streams.string kernel 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 IN: db.tuples
HELP: define-persistent HELP: define-persistent
@ -11,7 +11,18 @@ HELP: define-persistent
{ $list { $list
{ "a slot name from the " { $snippet "tuple class" } } { "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" } ")" } { "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 HELP: create-table
{ $values { $values
@ -64,36 +75,35 @@ HELP: delete-tuples
HELP: select-tuple HELP: select-tuple
{ $values { $values
{ "tuple" tuple } { "query/tuple" tuple }
{ "tuple/f" "a tuple or f" } } { "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." } ; { $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 HELP: select-tuples
{ $values { $values
{ "tuple" tuple } { "query/tuple" tuple }
{ "tuples" "an array of tuples" } } { "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." } ; { $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 HELP: count-tuples
{ $values { $values
{ "tuple" tuple } { "groups" "an array of slots to group by" } { "query/tuple" tuple }
{ "n" integer } } { "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" ARTICLE: "db-tuples" "High-level tuple/database integration"
"Start with a tutorial:" "Start with a tutorial:"
{ $subsection "db-tuples-tutorial" } { $subsection "db-tuples-tutorial" }
"Database types supported:"
{ $subsection "db.types" }
"Useful words:" "Useful words:"
{ $subsection "db-tuples-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" ARTICLE: "db-tuples-words" "High-level tuple/database words"
@ -115,12 +125,9 @@ ARTICLE: "db-tuples-words" "High-level tuple/database words"
"Querying tuples:" "Querying tuples:"
{ $subsection select-tuple } { $subsection select-tuple }
{ $subsection select-tuples } { $subsection select-tuples }
{ $subsection count-tuples } { $subsection count-tuples } ;
"Advanced querying of tuples:"
{ $subsection query } ;
ARTICLE: "db-tuples-protocol" "Tuple database protocol"
ARTICLE: "db-tuples-protocol" "High-level tuple/database protocol"
; ;
ARTICLE: "db-tuples-tutorial" "Tuple database tutorial" ARTICLE: "db-tuples-tutorial" "Tuple database tutorial"

View File

@ -4,7 +4,7 @@ USING: io.files kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals prettyprint calendar sequences db.sqlite math.intervals
db.postgresql accessors random math.bitwise db.postgresql accessors random math.bitwise
math.ranges strings urls fry ; math.ranges strings urls fry db.tuples.private ;
IN: db.tuples.tests IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real TUPLE: person the-id the-name the-number the-real
@ -357,7 +357,7 @@ TUPLE: exam id name score ;
T{ exam } select-tuples T{ exam } select-tuples
] unit-test ] unit-test
[ 4 ] [ T{ exam } f count-tuples ] unit-test ; [ 4 ] [ T{ exam } count-tuples ] unit-test ;
TUPLE: bignum-test id m n o ; TUPLE: bignum-test id m n o ;
: <bignum-test> ( m n o -- obj ) : <bignum-test> ( m n o -- obj )
@ -518,6 +518,7 @@ string-encoding-test "STRING_ENCODING_TEST" {
! [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test ! [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
! [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test ! [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
[ ] [ 10 [ random-exam insert-tuple ] times ] unit-test [ ] [ 10 [ 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
! [ ] [ T{ exam { name "Kenny" } } >query ] unit-test ! [ ] [ T{ exam { name "Kenny" } } >query ] unit-test
! [ ] [ query ] unit-test ! [ ] [ query ] unit-test
; ;

View File

@ -3,19 +3,10 @@
USING: arrays assocs classes db kernel namespaces USING: arrays assocs classes db kernel namespaces
classes.tuple words sequences slots math accessors classes.tuple words sequences slots math accessors
math.parser io prettyprint db.types continuations math.parser io prettyprint db.types continuations
destructors mirrors sets ; destructors mirrors sets db.types ;
IN: db.tuples IN: db.tuples
TUPLE: query tuple group order offset limit ; <PRIVATE
: <query> ( -- query ) \ query new ;
GENERIC: >query ( object -- query )
M: query >query ;
M: tuple >query <query> swap >>tuple ;
! returns a sequence of prepared-statements ! returns a sequence of prepared-statements
HOOK: create-sql-statement db ( class -- object ) HOOK: create-sql-statement db ( class -- object )
HOOK: drop-sql-statement db ( class -- object ) HOOK: drop-sql-statement db ( class -- object )
@ -25,27 +16,11 @@ HOOK: <insert-user-assigned-statement> db ( class -- object )
HOOK: <update-tuple-statement> db ( class -- object ) HOOK: <update-tuple-statement> db ( class -- object )
HOOK: <delete-tuples-statement> db ( tuple class -- object ) HOOK: <delete-tuples-statement> db ( tuple class -- object )
HOOK: <select-by-slots-statement> db ( tuple class -- tuple ) HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
HOOK: <count-statement> db ( tuple class groups -- statement ) HOOK: <count-statement> db ( query -- statement )
HOOK: make-query db ( tuple class query -- statement ) HOOK: query>statement db ( query -- statement )
HOOK: insert-tuple* db ( tuple 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 ; ERROR: not-persistent class ;
: db-table ( class -- object ) : db-table ( class -- object )
@ -70,9 +45,7 @@ GENERIC: eval-generator ( singleton -- object )
: resulting-tuple ( exemplar-tuple row out-params -- tuple ) : resulting-tuple ( exemplar-tuple row out-params -- tuple )
rot class new [ rot class new [
[ [ [ slot-name>> ] dip set-slot-named ] curry 2each
[ slot-name>> ] dip set-slot-named
] curry 2each
] keep ; ] keep ;
: query-tuples ( exemplar-tuple statement -- seq ) : query-tuples ( exemplar-tuple statement -- seq )
@ -93,6 +66,51 @@ GENERIC: eval-generator ( singleton -- object )
with-disposal with-disposal
] if ; inline ] if ; inline
: 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 ;
: 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-table ( class -- )
create-sql-statement [ execute-statement ] with-disposals ; create-sql-statement [ execute-statement ] with-disposals ;
@ -105,21 +123,9 @@ GENERIC: eval-generator ( singleton -- object )
] curry ignore-errors ] curry ignore-errors
] [ create-table ] bi ; ] [ create-table ] bi ;
: ensure-table ( class -- ) : ensure-table ( class -- ) [ create-table ] curry ignore-errors ;
[ create-table ] curry ignore-errors ;
: ensure-tables ( classes -- ) : ensure-tables ( classes -- ) [ ensure-table ] each ;
[ 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 ;
: insert-tuple ( tuple -- ) : insert-tuple ( tuple -- )
dup class db-columns find-primary-key db-assigned-id-spec? dup class db-columns find-primary-key db-assigned-id-spec?
@ -135,26 +141,14 @@ GENERIC: eval-generator ( singleton -- object )
[ bind-tuple ] keep execute-statement [ bind-tuple ] keep execute-statement
] with-disposal ; ] with-disposal ;
: do-select ( exemplar-tuple statement -- tuples ) : select-tuples ( query/tuple -- tuples )
[ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ; >query [ tuple>> ] [ query>statement ] bi do-select ;
: query ( tuple query -- tuples ) : select-tuple ( query/tuple -- tuple/f )
[ dup dup class ] dip make-query do-select ; >query 1 >>limit [ tuple>> ] [ query>statement ] bi 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
[ f ] [ first ] if-empty ; [ f ] [ first ] if-empty ;
: do-count ( exemplar-tuple statement -- tuples ) : count-tuples ( query/tuple -- n )
[ >query [ tuple>> ] [ <count-statement> ] bi do-count
[ bind-tuple ] [ nip default-query ] 2bi
] with-disposal ;
: count-tuples ( tuple groups -- n )
>r dup dup class r> <count-statement> do-count
dup length 1 = dup length 1 =
[ first first string>number ] [ [ first string>number ] map ] if ; [ first first string>number ] [ [ first string>number ] map ] if ;

View File

@ -1,14 +1,9 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: db.types
HELP: (lookup-type)
{ $values
{ "obj" object }
{ "string" string } }
{ $description "" } ;
HELP: +autoincrement+ HELP: +autoincrement+
{ $description "" } ; { $description "" } ;
@ -55,7 +50,7 @@ HELP: <low-level-binding>
{ $description "" } ; { $description "" } ;
HELP: BIG-INTEGER 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 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." } ; { $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." } ; { $description "Corresponds to Factor's 64bit floating-point numbers." } ;
HELP: FACTOR-BLOB HELP: FACTOR-BLOB
{ $description "" } ; { $description "A serialized Factor object." } ;
HELP: INTEGER 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 HELP: NULL
{ $description "" } ; { $description "The SQL null type." } ;
HELP: REAL HELP: REAL
{ $description "" } ; { $description "" } ;
@ -94,16 +89,18 @@ HELP: TIME
{ $description "" } ; { $description "" } ;
HELP: TIMESTAMP HELP: TIMESTAMP
{ $description "" } ; { $description "A Factor timestamp." } ;
HELP: UNSIGNED-BIG-INTEGER 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 HELP: URL
{ $description "" } ; { $description "A Factor " { $link "urls" } " object." } ;
HELP: VARCHAR HELP: VARCHAR
{ $description "" } ; { $description "The SQL varchar type. This type can take an integer as an argument." } ;
HELP: assigned-id-spec? HELP: assigned-id-spec?
{ $values { $values
@ -135,18 +132,19 @@ HELP: db-assigned-id-spec?
HELP: find-primary-key HELP: find-primary-key
{ $values { $values
{ "specs" null } { "specs" "an array of sql-specs" }
{ "obj" object } } { "obj" object } }
{ $description "" } ; { $description "Returns the row from the sql-specs array." }
{ $notes "This is a low-level word." } ;
HELP: generator-bind HELP: generator-bind
{ $description "" } ; { $description "" } ;
HELP: get-slot-named HELP: get-slot-named
{ $values { $values
{ "name" null } { "obj" object } { "name" "a slot name" } { "tuple" tuple }
{ "value" null } } { "value" "the value stored in the slot" } }
{ $description "" } ; { $description "Returns the value stored in a tuple slot, where the tuple slot is a string." } ;
HELP: join-space HELP: join-space
{ $values { $values
@ -192,23 +190,11 @@ HELP: normalize-spec
{ "spec" null } } { "spec" null } }
{ $description "" } ; { $description "" } ;
HELP: number>string*
{ $values
{ "n/string" null }
{ "string" string } }
{ $description "" } ;
HELP: offset-of-slot HELP: offset-of-slot
{ $values { $values
{ "string" string } { "obj" object } { "string" string } { "tuple" tuple }
{ "n" null } } { "n" integer } }
{ $description "" } ; { $description "Returns the offset of a tuple slot accessed by name." } ;
HELP: paren
{ $values
{ "string" string }
{ "new-string" null } }
{ $description "" } ;
HELP: persistent-table HELP: persistent-table
{ $values { $values
@ -294,7 +280,6 @@ ARTICLE: "db.types" "Database types"
{ $subsection BLOB } { $subsection BLOB }
{ $subsection FACTOR-BLOB } { $subsection FACTOR-BLOB }
"Factor URLs:" "Factor URLs:"
{ $subsection URL } { $subsection URL } ;
;
ABOUT: "db.types" ABOUT: "db.types"

View File

@ -126,11 +126,11 @@ ERROR: no-sql-type ;
HOOK: bind% db ( spec -- ) HOOK: bind% db ( spec -- )
HOOK: bind# db ( spec obj -- ) HOOK: bind# db ( spec obj -- )
: offset-of-slot ( string obj -- n ) : offset-of-slot ( string tuple -- n )
class superclasses [ "slots" word-prop ] map concat class superclasses [ "slots" word-prop ] map concat
slot-named offset>> ; slot-named offset>> ;
: get-slot-named ( name obj -- value ) : get-slot-named ( name tuple -- value )
tuck offset-of-slot slot ; tuck offset-of-slot slot ;
: set-slot-named ( value name obj -- ) : set-slot-named ( value name obj -- )

View File

@ -323,3 +323,5 @@ M: bad-effect summary
drop "Bad stack effect declaration" ; drop "Bad stack effect declaration" ;
M: bad-escape summary drop "Bad escape code" ; M: bad-escape summary drop "Bad escape code" ;
M: bad-literal-tuple summary drop "Bad literal tuple" ;

View File

@ -135,3 +135,18 @@ link-no-follow? off
[ "<hr/>" ] [ "___" convert-farkup ] unit-test [ "<hr/>" ] [ "___" convert-farkup ] unit-test
[ "<hr/>\n" ] [ "___\n" 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

View File

@ -38,7 +38,7 @@ TUPLE: line ;
EBNF: parse-farkup EBNF: parse-farkup
nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]] nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
2nl = nl nl whitespace = " " | "\t" | nl
heading1 = "=" (!("=" | nl).)+ "=" heading1 = "=" (!("=" | nl).)+ "="
=> [[ second >string heading1 boa ]] => [[ second >string heading1 boa ]]
@ -52,6 +52,10 @@ heading3 = "===" (!("=" | nl).)+ "==="
heading4 = "====" (!("=" | nl).)+ "====" heading4 = "====" (!("=" | nl).)+ "===="
=> [[ second >string heading4 boa ]] => [[ second >string heading4 boa ]]
heading = heading4 | heading3 | heading2 | heading1
strong = "*" (!("*" | nl).)+ "*" strong = "*" (!("*" | nl).)+ "*"
=> [[ second >string strong boa ]] => [[ second >string strong boa ]]
@ -67,8 +71,6 @@ subscript = "~" (!("~" | nl).)+ "~"
inline-code = "%" (!("%" | nl).)+ "%" inline-code = "%" (!("%" | nl).)+ "%"
=> [[ second >string inline-code boa ]] => [[ second >string inline-code boa ]]
escaped-char = "\" . => [[ second 1string ]]
link-content = (!("|"|"]").)+ link-content = (!("|"|"]").)+
image-link = "[[image:" link-content "|" link-content "]]" image-link = "[[image:" link-content "|" link-content "]]"
@ -84,11 +86,13 @@ labelled-link = "[[" link-content "|" link-content "]]"
link = image-link | labelled-link | simple-link link = image-link | labelled-link | simple-link
heading = heading4 | heading3 | heading2 | heading1 escaped-char = "\" . => [[ second 1string ]]
inline-tag = strong | emphasis | superscript | subscript | inline-code inline-tag = strong | emphasis | superscript | subscript | inline-code
| link | escaped-char | link | escaped-char
inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '[' inline-delimiter = '*' | '_' | '^' | '~' | '%' | '\' | '['
cell = (!(inline-delimiter | '|' | nl).)+ cell = (!(inline-delimiter | '|' | nl).)+
@ -104,12 +108,13 @@ table = ((table-row nl => [[ first ]] )+ table-row? | table-row)
text = (!(nl | code | heading | inline-delimiter | table ).)+ text = (!(nl | code | heading | inline-delimiter | table ).)+
=> [[ >string ]] => [[ >string ]]
paragraph-item = (table | list | text | inline-tag | inline-delimiter)+ paragraph-item = (table | nl list | nl line | code | text | inline-tag | inline-delimiter)+
paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]] paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]]
| (paragraph-item nl)+ paragraph-item? | (paragraph-item nl)+ paragraph-item?
| paragraph-item) | paragraph-item)
=> [[ paragraph boa ]] => [[ paragraph boa ]]
list-item = (cell | inline-tag)* list-item = (cell | inline-tag)*
ordered-list-item = '#' list-item ordered-list-item = '#' list-item
@ -124,18 +129,23 @@ unordered-list = ((unordered-list-item nl)+ unordered-list-item? | unordered-lis
list = ordered-list | unordered-list list = ordered-list | unordered-list
line = '___' line = '___'
=> [[ drop line new ]] => [[ drop line new ]]
code = '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]"
named-code = '[' (!('{' | whitespace | '[').)+ '{' (!("}]").)+ "}]"
=> [[ [ second >string ] [ fourth >string ] bi code boa ]] => [[ [ second >string ] [ fourth >string ] bi code boa ]]
simple-code simple-code
= "[{" (!("}]").)+ "}]" = "[{" (!("}]").)+ "}]"
=> [[ second f swap code boa ]] => [[ second f swap code boa ]]
code = named-code | simple-code
stand-alone stand-alone
= (line | code | simple-code | heading | list | table | paragraph | nl)* = (line | code | heading | list | table | paragraph | nl)*
;EBNF ;EBNF

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"

View File

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

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

@ -0,0 +1,161 @@
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" "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."
$nl
"HTTP requests:"
{ $subsection request }
{ $subsection <request> }
"Requests can contain form submissions:"
{ $subsection "http.post-data" }
"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> }
"Both requests and responses support some common functionality:"
{ $subsection "http.headers" }
{ $subsection "http.cookies" }
{ $see-also "urls" } ;
ABOUT: "http"

View File

@ -31,7 +31,7 @@ HELP: [let
} ; } ;
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" } "." } { $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 { $examples
{ $example { $example

View File

@ -1,7 +1,7 @@
USING: locals math sequences tools.test hashtables words kernel USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit accessors generic eval combinators combinators.short-circuit
combinators.short-circuit.smart ; combinators.short-circuit.smart math.order ;
IN: locals.tests IN: locals.tests
:: foo ( a b -- a a ) a a ; :: 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" } ] [ T{ slice f 0 3 "abc" } ]
[ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test [ 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

View File

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

View File

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

View File

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

View File

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

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"

View File

@ -1,12 +1,13 @@
IN: summary IN: summary
USING: kernel strings help.markup help.syntax ; USING: kernel strings help.markup help.syntax ;
ARTICLE: "summary" "Summary" ARTICLE: "summary" "Converting objects to summary strings"
"A word for getting very brief descriptions of words and general objects:" "A word for getting very brief descriptions of words and general objects:"
{ $subsection summary } ; { $subsection summary } ;
HELP: summary HELP: summary
{ $values { "object" object } { "string" string } } { $values { "object" object } { "string" string } }
{ $contract "Outputs a brief description of the object." } ; { $contract "Outputs a brief description of the object." }
{ $notes "New methods can be defined by user code. Most often, this is used with error classes so that " { $link "debugger" } " can print friendlier error messages." } ;
ABOUT: "summary" ABOUT: "summary"

View File

@ -4,7 +4,7 @@ USING: assocs io.files hashtables kernel namespaces sequences
vocabs.loader io combinators io.encodings.utf8 calendar accessors vocabs.loader io combinators io.encodings.utf8 calendar accessors
math.parser io.streams.string ui.tools.operations quotations math.parser io.streams.string ui.tools.operations quotations
strings arrays prettyprint words vocabs sorting sets strings arrays prettyprint words vocabs sorting sets
classes math alien ; classes math alien urls splitting ascii ;
IN: tools.scaffold IN: tools.scaffold
SYMBOL: developer-name SYMBOL: developer-name
@ -89,17 +89,12 @@ ERROR: no-vocab vocab ;
] if ; ] if ;
: lookup-type ( string -- object/string ? ) : lookup-type ( string -- object/string ? )
"new" ?head drop [ [ CHAR: ' = ] [ digit? ] bi or ] trim-right
H{ H{
{ "object" object } { "obj" object } { "object" object } { "obj" object }
{ "obj1" object } { "obj2" object } { "quot" quotation }
{ "obj3" object } { "obj4" object } { "string" string }
{ "quot" quotation } { "quot1" quotation }
{ "quot2" quotation } { "quot3" quotation }
{ "quot'" quotation }
{ "string" string } { "string1" string }
{ "string2" string } { "string3" string }
{ "str" string } { "str" string }
{ "str1" string } { "str2" string } { "str3" string }
{ "hash" hashtable } { "hash" hashtable }
{ "hashtable" hashtable } { "hashtable" hashtable }
{ "?" "a boolean" } { "?" "a boolean" }
@ -111,16 +106,12 @@ ERROR: no-vocab vocab ;
{ "vocab" "a vocabulary specifier" } { "vocab" "a vocabulary specifier" }
{ "vocab-root" "a vocabulary root string" } { "vocab-root" "a vocabulary root string" }
{ "c-ptr" c-ptr } { "c-ptr" c-ptr }
{ "seq" sequence } { "seq1" sequence } { "seq2" sequence } { "seq" sequence }
{ "seq3" sequence } { "seq4" sequence } { "assoc" assoc }
{ "seq1'" sequence } { "seq2'" sequence }
{ "newseq" sequence }
{ "seq'" sequence }
{ "assoc" assoc } { "assoc1" assoc } { "assoc2" assoc }
{ "assoc3" assoc } { "newassoc" assoc }
{ "alist" "an array of key/value pairs" } { "alist" "an array of key/value pairs" }
{ "keys" sequence } { "values" sequence } { "keys" sequence } { "values" sequence }
{ "class" class } { "tuple" tuple } { "class" class } { "tuple" tuple }
{ "url" url }
} at* ; } at* ;
: add-using ( object -- ) : add-using ( object -- )
@ -158,7 +149,7 @@ ERROR: no-vocab vocab ;
"{ $description \"\" } ;" print ; "{ $description \"\" } ;" print ;
: help-header. ( word -- ) : help-header. ( word -- )
"HELP: " write . ; "HELP: " write name>> print ;
: (help.) ( word -- ) : (help.) ( word -- )
[ help-header. ] [ $values. ] [ $description. ] tri ; [ help-header. ] [ $values. ] [ $description. ] tri ;
@ -171,7 +162,7 @@ ERROR: no-vocab vocab ;
: interesting-words. ( vocab -- ) : interesting-words. ( vocab -- )
interesting-words [ (help.) nl ] each ; interesting-words [ (help.) nl ] each ;
: help-file-string ( str1 -- str2 ) : help-file-string ( vocab -- str2 )
[ [
{ {
[ "IN: " write print nl ] [ "IN: " write print nl ]
@ -185,16 +176,18 @@ ERROR: no-vocab vocab ;
} cleave } cleave
] with-string-writer ; ] with-string-writer ;
: write-using ( -- ) : write-using ( vocab -- )
"USING:" write "USING:" write
using get keys using get keys
{ "help.markup" "help.syntax" } append natural-sort { "help.markup" "help.syntax" } append natural-sort remove
[ bl write ] each [ bl write ] each
" ;" print ; " ;" print ;
: set-scaffold-help-file ( path vocab -- ) : set-scaffold-help-file ( path vocab -- )
swap utf8 <file-writer> [ swap utf8 <file-writer> [
scaffold-copyright help-file-string write-using write scaffold-copyright
[ help-file-string ] [ write-using ] bi
write
] with-output-stream ; ] with-output-stream ;
: check-scaffold ( vocab-root string -- vocab-root string ) : check-scaffold ( vocab-root string -- vocab-root string )

247
basis/urls/urls-docs.factor Normal file
View File

@ -0,0 +1,247 @@
USING: assocs hashtables help.markup help.syntax
io.streams.string io.files kernel strings present math multiline
;
IN: urls
HELP: url
{ $class-description "The class of URLs. The slots correspond to the standard components of a URL." } ;
HELP: <url>
{ $values { "url" url } }
{ $description "Creates an empty URL." } ;
HELP: >url
{ $values { "obj" object } { "url" url } }
{ $description "Converts an object into a URL. If the object is already a URL, does nothing; if it is a string, then it is parsed as a URL." }
{ $errors "Throws an error if the object is of the wrong type, or if it is a string which is not a valid URL." }
{ $examples
"If we convert a string to a URL and print it out again, it will print similarly to the input string, except some normalization may have occurred:"
{ $example
"USING: accessors prettyprint urls ;"
"\"http://www.apple.com\" >url ."
"URL\" http://www.apple.com/\""
}
"We can examine the URL object:"
{ $example
"USING: accessors io urls ;"
"\"http://www.apple.com\" >url host>> print"
"www.apple.com"
}
"A relative URL does not have a protocol, host or port:"
{ $example
"USING: accessors prettyprint urls ;"
"\"file.txt\" >url protocol>> ."
"f"
}
} ;
HELP: URL"
{ $syntax "URL\" url...\"" }
{ $description "URL literal syntax." }
{ $examples
{ $example
"USING: accessors prettyprint urls ;"
"URL\" http://factorcode.org:80\" port>> ."
"80"
}
} ;
HELP: assoc>query
{ $values { "assoc" assoc } { "str" string } }
{ $description "Converts an assoc of query parameters into a query string, performing URL encoding." }
{ $notes "This word is used to implement the " { $link present } " method on URLs; it is also used by the HTTP client to encode POST requests." }
{ $examples
{ $example
"USING: io urls ;"
"{ { \"from\" \"Lead\" } { \"to\" \"Gold, please\" } }"
"assoc>query print"
"from=Lead&to=Gold%2c+please"
}
} ;
HELP: query>assoc
{ $values { "query" string } { "assoc" assoc } }
{ $description "Parses a URL query string and URL-decodes each component." }
{ $notes "This word is used to implement " { $link >url } ". It is also used by the HTTP server to parse POST requests." }
{ $examples
{ $unchecked-example
"USING: prettyprint urls ;"
"\"gender=female&agefrom=22&ageto=28&location=Omaha+NE\""
"query>assoc ."
<" H{
{ "gender" "female" }
{ "agefrom" "22" }
{ "ageto" "28" }
{ "location" "Omaha NE" }
}">
}
} ;
HELP: derive-url
{ $values { "base" url } { "url" url } { "url'" url } }
{ $description "Builds a URL by filling in missing components of " { $snippet "url" } " from " { $snippet "base" } "." }
{ $examples
{ $example
"USING: prettyprint urls ;"
"URL\" http://factorcode.org\""
"URL\" binaries.fhtml\" derive-url ."
"URL\" http://factorcode.org/binaries.fhtml\""
}
{ $example
"USING: prettyprint urls ;"
"URL\" http://www.truecasey.com/drinks/kombucha\""
"URL\" master-cleanser\" derive-url ."
"URL\" http://www.truecasey.com/drinks/master-cleanser\""
}
} ;
HELP: ensure-port
{ $values { "url" url } }
{ $description "If the URL does not specify a port number, fill in the default for the URL's protocol. If the protocol is unknown, the port number is not changed." }
{ $side-effects "url" }
{ $examples
{ $example
"USING: accessors prettyprint urls ;"
"URL\" https://concatenative.org\" ensure-port port>> ."
"443"
}
} ;
HELP: parse-host
{ $values { "string" string } { "host" string } { "port" "an " { $link integer } " or " { $link f } } }
{ $description "Splits a string of the form " { $snippet "host:port" } " into a host and a port number. If the port number is not specified, outputs " { $link f } "." }
{ $notes "This word is used by " { $link >url } ". It can also be used directly to parse " { $snippet "host:port" } " strings which are not full URLs." }
{ $examples
{ $example
"USING: prettyprint urls ;"
"\"sbcl.org:80\" parse-host .s"
"\"sbcl.org\"\n80"
}
} ;
HELP: protocol-port
{ $values { "protocol" "a protocol string" } { "port" "an " { $link integer } " or " { $link f } } }
{ $description "Outputs the port number associated with a protocol, or " { $link f } " if the protocol is unknown." } ;
HELP: query-param
{ $values
{ "url" url } { "key" string }
{ "value" "a " { $link string } " or " { $link f } } }
{ $description "Outputs the URL-decoded value of a URL query parameter." }
{ $examples
{ $example
"USING: io urls ;"
"URL\" http://food.com/calories?item=French+Fries\""
"\"item\" query-param print"
"French Fries"
}
} ;
HELP: set-query-param
{ $values { "url" url } { "value" object } { "key" string } }
{ $description "Sets a query parameter. The value can be any object supported by " { $link present } ", or " { $link f } ", in which case the key is removed." }
{ $notes "This word always returns the same URL object that was input. This allows for a ``pipeline'' coding style, where several query parameters are set in a row. Since it mutates the input object, you must " { $link clone } " it first if it is literal, as in the below example."
}
{ $examples
{ $code
<" USING: kernel http.client urls ;
URL" http://search.yahooapis.com/WebSearchService/V1/webSearch" clone
"concatenative programming (NSFW)" "query" set-query-param
"1" "adult_ok" set-query-param
http-get">
}
"(For a complete Yahoo! search web service implementation, see the " { $vocab-link "yahoo" } " vocabulary.)"
}
{ $side-effects "url" } ;
HELP: relative-url
{ $values { "url" url } { "url'" url } }
{ $description "Outputs a new URL with the same path and query components as the input value, but with the protocol, host and port set to " { $link f } "." }
{ $examples
{ $example
"USING: prettyprint urls ;"
"URL\" http://factorcode.org/binaries.fhtml\""
"relative-url ."
"URL\" /binaries.fhtml\""
}
} ;
HELP: secure-protocol?
{ $values { "protocol" string } { "?" "a boolean" } }
{ $description "Tests if protocol connections must be made with secure sockets (SSL/TLS)." }
{ $examples
{ $example
"USING: prettyprint urls ;"
"\"https\" secure-protocol? ."
"t"
}
} ;
HELP: url-addr
{ $values { "url" url } { "addr" "an address specifier" } }
{ $description "Outputs an address specifier for use with " { $link "network-connection" } "." }
{ $examples
{ $example
"USING: prettyprint urls ;"
"URL\" ftp://ftp.cdrom.com\" url-addr ."
"T{ inet { host \"ftp.cdrom.com\" } { port 21 } }"
}
} ;
HELP: url-append-path
{ $values { "path1" string } { "path2" string } { "path" string } }
{ $description "Like " { $link append-path } ", but intended for use with URL paths and not filesystem paths." } ;
HELP: url-decode
{ $values { "str" string } { "decoded" string } }
{ $description "Decodes a URL-encoded string." } ;
HELP: url-encode
{ $values { "str" string } { "encoded" string } }
{ $description "URL-encodes a string." } ;
HELP: url-quotable?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests if a character be used without URL-encoding in a URL." } ;
ARTICLE: "url-encoding" "URL encoding and decoding"
"URL encoding and decoding strings:"
{ $subsection url-encode }
{ $subsection url-decode }
{ $subsection url-quotable? }
"The URL implemention encodes and decodes components of " { $link url } " instances automatically, but sometimes it is required for non-URL strings. See " { $url "http://en.wikipedia.org/wiki/Percent-encoding" } " for a description of URL encoding." ;
ARTICLE: "url-utilities" "URL implementation utilities"
{ $subsection assoc>query }
{ $subsection query>assoc }
{ $subsection parse-host }
{ $subsection secure-protocol? }
{ $subsection url-append-path } ;
ARTICLE: "urls" "URL objects"
"The " { $vocab-link "urls" } " vocabulary implements a URL data type. The benefit of using a data type to prepresent URLs rather than a string is that the parsing, printing and escaping logic is encapsulated and reused, rather than re-implemented in a potentially buggy manner every time."
$nl
"URL objects are used heavily by the " { $vocab-link "http" } " and " { $vocab-link "furnace" } " vocabularies, and are also useful on their own."
$nl
"The class of URLs, and a constructor:"
{ $subsection url }
{ $subsection <url> }
"Converting strings to URLs:"
{ $subsection >url }
"URLs can be converted back to strings using the " { $link present } " word."
$nl
"URL literal syntax:"
{ $subsection POSTPONE: URL" }
"Manipulating URLs:"
{ $subsection derive-url }
{ $subsection relative-url }
{ $subsection ensure-port }
{ $subsection query-param }
{ $subsection set-query-param }
"Creating " { $link "network-addressing" } " from URLs:"
{ $subsection url-addr }
"Additional topics:"
{ $subsection "url-utilities" }
{ $subsection "url-encoding" } ;
ABOUT: "urls"

View File

@ -2,19 +2,19 @@ IN: urls.tests
USING: urls urls.private tools.test USING: urls urls.private tools.test
arrays kernel assocs present accessors ; arrays kernel assocs present accessors ;
[ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello+world" ] [ "hello world" url-encode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test [ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
[ f ] [ "%XX%XX%XX" url-decode ] unit-test [ f ] [ "%XX%XX%XX" url-decode ] unit-test
[ f ] [ "%XX%XX%X" url-decode ] unit-test [ f ] [ "%XX%XX%X" url-decode ] unit-test
[ "hello world" ] [ "hello+world" url-decode ] unit-test [ "hello world" ] [ "hello+world" url-decode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test [ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ " ! " ] [ "%20%21%20" url-decode ] unit-test [ " ! " ] [ "%20%21%20" url-decode ] unit-test
[ "hello world" ] [ "hello world%" url-decode ] unit-test [ "hello world" ] [ "hello world%" url-decode ] unit-test
[ "hello world" ] [ "hello world%x" url-decode ] unit-test [ "hello world" ] [ "hello world%x" url-decode ] unit-test
[ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello+world" ] [ "hello world" url-encode ] unit-test
[ "%20%21%20" ] [ " ! " url-encode ] unit-test [ "+%21+" ] [ " ! " url-encode ] unit-test
[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test [ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test

View File

@ -8,8 +8,6 @@ strings.parser lexer prettyprint.backend hashtables present ;
IN: urls IN: urls
: url-quotable? ( ch -- ? ) : url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
#! URL-encoding?
{ {
[ letter? ] [ letter? ]
[ LETTER? ] [ LETTER? ]
@ -20,8 +18,10 @@ IN: urls
<PRIVATE <PRIVATE
: push-utf8 ( ch -- ) : push-utf8 ( ch -- )
1string utf8 encode dup CHAR: \s = [ drop "+" % ] [
[ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; 1string utf8 encode
[ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each
] if ;
PRIVATE> PRIVATE>
@ -86,7 +86,7 @@ PRIVATE>
] keep ] keep
] when ; ] when ;
: assoc>query ( hash -- str ) : assoc>query ( assoc -- str )
[ [
dup array? [ [ present ] map ] [ present 1array ] if dup array? [ [ present ] map ] [ present 1array ] if
] assoc-map ] assoc-map
@ -104,8 +104,15 @@ TUPLE: url protocol username password host port path query anchor ;
: query-param ( url key -- value ) : query-param ( url key -- value )
swap query>> at ; swap query>> at ;
: delete-query-param ( url key -- url )
over query>> delete-at ;
: set-query-param ( url value key -- url ) : set-query-param ( url value key -- url )
'[ [ _ _ ] dip ?set-at ] change-query ; over [
'[ [ _ _ ] dip ?set-at ] change-query
] [
nip delete-query-param
] if ;
: parse-host ( string -- host port ) : parse-host ( string -- host port )
":" split1 [ url-decode ] [ ":" split1 [ url-decode ] [
@ -152,7 +159,6 @@ M: string >url
{ {
{ "http" [ 80 ] } { "http" [ 80 ] }
{ "https" [ 443 ] } { "https" [ 443 ] }
{ "feed" [ 80 ] }
{ "ftp" [ 21 ] } { "ftp" [ 21 ] }
[ drop f ] [ drop f ]
} case ; } case ;
@ -168,8 +174,6 @@ M: string >url
[ port>> ] [ port>> ] [ protocol>> protocol-port ] tri = [ port>> ] [ port>> ] [ protocol>> protocol-port ] tri =
[ drop f ] when ; [ drop f ] when ;
PRIVATE>
: unparse-host-part ( url protocol -- ) : unparse-host-part ( url protocol -- )
% %
"://" % "://" %
@ -180,6 +184,8 @@ PRIVATE>
[ path>> "/" head? [ "/" % ] unless ] [ path>> "/" head? [ "/" % ] unless ]
} cleave ; } cleave ;
PRIVATE>
M: url present M: url present
[ [
{ {
@ -224,10 +230,15 @@ PRIVATE>
"https" = ; "https" = ;
: url-addr ( url -- addr ) : url-addr ( url -- addr )
[ [ host>> ] [ port>> ] bi <inet> ] [ protocol>> ] bi [
[ host>> ]
[ port>> ]
[ protocol>> protocol-port ]
tri or <inet>
] [ protocol>> ] bi
secure-protocol? [ <secure> ] when ; secure-protocol? [ <secure> ] when ;
: ensure-port ( url -- url' ) : ensure-port ( url -- url )
dup protocol>> '[ _ protocol-port or ] change-port ; dup protocol>> '[ _ protocol-port or ] change-port ;
! Literal syntax ! Literal syntax

View File

@ -63,11 +63,14 @@ ERROR: invalid-slot-name name ;
: parse-slot-value ( -- ) : parse-slot-value ( -- )
scan scan-object 2array , scan "}" assert= ; scan scan-object 2array , scan "}" assert= ;
ERROR: bad-literal-tuple ;
: (parse-slot-values) ( -- ) : (parse-slot-values) ( -- )
parse-slot-value parse-slot-value
scan { scan {
{ "{" [ (parse-slot-values) ] } { "{" [ (parse-slot-values) ] }
{ "}" [ ] } { "}" [ ] }
[ bad-literal-tuple ]
} case ; } case ;
: parse-slot-values ( -- ) : parse-slot-values ( -- )
@ -86,4 +89,5 @@ ERROR: invalid-slot-name name ;
{ "f" [ \ } parse-until boa>tuple ] } { "f" [ \ } parse-until boa>tuple ] }
{ "{" [ parse-slot-values assoc>tuple ] } { "{" [ parse-slot-values assoc>tuple ] }
{ "}" [ new ] } { "}" [ new ] }
[ bad-literal-tuple ]
} case ; } case ;

View File

@ -519,7 +519,7 @@ HELP: UNION:
HELP: INTERSECTION: HELP: INTERSECTION:
{ $syntax "INTERSECTION: class participants... ;" } { $syntax "INTERSECTION: class participants... ;" }
{ $values { "class" "a new class word to define" } { "participants" "a list of class words separated by whitespace" } } { $values { "class" "a new class word to define" } { "participants" "a list of class words separated by whitespace" } }
{ $description "Defines an intersection class. An object is an instance of a union class if it is an instance of all of its participants." } ; { $description "Defines an intersection class. An object is an instance of an intersection class if it is an instance of all of its participants." } ;
HELP: MIXIN: HELP: MIXIN:
{ $syntax "MIXIN: class" } { $syntax "MIXIN: class" }

View File

@ -40,8 +40,7 @@ function foldl(f, initial, seq) {
for(var i=0; i< seq.length; ++i) for(var i=0; i< seq.length; ++i)
initial = f(initial, seq[i]); initial = f(initial, seq[i]);
return initial; return initial;
} }"> main \ javascript rule (parse) remaining>> length zero?
"> main \ javascript rule (parse) remaining>> length zero?
] unit-test ] unit-test
{ t } [ { t } [
@ -51,7 +50,6 @@ ParseState.prototype.from = function(index) {
r.cache = this.cache; r.cache = this.cache;
r.length = this.length - index; r.length = this.length - index;
return r; return r;
} }"> main \ javascript rule (parse) remaining>> length zero?
"> main \ javascript rule (parse) remaining>> length zero?
] unit-test ] unit-test

View File

@ -57,8 +57,7 @@ BEGIN
CALL square; CALL square;
x := x + 1; x := x + 1;
END END
END. END."> main \ pl0 rule (parse) remaining>> empty?
"> main \ pl0 rule (parse) remaining>> empty?
] unit-test ] unit-test
{ f } [ { f } [

View File

@ -90,7 +90,7 @@ M: comment entity-url
: list-posts ( -- posts ) : list-posts ( -- posts )
f <post> "author" value >>author f <post> "author" value >>author
select-tuples [ dup id>> f <comment> f count-tuples >>comments ] map select-tuples [ dup id>> f <comment> count-tuples >>comments ] map
reverse-chronological-order ; reverse-chronological-order ;
: <list-posts-action> ( -- action ) : <list-posts-action> ( -- action )

View File

@ -28,6 +28,10 @@ Ordered lists:
# with three # with three
# numbered items # numbered items
Horizontal lines:
___
Tables: Tables:
|a table|with|four|columns| |a table|with|four|columns|