Delete empty unit tests files, remove 1- and 1+, reorder IN: lines in a lot of places...

[factor.git] / basis / urls / encoding / encoding.factor

diff --git a/basis/urls/encoding/encoding.factor b/basis/urls/encoding/encoding.factor
index f621384ede3d77c4a9349bd559ae120f1128db44..f87c21d2ffbdd9e6acb167388d2f6c833d7c1a37 100644 (file)
--- a/basis/urls/encoding/encoding.factor
+++ b/basis/urls/encoding/encoding.factor
@@ -14,11 +14,30 @@ IN: urls.encoding
         [ "/_-.:" member? ]
     } 1|| ; foldable
 
+! see http://tools.ietf.org/html/rfc3986#section-2.2
+: gen-delim? ( ch -- ? )
+    ":/?#[]@" member? ; foldable
+
+: sub-delim? ( ch -- ? )
+    "!$&'()*+,;=" member? ; foldable
+
+: reserved? ( ch -- ? )
+    [ gen-delim? ] [ sub-delim? ] bi or ; foldable
+
+! see http://tools.ietf.org/html/rfc3986#section-2.3
+: unreserved? ( ch -- ? )
+    {
+        [ letter? ]
+        [ LETTER? ]
+        [ digit? ]
+        [ "-._~" member? ]
+    } 1|| ; foldable
+
 <PRIVATE
 
 : push-utf8 ( ch -- )
     1string utf8 encode
-    [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
+    [ CHAR: % , >hex >upper 2 CHAR: 0 pad-head % ] each ;
 
 PRIVATE>
 
@@ -27,13 +46,18 @@ PRIVATE>
         [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
     ] "" make ;
 
+: url-encode-full ( str -- encoded )
+    [
+        [ dup unreserved? [ , ] [ push-utf8 ] if ] each
+    ] "" make ;
+
 <PRIVATE
 
 : url-decode-hex ( index str -- )
     2dup length 2 - >= [
         2drop
     ] [
-        [ 1+ dup 2 + ] dip subseq  hex> [ , ] when*
+        [ 1 + dup 2 + ] dip subseq  hex> [ , ] when*
     ] if ;
 
 : url-decode-% ( index str -- index str )
@@ -46,7 +70,7 @@ PRIVATE>
         2dup nth dup CHAR: % = [
             drop url-decode-% [ 3 + ] dip
         ] [
-            , [ 1+ ] dip
+            , [ 1 + ] dip
         ] if url-decode-iter
     ] if ;
 
@@ -72,6 +96,15 @@ PRIVATE>
         ] when*
     ] 2keep set-at ;
 
+: assoc-strings ( assoc -- assoc' )
+    [
+        {
+            { [ dup not ] [ ] }
+            { [ dup array? ] [ [ present ] map ] }
+            [ present 1array ]
+        } cond
+    ] assoc-map ;
+
 PRIVATE>
 
 : query>assoc ( query -- assoc )
@@ -86,11 +119,8 @@ PRIVATE>
 
 : assoc>query ( assoc -- str )
     [
-        dup array? [ [ present ] map ] [ present 1array ] if
-    ] assoc-map
-    [
-        [
+        assoc-strings [
             [ url-encode ] dip
-            [ url-encode "=" glue , ] with each
+            [ [ url-encode "=" glue , ] with each ] [ , ] if*
         ] assoc-each
     ] { } make "&" join ;