From 969763e80798a0f530d9e589897da93815e3d4e9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 24 Sep 2008 17:59:17 -0500
Subject: [PATCH 01/25] change what select-tuples/select-tuple/count-tuples
takes
---
basis/db/queries/queries.factor | 8 +--
basis/db/tuples/tuples-tests.factor | 2 +-
basis/db/tuples/tuples.factor | 83 ++++++++++++++---------------
3 files changed, 44 insertions(+), 49 deletions(-)
diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor
index 300822cc50..7451676752 100644
--- a/basis/db/queries/queries.factor
+++ b/basis/db/queries/queries.factor
@@ -177,7 +177,8 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
[ offset>> [ do-offset ] [ drop ] if* ]
} 2cleave ;
-M: db make-query ( tuple class query -- tuple )
+M: db query>statement ( query -- tuple )
+ [ tuple>> dup class ] keep
[ <select-by-slots-statement> ] dip make-query* ;
! select ID, NAME, SCORE from EXAM limit 1 offset 3
@@ -194,9 +195,8 @@ M: db make-query ( tuple class query -- tuple )
>r >r parse-sql 4drop r> r>
<simple-statement> maybe-make-retryable do-select ;
-M: db <count-statement> ( tuple class groups -- statement )
- \ query new
- swap >>group
+M: db <count-statement> ( query -- statement )
+ [ tuple>> dup class ] keep
[ [ "select count(*) from " 0% 0% where-clause ] query-make ]
dip make-query* ;
diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor
index 45a51719f9..656802136d 100755
--- a/basis/db/tuples/tuples-tests.factor
+++ b/basis/db/tuples/tuples-tests.factor
@@ -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 ;
: <bignum-test> ( m n o -- obj )
diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor
index 2bdbb138d7..3f1889aef2 100755
--- a/basis/db/tuples/tuples.factor
+++ b/basis/db/tuples/tuples.factor
@@ -6,16 +6,6 @@ math.parser io prettyprint db.types continuations
destructors mirrors sets ;
IN: db.tuples
-TUPLE: query tuple group order offset limit ;
-
-: <query> ( -- query ) \ query new ;
-
-GENERIC: >query ( object -- query )
-
-M: query >query ;
-
-M: tuple >query <query> swap >>tuple ;
-
! returns a sequence of prepared-statements
HOOK: create-sql-statement db ( class -- object )
HOOK: drop-sql-statement db ( class -- object )
@@ -25,8 +15,8 @@ HOOK: <insert-user-assigned-statement> db ( class -- object )
HOOK: <update-tuple-statement> db ( class -- object )
HOOK: <delete-tuples-statement> db ( tuple class -- object )
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
-HOOK: <count-statement> db ( tuple class groups -- statement )
-HOOK: make-query db ( tuple class query -- statement )
+HOOK: <count-statement> db ( query -- statement )
+HOOK: query>statement db ( query -- statement )
HOOK: insert-tuple* db ( tuple statement -- )
@@ -93,6 +83,35 @@ GENERIC: eval-generator ( singleton -- object )
with-disposal
] if ; inline
+: insert-db-assigned-statement ( tuple -- )
+ dup class
+ db get insert-statements>> [ <insert-db-assigned-statement> ] cache
+ [ bind-tuple ] 2keep insert-tuple* ;
+
+: 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 ;
+
+! High level
+
+TUPLE: query tuple group order offset limit ;
+
+: <query> ( -- query ) \ query new ;
+
+GENERIC: >query ( object -- query )
+
+M: query >query clone ;
+
+M: tuple >query <query> swap >>tuple ;
+
+
: create-table ( class -- )
create-sql-statement [ execute-statement ] with-disposals ;
@@ -105,21 +124,9 @@ GENERIC: eval-generator ( singleton -- object )
] curry ignore-errors
] [ create-table ] bi ;
-: ensure-table ( class -- )
- [ create-table ] curry ignore-errors ;
+: ensure-table ( class -- ) [ create-table ] curry ignore-errors ;
-: ensure-tables ( classes -- )
- [ ensure-table ] each ;
-
-: insert-db-assigned-statement ( tuple -- )
- dup class
- db get insert-statements>> [ <insert-db-assigned-statement> ] cache
- [ bind-tuple ] 2keep insert-tuple* ;
-
-: insert-user-assigned-statement ( tuple -- )
- dup class
- db get insert-statements>> [ <insert-user-assigned-statement> ] cache
- [ bind-tuple ] keep execute-statement ;
+: ensure-tables ( classes -- ) [ ensure-table ] each ;
: insert-tuple ( tuple -- )
dup class db-columns find-primary-key db-assigned-id-spec?
@@ -135,26 +142,14 @@ GENERIC: eval-generator ( singleton -- object )
[ bind-tuple ] keep execute-statement
] with-disposal ;
-: do-select ( exemplar-tuple statement -- tuples )
- [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ;
+: select-tuples ( query/tuple -- tuples )
+ >query [ tuple>> ] [ query>statement ] bi do-select ;
-: query ( tuple query -- tuples )
- [ dup dup class ] dip make-query do-select ;
-
-
-: select-tuples ( tuple -- tuples )
- dup dup class <select-by-slots-statement> do-select ;
-
-: select-tuple ( tuple -- tuple/f )
- dup dup class \ query new 1 >>limit make-query do-select
+: select-tuple ( query/tuple -- tuple/f )
+ >query 1 >>limit [ tuple>> ] [ query>statement ] bi do-select
[ f ] [ first ] if-empty ;
-: do-count ( exemplar-tuple statement -- tuples )
- [
- [ bind-tuple ] [ nip default-query ] 2bi
- ] with-disposal ;
-
-: count-tuples ( tuple groups -- n )
- >r dup dup class r> <count-statement> do-count
+: count-tuples ( query/tuple -- n )
+ >query [ tuple>> ] [ <count-statement> ] bi do-count
dup length 1 =
[ first first string>number ] [ [ first string>number ] map ] if ;
From 2eb5d3b36d471c47f457c0618dc205a004cfa1e6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 24 Sep 2008 18:00:48 -0500
Subject: [PATCH 02/25] update usage of count-tuples
---
extra/webapps/blogs/blogs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
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 <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 ;
: <list-posts-action> ( -- action )
From eae7e95d9b95c75ff9a12cd564a167832a92a264 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 24 Sep 2008 19:04:44 -0500
Subject: [PATCH 03/25] Fix <"
---
basis/multiline/multiline-tests.factor | 5 ++++-
basis/multiline/multiline.factor | 2 +-
2 files changed, 5 insertions(+), 2 deletions(-)
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
From 95bfec86e4898b2c9a79dbecedf12e2178750d97 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 24 Sep 2008 19:05:03 -0500
Subject: [PATCH 04/25] Minor improvements to tools.scaffold
---
basis/tools/scaffold/scaffold.factor | 35 +++++++++++-----------------
1 file changed, 14 insertions(+), 21 deletions(-)
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 <file-writer> [
- 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 )
From 7e5af60cbcbd2c922c0ae2f25a6402f8fcaa3376 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 24 Sep 2008 19:19:51 -0500
Subject: [PATCH 05/25] refactor farkup a bit, fix bug w/ paragraphs and code
---
basis/farkup/farkup-tests.factor | 6 ++++++
basis/farkup/farkup.factor | 23 +++++++++++++++++------
2 files changed, 23 insertions(+), 6 deletions(-)
diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor
index 42979007e8..f549e9c04c 100644
--- a/basis/farkup/farkup-tests.factor
+++ b/basis/farkup/farkup-tests.factor
@@ -135,3 +135,9 @@ link-no-follow? off
[ "<hr/>" ] [ "___" convert-farkup ] unit-test
[ "<hr/>\n" ] [ "___\n" convert-farkup ] unit-test
+
+[ "<p>before:\n<pre><span class='OPERATOR'>{</span> <span class='DIGIT'>1</span> <span class='DIGIT'>2</span> <span class='DIGIT'>3</span> <span class='OPERATOR'>}</span> <span class='DIGIT'>1</span> tail\n</pre></p>" ]
+[ "before:\n[factor{{ 1 2 3 } 1 tail}]" convert-farkup ] unit-test
+
+[ "<a href='Factor'>Factor</a>-rific!" ]
+[ "[[Factor]]-rific" convert-farkup ] unit-test
diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor
index f482f8beaa..2957e6f2ec 100644
--- a/basis/farkup/farkup.factor
+++ b/basis/farkup/farkup.factor
@@ -40,6 +40,7 @@ EBNF: parse-farkup
nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
2nl = nl nl
+
heading1 = "=" (!("=" | nl).)+ "="
=> [[ second >string heading1 boa ]]
@@ -52,6 +53,10 @@ heading3 = "===" (!("=" | nl).)+ "==="
heading4 = "====" (!("=" | nl).)+ "===="
=> [[ second >string heading4 boa ]]
+heading = heading4 | heading3 | heading2 | heading1
+
+
+
strong = "*" (!("*" | nl).)+ "*"
=> [[ second >string strong boa ]]
@@ -67,8 +72,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 +87,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 +109,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 | list | 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 +130,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 = '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]"
=> [[ [ 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
From 72685aa77e155d502792cb52629cc36c566266aa Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 24 Sep 2008 19:26:37 -0500
Subject: [PATCH 06/25] fix [[link]]-foo --- should not create a list
---
basis/farkup/farkup-tests.factor | 4 ++--
basis/farkup/farkup.factor | 4 +---
2 files changed, 3 insertions(+), 5 deletions(-)
diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor
index f549e9c04c..9120ec97f9 100644
--- a/basis/farkup/farkup-tests.factor
+++ b/basis/farkup/farkup-tests.factor
@@ -139,5 +139,5 @@ link-no-follow? off
[ "<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
-[ "<a href='Factor'>Factor</a>-rific!" ]
-[ "[[Factor]]-rific" convert-farkup ] unit-test
+[ "<p><a href='Factor'>Factor</a>-rific!</p>" ]
+[ "[[Factor]]-rific!" convert-farkup ] unit-test
diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor
index 2957e6f2ec..ec49655d5a 100644
--- a/basis/farkup/farkup.factor
+++ b/basis/farkup/farkup.factor
@@ -38,8 +38,6 @@ TUPLE: line ;
EBNF: parse-farkup
nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
-2nl = nl nl
-
heading1 = "=" (!("=" | nl).)+ "="
=> [[ second >string heading1 boa ]]
@@ -109,7 +107,7 @@ table = ((table-row nl => [[ first ]] )+ table-row? | table-row)
text = (!(nl | code | heading | inline-delimiter | table ).)+
=> [[ >string ]]
-paragraph-item = (table | list | code | text | inline-tag | inline-delimiter)+
+paragraph-item = (table | nl list | code | text | inline-tag | inline-delimiter)+
paragraph = ((paragraph-item nl => [[ first ]])+ nl+ => [[ first ]]
| (paragraph-item nl)+ paragraph-item?
| paragraph-item)
From 8e86c31c3148d37e5b51e1c8dc2d26ea45edadc8 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 24 Sep 2008 19:30:46 -0500
Subject: [PATCH 07/25] a little refactoring, docs
---
basis/db/db-docs.factor | 6 +++--
basis/db/tuples/tuples-docs.factor | 31 ++++++++++++++----------
basis/db/tuples/tuples.factor | 39 +++++++++++++++---------------
3 files changed, 41 insertions(+), 35 deletions(-)
diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor
index f8e3956b3e..244555b93e 100644
--- a/basis/db/db-docs.factor
+++ b/basis/db/db-docs.factor
@@ -118,13 +118,16 @@ HELP: execute-statement
{ $values { "statement" statement } }
{ $description } ;
-ARTICLE: "db" "Low-level database library"
+ARTICLE: "db" "Database library"
{ $subsection "db-custom-database-combinators" }
{ $subsection "db-protocol" }
{ $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" }
@@ -144,7 +147,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
diff --git a/basis/db/tuples/tuples-docs.factor b/basis/db/tuples/tuples-docs.factor
index 26ecec0365..cde362168f 100644
--- a/basis/db/tuples/tuples-docs.factor
+++ b/basis/db/tuples/tuples-docs.factor
@@ -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,30 +75,26 @@ 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 "" } ;
-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" }
@@ -115,9 +122,7 @@ 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"
diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor
index 3f1889aef2..862e28d58e 100755
--- a/basis/db/tuples/tuples.factor
+++ b/basis/db/tuples/tuples.factor
@@ -6,6 +6,7 @@ math.parser io prettyprint db.types continuations
destructors mirrors sets ;
IN: db.tuples
+<PRIVATE
! returns a sequence of prepared-statements
HOOK: create-sql-statement db ( class -- object )
HOOK: drop-sql-statement db ( class -- object )
@@ -20,22 +21,6 @@ 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 )
@@ -60,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 )
@@ -98,8 +81,25 @@ GENERIC: eval-generator ( singleton -- object )
: 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 ;
@@ -111,7 +111,6 @@ M: query >query clone ;
M: tuple >query <query> swap >>tuple ;
-
: create-table ( class -- )
create-sql-statement [ execute-statement ] with-disposals ;
From e270db3768e799df958643da41f0aa5d82f1bdbc Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 24 Sep 2008 19:47:32 -0500
Subject: [PATCH 08/25] fix usings
---
basis/db/postgresql/postgresql.factor | 2 +-
basis/db/queries/queries.factor | 2 +-
basis/db/sqlite/sqlite.factor | 2 +-
basis/db/tuples/tuples-docs.factor | 3 ++-
basis/db/tuples/tuples-tests.factor | 2 +-
5 files changed, 6 insertions(+), 5 deletions(-)
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 7451676752..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 -- )
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 cde362168f..7af827eea2 100644
--- a/basis/db/tuples/tuples-docs.factor
+++ b/basis/db/tuples/tuples-docs.factor
@@ -100,7 +100,8 @@ ARTICLE: "db-tuples" "High-level tuple/database integration"
{ $subsection "db-tuples-tutorial" }
"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"
diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor
index 656802136d..e8e7fdacf3 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
From 505eedc34bfec66823991f7726854a0657da6a02 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 24 Sep 2008 20:18:03 -0500
Subject: [PATCH 09/25] Fix a macro.expander bug
---
basis/locals/locals-tests.factor | 13 +++++++++++--
basis/macros/expander/expander-tests.factor | 2 ++
basis/macros/expander/expander.factor | 4 ++--
3 files changed, 15 insertions(+), 4 deletions(-)
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..8e6d8bc4b4 100644
--- a/basis/macros/expander/expander-tests.factor
+++ b/basis/macros/expander/expander-tests.factor
@@ -7,3 +7,5 @@ kernel ;
[ 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 ;
From 01790339a51277487da2824fce675d083af19477 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 24 Sep 2008 20:24:54 -0500
Subject: [PATCH 10/25] fix some db docs
---
basis/db/tuples/tuples-docs.factor | 9 +++++----
1 file changed, 5 insertions(+), 4 deletions(-)
diff --git a/basis/db/tuples/tuples-docs.factor b/basis/db/tuples/tuples-docs.factor
index 7af827eea2..ec43ffe616 100644
--- a/basis/db/tuples/tuples-docs.factor
+++ b/basis/db/tuples/tuples-docs.factor
@@ -89,15 +89,17 @@ HELP: count-tuples
{ $values
{ "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 query } related-words
+{ select-tuple select-tuples count-tuples } 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:"
@@ -125,8 +127,7 @@ ARTICLE: "db-tuples-words" "High-level tuple/database words"
{ $subsection select-tuples }
{ $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"
From d64808b5d0376b918438c904d8229c180aa089e1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 24 Sep 2008 21:19:27 -0500
Subject: [PATCH 11/25] Documentation updates
---
basis/present/present-docs.factor | 13 ++
basis/summary/summary-docs.factor | 5 +-
basis/urls/urls-docs.factor | 248 ++++++++++++++++++++++++++++++
basis/urls/urls.factor | 24 +--
4 files changed, 278 insertions(+), 12 deletions(-)
create mode 100644 basis/present/present-docs.factor
create mode 100644 basis/urls/urls-docs.factor
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/urls/urls-docs.factor b/basis/urls/urls-docs.factor
new file mode 100644
index 0000000000..d413cff600
--- /dev/null
+++ b/basis/urls/urls-docs.factor
@@ -0,0 +1,248 @@
+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 io urls ;"
+ "\"http://www.apple.com\" >url ."
+ "URL\" 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 or host component:"
+ { $example
+ "USING: accessors io 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
+ { "hash" hashtable }
+ { "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
+ "{ { \"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/kamboocha\""
+ "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" "URLs"
+"The " { $vocab-link "urls" } " 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"
diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor
index e35292e9d7..b8b87a92bd 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
<PRIVATE
: push-utf8 ( ch -- )
- 1string utf8 encode
- [ CHAR: % , >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
@@ -152,7 +152,6 @@ M: string >url
{
{ "http" [ 80 ] }
{ "https" [ 443 ] }
- { "feed" [ 80 ] }
{ "ftp" [ 21 ] }
[ drop f ]
} case ;
@@ -168,8 +167,6 @@ M: string >url
[ port>> ] [ port>> ] [ protocol>> protocol-port ] tri =
[ drop f ] when ;
-PRIVATE>
-
: unparse-host-part ( url protocol -- )
%
"://" %
@@ -180,6 +177,8 @@ PRIVATE>
[ path>> "/" head? [ "/" % ] unless ]
} cleave ;
+PRIVATE>
+
M: url present
[
{
@@ -224,10 +223,15 @@ PRIVATE>
"https" = ;
: url-addr ( url -- addr )
- [ [ host>> ] [ port>> ] bi <inet> ] [ protocol>> ] bi
+ [
+ [ host>> ]
+ [ port>> ]
+ [ protocol>> protocol-port ]
+ tri or <inet>
+ ] [ protocol>> ] bi
secure-protocol? [ <secure> ] when ;
-: ensure-port ( url -- url' )
+: ensure-port ( url -- url )
dup protocol>> '[ _ protocol-port or ] change-port ;
! Literal syntax
From 78881e13687fd425b69f9318e7ff32c970b964f9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 24 Sep 2008 21:23:26 -0500
Subject: [PATCH 12/25] Better error message with invalid tuple literals
---
basis/debugger/debugger.factor | 2 ++
core/classes/tuple/parser/parser.factor | 4 ++++
2 files changed, 6 insertions(+)
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/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 ;
From ca22e075f0ef773ba16e4250564fe4b7c7e31be6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 24 Sep 2008 21:35:12 -0500
Subject: [PATCH 13/25] fix docs
---
basis/urls/urls-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor
index d413cff600..5d9500788b 100644
--- a/basis/urls/urls-docs.factor
+++ b/basis/urls/urls-docs.factor
@@ -90,7 +90,7 @@ HELP: derive-url
}
{ $example
"USING: prettyprint urls ;"
- "URL\" http://www.truecasey.com/drinks/kamboocha\""
+ "URL\" http://www.truecasey.com/drinks/kombucha\""
"URL\" master-cleanser\" derive-url ."
"URL\" http://www.truecasey.com/drinks/master-cleanser\""
}
From 5edf3ae9837ae32e4c4a4eeca2135a7bd6821481 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 24 Sep 2008 22:14:40 -0500
Subject: [PATCH 14/25] Fix unit test for macros.expander
---
basis/macros/expander/expander-tests.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/macros/expander/expander-tests.factor b/basis/macros/expander/expander-tests.factor
index 8e6d8bc4b4..af67ac5639 100644
--- a/basis/macros/expander/expander-tests.factor
+++ b/basis/macros/expander/expander-tests.factor
@@ -1,6 +1,6 @@
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
From 2e5273df527426a56282133027035054b6470460 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 24 Sep 2008 22:22:36 -0500
Subject: [PATCH 15/25] xmodes now can't contain whitespace. [ factor { 1 2 3
}] prints literally instead of getting syntax-highlighted
---
basis/farkup/farkup-tests.factor | 3 +++
basis/farkup/farkup.factor | 3 ++-
2 files changed, 5 insertions(+), 1 deletion(-)
diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor
index 9120ec97f9..f136ec91d4 100644
--- a/basis/farkup/farkup-tests.factor
+++ b/basis/farkup/farkup-tests.factor
@@ -141,3 +141,6 @@ link-no-follow? off
[ "<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
diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor
index ec49655d5a..37233447bc 100644
--- a/basis/farkup/farkup.factor
+++ b/basis/farkup/farkup.factor
@@ -38,6 +38,7 @@ TUPLE: line ;
EBNF: parse-farkup
nl = ("\r\n" | "\r" | "\n") => [[ drop "\n" ]]
+whitespace = " " | "\t" | nl
heading1 = "=" (!("=" | nl).)+ "="
=> [[ second >string heading1 boa ]]
@@ -133,7 +134,7 @@ line = '___'
=> [[ drop line new ]]
-named-code = '[' (!('{' | nl | '[').)+ '{' (!("}]").)+ "}]"
+named-code = '[' (!('{' | whitespace | '[').)+ '{' (!("}]").)+ "}]"
=> [[ [ second >string ] [ fourth >string ] bi code boa ]]
simple-code
From 5be907e85724a18aeebf046cdcface0dce5130d3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 24 Sep 2008 22:24:34 -0500
Subject: [PATCH 16/25] fix potential infinite loop, minor docs updates
---
basis/db/db-docs.factor | 2 +-
basis/db/db.factor | 7 +++-
basis/db/tuples/tuples-tests.factor | 1 +
basis/db/types/types-docs.factor | 58 +++++++++++------------------
basis/db/types/types.factor | 4 +-
5 files changed, 30 insertions(+), 42 deletions(-)
diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor
index 244555b93e..d726f48efe 100644
--- a/basis/db/db-docs.factor
+++ b/basis/db/db-docs.factor
@@ -116,7 +116,7 @@ HELP: execute-statement*
HELP: execute-statement
{ $values { "statement" statement } }
-{ $description } ;
+{ $description "" } ;
ARTICLE: "db" "Database library"
{ $subsection "db-custom-database-combinators" }
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/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor
index e8e7fdacf3..4b1e49c76e 100755
--- a/basis/db/tuples/tuples-tests.factor
+++ b/basis/db/tuples/tuples-tests.factor
@@ -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 ] [ <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
! [ ] [ query ] unit-test
;
diff --git a/basis/db/types/types-docs.factor b/basis/db/types/types-docs.factor
index 9300a68f2e..a7e230079c 100644
--- a/basis/db/types/types-docs.factor
+++ b/basis/db/types/types-docs.factor
@@ -1,14 +1,8 @@
! 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 db.tuples math ;
IN: db.types
-HELP: (lookup-type)
-{ $values
- { "obj" object }
- { "string" string } }
-{ $description "" } ;
-
HELP: +autoincrement+
{ $description "" } ;
@@ -55,7 +49,7 @@ HELP: <low-level-binding>
{ $description "" } ;
HELP: BIG-INTEGER
-{ $description "A 64-bit integer." } ;
+{ $description "A 64-bit integer. Whether this number is signed or unsigned depends on the database backend." } ;
HELP: BLOB
{ $description "A serialized Factor object. The database library automatically serializes the object for a SQL insert or update and deserializes it on a tuple query." } ;
@@ -73,13 +67,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 +88,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 +131,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 that was defined by " { $link define-persistent } "." }
+{ $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 +189,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 +279,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 -- )
From 37130f911cb26f4513ee876b47bc6162d247458f Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 24 Sep 2008 22:39:38 -0500
Subject: [PATCH 17/25] allow horizontal lines in paragraphs if they start at
the beginning of a line
---
basis/farkup/farkup-tests.factor | 6 ++++++
basis/farkup/farkup.factor | 2 +-
2 files changed, 7 insertions(+), 1 deletion(-)
diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor
index f136ec91d4..693c559ac5 100644
--- a/basis/farkup/farkup-tests.factor
+++ b/basis/farkup/farkup-tests.factor
@@ -144,3 +144,9 @@ link-no-follow? off
[ "<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
diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor
index 37233447bc..7844cf8f41 100644
--- a/basis/farkup/farkup.factor
+++ b/basis/farkup/farkup.factor
@@ -108,7 +108,7 @@ table = ((table-row nl => [[ first ]] )+ table-row? | table-row)
text = (!(nl | code | heading | inline-delimiter | table ).)+
=> [[ >string ]]
-paragraph-item = (table | nl list | code | 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)
From e56d49334e031689e09d4a9361e7f5cf03403ad8 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 24 Sep 2008 22:40:05 -0500
Subject: [PATCH 18/25] add a horizontal line demo
---
extra/webapps/wiki/initial-content/Farkup.txt | 4 ++++
1 file changed, 4 insertions(+)
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|
From 2057e643e733d810cfe99b57b43e6f06c2d3a671 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 25 Sep 2008 00:05:41 -0500
Subject: [PATCH 19/25] more docs, fix circular vocabs
---
basis/db/db-docs.factor | 151 +++++++++++++++++++++++++++--
basis/db/tuples/tuples-docs.factor | 2 +-
basis/db/tuples/tuples.factor | 2 +-
basis/db/types/types-docs.factor | 5 +-
4 files changed, 148 insertions(+), 12 deletions(-)
diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor
index d726f48efe..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,32 +110,119 @@ 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 "" } ;
+
+
+
+
+
+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" }
@@ -135,6 +237,40 @@ ARTICLE: "db" "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."
;
@@ -157,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/tuples/tuples-docs.factor b/basis/db/tuples/tuples-docs.factor
index ec43ffe616..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
diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor
index 862e28d58e..4ecff74c10 100755
--- a/basis/db/tuples/tuples.factor
+++ b/basis/db/tuples/tuples.factor
@@ -3,7 +3,7 @@
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
<PRIVATE
diff --git a/basis/db/types/types-docs.factor b/basis/db/types/types-docs.factor
index a7e230079c..590a2e432f 100644
--- a/basis/db/types/types-docs.factor
+++ b/basis/db/types/types-docs.factor
@@ -1,6 +1,7 @@
! 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 db.tuples math ;
+USING: classes hashtables help.markup help.syntax io.streams.string
+kernel sequences strings math ;
IN: db.types
HELP: +autoincrement+
@@ -133,7 +134,7 @@ HELP: find-primary-key
{ $values
{ "specs" "an array of sql-specs" }
{ "obj" object } }
-{ $description "Returns the row from the sql-specs array that was defined by " { $link define-persistent } "." }
+{ $description "Returns the row from the sql-specs array." }
{ $notes "This is a low-level word." } ;
HELP: generator-bind
From bfbe5b8b92fbd39f7049c9c20190c572a6d4e927 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 25 Sep 2008 02:46:21 -0500
Subject: [PATCH 20/25] Yet-another HTTP cookie date format... how many
variations are there?
---
basis/calendar/format/format-tests.factor | 12 ++++++++++++
basis/calendar/format/format.factor | 8 ++++++--
2 files changed, 18 insertions(+), 2 deletions(-)
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
From cbd40b71d4474b423c54bcf6326d0882e76562b0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 25 Sep 2008 02:46:37 -0500
Subject: [PATCH 21/25] Fixing URL docs, http docs
---
basis/http/http-docs.factor | 160 +++++++++++++++++++++++++++++++++++
basis/urls/urls-docs.factor | 15 ++--
basis/urls/urls-tests.factor | 16 ++--
basis/urls/urls.factor | 9 +-
4 files changed, 183 insertions(+), 17 deletions(-)
create mode 100644 basis/http/http-docs.factor
diff --git a/basis/http/http-docs.factor b/basis/http/http-docs.factor
new file mode 100644
index 0000000000..100d6c5f06
--- /dev/null
+++ b/basis/http/http-docs.factor
@@ -0,0 +1,160 @@
+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 implementation"
+"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" } ;
+
+ABOUT: "http"
diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor
index 5d9500788b..c96ecc1f29 100644
--- a/basis/urls/urls-docs.factor
+++ b/basis/urls/urls-docs.factor
@@ -17,9 +17,9 @@ HELP: >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 io urls ;"
+ "USING: accessors prettyprint urls ;"
"\"http://www.apple.com\" >url ."
- "URL\" www.apple.com/\""
+ "URL\" http://www.apple.com/\""
}
"We can examine the URL object:"
{ $example
@@ -27,9 +27,9 @@ HELP: >url
"\"http://www.apple.com\" >url host>> print"
"www.apple.com"
}
- "A relative URL does not have a protocol or host component:"
+ "A relative URL does not have a protocol, host or port:"
{ $example
- "USING: accessors io urls ;"
+ "USING: accessors prettyprint urls ;"
"\"file.txt\" >url protocol>> ."
"f"
}
@@ -47,13 +47,12 @@ HELP: URL"
} ;
HELP: assoc>query
-{ $values
- { "hash" hashtable }
- { "str" string } }
+{ $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"
@@ -134,7 +133,7 @@ HELP: query-param
"USING: io urls ;"
"URL\" http://food.com/calories?item=French+Fries\""
"\"item\" query-param print"
- "\"French Fries\""
+ "French Fries"
}
} ;
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 b8b87a92bd..17b309f37f 100644
--- a/basis/urls/urls.factor
+++ b/basis/urls/urls.factor
@@ -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 ] [
From 736974fe150a0d9601c9e7dcce0f85e435177f6f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 25 Sep 2008 03:37:48 -0500
Subject: [PATCH 22/25] Fix PEG tests for multiline changes
---
extra/peg/javascript/parser/parser-tests.factor | 6 ++----
extra/peg/pl0/pl0-tests.factor | 3 +--
2 files changed, 3 insertions(+), 6 deletions(-)
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 } [
From 9cbe0b73ee93a0513ab642c17c28b9287754856e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 25 Sep 2008 04:47:42 -0500
Subject: [PATCH 23/25] http.client docs
---
basis/http/client/client-docs.factor | 93 ++++++++++++++++++++++++++++
basis/http/client/client.factor | 2 +-
basis/http/http-docs.factor | 5 +-
basis/urls/urls-docs.factor | 4 +-
4 files changed, 99 insertions(+), 5 deletions(-)
create mode 100644 basis/http/client/client-docs.factor
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: <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"
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
index 100d6c5f06..3261f9aa27 100644
--- a/basis/http/http-docs.factor
+++ b/basis/http/http-docs.factor
@@ -137,7 +137,7 @@ ARTICLE: "http.post-data" "HTTP post data"
{ $subsection post-data }
{ $subsection <post-data> } ;
-ARTICLE: "http" "HTTP protocol implementation"
+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."
@@ -155,6 +155,7 @@ $nl
{ $subsection <raw-response> }
"Both requests and responses support some common functionality:"
{ $subsection "http.headers" }
-{ $subsection "http.cookies" } ;
+{ $subsection "http.cookies" }
+{ $see-also "urls" } ;
ABOUT: "http"
diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor
index c96ecc1f29..166ad9d586 100644
--- a/basis/urls/urls-docs.factor
+++ b/basis/urls/urls-docs.factor
@@ -218,8 +218,8 @@ ARTICLE: "url-utilities" "URL implementation utilities"
{ $subsection secure-protocol? }
{ $subsection url-append-path } ;
-ARTICLE: "urls" "URLs"
-"The " { $vocab-link "urls" } " 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."
+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
From f91b8ead3b126488aea4e5556d271324b1875a76 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 25 Sep 2008 05:35:48 -0500
Subject: [PATCH 24/25] Fix typo
---
core/syntax/syntax-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
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" }
From b85a0252d765af22ec038fdc437ae253265ee8e7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 25 Sep 2008 05:41:35 -0500
Subject: [PATCH 25/25] Fix typo
---
basis/locals/locals-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
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