steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Slava Pestov 2009-07-09 06:40:52 -05:00
parent 128c6c8e03 b1e91e10e6
commit 93195e2914
8 changed files with 66 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/urls/encoding/encoding.factor
View File

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

15
extra/bson/reader/reader.factor
View File

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

15
extra/bson/writer/writer.factor
View File

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

2
extra/mongodb/benchmark/benchmark.factor
View File

@ -163,7 +163,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
[ create-collection ] keep ; [ create-collection ] keep ;
: prepare-index ( collection -- ) : 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: ( -- ) ) : insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
prepare-collection prepare-collection

10
extra/mongodb/connection/connection.factor
View File

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

2
extra/mongodb/driver/driver-docs.factor
View File

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

69
extra/mongodb/driver/driver.factor
View File

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

2
extra/mongodb/tuple/collection/collection.factor
View File

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