Merge branch 'for-slava' of git://github.com/x6j8x/factor

basis/urls/encoding/encoding.factor

@@ -37,7 +37,7 @@ IN: urls.encoding
 
 : push-utf8 ( ch -- )
     1string utf8 encode
-    [ CHAR: % , >hex 2 CHAR: 0 pad-head % ] each ;
+    [ CHAR: % , >hex >upper 2 CHAR: 0 pad-head % ] each ;
 
 PRIVATE>
 

extra/bson/reader/reader.factor

@@ -1,6 +1,6 @@
-USING: accessors assocs bson.constants byte-arrays byte-vectors fry io
-io.binary io.encodings.string io.encodings.utf8 kernel math namespaces
-sequences serialize arrays calendar io.encodings ;
+USING: accessors assocs bson.constants calendar fry io io.binary
+io.encodings io.encodings.utf8 kernel math math.bitwise namespaces
+sequences serialize ;
 
 FROM: kernel.private => declare ;
 FROM: io.encodings.private => (read-until) ;
@@ -44,20 +44,17 @@ GENERIC: element-read ( type -- cont? )
 GENERIC: element-data-read ( type -- object )
 GENERIC: element-binary-read ( length type -- object )
 
-: byte-array>number ( seq -- number )
-    byte-array>bignum >integer ; inline
-
 : get-state ( -- state )
     state get ; inline
 
 : read-int32 ( -- int32 )
-    4 read byte-array>number ; inline
+    4 read signed-le> ; inline
 
 : read-longlong ( -- longlong )
-    8 read byte-array>number ; inline
+    8 read signed-le> ; inline
 
 : read-double ( -- double )
-    8 read byte-array>number bits>double ; inline
+    8 read le> bits>double ; inline
 
 : read-byte-raw ( -- byte-raw )
     1 read ; inline

extra/bson/writer/writer.factor

@@ -75,24 +75,23 @@ M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
 
 : write-utf8-string ( string -- ) output-stream get '[ _ swap char>utf8 ] each ; inline
 
-: write-byte ( byte -- ) CHAR-SIZE >le write ; inline
 : write-int32 ( int -- ) INT32-SIZE >le write ; inline
 : write-double ( real -- ) double>bits INT64-SIZE >le write ; inline
-: write-cstring ( string -- ) write-utf8-string 0 write-byte ; inline
+: write-cstring ( string -- ) write-utf8-string 0 write1 ; inline
 : write-longlong ( object -- ) INT64-SIZE >le write ; inline
 
-: write-eoo ( -- ) T_EOO write-byte ; inline
-: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline
+: write-eoo ( -- ) T_EOO write1 ; inline
+: write-type ( obj -- obj ) [ bson-type? write1 ] keep ; inline
 : write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline
 
 M: string bson-write ( obj -- )
     '[ _ write-cstring ] with-length-prefix-excl ;
 
 M: f bson-write ( f -- )
-    drop 0 write-byte ; 
+    drop 0 write1 ; 
 
 M: t bson-write ( t -- )
-    drop 1 write-byte ;
+    drop 1 write1 ;
 
 M: integer bson-write ( num -- )
     write-int32 ;
@@ -105,7 +104,7 @@ M: timestamp bson-write ( timestamp -- )
 
 M: byte-array bson-write ( binary -- )
     [ length write-int32 ] keep
-    T_Binary_Bytes write-byte
+    T_Binary_Bytes write1
     write ; 
 
 M: oid bson-write ( oid -- )
@@ -134,7 +133,7 @@ M: assoc bson-write ( assoc -- )
 
 : (serialize-code) ( code -- )
     object>bytes [ length write-int32 ] keep
-    T_Binary_Custom write-byte
+    T_Binary_Custom write1
     write ;
 
 M: quotation bson-write ( quotation -- )

extra/mongodb/benchmark/benchmark.factor

@@ -163,7 +163,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
     [ create-collection ] keep ; 
 
 : prepare-index ( collection -- )
