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

basis/farkup/farkup.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators html.elements io
-io.streams.string kernel math memoize namespaces peg peg.ebnf
+io.streams.string kernel math namespaces peg peg.ebnf
 sequences sequences.deep strings xml.entities
-vectors splitting xmode.code2html urls ;
+vectors splitting xmode.code2html urls.encoding ;
 IN: farkup
 
 SYMBOL: relative-link-prefix

basis/furnace/boilerplate/boilerplate.factor

@@ -17,16 +17,13 @@ TUPLE: boilerplate < filter-responder template init ;
         [ ] >>init ;
 
 : wrap-boilerplate? ( response -- ? )
-    {
+    { [ code>> 200 = ] [ content-type>> "text/html" = ] } 1&& ;
-        [ code>> { [ 200 = ] [ 400 499 between? ] } 1|| ]
-        [ content-type>> "text/html" = ]
-    } 1&& ;
 
 M:: boilerplate call-responder* ( path responder -- )
     begin-form
     path responder call-next-method
     responder init>> call
-    dup content-type>> "text/html" = [
+    dup wrap-boilerplate? [
         clone [| body |
             [
                 body

basis/help/html/html.factor

@@ -29,21 +29,28 @@ IN: help.html
 
 GENERIC: topic>filename* ( topic -- name prefix )
 
-M: word topic>filename* [ name>> ] [ vocabulary>> ] bi 2array "word" ;
+M: word topic>filename*
-M: link topic>filename* name>> "article" ;
+    dup vocabulary>> [
+        [ name>> ] [ vocabulary>> ] bi 2array "word"
+    ] [ drop f f ] if ;
+
+M: link topic>filename* name>> dup [ "article" ] [ topic>filename* ] if ;
 M: word-link topic>filename* name>> topic>filename* ;
 M: vocab-spec topic>filename* vocab-name "vocab" ;
 M: vocab-tag topic>filename* name>> "tag" ;
 M: vocab-author topic>filename* name>> "author" ;
+M: f topic>filename* drop \ f topic>filename* ;
 
 : topic>filename ( topic -- filename )
-    [
+    topic>filename* dup [
-        topic>filename* % "-" %
+        [
-        dup array?
+            % "-" %
-        [ [ escape-filename ] map "," join ]
+            dup array?
-        [ escape-filename ]
+            [ [ escape-filename ] map "," join ]
-        if % ".html" %
+            [ escape-filename ]
-    ] "" make ;
+            if % ".html" %
+        ] "" make
+    ] [ 2drop f ] if ;
 
 M: topic browser-link-href topic>filename ;
 

basis/html/components/components-tests.factor

@@ -134,7 +134,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
 [ ] [ link-test "link" set-value ] unit-test
 
 [ "<a href='http://www.apple.com/foo&amp;bar'>&lt;Link Title&gt;</a>" ] [
-    [ "link" link render ] with-string-writer
+    [ "link" link new render ] with-string-writer
 ] unit-test
 
 [ ] [

basis/html/streams/streams.factor

@@ -4,7 +4,7 @@ USING: combinators generic assocs help http io io.styles
 io.files continuations io.streams.string kernel math math.order
 math.parser namespaces make quotations assocs sequences strings
 words html.elements xml.entities sbufs continuations destructors
-accessors arrays ;
+accessors arrays urls.encoding ;
 IN: html.streams
 
 GENERIC: browser-link-href ( presented -- href )
@@ -44,12 +44,14 @@ TUPLE: html-sub-stream < html-stream style parent ;
 : object-link-tag ( style quot -- )
     presented pick at [
         browser-link-href [
-            <a =href a> call </a>
+            <a url-encode =href a> call </a>
         ] [ call ] if*
     ] [ call ] if* ; inline
 
 : href-link-tag ( style quot -- )
-    href pick at [ <a =href a> call </a> ] [ call ] if* ; inline
+    href pick at [
+        <a url-encode =href a> call </a>
+    ] [ call ] if* ; inline
 
 : hex-color, ( color -- )
     [ red>> ] [ green>> ] [ blue>> ] tri

basis/http/client/client-docs.factor

@@ -1,6 +1,6 @@
 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 ;
+urls.encoding byte-arrays strings assocs sequences ;
 IN: http.client
 
 HELP: download-failed

basis/http/client/client.factor

@@ -10,7 +10,7 @@ io.encodings.ascii
 io.encodings.8-bit
 io.encodings.binary
 io.streams.duplex
-fry debugger summary ascii urls present
+fry debugger summary ascii urls urls.encoding present
 http http.parsers ;
 IN: http.client
 

basis/http/server/cgi/cgi.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces kernel assocs io.files io.streams.duplex
 combinators arrays io.launcher io http.server.static http.server
-http accessors sequences strings math.parser fry urls ;
+http accessors sequences strings math.parser fry urls
+urls.encoding ;
 IN: http.server.cgi
 
 : cgi-variables ( script-path -- assoc )

basis/http/server/server.factor

@@ -14,7 +14,7 @@ io.encodings.binary
 io.streams.limited
 io.servers.connection
 io.timeouts
-fry logging logging.insomniac calendar urls
+fry logging logging.insomniac calendar urls urls.encoding
 http
 http.parsers
 http.server.responses

basis/prettyprint/prettyprint.factor

@@ -229,7 +229,7 @@ M: word declarations.
 
 : pprint-; ( -- ) \ ; pprint-word ;
 
-: (see) ( spec -- )
+M: object see
     [
         12 nesting-limit set
         100 length-limit set
@@ -237,10 +237,7 @@ M: word declarations.
         <block dup definition pprint-elements block>
         dup definer nip [ pprint-word ] when* declarations.
         block>
-    ] with-scope ;
+    ] with-use nl ;
-
-M: object see
-    [ (see) ] with-use nl ;
 
 GENERIC: see-class* ( word -- )
 
@@ -328,10 +325,8 @@ M: word see
     dup class? over symbol? not and [
         nl
     ] when
-    dup class? over symbol? and not [
+    dup [ class? ] [ symbol? ] bi and
-        [ dup (see) ] with-use nl
+    [ drop ] [ call-next-method ] if ;
-    ] when
-    drop ;
 
 : see-all ( seq -- )
     natural-sort [ nl ] [ see ] interleave ;

basis/urls/encoding/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/urls/encoding/encoding-docs.factor

@@ -0,0 +1,57 @@
+IN: urls.encoding
+USING: strings help.markup help.syntax assocs multiline ;
+
+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." } ;
+
+HELP: assoc>query
+{ $values { "assoc" assoc } { "str" string } }
+{ $description "Converts an assoc of query parameters into a query string, performing URL encoding." }
+{ $notes "This word is used by the implementation of " { $link "urls" } ". It is also used by the HTTP client to encode POST requests." }
+{ $examples
+    { $example
+        "USING: io urls ;"
+        "{ { \"from\" \"Lead\" } { \"to\" \"Gold, please\" } }"
+        "assoc>query print"
+        "from=Lead&to=Gold%2c+please"
+    }
+} ;
+
+HELP: query>assoc
+{ $values { "query" string } { "assoc" assoc } }
+{ $description "Parses a URL query string and URL-decodes each component." }
+{ $notes "This word is used by the implementation of " { $link "urls" } ". 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" }
+}">
+    }
+} ;
+
+ARTICLE: "url-encoding" "URL encoding and decoding"
+"URL encoding and decoding strings:"
+{ $subsection url-encode }
+{ $subsection url-decode }
+{ $subsection url-quotable? }
+"Encoding and decoding queries:"
+{ $subsection assoc>query }
+{ $subsection query>assoc }
+"See " { $url "http://en.wikipedia.org/wiki/Percent-encoding" } " for a description of URL encoding." ;
+
+ABOUT: "url-encoding"

basis/urls/encoding/encoding-tests.factor

@@ -0,0 +1,26 @@
+IN: urls.encoding.tests
+USING: urls.encoding tools.test arrays kernel assocs present accessors ;
+
+[ "~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%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
+
+[ "hello world" ] [ "hello+world" query-decode ] unit-test
+
+[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
+
+[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test
+
+[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test
+
+[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
+
+[ H{ { "text" "hello world" } } ] [ "text=hello+world" query>assoc ] unit-test
+
+[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test

basis/urls/encoding/encoding.factor

@@ -0,0 +1,96 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel ascii combinators combinators.short-circuit
+sequences splitting fry namespaces make assocs arrays strings
+io.sockets io.sockets.secure io.encodings.string
+io.encodings.utf8 math math.parser accessors hashtables present ;
+IN: urls.encoding
+
+: url-quotable? ( ch -- ? )
+    {
+        [ letter? ]
+        [ LETTER? ]
+        [ digit? ]
+        [ "/_-.:" member? ]
+    } 1|| ; foldable
+
+<PRIVATE
+
+: push-utf8 ( ch -- )
+    1string utf8 encode
+    [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
+
+PRIVATE>
+
+: url-encode ( str -- encoded )
+    [
+        [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
+    ] "" make ;
+
+<PRIVATE
+
+: url-decode-hex ( index str -- )
+    2dup length 2 - >= [
+        2drop
+    ] [
+        [ 1+ dup 2 + ] dip subseq  hex> [ , ] when*
+    ] if ;
+
+: url-decode-% ( index str -- index str )
+    2dup url-decode-hex ;
+
+: url-decode-iter ( index str -- )
+    2dup length >= [
+        2drop
+    ] [
+        2dup nth dup CHAR: % = [
+            drop url-decode-% [ 3 + ] dip
+        ] [
+            , [ 1+ ] dip
+        ] if url-decode-iter
+    ] if ;
+
+PRIVATE>
+
+: url-decode ( str -- decoded )
+    [ 0 swap url-decode-iter ] "" make utf8 decode ;
+
+: query-decode ( str -- decoded )
+    [ dup CHAR: + = [ drop "%20" ] [ 1string ] if ] { } map-as
+    concat url-decode ;
+
+<PRIVATE
+
+: add-query-param ( value key assoc -- )
+    [
+        at [
+            {
+                { [ dup string? ] [ swap 2array ] }
+                { [ dup array? ] [ swap suffix ] }
+                { [ dup not ] [ drop ] }
+            } cond
+        ] when*
+    ] 2keep set-at ;
+
+PRIVATE>
+
+: query>assoc ( query -- assoc )
+    dup [
+        "&" split H{ } clone [
+            [
+                [ "=" split1 [ dup [ query-decode ] when ] bi@ swap ] dip
+                add-query-param
+            ] curry each
+        ] keep
+    ] when ;
+
+: assoc>query ( assoc -- str )
+    [
+        dup array? [ [ present ] map ] [ present 1array ] if
+    ] assoc-map
+    [
+        [
+            [ url-encode ] dip
+            [ url-encode "=" swap 3append , ] with each
+        ] assoc-each
+    ] { } make "&" join ;

basis/urls/encoding/summary.txt

@@ -0,0 +1 @@
+URL and form encoding/decoding

basis/urls/encoding/tags.txt

@@ -0,0 +1 @@
+web

basis/urls/urls-docs.factor

@@ -46,37 +46,6 @@ HELP: URL"
     }
 } ;
 
-HELP: assoc>query
-{ $values { "assoc" assoc } { "str" string } }
-{ $description "Converts an assoc of query parameters into a query string, performing URL encoding." }
-{ $notes "This word is used to implement the " { $link present } " method on URLs; it is also used by the HTTP client to encode POST requests." }
-{ $examples
-    { $example
-        "USING: io urls ;"
-        "{ { \"from\" \"Lead\" } { \"to\" \"Gold, please\" } }"
-        "assoc>query print"
-        "from=Lead&to=Gold%2c+please"
-    }
-} ;
-
-HELP: query>assoc
-{ $values { "query" string } { "assoc" assoc } }
-{ $description "Parses a URL query string and URL-decodes each component." }
-{ $notes "This word is used to implement " { $link >url } ". It is also used by the HTTP server to parse POST requests." }
-{ $examples
-    { $unchecked-example
-        "USING: prettyprint urls ;"
-        "\"gender=female&agefrom=22&ageto=28&location=Omaha+NE\""
-        "query>assoc ."
-        <" H{
-    { "gender" "female" }
-    { "agefrom" "22" }
-    { "ageto" "28" }
-    { "location" "Omaha NE" }
-}">
-    }
-} ;
-
 HELP: derive-url
 { $values { "base" url } { "url" url } { "url'" url } }
 { $description "Builds a URL by filling in missing components of " { $snippet "url" } " from " { $snippet "base" } "." }
@@ -192,28 +161,7 @@ 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 } ;
@@ -240,8 +188,9 @@ $nl
 { $subsection set-query-param }
 "Creating " { $link "network-addressing" } " from URLs:"
 { $subsection url-addr }
-"Additional topics:"
+"The URL implemention encodes and decodes components of " { $link url } " instances automatically, but sometimes this functionality is needed for non-URL strings."
-{ $subsection "url-utilities" }
+{ $subsection "url-encoding" }
-{ $subsection "url-encoding" } ;
+"Utility words used by the URL implementation:"
+{ $subsection "url-utilities" } ;
 
 ABOUT: "urls"

basis/urls/urls-tests.factor

@@ -2,30 +2,6 @@ IN: urls.tests
 USING: urls urls.private tools.test
 arrays kernel assocs present accessors ;
 
-[ "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+world" ] [ "hello world"   url-encode ] unit-test
-[ "+%21+"       ] [ " ! "           url-encode ] unit-test
-
-[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
-
-[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test
-
-[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test
-
-[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
-
-[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
-
 : urls
     {
         {

basis/urls/urls.factor

@@ -5,99 +5,9 @@ sequences splitting fry namespaces make assocs arrays strings
 io.sockets io.sockets.secure io.encodings.string
 io.encodings.utf8 math math.parser accessors parser
 strings.parser lexer prettyprint.backend hashtables present
-peg.ebnf ;
+peg.ebnf urls.encoding ;
 IN: urls
 
-: url-quotable? ( ch -- ? )
-    {
-        [ letter? ]
-        [ LETTER? ]
-        [ digit? ]
-        [ "/_-.:" member? ]
-    } 1|| ; foldable
-
-<PRIVATE
-
-: push-utf8 ( ch -- )
-    dup CHAR: \s = [ drop "+" % ] [
-        1string utf8 encode
-        [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each
-    ] if ;
-
-PRIVATE>
-
-: url-encode ( str -- encoded )
-    [
-        [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
-    ] "" make ;
-
-<PRIVATE
-
-: url-decode-hex ( index str -- )
-    2dup length 2 - >= [
-        2drop
-    ] [
-        [ 1+ dup 2 + ] dip subseq  hex> [ , ] when*
-    ] if ;
-
-: url-decode-% ( index str -- index str )
-    2dup url-decode-hex [ 3 + ] dip ;
-
-: url-decode-+-or-other ( index str ch -- index str )
-    dup CHAR: + = [ drop CHAR: \s ] when , [ 1+ ] dip ;
-
-: url-decode-iter ( index str -- )
-    2dup length >= [
-        2drop
-    ] [
-        2dup nth dup CHAR: % = [
-            drop url-decode-%
-        ] [
-            url-decode-+-or-other
-        ] if url-decode-iter
-    ] if ;
-
-PRIVATE>
-
-: url-decode ( str -- decoded )
-    [ 0 swap url-decode-iter ] "" make utf8 decode ;
-
-<PRIVATE
-
-: add-query-param ( value key assoc -- )
-    [
-        at [
-            {
-                { [ dup string? ] [ swap 2array ] }
-                { [ dup array? ] [ swap suffix ] }
-                { [ dup not ] [ drop ] }
-            } cond
-        ] when*
-    ] 2keep set-at ;
-
-PRIVATE>
-
-: query>assoc ( query -- assoc )
-    dup [
-        "&" split H{ } clone [
-            [
-                [ "=" split1 [ dup [ url-decode ] when ] bi@ swap ] dip
-                add-query-param
-            ] curry each
-        ] keep
-    ] when ;
-
-: assoc>query ( assoc -- str )
-    [
-        dup array? [ [ present ] map ] [ present 1array ] if
-    ] assoc-map
-    [
-        [
-            [ url-encode ] dip
-            [ url-encode "=" swap 3append , ] with each
-        ] assoc-each
-    ] { } make "&" join ;
-
 TUPLE: url protocol username password host port path query anchor ;
 
 : <url> ( -- url ) url new ;

extra/html/parser/analyzer/analyzer.factor

@@ -3,7 +3,7 @@
 USING: assocs html.parser kernel math sequences strings ascii
 arrays generalizations shuffle unicode.case namespaces make
 splitting http accessors io combinators http.client urls
-fry sequences.lib ;
+urls.encoding fry sequences.lib ;
 IN: html.parser.analyzer
 
 TUPLE: link attributes clickable ;