diff --git a/basis/calendar/format/format-tests.factor b/basis/calendar/format/format-tests.factor index c433a118c2..81930cdf49 100755 --- a/basis/calendar/format/format-tests.factor +++ b/basis/calendar/format/format-tests.factor @@ -62,3 +62,15 @@ IN: calendar.format.tests T{ duration f 0 0 0 -5 0 0 } } ] [ "2008-05-26T00:37:42.12345-05:00" rfc3339>timestamp ] unit-test + +[ + T{ timestamp + { year 2008 } + { month 10 } + { day 2 } + { hour 23 } + { minute 59 } + { second 59 } + { gmt-offset T{ duration f 0 0 0 0 0 0 } } + } +] [ "Thursday, 02-Oct-2008 23:59:59 GMT" cookie-string>timestamp ] unit-test diff --git a/basis/calendar/format/format.factor b/basis/calendar/format/format.factor index bfe438fae1..b15da42409 100755 --- a/basis/calendar/format/format.factor +++ b/basis/calendar/format/format.factor @@ -201,9 +201,13 @@ ERROR: invalid-timestamp-format ; : rfc822>timestamp ( str -- timestamp ) [ (rfc822>timestamp) ] with-string-reader ; +: check-day-name ( str -- ) + [ day-abbreviations3 member? ] [ day-names member? ] bi or + check-timestamp drop ; + : (cookie-string>timestamp-1) ( -- timestamp ) timestamp new - "," read-token day-abbreviations3 member? check-timestamp drop + "," read-token check-day-name read1 CHAR: \s assert= "-" read-token checked-number >>day "-" read-token month-abbreviations index 1+ check-timestamp >>month @@ -218,7 +222,7 @@ ERROR: invalid-timestamp-format ; : (cookie-string>timestamp-2) ( -- timestamp ) timestamp new - read-sp day-abbreviations3 member? check-timestamp drop + read-sp check-day-name read-sp month-abbreviations index 1+ check-timestamp >>month read-sp checked-number >>day ":" read-token checked-number >>hour diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor index f8e3956b3e..74b72b8789 100644 --- a/basis/db/db-docs.factor +++ b/basis/db/db-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: classes kernel help.markup help.syntax sequences -alien assocs strings math multiline ; +alien assocs strings math multiline quotations ; IN: db HELP: db @@ -45,7 +45,22 @@ HELP: prepared-statement { $description } ; HELP: result-set -{ $description } ; +{ $description "An object encapsulating a raw SQL result object. There are two ways in which a result set can be accessed, but they are specific to the database backend in use." + { $subsection "db-random-access-result-set" } + { $subsection "db-sequential-result-set" } +} ; + +HELP: init-result-set +{ $values + { "result-set" result-set } } +{ $description "" } ; + +HELP: new-result-set +{ $values + { "query" "a query" } { "handle" alien } { "class" class } + { "result-set" result-set } } +{ $description "Creates a new " { $link result-set } " object of type " { $snippet "class" } "." } ; + HELP: new-statement { $values { "sql" string } { "in" sequence } { "out" sequence } { "class" class } { "statement" statement } } @@ -81,7 +96,7 @@ HELP: query-results { $values { "query" object } { "result-set" result-set } } -{ $description "" } ; +{ $description "Returns a " { $link result-set } " object representing the reults of a SQL query." } ; HELP: #rows { $values { "result-set" result-set } { "n" integer } } @@ -95,36 +110,126 @@ HELP: row-column { $values { "result-set" result-set } { "column" integer } { "obj" object } } -{ $description "" } ; +{ $description "Returns the value indexed by " { $snippet "column" } " in the current row of a " { $link result-set } "." } ; HELP: row-column-typed { $values { "result-set" result-set } { "column" integer } { "sql" "sql" } } -{ $description "" } ; +{ $description "Returns the value indexed by " { $snippet "column" } " in the current row of a " { $link result-set } " and converts the result based on a type stored in the " { $link result-set } "'s " { $slot "out-params" } "." } ; HELP: advance-row { $values { "result-set" result-set } } -; +{ $description "Advanced the pointer to an underlying SQL result set stored in a " { $link result-set } " object." } ; HELP: more-rows? { $values { "result-set" result-set } { "?" "a boolean" } } -; +{ $description "Returns true if the " { $link result-set } " has more rows to traverse." } ; HELP: execute-statement* { $values { "statement" statement } { "type" object } } { $description } ; +HELP: execute-one-statement +{ $values + { "statement" null } } +{ $description "" } ; + HELP: execute-statement { $values { "statement" statement } } -{ $description } ; +{ $description "" } ; -ARTICLE: "db" "Low-level database library" + + + + + +HELP: begin-transaction +{ $description "Begins a new transaction. User code should make use of the " { $link with-transaction } " combinator." } ; + +HELP: bind-statement +{ $values + { "obj" object } { "statement" null } } +{ $description "" } ; + +HELP: commit-transaction +{ $description "Commits a transaction. User code should make use of the " { $link with-transaction } " combinator." } ; + +HELP: default-query +{ $values + { "query" null } + { "result-set" null } } +{ $description "" } ; + +HELP: in-transaction +{ $description "A variable that is set true when a transaction is in progress." } ; + +HELP: in-transaction? +{ $values + { "?" "a boolean" } } +{ $description "Returns true if there is currently a transaction in progress in this scope." } ; + +HELP: query-each +{ $values + { "statement" null } { "quot" quotation } } +{ $description "" } ; + +HELP: query-map +{ $values + { "statement" null } { "quot" quotation } + { "seq" sequence } } +{ $description "" } ; + +HELP: rollback-transaction +{ $description "Rolls back a transaction; no data is committed to the database. User code should make use of the " { $link with-transaction } " combinator." } ; + +HELP: sql-command +{ $values + { "sql" string } } +{ $description "Executes a SQL string using the databse in the " { $link db } " symbol." } ; + +HELP: sql-query +{ $values + { "sql" string } + { "rows" "an array of arrays of strings" } } +{ $description "Runs a SQL query of raw text in the database in the " { $link db } " symbol. Each row is returned as an array of strings; no type-conversions are done on the resulting data." } ; + +{ sql-command sql-query } related-words + +HELP: sql-row +{ $values + { "result-set" result-set } + { "seq" sequence } } +{ $description "Returns the current row in a " { $link result-set } " as an array of strings." } ; + +HELP: sql-row-typed +{ $values + { "result-set" result-set } + { "seq" sequence } } +{ $description "Returns the current row in a " { $link result-set } " as an array of typed Factor objects." } ; + +{ sql-row sql-row-typed } related-words + +HELP: with-db +{ $values + { "seq" sequence } { "class" class } { "quot" quotation } } +{ $description "Calls the quotation with a database bound to the " { $link db } " symbol. The database called is based on the " { $snippet "class" } " with the " } ; + +HELP: with-transaction +{ $values + { "quot" quotation } } +{ $description "" } ; + +ARTICLE: "db" "Database library" { $subsection "db-custom-database-combinators" } { $subsection "db-protocol" } +{ $subsection "db-result-sets" } { $subsection "db-lowlevel-tutorial" } "Higher-level database:" { $vocab-subsection "Database types" "db.types" } { $vocab-subsection "High-level tuple/database integration" "db.tuples" } +! { $subsection "db-tuples" } +! { $subsection "db-tuples-protocol" } +! { $subsection "db-tuples-tutorial" } "Supported database backends:" { $vocab-subsection "SQLite" "db.sqlite" } { $vocab-subsection "PostgreSQL" "db.postgresql" } @@ -132,6 +237,40 @@ ARTICLE: "db" "Low-level database library" { $subsection "db-porting-the-library" } ; +ARTICLE: "db-random-access-result-set" "Random access result sets" +"Random-access result sets do not have to be traversed in order. For instance, PostgreSQL's result set object can be accessed as a matrix with i,j coordinates." +$nl +"Databases which work in this way must provide methods for the following traversal words:" +{ $subsection #rows } +{ $subsection #columns } +{ $subsection row-column } +{ $subsection row-column-typed } ; + +ARTICLE: "db-sequential-result-set" "Sequential result sets" +"Sequential result sets can be iterated one element after the next. SQLite's result sets offer this method of traversal." +$nl +"Databases which work in this way must provide methods for the following traversal words:" +{ $subsection more-rows? } +{ $subsection advance-row } +{ $subsection row-column } +{ $subsection row-column-typed } ; + +ARTICLE: "db-result-sets" "Result sets" +"Result sets are the encapsulated, database-specific results from a SQL query." +$nl +"Two possible protocols for iterating over result sets exist:" +{ $subsection "db-random-access-result-set" } +{ $subsection "db-sequential-result-set" } +"Query the number of rows or columns:" +{ $subsection #rows } +{ $subsection #columns } +"Traversing a result set:" +{ $subsection advance-row } +{ $subsection more-rows? } +"Pulling out a single row of results:" +{ $subsection row-column } +{ $subsection row-column-typed } ; + ARTICLE: "db-protocol" "Low-level database protocol" "The high-level protocol (see " { $vocab-link "db.tuples" } ") uses this low-level protocol for executing statements and queries." ; @@ -144,7 +283,6 @@ ARTICLE: "db-porting-the-library" "Porting the database library" "This section is not yet written." ; - ARTICLE: "db-custom-database-combinators" "Custom database combinators" "Every database library requires some effort on the programmer's part to initialize and open a database. SQLite uses files on your harddisk, so a simple pathname is all the setup required. With PostgreSQL, you log in to a networked server as a user on a specfic port." $nl @@ -155,7 +293,6 @@ USING: db.sqlite db io.files ; { "my-database.db" temp-file } sqlite-db rot with-db ; "> } - ; ABOUT: "db" diff --git a/basis/db/db.factor b/basis/db/db.factor index eac22a2999..87bf21d261 100755 --- a/basis/db/db.factor +++ b/basis/db/db.factor @@ -80,11 +80,14 @@ GENERIC: execute-statement* ( statement type -- ) M: object execute-statement* ( statement type -- ) drop query-results dispose ; +: execute-one-statement ( statement -- ) + dup type>> execute-statement* ; + : execute-statement ( statement -- ) dup sequence? [ - [ execute-statement ] each + [ execute-one-statement ] each ] [ - dup type>> execute-statement* + execute-one-statement ] if ; : bind-statement ( obj statement -- ) diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor index 38fa4cc715..17bb97320d 100755 --- a/basis/db/postgresql/postgresql.factor +++ b/basis/db/postgresql/postgresql.factor @@ -5,7 +5,7 @@ kernel math math.parser namespaces make prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi db.tuples db.types tools.annotations math.ranges combinators classes locals words tools.walker -nmake accessors random db.queries destructors ; +nmake accessors random db.queries destructors db.tuples.private ; USE: tools.walker IN: db.postgresql diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index 300822cc50..2beb3a9ecb 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -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 -- ) @@ -177,7 +177,8 @@ M: db ( 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 [ ] dip make-query* ; ! 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> maybe-make-retryable do-select ; -M: db ( tuple class groups -- statement ) - \ query new - swap >>group +M: db ( query -- statement ) + [ tuple>> dup class ] keep [ [ "select count(*) from " 0% 0% where-clause ] query-make ] dip make-query* ; diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index 1eb9b566d3..a4d16ae4d1 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -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 ; diff --git a/basis/db/tuples/tuples-docs.factor b/basis/db/tuples/tuples-docs.factor index 26ecec0365..d7ee3a5ad2 100644 --- a/basis/db/tuples/tuples-docs.factor +++ b/basis/db/tuples/tuples-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: classes help.markup help.syntax io.streams.string kernel -quotations sequences strings multiline math ; +quotations sequences strings multiline math db.types ; IN: db.tuples HELP: define-persistent @@ -11,7 +11,18 @@ HELP: define-persistent { $list { "a slot name from the " { $snippet "tuple class" } } { "the name of a database column that maps to the slot" } { "a database type (see " { $link "db.types" } ")" } -} } ; +} "Throws an error if the slot name (column one from each row) is not a slot in the tuple or its superclases." } +{ $examples + { $unchecked-example "USING: db.tuples db.types ;" + "TUPLE: boat id year name ;" + "boat \"BOAT\" {" + " { \"id\" \"ID\" +db-assigned-id+ }" + " { \"year\" \"YEAR\" INTEGER }" + " { \"name\" \"NAME\" TEXT }" + "} define-persistent" + "" + } +} ; HELP: create-table { $values @@ -64,36 +75,35 @@ HELP: delete-tuples HELP: select-tuple { $values - { "tuple" tuple } + { "query/tuple" tuple } { "tuple/f" "a tuple or f" } } { $description "A SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". Returns a single tuple from the database if it matches the query constructed from the exemplar tuple." } ; HELP: select-tuples { $values - { "tuple" tuple } + { "query/tuple" tuple } { "tuples" "an array of tuples" } } { $description "A SQL query is constructed from the slots of the exemplar tuple that are not " { $link f } ". Returns a multiple tuples from the database that match the query constructed from the exemplar tuple." } ; HELP: count-tuples { $values - { "tuple" tuple } { "groups" "an array of slots to group by" } + { "query/tuple" tuple } { "n" integer } } -{ $description "" } ; +{ $description "Returns the number of items that would be returned if the query were a select query. Counting the tuples with this word is more efficient than calling " { $link length } " on the result of " { $link select-tuples } "." } ; + +{ select-tuple select-tuples count-tuples } related-words -HELP: query -{ $values - { "tuple" tuple } { "query" query } - { "tuples" "a sequence of tuples" } } -{ $description "Allows for queries with group by, order by, limit, and offset clauses. " } ; -{ select-tuple select-tuples count-tuples query } related-words ARTICLE: "db-tuples" "High-level tuple/database integration" "Start with a tutorial:" { $subsection "db-tuples-tutorial" } +"Database types supported:" +{ $subsection "db.types" } "Useful words:" { $subsection "db-tuples-words" } - +"For porting db.tuples to other databases:" +{ $subsection "db-tuples-protocol" } ; ARTICLE: "db-tuples-words" "High-level tuple/database words" @@ -115,12 +125,9 @@ ARTICLE: "db-tuples-words" "High-level tuple/database words" "Querying tuples:" { $subsection select-tuple } { $subsection select-tuples } -{ $subsection count-tuples } -"Advanced querying of tuples:" -{ $subsection query } ; +{ $subsection count-tuples } ; - -ARTICLE: "db-tuples-protocol" "High-level tuple/database protocol" +ARTICLE: "db-tuples-protocol" "Tuple database protocol" ; ARTICLE: "db-tuples-tutorial" "Tuple database tutorial" diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 45a51719f9..4b1e49c76e 100755 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -4,7 +4,7 @@ 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 TUPLE: person the-id the-name the-number the-real @@ -357,7 +357,7 @@ TUPLE: exam id name score ; T{ exam } select-tuples ] unit-test - [ 4 ] [ T{ exam } f count-tuples ] unit-test ; + [ 4 ] [ T{ exam } count-tuples ] unit-test ; TUPLE: bignum-test id m n o ; : ( m n o -- obj ) @@ -518,6 +518,7 @@ string-encoding-test "STRING_ENCODING_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 + [ 5 ] [ 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 ! [ ] [ query ] unit-test ; diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor index 2bdbb138d7..4ecff74c10 100755 --- a/basis/db/tuples/tuples.factor +++ b/basis/db/tuples/tuples.factor @@ -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 new ; - -GENERIC: >query ( object -- query ) - -M: query >query ; - -M: tuple >query swap >>tuple ; - + db ( class -- object ) HOOK: db ( class -- object ) HOOK: db ( tuple class -- object ) HOOK: db ( tuple class -- tuple ) -HOOK: db ( tuple class groups -- statement ) -HOOK: make-query db ( tuple class query -- statement ) +HOOK: 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 ) @@ -70,9 +45,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 +66,51 @@ GENERIC: eval-generator ( singleton -- object ) with-disposal ] if ; inline +: insert-db-assigned-statement ( tuple -- ) + dup class + db get insert-statements>> [ ] cache + [ bind-tuple ] 2keep insert-tuple* ; + +: insert-user-assigned-statement ( tuple -- ) + dup class + db get insert-statements>> [ ] cache + [ bind-tuple ] keep execute-statement ; + +: do-select ( exemplar-tuple statement -- tuples ) + [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ; + +: do-count ( exemplar-tuple statement -- tuples ) + [ [ bind-tuple ] [ nip default-query ] 2bi ] with-disposal ; +PRIVATE> + + +! High level +ERROR: no-slots-named class seq ; +: check-columns ( class columns -- ) + tuck + [ [ first ] map ] + [ all-slots [ name>> ] map ] bi* diff + [ drop ] [ no-slots-named ] if-empty ; + +: define-persistent ( class table columns -- ) + pick dupd + check-columns + [ dupd "db-table" set-word-prop dup ] dip + [ relation? ] partition swapd + dupd [ spec>tuple ] with map + "db-columns" set-word-prop + "db-relations" set-word-prop ; + +TUPLE: query tuple group order offset limit ; + +: ( -- query ) \ query new ; + +GENERIC: >query ( object -- query ) + +M: query >query clone ; + +M: tuple >query swap >>tuple ; + : create-table ( class -- ) create-sql-statement [ execute-statement ] with-disposals ; @@ -105,21 +123,9 @@ GENERIC: eval-generator ( singleton -- object ) ] curry ignore-errors ] [ create-table ] bi ; -: ensure-table ( class -- ) - [ create-table ] curry ignore-errors ; +: ensure-table ( class -- ) [ create-table ] curry ignore-errors ; -: ensure-tables ( classes -- ) - [ ensure-table ] each ; - -: insert-db-assigned-statement ( tuple -- ) - dup class - db get insert-statements>> [ ] cache - [ bind-tuple ] 2keep insert-tuple* ; - -: insert-user-assigned-statement ( tuple -- ) - dup class - db get insert-statements>> [ ] cache - [ bind-tuple ] keep execute-statement ; +: ensure-tables ( classes -- ) [ ensure-table ] each ; : insert-tuple ( tuple -- ) dup class db-columns find-primary-key db-assigned-id-spec? @@ -135,26 +141,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 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> do-count +: count-tuples ( query/tuple -- n ) + >query [ tuple>> ] [ ] bi do-count dup length 1 = [ first first string>number ] [ [ first string>number ] map ] if ; diff --git a/basis/db/types/types-docs.factor b/basis/db/types/types-docs.factor index 9300a68f2e..590a2e432f 100644 --- a/basis/db/types/types-docs.factor +++ b/basis/db/types/types-docs.factor @@ -1,14 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: classes hashtables help.markup help.syntax io.streams.string kernel sequences strings ; +USING: classes hashtables help.markup help.syntax io.streams.string +kernel sequences strings math ; IN: db.types -HELP: (lookup-type) -{ $values - { "obj" object } - { "string" string } } -{ $description "" } ; - HELP: +autoincrement+ { $description "" } ; @@ -55,7 +50,7 @@ HELP: { $description "" } ; HELP: BIG-INTEGER -{ $description "A 64-bit integer." } ; +{ $description "A 64-bit integer. Whether this number is signed or unsigned depends on the database backend." } ; HELP: BLOB { $description "A serialized Factor object. The database library automatically serializes the object for a SQL insert or update and deserializes it on a tuple query." } ; @@ -73,13 +68,13 @@ HELP: DOUBLE { $description "Corresponds to Factor's 64bit floating-point numbers." } ; HELP: FACTOR-BLOB -{ $description "" } ; +{ $description "A serialized Factor object." } ; HELP: INTEGER -{ $description "" } ; +{ $description "A small integer, at least 32 bits in length. Whether this number is signed or unsigned depends on the database backend." } ; HELP: NULL -{ $description "" } ; +{ $description "The SQL null type." } ; HELP: REAL { $description "" } ; @@ -94,16 +89,18 @@ 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? { $values @@ -135,18 +132,19 @@ HELP: db-assigned-id-spec? HELP: find-primary-key { $values - { "specs" null } + { "specs" "an array of sql-specs" } { "obj" object } } -{ $description "" } ; +{ $description "Returns the row from the sql-specs array." } +{ $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 @@ -192,23 +190,11 @@ HELP: normalize-spec { "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 @@ -294,7 +280,6 @@ ARTICLE: "db.types" "Database types" { $subsection BLOB } { $subsection FACTOR-BLOB } "Factor URLs:" -{ $subsection URL } -; +{ $subsection URL } ; ABOUT: "db.types" diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index 476d82a1e2..24876336c7 100755 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -126,11 +126,11 @@ ERROR: no-sql-type ; HOOK: bind% db ( spec -- ) HOOK: bind# db ( spec obj -- ) -: offset-of-slot ( string obj -- n ) +: offset-of-slot ( string tuple -- n ) class superclasses [ "slots" word-prop ] map concat slot-named offset>> ; -: get-slot-named ( name obj -- value ) +: get-slot-named ( name tuple -- value ) tuck offset-of-slot slot ; : set-slot-named ( value name obj -- ) diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index b7fd34c5be..20e0703ce0 100755 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -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" ; diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index 42979007e8..693c559ac5 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -135,3 +135,18 @@ link-no-follow? off [ "
" ] [ "___" convert-farkup ] unit-test [ "
\n" ] [ "___\n" convert-farkup ] unit-test + +[ "