-    "_x_idx" [ "x" asc ] key-spec <index-spec> unique-index ensure-index ; 
+    "_x_idx" [ "x" asc ] key-spec <index-spec> t >>unique? ensure-index ; 
 
 : insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
     prepare-collection

extra/mongodb/connection/connection.factor

@@ -1,6 +1,6 @@
 USING: accessors assocs fry io.encodings.binary io.sockets kernel math
 math.parser mongodb.msg mongodb.operations namespaces destructors
-constructors sequences splitting checksums checksums.md5 formatting
+constructors sequences splitting checksums checksums.md5 
 io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart
 arrays hashtables sequences.deep vectors locals ;
 
@@ -39,16 +39,16 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
     mdb-connection get instance>> ; inline
 
 : index-collection ( -- ns )
-    mdb-instance name>> "%s.system.indexes" sprintf ; inline
+    mdb-instance name>> "system.indexes" 2array "." join ; inline
 
 : namespaces-collection ( -- ns )
-    mdb-instance name>> "%s.system.namespaces" sprintf ; inline
+    mdb-instance name>> "system.namespaces" 2array "." join ; inline
 
 : cmd-collection ( -- ns )
-    mdb-instance name>> "%s.$cmd" sprintf ; inline
+    mdb-instance name>> "$cmd" 2array "." join ; inline
 
 : index-ns ( colname -- index-ns )
-    [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline
+    [ mdb-instance name>> ] dip 2array "." join ; inline
 
 : send-message ( message -- )
     [ mdb-connection get handle>> ] dip '[ _ write-message ] with-stream* ;

extra/mongodb/driver/driver-docs.factor

@@ -131,7 +131,7 @@ HELP: ensure-index
     "\"db\" \"127.0.0.1\" 27017 <mdb>"
     "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> ensure-index ] with-db" "" }
   { $unchecked-example  "USING: mongodb.driver ;"
-    "\"db\" \"127.0.0.1\" 27017 <mdb>" "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> unique-index ensure-index ] with-db" "" } } ;
+    "\"db\" \"127.0.0.1\" 27017 <mdb>" "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> t >>unique? ensure-index ] with-db" "" } } ;
 
 HELP: explain.
 { $values

extra/mongodb/driver/driver.factor

@@ -1,8 +1,8 @@
-USING: accessors assocs bson.constants bson.writer combinators combinators.smart
-constructors continuations destructors formatting fry io io.pools
-io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs hashtables
-namespaces parser prettyprint sequences sets splitting strings uuid arrays
-math math.parser memoize mongodb.connection mongodb.msg mongodb.operations  ;
+USING: accessors arrays assocs bson.constants combinators
+combinators.smart constructors destructors formatting fry hashtables
+io io.pools io.sockets kernel linked-assocs math mongodb.connection
+mongodb.msg parser prettyprint sequences sets splitting strings
+tools.continuations uuid memoize locals ;
 
 IN: mongodb.driver
 
@@ -23,9 +23,6 @@ TUPLE: index-spec
 
 CONSTRUCTOR: index-spec ( ns name key -- index-spec ) ;
 
-: unique-index ( index-spec -- index-spec )
-    t >>unique? ;
-
 M: mdb-pool make-connection
     mdb>> mdb-open ;
 
@@ -83,6 +80,15 @@ M: mdb-getmore-msg verify-query-result
     [ make-cursor ] 2tri
     swap objects>> ;
 
+: make-collection-assoc ( collection assoc -- )
+    [ [ name>> "create" ] dip set-at ]
+    [ [ [ capped>> ] keep ] dip
+      '[ _ _
+         [ [ drop t "capped" ] dip set-at ]
+         [ [ size>> "size" ] dip set-at ]
+         [ [ max>> "max" ] dip set-at ] 2tri ] when
+    ] 2bi ; 
+
 PRIVATE>
 
 SYNTAX: r/ ( token -- mdbregexp )
@@ -100,23 +106,17 @@ SYNTAX: r/ ( token -- mdbregexp )
    H{ } clone [ set-at ] keep <mdb-db>
    [ verify-nodes ] keep ;
 
-GENERIC: create-collection ( name -- )
+GENERIC: create-collection ( name/collection -- )
 
 M: string create-collection
     <mdb-collection> create-collection ;
 
 M: mdb-collection create-collection
-    [ cmd-collection ] dip
-    <linked-hash> [
-        [ [ name>> "create" ] dip set-at ]
-        [ [ [ capped>> ] keep ] dip
-          '[ _ _
-             [ [ drop t "capped" ] dip set-at ]
-             [ [ size>> "size" ] dip set-at ]
-             [ [ max>> "max" ] dip set-at ] 2tri ] when
-        ] 2bi
-    ] keep <mdb-query-msg> 1 >>return# send-query-plain drop ;
-
+    [ [ cmd-collection ] dip
+      <linked-hash> [ make-collection-assoc ] keep
+      <mdb-query-msg> 1 >>return# send-query-plain drop ] keep
+      [ ] [ name>> ] bi mdb-instance collections>> set-at ;
+  
 : load-collection-list ( -- collection-list )
     namespaces-collection
     H{ } clone <mdb-query-msg> send-query-plain objects>> ;
@@ -125,27 +125,36 @@ M: mdb-collection create-collection
 
 : ensure-valid-collection-name ( collection -- )
     [ ";$." intersect length 0 > ] keep
-    '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline
+    '[ _ "contains invalid characters ( . $ ; )" 2array "." join throw ] when ; inline
 
-: (ensure-collection) ( collection --  )
-    mdb-instance collections>> dup keys length 0 = 
-    [ load-collection-list      
-      [ [ "options" ] dip key? ] filter
-      [ [ "name" ] dip at "." split second <mdb-collection> ] map
-      over '[ [ ] [ name>> ] bi _ set-at ] each ] [ ] if
-    [ dup ] dip key? [ drop ]
-    [ [ ensure-valid-collection-name ] keep create-collection ] if ; 
+: build-collection-map ( -- assoc )
+    H{ } clone load-collection-list      
+    [ [ "name" ] dip at "." split second <mdb-collection> ] map
+    over '[ [ ] [ name>> ] bi _ set-at ] each ;
 
+: ensure-collection-map ( mdb-instance -- assoc )
+    dup collections>> dup keys length 0 = 
+    [ drop build-collection-map [ >>collections drop ] keep ]
+    [ nip ] if ; 
+
+: (ensure-collection) ( collection mdb-instance -- collection )
+    ensure-collection-map [ dup ] dip key?
+    [ ] [ [ ensure-valid-collection-name ]
+          [ create-collection ]
+          [ ] tri ] if ; 
+      
 : reserved-namespace? ( name -- ? )
     [ "$cmd" = ] [ "system" head? ] bi or ;
 
 : check-collection ( collection -- fq-collection )
-    dup mdb-collection? [ name>> ] when
-    "." split1 over mdb-instance name>> =
-    [ nip ] [ drop ] if
-    [ ] [ reserved-namespace? ] bi
-    [ [ (ensure-collection) ] keep ] unless
-    [ mdb-instance name>> ] dip "%s.%s" sprintf ; 
+    [let* | instance [ mdb-instance ]
+            instance-name [ instance name>> ] |        
+        dup mdb-collection? [ name>> ] when
+        "." split1 over instance-name =
+        [ nip ] [ drop ] if
+        [ ] [ reserved-namespace? ] bi
+        [ instance (ensure-collection) ] unless
+        [ instance-name ] dip 2array "." join ] ; 
 
 : fix-query-collection ( mdb-query -- mdb-query )
     [ check-collection ] change-collection ; inline

extra/mongodb/tuple/collection/collection.factor

@@ -88,7 +88,7 @@ GENERIC: mdb-index-map ( tuple -- sequence )
 : user-defined-key-index ( class -- assoc )
     mdb-slot-map user-defined-key
     [ drop [ "user-defined-key-index" 1 ] dip
-      H{ } clone [ set-at ] keep <tuple-index> unique-index
+      H{ } clone [ set-at ] keep <tuple-index> t >>unique?
       [ ] [ name>> ] bi  H{ } clone [ set-at ] keep
     ] [ 2drop H{ } clone ] if ;