before:\n

{ 1 2 3 } 1 tail\n

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

Factor-rific!

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

[ factor { 1 2 3 }]

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

paragraph\n


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

paragraph\n a ___ b

" ] +[ "paragraph\n a ___ b" convert-farkup ] unit-test diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index f482f8beaa..7844cf8f41 100644 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -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,13 @@ 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 +108,13 @@ 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-item = (table | nl list | nl line | code | text | inline-tag | inline-delimiter)+ paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]] | (paragraph-item nl)+ paragraph-item? | paragraph-item) => [[ paragraph boa ]] + list-item = (cell | inline-tag)* 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 + 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 diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor new file mode 100644 index 0000000000..adab7caa44 --- /dev/null +++ b/basis/http/client/client-docs.factor @@ -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: +{ $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: +{ $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 } +{ $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 } +"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 } " and filling everything in by hand." +{ $subsection "http.client.encoding" } +{ $subsection "http.client.errors" } +{ $see-also "urls" } ; + +ABOUT: "http.client" diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 5e22f5144d..e473ef4e26 100755 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -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 ) diff --git a/basis/http/http-docs.factor b/basis/http/http-docs.factor new file mode 100644 index 0000000000..3261f9aa27 --- /dev/null +++ b/basis/http/http-docs.factor @@ -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: +{ $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: +{ $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: +{ $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: +{ $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: +{ $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 } +"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 } ; + +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 } +"Requests can contain form submissions:" +{ $subsection "http.post-data" } +"HTTP responses:" +{ $subsection response } +{ $subsection } +"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 } +"Both requests and responses support some common functionality:" +{ $subsection "http.headers" } +{ $subsection "http.cookies" } +{ $see-also "urls" } ; + +ABOUT: "http" diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index b3b676c1cb..5be5e24105 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -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 diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index eb06d05146..bc1e736b75 100755 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -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 \ No newline at end of file +{ 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 \ No newline at end of file diff --git a/basis/macros/expander/expander-tests.factor b/basis/macros/expander/expander-tests.factor index fe0154b725..af67ac5639 100644 --- a/basis/macros/expander/expander-tests.factor +++ b/basis/macros/expander/expander-tests.factor @@ -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 diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor index d766430810..d62c6bf466 100644 --- a/basis/macros/expander/expander.factor +++ b/basis/macros/expander/expander.factor @@ -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 ; diff --git a/basis/multiline/multiline-tests.factor b/basis/multiline/multiline-tests.factor index c323e9b96a..357fd2cb6c 100755 --- a/basis/multiline/multiline-tests.factor +++ b/basis/multiline/multiline-tests.factor @@ -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 diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor index 5969fc0a95..ecbe9e668f 100755 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -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 diff --git a/basis/present/present-docs.factor b/basis/present/present-docs.factor new file mode 100644 index 0000000000..f148d96b32 --- /dev/null +++ b/basis/present/present-docs.factor @@ -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" diff --git a/basis/summary/summary-docs.factor b/basis/summary/summary-docs.factor index 4dfbd16ed4..7822857bbb 100644 --- a/basis/summary/summary-docs.factor +++ b/basis/summary/summary-docs.factor @@ -1,12 +1,13 @@ IN: summary 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:" { $subsection summary } ; HELP: summary { $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" diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index d80adeaed9..d8d35ebf31 100644 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -4,7 +4,7 @@ USING: assocs io.files hashtables kernel namespaces sequences vocabs.loader io combinators io.encodings.utf8 calendar accessors math.parser io.streams.string ui.tools.operations quotations strings arrays prettyprint words vocabs sorting sets -classes math alien ; +classes math alien urls splitting ascii ; IN: tools.scaffold SYMBOL: developer-name @@ -89,17 +89,12 @@ ERROR: no-vocab vocab ; ] if ; : lookup-type ( string -- object/string ? ) + "new" ?head drop [ [ CHAR: ' = ] [ digit? ] bi or ] trim-right H{ { "object" object } { "obj" object } - { "obj1" object } { "obj2" object } - { "obj3" object } { "obj4" object } - { "quot" quotation } { "quot1" quotation } - { "quot2" quotation } { "quot3" quotation } - { "quot'" quotation } - { "string" string } { "string1" string } - { "string2" string } { "string3" string } + { "quot" quotation } + { "string" string } { "str" string } - { "str1" string } { "str2" string } { "str3" string } { "hash" hashtable } { "hashtable" hashtable } { "?" "a boolean" } @@ -111,16 +106,12 @@ ERROR: no-vocab vocab ; { "vocab" "a vocabulary specifier" } { "vocab-root" "a vocabulary root string" } { "c-ptr" c-ptr } - { "seq" sequence } { "seq1" sequence } { "seq2" sequence } - { "seq3" sequence } { "seq4" sequence } - { "seq1'" sequence } { "seq2'" sequence } - { "newseq" sequence } - { "seq'" sequence } - { "assoc" assoc } { "assoc1" assoc } { "assoc2" assoc } - { "assoc3" assoc } { "newassoc" assoc } + { "seq" sequence } + { "assoc" assoc } { "alist" "an array of key/value pairs" } { "keys" sequence } { "values" sequence } { "class" class } { "tuple" tuple } + { "url" url } } at* ; : add-using ( object -- ) @@ -158,7 +149,7 @@ ERROR: no-vocab vocab ; "{ $description \"\" } ;" print ; : help-header. ( word -- ) - "HELP: " write . ; + "HELP: " write name>> print ; : (help.) ( word -- ) [ help-header. ] [ $values. ] [ $description. ] tri ; @@ -171,7 +162,7 @@ ERROR: no-vocab vocab ; : interesting-words. ( vocab -- ) interesting-words [ (help.) nl ] each ; -: help-file-string ( str1 -- str2 ) +: help-file-string ( vocab -- str2 ) [ { [ "IN: " write print nl ] @@ -185,16 +176,18 @@ ERROR: no-vocab vocab ; } cleave ] with-string-writer ; -: write-using ( -- ) +: write-using ( vocab -- ) "USING:" write using get keys - { "help.markup" "help.syntax" } append natural-sort + { "help.markup" "help.syntax" } append natural-sort remove [ bl write ] each " ;" print ; : set-scaffold-help-file ( path vocab -- ) swap utf8 [ - scaffold-copyright help-file-string write-using write + scaffold-copyright + [ help-file-string ] [ write-using ] bi + write ] with-output-stream ; : check-scaffold ( vocab-root string -- vocab-root string ) diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor new file mode 100644 index 0000000000..166ad9d586 --- /dev/null +++ b/basis/urls/urls-docs.factor @@ -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: +{ $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 } +"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" diff --git a/basis/urls/urls-tests.factor b/basis/urls/urls-tests.factor index 75ee7b6740..d1415a9dde 100644 --- a/basis/urls/urls-tests.factor +++ b/basis/urls/urls-tests.factor @@ -2,19 +2,19 @@ IN: urls.tests USING: urls urls.private tools.test 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" ] [ "%7ehello+world" url-decode ] unit-test [ f ] [ "%XX%XX%XX" url-decode ] unit-test [ f ] [ "%XX%XX%X" url-decode ] unit-test -[ "hello world" ] [ "hello+world" url-decode ] unit-test -[ "hello world" ] [ "hello%20world" url-decode ] unit-test -[ " ! " ] [ "%20%21%20" url-decode ] unit-test -[ "hello world" ] [ "hello world%" url-decode ] unit-test -[ "hello world" ] [ "hello world%x" url-decode ] unit-test -[ "hello%20world" ] [ "hello world" url-encode ] unit-test -[ "%20%21%20" ] [ " ! " url-encode ] unit-test +[ "hello world" ] [ "hello+world" url-decode ] unit-test +[ "hello world" ] [ "hello%20world" url-decode ] unit-test +[ " ! " ] [ "%20%21%20" 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" url-encode ] unit-test +[ "+%21+" ] [ " ! " url-encode ] unit-test [ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor index e35292e9d7..17b309f37f 100644 --- a/basis/urls/urls.factor +++ b/basis/urls/urls.factor @@ -8,8 +8,6 @@ strings.parser lexer prettyprint.backend hashtables present ; IN: urls : url-quotable? ( ch -- ? ) - #! In a URL, can this character be used without - #! URL-encoding? { [ letter? ] [ LETTER? ] @@ -20,8 +18,10 @@ IN: urls hex 2 CHAR: 0 pad-left % ] each ; + dup CHAR: \s = [ drop "+" % ] [ + 1string utf8 encode + [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each + ] if ; PRIVATE> @@ -86,7 +86,7 @@ PRIVATE> ] keep ] when ; -: assoc>query ( hash -- str ) +: assoc>query ( assoc -- str ) [ dup array? [ [ present ] map ] [ present 1array ] if ] assoc-map @@ -104,8 +104,15 @@ TUPLE: url protocol username password host port path query anchor ; : query-param ( url key -- value ) swap query>> at ; +: delete-query-param ( url key -- url ) + over query>> delete-at ; + : 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 ) ":" split1 [ url-decode ] [ @@ -152,7 +159,6 @@ M: string >url { { "http" [ 80 ] } { "https" [ 443 ] } - { "feed" [ 80 ] } { "ftp" [ 21 ] } [ drop f ] } case ; @@ -168,8 +174,6 @@ M: string >url [ port>> ] [ port>> ] [ protocol>> protocol-port ] tri = [ drop f ] when ; -PRIVATE> - : unparse-host-part ( url protocol -- ) % "://" % @@ -180,6 +184,8 @@ PRIVATE> [ path>> "/" head? [ "/" % ] unless ] } cleave ; +PRIVATE> + M: url present [ { @@ -224,10 +230,15 @@ PRIVATE> "https" = ; : url-addr ( url -- addr ) - [ [ host>> ] [ port>> ] bi ] [ protocol>> ] bi + [ + [ host>> ] + [ port>> ] + [ protocol>> protocol-port ] + tri or + ] [ protocol>> ] bi secure-protocol? [ ] when ; -: ensure-port ( url -- url' ) +: ensure-port ( url -- url ) dup protocol>> '[ _ protocol-port or ] change-port ; ! Literal syntax diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index c190ce85e7..dd78b4ba3e 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -63,11 +63,14 @@ ERROR: invalid-slot-name name ; : parse-slot-value ( -- ) scan scan-object 2array , scan "}" assert= ; +ERROR: bad-literal-tuple ; + : (parse-slot-values) ( -- ) parse-slot-value scan { { "{" [ (parse-slot-values) ] } { "}" [ ] } + [ bad-literal-tuple ] } case ; : parse-slot-values ( -- ) @@ -86,4 +89,5 @@ ERROR: invalid-slot-name name ; { "f" [ \ } parse-until boa>tuple ] } { "{" [ parse-slot-values assoc>tuple ] } { "}" [ new ] } + [ bad-literal-tuple ] } case ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index cd76967e5a..905cd87903 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -519,7 +519,7 @@ HELP: UNION: HELP: INTERSECTION: { $syntax "INTERSECTION: class participants... ;" } { $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: { $syntax "MIXIN: class" } diff --git a/extra/peg/javascript/parser/parser-tests.factor b/extra/peg/javascript/parser/parser-tests.factor index 769dc41f78..a2c50952be 100644 --- a/extra/peg/javascript/parser/parser-tests.factor +++ b/extra/peg/javascript/parser/parser-tests.factor @@ -40,8 +40,7 @@ function foldl(f, initial, seq) { for(var i=0; i< seq.length; ++i) initial = f(initial, seq[i]); return initial; -} -"> main \ javascript rule (parse) remaining>> length zero? +}"> main \ javascript rule (parse) remaining>> length zero? ] unit-test { t } [ @@ -51,7 +50,6 @@ ParseState.prototype.from = function(index) { r.cache = this.cache; r.length = this.length - index; return r; -} -"> main \ javascript rule (parse) remaining>> length zero? +}"> main \ javascript rule (parse) remaining>> length zero? ] unit-test diff --git a/extra/peg/pl0/pl0-tests.factor b/extra/peg/pl0/pl0-tests.factor index e84d37e5d4..873a4b760e 100644 --- a/extra/peg/pl0/pl0-tests.factor +++ b/extra/peg/pl0/pl0-tests.factor @@ -57,8 +57,7 @@ BEGIN CALL square; x := x + 1; END -END. -"> main \ pl0 rule (parse) remaining>> empty? +END."> main \ pl0 rule (parse) remaining>> empty? ] unit-test { f } [ diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor index 2858ad21f3..e035090fb0 100644 --- a/extra/webapps/blogs/blogs.factor +++ b/extra/webapps/blogs/blogs.factor @@ -90,7 +90,7 @@ M: comment entity-url : list-posts ( -- posts ) f "author" value >>author - select-tuples [ dup id>> f f count-tuples >>comments ] map + select-tuples [ dup id>> f count-tuples >>comments ] map reverse-chronological-order ; : ( -- action ) diff --git a/extra/webapps/wiki/initial-content/Farkup.txt b/extra/webapps/wiki/initial-content/Farkup.txt index 65f9defc5b..33b3a6c51a 100644 --- a/extra/webapps/wiki/initial-content/Farkup.txt +++ b/extra/webapps/wiki/initial-content/Farkup.txt @@ -28,6 +28,10 @@ Ordered lists: # with three # numbered items +Horizontal lines: + +___ + Tables: |a table|with|four|columns|