From dc825d21c565c320d27354c8e2042d12c93881c9 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Tue, 16 Dec 2008 14:17:00 +0100 Subject: [PATCH 002/101] working round-trip bson (tuples - strings, numbers, other tuples as members ) >bson/bson> --- mongodb/bson/bson.factor | 7 ++ mongodb/bson/constants/constants.factor | 53 ++++++++++++ mongodb/bson/reader/reader.factor | 104 ++++++++++++++++++++++++ mongodb/bson/writer/writer.factor | 100 +++++++++++++++++++++++ 4 files changed, 264 insertions(+) create mode 100644 mongodb/bson/bson.factor create mode 100644 mongodb/bson/constants/constants.factor create mode 100644 mongodb/bson/reader/reader.factor create mode 100644 mongodb/bson/writer/writer.factor diff --git a/mongodb/bson/bson.factor b/mongodb/bson/bson.factor new file mode 100644 index 0000000000..f6cd002b48 --- /dev/null +++ b/mongodb/bson/bson.factor @@ -0,0 +1,7 @@ +IN: mongodb.bson +USE: vocabs.loader + +SINGLETON: bson-null + +"mongodb.bson.reader" require +"mongodb.bson.writer" require diff --git a/mongodb/bson/constants/constants.factor b/mongodb/bson/constants/constants.factor new file mode 100644 index 0000000000..9163d06ba4 --- /dev/null +++ b/mongodb/bson/constants/constants.factor @@ -0,0 +1,53 @@ +USING: alien.c-types ; + +IN: mongodb.bson.constants + + +: T_EOO ( -- type ) 0 ; inline +: T_Double ( -- type ) 1 ; inline +: T_Integer ( -- type ) 16 ; inline +: T_Boolean ( -- type ) 8 ; inline +: T_String ( -- type ) 2 ; inline +: T_Object ( -- type ) 3 ; inline +: T_Array ( -- type ) 4 ; inline +: T_Binary ( -- type ) 5 ; inline +: T_Undefined ( -- type ) 6 ; inline +: T_OID ( -- type ) 7 ; inline +: T_Date ( -- type ) 9 ; inline +: T_NULL ( -- type ) 10 ; inline +: T_Regexp ( -- type ) 11 ; inline +: T_DBRef ( -- type ) 12 ; inline +: T_Code ( -- type ) 13 ; inline +: T_ScopedCode ( -- type ) 17 ; inline +: T_Symbol ( -- type ) 14 ; inline +: T_JSTypeMax ( -- type ) 16 ; inline +: T_MaxKey ( -- type ) 127 ; inline + + + +! todo Move to mongo vocab + +: OP_Reply ( -- const ) + 1 ; inline + +: OP_Message ( -- const ) + 1000 ; inline + +: OP_Update ( -- const ) + 2001 ; inline + +: OP_Insert ( -- const ) + 2002 ; inline + +: OP_Query ( -- const ) + 2004 ; inline + +: OP_GetMore ( -- const ) + 2005 ; inline + +: OP_Delete ( -- const ) + 2006 ; inline + +: OP_KillCursors ( -- const ) + 2007 ; inline + \ No newline at end of file diff --git a/mongodb/bson/reader/reader.factor b/mongodb/bson/reader/reader.factor new file mode 100644 index 0000000000..abbb1a2c12 --- /dev/null +++ b/mongodb/bson/reader/reader.factor @@ -0,0 +1,104 @@ +USING: io io.encodings.utf8 io.encodings.binary math match kernel sequences + splitting accessors io.streams.byte-array namespaces prettyprint + mongodb.bson.constants assocs alien.c-types alien.strings fry ; + +IN: mongodb.bson.reader + +ERROR: size-mismatch actual declared ; + + ( -- state ) + state new H{ } clone [ >>result ] [ >>scope ] bi ; + +PREDICATE: bson-eoo < integer T_EOO = ; +PREDICATE: bson-not-eoo < integer T_EOO > ; +PREDICATE: bson-double < integer T_Double = ; +PREDICATE: bson-integer < integer T_Integer = ; +PREDICATE: bson-string < integer T_String = ; +PREDICATE: bson-object < integer T_Object = ; +PREDICATE: bson-array < integer T_Array = ; +PREDICATE: bson-binary < integer T_Binary = ; +PREDICATE: bson-oid < integer T_OID = ; +PREDICATE: bson-boolean < integer T_Boolean = ; +PREDICATE: bson-date < integer T_Date = ; +PREDICATE: bson-null < integer T_NULL = ; +PREDICATE: bson-ref < integer T_DBRef = ; + +GENERIC: element-read ( type -- cont? ) + +GENERIC: element-data-read ( type -- object ) + +: get-state ( -- state ) + state get ; + +: count-bytes ( count -- ) + [ get-state ] dip '[ _ + ] change-read drop ; + +: read-int32 ( -- int32 ) + 4 [ read *int ] [ count-bytes ] bi ; + +: read-byte-raw ( -- byte-raw ) + 1 [ read ] [ count-bytes ] bi ; + +: read-byte ( -- byte ) + read-byte-raw *char ; + +: (read-cstring) ( acc -- acc ) + read-byte-raw dup + B{ 0 } = + [ append ] + [ append (read-cstring) ] if ; + +: read-cstring ( -- string ) + B{ } clone + (read-cstring) utf8 alien>string ; + + +: object-size ( -- size ) + read-int32 ; + + +: read-element-type ( -- type ) + read-byte ; + +: element-name ( -- name ) + read-cstring ; + +: read-elements ( -- ) + read-element-type + element-read + [ read-elements ] when ; + + +M: bson-eoo element-read ( type -- cont? ) + drop + f ; + +M: bson-not-eoo element-read ( type -- cont? ) + [ element-name ] dip + element-data-read + swap + get-state scope>> + set-at + t ; + + +M: bson-string element-data-read ( type -- object ) + drop + read-int32 drop + read-cstring ; + +M: bson-integer element-data-read ( type -- object ) + drop + read-int32 ; + +PRIVATE> + +: bson> ( arr -- ht ) + binary + [ dup state + [ object-size >>size read-elements ] with-variable + ] with-byte-reader ; diff --git a/mongodb/bson/writer/writer.factor b/mongodb/bson/writer/writer.factor new file mode 100644 index 0000000000..8550a720fe --- /dev/null +++ b/mongodb/bson/writer/writer.factor @@ -0,0 +1,100 @@ +! Copyright (C) 2008 Sascha Matzke. +! See http://factorcode.org/license.txt for BSD license. +USING: mongodb.bson mongodb.bson.constants accessors kernel io.streams.string io.encodings.binary + io.encodings.utf8 strings splitting math.parser + sequences math assocs classes words make fry + prettyprint hashtables mirrors bson alien.strings alien.c-types + io.streams.byte-array io ; + +IN: mongodb.bson.writer + + write ] keep ; + +: write-cstring ( string -- ) + utf8 string>alien write ; + +PRIVATE> + +#! Writes the object out to a stream in BSON format +GENERIC: bson-print ( obj -- ) + +: (>bson) ( obj -- byte-array ) + '[ _ bson-print ] binary swap with-byte-writer ; + +GENERIC: >bson ( obj -- byte-aray ) + +M: tuple >bson ( tuble -- byte-array ) + (>bson) ; + +M: hashtable >bson ( hashmap -- byte-array ) + (>bson) ; + +M: f bson-print ( f -- ) + drop 0 write ; + +M: t bson-print ( t -- ) + drop 1 write ; + +M: bson-null bson-print ( null -- ) + drop ; + +M: string bson-print ( obj -- ) + utf8 string>alien + [ length write ] keep + write ; + +M: integer bson-print ( num -- ) + write ; + +M: real bson-print ( num -- ) + >float write ; + +M: sequence bson-print ( array -- ) + '[ _ [ [ write-type ] dip number>string write-cstring bson-print ] + each-index ] + binary swap with-byte-writer + [ length 5 + bson-print ] keep + write + T_EOO write ; + + +M: tuple bson-print ( tuple -- ) + '[ _ [ write-type [ write-cstring ] dip bson-print ] assoc-each ] + binary swap with-byte-writer + [ length 5 + bson-print ] keep write + T_EOO bson-print ; + +M: hashtable bson-print ( hashtable -- ) + '[ _ [ write-type [ write-cstring ] dip bson-print ] assoc-each ] + binary swap with-byte-writer + [ length 5 + bson-print ] keep write + T_EOO bson-print ; + +M: word bson-print name>> bson-print ; From f67441f4931cdf89740fa0bc77691b028ee0f361 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 19 Dec 2008 13:47:46 +0100 Subject: [PATCH 003/101] started working on transparent persistence for tuples (using dynamic subclassing) *** state: broken *** --- mongodb/mongodb.factor | 15 ++++++++++ mongodb/persistent/persistent.factor | 42 ++++++++++++++++++++++++++++ 2 files changed, 57 insertions(+) create mode 100644 mongodb/mongodb.factor create mode 100644 mongodb/persistent/persistent.factor diff --git a/mongodb/mongodb.factor b/mongodb/mongodb.factor new file mode 100644 index 0000000000..b706dcffa6 --- /dev/null +++ b/mongodb/mongodb.factor @@ -0,0 +1,15 @@ +USING: mongodb.persistent ; + +IN: mongodb + + + +GENERIC: store ( tuple/ht -- tuple/ht ) +GENERIC: load ( example -- tuple/ht ) + +M: tuple store ( tuple -- tuple ) + [ check-persistent-tuple ] keep ; + +M: persistent-tuple store ( ptuple -- ptuple ) + ; + diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor new file mode 100644 index 0000000000..08837ed237 --- /dev/null +++ b/mongodb/persistent/persistent.factor @@ -0,0 +1,42 @@ +USING: formatting words classes.mixin kernel fry compiler.units + accessors classes classes.tuple ; + +IN: mongodb.persistent + +MIXIN: persistent-tuple + +SLOT: _p_oid +SLOT: _p_info + +TUPLE: oid { a initial: 0 } { b initial: 0 } ; + +TUPLE: persistent-info type vocab collection dirty? mt ; + + + +GENERIC: persistent-tuple-class ( tuple -- class ) + +M: tuple persistent-tuple-class ( tuple -- class ) + class persistent-tuple-class ; + +M: tuple-class persistent-tuple-class ( class -- class' ) + [ [ vocabulary>> ] [ name>> ] bi ] keep ! name vocab class + [ "%s_%s" sprintf ] dip swap dup ! class new_name new_name + P_VOCAB lookup dup ! class new_name vo/f vo/f + [ [ drop drop ] dip ] [ drop define-persistent-tuple ] if ; From 752c637cb8e34a33deb0dd074f79a6df005a120a Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 19 Dec 2008 14:57:01 +0100 Subject: [PATCH 004/101] some work --- mongodb/bson/bson.factor | 2 + mongodb/bson/constants/constants.factor | 4 + mongodb/bson/reader/reader.factor | 147 ++++++++++++++----- mongodb/bson/writer/writer.factor | 185 ++++++++++++++---------- 4 files changed, 225 insertions(+), 113 deletions(-) diff --git a/mongodb/bson/bson.factor b/mongodb/bson/bson.factor index f6cd002b48..27033094de 100644 --- a/mongodb/bson/bson.factor +++ b/mongodb/bson/bson.factor @@ -1,4 +1,6 @@ + IN: mongodb.bson + USE: vocabs.loader SINGLETON: bson-null diff --git a/mongodb/bson/constants/constants.factor b/mongodb/bson/constants/constants.factor index 9163d06ba4..80e9933740 100644 --- a/mongodb/bson/constants/constants.factor +++ b/mongodb/bson/constants/constants.factor @@ -23,7 +23,11 @@ IN: mongodb.bson.constants : T_JSTypeMax ( -- type ) 16 ; inline : T_MaxKey ( -- type ) 127 ; inline +: T_Binary_Bytes ( -- subtype ) 2 ; inline +: T_Binary_Function ( -- subtype ) 1 ; inline +: S_Name ( -- name ) "__t_name" ; inline +: S_Vocab ( -- name ) "__t_vocab" ; inline ! todo Move to mongo vocab diff --git a/mongodb/bson/reader/reader.factor b/mongodb/bson/reader/reader.factor index abbb1a2c12..dcfabfb947 100644 --- a/mongodb/bson/reader/reader.factor +++ b/mongodb/bson/reader/reader.factor @@ -1,6 +1,7 @@ -USING: io io.encodings.utf8 io.encodings.binary math match kernel sequences +USING: mirrors io io.encodings.utf8 io.encodings.binary math match kernel sequences splitting accessors io.streams.byte-array namespaces prettyprint - mongodb.bson.constants assocs alien.c-types alien.strings fry ; + mongodb.bson.constants assocs alien.c-types alien.strings fry words + tools.walker serialize ; IN: mongodb.bson.reader @@ -8,97 +9,171 @@ ERROR: size-mismatch actual declared ; ( -- state ) - state new H{ } clone [ >>result ] [ >>scope ] bi ; + state new H{ } clone + [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi + V{ } clone [ T_Object "" element boa swap push ] keep >>element ; -PREDICATE: bson-eoo < integer T_EOO = ; +PREDICATE: bson-eoo < integer T_EOO = ; PREDICATE: bson-not-eoo < integer T_EOO > ; -PREDICATE: bson-double < integer T_Double = ; + +PREDICATE: bson-double < integer T_Double = ; PREDICATE: bson-integer < integer T_Integer = ; -PREDICATE: bson-string < integer T_String = ; -PREDICATE: bson-object < integer T_Object = ; -PREDICATE: bson-array < integer T_Array = ; -PREDICATE: bson-binary < integer T_Binary = ; -PREDICATE: bson-oid < integer T_OID = ; +PREDICATE: bson-string < integer T_String = ; +PREDICATE: bson-object < integer T_Object = ; +PREDICATE: bson-array < integer T_Array = ; +PREDICATE: bson-binary < integer T_Binary = ; +PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ; +PREDICATE: bson-binary-function < integer T_Binary_Function = ; +PREDICATE: bson-oid < integer T_OID = ; PREDICATE: bson-boolean < integer T_Boolean = ; -PREDICATE: bson-date < integer T_Date = ; -PREDICATE: bson-null < integer T_NULL = ; -PREDICATE: bson-ref < integer T_DBRef = ; +PREDICATE: bson-date < integer T_Date = ; +PREDICATE: bson-null < integer T_NULL = ; +PREDICATE: bson-ref < integer T_DBRef = ; GENERIC: element-read ( type -- cont? ) - GENERIC: element-data-read ( type -- object ) +GENERIC: element-binary-read ( length type -- object ) : get-state ( -- state ) - state get ; + state get ; inline : count-bytes ( count -- ) - [ get-state ] dip '[ _ + ] change-read drop ; + [ get-state ] dip '[ _ + ] change-read drop ; inline : read-int32 ( -- int32 ) - 4 [ read *int ] [ count-bytes ] bi ; + 4 [ read *int ] [ count-bytes ] bi ; inline + +: read-double ( -- double ) + 8 [ read *double ] [ count-bytes ] bi ; inline : read-byte-raw ( -- byte-raw ) - 1 [ read ] [ count-bytes ] bi ; + 1 [ read ] [ count-bytes ] bi ; inline : read-byte ( -- byte ) - read-byte-raw *char ; + read-byte-raw *char ; inline : (read-cstring) ( acc -- acc ) read-byte-raw dup B{ 0 } = [ append ] - [ append (read-cstring) ] if ; + [ append (read-cstring) ] if ; : read-cstring ( -- string ) B{ } clone (read-cstring) utf8 alien>string ; - -: object-size ( -- size ) - read-int32 ; - +: read-sized-string ( length -- string ) + [ read ] [ count-bytes ] bi + utf8 alien>string ; : read-element-type ( -- type ) read-byte ; -: element-name ( -- name ) - read-cstring ; +: push-element ( type name -- element ) + element boa + [ get-state element>> push ] keep ; + +: pop-element ( -- element ) + get-state element>> pop ; + +: peek-scope ( -- ht ) + get-state scope>> peek ; : read-elements ( -- ) read-element-type element-read [ read-elements ] when ; +: make-tuple ( assoc -- tuple ) + [ [ S_Name swap at ] [ S_Vocab swap at ] bi ] keep ! name vocab assoc + [ lookup new ] dip ! instance assoc + [ dup [ keys ] keep ] dip ! instance array mirror assoc + '[ dup _ [ _ at ] dip [ swap ] dip set-at ] each ; + +GENERIC: fix-result ( assoc type -- result ) + +M: bson-object fix-result ( assoc type -- result ) + drop + [ ] [ S_Name swap key? ] bi + [ make-tuple ] [ ] if ; + +M: bson-array fix-result ( assoc type -- result ) + drop + values ; M: bson-eoo element-read ( type -- cont? ) drop - f ; + get-state scope>> [ pop ] keep swap ! vec assoc + pop-element [ type>> ] keep ! vec assoc type element + [ fix-result ] dip ! vec result element + rot length 0 > ! result element + [ name>> peek-scope set-at t ] + [ drop [ get-state ] dip >>result drop f ] if ; M: bson-not-eoo element-read ( type -- cont? ) - [ element-name ] dip - element-data-read - swap - get-state scope>> + [ peek-scope ] dip ! scope type + '[ _ + read-cstring push-element [ name>> ] [ type>> ] bi + element-data-read + swap + ] dip set-at t ; +M: bson-object element-data-read ( type -- object ) + drop + read-int32 drop + get-state + [ [ [ H{ } clone ] dip push ] keep ] change-scope + scope>> peek ; +M: bson-array element-data-read ( type -- object ) + drop + read-int32 drop + get-state + [ [ [ H{ } clone ] dip push ] keep ] change-scope + scope>> peek ; + M: bson-string element-data-read ( type -- object ) drop - read-int32 drop - read-cstring ; + read-int32 read-sized-string + pop-element drop ; M: bson-integer element-data-read ( type -- object ) drop - read-int32 ; + read-int32 + pop-element drop ; + +M: bson-double element-data-read ( type -- double ) + drop + read-double + pop-element drop ; + +M: bson-boolean element-data-read ( type -- boolean ) + drop + read-byte t = + pop-element drop ; + +M: bson-binary element-data-read ( type -- binary ) + drop + read-int32 read-byte element-binary-read + pop-element drop ; + +M: bson-binary-bytes element-binary-read ( size type -- bytes ) + drop read ; + +M: bson-binary-function element-binary-read ( size type -- quot ) + drop read bytes>object ; PRIVATE> : bson> ( arr -- ht ) binary [ dup state - [ object-size >>size read-elements ] with-variable + [ read-int32 >>size read-elements ] with-variable + result>> ] with-byte-reader ; diff --git a/mongodb/bson/writer/writer.factor b/mongodb/bson/writer/writer.factor index 8550a720fe..7cb1cc4cdb 100644 --- a/mongodb/bson/writer/writer.factor +++ b/mongodb/bson/writer/writer.factor @@ -1,100 +1,131 @@ ! Copyright (C) 2008 Sascha Matzke. ! See http://factorcode.org/license.txt for BSD license. -USING: mongodb.bson mongodb.bson.constants accessors kernel io.streams.string io.encodings.binary +USING: mongodb.bson mongodb.bson.constants accessors kernel io.streams.string + io.encodings.binary classes byte-arrays quotations serialize io.encodings.utf8 strings splitting math.parser - sequences math assocs classes words make fry - prettyprint hashtables mirrors bson alien.strings alien.c-types + sequences math assocs classes words make fry mongodb.persistent + prettyprint hashtables mirrors alien.strings alien.c-types io.streams.byte-array io ; IN: mongodb.bson.writer +#! Writes the object out to a stream in BSON format + write ] keep ; +M: oid bson-type? ( word -- type ) drop T_OID ; +M: real bson-type? ( real -- type ) drop T_Double ; +M: word bson-type? ( word -- type ) drop T_String ; +M: tuple bson-type? ( tuple -- type ) drop T_Object ; +M: assoc bson-type? ( hashtable -- type ) drop T_Object ; +M: string bson-type? ( string -- type ) drop T_String ; +M: integer bson-type? ( integer -- type ) drop T_Integer ; +M: sequence bson-type? ( seq -- type ) drop T_Array ; +M: quotation bson-type? ( quotation -- type ) drop T_Binary ; +M: bson-null bson-type? ( null -- type ) drop T_NULL ; +M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; -: write-cstring ( string -- ) - utf8 string>alien write ; +: write-byte ( byte -- ) write ; +: write-int32 ( int -- ) write ; +: write-double ( real -- ) write ; +: write-cstring ( string -- ) utf8 string>alien write ; +: write-longlong ( object -- ) write ; + +: write-eoo ( -- ) T_EOO write-byte ; +: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; +: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; + +: write-tuple-info ( object -- ) + class + [ [ S_Name ] dip name>> write-pair ] + [ [ S_Vocab ] dip vocabulary>> write-pair ] bi ; + +M: f bson-write ( f -- ) + drop 0 write-byte ; + +M: t bson-write ( t -- ) + drop 1 write-byte ; + +M: bson-null bson-write ( null -- ) + drop ; + +M: string bson-write ( obj -- ) + utf8 string>alien + [ length write-int32 ] keep + write ; + +M: integer bson-write ( num -- ) + write-int32 ; + +M: real bson-write ( num -- ) + >float write-double ; + +M: byte-array bson-write ( binary -- ) + [ length write-int32 ] keep + T_Binary_Bytes write-byte + write ; + +M: quotation bson-write ( quotation -- ) + object>bytes [ length write-int32 ] keep + T_Binary_Function write-byte + write ; + +M: oid bson-write ( oid -- ) + [ a>> write-longlong ] [ b>> write-int32 ] bi ; + +M: sequence bson-write ( array -- ) + '[ _ [ [ write-type ] dip number>string write-cstring bson-write ] + each-index ] + binary swap with-byte-writer + [ length 5 + bson-write ] keep + write + write-eoo ; + +M: persistent-tuple bson-write ( persistent-tuple -- ) + dup + '[ + _ write-tuple-info + _ [ write-pair ] assoc-each + ] + binary swap with-byte-writer + [ length 5 + bson-write ] keep + write + write-eoo ; + +M: tuple bson-write ( tuple -- ) + dup + '[ + _ write-tuple-info + _ [ write-pair ] assoc-each + ] + binary swap with-byte-writer + [ length 5 + bson-write ] keep + write + write-eoo ; + +M: assoc bson-write ( hashtable -- ) + '[ _ [ write-pair ] assoc-each ] + binary swap with-byte-writer + [ length 5 + bson-write ] keep + write + write-eoo ; + +M: word bson-write name>> bson-write ; PRIVATE> -#! Writes the object out to a stream in BSON format -GENERIC: bson-print ( obj -- ) - -: (>bson) ( obj -- byte-array ) - '[ _ bson-print ] binary swap with-byte-writer ; - GENERIC: >bson ( obj -- byte-aray ) M: tuple >bson ( tuble -- byte-array ) - (>bson) ; + '[ _ bson-write ] binary swap with-byte-writer ; M: hashtable >bson ( hashmap -- byte-array ) - (>bson) ; - -M: f bson-print ( f -- ) - drop 0 write ; - -M: t bson-print ( t -- ) - drop 1 write ; - -M: bson-null bson-print ( null -- ) - drop ; - -M: string bson-print ( obj -- ) - utf8 string>alien - [ length write ] keep - write ; - -M: integer bson-print ( num -- ) - write ; - -M: real bson-print ( num -- ) - >float write ; - -M: sequence bson-print ( array -- ) - '[ _ [ [ write-type ] dip number>string write-cstring bson-print ] - each-index ] - binary swap with-byte-writer - [ length 5 + bson-print ] keep - write - T_EOO write ; + '[ _ bson-write ] binary swap with-byte-writer ; -M: tuple bson-print ( tuple -- ) - '[ _ [ write-type [ write-cstring ] dip bson-print ] assoc-each ] - binary swap with-byte-writer - [ length 5 + bson-print ] keep write - T_EOO bson-print ; - -M: hashtable bson-print ( hashtable -- ) - '[ _ [ write-type [ write-cstring ] dip bson-print ] assoc-each ] - binary swap with-byte-writer - [ length 5 + bson-print ] keep write - T_EOO bson-print ; - -M: word bson-print name>> bson-print ; From 88d337a001ef475c0f3640115c4ed27b6314aa15 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 27 Dec 2008 12:03:30 +0100 Subject: [PATCH 005/101] added _p_info hashtable constant keys commented make-persistent cause it's not working, yet --- mongodb/persistent/persistent.factor | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor index 08837ed237..2e76a3f85b 100644 --- a/mongodb/persistent/persistent.factor +++ b/mongodb/persistent/persistent.factor @@ -10,7 +10,10 @@ SLOT: _p_info TUPLE: oid { a initial: 0 } { b initial: 0 } ; -TUPLE: persistent-info type vocab collection dirty? mt ; +: MDB_CLASS ( -- string ) "p_class" ; inline +: MDB_VOCAB ( -- string ) "p_vocab" ; inline +: MDB_MODIF ( -- string ) "p_mt" ; inline +: MDB_CREAT ( -- string ) "p_ct" ; inline Date: Sat, 27 Dec 2008 12:11:15 +0100 Subject: [PATCH 006/101] modified version --- mongodb/persistent/persistent.factor | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor index 08837ed237..c3b18b027e 100644 --- a/mongodb/persistent/persistent.factor +++ b/mongodb/persistent/persistent.factor @@ -40,3 +40,13 @@ M: tuple-class persistent-tuple-class ( class -- class' ) [ "%s_%s" sprintf ] dip swap dup ! class new_name new_name P_VOCAB lookup dup ! class new_name vo/f vo/f [ [ drop drop ] dip ] [ drop define-persistent-tuple ] if ; + + +GENERIC: make-persistent ( tuple -- 'tuple ) + +M: tuple make-persistent ( tuple -- 'tuple ) + [let* | tuple [ ] + class [ tuple class ] + 'tuple [ class persistent-tuple-class new ] | + + ] ; \ No newline at end of file From 3a03cadef68bc6602a08166914636bbbd97bfcaf Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 27 Dec 2008 16:57:54 +0100 Subject: [PATCH 007/101] some further persistent tuple work; not sure if the whole tuple persistence behavior should bleed into the bson reader/writer, of if to keep them "pure" --- mongodb/bson/reader/reader.factor | 17 +++++-- mongodb/bson/writer/writer.factor | 29 +++++------- mongodb/persistent/persistent.factor | 66 +++++++++++++++++++--------- 3 files changed, 69 insertions(+), 43 deletions(-) diff --git a/mongodb/bson/reader/reader.factor b/mongodb/bson/reader/reader.factor index dcfabfb947..276acc1263 100644 --- a/mongodb/bson/reader/reader.factor +++ b/mongodb/bson/reader/reader.factor @@ -1,7 +1,7 @@ USING: mirrors io io.encodings.utf8 io.encodings.binary math match kernel sequences splitting accessors io.streams.byte-array namespaces prettyprint mongodb.bson.constants assocs alien.c-types alien.strings fry words - tools.walker serialize ; + tools.walker serialize mongodb.persistent ; IN: mongodb.bson.reader @@ -47,6 +47,9 @@ GENERIC: element-binary-read ( length type -- object ) : read-int32 ( -- int32 ) 4 [ read *int ] [ count-bytes ] bi ; inline +: read-longlong ( -- longlong ) + 8 [ read *longlong ] [ count-bytes ] bi ; inline + : read-double ( -- double ) 8 [ read *double ] [ count-bytes ] bi ; inline @@ -89,8 +92,7 @@ GENERIC: element-binary-read ( length type -- object ) [ read-elements ] when ; : make-tuple ( assoc -- tuple ) - [ [ S_Name swap at ] [ S_Vocab swap at ] bi ] keep ! name vocab assoc - [ lookup new ] dip ! instance assoc + [ P_INFO swap at persistent-tuple-class new ] keep ! instance assoc [ dup [ keys ] keep ] dip ! instance array mirror assoc '[ dup _ [ _ at ] dip [ swap ] dip set-at ] each ; @@ -98,7 +100,7 @@ GENERIC: fix-result ( assoc type -- result ) M: bson-object fix-result ( assoc type -- result ) drop - [ ] [ S_Name swap key? ] bi + [ ] [ P_INFO swap key? ] bi [ make-tuple ] [ ] if ; M: bson-array fix-result ( assoc type -- result ) @@ -124,6 +126,13 @@ M: bson-not-eoo element-read ( type -- cont? ) set-at t ; +M: bson-oid element-data-read ( type -- object ) + drop + read-longlong + read-int32 + oid boa + pop-element drop ; + M: bson-object element-data-read ( type -- object ) drop read-int32 drop diff --git a/mongodb/bson/writer/writer.factor b/mongodb/bson/writer/writer.factor index 7cb1cc4cdb..44dca02991 100644 --- a/mongodb/bson/writer/writer.factor +++ b/mongodb/bson/writer/writer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: mongodb.bson mongodb.bson.constants accessors kernel io.streams.string io.encodings.binary classes byte-arrays quotations serialize - io.encodings.utf8 strings splitting math.parser + io.encodings.utf8 strings splitting math.parser locals sequences math assocs classes words make fry mongodb.persistent prettyprint hashtables mirrors alien.strings alien.c-types io.streams.byte-array io ; @@ -41,10 +41,8 @@ M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; : write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; : write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; -: write-tuple-info ( object -- ) - class - [ [ S_Name ] dip name>> write-pair ] - [ [ S_Vocab ] dip vocabulary>> write-pair ] bi ; +:: write-tuple-info ( object -- ) + P_SLOTS [ [ ] [ object at ] bi write-pair ] each ; M: f bson-write ( f -- ) drop 0 write-byte ; @@ -87,27 +85,20 @@ M: sequence bson-write ( array -- ) write write-eoo ; +: check-p-field ( key value -- key value boolean ) + [ [ "_p_" swap start 0 = ] keep ] dip rot ; + M: persistent-tuple bson-write ( persistent-tuple -- ) - dup - '[ - _ write-tuple-info - _ [ write-pair ] assoc-each - ] + + '[ _ [ write-tuple-info ] + [ [ check-p-field [ 2drop ] [ write-pair ] if ] assoc-each ] bi ] binary swap with-byte-writer [ length 5 + bson-write ] keep write write-eoo ; M: tuple bson-write ( tuple -- ) - dup - '[ - _ write-tuple-info - _ [ write-pair ] assoc-each - ] - binary swap with-byte-writer - [ length 5 + bson-write ] keep - write - write-eoo ; + make-persistent bson-write ; M: assoc bson-write ( hashtable -- ) '[ _ [ write-pair ] assoc-each ] diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor index fff9778a94..d438fbf978 100644 --- a/mongodb/persistent/persistent.factor +++ b/mongodb/persistent/persistent.factor @@ -1,5 +1,5 @@ -USING: formatting words classes.mixin kernel fry compiler.units - accessors classes classes.tuple ; +USING: accessors classes classes.mixin classes.tuple compiler.units +fry kernel words locals mirrors formatting assocs hashtables ; IN: mongodb.persistent @@ -12,24 +12,35 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ; : MDB_CLASS ( -- string ) "p_class" ; inline : MDB_VOCAB ( -- string ) "p_vocab" ; inline -: MDB_MODIF ( -- string ) "p_mt" ; inline -: MDB_CREAT ( -- string ) "p_ct" ; inline +: MDB_MT ( -- string ) "p_mt" ; inline +: MDB_CT ( -- string ) "p_ct" ; inline +: MDB_COL ( -- string ) "p_col" ; inline + +PREDICATE: pinfo-hashtable < hashtable [ MDB_CLASS swap key? ] [ MDB_VOCAB swap key? ] bi and ; + +: P_OID ( -- name ) "_p_oid" ; inline +: P_INFO ( -- name ) "_p_info" ; inline + +: P_SLOTS ( -- array ) + { "_p_oid" "_p_info" } ; ] + tm2 [ 'tuple ] | + tm1 [ swap tm2 set-at ] assoc-each + tm2 object>> ] ; PRIVATE> @@ -38,6 +49,10 @@ GENERIC: persistent-tuple-class ( tuple -- class ) M: tuple persistent-tuple-class ( tuple -- class ) class persistent-tuple-class ; +M: pinfo-hashtable persistent-tuple-class ( tuple -- class ) + [ MDB_CLASS swap at ] [ MDB_VOCAB swap at ] bi lookup + persistent-tuple-class ; + M: tuple-class persistent-tuple-class ( class -- class' ) [ [ vocabulary>> ] [ name>> ] bi ] keep ! name vocab class [ "%s_%s" sprintf ] dip swap dup ! class new_name new_name @@ -47,9 +62,20 @@ M: tuple-class persistent-tuple-class ( class -- class' ) GENERIC: make-persistent ( tuple -- 'tuple ) -! M: tuple make-persistent ( tuple -- 'tuple ) -! [let* | tuple [ ] -! class [ tuple class ] -! 'tuple [ class persistent-tuple-class new ] | -! -! ] ; +M: tuple make-persistent ( tuple -- 'tuple ) + [let* | tuple [ ] + tclass [ tuple class ] + 'tuple [ tclass persistent-tuple-class new ] + pinfo [ H{ } clone ] | + tuple 'tuple copy-slots + oid new >>_p_oid + tclass name>> MDB_CLASS pinfo set-at + tclass vocabulary>> MDB_VOCAB pinfo set-at + 0 MDB_MT pinfo set-at + 0 MDB_CT pinfo set-at + "" MDB_COL pinfo set-at + pinfo >>_p_info + ] ; + +M: persistent-tuple make-persistent ( tuple -- tuple ) + ; From 28809b0ec0ddec5478ffc89742d22e3ea2b3a3f4 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 3 Jan 2009 12:48:11 +0100 Subject: [PATCH 008/101] made bson a toplevel vocab --- bson/bson.factor | 9 ++ .../bson => bson}/constants/constants.factor | 32 +---- {mongodb/bson => bson}/reader/reader.factor | 90 +++++++------ bson/writer/writer.factor | 102 +++++++++++++++ mongodb/bson/bson.factor | 9 -- mongodb/bson/writer/writer.factor | 122 ------------------ 6 files changed, 161 insertions(+), 203 deletions(-) create mode 100644 bson/bson.factor rename {mongodb/bson => bson}/constants/constants.factor (58%) rename {mongodb/bson => bson}/reader/reader.factor (71%) create mode 100644 bson/writer/writer.factor delete mode 100644 mongodb/bson/bson.factor delete mode 100644 mongodb/bson/writer/writer.factor diff --git a/bson/bson.factor b/bson/bson.factor new file mode 100644 index 0000000000..4be8e2d3ed --- /dev/null +++ b/bson/bson.factor @@ -0,0 +1,9 @@ + +IN: bson + +USE: vocabs.loader + +SINGLETON: bson-null + +"bson.reader" require +"bson.writer" require diff --git a/mongodb/bson/constants/constants.factor b/bson/constants/constants.factor similarity index 58% rename from mongodb/bson/constants/constants.factor rename to bson/constants/constants.factor index 80e9933740..f519c0f998 100644 --- a/mongodb/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -1,6 +1,8 @@ USING: alien.c-types ; -IN: mongodb.bson.constants +IN: bson.constants + +TUPLE: oid { a initial: 0 } { b initial: 0 } ; : T_EOO ( -- type ) 0 ; inline @@ -26,32 +28,4 @@ IN: mongodb.bson.constants : T_Binary_Bytes ( -- subtype ) 2 ; inline : T_Binary_Function ( -- subtype ) 1 ; inline -: S_Name ( -- name ) "__t_name" ; inline -: S_Vocab ( -- name ) "__t_vocab" ; inline -! todo Move to mongo vocab - -: OP_Reply ( -- const ) - 1 ; inline - -: OP_Message ( -- const ) - 1000 ; inline - -: OP_Update ( -- const ) - 2001 ; inline - -: OP_Insert ( -- const ) - 2002 ; inline - -: OP_Query ( -- const ) - 2004 ; inline - -: OP_GetMore ( -- const ) - 2005 ; inline - -: OP_Delete ( -- const ) - 2006 ; inline - -: OP_KillCursors ( -- const ) - 2007 ; inline - \ No newline at end of file diff --git a/mongodb/bson/reader/reader.factor b/bson/reader/reader.factor similarity index 71% rename from mongodb/bson/reader/reader.factor rename to bson/reader/reader.factor index 276acc1263..b7ef83d80e 100644 --- a/mongodb/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -1,21 +1,22 @@ USING: mirrors io io.encodings.utf8 io.encodings.binary math match kernel sequences splitting accessors io.streams.byte-array namespaces prettyprint - mongodb.bson.constants assocs alien.c-types alien.strings fry words - tools.walker serialize mongodb.persistent ; + bson.constants assocs alien.c-types alien.strings fry words + tools.walker serialize locals byte-arrays ; -IN: mongodb.bson.reader +IN: bson.reader ERROR: size-mismatch actual declared ; ( -- state ) - state new H{ } clone - [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi - V{ } clone [ T_Object "" element boa swap push ] keep >>element ; +:: ( exemplar -- state ) + state new + exemplar clone >>exemplar + exemplar clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi + V{ } clone [ T_Object "" element boa swap push ] keep >>element ; inline PREDICATE: bson-eoo < integer T_EOO = ; PREDICATE: bson-not-eoo < integer T_EOO > ; @@ -63,45 +64,38 @@ GENERIC: element-binary-read ( length type -- object ) read-byte-raw dup B{ 0 } = [ append ] - [ append (read-cstring) ] if ; + [ append (read-cstring) ] if ; inline recursive : read-cstring ( -- string ) B{ } clone - (read-cstring) utf8 alien>string ; + (read-cstring) utf8 alien>string ; inline : read-sized-string ( length -- string ) [ read ] [ count-bytes ] bi - utf8 alien>string ; + utf8 alien>string ; inline : read-element-type ( -- type ) - read-byte ; + read-byte ; inline : push-element ( type name -- element ) element boa - [ get-state element>> push ] keep ; + [ get-state element>> push ] keep ; inline : pop-element ( -- element ) - get-state element>> pop ; + get-state element>> pop ; inline : peek-scope ( -- ht ) - get-state scope>> peek ; + get-state scope>> peek ; inline : read-elements ( -- ) read-element-type element-read - [ read-elements ] when ; - -: make-tuple ( assoc -- tuple ) - [ P_INFO swap at persistent-tuple-class new ] keep ! instance assoc - [ dup [ keys ] keep ] dip ! instance array mirror assoc - '[ dup _ [ _ at ] dip [ swap ] dip set-at ] each ; + [ read-elements ] when ; inline recursive GENERIC: fix-result ( assoc type -- result ) M: bson-object fix-result ( assoc type -- result ) - drop - [ ] [ P_INFO swap key? ] bi - [ make-tuple ] [ ] if ; + drop ; M: bson-array fix-result ( assoc type -- result ) drop @@ -109,10 +103,10 @@ M: bson-array fix-result ( assoc type -- result ) M: bson-eoo element-read ( type -- cont? ) drop - get-state scope>> [ pop ] keep swap ! vec assoc - pop-element [ type>> ] keep ! vec assoc type element - [ fix-result ] dip ! vec result element - rot length 0 > ! result element + get-state scope>> [ pop ] keep swap ! vec assoc + pop-element [ type>> ] keep ! vec assoc element + [ fix-result ] dip + rot length 0 > ! assoc element [ name>> peek-scope set-at t ] [ drop [ get-state ] dip >>result drop f ] if ; @@ -133,19 +127,21 @@ M: bson-oid element-data-read ( type -- object ) oid boa pop-element drop ; -M: bson-object element-data-read ( type -- object ) - drop - read-int32 drop - get-state - [ [ [ H{ } clone ] dip push ] keep ] change-scope - scope>> peek ; +: [scope-changer] ( state -- state quot ) + dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline -M: bson-array element-data-read ( type -- object ) +: (object-data-read) ( type -- object ) drop read-int32 drop get-state - [ [ [ H{ } clone ] dip push ] keep ] change-scope - scope>> peek ; + [scope-changer] change-scope + scope>> peek ; inline + +M: bson-object element-data-read ( type -- object ) + (object-data-read) ; + +M: bson-array element-data-read ( type -- object ) + (object-data-read) ; M: bson-string element-data-read ( type -- object ) drop @@ -179,10 +175,18 @@ M: bson-binary-function element-binary-read ( size type -- quot ) drop read bytes>object ; PRIVATE> - -: bson> ( arr -- ht ) - binary - [ dup state + +GENERIC: stream>assoc ( exemplar -- assoc ) + +M: assoc stream>assoc ( exemplar -- assoc ) + dup state [ read-int32 >>size read-elements ] with-variable - result>> - ] with-byte-reader ; + result>> ; + +USING: multi-methods ; + +GENERIC: array>assoc ( array exemplar -- assoc ) + +METHOD: array>assoc { byte-array assoc } ( array exemplar -- assoc ) + [ binary ] dip '[ _ stream>assoc ] with-byte-reader ; + diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor new file mode 100644 index 0000000000..a85a9867c5 --- /dev/null +++ b/bson/writer/writer.factor @@ -0,0 +1,102 @@ +! Copyright (C) 2008 Sascha Matzke. +! See http://factorcode.org/license.txt for BSD license. +USING: bson bson.constants accessors kernel io.streams.string + io.encodings.binary classes byte-arrays quotations serialize + io.encodings.utf8 strings splitting math.parser locals + sequences math assocs classes words make fry + prettyprint hashtables mirrors alien.strings alien.c-types + io.streams.byte-array io ; + +IN: bson.writer + +#! Writes the object out to a stream in BSON format + + write ; inline +: write-int32 ( int -- ) write ; inline +: write-double ( real -- ) write ; inline +: write-cstring ( string -- ) utf8 string>alien write ; inline +: write-longlong ( object -- ) write ; inline + +: write-eoo ( -- ) T_EOO write-byte ; inline +: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline +: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline + + +M: f bson-write ( f -- ) + drop 0 write-byte ; + +M: t bson-write ( t -- ) + drop 1 write-byte ; + +M: bson-null bson-write ( null -- ) + drop ; + +M: string bson-write ( obj -- ) + utf8 string>alien + [ length write-int32 ] keep + write ; + +M: integer bson-write ( num -- ) + write-int32 ; + +M: real bson-write ( num -- ) + >float write-double ; + +M: byte-array bson-write ( binary -- ) + [ length write-int32 ] keep + T_Binary_Bytes write-byte + write ; + +M: quotation bson-write ( quotation -- ) + object>bytes [ length write-int32 ] keep + T_Binary_Function write-byte + write ; + +M: oid bson-write ( oid -- ) + [ a>> write-longlong ] [ b>> write-int32 ] bi ; + +M: sequence bson-write ( array -- ) + '[ _ [ [ write-type ] dip number>string write-cstring bson-write ] + each-index ] + binary swap with-byte-writer + [ length 5 + bson-write ] keep + write + write-eoo ; + +M: assoc bson-write ( hashtable -- ) + '[ _ [ write-pair ] assoc-each ] + binary swap with-byte-writer + [ length 5 + bson-write ] keep + write + write-eoo ; + +M: word bson-write name>> bson-write ; + +PRIVATE> + +: assoc>array ( assoc -- byte-array ) + '[ _ bson-write ] binary swap with-byte-writer ; inline + +: assoc>stream ( assoc -- ) + bson-write ; inline + diff --git a/mongodb/bson/bson.factor b/mongodb/bson/bson.factor deleted file mode 100644 index 27033094de..0000000000 --- a/mongodb/bson/bson.factor +++ /dev/null @@ -1,9 +0,0 @@ - -IN: mongodb.bson - -USE: vocabs.loader - -SINGLETON: bson-null - -"mongodb.bson.reader" require -"mongodb.bson.writer" require diff --git a/mongodb/bson/writer/writer.factor b/mongodb/bson/writer/writer.factor deleted file mode 100644 index 44dca02991..0000000000 --- a/mongodb/bson/writer/writer.factor +++ /dev/null @@ -1,122 +0,0 @@ -! Copyright (C) 2008 Sascha Matzke. -! See http://factorcode.org/license.txt for BSD license. -USING: mongodb.bson mongodb.bson.constants accessors kernel io.streams.string - io.encodings.binary classes byte-arrays quotations serialize - io.encodings.utf8 strings splitting math.parser locals - sequences math assocs classes words make fry mongodb.persistent - prettyprint hashtables mirrors alien.strings alien.c-types - io.streams.byte-array io ; - -IN: mongodb.bson.writer - -#! Writes the object out to a stream in BSON format - - write ; -: write-int32 ( int -- ) write ; -: write-double ( real -- ) write ; -: write-cstring ( string -- ) utf8 string>alien write ; -: write-longlong ( object -- ) write ; - -: write-eoo ( -- ) T_EOO write-byte ; -: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; -: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; - -:: write-tuple-info ( object -- ) - P_SLOTS [ [ ] [ object at ] bi write-pair ] each ; - -M: f bson-write ( f -- ) - drop 0 write-byte ; - -M: t bson-write ( t -- ) - drop 1 write-byte ; - -M: bson-null bson-write ( null -- ) - drop ; - -M: string bson-write ( obj -- ) - utf8 string>alien - [ length write-int32 ] keep - write ; - -M: integer bson-write ( num -- ) - write-int32 ; - -M: real bson-write ( num -- ) - >float write-double ; - -M: byte-array bson-write ( binary -- ) - [ length write-int32 ] keep - T_Binary_Bytes write-byte - write ; - -M: quotation bson-write ( quotation -- ) - object>bytes [ length write-int32 ] keep - T_Binary_Function write-byte - write ; - -M: oid bson-write ( oid -- ) - [ a>> write-longlong ] [ b>> write-int32 ] bi ; - -M: sequence bson-write ( array -- ) - '[ _ [ [ write-type ] dip number>string write-cstring bson-write ] - each-index ] - binary swap with-byte-writer - [ length 5 + bson-write ] keep - write - write-eoo ; - -: check-p-field ( key value -- key value boolean ) - [ [ "_p_" swap start 0 = ] keep ] dip rot ; - -M: persistent-tuple bson-write ( persistent-tuple -- ) - - '[ _ [ write-tuple-info ] - [ [ check-p-field [ 2drop ] [ write-pair ] if ] assoc-each ] bi ] - binary swap with-byte-writer - [ length 5 + bson-write ] keep - write - write-eoo ; - -M: tuple bson-write ( tuple -- ) - make-persistent bson-write ; - -M: assoc bson-write ( hashtable -- ) - '[ _ [ write-pair ] assoc-each ] - binary swap with-byte-writer - [ length 5 + bson-write ] keep - write - write-eoo ; - -M: word bson-write name>> bson-write ; - -PRIVATE> - -GENERIC: >bson ( obj -- byte-aray ) - -M: tuple >bson ( tuble -- byte-array ) - '[ _ bson-write ] binary swap with-byte-writer ; - -M: hashtable >bson ( hashmap -- byte-array ) - '[ _ bson-write ] binary swap with-byte-writer ; - - From 3e433f52a20581866ad921f9106c9e0d1653d6fd Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 23 Jan 2009 06:53:08 +0100 Subject: [PATCH 009/101] various changes --- bson/bson.factor | 5 +- bson/constants/constants.factor | 55 +++++---- bson/reader/reader.factor | 78 ++++++++----- bson/writer/writer.factor | 15 ++- mongodb/mongodb.factor | 48 ++++++-- mongodb/persistent/persistent.factor | 168 +++++++++++++++++---------- 6 files changed, 237 insertions(+), 132 deletions(-) diff --git a/bson/bson.factor b/bson/bson.factor index 4be8e2d3ed..a97b5029b0 100644 --- a/bson/bson.factor +++ b/bson/bson.factor @@ -1,9 +1,6 @@ +USING: vocabs.loader ; IN: bson -USE: vocabs.loader - -SINGLETON: bson-null - "bson.reader" require "bson.writer" require diff --git a/bson/constants/constants.factor b/bson/constants/constants.factor index f519c0f998..8f5b61a671 100644 --- a/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -1,31 +1,40 @@ -USING: alien.c-types ; +USING: alien.c-types accessors kernel calendar random math.bitwise math unix ; IN: bson.constants TUPLE: oid { a initial: 0 } { b initial: 0 } ; +: ( -- oid ) + oid new + now timestamp>micros >>a + 8 random-bits 16 shift HEX: FF0000 mask + getpid HEX: FFFF mask + bitor >>b ; -: T_EOO ( -- type ) 0 ; inline -: T_Double ( -- type ) 1 ; inline -: T_Integer ( -- type ) 16 ; inline -: T_Boolean ( -- type ) 8 ; inline -: T_String ( -- type ) 2 ; inline -: T_Object ( -- type ) 3 ; inline -: T_Array ( -- type ) 4 ; inline -: T_Binary ( -- type ) 5 ; inline -: T_Undefined ( -- type ) 6 ; inline -: T_OID ( -- type ) 7 ; inline -: T_Date ( -- type ) 9 ; inline -: T_NULL ( -- type ) 10 ; inline -: T_Regexp ( -- type ) 11 ; inline -: T_DBRef ( -- type ) 12 ; inline -: T_Code ( -- type ) 13 ; inline -: T_ScopedCode ( -- type ) 17 ; inline -: T_Symbol ( -- type ) 14 ; inline -: T_JSTypeMax ( -- type ) 16 ; inline -: T_MaxKey ( -- type ) 127 ; inline - -: T_Binary_Bytes ( -- subtype ) 2 ; inline -: T_Binary_Function ( -- subtype ) 1 ; inline +TUPLE: dbref ns oid ; + + +CONSTANT: T_EOO 0 +CONSTANT: T_Double 1 +CONSTANT: T_Integer 16 +CONSTANT: T_Boolean 8 +CONSTANT: T_String 2 +CONSTANT: T_Object 3 +CONSTANT: T_Array 4 +CONSTANT: T_Binary 5 +CONSTANT: T_Undefined 6 +CONSTANT: T_OID 7 +CONSTANT: T_Date 9 +CONSTANT: T_NULL 10 +CONSTANT: T_Regexp 11 +CONSTANT: T_DBRef 12 +CONSTANT: T_Code 13 +CONSTANT: T_ScopedCode 17 +CONSTANT: T_Symbol 14 +CONSTANT: T_JSTypeMax 16 +CONSTANT: T_MaxKey 127 + +CONSTANT: T_Binary_Bytes 2 +CONSTANT: T_Binary_Function 1 diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index b7ef83d80e..5aebb4bcee 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -1,21 +1,21 @@ USING: mirrors io io.encodings.utf8 io.encodings.binary math match kernel sequences splitting accessors io.streams.byte-array namespaces prettyprint bson.constants assocs alien.c-types alien.strings fry words - tools.walker serialize locals byte-arrays ; + serialize byte-arrays ; IN: bson.reader -ERROR: size-mismatch actual declared ; - ( exemplar -- state ) - state new - exemplar clone >>exemplar - exemplar clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi +: ( exemplar -- state ) + [ state new ] dip + [ clone >>exemplar ] keep + clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi V{ } clone [ T_Object "" element boa swap push ] keep >>element ; inline PREDICATE: bson-eoo < integer T_EOO = ; @@ -101,6 +101,18 @@ M: bson-array fix-result ( assoc type -- result ) drop values ; +GENERIC: end-element ( type -- ) + +M: bson-object end-element ( type -- ) + drop ; + +M: bson-array end-element ( type -- ) + drop ; + +M: object end-element ( type -- ) + drop + pop-element drop ; + M: bson-eoo element-read ( type -- cont? ) drop get-state scope>> [ pop ] keep swap ! vec assoc @@ -113,9 +125,10 @@ M: bson-eoo element-read ( type -- cont? ) M: bson-not-eoo element-read ( type -- cont? ) [ peek-scope ] dip ! scope type '[ _ - read-cstring push-element [ name>> ] [ type>> ] bi - element-data-read - swap + read-cstring push-element [ name>> ] [ type>> ] bi + [ element-data-read ] keep + end-element + swap ] dip set-at t ; @@ -124,8 +137,7 @@ M: bson-oid element-data-read ( type -- object ) drop read-longlong read-int32 - oid boa - pop-element drop ; + oid boa ; : [scope-changer] ( state -- state quot ) dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline @@ -145,28 +157,34 @@ M: bson-array element-data-read ( type -- object ) M: bson-string element-data-read ( type -- object ) drop - read-int32 read-sized-string - pop-element drop ; + read-int32 read-sized-string ; M: bson-integer element-data-read ( type -- object ) drop - read-int32 - pop-element drop ; + read-int32 ; M: bson-double element-data-read ( type -- double ) drop - read-double - pop-element drop ; + read-double ; M: bson-boolean element-data-read ( type -- boolean ) drop - read-byte t = - pop-element drop ; + read-byte t = ; + +M: bson-ref element-data-read ( type -- dbref ) + drop + read-int32 + read-sized-string + T_OID element-data-read + dbref boa ; M: bson-binary element-data-read ( type -- binary ) drop - read-int32 read-byte element-binary-read - pop-element drop ; + read-int32 read-byte element-binary-read ; + +M: bson-null element-data-read ( type -- bf ) + drop + f ; M: bson-binary-bytes element-binary-read ( size type -- bytes ) drop read ; @@ -176,17 +194,13 @@ M: bson-binary-function element-binary-read ( size type -- quot ) PRIVATE> -GENERIC: stream>assoc ( exemplar -- assoc ) - -M: assoc stream>assoc ( exemplar -- assoc ) +: stream>assoc ( exemplar -- assoc ) dup state [ read-int32 >>size read-elements ] with-variable result>> ; - -USING: multi-methods ; - -GENERIC: array>assoc ( array exemplar -- assoc ) - -METHOD: array>assoc { byte-array assoc } ( array exemplar -- assoc ) + +: array>assoc ( array exemplar -- assoc ) [ binary ] dip '[ _ stream>assoc ] with-byte-reader ; +: array>hashtable ( array -- assoc ) + H{ } array>assoc ; diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index a85a9867c5..c5e9b02ef8 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: bson bson.constants accessors kernel io.streams.string io.encodings.binary classes byte-arrays quotations serialize - io.encodings.utf8 strings splitting math.parser locals + io.encodings.utf8 strings splitting math.parser sequences math assocs classes words make fry prettyprint hashtables mirrors alien.strings alien.c-types io.streams.byte-array io ; @@ -19,7 +19,8 @@ GENERIC: bson-write ( obj -- ) M: t bson-type? ( boolean -- type ) drop T_Boolean ; M: f bson-type? ( boolean -- type ) drop T_Boolean ; -M: oid bson-type? ( word -- type ) drop T_OID ; +M: oid bson-type? ( word -- type ) drop T_OID ; +M: dbref bson-type? ( dbref -- type ) drop T_DBRef ; M: real bson-type? ( real -- type ) drop T_Double ; M: word bson-type? ( word -- type ) drop T_String ; M: tuple bson-type? ( tuple -- type ) drop T_Object ; @@ -28,7 +29,6 @@ M: string bson-type? ( string -- type ) drop T_String ; M: integer bson-type? ( integer -- type ) drop T_Integer ; M: sequence bson-type? ( seq -- type ) drop T_Array ; M: quotation bson-type? ( quotation -- type ) drop T_Binary ; -M: bson-null bson-type? ( null -- type ) drop T_NULL ; M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; : write-byte ( byte -- ) write ; inline @@ -48,9 +48,6 @@ M: f bson-write ( f -- ) M: t bson-write ( t -- ) drop 1 write-byte ; -M: bson-null bson-write ( null -- ) - drop ; - M: string bson-write ( obj -- ) utf8 string>alien [ length write-int32 ] keep @@ -74,6 +71,12 @@ M: quotation bson-write ( quotation -- ) M: oid bson-write ( oid -- ) [ a>> write-longlong ] [ b>> write-int32 ] bi ; + +M: dbref bson-write ( dbref -- ) + [ ns>> utf8 string>alien + [ length write-int32 ] keep write + ] + [ oid>> bson-write ] bi ; M: sequence bson-write ( array -- ) '[ _ [ [ write-type ] dip number>string write-cstring bson-write ] diff --git a/mongodb/mongodb.factor b/mongodb/mongodb.factor index b706dcffa6..b9c15c0317 100644 --- a/mongodb/mongodb.factor +++ b/mongodb/mongodb.factor @@ -1,15 +1,49 @@ -USING: mongodb.persistent ; +USING: accessors assocs fry io.encodings.binary io.sockets kernel math +math.parser mongodb.msg mongodb.persistent mongodb.query mongodb.tuple +namespaces sequences splitting ; IN: mongodb +INTERSECTION: storable mdb-persistent ; + +> get-collection-fqn ] keep + H{ } tuple>query ; inline -M: tuple store ( tuple -- tuple ) - [ check-persistent-tuple ] keep ; +PRIVATE> -M: persistent-tuple store ( ptuple -- ptuple ) - ; + +: ( db host port -- mdb ) + () ; + + +GENERIC: store ( tuple/ht -- ) + +GENERIC: find ( example -- tuple/ht ) + +GENERIC: findOne ( exampe -- tuple/ht ) + +GENERIC: load ( object -- object ) + + +M: storable store ( tuple -- ) + prepare-store ! H { collection { ... values ... } + [ [ ] 2dip + [ get-collection-fqn >>collection ] dip + objects>> + [ mdb>> master>> binary ] dip '[ _ write-request ] with-client + ] assoc-each ; + +M: storable find ( example -- result ) + prepare-find (find) + build-result ; + +M: storable findOne ( example -- result ) + prepare-find (find-one) + dup returned#>> 1 = + [ objects>> first ] + [ drop f ] if ; diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor index d438fbf978..c7c3fcf134 100644 --- a/mongodb/persistent/persistent.factor +++ b/mongodb/persistent/persistent.factor @@ -1,81 +1,129 @@ -USING: accessors classes classes.mixin classes.tuple compiler.units -fry kernel words locals mirrors formatting assocs hashtables ; +USING: accessors assocs classes fry kernel linked-assocs math mirrors +namespaces sequences strings vectors words bson.constants +continuations ; IN: mongodb.persistent -MIXIN: persistent-tuple +MIXIN: mdb-persistent -SLOT: _p_oid -SLOT: _p_info +SLOT: _id -TUPLE: oid { a initial: 0 } { b initial: 0 } ; +CONSTANT: MDB_P_SLOTS { "_id" } +CONSTANT: MDB_OID "_id" -: MDB_CLASS ( -- string ) "p_class" ; inline -: MDB_VOCAB ( -- string ) "p_vocab" ; inline -: MDB_MT ( -- string ) "p_mt" ; inline -: MDB_CT ( -- string ) "p_ct" ; inline -: MDB_COL ( -- string ) "p_col" ; inline +SYMBOL: mdb-op-seq -PREDICATE: pinfo-hashtable < hashtable [ MDB_CLASS swap key? ] [ MDB_VOCAB swap key? ] bi and ; +GENERIC# tuple>assoc 1 ( tuple exemplar -- assoc ) -: P_OID ( -- name ) "_p_oid" ; inline -: P_INFO ( -- name ) "_p_info" ; inline +: tuple>linked-assoc ( tuple -- linked-assoc ) + tuple>assoc ; inline -: P_SLOTS ( -- array ) - { "_p_oid" "_p_info" } ; +GENERIC# tuple>query 1 ( tuple examplar -- query-assoc ) + +GENERIC: mdb-collection>> ( tuple -- string ) + +GENERIC: mdb-slot-definitions>> ( tuple -- string ) + + +DEFER: assoc>tuple +DEFER: create-mdb-command ] - tm2 [ 'tuple ] | - tm1 [ swap tm2 set-at ] assoc-each - tm2 object>> ] ; +: ( tuple -- dbref ) + [ mdb-collection>> ] [ _id>> ] bi dbref boa ; inline + +: mdbinfo>tuple-class ( mdbinfo -- class ) + [ first ] keep second lookup ; inline + +: make-tuple ( assoc -- tuple ) + [ MDB_INFO swap at mdbinfo>tuple-class new ] keep ! instance assoc + [ dup [ keys ] keep ] dip ! instance array mirror assoc + '[ dup _ [ _ at assoc>tuple ] dip [ swap ] dip set-at ] each ; + +: persistent-info ( tuple -- pinfo ) + class V{ } clone tuck + [ [ name>> ] dip push ] + [ [ vocabulary>> ] dip push ] 2bi ; inline + +: id-or-f? ( key value -- key value boolean ) + over "_id" = + [ dup f = ] dip or ; inline + +: write-persistent-info ( mirror exemplar assoc -- ) + [ drop ] dip + 2dup [ "_id" ] 2dip [ over [ at ] dip ] dip set-at + [ object>> persistent-info MDB_INFO ] dip set-at ; + +: persistent-tuple? ( object -- object boolean ) + dup mdb-persistent? ; inline + +: ensure-value-ht ( key ht -- vht ) + 2dup key? + [ at ] + [ [ H{ } clone dup ] 2dip set-at ] if ; inline + +: data-tuple? ( tuple -- ? ) + dup tuple? [ assoc? [ f ] [ t ] if ] [ drop f ] if ; + +: write-tuple-fields ( mirror exemplar assoc -- ) + [ dup ] dip ! m e e a + '[ id-or-f? + [ 2drop ] + [ persistent-tuple? + [ _ keep + [ mdb-collection>> ] keep + [ create-mdb-command ] dip + ] + [ dup data-tuple? _ [ ] if ] if + swap _ set-at + ] if + ] assoc-each ; + +: prepare-assoc ( tuple exemplar -- assoc mirror exemplar assoc ) + [ ] dip dup clone swap [ tuck ] dip swap ; inline +: ensure-mdb-info ( tuple -- tuple ) + dup _id>> [ >>_id ] unless ; inline + +: with-op-seq ( quot -- op-seq ) + [ + [ H{ } clone mdb-op-seq set ] dip call mdb-op-seq get + ] with-scope ; inline + PRIVATE> -GENERIC: persistent-tuple-class ( tuple -- class ) +: create-mdb-command ( assoc ns -- ) + mdb-op-seq get + ensure-value-ht + [ dup [ MDB_OID ] dip at ] dip + set-at ; inline -M: tuple persistent-tuple-class ( tuple -- class ) - class persistent-tuple-class ; +: prepare-store ( mdb-persistent -- op-seq ) + '[ _ [ tuple>linked-assoc ] keep mdb-collection>> create-mdb-command ] + with-op-seq ; inline -M: pinfo-hashtable persistent-tuple-class ( tuple -- class ) - [ MDB_CLASS swap at ] [ MDB_VOCAB swap at ] bi lookup - persistent-tuple-class ; +M: mdb-persistent tuple>assoc ( tuple exemplar -- assoc ) + [ ensure-mdb-info ] dip ! tuple exemplar + prepare-assoc + [ write-persistent-info ] + [ [ '[ _ tuple>assoc ] ] dip write-tuple-fields ] 3bi ; -M: tuple-class persistent-tuple-class ( class -- class' ) - [ [ vocabulary>> ] [ name>> ] bi ] keep ! name vocab class - [ "%s_%s" sprintf ] dip swap dup ! class new_name new_name - P_VOCAB lookup dup ! class new_name vo/f vo/f - [ [ drop drop ] dip ] [ drop define-persistent-tuple ] if ; +M: tuple tuple>assoc ( tuple exemplar -- assoc ) + [ drop persistent-info MDB_INFO ] 2keep + prepare-assoc [ '[ _ tuple>assoc ] ] write-tuple-fields + [ set-at ] keep ; + +M: tuple tuple>query ( tuple examplar -- assoc ) + prepare-assoc [ '[ _ tuple>query ] ] dip write-tuple-fields ; + +: assoc>tuple ( assoc -- tuple ) + dup assoc? + [ [ dup MDB_INFO swap key? + [ make-tuple ] + [ ] if ] [ drop ] recover + ] [ ] if ; inline -GENERIC: make-persistent ( tuple -- 'tuple ) - -M: tuple make-persistent ( tuple -- 'tuple ) - [let* | tuple [ ] - tclass [ tuple class ] - 'tuple [ tclass persistent-tuple-class new ] - pinfo [ H{ } clone ] | - tuple 'tuple copy-slots - oid new >>_p_oid - tclass name>> MDB_CLASS pinfo set-at - tclass vocabulary>> MDB_VOCAB pinfo set-at - 0 MDB_MT pinfo set-at - 0 MDB_CT pinfo set-at - "" MDB_COL pinfo set-at - pinfo >>_p_info - ] ; - -M: persistent-tuple make-persistent ( tuple -- tuple ) - ; From 3c8402dbca37b947d9bda2fbcebfedae4905d581 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sun, 25 Jan 2009 11:19:07 +0100 Subject: [PATCH 010/101] added README.txt --- README.txt | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 README.txt diff --git a/README.txt b/README.txt new file mode 100644 index 0000000000..bb91f56c33 --- /dev/null +++ b/README.txt @@ -0,0 +1,2 @@ +This is the attempt to implement a driver for MongoDB +(http://www.mongodb.org) in Factor (http://www.factorcode.org). From c0f2c3a95f1c5d50ddd9f9a66352b614f9ec0142 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Tue, 27 Jan 2009 09:21:04 +0100 Subject: [PATCH 011/101] recovered files lost by my own stupidity... --- mongodb/collection/collection.factor | 105 +++++++++++++++++++ mongodb/connection/connection.factor | 61 ++++++++++++ mongodb/index/index.factor | 99 ++++++++++++++++++ mongodb/mongodb.factor | 27 +++-- mongodb/msg/msg.factor | 144 +++++++++++++++++++++++++++ mongodb/persistent/persistent.factor | 6 +- mongodb/query/query.factor | 64 ++++++++++++ mongodb/tuple/tuple.factor | 66 ++++++++++++ 8 files changed, 552 insertions(+), 20 deletions(-) create mode 100644 mongodb/collection/collection.factor create mode 100644 mongodb/connection/connection.factor create mode 100644 mongodb/index/index.factor create mode 100644 mongodb/msg/msg.factor create mode 100644 mongodb/query/query.factor create mode 100644 mongodb/tuple/tuple.factor diff --git a/mongodb/collection/collection.factor b/mongodb/collection/collection.factor new file mode 100644 index 0000000000..c7c72d8fad --- /dev/null +++ b/mongodb/collection/collection.factor @@ -0,0 +1,105 @@ +USING: accessors assocs formatting kernel math classes sequences splitting strings + words classes.tuple vectors ; + +IN: mongodb.collection + +GENERIC: mdb-slot-definitions>> ( tuple -- string ) +GENERIC: mdb-collection>> ( object -- mdb-collection ) + +CONSTANT: MDB_COLLECTIONS "mdb_collections" + +SYMBOLS: +transient+ +load+ ; + +UNION: boolean t POSTPONE: f ; + +TUPLE: mdb-collection + { name string } + { capped boolean initial: f } + { size integer initial: -1 } + { max integer initial: -1 } + { classes sequence } ; + +USING: mongodb.persistent mongodb.msg mongodb.tuple +mongodb.connection mongodb.query mongodb.index ; + +>) ( class -- mdb-collection ) + dup props>> [ MDB_COL_PROP ] dip at + [ [ drop ] dip ] + [ superclass [ (mdb-collection>>) ] [ f ] if* ] if* ; inline recursive + +: (mdb-slot-definitions>>) ( class -- slot-defs ) + superclasses [ MDB_SLOTOPT_PROP word-prop ] map assoc-combine ; inline + +: link-class ( class collection -- ) + tuck classes>> ! col class v{} + [ 2dup member? [ 2drop ] [ push ] if ] + [ 1vector >>classes ] if* drop ; + + +PRIVATE> + +M: tuple-class mdb-collection>> ( tuple -- mdb-collection ) + (mdb-collection>>) ; + +M: mdb-persistent mdb-collection>> ( tuple -- mdb-collection ) + class (mdb-collection>>) ; + +M: mdb-persistent mdb-slot-definitions>> ( tuple -- string ) + class (mdb-slot-definitions>>) ; + +M: tuple-class mdb-slot-definitions>> ( class -- assoc ) + (mdb-slot-definitions>>) ; + +M: mdb-collection mdb-slot-definitions>> ( collection -- assoc ) + classes>> [ mdb-slot-definitions>> ] map assoc-combine ; + +: link-collection ( class collection -- ) + 2dup link-class + swap [ MDB_COL_PROP ] dip props>> set-at ; inline + +: declared-collections> ( -- assoc ) + MDB_COLLECTIONS mdb-persistent props>> at + [ H{ } clone + [ MDB_COLLECTIONS mdb-persistent props>> set-at ] keep + ] unless* ; + +: ( name -- mdb-collection ) + declared-collections> 2dup key? + [ at ] + [ [ mdb-collection new ] 2dip + [ [ >>name dup ] keep ] dip set-at ] if ; + +: load-collections ( -- collections ) + namespaces-ns + H{ } clone (find) + objects>> [ [ "name" ] dip at "." split second ] map + dup [ ensure-indices ] each + [ mdb>> ] dip >>collections collections>> ; + +: check-ok ( result -- ? ) + [ "ok" ] dip key? ; inline + +: create-collection ( mdb-collection -- ) + dup name>> "create" H{ } clone [ set-at ] keep + [ + mdb>> [ master>> ] keep name>> "%s.$cmd" sprintf + ] dip (find-one) + check-ok + [ [ ensure-indices ] keep dup name>> mdb>> collections>> set-at ] + [ "could not create collection" throw ] if ; + +: get-collection-fqn ( mdb-collection -- fqdn ) + mdb>> collections>> + dup keys length 0 = + [ drop load-collections ] + [ ] if + [ dup name>> ] dip + key? + [ ] + [ dup create-collection ] if + name>> [ mdb>> name>> ] dip "%s.%s" sprintf ; diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor new file mode 100644 index 0000000000..c870ed7875 --- /dev/null +++ b/mongodb/connection/connection.factor @@ -0,0 +1,61 @@ +USING: accessors assocs fry io.sockets kernel math mongodb.msg +mongodb.query namespaces sequences splitting math.parser ; + +IN: mongodb.connection + +TUPLE: mdb-node master? inet ; + +TUPLE: mdb name nodes collections ; + +: mdb>> ( -- mdb ) + mdb get ; inline + +: with-db ( mdb quot -- ... ) + '[ _ mdb set _ call ] with-scope ; + +: master>> ( mdb -- inet ) + nodes>> [ t ] dip at inet>> ; + +: slave>> ( mdb -- inet ) + nodes>> [ f ] dip at inet>> ; + + + (find-one-raw) ; inline + +: -push ( seq elt -- ) + swap push ; inline + +: split-host-str ( hoststr -- host port ) + ":" split [ first ] keep + second string>number ; inline + +: check-nodes ( node -- nodelist ) + [ V{ } clone ] dip + [ -push ] 2keep + dup inet>> ismaster-cmd ! vec node result + dup [ "ismaster" ] dip at + >fixnum 1 = ! vec node result + [ [ t >>master? drop ] dip f ] + [ [ f >>master? drop ] dip t ] if + [ "remote" ] 2dip [ at split-host-str ] dip + swap mdb-node boa swap + [ push ] keep ; + +: verify-nodes ( -- ) + mdb>> nodes>> [ t ] dip at + check-nodes + H{ } clone tuck + '[ dup master?>> _ set-at ] each + [ mdb>> ] dip >>nodes drop ; + +PRIVATE> + +: () ( db host port -- mdb ) + [ f ] 2dip mdb-node boa + check-nodes + H{ } clone tuck + '[ dup master?>> _ set-at ] each + V{ } mdb boa ; diff --git a/mongodb/index/index.factor b/mongodb/index/index.factor new file mode 100644 index 0000000000..407abe5b48 --- /dev/null +++ b/mongodb/index/index.factor @@ -0,0 +1,99 @@ +USING: accessors assocs combinators formatting fry kernel memoize +linked-assocs mongodb.persistent mongodb.msg +sequences sequences.deep io.encodings.binary +io.sockets prettyprint sets ; + +IN: mongodb.index + +DEFER: mdb-slot-definitions>> + +TUPLE: index name ns key ; + +SYMBOLS: +fieldindex+ +compoundindex+ +deepindex+ ; + + ] 2dip + [ rest ] keep first ! assoc slot options itype + { { +fieldindex+ [ drop [ 1 ] dip pick set-at ] } + { +deepindex+ [ first "%s.%s" sprintf [ 1 ] dip pick set-at ] } + { +compoundindex+ [ + 2over swap [ 1 ] 2dip set-at [ drop ] dip ! assoc options + over '[ _ [ 1 ] 2dip set-at ] each ] } + } case ; + +: build-index-seq ( slot optlist ns -- index-seq ) + [ V{ } clone ] 3dip ! v{} slot optl ns + [ index new ] dip ! v{} slot optl index ns + >>ns + [ pick ] dip swap ! v{} slot optl index v{} + [ swap ] 2dip ! v{} optl slot index v{ } + '[ _ _ ! element slot exemplar + clone 2over swap index-name >>name ! element slot clone + [ build-index ] dip swap >>key _ push + ] each ; + +: is-index-declaration? ( entry -- ? ) + first + { { +fieldindex+ [ t ] } + { +compoundindex+ [ t ] } + { +deepindex+ [ t ] } + [ drop f ] } case ; + +: index-assoc ( seq -- assoc ) + H{ } clone tuck '[ dup name>> _ set-at ] each ; + +: delete-index ( name ns -- ) + "Drop index %s - %s" sprintf . ; + +: clean-indices ( existing defined -- ) + [ index-assoc ] bi@ assoc-diff values + [ [ name>> ] [ ns>> ] bi delete-index ] each ; + +PRIVATE> + +USE: mongodb.query + +: load-indices ( mdb-collection -- indexlist ) + [ mdb>> name>> ] dip name>> "%s.%s" sprintf + "ns" H{ } clone [ set-at ] keep [ index-ns ] dip + '[ _ write-request read-reply ] + [ mdb>> master>> binary ] dip with-client + objects>> [ [ index new ] dip + [ [ "ns" ] dip at >>ns ] + [ [ "name" ] dip at >>name ] + [ [ "key" ] dip at >>key ] tri + ] map ; + +: build-indices ( mdb-collection mdb -- seq ) + name>> + [ [ mdb-slot-definitions>> ] keep name>> ] dip + swap "%s.%s" sprintf + [ V{ } clone ] 2dip pick + '[ _ + [ [ is-index-declaration? ] filter ] dip + build-index-seq _ push + ] assoc-each flatten ; + +: ensure-indices ( mdb-collection -- ) + [ load-indices ] keep mdb>> build-indices + [ clean-indices ] keep + V{ } clone tuck + '[ _ [ tuple>query ] dip push ] each + mdb>> name>> "%s.system.indexes" sprintf >>collection + [ mdb>> master>> binary ] dip '[ _ write-request ] with-client ; + + +: show-indices ( mdb-collection -- ) + load-indices . ; diff --git a/mongodb/mongodb.factor b/mongodb/mongodb.factor index b9c15c0317..4c258eeb98 100644 --- a/mongodb/mongodb.factor +++ b/mongodb/mongodb.factor @@ -1,14 +1,19 @@ USING: accessors assocs fry io.encodings.binary io.sockets kernel math -math.parser mongodb.msg mongodb.persistent mongodb.query mongodb.tuple -namespaces sequences splitting ; +math.parser namespaces sequences splitting ; IN: mongodb -INTERSECTION: storable mdb-persistent ; +! generic methods +GENERIC: store ( tuple/ht -- ) +GENERIC: find ( example -- tuple/ht ) +GENERIC: findOne ( exampe -- tuple/ht ) +GENERIC: load ( object -- object ) + +USING: mongodb.msg mongodb.persistent mongodb.query mongodb.tuple +mongodb.collection mongodb.connection ; > get-collection-fqn ] keep H{ } tuple>query ; inline @@ -20,16 +25,8 @@ PRIVATE> () ; -GENERIC: store ( tuple/ht -- ) -GENERIC: find ( example -- tuple/ht ) - -GENERIC: findOne ( exampe -- tuple/ht ) - -GENERIC: load ( object -- object ) - - -M: storable store ( tuple -- ) +M: mdb-persistent store ( tuple -- ) prepare-store ! H { collection { ... values ... } [ [ ] 2dip [ get-collection-fqn >>collection ] dip @@ -37,11 +34,11 @@ M: storable store ( tuple -- ) [ mdb>> master>> binary ] dip '[ _ write-request ] with-client ] assoc-each ; -M: storable find ( example -- result ) +M: mdb-persistent find ( example -- result ) prepare-find (find) build-result ; -M: storable findOne ( example -- result ) +M: mdb-persistent findOne ( example -- result ) prepare-find (find-one) dup returned#>> 1 = [ objects>> first ] diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor new file mode 100644 index 0000000000..faafaf4b7b --- /dev/null +++ b/mongodb/msg/msg.factor @@ -0,0 +1,144 @@ +USING: io io.encodings.utf8 io.encodings.binary alien.c-types alien.strings math +bson.writer sequences kernel accessors io.streams.byte-array fry generalizations +combinators bson.reader sequences tools.walker assocs strings mongodb.persistent ; + +IN: mongodb.msg + +DEFER: tuple>linked-assoc + + + +TUPLE: mdb-msg + { opcode integer } + { req-id integer initial: 0 } + { resp-id integer initial: 0 } + { length integer initial: 0 } ; + +TUPLE: mdb-insert-msg < mdb-msg + { collection string } + { objects sequence } ; + +TUPLE: mdb-query-msg < mdb-msg + { collection string } + { skip# integer initial: 0 } + { return# integer initial: 0 } + { query assoc } + { returnfields assoc } + { orderby sequence } ; + +TUPLE: mdb-reply-msg < mdb-msg + { flags integer initial: 0 } + { cursor integer initial: 0 } + { start# integer initial: 0 } + { returned# integer initial: 0 } + { objects sequence } ; + + +: ( collection assoc -- mdb-query-msg ) + [ mdb-query-msg new ] 2dip + [ >>collection ] dip + >>query OP_Query >>opcode ; inline + +: ( collection assoc -- mdb-query-msg ) + 1 >>return# ; inline + +GENERIC: ( sequence -- mdb-insert-msg ) + +M: tuple ( tuple -- mdb-insert-msg ) + [ mdb-insert-msg new ] dip + tuple>linked-assoc V{ } clone tuck push + >>objects OP_Insert >>opcode ; + +M: sequence ( sequence -- mdb-insert-msg ) + [ mdb-insert-msg new ] dip >>objects OP_Insert >>opcode ; + + +: ( -- mdb-reply-msg ) + mdb-reply-msg new ; inline + + +GENERIC: write-request ( message -- ) + + write ; inline +: write-int32 ( int -- ) write ; inline +: write-double ( real -- ) write ; inline +: write-cstring ( string -- ) utf8 string>alien write ; inline +: write-longlong ( object -- ) write ; inline + +: read-int32 ( -- int32 ) 4 read *int ; inline +: read-longlong ( -- longlong ) 8 read *longlong ; inline +: read-byte-raw ( -- byte-raw ) 1 read ; inline +: read-byte ( -- byte ) read-byte-raw *char ; inline + +: (read-cstring) ( acc -- acc ) + read-byte-raw dup + B{ 0 } = + [ append ] + [ append (read-cstring) ] if ; recursive inline + +: read-cstring ( -- string ) + B{ } clone + (read-cstring) utf8 alien>string ; inline + +PRIVATE> + +: read-reply-header ( message -- message ) + read-int32 >>length + read-int32 >>req-id + read-int32 >>resp-id + read-int32 >>opcode ; inline + +: read-reply-message ( message -- message ) + read-int32 >>flags read-longlong >>cursor + read-int32 >>start# read-int32 tuck >>returned# swap + [ H{ } stream>assoc ] accumulator [ times ] dip >>objects ; inline + +: read-reply ( -- message ) + + read-reply-header + read-reply-message ; inline + +: write-request-header ( message length -- ) + MSG-HEADER-SIZE + write-int32 + [ req-id>> write-int32 ] keep + [ resp-id>> write-int32 ] keep + opcode>> write-int32 ; inline + +: (write-message) ( message quot -- ) + [ binary ] dip with-byte-writer dup + [ length write-request-header ] dip + write flush ; inline + +M: mdb-query-msg write-request ( message -- ) + dup + '[ _ + [ 4 write-int32 ] dip + [ collection>> write-cstring ] keep + [ skip#>> write-int32 ] keep + [ return#>> write-int32 ] keep + query>> assoc>array write + ] (write-message) ; + +M: mdb-insert-msg write-request ( message -- ) + dup + '[ _ + [ 0 write-int32 ] dip + [ collection>> write-cstring ] keep + objects>> [ assoc>array write ] each + ] (write-message) ; + diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor index c7c3fcf134..7967fd129c 100644 --- a/mongodb/persistent/persistent.factor +++ b/mongodb/persistent/persistent.factor @@ -20,13 +20,9 @@ GENERIC# tuple>assoc 1 ( tuple exemplar -- assoc ) GENERIC# tuple>query 1 ( tuple examplar -- query-assoc ) -GENERIC: mdb-collection>> ( tuple -- string ) - -GENERIC: mdb-slot-definitions>> ( tuple -- string ) - - DEFER: assoc>tuple DEFER: create-mdb-command +DEFER: mdb-collection>> > ( -- mdb ) + mdb get ; inline + +: with-db ( mdb quot -- * ) + '[ _ mdb set _ call ] with-scope ; inline + +: master>> ( mdb -- inet ) + nodes>> [ t ] dip at ; + +: slave>> ( mdb -- inet ) + nodes>> [ f ] dip at ; + +TUPLE: mdb-result { cursor integer } +{ start# integer } +{ returned# integer } +{ objects sequence } ; + +: index-ns ( -- ns ) + mdb>> name>> "%s.system.indexes" sprintf ; inline + +: namespaces-ns ( -- ns ) + mdb>> name>> "%s.system.namespaces" sprintf ; inline + + + +: (find-raw) ( inet query -- result ) + '[ _ write-request read-reply ] (execute-query) ; inline + +: (find-one-raw) ( inet query -- result ) + (find-raw) objects>> first ; inline + +: (find) ( query -- result ) + [ mdb>> master>> ] dip (find-raw) ; + +: (find-one) ( query -- result ) + [ mdb>> master>> ] dip (find-one-raw) ; + +: build-result ( resultmsg -- mdb-result ) + [ mdb-result new ] dip + { + [ cursor>> >>cursor ] + [ start#>> >>start# ] + [ returned#>> >>returned# ] + [ objects>> [ assoc>tuple ] map >>objects ] + } cleave ; + +: query-collections ( -- result ) + namespaces-ns H{ } clone (find) ; + diff --git a/mongodb/tuple/tuple.factor b/mongodb/tuple/tuple.factor new file mode 100644 index 0000000000..3a8cb09292 --- /dev/null +++ b/mongodb/tuple/tuple.factor @@ -0,0 +1,66 @@ +USING: accessors assocs classes classes.mixin classes.tuple vectors math +classes.tuple.parser formatting generalizations kernel sequences fry +prettyprint strings compiler.units slots tools.walker words arrays +mongodb.collection mongodb.persistent ; + +IN: mongodb.tuple + +> ] map [ MDB_OID ] dip memq? + [ ] + [ MDB_P_SLOTS prepend ] if ; inline + +PRIVATE> + +: show-persistence-info ( class -- ) + H{ } clone + [ [ dup mdb-collection>> "collection" ] dip set-at ] keep + [ [ mdb-slot-definitions>> "slots" ] dip set-at ] keep . ; + +GENERIC: mdb-persisted? ( tuple -- ? ) + +M: mdb-persistent mdb-persisted? ( tuple -- ? ) + _id>> f = not ; + +M: assoc mdb-persisted? ( assoc -- ? ) + [ MDB_OID ] dip key? ; inline + +: MDBTUPLE: + parse-tuple-definition + mdb-check-id-slot + define-tuple-class ; parsing + +> ! col class v{} + [ 2dup member? [ 2drop ] [ push ] if ] + [ 1vector >>classes ] if* drop ; + +: optl>assoc ( seq -- assoc ) + [ dup assoc? + [ 1array { "" } append ] unless + ] map ; + +PRIVATE> + +: set-slot-options ( class options -- ) + H{ } clone tuck '[ _ [ split-olist optl>assoc swap ] dip set-at ] each + over [ MDB_SLOTOPT_PROP ] dip props>> set-at + dup mdb-collection>> link-collection ; + +: define-collection ( class collection options -- ) + [ [ dup ] dip link-collection ] dip ! cl options + [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip + set-slot-options ; + From ef9971840d8ebbeefc9085562c1110678a0a70bd Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Tue, 27 Jan 2009 19:42:29 +0100 Subject: [PATCH 012/101] some more cleaning up --- mongodb/collection/collection.factor | 105 --------------------------- mongodb/connection/connection.factor | 9 ++- mongodb/index/index.factor | 26 +++++-- mongodb/mongodb.factor | 20 ++--- mongodb/msg/msg.factor | 19 ++--- mongodb/persistent/persistent.factor | 12 +-- mongodb/query/query.factor | 75 ++++++++++--------- mongodb/tuple/tuple.factor | 79 ++++++++++++++++++-- 8 files changed, 155 insertions(+), 190 deletions(-) delete mode 100644 mongodb/collection/collection.factor diff --git a/mongodb/collection/collection.factor b/mongodb/collection/collection.factor deleted file mode 100644 index c7c72d8fad..0000000000 --- a/mongodb/collection/collection.factor +++ /dev/null @@ -1,105 +0,0 @@ -USING: accessors assocs formatting kernel math classes sequences splitting strings - words classes.tuple vectors ; - -IN: mongodb.collection - -GENERIC: mdb-slot-definitions>> ( tuple -- string ) -GENERIC: mdb-collection>> ( object -- mdb-collection ) - -CONSTANT: MDB_COLLECTIONS "mdb_collections" - -SYMBOLS: +transient+ +load+ ; - -UNION: boolean t POSTPONE: f ; - -TUPLE: mdb-collection - { name string } - { capped boolean initial: f } - { size integer initial: -1 } - { max integer initial: -1 } - { classes sequence } ; - -USING: mongodb.persistent mongodb.msg mongodb.tuple -mongodb.connection mongodb.query mongodb.index ; - ->) ( class -- mdb-collection ) - dup props>> [ MDB_COL_PROP ] dip at - [ [ drop ] dip ] - [ superclass [ (mdb-collection>>) ] [ f ] if* ] if* ; inline recursive - -: (mdb-slot-definitions>>) ( class -- slot-defs ) - superclasses [ MDB_SLOTOPT_PROP word-prop ] map assoc-combine ; inline - -: link-class ( class collection -- ) - tuck classes>> ! col class v{} - [ 2dup member? [ 2drop ] [ push ] if ] - [ 1vector >>classes ] if* drop ; - - -PRIVATE> - -M: tuple-class mdb-collection>> ( tuple -- mdb-collection ) - (mdb-collection>>) ; - -M: mdb-persistent mdb-collection>> ( tuple -- mdb-collection ) - class (mdb-collection>>) ; - -M: mdb-persistent mdb-slot-definitions>> ( tuple -- string ) - class (mdb-slot-definitions>>) ; - -M: tuple-class mdb-slot-definitions>> ( class -- assoc ) - (mdb-slot-definitions>>) ; - -M: mdb-collection mdb-slot-definitions>> ( collection -- assoc ) - classes>> [ mdb-slot-definitions>> ] map assoc-combine ; - -: link-collection ( class collection -- ) - 2dup link-class - swap [ MDB_COL_PROP ] dip props>> set-at ; inline - -: declared-collections> ( -- assoc ) - MDB_COLLECTIONS mdb-persistent props>> at - [ H{ } clone - [ MDB_COLLECTIONS mdb-persistent props>> set-at ] keep - ] unless* ; - -: ( name -- mdb-collection ) - declared-collections> 2dup key? - [ at ] - [ [ mdb-collection new ] 2dip - [ [ >>name dup ] keep ] dip set-at ] if ; - -: load-collections ( -- collections ) - namespaces-ns - H{ } clone (find) - objects>> [ [ "name" ] dip at "." split second ] map - dup [ ensure-indices ] each - [ mdb>> ] dip >>collections collections>> ; - -: check-ok ( result -- ? ) - [ "ok" ] dip key? ; inline - -: create-collection ( mdb-collection -- ) - dup name>> "create" H{ } clone [ set-at ] keep - [ - mdb>> [ master>> ] keep name>> "%s.$cmd" sprintf - ] dip (find-one) - check-ok - [ [ ensure-indices ] keep dup name>> mdb>> collections>> set-at ] - [ "could not create collection" throw ] if ; - -: get-collection-fqn ( mdb-collection -- fqdn ) - mdb>> collections>> - dup keys length 0 = - [ drop load-collections ] - [ ] if - [ dup name>> ] dip - key? - [ ] - [ dup create-collection ] if - name>> [ mdb>> name>> ] dip "%s.%s" sprintf ; diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor index c870ed7875..2a7e04f504 100644 --- a/mongodb/connection/connection.factor +++ b/mongodb/connection/connection.factor @@ -1,5 +1,5 @@ USING: accessors assocs fry io.sockets kernel math mongodb.msg -mongodb.query namespaces sequences splitting math.parser ; +namespaces sequences splitting math.parser io.encodings.binary ; IN: mongodb.connection @@ -22,8 +22,9 @@ TUPLE: mdb name nodes collections ; - (find-one-raw) ; inline + binary "admin.$cmd" H{ { "ismaster" 1 } } + '[ _ write-request read-reply ] with-client + objects>> first ; : -push ( seq elt -- ) swap push ; inline @@ -58,4 +59,4 @@ PRIVATE> check-nodes H{ } clone tuck '[ dup master?>> _ set-at ] each - V{ } mdb boa ; + H{ } clone mdb boa ; diff --git a/mongodb/index/index.factor b/mongodb/index/index.factor index 407abe5b48..bb930e02d2 100644 --- a/mongodb/index/index.factor +++ b/mongodb/index/index.factor @@ -1,11 +1,12 @@ USING: accessors assocs combinators formatting fry kernel memoize -linked-assocs mongodb.persistent mongodb.msg -sequences sequences.deep io.encodings.binary -io.sockets prettyprint sets ; +linked-assocs mongodb.persistent mongodb.msg mongodb.connection +sequences sequences.deep io.encodings.binary mongodb.tuple +io.sockets prettyprint sets tools.walker math ; IN: mongodb.index -DEFER: mdb-slot-definitions>> +: index-ns ( name -- ns ) + "%s.system.indexes" sprintf ; inline TUPLE: index name ns key ; @@ -24,6 +25,7 @@ SYMBOLS: +fieldindex+ +compoundindex+ +deepindex+ ; "%s-%s-%s-Idx" sprintf ; : build-index ( element slot -- assoc ) + break swap [ ] 2dip [ rest ] keep first ! assoc slot options itype { { +fieldindex+ [ drop [ 1 ] dip pick set-at ] } @@ -67,7 +69,7 @@ USE: mongodb.query : load-indices ( mdb-collection -- indexlist ) [ mdb>> name>> ] dip name>> "%s.%s" sprintf - "ns" H{ } clone [ set-at ] keep [ index-ns ] dip + "ns" H{ } clone [ set-at ] keep [ mdb>> name>> index-ns ] dip '[ _ write-request read-reply ] [ mdb>> master>> binary ] dip with-client objects>> [ [ index new ] dip @@ -91,9 +93,17 @@ USE: mongodb.query [ clean-indices ] keep V{ } clone tuck '[ _ [ tuple>query ] dip push ] each - mdb>> name>> "%s.system.indexes" sprintf >>collection - [ mdb>> master>> binary ] dip '[ _ write-request ] with-client ; - + dup length 0 > + [ [ mdb>> name>> "%s.system.indexes" sprintf ] dip + + [ mdb>> master>> binary ] dip '[ _ write-request ] with-client + ] + [ drop ] if ; : show-indices ( mdb-collection -- ) load-indices . ; + +: show-all-indices ( -- ) + mdb>> collections>> values + V{ } clone tuck + '[ load-indices _ push ] each flatten . ; \ No newline at end of file diff --git a/mongodb/mongodb.factor b/mongodb/mongodb.factor index 4c258eeb98..a1cd3d7aff 100644 --- a/mongodb/mongodb.factor +++ b/mongodb/mongodb.factor @@ -1,5 +1,7 @@ USING: accessors assocs fry io.encodings.binary io.sockets kernel math -math.parser namespaces sequences splitting ; +math.parser namespaces sequences splitting +mongodb.connection mongodb.persistent mongodb.msg mongodb.query +mongodb.tuple ; IN: mongodb @@ -9,9 +11,6 @@ GENERIC: find ( example -- tuple/ht ) GENERIC: findOne ( exampe -- tuple/ht ) GENERIC: load ( object -- object ) -USING: mongodb.msg mongodb.persistent mongodb.query mongodb.tuple -mongodb.collection mongodb.connection ; - : ( db host port -- mdb ) () ; - - M: mdb-persistent store ( tuple -- ) prepare-store ! H { collection { ... values ... } - [ [ ] 2dip - [ get-collection-fqn >>collection ] dip - objects>> - [ mdb>> master>> binary ] dip '[ _ write-request ] with-client + [ [ get-collection-fqn ] dip + values + [ mdb>> master>> binary ] dip '[ _ write-request ] with-client ] assoc-each ; M: mdb-persistent find ( example -- result ) - prepare-find (find) + prepare-find [ mdb>> master>> ] dip (find) build-result ; M: mdb-persistent findOne ( example -- result ) - prepare-find (find-one) + prepare-find [ mdb>> master>> ] dip (find-one) dup returned#>> 1 = [ objects>> first ] [ drop f ] if ; diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index faafaf4b7b..e61006e01b 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -1,11 +1,9 @@ USING: io io.encodings.utf8 io.encodings.binary alien.c-types alien.strings math bson.writer sequences kernel accessors io.streams.byte-array fry generalizations -combinators bson.reader sequences tools.walker assocs strings mongodb.persistent ; +combinators bson.reader sequences tools.walker assocs strings linked-assocs ; IN: mongodb.msg -DEFER: tuple>linked-assoc - ( collection assoc -- mdb-query-msg ) 1 >>return# ; inline -GENERIC: ( sequence -- mdb-insert-msg ) +GENERIC# 1 ( collection objects -- mdb-insert-msg ) -M: tuple ( tuple -- mdb-insert-msg ) - [ mdb-insert-msg new ] dip - tuple>linked-assoc V{ } clone tuck push +M: linked-assoc ( collection linked-assoc -- mdb-insert-msg ) + [ mdb-insert-msg new ] 2dip + [ >>collection ] dip + V{ } clone tuck push >>objects OP_Insert >>opcode ; -M: sequence ( sequence -- mdb-insert-msg ) - [ mdb-insert-msg new ] dip >>objects OP_Insert >>opcode ; +M: sequence ( collection sequence -- mdb-insert-msg ) + [ mdb-insert-msg new ] 2dip + [ >>collection ] dip + >>objects OP_Insert >>opcode ; : ( -- mdb-reply-msg ) diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor index 7967fd129c..249a9d60af 100644 --- a/mongodb/persistent/persistent.factor +++ b/mongodb/persistent/persistent.factor @@ -1,16 +1,9 @@ USING: accessors assocs classes fry kernel linked-assocs math mirrors namespaces sequences strings vectors words bson.constants -continuations ; +continuations mongodb.tuple ; IN: mongodb.persistent -MIXIN: mdb-persistent - -SLOT: _id - -CONSTANT: MDB_P_SLOTS { "_id" } -CONSTANT: MDB_OID "_id" - SYMBOL: mdb-op-seq GENERIC# tuple>assoc 1 ( tuple exemplar -- assoc ) @@ -22,12 +15,13 @@ GENERIC# tuple>query 1 ( tuple examplar -- query-assoc ) DEFER: assoc>tuple DEFER: create-mdb-command -DEFER: mdb-collection>> ( tuple -- dbref ) [ mdb-collection>> ] [ _id>> ] bi dbref boa ; inline diff --git a/mongodb/query/query.factor b/mongodb/query/query.factor index 92c483bf2b..aede6a267f 100644 --- a/mongodb/query/query.factor +++ b/mongodb/query/query.factor @@ -1,54 +1,29 @@ USING: accessors combinators fry io.encodings.binary io.sockets kernel -mongodb.msg mongodb.persistent sequences math namespaces assocs -formatting ; +mongodb.msg mongodb.persistent mongodb.connection sequences math namespaces assocs +formatting splitting mongodb.tuple mongodb.index ; IN: mongodb.query -TUPLE: mdb-node master? inet ; - -TUPLE: mdb name nodes collections ; - -: mdb>> ( -- mdb ) - mdb get ; inline - -: with-db ( mdb quot -- * ) - '[ _ mdb set _ call ] with-scope ; inline - -: master>> ( mdb -- inet ) - nodes>> [ t ] dip at ; - -: slave>> ( mdb -- inet ) - nodes>> [ f ] dip at ; - TUPLE: mdb-result { cursor integer } { start# integer } { returned# integer } { objects sequence } ; -: index-ns ( -- ns ) - mdb>> name>> "%s.system.indexes" sprintf ; inline +: namespaces-ns ( name -- ns ) + "%s.system.namespaces" sprintf ; inline -: namespaces-ns ( -- ns ) - mdb>> name>> "%s.system.namespaces" sprintf ; inline - -: (find-raw) ( inet query -- result ) - '[ _ write-request read-reply ] (execute-query) ; inline +: (find) ( inet query -- result ) + '[ _ write-request read-reply ] (execute-query) ; inline -: (find-one-raw) ( inet query -- result ) - (find-raw) objects>> first ; inline - -: (find) ( query -- result ) - [ mdb>> master>> ] dip (find-raw) ; - -: (find-one) ( query -- result ) - [ mdb>> master>> ] dip (find-one-raw) ; +: (find-one) ( inet query -- result ) + (find) objects>> first ; inline : build-result ( resultmsg -- mdb-result ) [ mdb-result new ] dip @@ -59,6 +34,34 @@ PRIVATE> [ objects>> [ assoc>tuple ] map >>objects ] } cleave ; -: query-collections ( -- result ) - namespaces-ns H{ } clone (find) ; +: load-collections ( -- collections ) + mdb>> [ master>> ] [ name>> namespaces-ns ] bi + H{ } clone (find) + objects>> [ [ "name" ] dip at "." split second ] map + H{ } clone tuck + '[ [ ensure-indices ] [ ] [ name>> ] tri _ set-at ] each + [ mdb>> ] dip >>collections collections>> ; + +: check-ok ( result -- ? ) + [ "ok" ] dip key? ; inline +: create-collection ( mdb-collection -- ) + dup name>> "create" H{ } clone [ set-at ] keep + [ mdb>> [ master>> ] [ name>> ] bi "%s.$cmd" sprintf ] dip + (find-one) + check-ok + [ [ ensure-indices ] keep dup name>> mdb>> collections>> set-at ] + [ "could not create collection" throw ] if ; + +: get-collection-fqn ( mdb-collection -- fqdn ) + mdb>> collections>> + dup keys length 0 = + [ drop load-collections ] + [ ] if + [ dup name>> ] dip + key? + [ ] + [ dup create-collection ] if + name>> [ mdb>> name>> ] dip "%s.%s" sprintf ; + + \ No newline at end of file diff --git a/mongodb/tuple/tuple.factor b/mongodb/tuple/tuple.factor index 3a8cb09292..16e408d78e 100644 --- a/mongodb/tuple/tuple.factor +++ b/mongodb/tuple/tuple.factor @@ -1,16 +1,85 @@ USING: accessors assocs classes classes.mixin classes.tuple vectors math classes.tuple.parser formatting generalizations kernel sequences fry -prettyprint strings compiler.units slots tools.walker words arrays -mongodb.collection mongodb.persistent ; +prettyprint strings compiler.units slots tools.walker words arrays mongodb.persistent ; IN: mongodb.tuple -> ( tuple -- string ) +GENERIC: mdb-collection>> ( object -- mdb-collection ) + +CONSTANT: MDB_COLLECTIONS "mdb_collections" +CONSTANT: MDB_COL_PROP "mdb_collection" CONSTANT: MDB_SLOTOPT_PROP "mdb_slot_options" + +SLOT: _id CONSTANT: MDB_P_SLOTS { "_id" } CONSTANT: MDB_OID "_id" +SYMBOLS: +transient+ +load+ ; + +UNION: boolean t POSTPONE: f ; + +TUPLE: mdb-collection + { name string } + { capped boolean initial: f } + { size integer initial: -1 } + { max integer initial: -1 } + { classes sequence } ; + +>) ( class -- mdb-collection ) + dup props>> [ MDB_COL_PROP ] dip at + [ [ drop ] dip ] + [ superclass [ (mdb-collection>>) ] [ f ] if* ] if* ; inline recursive + +: (mdb-slot-definitions>>) ( class -- slot-defs ) + superclasses [ MDB_SLOTOPT_PROP word-prop ] map assoc-combine ; inline + +: link-class ( class collection -- ) + tuck classes>> ! col class v{} + [ 2dup member? [ 2drop ] [ push ] if ] + [ 1vector >>classes ] if* drop ; + +PRIVATE> + +M: tuple-class mdb-collection>> ( tuple -- mdb-collection ) + (mdb-collection>>) ; + +M: mdb-persistent mdb-collection>> ( tuple -- mdb-collection ) + class (mdb-collection>>) ; + +M: mdb-persistent mdb-slot-definitions>> ( tuple -- string ) + class (mdb-slot-definitions>>) ; + +M: tuple-class mdb-slot-definitions>> ( class -- assoc ) + (mdb-slot-definitions>>) ; + +M: mdb-collection mdb-slot-definitions>> ( collection -- assoc ) + classes>> [ mdb-slot-definitions>> ] map assoc-combine ; + +: link-collection ( class collection -- ) + 2dup link-class + swap [ MDB_COL_PROP ] dip props>> set-at ; inline + +: declared-collections> ( -- assoc ) + MDB_COLLECTIONS mdb-persistent props>> at + [ H{ } clone + [ MDB_COLLECTIONS mdb-persistent props>> set-at ] keep + ] unless* ; + +: ( name -- mdb-collection ) + declared-collections> 2dup key? + [ at ] + [ [ mdb-collection new ] 2dip + [ [ >>name dup ] keep ] dip set-at ] if ; + +> ] map [ MDB_OID ] dip memq? @@ -42,10 +111,6 @@ M: assoc mdb-persisted? ( assoc -- ? ) : split-olist ( seq -- key options ) [ first ] [ rest ] bi ; inline -: link-class ( class collection -- ) - tuck classes>> ! col class v{} - [ 2dup member? [ 2drop ] [ push ] if ] - [ 1vector >>classes ] if* drop ; : optl>assoc ( seq -- assoc ) [ dup assoc? From fa8aa747b9b49b1bdaddb336ced35cc743c22c4d Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Wed, 28 Jan 2009 21:11:45 +0100 Subject: [PATCH 013/101] added mongo message monitor in factor... fixed some things, unified read/write message --- mongodb/connection/connection.factor | 2 +- mongodb/index/index.factor | 5 +- mongodb/mmm/mmm.factor | 90 ++++++++++++++++++++++ mongodb/mongodb.factor | 2 +- mongodb/msg/msg.factor | 111 ++++++++++++++++++--------- mongodb/query/query.factor | 2 +- 6 files changed, 169 insertions(+), 43 deletions(-) create mode 100644 mongodb/mmm/mmm.factor diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor index 2a7e04f504..569a68aa3b 100644 --- a/mongodb/connection/connection.factor +++ b/mongodb/connection/connection.factor @@ -23,7 +23,7 @@ TUPLE: mdb name nodes collections ; : ismaster-cmd ( node -- result ) binary "admin.$cmd" H{ { "ismaster" 1 } } - '[ _ write-request read-reply ] with-client + '[ _ write-message read-message ] with-client objects>> first ; : -push ( seq elt -- ) diff --git a/mongodb/index/index.factor b/mongodb/index/index.factor index bb930e02d2..487251c27f 100644 --- a/mongodb/index/index.factor +++ b/mongodb/index/index.factor @@ -25,7 +25,6 @@ SYMBOLS: +fieldindex+ +compoundindex+ +deepindex+ ; "%s-%s-%s-Idx" sprintf ; : build-index ( element slot -- assoc ) - break swap [ ] 2dip [ rest ] keep first ! assoc slot options itype { { +fieldindex+ [ drop [ 1 ] dip pick set-at ] } @@ -70,7 +69,7 @@ USE: mongodb.query : load-indices ( mdb-collection -- indexlist ) [ mdb>> name>> ] dip name>> "%s.%s" sprintf "ns" H{ } clone [ set-at ] keep [ mdb>> name>> index-ns ] dip - '[ _ write-request read-reply ] + '[ _ write-message read-message ] [ mdb>> master>> binary ] dip with-client objects>> [ [ index new ] dip [ [ "ns" ] dip at >>ns ] @@ -96,7 +95,7 @@ USE: mongodb.query dup length 0 > [ [ mdb>> name>> "%s.system.indexes" sprintf ] dip - [ mdb>> master>> binary ] dip '[ _ write-request ] with-client + [ mdb>> master>> binary ] dip '[ _ write-message ] with-client ] [ drop ] if ; diff --git a/mongodb/mmm/mmm.factor b/mongodb/mmm/mmm.factor new file mode 100644 index 0000000000..93281f4134 --- /dev/null +++ b/mongodb/mmm/mmm.factor @@ -0,0 +1,90 @@ +USING: accessors fry io io.encodings.binary io.servers.connection +io.sockets io.streams.byte-array kernel math mongodb.msg classes formatting +mongodb.msg.private namespaces prettyprint tools.walker calendar calendar.format ; + +IN: mongodb.mmm + +SYMBOLS: mmm-port mmm-server-ip mmm-server-port mmm-server mmm-dump-output mmm-t-srv ; + +GENERIC: dump-message ( message -- ) + +: check-options ( -- ) + mmm-port get [ 27040 mmm-port set ] unless + mmm-server-ip get [ "127.0.0.1" mmm-server-ip set ] unless + mmm-server-port get [ 27017 mmm-server-port set ] unless + mmm-server-ip get mmm-server-port get mmm-server set ; + +: read-msg-binary ( -- ) + read-int32 + [ write-int32 ] keep + 4 - read write ; + +: read-request-header ( -- msg-stub ) + mdb-msg new + read-int32 MSG-HEADER-SIZE - >>length + read-int32 >>req-id + read-int32 >>resp-id + read-int32 >>opcode ; + +: read-request ( -- msg-stub binary ) + binary [ read-msg-binary ] with-byte-writer + [ binary [ read-request-header ] with-byte-reader ] keep ; ! msg-stub binary + +: dump-request ( msg-stub binary -- ) + [ mmm-dump-output get ] 2dip + '[ _ drop _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ; + +: read-reply ( -- binary ) + binary [ read-msg-binary ] with-byte-writer ; + +: forward-request-read-reply ( msg-stub binary -- binary ) + [ mmm-server get binary ] 2dip + '[ _ opcode>> _ write flush + OP_Query = + [ read-reply ] + [ f ] if ] with-client ; + +: dump-reply ( binary -- ) + [ mmm-dump-output get ] dip + '[ _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ; + +: message-prefix ( message -- tst name message ) + [ now timestamp>http-string ] dip + [ class name>> ] keep ; inline + +M: mdb-query-msg dump-message ( message -- ) + message-prefix + collection>> + "%s: %s -> %s \n" printf ; + +M: mdb-insert-msg dump-message ( message -- ) + message-prefix + collection>> + "%s: %s -> %s \n" printf ; + +M: mdb-msg dump-message ( message -- ) + message-prefix drop "%s: %s \n" printf ; + +: forward-reply ( binary -- ) + write flush ; + +: handle-mmm-connection ( -- ) + read-request + [ dump-request ] 2keep + forward-request-read-reply + [ dump-reply ] keep + forward-reply ; + +: start-mmm-server ( -- ) + output-stream get mmm-dump-output set + [ mmm-t-srv set ] keep + "127.0.0.1" mmm-port get >>insecure + binary >>encoding + [ handle-mmm-connection ] >>handler + start-server* ; + +: run-mmm ( -- ) + check-options + start-mmm-server ; + +MAIN: run-mmm \ No newline at end of file diff --git a/mongodb/mongodb.factor b/mongodb/mongodb.factor index a1cd3d7aff..96800d3d87 100644 --- a/mongodb/mongodb.factor +++ b/mongodb/mongodb.factor @@ -27,7 +27,7 @@ M: mdb-persistent store ( tuple -- ) prepare-store ! H { collection { ... values ... } [ [ get-collection-fqn ] dip values - [ mdb>> master>> binary ] dip '[ _ write-request ] with-client + [ mdb>> master>> binary ] dip '[ _ write-message ] with-client ] assoc-each ; M: mdb-persistent find ( example -- result ) diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index e61006e01b..88d2421ce3 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -15,32 +15,39 @@ CONSTANT: OP_GetMore 2005 CONSTANT: OP_Delete 2006 CONSTANT: OP_KillCursors 2007 +PREDICATE: mdb-reply-op < integer OP_Reply = ; +PREDICATE: mdb-query-op < integer OP_Query = ; +PREDICATE: mdb-insert-op < integer OP_Insert = ; +PREDICATE: mdb-delete-op < integer OP_Delete = ; +PREDICATE: mdb-getmore-op < integer OP_GetMore = ; +PREDICATE: mdb-killcursors-op < integer OP_KillCursors = ; + PRIVATE> TUPLE: mdb-msg - { opcode integer } - { req-id integer initial: 0 } - { resp-id integer initial: 0 } - { length integer initial: 0 } ; +{ opcode integer } +{ req-id integer initial: 0 } +{ resp-id integer initial: 0 } +{ length integer initial: 0 } +{ flags integer initial: 0 } ; TUPLE: mdb-insert-msg < mdb-msg - { collection string } - { objects sequence } ; +{ collection string } +{ objects sequence } ; TUPLE: mdb-query-msg < mdb-msg - { collection string } - { skip# integer initial: 0 } - { return# integer initial: 0 } - { query assoc } - { returnfields assoc } - { orderby sequence } ; +{ collection string } +{ skip# integer initial: 0 } +{ return# integer initial: 0 } +{ query assoc } +{ returnfields assoc } +{ orderby sequence } ; TUPLE: mdb-reply-msg < mdb-msg - { flags integer initial: 0 } - { cursor integer initial: 0 } - { start# integer initial: 0 } - { returned# integer initial: 0 } - { objects sequence } ; +{ cursor integer initial: 0 } +{ start# integer initial: 0 } +{ returned# integer initial: 0 } +{ objects sequence } ; : ( collection assoc -- mdb-query-msg ) @@ -68,8 +75,7 @@ M: sequence ( collection sequence -- mdb-insert-msg ) : ( -- mdb-reply-msg ) mdb-reply-msg new ; inline - -GENERIC: write-request ( message -- ) +GENERIC: write-message ( message -- ) string ; inline -PRIVATE> +GENERIC: (read-message) ( message opcode -- message ) -: read-reply-header ( message -- message ) +: copy-header ( message msg-stub -- message ) + [ length>> ] keep [ >>length ] dip + [ req-id>> ] keep [ >>req-id ] dip + [ resp-id>> ] keep [ >>resp-id ] dip + [ opcode>> ] keep [ >>opcode ] dip + flags>> >>flags ; + +M: mdb-query-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-query-msg new ] dip copy-header + read-cstring >>collection + read-int32 >>skip# + read-int32 >>return# + H{ } stream>assoc >>query ; + +M: mdb-insert-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-insert-msg new ] dip copy-header + read-cstring >>collection + H{ } stream>assoc >>objects ; + +M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) + drop + [ ] dip copy-header + read-longlong >>cursor + read-int32 >>start# + read-int32 [ >>returned# ] keep + [ H{ } stream>assoc ] accumulator [ times ] dip >>objects ; + +: read-header ( message -- message ) read-int32 >>length read-int32 >>req-id read-int32 >>resp-id - read-int32 >>opcode ; inline + read-int32 >>opcode + read-int32 >>flags ; inline -: read-reply-message ( message -- message ) - read-int32 >>flags read-longlong >>cursor - read-int32 >>start# read-int32 tuck >>returned# swap - [ H{ } stream>assoc ] accumulator [ times ] dip >>objects ; inline - -: read-reply ( -- message ) - - read-reply-header - read-reply-message ; inline - -: write-request-header ( message length -- ) +: write-header ( message length -- ) MSG-HEADER-SIZE + write-int32 [ req-id>> write-int32 ] keep [ resp-id>> write-int32 ] keep opcode>> write-int32 ; inline +PRIVATE> + +: read-message ( -- message ) + mdb-msg new + read-header + [ ] [ opcode>> ] bi (read-message) ; + + + +M: mdb-query-msg write-message ( message -- ) dup '[ _ [ 4 write-int32 ] dip @@ -134,8 +171,8 @@ M: mdb-query-msg write-request ( message -- ) [ return#>> write-int32 ] keep query>> assoc>array write ] (write-message) ; - -M: mdb-insert-msg write-request ( message -- ) + +M: mdb-insert-msg write-message ( message -- ) dup '[ _ [ 0 write-int32 ] dip diff --git a/mongodb/query/query.factor b/mongodb/query/query.factor index aede6a267f..c3477d2678 100644 --- a/mongodb/query/query.factor +++ b/mongodb/query/query.factor @@ -20,7 +20,7 @@ TUPLE: mdb-result { cursor integer } PRIVATE> : (find) ( inet query -- result ) - '[ _ write-request read-reply ] (execute-query) ; inline + '[ _ write-message read-message ] (execute-query) ; inline : (find-one) ( inet query -- result ) (find) objects>> first ; inline From f588143082c2dac93320647291bf51c9f6d277e5 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 29 Jan 2009 13:47:33 +0100 Subject: [PATCH 014/101] changed stream>assoc to return the amount of bytes read from the stream --- bson/reader/reader.factor | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index 5aebb4bcee..348a25b732 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -194,13 +194,7 @@ M: bson-binary-function element-binary-read ( size type -- quot ) PRIVATE> -: stream>assoc ( exemplar -- assoc ) +: stream>assoc ( exemplar -- assoc bytes-read ) dup state - [ read-int32 >>size read-elements ] with-variable - result>> ; - -: array>assoc ( array exemplar -- assoc ) - [ binary ] dip '[ _ stream>assoc ] with-byte-reader ; - -: array>hashtable ( array -- assoc ) - H{ } array>assoc ; + [ read-int32 >>size read-elements ] with-variable + [ result>> ] [ read>> ] bi ; From 0cbd1ed207aef7d795e8c45887af593033775fa6 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 29 Jan 2009 13:48:22 +0100 Subject: [PATCH 015/101] rewrote check-nodes --- mongodb/connection/connection.factor | 29 +++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor index 569a68aa3b..c32a183c40 100644 --- a/mongodb/connection/connection.factor +++ b/mongodb/connection/connection.factor @@ -26,24 +26,27 @@ TUPLE: mdb name nodes collections ; '[ _ write-message read-message ] with-client objects>> first ; -: -push ( seq elt -- ) - swap push ; inline - : split-host-str ( hoststr -- host port ) ":" split [ first ] keep second string>number ; inline +: eval-ismaster-result ( node result -- node result ) + [ [ "ismaster" ] dip at + >fixnum 1 = + [ t >>master? ] [ f >>master? ] if ] keep ; + +: check-node ( node -- node remote ) + dup inet>> ismaster-cmd + eval-ismaster-result + [ "remote" ] dip at ; + : check-nodes ( node -- nodelist ) - [ V{ } clone ] dip - [ -push ] 2keep - dup inet>> ismaster-cmd ! vec node result - dup [ "ismaster" ] dip at - >fixnum 1 = ! vec node result - [ [ t >>master? drop ] dip f ] - [ [ f >>master? drop ] dip t ] if - [ "remote" ] 2dip [ at split-host-str ] dip - swap mdb-node boa swap - [ push ] keep ; + check-node + [ V{ } clone [ push ] keep ] dip + [ split-host-str [ f ] dip + mdb-node boa check-node drop + swap tuck push + ] when* ; : verify-nodes ( -- ) mdb>> nodes>> [ t ] dip at From eb00f33fa8a034c74e113b712f01071b400ad5df Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 29 Jan 2009 13:49:18 +0100 Subject: [PATCH 016/101] removed findOne words, added new word nfind ( example n -- result ) which limits the number of results returned to n --- mongodb/mongodb.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/mongodb/mongodb.factor b/mongodb/mongodb.factor index 96800d3d87..1d5d7f3693 100644 --- a/mongodb/mongodb.factor +++ b/mongodb/mongodb.factor @@ -8,7 +8,7 @@ IN: mongodb ! generic methods GENERIC: store ( tuple/ht -- ) GENERIC: find ( example -- tuple/ht ) -GENERIC: findOne ( exampe -- tuple/ht ) +GENERIC# nfind 1 ( example n -- tuple/ht ) GENERIC: load ( object -- object ) > master>> ] dip (find) build-result ; -M: mdb-persistent findOne ( example -- result ) - prepare-find [ mdb>> master>> ] dip (find-one) - dup returned#>> 1 = - [ objects>> first ] - [ drop f ] if ; +M: mdb-persistent nfind ( example n -- result ) + [ prepare-find ] dip >>return# + [ mdb>> master>> ] dip (find) + build-result ; + From 399838b960fcf51219e242802163d0cba98e04dd Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 29 Jan 2009 13:50:42 +0100 Subject: [PATCH 017/101] rewrote low-level (find-one) word as wrapper around (find) --- mongodb/query/query.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/mongodb/query/query.factor b/mongodb/query/query.factor index c3477d2678..ca3b059537 100644 --- a/mongodb/query/query.factor +++ b/mongodb/query/query.factor @@ -23,7 +23,8 @@ PRIVATE> '[ _ write-message read-message ] (execute-query) ; inline : (find-one) ( inet query -- result ) - (find) objects>> first ; inline + 1 >>return# + (find) ; inline : build-result ( resultmsg -- mdb-result ) [ mdb-result new ] dip @@ -48,7 +49,7 @@ PRIVATE> : create-collection ( mdb-collection -- ) dup name>> "create" H{ } clone [ set-at ] keep [ mdb>> [ master>> ] [ name>> ] bi "%s.$cmd" sprintf ] dip - (find-one) + (find-one) objects>> first check-ok [ [ ensure-indices ] keep dup name>> mdb>> collections>> set-at ] [ "could not create collection" throw ] if ; From e5ba1d2509ded297a85a682cc794b061730ea7e6 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 29 Jan 2009 13:51:51 +0100 Subject: [PATCH 018/101] fixed reading of multiple bson objects in one message (tracking bytes read and comparing with overall message size) --- mongodb/msg/msg.factor | 46 ++++++++++++++++++++++++++++++------------ 1 file changed, 33 insertions(+), 13 deletions(-) diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index 88d2421ce3..f99e4cad2b 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -1,6 +1,6 @@ USING: io io.encodings.utf8 io.encodings.binary alien.c-types alien.strings math bson.writer sequences kernel accessors io.streams.byte-array fry generalizations -combinators bson.reader sequences tools.walker assocs strings linked-assocs ; +combinators bson.reader sequences tools.walker assocs strings linked-assocs namespaces ; IN: mongodb.msg @@ -81,15 +81,26 @@ GENERIC: write-message ( message -- ) CONSTANT: MSG-HEADER-SIZE 16 +SYMBOL: msg-bytes-read + +: bytes-read> ( -- integer ) + msg-bytes-read get ; inline + +: >bytes-read ( integer -- ) + msg-bytes-read set ; inline + +: change-bytes-read ( integer -- ) + bytes-read> [ 0 ] unless* + >bytes-read ; inline + : write-byte ( byte -- ) write ; inline : write-int32 ( int -- ) write ; inline : write-double ( real -- ) write ; inline : write-cstring ( string -- ) utf8 string>alien write ; inline : write-longlong ( object -- ) write ; inline -: read-int32 ( -- int32 ) 4 read *int ; inline -: read-longlong ( -- longlong ) 8 read *longlong ; inline -: read-byte-raw ( -- byte-raw ) 1 read ; inline +: read-int32 ( -- int32 ) 4 [ read *int ] [ change-bytes-read ] bi ; inline +: read-longlong ( -- longlong ) 8 [ read *longlong ] [ change-bytes-read ] bi ; inline +: read-byte-raw ( -- byte-raw ) 1 [ read ] [ change-bytes-read ] bi ; inline : read-byte ( -- byte ) read-byte-raw *char ; inline : (read-cstring) ( acc -- acc ) @@ -117,13 +128,21 @@ M: mdb-query-op (read-message) ( msg-stub opcode -- message ) read-cstring >>collection read-int32 >>skip# read-int32 >>return# - H{ } stream>assoc >>query ; + H{ } stream>assoc change-bytes-read >>query ! message length + dup length>> bytes-read> > + [ H{ } stream>assoc change-bytes-read >>returnfields + dup length>> bytes-read> > + [ H{ } stream>assoc drop >>orderby ] when + ] when ; M: mdb-insert-op (read-message) ( msg-stub opcode -- message ) drop [ mdb-insert-msg new ] dip copy-header read-cstring >>collection - H{ } stream>assoc >>objects ; + V{ } clone >>objects + [ '[ _ length>> bytes-read> > ] ] keep tuck + '[ H{ } stream>assoc change-bytes-read _ objects>> push ] + [ ] while ; M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) drop @@ -131,7 +150,7 @@ M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) read-longlong >>cursor read-int32 >>start# read-int32 [ >>returned# ] keep - [ H{ } stream>assoc ] accumulator [ times ] dip >>objects ; + [ H{ } stream>assoc drop ] accumulator [ times ] dip >>objects ; : read-header ( message -- message ) read-int32 >>length @@ -150,6 +169,7 @@ PRIVATE> : read-message ( -- message ) mdb-msg new + 0 >bytes-read read-header [ ] [ opcode>> ] bi (read-message) ; @@ -173,10 +193,10 @@ M: mdb-query-msg write-message ( message -- ) ] (write-message) ; M: mdb-insert-msg write-message ( message -- ) - dup - '[ _ - [ 0 write-int32 ] dip - [ collection>> write-cstring ] keep - objects>> [ assoc>array write ] each - ] (write-message) ; + dup + '[ _ + [ 0 write-int32 ] dip + [ collection>> write-cstring ] keep + objects>> [ assoc>array write ] each + ] (write-message) ; From 050b77d44c6d79ad9dec045753a854142491518e Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 29 Jan 2009 13:52:37 +0100 Subject: [PATCH 019/101] nicer output --- mongodb/mmm/mmm.factor | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/mongodb/mmm/mmm.factor b/mongodb/mmm/mmm.factor index 93281f4134..ce942ce67b 100644 --- a/mongodb/mmm/mmm.factor +++ b/mongodb/mmm/mmm.factor @@ -1,6 +1,7 @@ USING: accessors fry io io.encodings.binary io.servers.connection io.sockets io.streams.byte-array kernel math mongodb.msg classes formatting -mongodb.msg.private namespaces prettyprint tools.walker calendar calendar.format ; +mongodb.msg.private namespaces prettyprint tools.walker calendar calendar.format +json.writer ; IN: mongodb.mmm @@ -48,22 +49,33 @@ GENERIC: dump-message ( message -- ) [ mmm-dump-output get ] dip '[ _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ; -: message-prefix ( message -- tst name message ) +: message-prefix ( message -- prefix message ) [ now timestamp>http-string ] dip - [ class name>> ] keep ; inline + [ class name>> ] keep + [ "%s: %s" sprintf ] dip ; inline M: mdb-query-msg dump-message ( message -- ) message-prefix - collection>> - "%s: %s -> %s \n" printf ; + [ collection>> ] keep + query>> >json + "%s -> %s: %s \n" printf ; M: mdb-insert-msg dump-message ( message -- ) message-prefix - collection>> - "%s: %s -> %s \n" printf ; + [ collection>> ] keep + objects>> >json + "%s -> %s : %s \n" printf ; + +M: mdb-reply-msg dump-message ( message -- ) + message-prefix + [ cursor>> ] keep + [ start#>> ] keep + [ returned#>> ] keep + objects>> >json + "%s -> cursor: %d, start: %d, returned#: %d, -> %s \n" printf ; M: mdb-msg dump-message ( message -- ) - message-prefix drop "%s: %s \n" printf ; + message-prefix drop "%s \n" printf ; : forward-reply ( binary -- ) write flush ; From aa77fdd4e514d37f543d9df300012ecbad20089f Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 30 Jan 2009 12:23:05 +0100 Subject: [PATCH 020/101] removed unused vocab --- bson/reader/reader.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index 348a25b732..d7b6bfef74 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -1,4 +1,4 @@ -USING: mirrors io io.encodings.utf8 io.encodings.binary math match kernel sequences +USING: mirrors io io.encodings.utf8 io.encodings.binary math kernel sequences splitting accessors io.streams.byte-array namespaces prettyprint bson.constants assocs alien.c-types alien.strings fry words serialize byte-arrays ; From 7179e2f84b89e93c8a52a9e4801be04d42a5d714 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 30 Jan 2009 12:23:35 +0100 Subject: [PATCH 021/101] added missing messages: killcursors, getmore, delete --- mongodb/msg/msg.factor | 86 ++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 82 insertions(+), 4 deletions(-) diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index f99e4cad2b..a13b6bdea2 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -35,6 +35,19 @@ TUPLE: mdb-insert-msg < mdb-msg { collection string } { objects sequence } ; +TUPLE: mdb-delete-msg < mdb-msg +{ collection string } +{ selector assoc } ; + +TUPLE: mdb-getmore-msg < mdb-msg +{ collection string } +{ return# integer initial: 0 } +{ cursor integer initial: 0 } ; + +TUPLE: mdb-killcursors-msg < mdb-msg +{ cursors# integer initial: 0 } +{ cursors sequence } ; + TUPLE: mdb-query-msg < mdb-msg { collection string } { skip# integer initial: 0 } @@ -50,11 +63,31 @@ TUPLE: mdb-reply-msg < mdb-msg { objects sequence } ; +: ( collection return# -- mdb-getmore-msg ) + [ mdb-getmore-msg new ] 2dip + [ >>collection ] dip + >>return# OP_GetMore >>opcode ; inline + +: ( collection assoc -- mdb-delete-msg ) + [ mdb-delete-msg new ] 2dip + [ >>collection ] dip + >>selector OP_Delete >>opcode ; inline + : ( collection assoc -- mdb-query-msg ) [ mdb-query-msg new ] 2dip [ >>collection ] dip >>query OP_Query >>opcode ; inline +GENERIC: ( object -- mdb-killcursors-msg ) + +M: sequence ( sequences -- mdb-killcursors-msg ) + [ mdb-killcursors-msg new ] dip + [ length >>cursors# ] keep + >>cursors OP_KillCursors >>opcode ; inline + +M: integer ( integer -- mdb-killcursors-msg ) + V{ } clone [ push ] keep ; + : ( collection assoc -- mdb-query-msg ) 1 >>return# ; inline @@ -71,7 +104,6 @@ M: sequence ( collection sequence -- mdb-insert-msg ) [ >>collection ] dip >>objects OP_Insert >>opcode ; - : ( -- mdb-reply-msg ) mdb-reply-msg new ; inline @@ -128,7 +160,7 @@ M: mdb-query-op (read-message) ( msg-stub opcode -- message ) read-cstring >>collection read-int32 >>skip# read-int32 >>return# - H{ } stream>assoc change-bytes-read >>query ! message length + H{ } stream>assoc change-bytes-read >>query dup length>> bytes-read> > [ H{ } stream>assoc change-bytes-read >>returnfields dup length>> bytes-read> > @@ -144,6 +176,27 @@ M: mdb-insert-op (read-message) ( msg-stub opcode -- message ) '[ H{ } stream>assoc change-bytes-read _ objects>> push ] [ ] while ; +M: mdb-delete-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-delete-msg new ] dip copy-header + read-cstring >>collection + H{ } stream>assoc change-bytes-read >>selector ; + +M: mdb-getmore-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-getmore-msg new ] dip copy-header + read-cstring >>collection + read-int32 >>return# + read-longlong >>cursor ; + +M: mdb-killcursors-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-killcursors-msg new ] dip copy-header + read-int32 >>cursors# + V{ } clone >>cursors + [ [ cursors#>> ] keep + '[ read-longlong _ cursors>> push ] times ] keep ; + M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) drop [ ] dip copy-header @@ -185,7 +238,7 @@ PRIVATE> M: mdb-query-msg write-message ( message -- ) dup '[ _ - [ 4 write-int32 ] dip + [ flags>> write-int32 ] keep [ collection>> write-cstring ] keep [ skip#>> write-int32 ] keep [ return#>> write-int32 ] keep @@ -195,8 +248,33 @@ M: mdb-query-msg write-message ( message -- ) M: mdb-insert-msg write-message ( message -- ) dup '[ _ - [ 0 write-int32 ] dip + [ flags>> write-int32 ] keep [ collection>> write-cstring ] keep objects>> [ assoc>array write ] each ] (write-message) ; +M: mdb-delete-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ collection>> write-cstring ] keep + 0 write-int32 + selector>> assoc>array write + ] (write-message) ; + +M: mdb-getmore-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ collection>> write-cstring ] keep + [ return#>> write-int32 ] keep + cursor>> write-longlong + ] (write-message) ; + +M: mdb-killcursors-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ cursors#>> write-int32 ] keep + cursors>> [ write-longlong ] each + ] (write-message) ; \ No newline at end of file From af9f0f32df0f1f5e0cad95b85d9c4982308c9819 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 30 Jan 2009 12:51:46 +0100 Subject: [PATCH 022/101] added update message --- mongodb/msg/msg.factor | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index a13b6bdea2..6610b15893 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -18,6 +18,7 @@ CONSTANT: OP_KillCursors 2007 PREDICATE: mdb-reply-op < integer OP_Reply = ; PREDICATE: mdb-query-op < integer OP_Query = ; PREDICATE: mdb-insert-op < integer OP_Insert = ; +PREDICATE: mdb-update-op < integer OP_Update = ; PREDICATE: mdb-delete-op < integer OP_Delete = ; PREDICATE: mdb-getmore-op < integer OP_GetMore = ; PREDICATE: mdb-killcursors-op < integer OP_KillCursors = ; @@ -35,6 +36,12 @@ TUPLE: mdb-insert-msg < mdb-msg { collection string } { objects sequence } ; +TUPLE: mdb-update-msg < mdb-msg +{ collection string } +{ upsert? integer initial: 1 } +{ selector assoc } +{ object assoc } ; + TUPLE: mdb-delete-msg < mdb-msg { collection string } { selector assoc } ; @@ -104,6 +111,12 @@ M: sequence ( collection sequence -- mdb-insert-msg ) [ >>collection ] dip >>objects OP_Insert >>opcode ; +: ( collection object -- mdb-update-msg ) + [ mdb-update-msg new ] 2dip + [ >>collection ] dip + [ [ "_id" ] dip at "_id" H{ } clone [ set-at ] keep >>selector ] keep + >>object OP_Update >>opcode ; + : ( -- mdb-reply-msg ) mdb-reply-msg new ; inline @@ -197,6 +210,14 @@ M: mdb-killcursors-op (read-message) ( msg-stub opcode -- message ) [ [ cursors#>> ] keep '[ read-longlong _ cursors>> push ] times ] keep ; +M: mdb-update-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-update-msg new ] dip copy-header + read-cstring >>collection + read-int32 >>upsert? + H{ } stream>assoc change-bytes-read >>selector + H{ } stream>assoc change-bytes-read >>object ; + M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) drop [ ] dip copy-header @@ -253,6 +274,16 @@ M: mdb-insert-msg write-message ( message -- ) objects>> [ assoc>array write ] each ] (write-message) ; +M: mdb-update-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ collection>> write-cstring ] keep + [ upsert?>> write-int32 ] keep + [ selector>> assoc>array write ] keep + object>> assoc>array write + ] (write-message) ; + M: mdb-delete-msg write-message ( message -- ) dup '[ _ From 9838b6fee1411eff4d28768dcd01105c0f97079d Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 31 Jan 2009 11:51:30 +0100 Subject: [PATCH 023/101] reworked reading of cstrings (using BV{ } now) - not sure about using read-until --- bson/reader/reader.factor | 17 +++++++++-------- mongodb/msg/msg.factor | 20 +++++++++++--------- 2 files changed, 20 insertions(+), 17 deletions(-) diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index d7b6bfef74..d8b5e2b44a 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -1,7 +1,7 @@ USING: mirrors io io.encodings.utf8 io.encodings.binary math kernel sequences splitting accessors io.streams.byte-array namespaces prettyprint bson.constants assocs alien.c-types alien.strings fry words - serialize byte-arrays ; + serialize byte-arrays byte-vectors ; IN: bson.reader @@ -60,15 +60,16 @@ GENERIC: element-binary-read ( length type -- object ) : read-byte ( -- byte ) read-byte-raw *char ; inline -: (read-cstring) ( acc -- acc ) - read-byte-raw dup - B{ 0 } = - [ append ] - [ append (read-cstring) ] if ; inline recursive +: (read-cstring) ( acc -- ) + [ read-byte-raw first ] dip ! b acc + 2dup push ! b acc + [ 0 = ] dip ! bool acc + '[ _ (read-cstring) ] unless ; inline recursive : read-cstring ( -- string ) - B{ } clone - (read-cstring) utf8 alien>string ; inline + BV{ } clone + [ (read-cstring) ] keep + >byte-array utf8 alien>string ; inline : read-sized-string ( length -- string ) [ read ] [ count-bytes ] bi diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index 6610b15893..666250b45e 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -1,6 +1,7 @@ USING: io io.encodings.utf8 io.encodings.binary alien.c-types alien.strings math bson.writer sequences kernel accessors io.streams.byte-array fry generalizations -combinators bson.reader sequences tools.walker assocs strings linked-assocs namespaces ; +combinators bson.reader sequences tools.walker assocs strings linked-assocs namespaces +byte-vectors byte-arrays ; IN: mongodb.msg @@ -146,17 +147,18 @@ SYMBOL: msg-bytes-read : read-int32 ( -- int32 ) 4 [ read *int ] [ change-bytes-read ] bi ; inline : read-longlong ( -- longlong ) 8 [ read *longlong ] [ change-bytes-read ] bi ; inline : read-byte-raw ( -- byte-raw ) 1 [ read ] [ change-bytes-read ] bi ; inline -: read-byte ( -- byte ) read-byte-raw *char ; inline +: read-byte ( -- byte ) read-byte-raw first ; inline -: (read-cstring) ( acc -- acc ) - read-byte-raw dup - B{ 0 } = - [ append ] - [ append (read-cstring) ] if ; recursive inline +: (read-cstring) ( acc -- ) + [ read-byte ] dip ! b acc + 2dup push ! b acc + [ 0 = ] dip ! bool acc + '[ _ (read-cstring) ] unless ; inline recursive : read-cstring ( -- string ) - B{ } clone - (read-cstring) utf8 alien>string ; inline + BV{ } clone + [ (read-cstring) ] keep + >byte-array utf8 alien>string ; inline GENERIC: (read-message) ( message opcode -- message ) From 5dacbdaace2803a2712de70598e27ac62f139b8f Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 31 Jan 2009 16:04:19 +0100 Subject: [PATCH 024/101] rewrote (write-message) --- mongodb/msg/msg.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index 666250b45e..c3b124568d 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -252,8 +252,8 @@ PRIVATE> From bd6be4fe27a14ce9cef841c78553d68746ffc255 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 31 Jan 2009 16:05:21 +0100 Subject: [PATCH 025/101] using CONSTRUCTOR: for non-generic tuple constructors --- mongodb/msg/msg.factor | 40 ++++++++++++++-------------------------- 1 file changed, 14 insertions(+), 26 deletions(-) diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index c3b124568d..3b0db0a08f 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -1,7 +1,7 @@ -USING: io io.encodings.utf8 io.encodings.binary alien.c-types alien.strings math -bson.writer sequences kernel accessors io.streams.byte-array fry generalizations -combinators bson.reader sequences tools.walker assocs strings linked-assocs namespaces -byte-vectors byte-arrays ; +USING: accessors alien.c-types alien.strings assocs bson.reader +bson.writer byte-arrays byte-vectors constructors fry io +io.encodings.binary io.encodings.utf8 io.streams.byte-array kernel +linked-assocs math namespaces sequences strings ; IN: mongodb.msg @@ -71,20 +71,14 @@ TUPLE: mdb-reply-msg < mdb-msg { objects sequence } ; -: ( collection return# -- mdb-getmore-msg ) - [ mdb-getmore-msg new ] 2dip - [ >>collection ] dip - >>return# OP_GetMore >>opcode ; inline +CONSTRUCTOR: mdb-getmore-msg ( collection return# -- mdb-getmore-msg ) + OP_GetMore >>opcode ; inline -: ( collection assoc -- mdb-delete-msg ) - [ mdb-delete-msg new ] 2dip - [ >>collection ] dip - >>selector OP_Delete >>opcode ; inline +CONSTRUCTOR: mdb-delete-msg ( collection selector -- mdb-delete-msg ) + OP_Delete >>opcode ; inline -: ( collection assoc -- mdb-query-msg ) - [ mdb-query-msg new ] 2dip - [ >>collection ] dip - >>query OP_Query >>opcode ; inline +CONSTRUCTOR: mdb-query-msg ( collection query -- mdb-query-msg ) + OP_Query >>opcode ; inline GENERIC: ( object -- mdb-killcursors-msg ) @@ -96,9 +90,6 @@ M: sequence ( sequences -- mdb-killcursors-msg ) M: integer ( integer -- mdb-killcursors-msg ) V{ } clone [ push ] keep ; -: ( collection assoc -- mdb-query-msg ) - 1 >>return# ; inline - GENERIC# 1 ( collection objects -- mdb-insert-msg ) M: linked-assoc ( collection linked-assoc -- mdb-insert-msg ) @@ -112,14 +103,11 @@ M: sequence ( collection sequence -- mdb-insert-msg ) [ >>collection ] dip >>objects OP_Insert >>opcode ; -: ( collection object -- mdb-update-msg ) - [ mdb-update-msg new ] 2dip - [ >>collection ] dip - [ [ "_id" ] dip at "_id" H{ } clone [ set-at ] keep >>selector ] keep - >>object OP_Update >>opcode ; +CONSTRUCTOR: mdb-update-msg ( collection object -- mdb-update-msg ) + dup object>> [ "_id" ] dip at "_id" H{ } clone [ set-at ] keep >>selector + OP_Update >>opcode ; -: ( -- mdb-reply-msg ) - mdb-reply-msg new ; inline +CONSTRUCTOR: mdb-reply-msg ( -- mdb-reply-msg ) ; inline GENERIC: write-message ( message -- ) From 0e2b60bf89c7936845028d9bc585b7c1ccb426bd Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 31 Jan 2009 16:06:49 +0100 Subject: [PATCH 026/101] fixed ismastercmd --- mongodb/connection/connection.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor index c32a183c40..6e608dcb63 100644 --- a/mongodb/connection/connection.factor +++ b/mongodb/connection/connection.factor @@ -22,8 +22,8 @@ TUPLE: mdb name nodes collections ; - '[ _ write-message read-message ] with-client + binary "admin.$cmd" H{ { "ismaster" 1 } } + 1 >>return# '[ _ write-message read-message ] with-client objects>> first ; : split-host-str ( hoststr -- host port ) From 16965933bc2b1207f2efbd19d7348e9180ad3758 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sun, 1 Feb 2009 17:40:52 +0100 Subject: [PATCH 027/101] dropped oid and dbref support from bson; now using uuid (v1) for objid (Binary, Subtype: UUID) and custom binary format for objrefs (ns, objid - Binary, Subtype: Custom) --- bson/constants/constants.factor | 21 ++++++++++----------- bson/reader/reader.factor | 26 +++++++++++++------------- bson/writer/writer.factor | 28 +++++++++++++++++----------- mongodb/persistent/persistent.factor | 10 ++++------ 4 files changed, 44 insertions(+), 41 deletions(-) diff --git a/bson/constants/constants.factor b/bson/constants/constants.factor index 8f5b61a671..fc54f62927 100644 --- a/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -1,18 +1,14 @@ -USING: alien.c-types accessors kernel calendar random math.bitwise math unix ; +USING: alien.c-types accessors kernel calendar random math.bitwise math unix +constructors uuid ; IN: bson.constants -TUPLE: oid { a initial: 0 } { b initial: 0 } ; +TUPLE: objid id ; -: ( -- oid ) - oid new - now timestamp>micros >>a - 8 random-bits 16 shift HEX: FF0000 mask - getpid HEX: FFFF mask - bitor >>b ; - -TUPLE: dbref ns oid ; +CONSTRUCTOR: objid ( -- objid ) + uuid1 >>id ; inline +TUPLE: objref ns objid ; CONSTANT: T_EOO 0 CONSTANT: T_Double 1 @@ -34,7 +30,10 @@ CONSTANT: T_Symbol 14 CONSTANT: T_JSTypeMax 16 CONSTANT: T_MaxKey 127 -CONSTANT: T_Binary_Bytes 2 CONSTANT: T_Binary_Function 1 +CONSTANT: T_Binary_Bytes 2 +CONSTANT: T_Binary_UUID 3 +CONSTANT: T_Binary_MD5 5 +CONSTANT: T_Binary_Custom 128 diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index d8b5e2b44a..f697f16691 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -29,6 +29,8 @@ PREDICATE: bson-array < integer T_Array = ; PREDICATE: bson-binary < integer T_Binary = ; PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ; PREDICATE: bson-binary-function < integer T_Binary_Function = ; +PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ; +PREDICATE: bson-binary-custom < integer T_Binary_Custom = ; PREDICATE: bson-oid < integer T_OID = ; PREDICATE: bson-boolean < integer T_Boolean = ; PREDICATE: bson-date < integer T_Date = ; @@ -134,12 +136,6 @@ M: bson-not-eoo element-read ( type -- cont? ) set-at t ; -M: bson-oid element-data-read ( type -- object ) - drop - read-longlong - read-int32 - oid boa ; - : [scope-changer] ( state -- state quot ) dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline @@ -172,13 +168,6 @@ M: bson-boolean element-data-read ( type -- boolean ) drop read-byte t = ; -M: bson-ref element-data-read ( type -- dbref ) - drop - read-int32 - read-sized-string - T_OID element-data-read - dbref boa ; - M: bson-binary element-data-read ( type -- binary ) drop read-int32 read-byte element-binary-read ; @@ -187,6 +176,17 @@ M: bson-null element-data-read ( type -- bf ) drop f ; +M: bson-binary-custom element-binary-read ( size type -- dbref ) + 2drop + read-cstring + read-cstring objid boa + objref boa ; + +M: bson-binary-uuid element-binary-read ( size type -- object ) + drop + read-sized-string + objid boa ; + M: bson-binary-bytes element-binary-read ( size type -- bytes ) drop read ; diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index c5e9b02ef8..4e07e3ab2f 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -5,7 +5,7 @@ USING: bson bson.constants accessors kernel io.streams.string io.encodings.utf8 strings splitting math.parser sequences math assocs classes words make fry prettyprint hashtables mirrors alien.strings alien.c-types - io.streams.byte-array io ; + io.streams.byte-array io alien.strings ; IN: bson.writer @@ -19,15 +19,16 @@ GENERIC: bson-write ( obj -- ) M: t bson-type? ( boolean -- type ) drop T_Boolean ; M: f bson-type? ( boolean -- type ) drop T_Boolean ; -M: oid bson-type? ( word -- type ) drop T_OID ; -M: dbref bson-type? ( dbref -- type ) drop T_DBRef ; M: real bson-type? ( real -- type ) drop T_Double ; M: word bson-type? ( word -- type ) drop T_String ; M: tuple bson-type? ( tuple -- type ) drop T_Object ; M: assoc bson-type? ( hashtable -- type ) drop T_Object ; M: string bson-type? ( string -- type ) drop T_String ; M: integer bson-type? ( integer -- type ) drop T_Integer ; -M: sequence bson-type? ( seq -- type ) drop T_Array ; +M: sequence bson-type? ( seq -- type ) drop T_Array ; + +M: objid bson-type? ( objid -- type ) drop T_Binary ; +M: objref bson-type? ( objref -- type ) drop T_Binary ; M: quotation bson-type? ( quotation -- type ) drop T_Binary ; M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; @@ -69,14 +70,19 @@ M: quotation bson-write ( quotation -- ) T_Binary_Function write-byte write ; -M: oid bson-write ( oid -- ) - [ a>> write-longlong ] [ b>> write-int32 ] bi ; +M: objid bson-write ( oid -- ) + id>> utf8 string>alien + [ length write-int32 ] keep + T_Binary_UUID write-byte + write ; -M: dbref bson-write ( dbref -- ) - [ ns>> utf8 string>alien - [ length write-int32 ] keep write - ] - [ oid>> bson-write ] bi ; +M: objref bson-write ( objref -- ) + [ ns>> utf8 string>alien ] + [ objid>> id>> utf8 string>alien ] bi + append + [ length write-int32 ] keep + T_Binary_Custom write-byte + write ; M: sequence bson-write ( array -- ) '[ _ [ [ write-type ] dip number>string write-cstring bson-write ] diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor index 249a9d60af..f83d06905c 100644 --- a/mongodb/persistent/persistent.factor +++ b/mongodb/persistent/persistent.factor @@ -20,10 +20,8 @@ DEFER: create-mdb-command CONSTANT: MDB_INFO "_mdb_info" - - -: ( tuple -- dbref ) - [ mdb-collection>> ] [ _id>> ] bi dbref boa ; inline +: ( tuple -- objref ) + [ mdb-collection>> ] [ _id>> ] bi objref boa ; inline : mdbinfo>tuple-class ( mdbinfo -- class ) [ first ] keep second lookup ; inline @@ -66,7 +64,7 @@ CONSTANT: MDB_INFO "_mdb_info" [ _ keep [ mdb-collection>> ] keep [ create-mdb-command ] dip - ] + ] [ dup data-tuple? _ [ ] if ] if swap _ set-at ] if @@ -76,7 +74,7 @@ CONSTANT: MDB_INFO "_mdb_info" [ ] dip dup clone swap [ tuck ] dip swap ; inline : ensure-mdb-info ( tuple -- tuple ) - dup _id>> [ >>_id ] unless ; inline + dup _id>> [ >>_id ] unless ; inline : with-op-seq ( quot -- op-seq ) [ From 2e641216f3dd088b02dc3464504e16a87cc4b664 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Mon, 9 Feb 2009 08:31:47 +0100 Subject: [PATCH 028/101] changed type > byte-array conversion; now using io.binary (>le, le>) updated USING:s --- bson/constants/constants.factor | 3 +-- bson/reader/reader.factor | 20 ++++++++++---------- bson/writer/writer.factor | 28 +++++++++++++--------------- mongodb/mongodb.factor | 8 ++++++-- mongodb/msg/msg.factor | 23 ++++++++++++----------- 5 files changed, 42 insertions(+), 40 deletions(-) diff --git a/bson/constants/constants.factor b/bson/constants/constants.factor index fc54f62927..29144ded86 100644 --- a/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -1,5 +1,4 @@ -USING: alien.c-types accessors kernel calendar random math.bitwise math unix -constructors uuid ; +USING: accessors constructors uuid ; IN: bson.constants diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index f697f16691..0f699ca499 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -1,7 +1,6 @@ -USING: mirrors io io.encodings.utf8 io.encodings.binary math kernel sequences - splitting accessors io.streams.byte-array namespaces prettyprint - bson.constants assocs alien.c-types alien.strings fry words - serialize byte-arrays byte-vectors ; +USING: accessors assocs bson.constants byte-arrays byte-vectors fry io +io.binary io.encodings.string io.encodings.utf8 kernel math namespaces +sequences serialize ; IN: bson.reader @@ -48,19 +47,19 @@ GENERIC: element-binary-read ( length type -- object ) [ get-state ] dip '[ _ + ] change-read drop ; inline : read-int32 ( -- int32 ) - 4 [ read *int ] [ count-bytes ] bi ; inline + 4 [ read le> ] [ count-bytes ] bi ; inline : read-longlong ( -- longlong ) - 8 [ read *longlong ] [ count-bytes ] bi ; inline + 8 [ read le> ] [ count-bytes ] bi ; inline : read-double ( -- double ) - 8 [ read *double ] [ count-bytes ] bi ; inline + 8 [ read le> bits>double ] [ count-bytes ] bi ; inline : read-byte-raw ( -- byte-raw ) 1 [ read ] [ count-bytes ] bi ; inline : read-byte ( -- byte ) - read-byte-raw *char ; inline + read-byte-raw first ; inline : (read-cstring) ( acc -- ) [ read-byte-raw first ] dip ! b acc @@ -71,11 +70,12 @@ GENERIC: element-binary-read ( length type -- object ) : read-cstring ( -- string ) BV{ } clone [ (read-cstring) ] keep - >byte-array utf8 alien>string ; inline + [ zero? ] trim-tail + >byte-array utf8 decode ; inline : read-sized-string ( length -- string ) [ read ] [ count-bytes ] bi - utf8 alien>string ; inline + [ zero? ] trim-tail utf8 decode ; inline : read-element-type ( -- type ) read-byte ; inline diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 4e07e3ab2f..a850c86e32 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -1,11 +1,9 @@ ! Copyright (C) 2008 Sascha Matzke. ! See http://factorcode.org/license.txt for BSD license. -USING: bson bson.constants accessors kernel io.streams.string - io.encodings.binary classes byte-arrays quotations serialize - io.encodings.utf8 strings splitting math.parser - sequences math assocs classes words make fry - prettyprint hashtables mirrors alien.strings alien.c-types - io.streams.byte-array io alien.strings ; +USING: accessors assocs bson.constants byte-arrays fry io io.binary +io.encodings.binary io.encodings.string io.encodings.utf8 +io.streams.byte-array kernel math math.parser quotations sequences +serialize strings words ; IN: bson.writer @@ -32,11 +30,11 @@ M: objref bson-type? ( objref -- type ) drop T_Binary ; M: quotation bson-type? ( quotation -- type ) drop T_Binary ; M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; -: write-byte ( byte -- ) write ; inline -: write-int32 ( int -- ) write ; inline -: write-double ( real -- ) write ; inline -: write-cstring ( string -- ) utf8 string>alien write ; inline -: write-longlong ( object -- ) write ; inline +: write-byte ( byte -- ) 1 >le write ; inline +: write-int32 ( int -- ) 4 >le write ; inline +: write-double ( real -- ) double>bits 8 >le write ; inline +: write-cstring ( string -- ) utf8 encode B{ 0 } append write ; inline +: write-longlong ( object -- ) 8 >le write ; inline : write-eoo ( -- ) T_EOO write-byte ; inline : write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline @@ -50,7 +48,7 @@ M: t bson-write ( t -- ) drop 1 write-byte ; M: string bson-write ( obj -- ) - utf8 string>alien + utf8 encode B{ 0 } append [ length write-int32 ] keep write ; @@ -71,14 +69,14 @@ M: quotation bson-write ( quotation -- ) write ; M: objid bson-write ( oid -- ) - id>> utf8 string>alien + id>> utf8 encode [ length write-int32 ] keep T_Binary_UUID write-byte write ; M: objref bson-write ( objref -- ) - [ ns>> utf8 string>alien ] - [ objid>> id>> utf8 string>alien ] bi + [ ns>> utf8 encode ] + [ objid>> id>> utf8 encode ] bi append [ length write-int32 ] keep T_Binary_Custom write-byte diff --git a/mongodb/mongodb.factor b/mongodb/mongodb.factor index 1d5d7f3693..69c2809a1e 100644 --- a/mongodb/mongodb.factor +++ b/mongodb/mongodb.factor @@ -9,7 +9,8 @@ IN: mongodb GENERIC: store ( tuple/ht -- ) GENERIC: find ( example -- tuple/ht ) GENERIC# nfind 1 ( example n -- tuple/ht ) -GENERIC: load ( object -- object ) +GENERIC: load ( object -- object ) +GENERIC: explain ( object -- object ) > master>> ] dip (find) build-result ; - +M: mdb-persistent explain ( example -- result ) + prepare-find [ query>> [ t "$explain" ] dip set-at ] keep + [ mdb>> master>> ] dip (find-one) + build-result ; diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index 3b0db0a08f..1df971b229 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -1,5 +1,5 @@ -USING: accessors alien.c-types alien.strings assocs bson.reader -bson.writer byte-arrays byte-vectors constructors fry io +USING: accessors io.encodings.string assocs bson.reader +bson.writer byte-arrays byte-vectors constructors fry io io.binary io.encodings.binary io.encodings.utf8 io.streams.byte-array kernel linked-assocs math namespaces sequences strings ; @@ -126,15 +126,15 @@ SYMBOL: msg-bytes-read : change-bytes-read ( integer -- ) bytes-read> [ 0 ] unless* + >bytes-read ; inline -: write-byte ( byte -- ) write ; inline -: write-int32 ( int -- ) write ; inline -: write-double ( real -- ) write ; inline -: write-cstring ( string -- ) utf8 string>alien write ; inline -: write-longlong ( object -- ) write ; inline +: write-byte ( byte -- ) 1 >le write ; inline +: write-int32 ( int -- ) 4 >le write ; inline +: write-double ( real -- ) double>bits 8 >le write ; inline +: write-cstring ( string -- ) utf8 encode B{ 0 } append write ; inline +: write-longlong ( object -- ) 8 >le write ; inline -: read-int32 ( -- int32 ) 4 [ read *int ] [ change-bytes-read ] bi ; inline -: read-longlong ( -- longlong ) 8 [ read *longlong ] [ change-bytes-read ] bi ; inline -: read-byte-raw ( -- byte-raw ) 1 [ read ] [ change-bytes-read ] bi ; inline +: read-int32 ( -- int32 ) 4 [ read le> ] [ change-bytes-read ] bi ; inline +: read-longlong ( -- longlong ) 8 [ read le> ] [ change-bytes-read ] bi ; inline +: read-byte-raw ( -- byte-raw ) 1 [ read le> ] [ change-bytes-read ] bi ; inline : read-byte ( -- byte ) read-byte-raw first ; inline : (read-cstring) ( acc -- ) @@ -146,7 +146,8 @@ SYMBOL: msg-bytes-read : read-cstring ( -- string ) BV{ } clone [ (read-cstring) ] keep - >byte-array utf8 alien>string ; inline + [ zero? ] trim-tail + >byte-array utf8 decode ; inline GENERIC: (read-message) ( message opcode -- message ) From 02a76d0a3e0be7d8ba97b1c6a60dfb3542feb0c4 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sun, 1 Mar 2009 22:45:38 +0100 Subject: [PATCH 029/101] started complete rewrite... Now there's a low-level driver (mongodb.driver) implementation. Tuple integration will follow soon. --- bson/constants/constants.factor | 8 +- bson/reader/reader.factor | 7 +- bson/writer/writer.factor | 4 + mongodb/connection/connection.factor | 65 ------ mongodb/driver/driver.factor | 282 +++++++++++++++++++++++++++ mongodb/index/index.factor | 108 ---------- mongodb/mongodb.factor | 40 ++-- mongodb/msg/msg.factor | 240 ++--------------------- mongodb/operations/operations.factor | 219 +++++++++++++++++++++ mongodb/persistent/persistent.factor | 6 +- mongodb/query/query.factor | 68 ------- mongodb/tuple/tuple.factor | 203 +++++++++++-------- 12 files changed, 681 insertions(+), 569 deletions(-) delete mode 100644 mongodb/connection/connection.factor create mode 100644 mongodb/driver/driver.factor delete mode 100644 mongodb/index/index.factor create mode 100644 mongodb/operations/operations.factor delete mode 100644 mongodb/query/query.factor diff --git a/bson/constants/constants.factor b/bson/constants/constants.factor index 29144ded86..039ea18089 100644 --- a/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -1,11 +1,13 @@ -USING: accessors constructors uuid ; +USING: accessors kernel uuid ; IN: bson.constants TUPLE: objid id ; -CONSTRUCTOR: objid ( -- objid ) - uuid1 >>id ; inline +: ( -- objid ) + objid new uuid1 >>id ; inline + +TUPLE: oid { a initial: 0 } { b initial: 0 } ; TUPLE: objref ns objid ; diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index 0f699ca499..44eadef973 100644 --- a/bson/reader/reader.factor +++ b/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 ; +sequences serialize arrays ; IN: bson.reader @@ -176,6 +176,11 @@ M: bson-null element-data-read ( type -- bf ) drop f ; +M: bson-oid element-data-read ( type -- oid ) + drop + read-longlong + read-int32 oid boa ; + M: bson-binary-custom element-binary-read ( size type -- dbref ) 2drop read-cstring diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index a850c86e32..439cfb7372 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -25,6 +25,7 @@ M: string bson-type? ( string -- type ) drop T_String ; M: integer bson-type? ( integer -- type ) drop T_Integer ; M: sequence bson-type? ( seq -- type ) drop T_Array ; +M: oid bson-type? ( word -- type ) drop T_OID ; M: objid bson-type? ( objid -- type ) drop T_Binary ; M: objref bson-type? ( objref -- type ) drop T_Binary ; M: quotation bson-type? ( quotation -- type ) drop T_Binary ; @@ -68,6 +69,9 @@ M: quotation bson-write ( quotation -- ) T_Binary_Function write-byte write ; +M: oid bson-write ( oid -- ) + [ a>> write-longlong ] [ b>> write-int32 ] bi ; + M: objid bson-write ( oid -- ) id>> utf8 encode [ length write-int32 ] keep diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor deleted file mode 100644 index 6e608dcb63..0000000000 --- a/mongodb/connection/connection.factor +++ /dev/null @@ -1,65 +0,0 @@ -USING: accessors assocs fry io.sockets kernel math mongodb.msg -namespaces sequences splitting math.parser io.encodings.binary ; - -IN: mongodb.connection - -TUPLE: mdb-node master? inet ; - -TUPLE: mdb name nodes collections ; - -: mdb>> ( -- mdb ) - mdb get ; inline - -: with-db ( mdb quot -- ... ) - '[ _ mdb set _ call ] with-scope ; - -: master>> ( mdb -- inet ) - nodes>> [ t ] dip at inet>> ; - -: slave>> ( mdb -- inet ) - nodes>> [ f ] dip at inet>> ; - - - 1 >>return# '[ _ write-message read-message ] with-client - objects>> first ; - -: split-host-str ( hoststr -- host port ) - ":" split [ first ] keep - second string>number ; inline - -: eval-ismaster-result ( node result -- node result ) - [ [ "ismaster" ] dip at - >fixnum 1 = - [ t >>master? ] [ f >>master? ] if ] keep ; - -: check-node ( node -- node remote ) - dup inet>> ismaster-cmd - eval-ismaster-result - [ "remote" ] dip at ; - -: check-nodes ( node -- nodelist ) - check-node - [ V{ } clone [ push ] keep ] dip - [ split-host-str [ f ] dip - mdb-node boa check-node drop - swap tuck push - ] when* ; - -: verify-nodes ( -- ) - mdb>> nodes>> [ t ] dip at - check-nodes - H{ } clone tuck - '[ dup master?>> _ set-at ] each - [ mdb>> ] dip >>nodes drop ; - -PRIVATE> - -: () ( db host port -- mdb ) - [ f ] 2dip mdb-node boa - check-nodes - H{ } clone tuck - '[ dup master?>> _ set-at ] each - H{ } clone mdb boa ; diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor new file mode 100644 index 0000000000..6337452174 --- /dev/null +++ b/mongodb/driver/driver.factor @@ -0,0 +1,282 @@ +USING: accessors assocs fry io.sockets kernel math mongodb.msg formatting linked-assocs destructors continuations +mongodb.operations namespaces sequences splitting math.parser io.encodings.binary combinators io.streams.duplex +arrays io memoize constructors sets strings ; + +IN: mongodb.driver + +TUPLE: mdb-node master? inet ; + +TUPLE: mdb name nodes collections ; + +TUPLE: mdb-cursor collection id return# ; + +UNION: boolean t POSTPONE: f ; + +TUPLE: mdb-collection +{ name string } +{ capped boolean initial: f } +{ size integer initial: -1 } +{ max integer initial: -1 } ; + +CONSTRUCTOR: mdb-cursor ( id collection return# -- cursor ) ; +CONSTRUCTOR: mdb-collection ( name -- collection ) ; + +CONSTANT: MDB-GENERAL-ERROR 1 + +CONSTANT: MDB_OID "_id" +CONSTANT: MDB_PROPERTIES "_mdb_" + +CONSTANT: PARTIAL? "partial?" +CONSTANT: DIRTY? "dirty?" + +ERROR: mdb-error id msg ; + +> ( -- stream ) + mdb-socket-stream get ; inline + +: check-ok ( result -- ? ) + [ "ok" ] dip key? ; inline + +PRIVATE> + +: mdb>> ( -- mdb ) + mdb get ; inline + +: master>> ( mdb -- inet ) + nodes>> [ t ] dip at inet>> ; + +: slave>> ( mdb -- inet ) + nodes>> [ f ] dip at inet>> ; + +: with-db ( mdb quot -- ... ) + [ [ '[ _ [ mdb set ] keep master>> + [ remote-address set ] keep + binary + local-address set + mdb-socket-stream set ] ] dip compose + [ mdb-stream>> [ dispose ] when* ] [ ] cleanup + ] with-scope ; + +> name>> "%s.system.indexes" sprintf ; inline + +: namespaces-collection ( -- ns ) + mdb>> name>> "%s.system.namespaces" sprintf ; inline + +: cmd-collection ( -- ns ) + mdb>> name>> "%s.$cmd" sprintf ; inline + +: index-ns ( colname -- index-ns ) + [ mdb>> name>> ] dip "%s.%s" sprintf ; inline + +: ismaster-cmd ( node -- result ) + binary "admin.$cmd" H{ { "ismaster" 1 } } + 1 >>return# '[ _ write-message read-message ] with-client + objects>> first ; + +: split-host-str ( hoststr -- host port ) + ":" split [ first ] keep + second string>number ; inline + +: eval-ismaster-result ( node result -- node result ) + [ [ "ismaster" ] dip at + >fixnum 1 = + [ t >>master? ] [ f >>master? ] if ] keep ; + +: check-node ( node -- node remote ) + dup inet>> ismaster-cmd + eval-ismaster-result + [ "remote" ] dip at ; + +: check-nodes ( node -- nodelist ) + check-node + [ V{ } clone [ push ] keep ] dip + [ split-host-str [ f ] dip + mdb-node boa check-node drop + swap tuck push + ] when* ; + +: verify-nodes ( -- ) + mdb>> nodes>> [ t ] dip at + check-nodes + H{ } clone tuck + '[ dup master?>> _ set-at ] each + [ mdb>> ] dip >>nodes drop ; + +: send-message ( message -- ) + [ mdb-stream>> ] dip '[ _ write-message ] with-stream* ; + +: send-query-plain ( query-message -- result ) + [ mdb-stream>> ] dip + '[ _ write-message read-message ] with-stream* ; + +: send-query ( query-message -- cursor result ) + [ send-query-plain ] keep + { [ collection>> >>collection drop ] + [ return#>> >>requested# ] + } 2cleave + [ [ cursor>> 0 > ] keep + '[ _ [ cursor>> ] [ collection>> ] [ requested#>> ] tri ] + [ f ] if + ] [ objects>> ] bi ; + +PRIVATE> + +: ( db host port -- mdb ) + [ f ] 2dip mdb-node boa + check-nodes + H{ } clone tuck + '[ dup master?>> _ set-at ] each + H{ } clone mdb boa ; + +: create-collection ( name -- ) + [ cmd-collection ] dip + "create" H{ } clone [ set-at ] keep + 1 >>return# send-query-plain objects>> first check-ok + [ "could not create collection" throw ] unless ; + +: load-collection-list ( -- collection-list ) + namespaces-collection + H{ } clone send-query-plain objects>> ; + + ] keep + '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline + +: (ensure-collection) ( collection -- ) + mdb>> collections>> dup keys length 0 = + [ load-collection-list + [ [ "options" ] dip key? ] filter + [ [ "name" ] dip at "." split second ] map + over '[ [ ] [ name>> ] bi _ set-at ] each ] [ ] if + [ dup ] dip key? [ drop ] + [ [ ensure-valid-collection-name ] keep create-collection ] if ; inline + +MEMO: reserved-namespace? ( name -- ? ) + [ "$cmd" = ] [ "system" head? ] bi or ; + +PRIVATE> + +MEMO: ensure-collection ( collection -- fq-collection ) + "." split1 over mdb>> name>> = + [ [ drop ] dip ] [ drop ] if + [ ] [ reserved-namespace? ] bi + [ [ (ensure-collection) ] keep ] unless + [ mdb>> name>> ] dip "%s.%s" sprintf ; inline + +: ( collection query -- mdb-query ) + [ ensure-collection ] dip + ; inline + +GENERIC# limit 1 ( mdb-query limit# -- mdb-query ) +M: mdb-query-msg limit ( query limit# -- mdb-query ) + >>return# ; inline + +GENERIC# skip 1 ( mdb-query skip# -- mdb-query ) +M: mdb-query-msg skip ( query skip# -- mdb-query ) + >>skip# ; inline + +: asc ( key -- spec ) [ 1 ] dip H{ } clone [ set-at ] keep ; inline +: desc ( key -- spec ) [ -1 ] dip H{ } clone [ set-at ] keep ; inline + +GENERIC# sort 1 ( mdb-query quot -- mdb-query ) +M: mdb-query-msg sort ( query qout -- mdb-query ) + [ { } ] dip with-datastack >>orderby ; + +GENERIC# hint 1 ( mdb-query index-hint -- mdb-query ) +M: mdb-query-msg hint ( mdb-query index-hint -- mdb-query ) + >>hint ; + +: find ( mdb-query -- cursor result ) + send-query ; + +: explain ( mdb-query -- result ) + t >>explain find [ drop ] dip ; + +GENERIC: get-more ( mdb-cursor -- mdb-cursor objects ) +M: mdb-cursor get-more ( mdb-cursor -- mdb-cursor objects ) + [ [ collection>> ] [ return#>> ] [ id>> ] tri send-query ] + [ f f ] if* ; + +: find-one ( mdb-query -- result ) + 1 >>return# send-query-plain ; + +: count ( collection query -- result ) + [ "count" H{ } clone [ set-at ] keep ] dip + [ over [ "query" ] dip set-at ] when* + [ cmd-collection ] dip find-one objects>> first + [ check-ok ] keep '[ "n" _ at >fixnum ] [ f ] if ; + +: lasterror ( -- error ) + cmd-collection H{ { "getlasterror" 1 } } + find-one objects>> [ "err" ] at ; + +: validate ( collection -- ) + [ cmd-collection ] dip + "validate" H{ } clone [ set-at ] keep + find-one objects>> first [ check-ok ] keep + '[ "result" _ at print ] when ; + + + +: save ( collection object -- ) + [ ensure-collection ] dip + send-message-check-error ; + +: save-unsafe ( collection object -- ) + [ ensure-collection ] dip + send-message ; + +: ensure-index ( collection name spec -- ) + H{ } clone + [ [ "key" ] dip set-at ] keep + [ [ "name" ] dip set-at ] keep + [ [ index-ns "ns" ] dip set-at ] keep + [ index-collection ] dip + save ; + +: drop-index ( collection name -- ) + H{ } clone + [ [ "index" ] dip set-at ] keep + [ [ "deleteIndexes" ] dip set-at ] keep + [ cmd-collection ] dip find-one objects>> first + check-ok [ "could not drop index" throw ] unless ; + +: update ( collection selector object -- ) + [ ensure-collection ] dip + send-message-check-error ; + +: update-unsafe ( collection selector object -- ) + [ ensure-collection ] dip + send-message ; + +: delete ( collection selector -- ) + [ ensure-collection ] dip + send-message-check-error ; + +: delete-unsafe ( collection selector -- ) + [ ensure-collection ] dip + send-message ; + +: load-index-list ( -- index-list ) + index-collection + H{ } clone find [ drop ] dip ; + +: drop-collection ( name -- ) + [ cmd-collection ] dip + "drop" H{ } clone [ set-at ] keep + find-one objects>> first check-ok + [ "could not drop collection" throw ] unless ; diff --git a/mongodb/index/index.factor b/mongodb/index/index.factor deleted file mode 100644 index 487251c27f..0000000000 --- a/mongodb/index/index.factor +++ /dev/null @@ -1,108 +0,0 @@ -USING: accessors assocs combinators formatting fry kernel memoize -linked-assocs mongodb.persistent mongodb.msg mongodb.connection -sequences sequences.deep io.encodings.binary mongodb.tuple -io.sockets prettyprint sets tools.walker math ; - -IN: mongodb.index - -: index-ns ( name -- ns ) - "%s.system.indexes" sprintf ; inline - -TUPLE: index name ns key ; - -SYMBOLS: +fieldindex+ +compoundindex+ +deepindex+ ; - - ] 2dip - [ rest ] keep first ! assoc slot options itype - { { +fieldindex+ [ drop [ 1 ] dip pick set-at ] } - { +deepindex+ [ first "%s.%s" sprintf [ 1 ] dip pick set-at ] } - { +compoundindex+ [ - 2over swap [ 1 ] 2dip set-at [ drop ] dip ! assoc options - over '[ _ [ 1 ] 2dip set-at ] each ] } - } case ; - -: build-index-seq ( slot optlist ns -- index-seq ) - [ V{ } clone ] 3dip ! v{} slot optl ns - [ index new ] dip ! v{} slot optl index ns - >>ns - [ pick ] dip swap ! v{} slot optl index v{} - [ swap ] 2dip ! v{} optl slot index v{ } - '[ _ _ ! element slot exemplar - clone 2over swap index-name >>name ! element slot clone - [ build-index ] dip swap >>key _ push - ] each ; - -: is-index-declaration? ( entry -- ? ) - first - { { +fieldindex+ [ t ] } - { +compoundindex+ [ t ] } - { +deepindex+ [ t ] } - [ drop f ] } case ; - -: index-assoc ( seq -- assoc ) - H{ } clone tuck '[ dup name>> _ set-at ] each ; - -: delete-index ( name ns -- ) - "Drop index %s - %s" sprintf . ; - -: clean-indices ( existing defined -- ) - [ index-assoc ] bi@ assoc-diff values - [ [ name>> ] [ ns>> ] bi delete-index ] each ; - -PRIVATE> - -USE: mongodb.query - -: load-indices ( mdb-collection -- indexlist ) - [ mdb>> name>> ] dip name>> "%s.%s" sprintf - "ns" H{ } clone [ set-at ] keep [ mdb>> name>> index-ns ] dip - '[ _ write-message read-message ] - [ mdb>> master>> binary ] dip with-client - objects>> [ [ index new ] dip - [ [ "ns" ] dip at >>ns ] - [ [ "name" ] dip at >>name ] - [ [ "key" ] dip at >>key ] tri - ] map ; - -: build-indices ( mdb-collection mdb -- seq ) - name>> - [ [ mdb-slot-definitions>> ] keep name>> ] dip - swap "%s.%s" sprintf - [ V{ } clone ] 2dip pick - '[ _ - [ [ is-index-declaration? ] filter ] dip - build-index-seq _ push - ] assoc-each flatten ; - -: ensure-indices ( mdb-collection -- ) - [ load-indices ] keep mdb>> build-indices - [ clean-indices ] keep - V{ } clone tuck - '[ _ [ tuple>query ] dip push ] each - dup length 0 > - [ [ mdb>> name>> "%s.system.indexes" sprintf ] dip - - [ mdb>> master>> binary ] dip '[ _ write-message ] with-client - ] - [ drop ] if ; - -: show-indices ( mdb-collection -- ) - load-indices . ; - -: show-all-indices ( -- ) - mdb>> collections>> values - V{ } clone tuck - '[ load-indices _ push ] each flatten . ; \ No newline at end of file diff --git a/mongodb/mongodb.factor b/mongodb/mongodb.factor index 69c2809a1e..28ca6acc25 100644 --- a/mongodb/mongodb.factor +++ b/mongodb/mongodb.factor @@ -1,7 +1,8 @@ -USING: accessors assocs fry io.encodings.binary io.sockets kernel math -math.parser namespaces sequences splitting -mongodb.connection mongodb.persistent mongodb.msg mongodb.query -mongodb.tuple ; +USING: accessors assocs combinators fry io.encodings.binary +io.sockets kernel math math.parser mongodb.driver +mongodb.msg mongodb.operations mongodb.persistent +mongodb.tuple namespaces +sequences splitting ; IN: mongodb @@ -18,29 +19,32 @@ GENERIC: explain ( object -- object ) [ mdb-collection>> get-collection-fqn ] keep H{ } tuple>query ; inline +TUPLE: mdb-result { cursor integer } +{ start# integer } +{ returned# integer } +{ objects sequence } ; + +: build-result ( resultmsg -- mdb-result ) + [ mdb-result new ] dip + { + [ cursor>> >>cursor ] + [ start#>> >>start# ] + [ returned#>> >>returned# ] + [ objects>> [ assoc>tuple ] map >>objects ] + } cleave ; + PRIVATE> - -: ( db host port -- mdb ) - () ; - M: mdb-persistent store ( tuple -- ) prepare-store ! H { collection { ... values ... } [ [ get-collection-fqn ] dip - values - [ mdb>> master>> binary ] dip '[ _ write-message ] with-client + values send-message ] assoc-each ; M: mdb-persistent find ( example -- result ) - prepare-find [ mdb>> master>> ] dip (find) + prepare-find [ mdb>> master>> ] dip send-query build-result ; M: mdb-persistent nfind ( example n -- result ) [ prepare-find ] dip >>return# - [ mdb>> master>> ] dip (find) - build-result ; - -M: mdb-persistent explain ( example -- result ) - prepare-find [ query>> [ t "$explain" ] dip set-at ] keep - [ mdb>> master>> ] dip (find-one) - build-result ; + send-query build-result ; diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index 1df971b229..636e5e6755 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -1,12 +1,8 @@ -USING: accessors io.encodings.string assocs bson.reader -bson.writer byte-arrays byte-vectors constructors fry io io.binary -io.encodings.binary io.encodings.utf8 io.streams.byte-array kernel -linked-assocs math namespaces sequences strings ; +USING: accessors assocs constructors kernel linked-assocs math +sequences strings ; IN: mongodb.msg - +CONSTANT: OP_KillCursors 2007 TUPLE: mdb-msg { opcode integer } @@ -39,7 +25,7 @@ TUPLE: mdb-insert-msg < mdb-msg TUPLE: mdb-update-msg < mdb-msg { collection string } -{ upsert? integer initial: 1 } +{ upsert? integer initial: 0 } { selector assoc } { object assoc } ; @@ -62,16 +48,19 @@ TUPLE: mdb-query-msg < mdb-msg { return# integer initial: 0 } { query assoc } { returnfields assoc } -{ orderby sequence } ; +{ orderby sequence } +explain hint ; TUPLE: mdb-reply-msg < mdb-msg +{ collection string } { cursor integer initial: 0 } { start# integer initial: 0 } +{ requested# integer initial: 0 } { returned# integer initial: 0 } { objects sequence } ; -CONSTRUCTOR: mdb-getmore-msg ( collection return# -- mdb-getmore-msg ) +CONSTRUCTOR: mdb-getmore-msg ( collection return# cursor -- mdb-getmore-msg ) OP_GetMore >>opcode ; inline CONSTRUCTOR: mdb-delete-msg ( collection selector -- mdb-delete-msg ) @@ -90,213 +79,22 @@ M: sequence ( sequences -- mdb-killcursors-msg ) M: integer ( integer -- mdb-killcursors-msg ) V{ } clone [ push ] keep ; -GENERIC# 1 ( collection objects -- mdb-insert-msg ) - -M: linked-assoc ( collection linked-assoc -- mdb-insert-msg ) - [ mdb-insert-msg new ] 2dip - [ >>collection ] dip - V{ } clone tuck push - >>objects OP_Insert >>opcode ; +GENERIC: ( collection objects -- mdb-insert-msg ) M: sequence ( collection sequence -- mdb-insert-msg ) [ mdb-insert-msg new ] 2dip [ >>collection ] dip >>objects OP_Insert >>opcode ; -CONSTRUCTOR: mdb-update-msg ( collection object -- mdb-update-msg ) - dup object>> [ "_id" ] dip at "_id" H{ } clone [ set-at ] keep >>selector - OP_Update >>opcode ; +M: assoc ( collection assoc -- mdb-insert-msg ) + [ mdb-insert-msg new ] 2dip + [ >>collection ] dip + V{ } clone tuck push + >>objects OP_Insert >>opcode ; + + +CONSTRUCTOR: mdb-update-msg ( collection selector object -- mdb-update-msg ) + OP_Update >>opcode ; inline CONSTRUCTOR: mdb-reply-msg ( -- mdb-reply-msg ) ; inline -GENERIC: write-message ( message -- ) - - ( -- integer ) - msg-bytes-read get ; inline - -: >bytes-read ( integer -- ) - msg-bytes-read set ; inline - -: change-bytes-read ( integer -- ) - bytes-read> [ 0 ] unless* + >bytes-read ; inline - -: write-byte ( byte -- ) 1 >le write ; inline -: write-int32 ( int -- ) 4 >le write ; inline -: write-double ( real -- ) double>bits 8 >le write ; inline -: write-cstring ( string -- ) utf8 encode B{ 0 } append write ; inline -: write-longlong ( object -- ) 8 >le write ; inline - -: read-int32 ( -- int32 ) 4 [ read le> ] [ change-bytes-read ] bi ; inline -: read-longlong ( -- longlong ) 8 [ read le> ] [ change-bytes-read ] bi ; inline -: read-byte-raw ( -- byte-raw ) 1 [ read le> ] [ change-bytes-read ] bi ; inline -: read-byte ( -- byte ) read-byte-raw first ; inline - -: (read-cstring) ( acc -- ) - [ read-byte ] dip ! b acc - 2dup push ! b acc - [ 0 = ] dip ! bool acc - '[ _ (read-cstring) ] unless ; inline recursive - -: read-cstring ( -- string ) - BV{ } clone - [ (read-cstring) ] keep - [ zero? ] trim-tail - >byte-array utf8 decode ; inline - -GENERIC: (read-message) ( message opcode -- message ) - -: copy-header ( message msg-stub -- message ) - [ length>> ] keep [ >>length ] dip - [ req-id>> ] keep [ >>req-id ] dip - [ resp-id>> ] keep [ >>resp-id ] dip - [ opcode>> ] keep [ >>opcode ] dip - flags>> >>flags ; - -M: mdb-query-op (read-message) ( msg-stub opcode -- message ) - drop - [ mdb-query-msg new ] dip copy-header - read-cstring >>collection - read-int32 >>skip# - read-int32 >>return# - H{ } stream>assoc change-bytes-read >>query - dup length>> bytes-read> > - [ H{ } stream>assoc change-bytes-read >>returnfields - dup length>> bytes-read> > - [ H{ } stream>assoc drop >>orderby ] when - ] when ; - -M: mdb-insert-op (read-message) ( msg-stub opcode -- message ) - drop - [ mdb-insert-msg new ] dip copy-header - read-cstring >>collection - V{ } clone >>objects - [ '[ _ length>> bytes-read> > ] ] keep tuck - '[ H{ } stream>assoc change-bytes-read _ objects>> push ] - [ ] while ; - -M: mdb-delete-op (read-message) ( msg-stub opcode -- message ) - drop - [ mdb-delete-msg new ] dip copy-header - read-cstring >>collection - H{ } stream>assoc change-bytes-read >>selector ; - -M: mdb-getmore-op (read-message) ( msg-stub opcode -- message ) - drop - [ mdb-getmore-msg new ] dip copy-header - read-cstring >>collection - read-int32 >>return# - read-longlong >>cursor ; - -M: mdb-killcursors-op (read-message) ( msg-stub opcode -- message ) - drop - [ mdb-killcursors-msg new ] dip copy-header - read-int32 >>cursors# - V{ } clone >>cursors - [ [ cursors#>> ] keep - '[ read-longlong _ cursors>> push ] times ] keep ; - -M: mdb-update-op (read-message) ( msg-stub opcode -- message ) - drop - [ mdb-update-msg new ] dip copy-header - read-cstring >>collection - read-int32 >>upsert? - H{ } stream>assoc change-bytes-read >>selector - H{ } stream>assoc change-bytes-read >>object ; - -M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) - drop - [ ] dip copy-header - read-longlong >>cursor - read-int32 >>start# - read-int32 [ >>returned# ] keep - [ H{ } stream>assoc drop ] accumulator [ times ] dip >>objects ; - -: read-header ( message -- message ) - read-int32 >>length - read-int32 >>req-id - read-int32 >>resp-id - read-int32 >>opcode - read-int32 >>flags ; inline - -: write-header ( message length -- ) - MSG-HEADER-SIZE + write-int32 - [ req-id>> write-int32 ] keep - [ resp-id>> write-int32 ] keep - opcode>> write-int32 ; inline - -PRIVATE> - -: read-message ( -- message ) - mdb-msg new - 0 >bytes-read - read-header - [ ] [ opcode>> ] bi (read-message) ; - - - -M: mdb-query-msg write-message ( message -- ) - dup - '[ _ - [ flags>> write-int32 ] keep - [ collection>> write-cstring ] keep - [ skip#>> write-int32 ] keep - [ return#>> write-int32 ] keep - query>> assoc>array write - ] (write-message) ; - -M: mdb-insert-msg write-message ( message -- ) - dup - '[ _ - [ flags>> write-int32 ] keep - [ collection>> write-cstring ] keep - objects>> [ assoc>array write ] each - ] (write-message) ; - -M: mdb-update-msg write-message ( message -- ) - dup - '[ _ - [ flags>> write-int32 ] keep - [ collection>> write-cstring ] keep - [ upsert?>> write-int32 ] keep - [ selector>> assoc>array write ] keep - object>> assoc>array write - ] (write-message) ; - -M: mdb-delete-msg write-message ( message -- ) - dup - '[ _ - [ flags>> write-int32 ] keep - [ collection>> write-cstring ] keep - 0 write-int32 - selector>> assoc>array write - ] (write-message) ; - -M: mdb-getmore-msg write-message ( message -- ) - dup - '[ _ - [ flags>> write-int32 ] keep - [ collection>> write-cstring ] keep - [ return#>> write-int32 ] keep - cursor>> write-longlong - ] (write-message) ; - -M: mdb-killcursors-msg write-message ( message -- ) - dup - '[ _ - [ flags>> write-int32 ] keep - [ cursors#>> write-int32 ] keep - cursors>> [ write-longlong ] each - ] (write-message) ; \ No newline at end of file diff --git a/mongodb/operations/operations.factor b/mongodb/operations/operations.factor new file mode 100644 index 0000000000..e628251103 --- /dev/null +++ b/mongodb/operations/operations.factor @@ -0,0 +1,219 @@ +USING: accessors bson.reader bson.writer byte-arrays byte-vectors fry +io io.binary io.encodings.binary io.encodings.string io.encodings.utf8 +io.streams.byte-array kernel math mongodb.msg namespaces sequences +locals assocs combinators linked-assocs ; + +IN: mongodb.operations + + + +GENERIC: write-message ( message -- ) + + ( -- integer ) + msg-bytes-read get ; inline + +: >bytes-read ( integer -- ) + msg-bytes-read set ; inline + +: change-bytes-read ( integer -- ) + bytes-read> [ 0 ] unless* + >bytes-read ; inline + +: write-byte ( byte -- ) 1 >le write ; inline +: write-int32 ( int -- ) 4 >le write ; inline +: write-double ( real -- ) double>bits 8 >le write ; inline +: write-cstring ( string -- ) utf8 encode B{ 0 } append write ; inline +: write-longlong ( object -- ) 8 >le write ; inline + +: read-int32 ( -- int32 ) 4 [ read le> ] [ change-bytes-read ] bi ; inline +: read-longlong ( -- longlong ) 8 [ read le> ] [ change-bytes-read ] bi ; inline +: read-byte-raw ( -- byte-raw ) 1 [ read le> ] [ change-bytes-read ] bi ; inline +: read-byte ( -- byte ) read-byte-raw first ; inline + +: (read-cstring) ( acc -- ) + [ read-byte ] dip ! b acc + 2dup push ! b acc + [ 0 = ] dip ! bool acc + '[ _ (read-cstring) ] unless ; inline recursive + +: read-cstring ( -- string ) + BV{ } clone + [ (read-cstring) ] keep + [ zero? ] trim-tail + >byte-array utf8 decode ; inline + +GENERIC: (read-message) ( message opcode -- message ) + +: copy-header ( message msg-stub -- message ) + [ length>> ] keep [ >>length ] dip + [ req-id>> ] keep [ >>req-id ] dip + [ resp-id>> ] keep [ >>resp-id ] dip + [ opcode>> ] keep [ >>opcode ] dip + flags>> >>flags ; + +M: mdb-query-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-query-msg new ] dip copy-header + read-cstring >>collection + read-int32 >>skip# + read-int32 >>return# + H{ } stream>assoc change-bytes-read >>query + dup length>> bytes-read> > + [ H{ } stream>assoc change-bytes-read >>returnfields ] when ; + +M: mdb-insert-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-insert-msg new ] dip copy-header + read-cstring >>collection + V{ } clone >>objects + [ '[ _ length>> bytes-read> > ] ] keep tuck + '[ H{ } stream>assoc change-bytes-read _ objects>> push ] + while ; + +M: mdb-delete-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-delete-msg new ] dip copy-header + read-cstring >>collection + H{ } stream>assoc change-bytes-read >>selector ; + +M: mdb-getmore-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-getmore-msg new ] dip copy-header + read-cstring >>collection + read-int32 >>return# + read-longlong >>cursor ; + +M: mdb-killcursors-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-killcursors-msg new ] dip copy-header + read-int32 >>cursors# + V{ } clone >>cursors + [ [ cursors#>> ] keep + '[ read-longlong _ cursors>> push ] times ] keep ; + +M: mdb-update-op (read-message) ( msg-stub opcode -- message ) + drop + [ mdb-update-msg new ] dip copy-header + read-cstring >>collection + read-int32 >>upsert? + H{ } stream>assoc change-bytes-read >>selector + H{ } stream>assoc change-bytes-read >>object ; + +M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) + drop + [ ] dip copy-header + read-longlong >>cursor + read-int32 >>start# + read-int32 [ >>returned# ] keep + [ stream>assoc drop ] accumulator [ times ] dip >>objects ; + +: read-header ( message -- message ) + read-int32 >>length + read-int32 >>req-id + read-int32 >>resp-id + read-int32 >>opcode + read-int32 >>flags ; inline + +: write-header ( message length -- ) + MSG-HEADER-SIZE + write-int32 + [ req-id>> write-int32 ] keep + [ resp-id>> write-int32 ] keep + opcode>> write-int32 ; inline + +PRIVATE> + +: read-message ( -- message ) + mdb-msg new + 0 >bytes-read + read-header + [ ] [ opcode>> ] bi (read-message) ; + + ] | + { [ orderby>> [ "orderby" selector set-at ] when* ] + [ explain>> [ "$explain" selector set-at ] when* ] + [ hint>> [ "$hint" selector set-at ] when* ] + [ query>> "query" selector set-at ] + } cleave + selector + ] ; + +PRIVATE> + +M: mdb-query-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ collection>> write-cstring ] keep + [ skip#>> write-int32 ] keep + [ return#>> write-int32 ] keep + [ build-query-object assoc>array write ] keep + returnfields>> [ assoc>array write ] when* + ] (write-message) ; + +M: mdb-insert-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ collection>> write-cstring ] keep + objects>> [ assoc>array write ] each + ] (write-message) ; + +M: mdb-update-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ collection>> write-cstring ] keep + [ upsert?>> write-int32 ] keep + [ selector>> assoc>array write ] keep + object>> assoc>array write + ] (write-message) ; + +M: mdb-delete-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ collection>> write-cstring ] keep + 0 write-int32 + selector>> assoc>array write + ] (write-message) ; + +M: mdb-getmore-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ collection>> write-cstring ] keep + [ return#>> write-int32 ] keep + cursor>> write-longlong + ] (write-message) ; + +M: mdb-killcursors-msg write-message ( message -- ) + dup + '[ _ + [ flags>> write-int32 ] keep + [ cursors#>> write-int32 ] keep + cursors>> [ write-longlong ] each + ] (write-message) ; + diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor index f83d06905c..dc5ddb614b 100644 --- a/mongodb/persistent/persistent.factor +++ b/mongodb/persistent/persistent.factor @@ -1,6 +1,6 @@ USING: accessors assocs classes fry kernel linked-assocs math mirrors namespaces sequences strings vectors words bson.constants -continuations mongodb.tuple ; +continuations mongodb.driver mongodb.tuple ; IN: mongodb.persistent @@ -18,10 +18,10 @@ DEFER: create-mdb-command ( tuple -- objref ) - [ mdb-collection>> ] [ _id>> ] bi objref boa ; inline + [ mdb-collection-prop ] [ _id>> ] bi objref boa ; inline : mdbinfo>tuple-class ( mdbinfo -- class ) [ first ] keep second lookup ; inline diff --git a/mongodb/query/query.factor b/mongodb/query/query.factor deleted file mode 100644 index ca3b059537..0000000000 --- a/mongodb/query/query.factor +++ /dev/null @@ -1,68 +0,0 @@ -USING: accessors combinators fry io.encodings.binary io.sockets kernel -mongodb.msg mongodb.persistent mongodb.connection sequences math namespaces assocs -formatting splitting mongodb.tuple mongodb.index ; - -IN: mongodb.query - -TUPLE: mdb-result { cursor integer } -{ start# integer } -{ returned# integer } -{ objects sequence } ; - -: namespaces-ns ( name -- ns ) - "%s.system.namespaces" sprintf ; inline - - - -: (find) ( inet query -- result ) - '[ _ write-message read-message ] (execute-query) ; inline - -: (find-one) ( inet query -- result ) - 1 >>return# - (find) ; inline - -: build-result ( resultmsg -- mdb-result ) - [ mdb-result new ] dip - { - [ cursor>> >>cursor ] - [ start#>> >>start# ] - [ returned#>> >>returned# ] - [ objects>> [ assoc>tuple ] map >>objects ] - } cleave ; - -: load-collections ( -- collections ) - mdb>> [ master>> ] [ name>> namespaces-ns ] bi - H{ } clone (find) - objects>> [ [ "name" ] dip at "." split second ] map - H{ } clone tuck - '[ [ ensure-indices ] [ ] [ name>> ] tri _ set-at ] each - [ mdb>> ] dip >>collections collections>> ; - -: check-ok ( result -- ? ) - [ "ok" ] dip key? ; inline - -: create-collection ( mdb-collection -- ) - dup name>> "create" H{ } clone [ set-at ] keep - [ mdb>> [ master>> ] [ name>> ] bi "%s.$cmd" sprintf ] dip - (find-one) objects>> first - check-ok - [ [ ensure-indices ] keep dup name>> mdb>> collections>> set-at ] - [ "could not create collection" throw ] if ; - -: get-collection-fqn ( mdb-collection -- fqdn ) - mdb>> collections>> - dup keys length 0 = - [ drop load-collections ] - [ ] if - [ dup name>> ] dip - key? - [ ] - [ dup create-collection ] if - name>> [ mdb>> name>> ] dip "%s.%s" sprintf ; - - \ No newline at end of file diff --git a/mongodb/tuple/tuple.factor b/mongodb/tuple/tuple.factor index 16e408d78e..34591a5d4a 100644 --- a/mongodb/tuple/tuple.factor +++ b/mongodb/tuple/tuple.factor @@ -1,131 +1,170 @@ USING: accessors assocs classes classes.mixin classes.tuple vectors math -classes.tuple.parser formatting generalizations kernel sequences fry -prettyprint strings compiler.units slots tools.walker words arrays mongodb.persistent ; +classes.tuple.parser formatting generalizations kernel sequences fry combinators +linked-assocs sequences.deep mongodb.driver continuations memoize +prettyprint strings compiler.units slots tools.walker words arrays ; IN: mongodb.tuple MIXIN: mdb-persistent - -GENERIC: mdb-slot-definitions>> ( tuple -- string ) -GENERIC: mdb-collection>> ( object -- mdb-collection ) - -CONSTANT: MDB_COLLECTIONS "mdb_collections" -CONSTANT: MDB_COL_PROP "mdb_collection" -CONSTANT: MDB_SLOTOPT_PROP "mdb_slot_options" - SLOT: _id -CONSTANT: MDB_P_SLOTS { "_id" } -CONSTANT: MDB_OID "_id" +SLOT: _mdb_ -SYMBOLS: +transient+ +load+ ; +GENERIC: mdb-collection-prop ( object -- mdb-collection ) +GENERIC: mdb-slot-list ( tuple -- string ) -UNION: boolean t POSTPONE: f ; +CONSTANT: MDB_COLLECTION_MAP "_mdb_col_map" +CONSTANT: MDB_COLLECTION "_mdb_col" +CONSTANT: MDB_SLOTDEF_LIST "_mdb_slot_list" -TUPLE: mdb-collection - { name string } - { capped boolean initial: f } - { size integer initial: -1 } - { max integer initial: -1 } - { classes sequence } ; +SYMBOLS: +transient+ +load+ +fieldindex+ +compoundindex+ +deepindex+ ; + +TUPLE: mdb-tuple-collection < mdb-collection { classes sequence } ; +TUPLE: mdb-tuple-index name key ; + +USE: mongodb.persistent >) ( class -- mdb-collection ) - dup props>> [ MDB_COL_PROP ] dip at - [ [ drop ] dip ] - [ superclass [ (mdb-collection>>) ] [ f ] if* ] if* ; inline recursive +: MDB_ADDON_SLOTS ( -- slots ) + { } [ MDB_OID MDB_PROPERTIES ] with-datastack ; inline -: (mdb-slot-definitions>>) ( class -- slot-defs ) - superclasses [ MDB_SLOTOPT_PROP word-prop ] map assoc-combine ; inline +: (mdb-collection) ( class -- mdb-collection ) + dup MDB_COLLECTION word-prop + [ [ drop ] dip ] + [ superclass [ (mdb-collection) ] [ f ] if* ] if* ; inline recursive + +: (mdb-slot-list) ( class -- slot-defs ) + superclasses [ MDB_SLOTDEF_LIST word-prop ] map assoc-combine ; inline : link-class ( class collection -- ) - tuck classes>> ! col class v{} + over classes>> [ 2dup member? [ 2drop ] [ push ] if ] - [ 1vector >>classes ] if* drop ; + [ 1vector >>classes ] if* drop ; inline + +: link-collection ( class collection -- ) + [ swap link-class ] [ MDB_COLLECTION set-word-prop ] 2bi ; inline PRIVATE> -M: tuple-class mdb-collection>> ( tuple -- mdb-collection ) - (mdb-collection>>) ; +M: tuple-class mdb-collection-prop ( tuple -- mdb-collection ) + (mdb-collection) ; -M: mdb-persistent mdb-collection>> ( tuple -- mdb-collection ) - class (mdb-collection>>) ; +M: mdb-persistent mdb-collection-prop ( tuple -- mdb-collection ) + class (mdb-collection) ; -M: mdb-persistent mdb-slot-definitions>> ( tuple -- string ) - class (mdb-slot-definitions>>) ; +M: mdb-persistent mdb-slot-list ( tuple -- string ) + class (mdb-slot-list) ; -M: tuple-class mdb-slot-definitions>> ( class -- assoc ) - (mdb-slot-definitions>>) ; +M: tuple-class mdb-slot-list ( class -- assoc ) + (mdb-slot-list) ; -M: mdb-collection mdb-slot-definitions>> ( collection -- assoc ) - classes>> [ mdb-slot-definitions>> ] map assoc-combine ; - -: link-collection ( class collection -- ) - 2dup link-class - swap [ MDB_COL_PROP ] dip props>> set-at ; inline - -: declared-collections> ( -- assoc ) - MDB_COLLECTIONS mdb-persistent props>> at - [ H{ } clone - [ MDB_COLLECTIONS mdb-persistent props>> set-at ] keep - ] unless* ; - -: ( name -- mdb-collection ) - declared-collections> 2dup key? - [ at ] - [ [ mdb-collection new ] 2dip - [ [ >>name dup ] keep ] dip set-at ] if ; +M: mdb-collection mdb-slot-list ( collection -- assoc ) + classes>> [ mdb-slot-list ] map assoc-combine ; +: collection-map ( -- assoc ) + MDB_COLLECTION_MAP mdb-persistent word-prop + [ mdb-persistent MDB_COLLECTION_MAP H{ } clone + [ set-word-prop ] keep ] unless* ; inline + +: ( name -- mdb-tuple-collection ) + collection-map [ ] [ key? ] 2bi + [ at ] [ [ mdb-tuple-collection new dup ] 2dip + [ [ >>name ] keep ] dip set-at ] if ; + > ] map [ MDB_OID ] dip memq? - [ ] - [ MDB_P_SLOTS prepend ] if ; inline +: mdb-check-slots ( superclass slots -- superclass slots ) + over all-slots [ name>> ] map [ MDB_OID ] dip member? + [ ] [ MDB_ADDON_SLOTS prepend ] if ; inline PRIVATE> : show-persistence-info ( class -- ) H{ } clone - [ [ dup mdb-collection>> "collection" ] dip set-at ] keep - [ [ mdb-slot-definitions>> "slots" ] dip set-at ] keep . ; - -GENERIC: mdb-persisted? ( tuple -- ? ) - -M: mdb-persistent mdb-persisted? ( tuple -- ? ) - _id>> f = not ; - -M: assoc mdb-persisted? ( assoc -- ? ) - [ MDB_OID ] dip key? ; inline + [ [ mdb-collection-prop "collection" ] dip set-at ] 2keep + [ [ mdb-slot-list "slots" ] dip set-at ] keep . ; : MDBTUPLE: parse-tuple-definition - mdb-check-id-slot + mdb-check-slots define-tuple-class ; parsing assoc ( seq -- assoc ) +: opt>assoc ( seq -- assoc ) [ dup assoc? - [ 1array { "" } append ] unless - ] map ; + [ 1array { "" } append ] unless ] map ; + +: optl>map ( seq -- map ) + H{ } clone tuck + '[ split-optl opt>assoc swap _ set-at ] each ; inline + +: set-slot-options ( class options -- ) + '[ MDB_SLOTDEF_LIST _ optl>map set-word-prop ] keep + dup mdb-collection-prop link-collection ; inline PRIVATE> -: set-slot-options ( class options -- ) - H{ } clone tuck '[ _ [ split-olist optl>assoc swap ] dip set-at ] each - over [ MDB_SLOTOPT_PROP ] dip props>> set-at - dup mdb-collection>> link-collection ; - -: define-collection ( class collection options -- ) +: set-collection ( class collection options -- ) [ [ dup ] dip link-collection ] dip ! cl options [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip set-slot-options ; + ] 2dip + [ rest ] keep first ! assoc slot options itype + { { +fieldindex+ [ drop [ 1 ] dip pick set-at ] } + { +deepindex+ [ first "%s.%s" sprintf [ 1 ] dip pick set-at ] } + { +compoundindex+ [ + 2over swap [ 1 ] 2dip set-at [ drop ] dip ! assoc options + over '[ _ [ 1 ] 2dip set-at ] each ] } + } case ; + +: build-index-seq ( slot optlist -- index-seq ) + [ V{ } clone ] 2dip pick ! v{} slot optl v{} + [ swap ] dip ! v{} optl slot v{ } + '[ _ mdb-tuple-index new ! element slot exemplar + 2over swap index-name >>name ! element slot clone + [ build-index ] dip swap >>key _ push + ] each ; + +MEMO: is-index-declaration? ( entry -- ? ) + first + { { +fieldindex+ [ t ] } + { +compoundindex+ [ t ] } + { +deepindex+ [ t ] } + [ drop f ] } case ; + +: build-tuple-index-list ( mdb-collection -- seq ) + mdb-slot-list V{ } clone tuck + '[ [ is-index-declaration? ] filter + build-index-seq _ push + ] assoc-each flatten ; + +PRIVATE> + +: clean-indices ( list list2 -- ) 2drop ; + +: load-tuple-index-list ( mdb-collection -- indexlist ) + [ load-index-list ] dip + '[ [ "ns" ] dip at _ name>> ensure-collection = ] filter ; + +: ensure-tuple-index-list ( mdb-collection -- ) + [ build-tuple-index-list ] keep + '[ [ _ name>> ] dip [ name>> ] [ key>> ] bi ensure-index ] each ; From 83b251feee9677d888bd541eb4e6876696bcdc3d Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Mon, 2 Mar 2009 06:44:35 +0100 Subject: [PATCH 030/101] removed tuple integration from main branch --- mongodb/persistent/persistent.factor | 117 ------------------ mongodb/tuple/tuple.factor | 170 --------------------------- 2 files changed, 287 deletions(-) delete mode 100644 mongodb/persistent/persistent.factor delete mode 100644 mongodb/tuple/tuple.factor diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor deleted file mode 100644 index dc5ddb614b..0000000000 --- a/mongodb/persistent/persistent.factor +++ /dev/null @@ -1,117 +0,0 @@ -USING: accessors assocs classes fry kernel linked-assocs math mirrors -namespaces sequences strings vectors words bson.constants -continuations mongodb.driver mongodb.tuple ; - -IN: mongodb.persistent - -SYMBOL: mdb-op-seq - -GENERIC# tuple>assoc 1 ( tuple exemplar -- assoc ) - -: tuple>linked-assoc ( tuple -- linked-assoc ) - tuple>assoc ; inline - -GENERIC# tuple>query 1 ( tuple examplar -- query-assoc ) - -DEFER: assoc>tuple -DEFER: create-mdb-command - - ( tuple -- objref ) - [ mdb-collection-prop ] [ _id>> ] bi objref boa ; inline - -: mdbinfo>tuple-class ( mdbinfo -- class ) - [ first ] keep second lookup ; inline - -: make-tuple ( assoc -- tuple ) - [ MDB_INFO swap at mdbinfo>tuple-class new ] keep ! instance assoc - [ dup [ keys ] keep ] dip ! instance array mirror assoc - '[ dup _ [ _ at assoc>tuple ] dip [ swap ] dip set-at ] each ; - -: persistent-info ( tuple -- pinfo ) - class V{ } clone tuck - [ [ name>> ] dip push ] - [ [ vocabulary>> ] dip push ] 2bi ; inline - -: id-or-f? ( key value -- key value boolean ) - over "_id" = - [ dup f = ] dip or ; inline - -: write-persistent-info ( mirror exemplar assoc -- ) - [ drop ] dip - 2dup [ "_id" ] 2dip [ over [ at ] dip ] dip set-at - [ object>> persistent-info MDB_INFO ] dip set-at ; - -: persistent-tuple? ( object -- object boolean ) - dup mdb-persistent? ; inline - -: ensure-value-ht ( key ht -- vht ) - 2dup key? - [ at ] - [ [ H{ } clone dup ] 2dip set-at ] if ; inline - -: data-tuple? ( tuple -- ? ) - dup tuple? [ assoc? [ f ] [ t ] if ] [ drop f ] if ; - -: write-tuple-fields ( mirror exemplar assoc -- ) - [ dup ] dip ! m e e a - '[ id-or-f? - [ 2drop ] - [ persistent-tuple? - [ _ keep - [ mdb-collection>> ] keep - [ create-mdb-command ] dip - ] - [ dup data-tuple? _ [ ] if ] if - swap _ set-at - ] if - ] assoc-each ; - -: prepare-assoc ( tuple exemplar -- assoc mirror exemplar assoc ) - [ ] dip dup clone swap [ tuck ] dip swap ; inline - -: ensure-mdb-info ( tuple -- tuple ) - dup _id>> [ >>_id ] unless ; inline - -: with-op-seq ( quot -- op-seq ) - [ - [ H{ } clone mdb-op-seq set ] dip call mdb-op-seq get - ] with-scope ; inline - -PRIVATE> - -: create-mdb-command ( assoc ns -- ) - mdb-op-seq get - ensure-value-ht - [ dup [ MDB_OID ] dip at ] dip - set-at ; inline - -: prepare-store ( mdb-persistent -- op-seq ) - '[ _ [ tuple>linked-assoc ] keep mdb-collection>> create-mdb-command ] - with-op-seq ; inline - -M: mdb-persistent tuple>assoc ( tuple exemplar -- assoc ) - [ ensure-mdb-info ] dip ! tuple exemplar - prepare-assoc - [ write-persistent-info ] - [ [ '[ _ tuple>assoc ] ] dip write-tuple-fields ] 3bi ; - -M: tuple tuple>assoc ( tuple exemplar -- assoc ) - [ drop persistent-info MDB_INFO ] 2keep - prepare-assoc [ '[ _ tuple>assoc ] ] write-tuple-fields - [ set-at ] keep ; - -M: tuple tuple>query ( tuple examplar -- assoc ) - prepare-assoc [ '[ _ tuple>query ] ] dip write-tuple-fields ; - -: assoc>tuple ( assoc -- tuple ) - dup assoc? - [ [ dup MDB_INFO swap key? - [ make-tuple ] - [ ] if ] [ drop ] recover - ] [ ] if ; inline - - diff --git a/mongodb/tuple/tuple.factor b/mongodb/tuple/tuple.factor deleted file mode 100644 index 34591a5d4a..0000000000 --- a/mongodb/tuple/tuple.factor +++ /dev/null @@ -1,170 +0,0 @@ -USING: accessors assocs classes classes.mixin classes.tuple vectors math -classes.tuple.parser formatting generalizations kernel sequences fry combinators -linked-assocs sequences.deep mongodb.driver continuations memoize -prettyprint strings compiler.units slots tools.walker words arrays ; - -IN: mongodb.tuple - -MIXIN: mdb-persistent - -SLOT: _id -SLOT: _mdb_ - -GENERIC: mdb-collection-prop ( object -- mdb-collection ) -GENERIC: mdb-slot-list ( tuple -- string ) - -CONSTANT: MDB_COLLECTION_MAP "_mdb_col_map" -CONSTANT: MDB_COLLECTION "_mdb_col" -CONSTANT: MDB_SLOTDEF_LIST "_mdb_slot_list" - -SYMBOLS: +transient+ +load+ +fieldindex+ +compoundindex+ +deepindex+ ; - -TUPLE: mdb-tuple-collection < mdb-collection { classes sequence } ; -TUPLE: mdb-tuple-index name key ; - -USE: mongodb.persistent - -> - [ 2dup member? [ 2drop ] [ push ] if ] - [ 1vector >>classes ] if* drop ; inline - -: link-collection ( class collection -- ) - [ swap link-class ] [ MDB_COLLECTION set-word-prop ] 2bi ; inline - -PRIVATE> - -M: tuple-class mdb-collection-prop ( tuple -- mdb-collection ) - (mdb-collection) ; - -M: mdb-persistent mdb-collection-prop ( tuple -- mdb-collection ) - class (mdb-collection) ; - -M: mdb-persistent mdb-slot-list ( tuple -- string ) - class (mdb-slot-list) ; - -M: tuple-class mdb-slot-list ( class -- assoc ) - (mdb-slot-list) ; - -M: mdb-collection mdb-slot-list ( collection -- assoc ) - classes>> [ mdb-slot-list ] map assoc-combine ; - -: collection-map ( -- assoc ) - MDB_COLLECTION_MAP mdb-persistent word-prop - [ mdb-persistent MDB_COLLECTION_MAP H{ } clone - [ set-word-prop ] keep ] unless* ; inline - -: ( name -- mdb-tuple-collection ) - collection-map [ ] [ key? ] 2bi - [ at ] [ [ mdb-tuple-collection new dup ] 2dip - [ [ >>name ] keep ] dip set-at ] if ; - -> ] map [ MDB_OID ] dip member? - [ ] [ MDB_ADDON_SLOTS prepend ] if ; inline - -PRIVATE> - -: show-persistence-info ( class -- ) - H{ } clone - [ [ mdb-collection-prop "collection" ] dip set-at ] 2keep - [ [ mdb-slot-list "slots" ] dip set-at ] keep . ; - -: MDBTUPLE: - parse-tuple-definition - mdb-check-slots - define-tuple-class ; parsing - -assoc ( seq -- assoc ) - [ dup assoc? - [ 1array { "" } append ] unless ] map ; - -: optl>map ( seq -- map ) - H{ } clone tuck - '[ split-optl opt>assoc swap _ set-at ] each ; inline - -: set-slot-options ( class options -- ) - '[ MDB_SLOTDEF_LIST _ optl>map set-word-prop ] keep - dup mdb-collection-prop link-collection ; inline - -PRIVATE> - -: set-collection ( class collection options -- ) - [ [ dup ] dip link-collection ] dip ! cl options - [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip - set-slot-options ; - - ] 2dip - [ rest ] keep first ! assoc slot options itype - { { +fieldindex+ [ drop [ 1 ] dip pick set-at ] } - { +deepindex+ [ first "%s.%s" sprintf [ 1 ] dip pick set-at ] } - { +compoundindex+ [ - 2over swap [ 1 ] 2dip set-at [ drop ] dip ! assoc options - over '[ _ [ 1 ] 2dip set-at ] each ] } - } case ; - -: build-index-seq ( slot optlist -- index-seq ) - [ V{ } clone ] 2dip pick ! v{} slot optl v{} - [ swap ] dip ! v{} optl slot v{ } - '[ _ mdb-tuple-index new ! element slot exemplar - 2over swap index-name >>name ! element slot clone - [ build-index ] dip swap >>key _ push - ] each ; - -MEMO: is-index-declaration? ( entry -- ? ) - first - { { +fieldindex+ [ t ] } - { +compoundindex+ [ t ] } - { +deepindex+ [ t ] } - [ drop f ] } case ; - -: build-tuple-index-list ( mdb-collection -- seq ) - mdb-slot-list V{ } clone tuck - '[ [ is-index-declaration? ] filter - build-index-seq _ push - ] assoc-each flatten ; - -PRIVATE> - -: clean-indices ( list list2 -- ) 2drop ; - -: load-tuple-index-list ( mdb-collection -- indexlist ) - [ load-index-list ] dip - '[ [ "ns" ] dip at _ name>> ensure-collection = ] filter ; - -: ensure-tuple-index-list ( mdb-collection -- ) - [ build-tuple-index-list ] keep - '[ [ _ name>> ] dip [ name>> ] [ key>> ] bi ensure-index ] each ; From e21f36769119b58cc20f1e64df6bce49bcfa5a44 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Mon, 2 Mar 2009 06:53:32 +0100 Subject: [PATCH 031/101] removed mongodb.factor isn't needed until tuple integration really works --- mongodb/mongodb.factor | 50 ------------------------------------------ 1 file changed, 50 deletions(-) delete mode 100644 mongodb/mongodb.factor diff --git a/mongodb/mongodb.factor b/mongodb/mongodb.factor deleted file mode 100644 index 28ca6acc25..0000000000 --- a/mongodb/mongodb.factor +++ /dev/null @@ -1,50 +0,0 @@ -USING: accessors assocs combinators fry io.encodings.binary -io.sockets kernel math math.parser mongodb.driver -mongodb.msg mongodb.operations mongodb.persistent -mongodb.tuple namespaces -sequences splitting ; - -IN: mongodb - -! generic methods -GENERIC: store ( tuple/ht -- ) -GENERIC: find ( example -- tuple/ht ) -GENERIC# nfind 1 ( example n -- tuple/ht ) -GENERIC: load ( object -- object ) -GENERIC: explain ( object -- object ) - -> get-collection-fqn ] keep - H{ } tuple>query ; inline - -TUPLE: mdb-result { cursor integer } -{ start# integer } -{ returned# integer } -{ objects sequence } ; - -: build-result ( resultmsg -- mdb-result ) - [ mdb-result new ] dip - { - [ cursor>> >>cursor ] - [ start#>> >>start# ] - [ returned#>> >>returned# ] - [ objects>> [ assoc>tuple ] map >>objects ] - } cleave ; - -PRIVATE> - -M: mdb-persistent store ( tuple -- ) - prepare-store ! H { collection { ... values ... } - [ [ get-collection-fqn ] dip - values send-message - ] assoc-each ; - -M: mdb-persistent find ( example -- result ) - prepare-find [ mdb>> master>> ] dip send-query - build-result ; - -M: mdb-persistent nfind ( example n -- result ) - [ prepare-find ] dip >>return# - send-query build-result ; From 22a891b4832ea34f905298ba4700370f267bd72a Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Mon, 2 Mar 2009 18:44:24 +0100 Subject: [PATCH 032/101] added _id handling; the _id field must always be the first field in a bson document. Handling it at this "low" level makes things easier in the layers above --- bson/constants/constants.factor | 2 ++ bson/writer/writer.factor | 11 +++++++++-- mongodb/operations/operations.factor | 4 ++-- 3 files changed, 13 insertions(+), 4 deletions(-) diff --git a/bson/constants/constants.factor b/bson/constants/constants.factor index 039ea18089..368374fb30 100644 --- a/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -11,6 +11,8 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ; TUPLE: objref ns objid ; +CONSTANT: MDB_OID_FIELD "_id" + CONSTANT: T_EOO 0 CONSTANT: T_Double 1 CONSTANT: T_Integer 16 diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 439cfb7372..55adb95b11 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -93,9 +93,16 @@ M: sequence bson-write ( array -- ) [ length 5 + bson-write ] keep write write-eoo ; - + +: write-oid ( hashtable -- ) + [ MDB_OID_FIELD ] dip at* + [ [ MDB_OID_FIELD ] dip write-pair ] [ drop ] if ; inline + +: oid-field? ( name -- boolean ) + MDB_OID_FIELD = ; inline + M: assoc bson-write ( hashtable -- ) - '[ _ [ write-pair ] assoc-each ] + '[ _ [ write-oid ] [ [ over oid-field? [ 2drop ] [ write-pair ] if ] assoc-each ] bi ] binary swap with-byte-writer [ length 5 + bson-write ] keep write diff --git a/mongodb/operations/operations.factor b/mongodb/operations/operations.factor index e628251103..75207cf30b 100644 --- a/mongodb/operations/operations.factor +++ b/mongodb/operations/operations.factor @@ -120,7 +120,7 @@ M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) read-longlong >>cursor read-int32 >>start# read-int32 [ >>returned# ] keep - [ stream>assoc drop ] accumulator [ times ] dip >>objects ; + [ H{ } stream>assoc drop ] accumulator [ times ] dip >>objects ; : read-header ( message -- message ) read-int32 >>length @@ -151,7 +151,7 @@ PRIVATE> write flush ; inline : build-query-object ( query -- selector ) - [let | selector [ ] | + [let | selector [ H{ } clone ] | { [ orderby>> [ "orderby" selector set-at ] when* ] [ explain>> [ "$explain" selector set-at ] when* ] [ hint>> [ "$hint" selector set-at ] when* ] From 75c28ee62f0f9c0b3be372b0c41ddbcbf6921d35 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Tue, 3 Mar 2009 16:26:54 +0100 Subject: [PATCH 033/101] renamed some things moved _id and _mdb_ constants to bson vocab --- bson/constants/constants.factor | 1 + bson/writer/writer.factor | 14 +++++++------- mongodb/driver/driver.factor | 33 ++++++++++++++++----------------- mongodb/msg/msg.factor | 4 ++-- 4 files changed, 26 insertions(+), 26 deletions(-) diff --git a/bson/constants/constants.factor b/bson/constants/constants.factor index 368374fb30..be9f9466b5 100644 --- a/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -12,6 +12,7 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ; TUPLE: objref ns objid ; CONSTANT: MDB_OID_FIELD "_id" +CONSTANT: MDB_INTERNAL_FIELD "_mdb_" CONSTANT: T_EOO 0 CONSTANT: T_Double 1 diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 55adb95b11..de764220be 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -3,7 +3,7 @@ USING: accessors assocs bson.constants byte-arrays fry io io.binary io.encodings.binary io.encodings.string io.encodings.utf8 io.streams.byte-array kernel math math.parser quotations sequences -serialize strings words ; +serialize strings words hashtables ; IN: bson.writer @@ -20,10 +20,10 @@ M: f bson-type? ( boolean -- type ) drop T_Boolean ; M: real bson-type? ( real -- type ) drop T_Double ; M: word bson-type? ( word -- type ) drop T_String ; M: tuple bson-type? ( tuple -- type ) drop T_Object ; -M: assoc bson-type? ( hashtable -- type ) drop T_Object ; +M: sequence bson-type? ( seq -- type ) drop T_Array ; M: string bson-type? ( string -- type ) drop T_String ; M: integer bson-type? ( integer -- type ) drop T_Integer ; -M: sequence bson-type? ( seq -- type ) drop T_Array ; +M: hashtable bson-type? ( hashtable -- type ) drop T_Object ; M: oid bson-type? ( word -- type ) drop T_OID ; M: objid bson-type? ( objid -- type ) drop T_Binary ; @@ -98,11 +98,11 @@ M: sequence bson-write ( array -- ) [ MDB_OID_FIELD ] dip at* [ [ MDB_OID_FIELD ] dip write-pair ] [ drop ] if ; inline -: oid-field? ( name -- boolean ) - MDB_OID_FIELD = ; inline +: skip-field? ( name -- boolean ) + { MDB_OID_FIELD MDB_INTERNAL_FIELD } member? ; inline -M: assoc bson-write ( hashtable -- ) - '[ _ [ write-oid ] [ [ over oid-field? [ 2drop ] [ write-pair ] if ] assoc-each ] bi ] +M: hashtable bson-write ( hashtable -- ) + '[ _ [ write-oid ] [ [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each ] bi ] binary swap with-byte-writer [ length 5 + bson-write ] keep write diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 6337452174..e9557a49ca 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -6,7 +6,7 @@ IN: mongodb.driver TUPLE: mdb-node master? inet ; -TUPLE: mdb name nodes collections ; +TUPLE: mdb-db name nodes collections ; TUPLE: mdb-cursor collection id return# ; @@ -23,9 +23,6 @@ CONSTRUCTOR: mdb-collection ( name -- collection ) ; CONSTANT: MDB-GENERAL-ERROR 1 -CONSTANT: MDB_OID "_id" -CONSTANT: MDB_PROPERTIES "_mdb_" - CONSTANT: PARTIAL? "partial?" CONSTANT: DIRTY? "dirty?" @@ -43,8 +40,10 @@ SYMBOL: mdb-socket-stream PRIVATE> -: mdb>> ( -- mdb ) - mdb get ; inline +SYMBOL: mdb-instance + +: mdb ( -- mdb ) + mdb-instance get ; inline : master>> ( mdb -- inet ) nodes>> [ t ] dip at inet>> ; @@ -53,7 +52,7 @@ PRIVATE> nodes>> [ f ] dip at inet>> ; : with-db ( mdb quot -- ... ) - [ [ '[ _ [ mdb set ] keep master>> + [ [ '[ _ [ mdb-instance set ] keep master>> [ remote-address set ] keep binary local-address set @@ -64,16 +63,16 @@ PRIVATE> > name>> "%s.system.indexes" sprintf ; inline + mdb name>> "%s.system.indexes" sprintf ; inline : namespaces-collection ( -- ns ) - mdb>> name>> "%s.system.namespaces" sprintf ; inline + mdb name>> "%s.system.namespaces" sprintf ; inline : cmd-collection ( -- ns ) - mdb>> name>> "%s.$cmd" sprintf ; inline + mdb name>> "%s.$cmd" sprintf ; inline : index-ns ( colname -- index-ns ) - [ mdb>> name>> ] dip "%s.%s" sprintf ; inline + [ mdb name>> ] dip "%s.%s" sprintf ; inline : ismaster-cmd ( node -- result ) binary "admin.$cmd" H{ { "ismaster" 1 } } @@ -103,11 +102,11 @@ PRIVATE> ] when* ; : verify-nodes ( -- ) - mdb>> nodes>> [ t ] dip at + mdb nodes>> [ t ] dip at check-nodes H{ } clone tuck '[ dup master?>> _ set-at ] each - [ mdb>> ] dip >>nodes drop ; + [ mdb ] dip >>nodes drop ; : send-message ( message -- ) [ mdb-stream>> ] dip '[ _ write-message ] with-stream* ; @@ -133,7 +132,7 @@ PRIVATE> check-nodes H{ } clone tuck '[ dup master?>> _ set-at ] each - H{ } clone mdb boa ; + H{ } clone mdb-db boa ; : create-collection ( name -- ) [ cmd-collection ] dip @@ -152,7 +151,7 @@ PRIVATE> '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline : (ensure-collection) ( collection -- ) - mdb>> collections>> dup keys length 0 = + mdb collections>> dup keys length 0 = [ load-collection-list [ [ "options" ] dip key? ] filter [ [ "name" ] dip at "." split second ] map @@ -166,11 +165,11 @@ MEMO: reserved-namespace? ( name -- ? ) PRIVATE> MEMO: ensure-collection ( collection -- fq-collection ) - "." split1 over mdb>> name>> = + "." split1 over mdb name>> = [ [ drop ] dip ] [ drop ] if [ ] [ reserved-namespace? ] bi [ [ (ensure-collection) ] keep ] unless - [ mdb>> name>> ] dip "%s.%s" sprintf ; inline + [ mdb name>> ] dip "%s.%s" sprintf ; inline : ( collection query -- mdb-query ) [ ensure-collection ] dip diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index 636e5e6755..7d1a8058b0 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -1,4 +1,4 @@ -USING: accessors assocs constructors kernel linked-assocs math +USING: accessors assocs hashtables constructors kernel linked-assocs math sequences strings ; IN: mongodb.msg @@ -86,7 +86,7 @@ M: sequence ( collection sequence -- mdb-insert-msg ) [ >>collection ] dip >>objects OP_Insert >>opcode ; -M: assoc ( collection assoc -- mdb-insert-msg ) +M: hashtable ( collection assoc -- mdb-insert-msg ) [ mdb-insert-msg new ] 2dip [ >>collection ] dip V{ } clone tuck push From 66cf30ac1c3982ab597c9fdd994689982305bc04 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Tue, 3 Mar 2009 22:44:24 +0100 Subject: [PATCH 034/101] made most "front" methods generic switched back to assoc generic type --- bson/writer/writer.factor | 8 +++--- mongodb/driver/driver.factor | 55 ++++++++++++++++++++++++++---------- 2 files changed, 44 insertions(+), 19 deletions(-) diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index de764220be..3859f314e2 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -3,7 +3,7 @@ USING: accessors assocs bson.constants byte-arrays fry io io.binary io.encodings.binary io.encodings.string io.encodings.utf8 io.streams.byte-array kernel math math.parser quotations sequences -serialize strings words hashtables ; +serialize strings words ; IN: bson.writer @@ -23,7 +23,7 @@ M: tuple bson-type? ( tuple -- type ) drop T_Object ; M: sequence bson-type? ( seq -- type ) drop T_Array ; M: string bson-type? ( string -- type ) drop T_String ; M: integer bson-type? ( integer -- type ) drop T_Integer ; -M: hashtable bson-type? ( hashtable -- type ) drop T_Object ; +M: assoc bson-type? ( assoc -- type ) drop T_Object ; M: oid bson-type? ( word -- type ) drop T_OID ; M: objid bson-type? ( objid -- type ) drop T_Binary ; @@ -94,14 +94,14 @@ M: sequence bson-write ( array -- ) write write-eoo ; -: write-oid ( hashtable -- ) +: write-oid ( assoc -- ) [ MDB_OID_FIELD ] dip at* [ [ MDB_OID_FIELD ] dip write-pair ] [ drop ] if ; inline : skip-field? ( name -- boolean ) { MDB_OID_FIELD MDB_INTERNAL_FIELD } member? ; inline -M: hashtable bson-write ( hashtable -- ) +M: assoc bson-write ( assoc -- ) '[ _ [ write-oid ] [ [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each ] bi ] binary swap with-byte-writer [ length 5 + bson-write ] keep diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index e9557a49ca..d8e90052d0 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -134,10 +134,21 @@ PRIVATE> '[ dup master?>> _ set-at ] each H{ } clone mdb-db boa ; -: create-collection ( name -- ) +GENERIC: create-collection ( name -- ) +M: string create-collection + create-collection ; + +M: mdb-collection create-collection ( mdb-collection -- ) [ cmd-collection ] dip - "create" H{ } clone [ set-at ] keep - 1 >>return# send-query-plain objects>> first check-ok + [ + [ [ 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 1 >>return# send-query-plain objects>> first check-ok [ "could not create collection" throw ] unless ; : load-collection-list ( -- collection-list ) @@ -194,10 +205,12 @@ GENERIC# hint 1 ( mdb-query index-hint -- mdb-query ) M: mdb-query-msg hint ( mdb-query index-hint -- mdb-query ) >>hint ; -: find ( mdb-query -- cursor result ) +GENERIC: find ( mdb-query -- cursor result ) +M: mdb-query-msg find send-query ; -: explain ( mdb-query -- result ) +GENERIC: explain ( mdb-query -- result ) +M: mdb-query-msg explain t >>explain find [ drop ] dip ; GENERIC: get-more ( mdb-cursor -- mdb-cursor objects ) @@ -205,10 +218,12 @@ M: mdb-cursor get-more ( mdb-cursor -- mdb-cursor objects ) [ [ collection>> ] [ return#>> ] [ id>> ] tri send-query ] [ f f ] if* ; -: find-one ( mdb-query -- result ) +GENERIC: find-one ( mdb-query -- result ) +M: mdb-query-msg find-one 1 >>return# send-query-plain ; -: count ( collection query -- result ) +GENERIC: count ( collection query -- result ) +M: assoc count [ "count" H{ } clone [ set-at ] keep ] dip [ over [ "query" ] dip set-at ] when* [ cmd-collection ] dip find-one objects>> first @@ -218,11 +233,14 @@ M: mdb-cursor get-more ( mdb-cursor -- mdb-cursor objects ) cmd-collection H{ { "getlasterror" 1 } } find-one objects>> [ "err" ] at ; -: validate ( collection -- ) +GENERIC: validate ( collection -- ) +M: string validate [ cmd-collection ] dip "validate" H{ } clone [ set-at ] keep find-one objects>> first [ check-ok ] keep '[ "result" _ at print ] when ; +M: mdb-collection validate + name>> validate ; -: save ( collection object -- ) +GENERIC: save ( collection assoc -- ) +M: assoc save [ ensure-collection ] dip send-message-check-error ; -: save-unsafe ( collection object -- ) +GENERIC: save-unsafe ( collection object -- ) +M: assoc save-unsafe [ ensure-collection ] dip send-message ; -: ensure-index ( collection name spec -- ) +GENERIC: ensure-index ( collection name spec -- ) +M: assoc ensure-index H{ } clone [ [ "key" ] dip set-at ] keep [ [ "name" ] dip set-at ] keep @@ -254,19 +275,23 @@ PRIVATE> [ cmd-collection ] dip find-one objects>> first check-ok [ "could not drop index" throw ] unless ; -: update ( collection selector object -- ) +GENERIC: update ( collection selector object -- ) +M: assoc update [ ensure-collection ] dip send-message-check-error ; -: update-unsafe ( collection selector object -- ) +GENERIC: update-unsafe ( collection selector object -- ) +M: assoc update-unsafe [ ensure-collection ] dip send-message ; -: delete ( collection selector -- ) +GENERIC: delete ( collection selector -- ) +M: assoc delete [ ensure-collection ] dip send-message-check-error ; -: delete-unsafe ( collection selector -- ) +GENERIC: delete-unsafe ( collection selector -- ) +M: assoc delete-unsafe [ ensure-collection ] dip send-message ; From 208620336f58d93c3e5fbf00e565c4db9f7e9564 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Wed, 4 Mar 2009 06:59:40 +0100 Subject: [PATCH 035/101] added a short example to README.txt --- README.txt | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/README.txt b/README.txt index bb91f56c33..467e8581fc 100644 --- a/README.txt +++ b/README.txt @@ -1,2 +1,27 @@ This is the attempt to implement a driver for MongoDB (http://www.mongodb.org) in Factor (http://www.factorcode.org). + +Usage example (for a quick overview): + +USE: mongodb.driver + +! 1. initialize mdb +! database host port +"db" "127.0.0.1" 27017 + +! 2. create an index +! [ collection name spec ensure-index ] with-db +dup [ "test" "idIdx" H{ { "_id" 1 } } ensure-index ] with-db + +! 3. insert an object +! [ collection object save ] with-db +dup [ "test" H{ { "_id" "12345" } { "name" "myobject" } } save ] with-db + +! 4. find the object +! [ collection example ..options.. find ] with-db +dup [ "test" H{ { "_id" "12345" } } find ] with-db + +! a find with options would look like this + +dup [ "test" H{ { "name" "myobject" } } 10 limit + [ "_id" asc "name" desc ] sort find ] with-db From 87f0eeb282e8fcaa9262d610bc34944586461c1e Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 5 Mar 2009 07:01:12 +0100 Subject: [PATCH 036/101] fixed bug in bson.writer which caused any field name "_id" to be written twice, fixed lasterror in mongodb.driver --- bson/writer/writer.factor | 10 ++++++---- mongodb/driver/driver.factor | 5 +++-- mongodb/mmm/mmm.factor | 4 ++-- 3 files changed, 11 insertions(+), 8 deletions(-) diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 3859f314e2..db452f4029 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -3,7 +3,7 @@ USING: accessors assocs bson.constants byte-arrays fry io io.binary io.encodings.binary io.encodings.string io.encodings.utf8 io.streams.byte-array kernel math math.parser quotations sequences -serialize strings words ; +serialize strings words tools.hexdump ; IN: bson.writer @@ -99,11 +99,13 @@ M: sequence bson-write ( array -- ) [ [ MDB_OID_FIELD ] dip write-pair ] [ drop ] if ; inline : skip-field? ( name -- boolean ) - { MDB_OID_FIELD MDB_INTERNAL_FIELD } member? ; inline + { "_id" "_mdb" } member? ; inline M: assoc bson-write ( assoc -- ) - '[ _ [ write-oid ] [ [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each ] bi ] - binary swap with-byte-writer + [ binary ] dip + '[ _ [ write-oid ] keep + [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each + ] with-byte-writer [ length 5 + bson-write ] keep write write-eoo ; diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index d8e90052d0..ee899522cc 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -1,6 +1,6 @@ USING: accessors assocs fry io.sockets kernel math mongodb.msg formatting linked-assocs destructors continuations mongodb.operations namespaces sequences splitting math.parser io.encodings.binary combinators io.streams.duplex -arrays io memoize constructors sets strings ; +arrays io memoize constructors sets strings uuid ; IN: mongodb.driver @@ -231,7 +231,7 @@ M: assoc count : lasterror ( -- error ) cmd-collection H{ { "getlasterror" 1 } } - find-one objects>> [ "err" ] at ; + find-one objects>> first [ "err" ] dip at ; GENERIC: validate ( collection -- ) M: string validate @@ -262,6 +262,7 @@ M: assoc save-unsafe GENERIC: ensure-index ( collection name spec -- ) M: assoc ensure-index H{ } clone + [ [ uuid1 "_id" ] dip set-at ] keep [ [ "key" ] dip set-at ] keep [ [ "name" ] dip set-at ] keep [ [ index-ns "ns" ] dip set-at ] keep diff --git a/mongodb/mmm/mmm.factor b/mongodb/mmm/mmm.factor index ce942ce67b..467070859e 100644 --- a/mongodb/mmm/mmm.factor +++ b/mongodb/mmm/mmm.factor @@ -1,7 +1,7 @@ USING: accessors fry io io.encodings.binary io.servers.connection io.sockets io.streams.byte-array kernel math mongodb.msg classes formatting -mongodb.msg.private namespaces prettyprint tools.walker calendar calendar.format -json.writer ; +namespaces prettyprint tools.walker calendar calendar.format +json.writer mongodb.operations.private mongodb.operations ; IN: mongodb.mmm From fbae728a2ee771dbcd3694b808fa2f46d71a705a Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 6 Mar 2009 14:37:11 +0100 Subject: [PATCH 037/101] added support (write/read) for timestamps --- bson/reader/reader.factor | 6 +++++- bson/writer/writer.factor | 6 +++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index 44eadef973..ca2d5a5bb3 100644 --- a/bson/reader/reader.factor +++ b/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 ; +sequences serialize arrays calendar ; IN: bson.reader @@ -168,6 +168,10 @@ M: bson-boolean element-data-read ( type -- boolean ) drop read-byte t = ; +M: bson-date element-data-read ( type -- timestamp ) + drop + read-longlong millis>timestamp ; + M: bson-binary element-data-read ( type -- binary ) drop read-int32 read-byte element-binary-read ; diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index db452f4029..6db25b7d1c 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -3,7 +3,7 @@ USING: accessors assocs bson.constants byte-arrays fry io io.binary io.encodings.binary io.encodings.string io.encodings.utf8 io.streams.byte-array kernel math math.parser quotations sequences -serialize strings words tools.hexdump ; +serialize strings words calendar ; IN: bson.writer @@ -24,6 +24,7 @@ M: sequence bson-type? ( seq -- type ) drop T_Array ; M: string bson-type? ( string -- type ) drop T_String ; M: integer bson-type? ( integer -- type ) drop T_Integer ; M: assoc bson-type? ( assoc -- type ) drop T_Object ; +M: timestamp bson-type? ( timestamp -- type ) drop T_Date ; M: oid bson-type? ( word -- type ) drop T_OID ; M: objid bson-type? ( objid -- type ) drop T_Binary ; @@ -59,6 +60,9 @@ M: integer bson-write ( num -- ) M: real bson-write ( num -- ) >float write-double ; +M: timestamp bson-write ( timestamp -- ) + timestamp>millis write-longlong ; + M: byte-array bson-write ( binary -- ) [ length write-int32 ] keep T_Binary_Bytes write-byte From cdb2e6e565f1019e0092b522674c9daa05c87b37 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 6 Mar 2009 22:56:02 +0100 Subject: [PATCH 038/101] added doc skeletons --- bson/reader/reader-docs.factor | 17 ++ bson/writer/writer-docs.factor | 23 ++ mongodb/driver/driver-docs.factor | 306 ++++++++++++++++++++++ mongodb/operations/operations-docs.factor | 23 ++ 4 files changed, 369 insertions(+) create mode 100644 bson/reader/reader-docs.factor create mode 100644 bson/writer/writer-docs.factor create mode 100644 mongodb/driver/driver-docs.factor create mode 100644 mongodb/operations/operations-docs.factor diff --git a/bson/reader/reader-docs.factor b/bson/reader/reader-docs.factor new file mode 100644 index 0000000000..be300f4be6 --- /dev/null +++ b/bson/reader/reader-docs.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2009 Your name. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs help.markup help.syntax kernel ; +IN: bson.reader + +HELP: stream>assoc +{ $values + { "exemplar" null } + { "assoc" assoc } { "bytes-read" null } +} +{ $description "" } ; + +ARTICLE: "bson.reader" "bson.reader" +{ $vocab-link "bson.reader" } +; + +ABOUT: "bson.reader" diff --git a/bson/writer/writer-docs.factor b/bson/writer/writer-docs.factor new file mode 100644 index 0000000000..cbcf1d2659 --- /dev/null +++ b/bson/writer/writer-docs.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2009 Your name. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs help.markup help.syntax kernel ; +IN: bson.writer + +HELP: assoc>array +{ $values + { "assoc" assoc } + { "byte-array" null } +} +{ $description "" } ; + +HELP: assoc>stream +{ $values + { "assoc" assoc } +} +{ $description "" } ; + +ARTICLE: "bson.writer" "bson.writer" +{ $vocab-link "bson.writer" } +; + +ABOUT: "bson.writer" diff --git a/mongodb/driver/driver-docs.factor b/mongodb/driver/driver-docs.factor new file mode 100644 index 0000000000..d06bbe4ed4 --- /dev/null +++ b/mongodb/driver/driver-docs.factor @@ -0,0 +1,306 @@ +! Copyright (C) 2009 Your name. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs help.markup help.syntax kernel quotations ; +IN: mongodb.driver + +HELP: +{ $values + { "name" null } + { "collection" null } +} +{ $description "" } ; + +HELP: +{ $values + { "id" null } { "collection" null } { "return#" null } + { "cursor" null } +} +{ $description "" } ; + +HELP: +{ $values + { "db" null } { "host" null } { "port" null } + { "mdb" null } +} +{ $description "" } ; + +HELP: +{ $values + { "collection" "the collection to be queried" } { "query" "query" } + { "mdb-query" "mdb-query-msg tuple instance" } +} +{ $description "create a new query instance" } ; + +HELP: DIRTY? +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: MDB-GENERAL-ERROR +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: PARTIAL? +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: asc +{ $values + { "key" null } + { "spec" null } +} +{ $description "" } ; + +HELP: boolean +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: count +{ $values + { "collection" null } { "query" null } + { "result" null } +} +{ $description "" } ; + +HELP: create-collection +{ $values + { "name" null } +} +{ $description "" } ; + +HELP: delete +{ $values + { "collection" null } { "selector" null } +} +{ $description "" } ; + +HELP: delete-unsafe +{ $values + { "collection" null } { "selector" null } +} +{ $description "" } ; + +HELP: desc +{ $values + { "key" null } + { "spec" null } +} +{ $description "" } ; + +HELP: drop-collection +{ $values + { "name" null } +} +{ $description "" } ; + +HELP: drop-index +{ $values + { "collection" null } { "name" null } +} +{ $description "" } ; + +HELP: ensure-collection +{ $values + { "collection" null } + { "fq-collection" null } +} +{ $description "" } ; + +HELP: ensure-index +{ $values + { "collection" null } { "name" null } { "spec" null } +} +{ $description "" } ; + +HELP: explain +{ $values + { "mdb-query" null } + { "result" null } +} +{ $description "" } ; + +HELP: find +{ $values + { "mdb-query" null } + { "cursor" null } { "result" null } +} +{ $description "" } ; + +HELP: find-one +{ $values + { "mdb-query" null } + { "result" null } +} +{ $description "" } ; + +HELP: get-more +{ $values + { "mdb-cursor" null } + { "mdb-cursor" null } { "objects" null } +} +{ $description "" } ; + +HELP: hint +{ $values + { "mdb-query" null } { "index-hint" null } + { "mdb-query" null } +} +{ $description "" } ; + +HELP: lasterror +{ $values + + { "error" null } +} +{ $description "" } ; + +HELP: limit +{ $values + { "mdb-query" null } { "limit#" null } + { "mdb-query" null } +} +{ $description "" } ; + +HELP: load-collection-list +{ $values + + { "collection-list" null } +} +{ $description "" } ; + +HELP: load-index-list +{ $values + + { "index-list" null } +} +{ $description "" } ; + +HELP: master>> +{ $values + { "mdb" null } + { "inet" null } +} +{ $description "" } ; + +HELP: mdb +{ $values + + { "mdb" null } +} +{ $description "" } ; + +HELP: mdb-collection +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: mdb-cursor +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: mdb-db +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: mdb-error +{ $values + { "id" null } { "msg" null } +} +{ $description "" } ; + +HELP: mdb-instance +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: mdb-node +{ $values + + { "value" null } +} +{ $description "" } ; + +HELP: save +{ $values + { "collection" null } { "assoc" assoc } +} +{ $description "" } ; + +HELP: save-unsafe +{ $values + { "collection" null } { "object" object } +} +{ $description "" } ; + +HELP: skip +{ $values + { "mdb-query" null } { "skip#" null } + { "mdb-query" null } +} +{ $description "" } ; + +HELP: slave>> +{ $values + { "mdb" null } + { "inet" null } +} +{ $description "" } ; + +HELP: sort +{ $values + { "mdb-query" null } { "quot" quotation } + { "mdb-query" null } +} +{ $description "" } ; + +HELP: update +{ $values + { "collection" null } { "selector" null } { "object" object } +} +{ $description "" } ; + +HELP: update-unsafe +{ $values + { "collection" null } { "selector" null } { "object" object } +} +{ $description "" } ; + +HELP: validate +{ $values + { "collection" null } +} +{ $description "" } ; + +HELP: with-db +{ $values + { "mdb" null } { "quot" quotation } + { "..." null } +} +{ $description "" } ; + +ARTICLE: "mongodb.driver" "mongodb.driver" +{ $vocab-link "mongodb.driver" } +; + +ABOUT: "mongodb.driver" diff --git a/mongodb/operations/operations-docs.factor b/mongodb/operations/operations-docs.factor new file mode 100644 index 0000000000..c6d00db1e8 --- /dev/null +++ b/mongodb/operations/operations-docs.factor @@ -0,0 +1,23 @@ +! Copyright (C) 2009 Your name. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel ; +IN: mongodb.operations + +HELP: read-message +{ $values + + { "message" null } +} +{ $description "" } ; + +HELP: write-message +{ $values + { "message" null } +} +{ $description "" } ; + +ARTICLE: "mongodb.operations" "mongodb.operations" +{ $vocab-link "mongodb.operations" } +; + +ABOUT: "mongodb.operations" From f56df9e96547e7f5ce086bafee384d957abcb636 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 6 Mar 2009 22:56:24 +0100 Subject: [PATCH 039/101] added benchmark vocab - @see http://www.mongodb.org/display/DOCS/Performance+Testing --- mongodb/benchmark/benchmark.factor | 192 +++++++++++++++++++++++++++++ 1 file changed, 192 insertions(+) create mode 100644 mongodb/benchmark/benchmark.factor diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor new file mode 100644 index 0000000000..39b6995034 --- /dev/null +++ b/mongodb/benchmark/benchmark.factor @@ -0,0 +1,192 @@ +USING: mongodb.driver calendar math fry kernel assocs math.ranges +sequences formatting combinators namespaces io tools.time prettyprint +accessors words ; + +IN: mongodb.benchmark + +SYMBOLS: per-trial batch-size collection host db port ; + +: get* ( symbol default -- value ) + [ get ] dip or ; inline + +TUPLE: result doc index batch lasterror ; + +: ( -- ) result new result set ; inline + +CONSTANT: DOC-SMALL H{ } + +CONSTANT: DOC-MEDIUM H{ { "integer" 5 } + { "number" 5.05 } + { "boolean" f } + { "array" + { "test" "benchmark" } } } + +CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } + { "total_word_count" 6743 } + { "access_time" f } + { "meta_tags" H{ { "description" "i am a long description string" } + { "author" "Holly Man" } + { "dynamically_created_meta_tag" "who know\n what" } } } + { "page_structure" H{ { "counted_tags" 3450 } + { "no_of_js_attached" 10 } + { "no_of_images" 6 } } } + { "harvested_words" { "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" + "10gen" "web" "open" "source" "application" "paas" + "platform-as-a-service" "technology" "helps" + "developers" "focus" "building" "mongodb" "mongo" } } } + +: small-doc ( -- quot: ( i -- doc ) ) + result [ "small" >>doc ] change + DOC-SMALL clone + '[ "x" _ [ set-at ] keep ] ; inline + +: medium-doc ( -- quot: ( i -- doc ) ) + result [ "medium" >>doc ] change + DOC-MEDIUM clone + '[ "x" _ [ set-at ] keep ] ; inline + +: large-doc ( -- quot: ( i -- doc ) ) + result [ "large" >>doc ] change + DOC-LARGE clone + '[ "x" _ [ set-at ] keep + [ now "access-time" ] dip + [ set-at ] keep ] ; + +: (insert) ( quot: ( i -- doc ) collection -- ) + [ per-trial get ] 2dip + '[ _ call [ _ ] dip + result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ; inline + +: (prepare-batch) ( i b quot: ( i -- doc ) -- ) + [ [ * ] keep 1 range boa ] dip + '[ _ call ] map ; inline + +: (insert-batch) ( quot: ( i -- doc ) collection -- ) + [ per-trial get batch-size get [ / ] keep ] 2dip + '[ _ _ (prepare-batch) [ _ ] dip + result get lasterror>> [ save ] [ save-unsafe ] if + ] each-integer ; inline + +: prepare-collection ( -- collection ) + collection "benchmark" get* + [ "_x_idx" drop-index ] keep + [ drop-collection ] keep + [ create-collection ] keep ; inline + +: prepare-index ( collection -- ) + "_x_idx" H{ { "x" 1 } } ensure-index ; inline + +: insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) + prepare-collection + result get index>> [ [ prepare-index ] keep ] when + result get batch>> + [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ; + +: batch ( -- ) + result [ t >>batch ] change ; inline + +: index ( -- ) + result [ t >>index ] change ; inline + +: errcheck ( -- ) + result [ t >>lasterror ] change ; inline + +: bchar ( boolean -- char ) + [ "t" ] [ "f" ] if ; inline + +: print-result ( time -- ) + [ result get [ doc>> ] keep + [ batch>> bchar ] keep + [ index>> bchar ] keep + lasterror>> bchar + per-trial get ] dip + 1000000 / /i + "%-6s: {batch:%s,index:%s;errchk:%s} %7s op/s" + sprintf print flush ; inline + +: print-separator ( -- ) + "-----------------------------------------------" print flush ; inline + +: print-header ( -- ) + per-trial get + batch-size get + "MongoDB Factor Driver Benchmark\n%d ops per Trial, Batch-Size: %d\n" + sprintf print flush + print-separator ; + +: with-result ( quot: ( -- ) -- ) + [ ] prepose + [ print-result ] compose with-scope ; inline + +: run-insert-bench ( doc-word-seq feat-seq -- ) + '[ _ swap + '[ [ [ _ execute ] dip + [ execute ] each insert benchmark ] with-result ] each + print-separator ] each ; + +: run-benchmarks ( -- ) + db "db" get* host "127.0.0.1" get* port 27020 get* + [ + print-header + { small-doc medium-doc large-doc } + { { } { errcheck } { batch } { batch errcheck } + { index } { index errcheck } { batch index errcheck } } run-insert-bench + ] with-db ; + + From ca2459f7291ea5275456ca5af49de2709e8a83d6 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 7 Mar 2009 13:54:53 +0100 Subject: [PATCH 040/101] made some performance improvements by using a shared byte-vector buffer for serialization --- bson/writer/writer-docs.factor | 2 +- bson/writer/writer.factor | 67 ++++++++---- mongodb/benchmark/benchmark.factor | 151 ++++++++++++++++++++------- mongodb/driver/driver.factor | 4 +- mongodb/operations/operations.factor | 28 ++--- 5 files changed, 181 insertions(+), 71 deletions(-) diff --git a/bson/writer/writer-docs.factor b/bson/writer/writer-docs.factor index cbcf1d2659..a4b393b5d9 100644 --- a/bson/writer/writer-docs.factor +++ b/bson/writer/writer-docs.factor @@ -3,7 +3,7 @@ USING: assocs help.markup help.syntax kernel ; IN: bson.writer -HELP: assoc>array +HELP: assoc>bv { $values { "assoc" assoc } { "byte-array" null } diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 6db25b7d1c..299b6faee7 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -1,17 +1,51 @@ ! Copyright (C) 2008 Sascha Matzke. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs bson.constants byte-arrays fry io io.binary +USING: accessors assocs bson.constants +byte-arrays byte-vectors calendar fry io io.binary io.encodings io.encodings.binary io.encodings.string io.encodings.utf8 -io.streams.byte-array kernel math math.parser quotations sequences -serialize strings words calendar ; +io.streams.byte-array kernel math math.parser namespaces +quotations sequences serialize strings words ; + IN: bson.writer -#! Writes the object out to a stream in BSON format +#! Writes the object out to a byte-vector in BSON format [ shared-buffer set ] keep ] unless* ; inline + +PRIVATE> + +: ensure-buffer ( -- ) + (buffer) drop ; + +: reset-buffer ( -- ) + (buffer) 0 >>length drop ; + +: with-buffer ( quot -- byte-vector ) + [ (buffer) ] dip [ output-stream get ] compose + with-output-stream* dup encoder? [ stream>> ] when ; inline + +: with-length ( quot: ( -- ) -- bytes-written start-index ) + [ (buffer) [ length ] keep ] dip call + length swap [ - ] keep ; inline + +: with-length-prefix ( quot: ( -- ) -- ) + [ B{ 0 0 0 0 } write ] prepose with-length + [ INT32-SIZE >le ] dip (buffer) + '[ _ over [ nth ] dip _ + _ set-nth ] + [ INT32-SIZE ] dip each-integer ; inline + +string write-cstring bson-write ] - each-index ] - binary swap with-byte-writer - [ length 5 + bson-write ] keep - write - write-eoo ; + '[ _ [ [ write-type ] dip number>string + write-cstring bson-write ] each-index + write-eoo + ] with-length-prefix ; : write-oid ( assoc -- ) [ MDB_OID_FIELD ] dip at* @@ -106,20 +137,16 @@ M: sequence bson-write ( array -- ) { "_id" "_mdb" } member? ; inline M: assoc bson-write ( assoc -- ) - [ binary ] dip '[ _ [ write-oid ] keep [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each - ] with-byte-writer - [ length 5 + bson-write ] keep - write - write-eoo ; + write-eoo ] with-length-prefix ; M: word bson-write name>> bson-write ; PRIVATE> - -: assoc>array ( assoc -- byte-array ) - '[ _ bson-write ] binary swap with-byte-writer ; inline + +: assoc>bv ( assoc -- byte-vector ) + [ '[ _ bson-write ] with-buffer ] with-scope ; inline : assoc>stream ( assoc -- ) bson-write ; inline diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index 39b6995034..757d7864a3 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -1,15 +1,21 @@ -USING: mongodb.driver calendar math fry kernel assocs math.ranges +USING: calendar math fry kernel assocs math.ranges sequences formatting combinators namespaces io tools.time prettyprint -accessors words ; +accessors words mongodb.driver ; IN: mongodb.benchmark -SYMBOLS: per-trial batch-size collection host db port ; +SYMBOLS: per-trial collection host db port ; : get* ( symbol default -- value ) [ get ] dip or ; inline -TUPLE: result doc index batch lasterror ; +: trial-size ( -- size ) + per-trial 10000 get* ; inline flushable + +: batch-size ( -- size ) + \ batch-size 100 get* ; inline flushable + +TUPLE: result doc collection index batch lasterror ; : ( -- ) result new result set ; inline @@ -91,25 +97,34 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } "platform-as-a-service" "technology" "helps" "developers" "focus" "building" "mongodb" "mongo" } } } -: small-doc ( -- quot: ( i -- doc ) ) - result [ "small" >>doc ] change - DOC-SMALL clone - '[ "x" _ [ set-at ] keep ] ; inline +: set-doc ( name -- ) + [ result ] dip '[ _ >>doc ] change ; inline -: medium-doc ( -- quot: ( i -- doc ) ) - result [ "medium" >>doc ] change - DOC-MEDIUM clone - '[ "x" _ [ set-at ] keep ] ; inline +: small-doc ( -- ) + "small" set-doc ; inline -: large-doc ( -- quot: ( i -- doc ) ) - result [ "large" >>doc ] change - DOC-LARGE clone - '[ "x" _ [ set-at ] keep +: medium-doc ( -- ) + "medium" set-doc ; inline + +: large-doc ( -- ) + "large" set-doc ; inline + +: small-doc-prepare ( -- quot: ( i -- doc ) ) + small-doc + '[ "x" DOC-SMALL clone [ set-at ] keep ] ; inline + +: medium-doc-prepare ( -- quot: ( i -- doc ) ) + medium-doc + '[ "x" DOC-MEDIUM clone [ set-at ] keep ] ; inline + +: large-doc-prepare ( -- quot: ( i -- doc ) ) + large-doc + [ "x" DOC-LARGE clone [ set-at ] keep [ now "access-time" ] dip [ set-at ] keep ] ; : (insert) ( quot: ( i -- doc ) collection -- ) - [ per-trial get ] 2dip + [ trial-size ] 2dip '[ _ call [ _ ] dip result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ; inline @@ -118,13 +133,23 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } '[ _ call ] map ; inline : (insert-batch) ( quot: ( i -- doc ) collection -- ) - [ per-trial get batch-size get [ / ] keep ] 2dip + [ trial-size batch-size [ / ] keep ] 2dip '[ _ _ (prepare-batch) [ _ ] dip result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ; inline -: prepare-collection ( -- collection ) +: bchar ( boolean -- char ) + [ "t" ] [ "f" ] if ; inline + +: collection-name ( -- collection ) collection "benchmark" get* + result get doc>> + result get index>> bchar + "%s-%s-%s" sprintf + [ [ result get ] dip >>collection drop ] keep ; inline + +: prepare-collection ( -- collection ) + collection-name [ "_x_idx" drop-index ] keep [ drop-collection ] keep [ create-collection ] keep ; inline @@ -138,6 +163,26 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } result get batch>> [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ; +: check-for-key ( assoc key -- ) + swap key? [ "ups... where's the key" throw ] unless ; inline + +: find-one ( -- quot: ( -- ) ) + collection-name + trial-size 2 / "x" H{ } clone [ set-at ] keep + '[ _ _ 1 limit find [ drop ] dip first "x" check-for-key ] ; + +: find-all ( -- quot: ( -- ) ) + collection-name + H{ } clone + '[ _ _ find [ "x" check-for-key ] each drop ] ; + +: find-range ( -- quot: ( -- ) ) + collection-name + trial-size 2 / "$gt" H{ } clone [ set-at ] keep + [ trial-size 2 / batch-size + "$lt" ] dip [ set-at ] keep + "x" H{ } clone [ set-at ] keep + '[ _ _ find [ "x" check-for-key ] each drop ] ; + : batch ( -- ) result [ t >>batch ] change ; inline @@ -147,46 +192,80 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : errcheck ( -- ) result [ t >>lasterror ] change ; inline -: bchar ( boolean -- char ) - [ "t" ] [ "f" ] if ; inline - : print-result ( time -- ) - [ result get [ doc>> ] keep + [ result get [ collection>> ] keep [ batch>> bchar ] keep [ index>> bchar ] keep lasterror>> bchar - per-trial get ] dip + trial-size ] dip 1000000 / /i - "%-6s: {batch:%s,index:%s;errchk:%s} %7s op/s" + "%-18s: {batch:%s,index:%s;errchk:%s} %10s op/s" sprintf print flush ; inline : print-separator ( -- ) - "-----------------------------------------------" print flush ; inline + "--------------------------------------------------------------" print flush ; inline + +: print-separator-bold ( -- ) + "==============================================================" print flush ; inline : print-header ( -- ) - per-trial get - batch-size get - "MongoDB Factor Driver Benchmark\n%d ops per Trial, Batch-Size: %d\n" + trial-size + batch-size + "MongoDB Factor Driver Benchmark\n%d ops per Trial, Batch-Size: %d" sprintf print flush - print-separator ; + print-separator-bold ; : with-result ( quot: ( -- ) -- ) [ ] prepose [ print-result ] compose with-scope ; inline -: run-insert-bench ( doc-word-seq feat-seq -- ) - '[ _ swap +: bench-quot ( feat-seq op-word -- quot: ( elt -- ) ) + '[ _ swap _ '[ [ [ _ execute ] dip - [ execute ] each insert benchmark ] with-result ] each - print-separator ] each ; + [ execute ] each _ execute benchmark ] with-result ] each + print-separator ] ; + +: run-insert-bench ( doc-word-seq feat-seq -- ) + "Insert Tests" print + print-separator-bold + \ insert bench-quot each ; + +: run-find-one-bench ( doc-word-seq feat-seq -- ) + "Query Tests - Find-One" print + print-separator-bold + \ find-one bench-quot each ; + +: run-find-all-bench ( doc-word-seq feat-seq -- ) + "Query Tests - Find-All" print + print-separator-bold + \ find-all bench-quot each ; + +: run-find-range-bench ( doc-word-seq feat-seq -- ) + "Query Tests - Find-Range" print + print-separator-bold + \ find-range bench-quot each ; + : run-benchmarks ( -- ) db "db" get* host "127.0.0.1" get* port 27020 get* [ print-header + ! insert + { small-doc-prepare medium-doc-prepare large-doc-prepare } + { { } { index } { errcheck } { index errcheck } + { batch } { batch errcheck } + { batch index errcheck } } + run-insert-bench + ! find-one { small-doc medium-doc large-doc } - { { } { errcheck } { batch } { batch errcheck } - { index } { index errcheck } { batch index errcheck } } run-insert-bench + { { } { index } } run-find-one-bench + ! find-all + { small-doc medium-doc large-doc } + { { } { index } } run-find-all-bench + ! find-range + { small-doc medium-doc large-doc } + { { } { index } } run-find-range-bench + ] with-db ; diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index ee899522cc..118a503213 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -1,6 +1,6 @@ USING: accessors assocs fry io.sockets kernel math mongodb.msg formatting linked-assocs destructors continuations mongodb.operations namespaces sequences splitting math.parser io.encodings.binary combinators io.streams.duplex -arrays io memoize constructors sets strings uuid ; +arrays io memoize constructors sets strings uuid bson.writer ; IN: mongodb.driver @@ -52,7 +52,7 @@ SYMBOL: mdb-instance nodes>> [ f ] dip at inet>> ; : with-db ( mdb quot -- ... ) - [ [ '[ _ [ mdb-instance set ] keep master>> + [ [ '[ _ [ mdb-instance set ensure-buffer ] keep master>> [ remote-address set ] keep binary local-address set diff --git a/mongodb/operations/operations.factor b/mongodb/operations/operations.factor index 75207cf30b..cc496b81c6 100644 --- a/mongodb/operations/operations.factor +++ b/mongodb/operations/operations.factor @@ -3,6 +3,10 @@ io io.binary io.encodings.binary io.encodings.string io.encodings.utf8 io.streams.byte-array kernel math mongodb.msg namespaces sequences locals assocs combinators linked-assocs ; +IN: alien.c-types + +M: byte-vector byte-length length ; + IN: mongodb.operations >opcode read-int32 >>flags ; inline -: write-header ( message length -- ) - MSG-HEADER-SIZE + write-int32 +: write-header ( message -- ) [ req-id>> write-int32 ] keep [ resp-id>> write-int32 ] keep opcode>> write-int32 ; inline @@ -145,10 +148,11 @@ PRIVATE> [ query>> "query" selector set-at ] } cleave selector - ] ; + ] ; inline flushable PRIVATE> @@ -169,8 +173,8 @@ M: mdb-query-msg write-message ( message -- ) [ collection>> write-cstring ] keep [ skip#>> write-int32 ] keep [ return#>> write-int32 ] keep - [ build-query-object assoc>array write ] keep - returnfields>> [ assoc>array write ] when* + [ build-query-object assoc>stream ] keep + returnfields>> [ assoc>stream ] when* ] (write-message) ; M: mdb-insert-msg write-message ( message -- ) @@ -178,7 +182,7 @@ M: mdb-insert-msg write-message ( message -- ) '[ _ [ flags>> write-int32 ] keep [ collection>> write-cstring ] keep - objects>> [ assoc>array write ] each + objects>> [ assoc>stream ] each ] (write-message) ; M: mdb-update-msg write-message ( message -- ) @@ -187,8 +191,8 @@ M: mdb-update-msg write-message ( message -- ) [ flags>> write-int32 ] keep [ collection>> write-cstring ] keep [ upsert?>> write-int32 ] keep - [ selector>> assoc>array write ] keep - object>> assoc>array write + [ selector>> assoc>stream ] keep + object>> assoc>stream ] (write-message) ; M: mdb-delete-msg write-message ( message -- ) @@ -197,7 +201,7 @@ M: mdb-delete-msg write-message ( message -- ) [ flags>> write-int32 ] keep [ collection>> write-cstring ] keep 0 write-int32 - selector>> assoc>array write + selector>> assoc>stream ] (write-message) ; M: mdb-getmore-msg write-message ( message -- ) From aaf887ab1d4417921be26a9e4f58dccfde5b1ba5 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 7 Mar 2009 14:06:53 +0100 Subject: [PATCH 041/101] added stack effect to quot argument to with-db made key check in query benchmarks optional --- mongodb/benchmark/benchmark.factor | 4 +++- mongodb/driver/driver.factor | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index 757d7864a3..17ea69f5e3 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -19,6 +19,8 @@ TUPLE: result doc collection index batch lasterror ; : ( -- ) result new result set ; inline +CONSTANT: CHECK-KEY f + CONSTANT: DOC-SMALL H{ } CONSTANT: DOC-MEDIUM H{ { "integer" 5 } @@ -164,7 +166,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ; : check-for-key ( assoc key -- ) - swap key? [ "ups... where's the key" throw ] unless ; inline + CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ; inline : find-one ( -- quot: ( -- ) ) collection-name diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 118a503213..38199bedaf 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -51,7 +51,7 @@ SYMBOL: mdb-instance : slave>> ( mdb -- inet ) nodes>> [ f ] dip at inet>> ; -: with-db ( mdb quot -- ... ) +: with-db ( mdb quot: ( -- * ) -- * ) [ [ '[ _ [ mdb-instance set ensure-buffer ] keep master>> [ remote-address set ] keep binary From 4b7c4a3564bf63e306cc5d7c5f26d0d5011a23f2 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 7 Mar 2009 14:24:38 +0100 Subject: [PATCH 042/101] made variables strings so that they can be set from the commandline --- mongodb/benchmark/benchmark.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index 17ea69f5e3..d5f7efe052 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -1,19 +1,19 @@ USING: calendar math fry kernel assocs math.ranges sequences formatting combinators namespaces io tools.time prettyprint -accessors words mongodb.driver ; +accessors words mongodb.driver strings math.parser ; IN: mongodb.benchmark -SYMBOLS: per-trial collection host db port ; +SYMBOL: collection : get* ( symbol default -- value ) [ get ] dip or ; inline : trial-size ( -- size ) - per-trial 10000 get* ; inline flushable + "per-trial" 10000 get* ; inline flushable : batch-size ( -- size ) - \ batch-size 100 get* ; inline flushable + "batch-size" 100 get* ; inline flushable TUPLE: result doc collection index batch lasterror ; @@ -249,7 +249,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : run-benchmarks ( -- ) - db "db" get* host "127.0.0.1" get* port 27020 get* + "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* dup string? [ string>number ] when [ print-header ! insert @@ -270,4 +270,5 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } ] with-db ; +MAIN: run-benchmarks From 26c4aae74b900fdbfe3539c2d251c4c734bfbb88 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 7 Mar 2009 14:52:28 +0100 Subject: [PATCH 043/101] fixed per-trial and batch-size variables to ensure the value is a number --- mongodb/benchmark/benchmark.factor | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index d5f7efe052..c2935231d1 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -9,16 +9,20 @@ SYMBOL: collection : get* ( symbol default -- value ) [ get ] dip or ; inline +: ensure-number ( v -- n ) + dup string? [ string>number ] when ; inline + : trial-size ( -- size ) - "per-trial" 10000 get* ; inline flushable + "per-trial" 10000 get* ensure-number ; inline flushable : batch-size ( -- size ) - "batch-size" 100 get* ; inline flushable + "batch-size" 100 get* ensure-number ; inline flushable TUPLE: result doc collection index batch lasterror ; : ( -- ) result new result set ; inline + CONSTANT: CHECK-KEY f CONSTANT: DOC-SMALL H{ } @@ -249,7 +253,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : run-benchmarks ( -- ) - "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* dup string? [ string>number ] when + "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number [ print-header ! insert From a041fb06dc23528f7195b3716dd982c555bf89d6 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 7 Mar 2009 19:08:40 +0100 Subject: [PATCH 044/101] added some more inlines to make words infer --- mongodb/benchmark/benchmark.factor | 10 +++++----- mongodb/driver/driver.factor | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index c2935231d1..4f7fc644d6 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -229,27 +229,27 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } '[ _ swap _ '[ [ [ _ execute ] dip [ execute ] each _ execute benchmark ] with-result ] each - print-separator ] ; + print-separator ] ; inline : run-insert-bench ( doc-word-seq feat-seq -- ) "Insert Tests" print print-separator-bold - \ insert bench-quot each ; + \ insert bench-quot each ; inline : run-find-one-bench ( doc-word-seq feat-seq -- ) "Query Tests - Find-One" print print-separator-bold - \ find-one bench-quot each ; + \ find-one bench-quot each ; inline : run-find-all-bench ( doc-word-seq feat-seq -- ) "Query Tests - Find-All" print print-separator-bold - \ find-all bench-quot each ; + \ find-all bench-quot each ; inline : run-find-range-bench ( doc-word-seq feat-seq -- ) "Query Tests - Find-Range" print print-separator-bold - \ find-range bench-quot each ; + \ find-range bench-quot each ; inline : run-benchmarks ( -- ) diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 38199bedaf..cf0bf8ac06 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -58,7 +58,7 @@ SYMBOL: mdb-instance local-address set mdb-socket-stream set ] ] dip compose [ mdb-stream>> [ dispose ] when* ] [ ] cleanup - ] with-scope ; + ] with-scope ; inline Date: Mon, 9 Mar 2009 22:58:19 +0100 Subject: [PATCH 045/101] some formatting --- mongodb/driver/driver.factor | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index cf0bf8ac06..f1dc204d1c 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -52,13 +52,12 @@ SYMBOL: mdb-instance nodes>> [ f ] dip at inet>> ; : with-db ( mdb quot: ( -- * ) -- * ) - [ [ '[ _ [ mdb-instance set ensure-buffer ] keep master>> - [ remote-address set ] keep - binary - local-address set + [ [ '[ ensure-buffer _ [ mdb-instance set ] keep + master>> [ remote-address set ] keep + binary local-address set mdb-socket-stream set ] ] dip compose - [ mdb-stream>> [ dispose ] when* ] [ ] cleanup - ] with-scope ; inline + [ mdb-stream>> [ dispose ] when* ] + [ ] cleanup ] with-scope ; inline >return# ; inline - + GENERIC# skip 1 ( mdb-query skip# -- mdb-query ) M: mdb-query-msg skip ( query skip# -- mdb-query ) >>skip# ; inline From 2a29d7fed42e2976273e0e41db40cbf62a6f825b Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Wed, 11 Mar 2009 14:40:07 +0100 Subject: [PATCH 046/101] changed find, update and get-more --- .gitignore | 1 + mongodb/driver/driver.factor | 33 ++++++++++++++++++++------------- 2 files changed, 21 insertions(+), 13 deletions(-) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000000..b25c15b81f --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +*~ diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index f1dc204d1c..53dd4ee427 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -204,18 +204,21 @@ GENERIC# hint 1 ( mdb-query index-hint -- mdb-query ) M: mdb-query-msg hint ( mdb-query index-hint -- mdb-query ) >>hint ; +GENERIC: get-more ( mdb-cursor -- mdb-cursor objects ) +M: mdb-cursor get-more ( mdb-cursor -- mdb-cursor objects ) + [ [ collection>> ] [ return#>> ] [ id>> ] tri send-query ] + [ f f ] if* ; + GENERIC: find ( mdb-query -- cursor result ) M: mdb-query-msg find - send-query ; + send-query ; +M: mdb-cursor find + get-more ; GENERIC: explain ( mdb-query -- result ) M: mdb-query-msg explain t >>explain find [ drop ] dip ; -GENERIC: get-more ( mdb-cursor -- mdb-cursor objects ) -M: mdb-cursor get-more ( mdb-cursor -- mdb-cursor objects ) - [ [ collection>> ] [ return#>> ] [ id>> ] tri send-query ] - [ f f ] if* ; GENERIC: find-one ( mdb-query -- result ) M: mdb-query-msg find-one @@ -275,15 +278,19 @@ M: assoc ensure-index [ cmd-collection ] dip find-one objects>> first check-ok [ "could not drop index" throw ] unless ; -GENERIC: update ( collection selector object -- ) -M: assoc update - [ ensure-collection ] dip - send-message-check-error ; +: ( collection selector object -- update-msg ) + [ ensure-collection ] 2dip ; -GENERIC: update-unsafe ( collection selector object -- ) -M: assoc update-unsafe - [ ensure-collection ] dip - send-message ; +: >upsert ( mdb-update-msg -- mdb-update-msg ) + 1 >>upsert? ; + +GENERIC: update ( mdb-update-msg -- ) +M: mdb-update-msg update + send-message-check-error ; + +GENERIC: update-unsafe ( mdb-update-msg -- ) +M: mdb-update-msg update-unsafe + send-message ; GENERIC: delete ( collection selector -- ) M: assoc delete From cd90702e39269aa3e03b6d4aaf658d889c517079 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Tue, 17 Mar 2009 17:50:46 +0100 Subject: [PATCH 047/101] added regexp queries --- bson/constants/constants.factor | 8 +++++++- bson/reader/reader.factor | 17 +++++++++++------ bson/writer/writer.factor | 8 ++++++-- mongodb/driver/driver.factor | 7 ++++++- 4 files changed, 30 insertions(+), 10 deletions(-) diff --git a/bson/constants/constants.factor b/bson/constants/constants.factor index be9f9466b5..0da3cc0bb5 100644 --- a/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -1,4 +1,4 @@ -USING: accessors kernel uuid ; +USING: accessors kernel math parser sequences strings uuid ; IN: bson.constants @@ -11,6 +11,12 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ; TUPLE: objref ns objid ; +TUPLE: mdbregexp { regexp string } { options string } ; + +: ( string -- mdbregexp ) + [ mdbregexp new ] dip >>regexp ; + + CONSTANT: MDB_OID_FIELD "_id" CONSTANT: MDB_INTERNAL_FIELD "_mdb_" diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index ca2d5a5bb3..f39d4a21d6 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -26,6 +26,7 @@ PREDICATE: bson-string < integer T_String = ; PREDICATE: bson-object < integer T_Object = ; PREDICATE: bson-array < integer T_Array = ; PREDICATE: bson-binary < integer T_Binary = ; +PREDICATE: bson-regexp < integer T_Regexp = ; PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ; PREDICATE: bson-binary-function < integer T_Binary_Function = ; PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ; @@ -165,17 +166,21 @@ M: bson-double element-data-read ( type -- double ) read-double ; M: bson-boolean element-data-read ( type -- boolean ) - drop - read-byte t = ; + drop + read-byte t = ; M: bson-date element-data-read ( type -- timestamp ) - drop - read-longlong millis>timestamp ; + drop + read-longlong millis>timestamp ; M: bson-binary element-data-read ( type -- binary ) - drop - read-int32 read-byte element-binary-read ; + drop + read-int32 read-byte element-binary-read ; +M: bson-regexp element-data-read ( type -- mdbregexp ) + drop mdbregexp new + read-cstring >>regexp read-cstring >>options ; + M: bson-null element-data-read ( type -- bf ) drop f ; diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 299b6faee7..086ff2af7f 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -59,6 +59,7 @@ M: string bson-type? ( string -- type ) drop T_String ; M: integer bson-type? ( integer -- type ) drop T_Integer ; M: assoc bson-type? ( assoc -- type ) drop T_Object ; M: timestamp bson-type? ( timestamp -- type ) drop T_Date ; +M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ; M: oid bson-type? ( word -- type ) drop T_OID ; M: objid bson-type? ( objid -- type ) drop T_Binary ; @@ -122,12 +123,15 @@ M: objref bson-write ( objref -- ) [ length write-int32 ] keep T_Binary_Custom write-byte write ; + +M: mdbregexp bson-write ( regexp -- ) + [ regexp>> utf8 encode write-cstring ] + [ options>> utf8 encode write-cstring ] bi ; M: sequence bson-write ( array -- ) '[ _ [ [ write-type ] dip number>string write-cstring bson-write ] each-index - write-eoo - ] with-length-prefix ; + write-eoo ] with-length-prefix ; : write-oid ( assoc -- ) [ MDB_OID_FIELD ] dip at* diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 53dd4ee427..2015ff8ecf 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -1,6 +1,6 @@ USING: accessors assocs fry io.sockets kernel math mongodb.msg formatting linked-assocs destructors continuations mongodb.operations namespaces sequences splitting math.parser io.encodings.binary combinators io.streams.duplex -arrays io memoize constructors sets strings uuid bson.writer ; +arrays io memoize constructors sets strings uuid bson.writer bson.constants parser ; IN: mongodb.driver @@ -38,8 +38,13 @@ SYMBOL: mdb-socket-stream : check-ok ( result -- ? ) [ "ok" ] dip key? ; inline +: >mdbregexp ( value -- regexp ) + first ; + PRIVATE> +: r/ \ / [ >mdbregexp ] parse-literal ; parsing + SYMBOL: mdb-instance : mdb ( -- mdb ) From 76824c3bc7de4e8cf61710db6f28f7a0808bd586 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Mon, 23 Mar 2009 08:55:07 +0100 Subject: [PATCH 048/101] changed "; parsing" to new "SYNTAX:" notation --- mongodb/driver/driver.factor | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 2015ff8ecf..93554b20bc 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -1,6 +1,8 @@ -USING: accessors assocs fry io.sockets kernel math mongodb.msg formatting linked-assocs destructors continuations -mongodb.operations namespaces sequences splitting math.parser io.encodings.binary combinators io.streams.duplex -arrays io memoize constructors sets strings uuid bson.writer bson.constants parser ; +USING: accessors assocs bson.constants bson.writer combinators +constructors continuations destructors formatting fry io +io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs +math math.parser memoize mongodb.msg mongodb.operations namespaces +parser sequences sets splitting strings uuid syntax ; IN: mongodb.driver @@ -43,7 +45,8 @@ SYMBOL: mdb-socket-stream PRIVATE> -: r/ \ / [ >mdbregexp ] parse-literal ; parsing +SYNTAX: r/ ( token -- mdbregexp ) + \ / [ >mdbregexp ] parse-literal ; SYMBOL: mdb-instance From 0378dda9b1b3a0793427f716516ab6acddeedc1d Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Mon, 23 Mar 2009 08:55:40 +0100 Subject: [PATCH 049/101] added constants for byte-lengths (INT32-SIZE, CHAR-SIZE, INT64-SIZE) --- bson/writer/writer.factor | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 086ff2af7f..22a278e1fb 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2008 Sascha Matzke. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs bson.constants -byte-arrays byte-vectors calendar fry io io.binary io.encodings -io.encodings.binary io.encodings.string io.encodings.utf8 -io.streams.byte-array kernel math math.parser namespaces -quotations sequences serialize strings words ; +USING: accessors assocs bson.constants byte-arrays byte-vectors +calendar fry io io.binary io.encodings io.encodings.string +io.encodings.utf8 kernel math math.parser namespaces quotations +sequences serialize strings tools.walker words ; IN: bson.writer @@ -16,6 +15,8 @@ IN: bson.writer SYMBOL: shared-buffer CONSTANT: INT32-SIZE 4 +CONSTANT: CHAR-SIZE 1 +CONSTANT: INT64-SIZE 8 : (buffer) ( -- buffer ) shared-buffer get @@ -24,10 +25,10 @@ CONSTANT: INT32-SIZE 4 PRIVATE> : ensure-buffer ( -- ) - (buffer) drop ; + (buffer) drop ; inline : reset-buffer ( -- ) - (buffer) 0 >>length drop ; + (buffer) 0 >>length drop ; inline : with-buffer ( quot -- byte-vector ) [ (buffer) ] dip [ output-stream get ] compose @@ -67,11 +68,11 @@ M: objref bson-type? ( objref -- type ) drop T_Binary ; M: quotation bson-type? ( quotation -- type ) drop T_Binary ; M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; -: write-byte ( byte -- ) 1 >le write ; inline -: write-int32 ( int -- ) 4 >le write ; inline -: write-double ( real -- ) double>bits 8 >le write ; 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 -- ) utf8 encode B{ 0 } append write ; inline -: write-longlong ( object -- ) 8 >le write ; 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 From b57cdefde0f53f751d84bcfc7e938e3b728dbe21 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Wed, 25 Mar 2009 18:22:28 +0100 Subject: [PATCH 050/101] added doc files optimized string write performance --- bson/reader/reader-docs.factor | 17 -- bson/writer/writer-docs.factor | 23 --- bson/writer/writer.factor | 47 ++--- mongodb/benchmark/benchmark.factor | 29 ++- mongodb/driver/driver-docs.factor | 221 ++++++++++++---------- mongodb/driver/driver.factor | 78 ++++---- mongodb/operations/operations-docs.factor | 23 --- mongodb/operations/operations.factor | 19 +- 8 files changed, 212 insertions(+), 245 deletions(-) delete mode 100644 bson/reader/reader-docs.factor delete mode 100644 bson/writer/writer-docs.factor delete mode 100644 mongodb/operations/operations-docs.factor diff --git a/bson/reader/reader-docs.factor b/bson/reader/reader-docs.factor deleted file mode 100644 index be300f4be6..0000000000 --- a/bson/reader/reader-docs.factor +++ /dev/null @@ -1,17 +0,0 @@ -! Copyright (C) 2009 Your name. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs help.markup help.syntax kernel ; -IN: bson.reader - -HELP: stream>assoc -{ $values - { "exemplar" null } - { "assoc" assoc } { "bytes-read" null } -} -{ $description "" } ; - -ARTICLE: "bson.reader" "bson.reader" -{ $vocab-link "bson.reader" } -; - -ABOUT: "bson.reader" diff --git a/bson/writer/writer-docs.factor b/bson/writer/writer-docs.factor deleted file mode 100644 index a4b393b5d9..0000000000 --- a/bson/writer/writer-docs.factor +++ /dev/null @@ -1,23 +0,0 @@ -! Copyright (C) 2009 Your name. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs help.markup help.syntax kernel ; -IN: bson.writer - -HELP: assoc>bv -{ $values - { "assoc" assoc } - { "byte-array" null } -} -{ $description "" } ; - -HELP: assoc>stream -{ $values - { "assoc" assoc } -} -{ $description "" } ; - -ARTICLE: "bson.writer" "bson.writer" -{ $vocab-link "bson.writer" } -; - -ABOUT: "bson.writer" diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 22a278e1fb..6e3d7badea 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Sascha Matzke. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs bson.constants byte-arrays byte-vectors -calendar fry io io.binary io.encodings io.encodings.string +calendar fry io io.binary io.encodings io.encodings.string io.encodings.private io.encodings.utf8 kernel math math.parser namespaces quotations -sequences serialize strings tools.walker words ; +sequences sequences.private serialize strings tools.walker words ; IN: bson.writer @@ -20,18 +20,18 @@ CONSTANT: INT64-SIZE 8 : (buffer) ( -- buffer ) shared-buffer get - [ 4096 [ shared-buffer set ] keep ] unless* ; inline + [ 8192 [ shared-buffer set ] keep ] unless* ; inline PRIVATE> +: reset-buffer ( buffer -- ) + 0 >>length drop ; inline + : ensure-buffer ( -- ) (buffer) drop ; inline -: reset-buffer ( -- ) - (buffer) 0 >>length drop ; inline - : with-buffer ( quot -- byte-vector ) - [ (buffer) ] dip [ output-stream get ] compose + [ (buffer) [ reset-buffer ] keep dup ] dip with-output-stream* dup encoder? [ stream>> ] when ; inline : with-length ( quot: ( -- ) -- bytes-written start-index ) @@ -41,9 +41,15 @@ PRIVATE> : with-length-prefix ( quot: ( -- ) -- ) [ B{ 0 0 0 0 } write ] prepose with-length [ INT32-SIZE >le ] dip (buffer) - '[ _ over [ nth ] dip _ + _ set-nth ] + '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ] [ INT32-SIZE ] dip each-integer ; inline +: with-length-prefix-excl ( quot: ( -- ) -- ) + [ B{ 0 0 0 0 } write ] prepose with-length + [ INT32-SIZE - INT32-SIZE >le ] dip (buffer) + '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ] + [ INT32-SIZE ] dip each-integer ; inline + le write ; inline : write-int32 ( int -- ) INT32-SIZE >le write ; inline : write-double ( real -- ) double>bits INT64-SIZE >le write ; inline -: write-cstring ( string -- ) utf8 encode B{ 0 } append write ; inline +: write-cstring ( string -- ) write-utf8-string B{ 0 } write ; inline : write-longlong ( object -- ) INT64-SIZE >le write ; inline : write-eoo ( -- ) T_EOO write-byte ; inline @@ -85,9 +92,7 @@ M: t bson-write ( t -- ) drop 1 write-byte ; M: string bson-write ( obj -- ) - utf8 encode B{ 0 } append - [ length write-int32 ] keep - write ; + '[ _ write-cstring ] with-length-prefix-excl ; M: integer bson-write ( num -- ) write-int32 ; @@ -112,22 +117,18 @@ M: oid bson-write ( oid -- ) [ a>> write-longlong ] [ b>> write-int32 ] bi ; M: objid bson-write ( oid -- ) - id>> utf8 encode - [ length write-int32 ] keep T_Binary_UUID write-byte - write ; + id>> '[ _ write-utf8-string ] with-length-prefix ; M: objref bson-write ( objref -- ) - [ ns>> utf8 encode ] - [ objid>> id>> utf8 encode ] bi - append - [ length write-int32 ] keep T_Binary_Custom write-byte - write ; - + '[ _ + [ ns>> write-cstring ] + [ objid>> id>> write-cstring ] bi ] with-length-prefix ; + M: mdbregexp bson-write ( regexp -- ) - [ regexp>> utf8 encode write-cstring ] - [ options>> utf8 encode write-cstring ] bi ; + [ regexp>> write-cstring ] + [ options>> write-cstring ] bi ; M: sequence bson-write ( array -- ) '[ _ [ [ write-type ] dip number>string diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index 4f7fc644d6..c9c04dfab1 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -1,6 +1,6 @@ USING: calendar math fry kernel assocs math.ranges sequences formatting combinators namespaces io tools.time prettyprint -accessors words mongodb.driver strings math.parser ; +accessors words mongodb.driver strings math.parser tools.walker bson.writer ; IN: mongodb.benchmark @@ -164,7 +164,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } "_x_idx" H{ { "x" 1 } } ensure-index ; inline : insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) - prepare-collection + prepare-collection result get index>> [ [ prepare-index ] keep ] when result get batch>> [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ; @@ -233,7 +233,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : run-insert-bench ( doc-word-seq feat-seq -- ) "Insert Tests" print - print-separator-bold + print-separator-bold \ insert bench-quot each ; inline : run-find-one-bench ( doc-word-seq feat-seq -- ) @@ -254,24 +254,23 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : run-benchmarks ( -- ) "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number - [ + [ ensure-buffer print-header ! insert - { small-doc-prepare medium-doc-prepare large-doc-prepare } + ! { small-doc-prepare medium-doc-prepare + { large-doc-prepare } { { } { index } { errcheck } { index errcheck } - { batch } { batch errcheck } - { batch index errcheck } } - run-insert-bench + { batch } { batch errcheck } { batch index errcheck } + } run-insert-bench ! find-one - { small-doc medium-doc large-doc } - { { } { index } } run-find-one-bench + ! { small-doc medium-doc large-doc } + ! { { } { index } } run-find-one-bench ! find-all - { small-doc medium-doc large-doc } - { { } { index } } run-find-all-bench + ! { small-doc medium-doc large-doc } + ! { { } { index } } run-find-all-bench ! find-range - { small-doc medium-doc large-doc } - { { } { index } } run-find-range-bench - + ! { small-doc medium-doc large-doc } + ! { { } { index } } run-find-range-bench ] with-db ; MAIN: run-benchmarks diff --git a/mongodb/driver/driver-docs.factor b/mongodb/driver/driver-docs.factor index d06bbe4ed4..591a84a528 100644 --- a/mongodb/driver/driver-docs.factor +++ b/mongodb/driver/driver-docs.factor @@ -5,297 +5,315 @@ IN: mongodb.driver HELP: { $values - { "name" null } - { "collection" null } + { "name" "name of the collection" } + { "collection" "mdb-collection instance" } } -{ $description "" } ; - -HELP: -{ $values - { "id" null } { "collection" null } { "return#" null } - { "cursor" null } -} -{ $description "" } ; +{ $description "Creates a new mdb-collection instance. Use this to create capped/limited collections. See also: " { $link mdb-collection } } +{ $examples + { $example "\"mycollection\" t >>capped" } } ; HELP: { $values - { "db" null } { "host" null } { "port" null } - { "mdb" null } + { "db" "name of the database to use" } + { "host" "host name or IP address" } + { "port" "port number" } + { "mdb" "mdb-db instance" } } -{ $description "" } ; +{ $description "Create a new mdb-db instance and automatically resolves master/slave information in a paired MongoDB setup." } +{ $examples + { $example "\"db\" \"127.0.0.1\" 27017 " } } ; HELP: { $values - { "collection" "the collection to be queried" } { "query" "query" } - { "mdb-query" "mdb-query-msg tuple instance" } + { "collection" "collection to query" } + { "query" "query assoc" } + { "mdb-query" "mdb-query-msg instance" } } -{ $description "create a new query instance" } ; +{ $description "Creates a new mdb-query-msg instance. " + "This word must be called from within a with-db scope." + "For more see: " + { $link with-db } } +{ $examples + { $example "\"mycollection\" H{ } " } } ; + +HELP: +{ $values + { "collection" "collection to update" } + { "selector" "selector assoc (selects which object(s) to update" } + { "object" "updated object or update instruction" } + { "update-msg" "mdb-update-msg instance" } +} +{ $description "" } ; + +HELP: >upsert +{ $values + { "mdb-update-msg" null } + { "mdb-update-msg" null } +} +{ $description "" } ; HELP: DIRTY? { $values - - { "value" null } + + { "value" null } } { $description "" } ; HELP: MDB-GENERAL-ERROR { $values - - { "value" null } + + { "value" null } } { $description "" } ; HELP: PARTIAL? { $values - - { "value" null } + + { "value" null } } { $description "" } ; HELP: asc { $values - { "key" null } - { "spec" null } + { "key" null } + { "spec" null } } { $description "" } ; HELP: boolean -{ $values - - { "value" null } -} -{ $description "" } ; +{ $var-description "" } ; HELP: count { $values - { "collection" null } { "query" null } - { "result" null } + { "collection" null } + { "query" null } + { "result" null } } { $description "" } ; HELP: create-collection { $values - { "name" null } + { "name" null } } { $description "" } ; HELP: delete { $values - { "collection" null } { "selector" null } + { "collection" null } + { "selector" null } } { $description "" } ; HELP: delete-unsafe { $values - { "collection" null } { "selector" null } + { "collection" null } + { "selector" null } } { $description "" } ; HELP: desc { $values - { "key" null } - { "spec" null } + { "key" null } + { "spec" null } } { $description "" } ; HELP: drop-collection { $values - { "name" null } + { "name" null } } { $description "" } ; HELP: drop-index { $values - { "collection" null } { "name" null } + { "collection" null } + { "name" null } } { $description "" } ; HELP: ensure-collection { $values - { "collection" null } - { "fq-collection" null } + { "collection" null } + { "fq-collection" null } } { $description "" } ; HELP: ensure-index { $values - { "collection" null } { "name" null } { "spec" null } + { "collection" null } + { "name" null } + { "spec" null } } { $description "" } ; -HELP: explain +HELP: explain. { $values - { "mdb-query" null } - { "result" null } + { "mdb-query" null } } { $description "" } ; HELP: find { $values - { "mdb-query" null } - { "cursor" null } { "result" null } + { "mdb-query" null } + { "cursor" null } + { "result" null } } { $description "" } ; HELP: find-one { $values - { "mdb-query" null } - { "result" null } + { "mdb-query" null } + { "result" null } } { $description "" } ; HELP: get-more { $values - { "mdb-cursor" null } - { "mdb-cursor" null } { "objects" null } + { "mdb-cursor" null } + { "mdb-cursor" null } + { "objects" null } } { $description "" } ; HELP: hint { $values - { "mdb-query" null } { "index-hint" null } - { "mdb-query" null } + { "mdb-query" null } + { "index-hint" null } + { "mdb-query" null } } { $description "" } ; HELP: lasterror { $values - - { "error" null } + + { "error" null } } { $description "" } ; HELP: limit { $values - { "mdb-query" null } { "limit#" null } - { "mdb-query" null } + { "mdb-query" null } + { "limit#" null } + { "mdb-query" null } } { $description "" } ; HELP: load-collection-list { $values - - { "collection-list" null } + + { "collection-list" null } } { $description "" } ; HELP: load-index-list { $values - - { "index-list" null } + + { "index-list" null } } { $description "" } ; HELP: master>> { $values - { "mdb" null } - { "inet" null } + { "mdb" null } + { "inet" null } } { $description "" } ; HELP: mdb { $values - - { "mdb" null } + + { "mdb" null } } { $description "" } ; HELP: mdb-collection -{ $values - - { "value" null } -} -{ $description "" } ; +{ $var-description "" } ; HELP: mdb-cursor -{ $values - - { "value" null } -} -{ $description "" } ; +{ $var-description "" } ; HELP: mdb-db -{ $values - - { "value" null } -} -{ $description "" } ; +{ $var-description "" } ; HELP: mdb-error { $values - { "id" null } { "msg" null } + { "id" null } + { "msg" null } } { $description "" } ; HELP: mdb-instance -{ $values - - { "value" null } -} -{ $description "" } ; +{ $var-description "" } ; HELP: mdb-node +{ $var-description "" } ; + +HELP: r/ { $values - - { "value" null } + { "token" null } + { "mdbregexp" null } } { $description "" } ; HELP: save { $values - { "collection" null } { "assoc" assoc } + { "collection" null } + { "assoc" assoc } } { $description "" } ; HELP: save-unsafe { $values - { "collection" null } { "object" object } + { "collection" null } + { "object" object } } { $description "" } ; HELP: skip { $values - { "mdb-query" null } { "skip#" null } - { "mdb-query" null } + { "mdb-query" null } + { "skip#" null } + { "mdb-query" null } } { $description "" } ; HELP: slave>> { $values - { "mdb" null } - { "inet" null } + { "mdb" null } + { "inet" null } } { $description "" } ; HELP: sort { $values - { "mdb-query" null } { "quot" quotation } - { "mdb-query" null } + { "mdb-query" null } + { "quot" quotation } + { "mdb-query" null } } { $description "" } ; HELP: update { $values - { "collection" null } { "selector" null } { "object" object } + { "mdb-update-msg" null } } { $description "" } ; HELP: update-unsafe { $values - { "collection" null } { "selector" null } { "object" object } + { "mdb-update-msg" null } } { $description "" } ; -HELP: validate +HELP: validate. { $values - { "collection" null } + { "collection" null } } { $description "" } ; HELP: with-db { $values - { "mdb" null } { "quot" quotation } - { "..." null } + { "mdb" null } + { "quot" quotation } } { $description "" } ; @@ -304,3 +322,4 @@ ARTICLE: "mongodb.driver" "mongodb.driver" ; ABOUT: "mongodb.driver" + diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 93554b20bc..7e94f6d035 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -2,7 +2,7 @@ USING: accessors assocs bson.constants bson.writer combinators constructors continuations destructors formatting fry io io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs math math.parser memoize mongodb.msg mongodb.operations namespaces -parser sequences sets splitting strings uuid syntax ; +parser prettyprint sequences sets splitting strings uuid ; IN: mongodb.driver @@ -20,7 +20,6 @@ TUPLE: mdb-collection { size integer initial: -1 } { max integer initial: -1 } ; -CONSTRUCTOR: mdb-cursor ( id collection return# -- cursor ) ; CONSTRUCTOR: mdb-collection ( name -- collection ) ; CONSTANT: MDB-GENERAL-ERROR 1 @@ -30,24 +29,6 @@ CONSTANT: DIRTY? "dirty?" ERROR: mdb-error id msg ; -> ( -- stream ) - mdb-socket-stream get ; inline - -: check-ok ( result -- ? ) - [ "ok" ] dip key? ; inline - -: >mdbregexp ( value -- regexp ) - first ; - -PRIVATE> - -SYNTAX: r/ ( token -- mdbregexp ) - \ / [ >mdbregexp ] parse-literal ; - SYMBOL: mdb-instance : mdb ( -- mdb ) @@ -59,14 +40,39 @@ SYMBOL: mdb-instance : slave>> ( mdb -- inet ) nodes>> [ f ] dip at inet>> ; -: with-db ( mdb quot: ( -- * ) -- * ) - [ [ '[ ensure-buffer _ [ mdb-instance set ] keep - master>> [ remote-address set ] keep - binary local-address set - mdb-socket-stream set ] ] dip compose - [ mdb-stream>> [ dispose ] when* ] - [ ] cleanup ] with-scope ; inline +>mdb-stream ( stream -- ) + mdb-socket-stream set ; inline + +: mdb-stream>> ( -- stream ) + mdb-socket-stream get ; inline + +: check-ok ( result -- ? ) + [ "ok" ] dip key? ; inline + +: >mdbregexp ( value -- regexp ) + first ; inline + +: prepare-mdb-session ( mdb -- stream ) + [ mdb-instance set ] keep + master>> [ remote-address set ] keep + binary local-address set ; inline + +PRIVATE> + +SYNTAX: r/ ( token -- mdbregexp ) + \ / [ >mdbregexp ] parse-literal ; + +: with-db ( mdb quot -- ... ) + [ [ prepare-mdb-session ] dip + [ [ >>mdb-stream ] keep ] prepose + with-disposal ] with-scope ; inline + MEMO: ensure-collection ( collection -- fq-collection ) "." split1 over mdb name>> = - [ [ drop ] dip ] [ drop ] if + [ nip ] [ drop ] if [ ] [ reserved-namespace? ] bi [ [ (ensure-collection) ] keep ] unless [ mdb name>> ] dip "%s.%s" sprintf ; inline @@ -223,9 +229,9 @@ M: mdb-query-msg find M: mdb-cursor find get-more ; -GENERIC: explain ( mdb-query -- result ) -M: mdb-query-msg explain - t >>explain find [ drop ] dip ; +GENERIC: explain. ( mdb-query -- ) +M: mdb-query-msg explain. + t >>explain find nip . ; GENERIC: find-one ( mdb-query -- result ) @@ -243,14 +249,14 @@ M: assoc count cmd-collection H{ { "getlasterror" 1 } } find-one objects>> first [ "err" ] dip at ; -GENERIC: validate ( collection -- ) -M: string validate +GENERIC: validate. ( collection -- ) +M: string validate. [ cmd-collection ] dip "validate" H{ } clone [ set-at ] keep find-one objects>> first [ check-ok ] keep '[ "result" _ at print ] when ; -M: mdb-collection validate - name>> validate ; +M: mdb-collection validate. + name>> validate. ; find [ drop ] dip ; + H{ } clone find nip ; : drop-collection ( name -- ) [ cmd-collection ] dip diff --git a/mongodb/operations/operations-docs.factor b/mongodb/operations/operations-docs.factor deleted file mode 100644 index c6d00db1e8..0000000000 --- a/mongodb/operations/operations-docs.factor +++ /dev/null @@ -1,23 +0,0 @@ -! Copyright (C) 2009 Your name. -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax kernel ; -IN: mongodb.operations - -HELP: read-message -{ $values - - { "message" null } -} -{ $description "" } ; - -HELP: write-message -{ $values - { "message" null } -} -{ $description "" } ; - -ARTICLE: "mongodb.operations" "mongodb.operations" -{ $vocab-link "mongodb.operations" } -; - -ABOUT: "mongodb.operations" diff --git a/mongodb/operations/operations.factor b/mongodb/operations/operations.factor index cc496b81c6..0b7f027500 100644 --- a/mongodb/operations/operations.factor +++ b/mongodb/operations/operations.factor @@ -1,7 +1,7 @@ -USING: accessors bson.reader bson.writer byte-arrays byte-vectors fry -io io.binary io.encodings.binary io.encodings.string io.encodings.utf8 -io.streams.byte-array kernel math mongodb.msg namespaces sequences -locals assocs combinators linked-assocs ; +USING: accessors assocs bson.reader bson.writer byte-arrays +byte-vectors combinators formatting fry io io.binary io.encodings.private +io.encodings.binary io.encodings.string io.encodings.utf8 io.files +kernel locals math mongodb.msg namespaces sequences uuid ; IN: alien.c-types @@ -41,7 +41,7 @@ SYMBOL: msg-bytes-read : write-byte ( byte -- ) 1 >le write ; inline : write-int32 ( int -- ) 4 >le write ; inline : write-double ( real -- ) double>bits 8 >le write ; inline -: write-cstring ( string -- ) utf8 encode B{ 0 } append write ; inline +: write-cstring ( string -- ) output-stream get utf8 encoder-write 0 write-byte ; inline : write-longlong ( object -- ) 8 >le write ; inline : read-int32 ( -- int32 ) 4 [ read le> ] [ change-bytes-read ] bi ; inline @@ -150,9 +150,14 @@ PRIVATE> USE: tools.walker -: (write-message) ( message quot -- ) +: dump-to-file ( array -- ) + [ uuid1 "/tmp/mfb/%s.dump" sprintf binary ] dip + '[ _ write ] with-file-writer ; + +: (write-message) ( message quot -- ) '[ [ [ _ write-header ] dip _ call ] with-length-prefix ] with-buffer - write flush reset-buffer ; inline + ! [ dump-to-file ] keep + write flush ; inline : build-query-object ( query -- selector ) [let | selector [ H{ } clone ] | From a050578c3b6946e593c33039d4a5dc9447e37cde Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Wed, 25 Mar 2009 21:33:39 +0100 Subject: [PATCH 051/101] some further optimizations --- bson/writer/writer.factor | 23 +++++++++++++------ mongodb/benchmark/benchmark.factor | 34 ++++++++++++++-------------- mongodb/operations/operations.factor | 12 +++------- 3 files changed, 36 insertions(+), 33 deletions(-) diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 6e3d7badea..6684888ad0 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs bson.constants byte-arrays byte-vectors calendar fry io io.binary io.encodings io.encodings.string io.encodings.private -io.encodings.utf8 kernel math math.parser namespaces quotations +io.encodings.utf8.private io.encodings.utf8 kernel math math.parser namespaces quotations sequences sequences.private serialize strings tools.walker words ; @@ -22,6 +22,13 @@ CONSTANT: INT64-SIZE 8 shared-buffer get [ 8192 [ shared-buffer set ] keep ] unless* ; inline +: >le-stream ( x n -- ) + ! >le write + swap '[ _ swap nth-byte 0 B{ 0 } + [ set-nth-unsafe ] keep write ] each + ; inline + + PRIVATE> : reset-buffer ( buffer -- ) @@ -74,12 +81,14 @@ M: objref bson-type? ( objref -- type ) drop T_Binary ; M: quotation bson-type? ( quotation -- type ) drop T_Binary ; M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; -: write-utf8-string ( string -- ) output-stream get utf8 encoder-write ; 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 B{ 0 } write ; inline -: write-longlong ( object -- ) INT64-SIZE >le write ; inline +: write-utf8-string ( string -- ) + output-stream get '[ _ swap char>utf8 ] each ; inline + +: write-byte ( byte -- ) CHAR-SIZE >le-stream ; inline +: write-int32 ( int -- ) INT32-SIZE >le-stream ; inline +: write-double ( real -- ) double>bits INT64-SIZE >le-stream ; inline +: write-cstring ( string -- ) write-utf8-string 0 write-byte ; inline +: write-longlong ( object -- ) INT64-SIZE >le-stream ; inline : write-eoo ( -- ) T_EOO write-byte ; inline : write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index c9c04dfab1..b8a0a7a8fe 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -254,23 +254,23 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : run-benchmarks ( -- ) "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number - [ ensure-buffer - print-header - ! insert - ! { small-doc-prepare medium-doc-prepare - { large-doc-prepare } - { { } { index } { errcheck } { index errcheck } - { batch } { batch errcheck } { batch index errcheck } - } run-insert-bench - ! find-one - ! { small-doc medium-doc large-doc } - ! { { } { index } } run-find-one-bench - ! find-all - ! { small-doc medium-doc large-doc } - ! { { } { index } } run-find-all-bench - ! find-range - ! { small-doc medium-doc large-doc } - ! { { } { index } } run-find-range-bench + [ ensure-buffer + print-header + ! insert + { small-doc-prepare medium-doc-prepare + large-doc-prepare } + { { } { index } { errcheck } { index errcheck } + { batch } { batch errcheck } { batch index errcheck } + } run-insert-bench + ! find-one + { small-doc medium-doc large-doc } + { { } { index } } run-find-one-bench + ! find-all + { small-doc medium-doc large-doc } + { { } { index } } run-find-all-bench + ! find-range + { small-doc medium-doc large-doc } + { { } { index } } run-find-range-bench ] with-db ; MAIN: run-benchmarks diff --git a/mongodb/operations/operations.factor b/mongodb/operations/operations.factor index 0b7f027500..ef74bce7e9 100644 --- a/mongodb/operations/operations.factor +++ b/mongodb/operations/operations.factor @@ -1,7 +1,7 @@ USING: accessors assocs bson.reader bson.writer byte-arrays byte-vectors combinators formatting fry io io.binary io.encodings.private -io.encodings.binary io.encodings.string io.encodings.utf8 io.files -kernel locals math mongodb.msg namespaces sequences uuid ; +io.encodings.binary io.encodings.string io.encodings.utf8 io.encodings.utf8.private io.files +kernel locals math mongodb.msg namespaces sequences uuid bson.writer.private ; IN: alien.c-types @@ -38,12 +38,6 @@ SYMBOL: msg-bytes-read : change-bytes-read ( integer -- ) bytes-read> [ 0 ] unless* + >bytes-read ; inline -: write-byte ( byte -- ) 1 >le write ; inline -: write-int32 ( int -- ) 4 >le write ; inline -: write-double ( real -- ) double>bits 8 >le write ; inline -: write-cstring ( string -- ) output-stream get utf8 encoder-write 0 write-byte ; inline -: write-longlong ( object -- ) 8 >le write ; inline - : read-int32 ( -- int32 ) 4 [ read le> ] [ change-bytes-read ] bi ; inline : read-longlong ( -- longlong ) 8 [ read le> ] [ change-bytes-read ] bi ; inline : read-byte-raw ( -- byte-raw ) 1 [ read le> ] [ change-bytes-read ] bi ; inline @@ -156,7 +150,7 @@ USE: tools.walker : (write-message) ( message quot -- ) '[ [ [ _ write-header ] dip _ call ] with-length-prefix ] with-buffer - ! [ dump-to-file ] keep + [ dump-to-file ] keep write flush ; inline : build-query-object ( query -- selector ) From fbf406b93efeef95ac9760ad2234437312028997 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Wed, 25 Mar 2009 21:51:21 +0100 Subject: [PATCH 052/101] removed debug output --- mongodb/operations/operations.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mongodb/operations/operations.factor b/mongodb/operations/operations.factor index ef74bce7e9..6d4300fa50 100644 --- a/mongodb/operations/operations.factor +++ b/mongodb/operations/operations.factor @@ -150,7 +150,7 @@ USE: tools.walker : (write-message) ( message quot -- ) '[ [ [ _ write-header ] dip _ call ] with-length-prefix ] with-buffer - [ dump-to-file ] keep + ! [ dump-to-file ] keep write flush ; inline : build-query-object ( query -- selector ) From 088e59ed34737b538c3b8117897664c2663a82eb Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Thu, 26 Mar 2009 12:00:08 +0100 Subject: [PATCH 053/101] fixed query benchmark --- mongodb/benchmark/benchmark.factor | 34 ++++++++++++++++++------------ 1 file changed, 21 insertions(+), 13 deletions(-) diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index b8a0a7a8fe..effac96b2c 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -172,22 +172,30 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : check-for-key ( assoc key -- ) CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ; inline +: (check-find-result) ( result -- ) + "x" check-for-key ; inline + +: (find) ( cursor -- ) + [ find [ (check-find-result) ] each (find) ] when* ; inline recursive + : find-one ( -- quot: ( -- ) ) - collection-name - trial-size 2 / "x" H{ } clone [ set-at ] keep - '[ _ _ 1 limit find [ drop ] dip first "x" check-for-key ] ; - + [ trial-size + collection-name + trial-size 2 / "x" H{ } clone [ set-at ] keep + '[ _ _ 1 limit (find) ] times ] ; + : find-all ( -- quot: ( -- ) ) - collection-name - H{ } clone - '[ _ _ find [ "x" check-for-key ] each drop ] ; - + collection-name + H{ } clone + '[ _ _ (find) ] ; + : find-range ( -- quot: ( -- ) ) - collection-name - trial-size 2 / "$gt" H{ } clone [ set-at ] keep - [ trial-size 2 / batch-size + "$lt" ] dip [ set-at ] keep - "x" H{ } clone [ set-at ] keep - '[ _ _ find [ "x" check-for-key ] each drop ] ; + [ trial-size batch-size /i + collection-name + trial-size 2 / "$gt" H{ } clone [ set-at ] keep + [ trial-size 2 / batch-size + "$lt" ] dip [ set-at ] keep + "x" H{ } clone [ set-at ] keep + '[ _ _ find [ "x" check-for-key ] each drop ] times ] ; : batch ( -- ) result [ t >>batch ] change ; inline From 5da056642665f5bb3f5ab3901333164a6504b1ca Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 27 Mar 2009 16:33:49 +0100 Subject: [PATCH 054/101] performance improvements --- bson/reader/reader.factor | 35 +++++++++---------------- bson/writer/writer.factor | 2 +- mongodb/benchmark/benchmark.factor | 42 +++++++++++++++++++++++------- mongodb/driver/driver.factor | 2 +- 4 files changed, 48 insertions(+), 33 deletions(-) diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index f39d4a21d6..7e81fd5e25 100644 --- a/bson/reader/reader.factor +++ b/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 ; +sequences serialize arrays calendar io.encodings ; IN: bson.reader @@ -41,6 +41,9 @@ GENERIC: element-read ( type -- cont? ) GENERIC: element-data-read ( type -- object ) GENERIC: element-binary-read ( length type -- object ) +: byte-arrary>number ( seq -- number ) + byte-array>bignum >integer ; inline + : get-state ( -- state ) state get ; inline @@ -48,13 +51,13 @@ GENERIC: element-binary-read ( length type -- object ) [ get-state ] dip '[ _ + ] change-read drop ; inline : read-int32 ( -- int32 ) - 4 [ read le> ] [ count-bytes ] bi ; inline + 4 [ read byte-array>number ] [ count-bytes ] bi ; inline : read-longlong ( -- longlong ) - 8 [ read le> ] [ count-bytes ] bi ; inline + 8 [ read byte-array>number ] [ count-bytes ] bi ; inline : read-double ( -- double ) - 8 [ read le> bits>double ] [ count-bytes ] bi ; inline + 8 [ read byte-array>number bits>double ] [ count-bytes ] bi ; inline : read-byte-raw ( -- byte-raw ) 1 [ read ] [ count-bytes ] bi ; inline @@ -62,21 +65,12 @@ GENERIC: element-binary-read ( length type -- object ) : read-byte ( -- byte ) read-byte-raw first ; inline -: (read-cstring) ( acc -- ) - [ read-byte-raw first ] dip ! b acc - 2dup push ! b acc - [ 0 = ] dip ! bool acc - '[ _ (read-cstring) ] unless ; inline recursive - : read-cstring ( -- string ) - BV{ } clone - [ (read-cstring) ] keep - [ zero? ] trim-tail - >byte-array utf8 decode ; inline + input-stream get utf8 + "\0" swap stream-read-until drop ; inline : read-sized-string ( length -- string ) - [ read ] [ count-bytes ] bi - [ zero? ] trim-tail utf8 decode ; inline + drop read-cstring ; inline : read-element-type ( -- type ) read-byte ; inline @@ -128,14 +122,11 @@ M: bson-eoo element-read ( type -- cont? ) M: bson-not-eoo element-read ( type -- cont? ) [ peek-scope ] dip ! scope type - '[ _ - read-cstring push-element [ name>> ] [ type>> ] bi + '[ _ read-cstring push-element [ name>> ] [ type>> ] bi [ element-data-read ] keep end-element swap - ] dip - set-at - t ; + ] dip set-at t ; : [scope-changer] ( state -- state quot ) dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline @@ -212,4 +203,4 @@ PRIVATE> : stream>assoc ( exemplar -- assoc bytes-read ) dup state [ read-int32 >>size read-elements ] with-variable - [ result>> ] [ read>> ] bi ; + [ result>> ] [ read>> ] bi ; inline diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 6684888ad0..4c94840888 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -82,7 +82,7 @@ M: quotation bson-type? ( quotation -- type ) drop T_Binary ; M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; : write-utf8-string ( string -- ) - output-stream get '[ _ swap char>utf8 ] each ; inline + output-stream get utf8 stream-write ; inline : write-byte ( byte -- ) CHAR-SIZE >le-stream ; inline : write-int32 ( int -- ) INT32-SIZE >le-stream ; inline diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index effac96b2c..424aa7732c 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -1,5 +1,5 @@ -USING: calendar math fry kernel assocs math.ranges -sequences formatting combinators namespaces io tools.time prettyprint +USING: calendar math fry kernel assocs math.ranges bson.reader io.streams.byte-array +sequences formatting combinators namespaces io tools.time prettyprint io.encodings.binary accessors words mongodb.driver strings math.parser tools.walker bson.writer ; IN: mongodb.benchmark @@ -13,7 +13,7 @@ SYMBOL: collection dup string? [ string>number ] when ; inline : trial-size ( -- size ) - "per-trial" 10000 get* ensure-number ; inline flushable + "per-trial" 5000 get* ensure-number ; inline flushable : batch-size ( -- size ) "batch-size" 100 get* ensure-number ; inline flushable @@ -169,6 +169,13 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } result get batch>> [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ; +: serialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) + '[ trial-size [ _ call assoc>bv drop ] each-integer ] ; inline + +: deserialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) + [ 0 ] dip call assoc>bv + '[ trial-size [ _ binary [ H{ } stream>assoc 2drop ] with-byte-reader ] times ] ; inline + : check-for-key ( assoc key -- ) CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ; inline @@ -213,14 +220,14 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } lasterror>> bchar trial-size ] dip 1000000 / /i - "%-18s: {batch:%s,index:%s;errchk:%s} %10s op/s" + "%-18s: {batch:%s,index:%s;errchk:%s} %10s docs/s" sprintf print flush ; inline : print-separator ( -- ) - "--------------------------------------------------------------" print flush ; inline + "----------------------------------------------------------------" print flush ; inline : print-separator-bold ( -- ) - "==============================================================" print flush ; inline + "================================================================" print flush ; inline : print-header ( -- ) trial-size @@ -238,7 +245,17 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } '[ [ [ _ execute ] dip [ execute ] each _ execute benchmark ] with-result ] each print-separator ] ; inline - + +: run-serialization-bench ( doc-word-seq feat-seq -- ) + "Serialization Tests" print + print-separator-bold + \ serialize bench-quot each ; inline + +: run-deserialization-bench ( doc-word-seq feat-seq -- ) + "Deserialization Tests" print + print-separator-bold + \ deserialize bench-quot each ; inline + : run-insert-bench ( doc-word-seq feat-seq -- ) "Insert Tests" print print-separator-bold @@ -262,8 +279,15 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : run-benchmarks ( -- ) "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number - [ ensure-buffer - print-header + [ print-header + ! serialization + { small-doc-prepare medium-doc-prepare + large-doc-prepare } + { { } } run-serialization-bench + ! deserialization + { small-doc-prepare medium-doc-prepare + large-doc-prepare } + { { } } run-deserialization-bench ! insert { small-doc-prepare medium-doc-prepare large-doc-prepare } diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 7e94f6d035..430f94f0cd 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -70,7 +70,7 @@ SYNTAX: r/ ( token -- mdbregexp ) : with-db ( mdb quot -- ... ) [ [ prepare-mdb-session ] dip - [ [ >>mdb-stream ] keep ] prepose + [ >>mdb-stream ] prepose with-disposal ] with-scope ; inline Date: Fri, 27 Mar 2009 16:38:29 +0100 Subject: [PATCH 055/101] fixed typo --- bson/reader/reader.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index 7e81fd5e25..ad0f8fdff8 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -41,7 +41,7 @@ GENERIC: element-read ( type -- cont? ) GENERIC: element-data-read ( type -- object ) GENERIC: element-binary-read ( length type -- object ) -: byte-arrary>number ( seq -- number ) +: byte-array>number ( seq -- number ) byte-array>bignum >integer ; inline : get-state ( -- state ) @@ -203,4 +203,4 @@ PRIVATE> : stream>assoc ( exemplar -- assoc bytes-read ) dup state [ read-int32 >>size read-elements ] with-variable - [ result>> ] [ read>> ] bi ; inline + [ result>> ] [ read>> ] bi ; From 1c1f9f46c6c0d48b8b30f98224cf50c6e113461d Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 28 Mar 2009 16:40:57 +0100 Subject: [PATCH 056/101] fixed find-one - now returns a result or f --- mongodb/driver/driver.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 430f94f0cd..2f3f8406a3 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -234,9 +234,9 @@ M: mdb-query-msg explain. t >>explain find nip . ; -GENERIC: find-one ( mdb-query -- result ) +GENERIC: find-one ( mdb-query -- result/f ) M: mdb-query-msg find-one - 1 >>return# send-query-plain ; + 1 >>return# send-query-plain objects>> [ first ] [ f ] if* ; GENERIC: count ( collection query -- result ) M: assoc count From f3a7f9d6be9638cdf4fb2bbeffcb1c8bfb9e5f9a Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Mon, 30 Mar 2009 11:01:15 +0200 Subject: [PATCH 057/101] fixed find-one --- mongodb/driver/driver.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 2f3f8406a3..a70dfb25c4 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -242,18 +242,18 @@ GENERIC: count ( collection query -- result ) M: assoc count [ "count" H{ } clone [ set-at ] keep ] dip [ over [ "query" ] dip set-at ] when* - [ cmd-collection ] dip find-one objects>> first + [ cmd-collection ] dip find-one [ check-ok ] keep '[ "n" _ at >fixnum ] [ f ] if ; : lasterror ( -- error ) cmd-collection H{ { "getlasterror" 1 } } - find-one objects>> first [ "err" ] dip at ; + find-one [ "err" ] dip at ; GENERIC: validate. ( collection -- ) M: string validate. [ cmd-collection ] dip "validate" H{ } clone [ set-at ] keep - find-one objects>> first [ check-ok ] keep + find-one [ check-ok ] keep '[ "result" _ at print ] when ; M: mdb-collection validate. name>> validate. ; @@ -289,7 +289,7 @@ M: assoc ensure-index H{ } clone [ [ "index" ] dip set-at ] keep [ [ "deleteIndexes" ] dip set-at ] keep - [ cmd-collection ] dip find-one objects>> first + [ cmd-collection ] dip find-one check-ok [ "could not drop index" throw ] unless ; : ( collection selector object -- update-msg ) @@ -323,5 +323,5 @@ M: assoc delete-unsafe : drop-collection ( name -- ) [ cmd-collection ] dip "drop" H{ } clone [ set-at ] keep - find-one objects>> first check-ok + find-one check-ok [ "could not drop collection" throw ] unless ; From 33d99b607653fbce0f34bc31678dcc070bbf0b63 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 4 Apr 2009 11:10:13 +0200 Subject: [PATCH 058/101] checkpoint tuple integration --- bson/constants/constants.factor | 6 +- bson/writer/writer.factor | 2 +- mongodb/driver/driver.factor | 12 ++- mongodb/tuple/collection/collection.factor | 90 +++++++++++++++++++++ mongodb/tuple/index/index.factor | 54 +++++++++++++ mongodb/tuple/persistent/persistent.factor | 92 ++++++++++++++++++++++ mongodb/tuple/state/state.factor | 44 +++++++++++ mongodb/tuple/tuple.factor | 83 +++++++++++++++++++ 8 files changed, 377 insertions(+), 6 deletions(-) create mode 100644 mongodb/tuple/collection/collection.factor create mode 100644 mongodb/tuple/index/index.factor create mode 100644 mongodb/tuple/persistent/persistent.factor create mode 100644 mongodb/tuple/state/state.factor create mode 100644 mongodb/tuple/tuple.factor diff --git a/bson/constants/constants.factor b/bson/constants/constants.factor index 0da3cc0bb5..aa852bbff8 100644 --- a/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -1,4 +1,4 @@ -USING: accessors kernel math parser sequences strings uuid ; +USING: accessors constructors kernel strings uuid ; IN: bson.constants @@ -11,6 +11,8 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ; TUPLE: objref ns objid ; +CONSTRUCTOR: objref ( ns objid -- objref ) ; + TUPLE: mdbregexp { regexp string } { options string } ; : ( string -- mdbregexp ) @@ -18,7 +20,7 @@ TUPLE: mdbregexp { regexp string } { options string } ; CONSTANT: MDB_OID_FIELD "_id" -CONSTANT: MDB_INTERNAL_FIELD "_mdb_" +CONSTANT: MDB_META_FIELD "_mfd" CONSTANT: T_EOO 0 CONSTANT: T_Double 1 diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 4c94840888..3684a644d5 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -149,7 +149,7 @@ M: sequence bson-write ( array -- ) [ [ MDB_OID_FIELD ] dip write-pair ] [ drop ] if ; inline : skip-field? ( name -- boolean ) - { "_id" "_mdb" } member? ; inline + { "_id" "_mfd" } member? ; inline M: assoc bson-write ( assoc -- ) '[ _ [ write-oid ] keep diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index a70dfb25c4..1853beb81f 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -20,7 +20,8 @@ TUPLE: mdb-collection { size integer initial: -1 } { max integer initial: -1 } ; -CONSTRUCTOR: mdb-collection ( name -- collection ) ; +: ( name -- collection ) + [ mdb-collection new ] dip >>name ; inline CONSTANT: MDB-GENERAL-ERROR 1 @@ -73,6 +74,10 @@ SYNTAX: r/ ( token -- mdbregexp ) [ >>mdb-stream ] prepose with-disposal ] with-scope ; inline +: build-id-selector ( assoc -- selector ) + [ MDB_OID_FIELD swap at ] keep + H{ } clone [ set-at ] keep ; + > "size" ] dip set-at ] [ [ max>> "max" ] dip set-at ] 2tri ] when ] 2bi - ] keep 1 >>return# send-query-plain objects>> first check-ok + ] keep 1 >>return# send-query-plain + objects>> first check-ok [ "could not create collection" throw ] unless ; : load-collection-list ( -- collection-list ) @@ -238,7 +244,7 @@ GENERIC: find-one ( mdb-query -- result/f ) M: mdb-query-msg find-one 1 >>return# send-query-plain objects>> [ first ] [ f ] if* ; -GENERIC: count ( collection query -- result ) +GENERIC: count ( collection selector -- result ) M: assoc count [ "count" H{ } clone [ set-at ] keep ] dip [ over [ "query" ] dip set-at ] when* diff --git a/mongodb/tuple/collection/collection.factor b/mongodb/tuple/collection/collection.factor new file mode 100644 index 0000000000..e5dedf1967 --- /dev/null +++ b/mongodb/tuple/collection/collection.factor @@ -0,0 +1,90 @@ + +USING: accessors arrays assocs bson.constants classes classes.tuple +continuations fry kernel mongodb.driver sequences +vectors words ; + +IN: mongodb.tuple.collection + +MIXIN: mdb-persistent + +SLOT: _id +SLOT: _mfd + +TUPLE: mdb-tuple-collection < mdb-collection { classes } ; + +GENERIC: tuple-collection ( object -- mdb-collection ) + +GENERIC: mdb-slot-list ( tuple -- string ) + +assoc ( seq -- assoc ) + [ dup assoc? + [ 1array { "" } append ] unless ] map ; + +: optl>map ( seq -- map ) + H{ } clone tuck + '[ split-optl opt>assoc swap _ set-at ] each ; inline + +PRIVATE> + +: MDB_ADDON_SLOTS ( -- slots ) + { } [ MDB_OID_FIELD MDB_META_FIELD ] with-datastack ; inline + +: link-class ( collection class -- ) + over classes>> + [ 2dup member? [ 2drop ] [ push ] if ] + [ 1vector >>classes ] if* drop ; inline + +: link-collection ( class collection -- ) + [ swap link-class ] + [ MDB_COLLECTION set-word-prop ] 2bi ; inline + +: mdb-check-slots ( superclass slots -- superclass slots ) + over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member? + [ ] [ MDB_ADDON_SLOTS prepend ] if ; inline + +: set-slot-options ( class options -- ) + '[ MDB_SLOTDEF_LIST _ optl>map set-word-prop ] keep + dup tuple-collection link-collection ; inline + +M: tuple-class tuple-collection ( tuple -- mdb-collection ) + (mdb-collection) ; + +M: mdb-persistent tuple-collection ( tuple -- mdb-collection ) + class (mdb-collection) ; + +M: mdb-persistent mdb-slot-list ( tuple -- string ) + class (mdb-slot-list) ; + +M: tuple-class mdb-slot-list ( class -- assoc ) + (mdb-slot-list) ; + +M: mdb-collection mdb-slot-list ( collection -- assoc ) + classes>> [ mdb-slot-list ] map assoc-combine ; + +: collection-map ( -- assoc ) + MDB_COLLECTION_MAP mdb-persistent word-prop + [ mdb-persistent MDB_COLLECTION_MAP H{ } clone + [ set-word-prop ] keep ] unless* ; inline + +: ( name -- mdb-tuple-collection ) + collection-map [ ] [ key? ] 2bi + [ at ] [ [ mdb-tuple-collection new dup ] 2dip + [ [ >>name ] keep ] dip set-at ] if ; inline + diff --git a/mongodb/tuple/index/index.factor b/mongodb/tuple/index/index.factor new file mode 100644 index 0000000000..466c36f719 --- /dev/null +++ b/mongodb/tuple/index/index.factor @@ -0,0 +1,54 @@ +USING: kernel fry accessors formatting linked-assocs assocs sequences sequences.deep +mongodb.tuple.collection combinators mongodb.tuple.collection ; + +IN: mongodb.tuple.index + +TUPLE: tuple-index name spec ; + +SYMBOLS: +transient+ +load+ +fieldindex+ +compoundindex+ +deepindex+ ; + + ] 2dip + [ rest ] keep first ! assoc slot options itype + { { +fieldindex+ [ drop [ 1 ] dip pick set-at ] } + { +deepindex+ [ first "%s.%s" sprintf [ 1 ] dip pick set-at ] } + { +compoundindex+ [ + 2over swap [ 1 ] 2dip set-at [ drop ] dip ! assoc options + over '[ _ [ 1 ] 2dip set-at ] each ] } + } case ; + +: build-index-seq ( slot optlist -- index-seq ) + [ V{ } clone ] 2dip pick ! v{} slot optl v{} + [ swap ] dip ! v{} optl slot v{ } + '[ _ tuple-index new ! element slot exemplar + 2over swap index-name >>name ! element slot clone + [ build-index ] dip swap >>spec _ push + ] each ; + +: is-index-declaration? ( entry -- ? ) + first + { { +fieldindex+ [ t ] } + { +compoundindex+ [ t ] } + { +deepindex+ [ t ] } + [ drop f ] } case ; + +PRIVATE> + +: tuple-index-list ( mdb-collection/class -- seq ) + mdb-slot-list V{ } clone tuck + '[ [ is-index-declaration? ] filter + build-index-seq _ push + ] assoc-each flatten ; + diff --git a/mongodb/tuple/persistent/persistent.factor b/mongodb/tuple/persistent/persistent.factor new file mode 100644 index 0000000000..9b6b8e646e --- /dev/null +++ b/mongodb/tuple/persistent/persistent.factor @@ -0,0 +1,92 @@ +USING: accessors assocs classes fry kernel linked-assocs math mirrors +namespaces sequences strings vectors words bson.constants +continuations mongodb.driver mongodb.tuple.collection mongodb.tuple.state ; + +IN: mongodb.tuple.persistent + +SYMBOL: mdb-store-list + +GENERIC: tuple>assoc ( tuple -- assoc ) + +GENERIC: tuple>selector ( tuple -- selector ) + +DEFER: assoc>tuple +DEFER: mdb-persistent? + +tuple-class ( tuple-info -- class ) + [ first ] keep second lookup ; inline + +: tuple-instance ( tuple-info -- instance ) + mdbinfo>tuple-class new ; inline + +: [keys>tuple] ( mirror assoc -- quot: ( elt -- ) ) + '[ dup _ at assoc>tuple swap _ set-at ] ; + +: prepare-assoc>tuple ( assoc -- tuple keylist mirror assoc ) + [ tuple-info tuple-instance dup + [ keys ] keep ] keep swap ; inline + +: make-tuple ( assoc -- tuple ) + prepare-assoc>tuple [keys>tuple] each + [ set-persistent ] keep ; inline + +: at+ ( value key assoc -- value ) + 2dup key? + [ at nip ] [ [ dup ] 2dip set-at ] if ; inline + +: data-tuple? ( tuple -- ? ) + dup tuple? + [ assoc? not ] [ drop f ] if ; inline + +: add-storable ( assoc ns -- ) + [ H{ } clone ] dip mdb-store-list get at+ + [ dup [ MDB_OID_FIELD ] dip at ] dip set-at ; inline + +: write-tuple-fields ( mirror assoc conv-quot -- ) + swap [ dup ] dip ! m a a q + '[ [ dup mdb-persistent? + [ _ keep + [ tuple-collection ] keep + [ add-storable ] dip + [ tuple-collection ] [ _id>> ] bi ] + [ dup data-tuple? _ [ ] if ] if _ set-at ] [ drop ] if* + ] assoc-each ; + +: prepare-assoc ( tuple -- assoc mirror assoc ) + H{ } clone tuck ; inline + +: ensure-mdb-info ( tuple -- tuple ) + dup _id>> [ >>_id ] unless + [ set-persistent ] keep ; inline + +: with-store-list ( quot: ( -- ) -- store-assoc ) + [ H{ } clone dup mdb-store-list ] dip with-variable ; inline + +: (tuple>assoc) ( tuple -- assoc ) + [ prepare-assoc [ tuple>assoc ] write-tuple-fields ] keep + over set-tuple-info ; + +PRIVATE> + +GENERIC: tuple>storable ( tuple -- storable ) +M: mdb-persistent tuple>storable ( mdb-persistent -- store-list ) + '[ _ [ tuple>assoc ] keep tuple-collection add-storable ] with-store-list ; inline + +M: mdb-persistent tuple>assoc ( tuple -- assoc ) + ensure-mdb-info (tuple>assoc) ; + +M: tuple tuple>assoc ( tuple -- assoc ) + (tuple>assoc) ; + +M: tuple tuple>selector ( tuple -- assoc ) + prepare-assoc [ tuple>selector ] write-tuple-fields ; + +: assoc>tuple ( assoc -- tuple ) + dup assoc? + [ [ dup tuple-info? + [ make-tuple ] + [ ] if ] [ drop ] recover + ] [ ] if ; inline + diff --git a/mongodb/tuple/state/state.factor b/mongodb/tuple/state/state.factor new file mode 100644 index 0000000000..1d6dde3654 --- /dev/null +++ b/mongodb/tuple/state/state.factor @@ -0,0 +1,44 @@ +USING: classes kernel accessors sequences assocs mongodb.tuple.collection ; + +IN: mongodb.tuple.state + + + +: ( tuple -- tuple-info ) + class V{ } clone tuck + [ [ name>> ] dip push ] + [ [ vocabulary>> ] dip push ] 2bi ; inline + +: tuple-info ( assoc -- tuple-info ) + [ MDB_TUPLE_INFO ] dip at ; inline + +: set-tuple-info ( tuple assoc -- ) + [ MDB_TUPLE_INFO ] dip set-at ; inline + +: tuple-info? ( assoc -- ? ) + [ MDB_TUPLE_INFO ] dip key? ; + +: tuple-meta ( tuple -- assoc ) + dup _mfd>> [ ] [ H{ } clone [ >>_mfd ] keep ] if* nip ; inline + +: dirty? ( tuple -- ? ) + MDB_DIRTY_FLAG tuple-meta at ; + +: set-dirty ( tuple -- ) + t MDB_DIRTY_FLAG tuple-meta set-at ; + +: persistent? ( tuple -- ? ) + MDB_PERSISTENT_FLAG tuple-meta at ; + +: set-persistent ( tuple -- ) + t MDB_PERSISTENT_FLAG tuple-meta set-at ; + +: needs-store? ( tuple -- ? ) + [ persistent? not ] [ dirty? ] bi or ; + diff --git a/mongodb/tuple/tuple.factor b/mongodb/tuple/tuple.factor new file mode 100644 index 0000000000..9b4f462f2e --- /dev/null +++ b/mongodb/tuple/tuple.factor @@ -0,0 +1,83 @@ +USING: accessors assocs classes classes.mixin classes.tuple vectors math +classes.tuple.parser formatting generalizations kernel sequences fry combinators +linked-assocs sequences.deep mongodb.driver continuations memoize bson.constants +prettyprint strings compiler.units slots tools.walker words arrays ; + +IN: mongodb.tuple + +USING: mongodb.tuple.state mongodb.tuple.persistent mongodb.tuple.collection +mongodb.tuple.index mongodb.msg ; + +SYNTAX: MDBTUPLE: + parse-tuple-definition + mdb-check-slots + define-tuple-class ; + +: define-persistent ( class collection options -- ) + [ [ dup ] dip link-collection ] dip ! cl options + [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip + set-slot-options ; + +: ensure-table ( class -- ) + tuple-collection + [ create-collection ] + [ [ tuple-index-list ] keep + '[ _ swap [ name>> ] [ spec>> ] bi ensure-index ] each + ] bi ; + +: ensure-tables ( classes -- ) + [ ensure-table ] each ; + +: drop-table ( class -- ) + tuple-collection + [ [ tuple-index-list ] keep + '[ _ swap name>> drop-index ] each ] + [ name>> drop-collection ] bi ; + +: recreate-table ( class -- ) + [ drop-table ] + [ ensure-table ] bi ; + +> id-selector ; + +: (save-tuples) ( collection assoc -- ) + swap '[ [ _ ] 2dip + [ id-selector ] dip + update ] assoc-each ; inline +PRIVATE> + +: save-tuple ( tuple -- ) + tuple>assoc [ (save-tuples) ] assoc-each ; + +: update-tuple ( tuple -- ) + save-tuple ; + +: insert-tuple ( tuple -- ) + save-tuple ; + +: delete-tuple ( tuple -- ) + dup persistent? + [ [ tuple-collection name>> ] keep + id-selector delete ] [ drop ] if ; + +: tuple>query ( tuple -- query ) + [ tuple-collection name>> ] keep + tuple>selector ; + +: select-tuple ( tuple/query -- tuple/f ) + dup mdb-query-msg? [ ] [ tuple>query ] if + find-one [ assoc>tuple ] [ f ] if* ; + +: select-tuples ( tuple/query -- cursor tuples/f ) + dup mdb-query-msg? [ ] [ tuple>query ] if + find [ assoc>tuple ] map ; + +: count-tuples ( tuple/query -- n ) + dup mdb-query-msg? [ tuple>query ] unless + [ collection>> ] [ query>> ] bi count ; From 3ef4784a631688624e1f7924446149c6ee7814d3 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 4 Apr 2009 11:25:38 +0200 Subject: [PATCH 059/101] fixed recursive compiler errors --- mongodb/tuple/persistent/persistent.factor | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/mongodb/tuple/persistent/persistent.factor b/mongodb/tuple/persistent/persistent.factor index 9b6b8e646e..5dfb418c0d 100644 --- a/mongodb/tuple/persistent/persistent.factor +++ b/mongodb/tuple/persistent/persistent.factor @@ -21,16 +21,14 @@ DEFER: mdb-persistent? : tuple-instance ( tuple-info -- instance ) mdbinfo>tuple-class new ; inline -: [keys>tuple] ( mirror assoc -- quot: ( elt -- ) ) - '[ dup _ at assoc>tuple swap _ set-at ] ; - : prepare-assoc>tuple ( assoc -- tuple keylist mirror assoc ) [ tuple-info tuple-instance dup [ keys ] keep ] keep swap ; inline : make-tuple ( assoc -- tuple ) - prepare-assoc>tuple [keys>tuple] each - [ set-persistent ] keep ; inline + prepare-assoc>tuple + '[ dup _ at assoc>tuple swap _ set-at ] each + [ set-persistent ] keep ; inline recursive : at+ ( value key assoc -- value ) 2dup key? @@ -88,5 +86,5 @@ M: tuple tuple>selector ( tuple -- assoc ) [ [ dup tuple-info? [ make-tuple ] [ ] if ] [ drop ] recover - ] [ ] if ; inline + ] [ ] if ; inline recursive From c80084d606e5312fe61173bb80ebffd6eea69829 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 4 Apr 2009 14:11:27 +0200 Subject: [PATCH 060/101] fixed objid / objref write and read --- bson/reader/reader.factor | 7 +++---- bson/writer/writer.factor | 22 +++++++++++++--------- 2 files changed, 16 insertions(+), 13 deletions(-) diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index ad0f8fdff8..595ca59544 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -184,12 +184,11 @@ M: bson-oid element-data-read ( type -- oid ) M: bson-binary-custom element-binary-read ( size type -- dbref ) 2drop read-cstring - read-cstring objid boa - objref boa ; + read-cstring objref boa ; M: bson-binary-uuid element-binary-read ( size type -- object ) - drop - read-sized-string + 2drop + read-cstring objid boa ; M: bson-binary-bytes element-binary-read ( size type -- bytes ) diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 3684a644d5..441bc182de 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Sascha Matzke. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs bson.constants byte-arrays byte-vectors -calendar fry io io.binary io.encodings io.encodings.string io.encodings.private -io.encodings.utf8.private io.encodings.utf8 kernel math math.parser namespaces quotations -sequences sequences.private serialize strings tools.walker words ; +calendar fry io io.binary io.encodings io.encodings.binary +io.encodings.utf8 io.streams.byte-array kernel math math.parser +namespaces quotations sequences sequences.private serialize strings +words ; IN: bson.writer @@ -126,14 +127,17 @@ M: oid bson-write ( oid -- ) [ a>> write-longlong ] [ b>> write-int32 ] bi ; M: objid bson-write ( oid -- ) - T_Binary_UUID write-byte - id>> '[ _ write-utf8-string ] with-length-prefix ; + id>> [ binary ] dip '[ _ write-cstring ] with-byte-writer + [ length write-int32 ] keep + T_Binary_UUID write-byte write ; M: objref bson-write ( objref -- ) - T_Binary_Custom write-byte + [ binary ] dip '[ _ [ ns>> write-cstring ] - [ objid>> id>> write-cstring ] bi ] with-length-prefix ; + [ objid>> id>> write-cstring ] bi ] with-byte-writer + [ length write-int32 ] keep + T_Binary_Custom write-byte write ; M: mdbregexp bson-write ( regexp -- ) [ regexp>> write-cstring ] @@ -145,8 +149,8 @@ M: sequence bson-write ( array -- ) write-eoo ] with-length-prefix ; : write-oid ( assoc -- ) - [ MDB_OID_FIELD ] dip at* - [ [ MDB_OID_FIELD ] dip write-pair ] [ drop ] if ; inline + [ MDB_OID_FIELD ] dip at + [ [ MDB_OID_FIELD ] dip write-pair ] when* ; inline : skip-field? ( name -- boolean ) { "_id" "_mfd" } member? ; inline From a61796fe7634eaa62e530c7025db3587d3b99b87 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 4 Apr 2009 16:13:56 +0200 Subject: [PATCH 061/101] another checkpoint - tuple integration seems to work --- bson/constants/constants.factor | 4 +- bson/reader/reader.factor | 5 -- bson/writer/writer.factor | 8 +--- mongodb/driver/driver.factor | 1 + mongodb/tuple/collection/collection.factor | 54 ++++++++++++++++------ mongodb/tuple/index/index.factor | 10 ++-- mongodb/tuple/persistent/persistent.factor | 19 ++++---- mongodb/tuple/state/state.factor | 10 ++-- mongodb/tuple/tuple.factor | 26 +++++------ 9 files changed, 79 insertions(+), 58 deletions(-) diff --git a/bson/constants/constants.factor b/bson/constants/constants.factor index aa852bbff8..5148413b61 100644 --- a/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -2,10 +2,8 @@ USING: accessors constructors kernel strings uuid ; IN: bson.constants -TUPLE: objid id ; - : ( -- objid ) - objid new uuid1 >>id ; inline + uuid1 ; inline TUPLE: oid { a initial: 0 } { b initial: 0 } ; diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index 595ca59544..94728b2622 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -186,11 +186,6 @@ M: bson-binary-custom element-binary-read ( size type -- dbref ) read-cstring read-cstring objref boa ; -M: bson-binary-uuid element-binary-read ( size type -- object ) - 2drop - read-cstring - objid boa ; - M: bson-binary-bytes element-binary-read ( size type -- bytes ) drop read ; diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 441bc182de..2b1fc54537 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -77,7 +77,6 @@ M: timestamp bson-type? ( timestamp -- type ) drop T_Date ; M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ; M: oid bson-type? ( word -- type ) drop T_OID ; -M: objid bson-type? ( objid -- type ) drop T_Binary ; M: objref bson-type? ( objref -- type ) drop T_Binary ; M: quotation bson-type? ( quotation -- type ) drop T_Binary ; M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; @@ -126,16 +125,11 @@ M: quotation bson-write ( quotation -- ) M: oid bson-write ( oid -- ) [ a>> write-longlong ] [ b>> write-int32 ] bi ; -M: objid bson-write ( oid -- ) - id>> [ binary ] dip '[ _ write-cstring ] with-byte-writer - [ length write-int32 ] keep - T_Binary_UUID write-byte write ; - M: objref bson-write ( objref -- ) [ binary ] dip '[ _ [ ns>> write-cstring ] - [ objid>> id>> write-cstring ] bi ] with-byte-writer + [ objid>> write-cstring ] bi ] with-byte-writer [ length write-int32 ] keep T_Binary_Custom write-byte write ; diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 1853beb81f..e15fe9b679 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -195,6 +195,7 @@ MEMO: reserved-namespace? ( name -- ? ) PRIVATE> MEMO: ensure-collection ( collection -- fq-collection ) + dup mdb-collection? [ name>> ] when "." split1 over mdb name>> = [ nip ] [ drop ] if [ ] [ reserved-namespace? ] bi diff --git a/mongodb/tuple/collection/collection.factor b/mongodb/tuple/collection/collection.factor index e5dedf1967..d75e143b7b 100644 --- a/mongodb/tuple/collection/collection.factor +++ b/mongodb/tuple/collection/collection.factor @@ -1,10 +1,16 @@ USING: accessors arrays assocs bson.constants classes classes.tuple -continuations fry kernel mongodb.driver sequences +combinators continuations fry kernel mongodb.driver sequences strings vectors words ; +IN: mongodb.tuple + +SINGLETONS: +transient+ +load+ ; + IN: mongodb.tuple.collection +FROM: mongodb.tuple => +transient+ +load+ ; + MIXIN: mdb-persistent SLOT: _id @@ -14,7 +20,7 @@ TUPLE: mdb-tuple-collection < mdb-collection { classes } ; GENERIC: tuple-collection ( object -- mdb-collection ) -GENERIC: mdb-slot-list ( tuple -- string ) +GENERIC: mdb-slot-map ( tuple -- string ) over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member? [ ] [ MDB_ADDON_SLOTS prepend ] if ; inline -: set-slot-options ( class options -- ) - '[ MDB_SLOTDEF_LIST _ optl>map set-word-prop ] keep +: set-slot-map ( class options -- ) + '[ _ optl>map MDB_SLOTDEF_LIST set-word-prop ] keep dup tuple-collection link-collection ; inline M: tuple-class tuple-collection ( tuple -- mdb-collection ) @@ -69,22 +75,44 @@ M: tuple-class tuple-collection ( tuple -- mdb-collection ) M: mdb-persistent tuple-collection ( tuple -- mdb-collection ) class (mdb-collection) ; -M: mdb-persistent mdb-slot-list ( tuple -- string ) - class (mdb-slot-list) ; +M: mdb-persistent mdb-slot-map ( tuple -- string ) + class (mdb-slot-map) ; -M: tuple-class mdb-slot-list ( class -- assoc ) - (mdb-slot-list) ; +M: tuple-class mdb-slot-map ( class -- assoc ) + (mdb-slot-map) ; -M: mdb-collection mdb-slot-list ( collection -- assoc ) - classes>> [ mdb-slot-list ] map assoc-combine ; +M: mdb-collection mdb-slot-map ( collection -- assoc ) + classes>> [ mdb-slot-map ] map assoc-combine ; + + ( name -- mdb-tuple-collection ) +PRIVATE> + +GENERIC: ( name -- mdb-tuple-collection ) +M: string ( name -- mdb-tuple-collection ) collection-map [ ] [ key? ] 2bi [ at ] [ [ mdb-tuple-collection new dup ] 2dip [ [ >>name ] keep ] dip set-at ] if ; inline +M: mdb-tuple-collection ( mdb-tuple-collection -- mdb-tuple-collection ) ; +M: mdb-collection ( mdb-collection -- mdb-tuple-collection ) + [ name>> ] keep + { + [ capped>> >>capped ] + [ size>> >>size ] + [ max>> >>max ] + } cleave ; +: transient-slot? ( tuple slot -- ? ) + +transient+ slot-option? ; + +: load-slot? ( tuple slot -- ? ) + +load+ slot-option? ; diff --git a/mongodb/tuple/index/index.factor b/mongodb/tuple/index/index.factor index 466c36f719..270fecfd38 100644 --- a/mongodb/tuple/index/index.factor +++ b/mongodb/tuple/index/index.factor @@ -1,11 +1,15 @@ USING: kernel fry accessors formatting linked-assocs assocs sequences sequences.deep mongodb.tuple.collection combinators mongodb.tuple.collection ; +IN: mongodb.tuple + +SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ ; + IN: mongodb.tuple.index -TUPLE: tuple-index name spec ; +FROM: mongodb.tuple => +fieldindex+ +compoundindex+ +deepindex+ ; -SYMBOLS: +transient+ +load+ +fieldindex+ +compoundindex+ +deepindex+ ; +TUPLE: tuple-index name spec ; : tuple-index-list ( mdb-collection/class -- seq ) - mdb-slot-list V{ } clone tuck + mdb-slot-map V{ } clone tuck '[ [ is-index-declaration? ] filter build-index-seq _ push ] assoc-each flatten ; diff --git a/mongodb/tuple/persistent/persistent.factor b/mongodb/tuple/persistent/persistent.factor index 5dfb418c0d..6d5e1837a7 100644 --- a/mongodb/tuple/persistent/persistent.factor +++ b/mongodb/tuple/persistent/persistent.factor @@ -11,7 +11,6 @@ GENERIC: tuple>assoc ( tuple -- assoc ) GENERIC: tuple>selector ( tuple -- selector ) DEFER: assoc>tuple -DEFER: mdb-persistent? > ] bi ] - [ dup data-tuple? _ [ ] if ] if _ set-at ] [ drop ] if* + [ dup data-tuple? _ [ ] if ] if swap _ set-at ] [ 2drop ] if ] assoc-each ; -: prepare-assoc ( tuple -- assoc mirror assoc ) - H{ } clone tuck ; inline +: prepare-assoc ( tuple -- assoc mirror tuple assoc ) + H{ } clone swap [ ] keep pick ; inline : ensure-mdb-info ( tuple -- tuple ) dup _id>> [ >>_id ] unless diff --git a/mongodb/tuple/state/state.factor b/mongodb/tuple/state/state.factor index 1d6dde3654..e0e045e31d 100644 --- a/mongodb/tuple/state/state.factor +++ b/mongodb/tuple/state/state.factor @@ -28,17 +28,17 @@ PRIVATE> dup _mfd>> [ ] [ H{ } clone [ >>_mfd ] keep ] if* nip ; inline : dirty? ( tuple -- ? ) - MDB_DIRTY_FLAG tuple-meta at ; + MDB_DIRTY_FLAG tuple-meta at ; : set-dirty ( tuple -- ) - t MDB_DIRTY_FLAG tuple-meta set-at ; + [ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ; : persistent? ( tuple -- ? ) - MDB_PERSISTENT_FLAG tuple-meta at ; + MDB_PERSISTENT_FLAG tuple-meta at ; : set-persistent ( tuple -- ) - t MDB_PERSISTENT_FLAG tuple-meta set-at ; + [ t MDB_PERSISTENT_FLAG ] dip tuple-meta set-at ; : needs-store? ( tuple -- ? ) - [ persistent? not ] [ dirty? ] bi or ; + [ persistent? not ] [ dirty? ] bi or ; diff --git a/mongodb/tuple/tuple.factor b/mongodb/tuple/tuple.factor index 9b4f462f2e..089a3ec121 100644 --- a/mongodb/tuple/tuple.factor +++ b/mongodb/tuple/tuple.factor @@ -1,28 +1,26 @@ -USING: accessors assocs classes classes.mixin classes.tuple vectors math -classes.tuple.parser formatting generalizations kernel sequences fry combinators -linked-assocs sequences.deep mongodb.driver continuations memoize bson.constants -prettyprint strings compiler.units slots tools.walker words arrays ; +USING: accessors assocs classes.mixin classes.tuple +classes.tuple.parser compiler.units fry kernel mongodb.driver +mongodb.msg mongodb.tuple.collection mongodb.tuple.index +mongodb.tuple.persistent mongodb.tuple.state sequences strings ; IN: mongodb.tuple -USING: mongodb.tuple.state mongodb.tuple.persistent mongodb.tuple.collection -mongodb.tuple.index mongodb.msg ; - SYNTAX: MDBTUPLE: parse-tuple-definition mdb-check-slots define-tuple-class ; : define-persistent ( class collection options -- ) + [ ] dip [ [ dup ] dip link-collection ] dip ! cl options [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip - set-slot-options ; + set-slot-map ; : ensure-table ( class -- ) tuple-collection [ create-collection ] [ [ tuple-index-list ] keep - '[ _ swap [ name>> ] [ spec>> ] bi ensure-index ] each + '[ _ name>> swap [ name>> ] [ spec>> ] bi ensure-index ] each ] bi ; : ensure-tables ( classes -- ) @@ -31,7 +29,7 @@ SYNTAX: MDBTUPLE: : drop-table ( class -- ) tuple-collection [ [ tuple-index-list ] keep - '[ _ swap name>> drop-index ] each ] + '[ _ name>> swap name>> drop-index ] each ] [ name>> drop-collection ] bi ; : recreate-table ( class -- ) @@ -41,19 +39,19 @@ SYNTAX: MDBTUPLE: > id-selector ; + _id>> id-selector ; : (save-tuples) ( collection assoc -- ) swap '[ [ _ ] 2dip [ id-selector ] dip - update ] assoc-each ; inline + >upsert update ] assoc-each ; inline PRIVATE> : save-tuple ( tuple -- ) - tuple>assoc [ (save-tuples) ] assoc-each ; + tuple>storable [ (save-tuples) ] assoc-each ; : update-tuple ( tuple -- ) save-tuple ; From 9a8270a43a22d2cb1fab51ac27492abda4cd45fb Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sun, 5 Apr 2009 20:11:35 +0200 Subject: [PATCH 062/101] some renaming now adding an advice for marking a tuple dirty --- bson/writer/writer.factor | 5 +- mongodb/tuple/persistent/persistent.factor | 68 +++++++++++++++------- mongodb/tuple/state/state.factor | 39 ++++++++++--- mongodb/tuple/tuple.factor | 9 ++- 4 files changed, 87 insertions(+), 34 deletions(-) diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 2b1fc54537..4ad1d7fdcc 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -4,7 +4,7 @@ USING: accessors assocs bson.constants byte-arrays byte-vectors calendar fry io io.binary io.encodings io.encodings.binary io.encodings.utf8 io.streams.byte-array kernel math math.parser namespaces quotations sequences sequences.private serialize strings -words ; +words combinators.short-circuit ; IN: bson.writer @@ -164,3 +164,6 @@ PRIVATE> : assoc>stream ( assoc -- ) bson-write ; inline +: mdb-special-value? ( value -- ? ) + { [ timestamp? ] [ quotation? ] [ mdbregexp? ] + [ oid? ] [ byte-array? ] } 1|| ; \ No newline at end of file diff --git a/mongodb/tuple/persistent/persistent.factor b/mongodb/tuple/persistent/persistent.factor index 6d5e1837a7..329d9cb0c7 100644 --- a/mongodb/tuple/persistent/persistent.factor +++ b/mongodb/tuple/persistent/persistent.factor @@ -1,10 +1,11 @@ -USING: accessors assocs classes fry kernel linked-assocs math mirrors -namespaces sequences strings vectors words bson.constants -continuations mongodb.driver mongodb.tuple.collection mongodb.tuple.state ; +USING: accessors assocs bson.constants combinators.short-circuit +constructors continuations fry kernel mirrors mongodb.tuple.collection +mongodb.tuple.state namespaces sequences words bson.writer combinators +hashtables linked-assocs ; IN: mongodb.tuple.persistent -SYMBOL: mdb-store-list +SYMBOLS: object-map ; GENERIC: tuple>assoc ( tuple -- assoc ) @@ -15,7 +16,7 @@ DEFER: assoc>tuple tuple-class ( tuple-info -- class ) - [ first ] keep second lookup ; inline + [ first ] keep second lookup ; inline : tuple-instance ( tuple-info -- instance ) mdbinfo>tuple-class new ; inline @@ -27,7 +28,7 @@ DEFER: assoc>tuple : make-tuple ( assoc -- tuple ) prepare-assoc>tuple '[ dup _ at assoc>tuple swap _ set-at ] each - [ set-persistent ] keep ; inline recursive + [ mark-persistent ] keep ; inline recursive : at+ ( value key assoc -- value ) 2dup key? @@ -38,21 +39,43 @@ DEFER: assoc>tuple [ assoc? not ] [ drop f ] if ; inline : add-storable ( assoc ns -- ) - [ H{ } clone ] dip mdb-store-list get at+ + [ H{ } clone ] dip object-map get at+ [ dup [ MDB_OID_FIELD ] dip at ] dip set-at ; inline : write-field? ( tuple key value -- ? ) - [ [ 2drop ] dip not ] [ drop transient-slot? ] 3bi or not ; inline + pick mdb-persistent? [ + { [ [ 2drop ] dip not ] + [ drop transient-slot? ] } 3|| not ] [ 3drop t ] if ; inline + +TUPLE: cond-value value quot ; + +CONSTRUCTOR: cond-value ( value quot -- cond-value ) ; + +: write-mdb-persistent ( value quot: ( tuple -- assoc ) -- value' ) + over needs-store? + [ over [ (( tuple -- assoc )) call-effect ] dip + [ tuple-collection name>> ] keep + [ add-storable ] dip + ] [ drop ] if + [ tuple-collection name>> ] [ _id>> ] bi ; inline + +: write-field ( value quot: ( tuple -- assoc ) -- value' ) + { + { [ dup value>> mdb-special-value? ] [ value>> ] } + { [ dup value>> mdb-persistent? ] + [ [ value>> ] [ quot>> ] bi write-mdb-persistent ] } + { [ dup value>> data-tuple? ] + [ [ value>> ] [ quot>> ] bi (( tuple -- assoc )) call-effect ] } + { [ dup value>> [ hashtable? ] [ linked-assoc? ] bi or ] + [ [ value>> ] [ quot>> ] bi '[ _ write-field ] assoc-map ] } + [ value>> ] + } cond ; inline recursive : write-tuple-fields ( mirror tuple assoc quot: ( tuple -- assoc ) -- ) - swap dupd ! m t q q a + swap ! m t q q a '[ _ 2over write-field? - [ dup mdb-persistent? - [ _ keep - [ tuple-collection ] keep - [ add-storable ] dip - [ tuple-collection ] [ _id>> ] bi ] - [ dup data-tuple? _ [ ] if ] if swap _ set-at ] [ 2drop ] if + [ _ write-field swap _ set-at ] + [ 2drop ] if ] assoc-each ; : prepare-assoc ( tuple -- assoc mirror tuple assoc ) @@ -60,20 +83,21 @@ DEFER: assoc>tuple : ensure-mdb-info ( tuple -- tuple ) dup _id>> [ >>_id ] unless - [ set-persistent ] keep ; inline + [ mark-persistent ] keep ; inline -: with-store-list ( quot: ( -- ) -- store-assoc ) - [ H{ } clone dup mdb-store-list ] dip with-variable ; inline +: with-object-map ( quot: ( -- ) -- store-assoc ) + [ H{ } clone dup object-map ] dip with-variable ; inline : (tuple>assoc) ( tuple -- assoc ) [ prepare-assoc [ tuple>assoc ] write-tuple-fields ] keep - over set-tuple-info ; + over set-tuple-info ; inline PRIVATE> -GENERIC: tuple>storable ( tuple -- storable ) -M: mdb-persistent tuple>storable ( mdb-persistent -- store-list ) - '[ _ [ tuple>assoc ] keep tuple-collection add-storable ] with-store-list ; inline +GENERIC: tuple>storable ( tuple -- storable ) + +M: mdb-persistent tuple>storable ( mdb-persistent -- object-map ) + '[ _ [ tuple>assoc ] write-mdb-persistent drop ] with-object-map ; inline M: mdb-persistent tuple>assoc ( tuple -- assoc ) ensure-mdb-info (tuple>assoc) ; diff --git a/mongodb/tuple/state/state.factor b/mongodb/tuple/state/state.factor index e0e045e31d..ace7b16c8f 100644 --- a/mongodb/tuple/state/state.factor +++ b/mongodb/tuple/state/state.factor @@ -1,4 +1,5 @@ -USING: classes kernel accessors sequences assocs mongodb.tuple.collection ; +USING: classes kernel accessors sequences fry assocs mongodb.tuple.collection +advice words classes.tuple slots ; IN: mongodb.tuple.state @@ -7,9 +8,13 @@ IN: mongodb.tuple.state CONSTANT: MDB_TUPLE_INFO "_mfd_t_info" CONSTANT: MDB_DIRTY_FLAG "d?" CONSTANT: MDB_PERSISTENT_FLAG "p?" +CONSTANT: MDB_DIRTY_ADVICE "mdb-dirty-set" PRIVATE> +: advised-with? ( name word loc -- ? ) + word-prop key? ; inline + : ( tuple -- tuple-info ) class V{ } clone tuck [ [ name>> ] dip push ] @@ -28,17 +33,35 @@ PRIVATE> dup _mfd>> [ ] [ H{ } clone [ >>_mfd ] keep ] if* nip ; inline : dirty? ( tuple -- ? ) - MDB_DIRTY_FLAG tuple-meta at ; + [ MDB_DIRTY_FLAG ] dip tuple-meta at ; -: set-dirty ( tuple -- ) - [ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ; +: mark-dirty ( tuple -- ) + [ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ; : persistent? ( tuple -- ? ) - MDB_PERSISTENT_FLAG tuple-meta at ; + [ MDB_PERSISTENT_FLAG ] dip tuple-meta at ; -: set-persistent ( tuple -- ) - [ t MDB_PERSISTENT_FLAG ] dip tuple-meta set-at ; +: mark-persistent ( tuple -- ) + [ t MDB_PERSISTENT_FLAG ] dip tuple-meta [ set-at ] keep + [ f MDB_DIRTY_FLAG ] dip set-at ; : needs-store? ( tuple -- ? ) - [ persistent? not ] [ dirty? ] bi or ; + [ persistent? not ] [ dirty? ] bi or ; + + +: annotate-writers ( class -- ) + dup all-slots [ name>> ] map + MDB_ADDON_SLOTS '[ _ memq? not ] filter + [ (annotate-writer) ] with each ; \ No newline at end of file diff --git a/mongodb/tuple/tuple.factor b/mongodb/tuple/tuple.factor index 089a3ec121..f99e32aaf1 100644 --- a/mongodb/tuple/tuple.factor +++ b/mongodb/tuple/tuple.factor @@ -1,7 +1,7 @@ USING: accessors assocs classes.mixin classes.tuple -classes.tuple.parser compiler.units fry kernel mongodb.driver +classes.tuple.parser compiler.units fry kernel sequences mongodb.driver mongodb.msg mongodb.tuple.collection mongodb.tuple.index -mongodb.tuple.persistent mongodb.tuple.state sequences strings ; +mongodb.tuple.persistent mongodb.tuple.state strings ; IN: mongodb.tuple @@ -13,7 +13,8 @@ SYNTAX: MDBTUPLE: : define-persistent ( class collection options -- ) [ ] dip [ [ dup ] dip link-collection ] dip ! cl options - [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip + [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip + [ dup annotate-writers ] dip set-slot-map ; : ensure-table ( class -- ) @@ -39,8 +40,10 @@ SYNTAX: MDBTUPLE: > id-selector ; From 57b3801992dd1aabb3c1ed11e865b21c404b058f Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Mon, 6 Apr 2009 22:43:25 +0200 Subject: [PATCH 063/101] using method word to lookup up method --- mongodb/tuple/state/state.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/mongodb/tuple/state/state.factor b/mongodb/tuple/state/state.factor index ace7b16c8f..b358cd8e38 100644 --- a/mongodb/tuple/state/state.factor +++ b/mongodb/tuple/state/state.factor @@ -1,5 +1,5 @@ USING: classes kernel accessors sequences fry assocs mongodb.tuple.collection -advice words classes.tuple slots ; +advice words classes.tuple slots generic ; IN: mongodb.tuple.state @@ -56,8 +56,7 @@ PRIVATE> [ [ [ dup mark-dirty ] MDB_DIRTY_ADVICE ] dip advise-after ] if ; : (annotate-writer) ( class name -- ) - writer-word "methods" word-prop at - [ create-advice ] when* ; + writer-word method [ create-advice ] when* ; PRIVATE> From 8965b31325224921198c37a723ae8b1da4d9dc63 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Mon, 13 Apr 2009 11:55:44 +0200 Subject: [PATCH 064/101] removed with-datastack usage (using output>array) made dirty-flag handling optional --- mongodb/tuple/collection/collection.factor | 4 ++-- mongodb/tuple/index/index.factor | 2 -- mongodb/tuple/persistent/persistent.factor | 12 ++++++------ mongodb/tuple/state/state.factor | 2 ++ 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/mongodb/tuple/collection/collection.factor b/mongodb/tuple/collection/collection.factor index d75e143b7b..939223b0b1 100644 --- a/mongodb/tuple/collection/collection.factor +++ b/mongodb/tuple/collection/collection.factor @@ -1,7 +1,7 @@ USING: accessors arrays assocs bson.constants classes classes.tuple combinators continuations fry kernel mongodb.driver sequences strings -vectors words ; +vectors words combinators.smart ; IN: mongodb.tuple @@ -50,7 +50,7 @@ CONSTANT: MDB_COLLECTION_MAP "_mdb_col_map" PRIVATE> : MDB_ADDON_SLOTS ( -- slots ) - { } [ MDB_OID_FIELD MDB_META_FIELD ] with-datastack ; inline + [ MDB_OID_FIELD MDB_META_FIELD ] output>array ; inline : link-class ( collection class -- ) over classes>> diff --git a/mongodb/tuple/index/index.factor b/mongodb/tuple/index/index.factor index 270fecfd38..1e7a679df3 100644 --- a/mongodb/tuple/index/index.factor +++ b/mongodb/tuple/index/index.factor @@ -7,8 +7,6 @@ SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ ; IN: mongodb.tuple.index -FROM: mongodb.tuple => +fieldindex+ +compoundindex+ +deepindex+ ; - TUPLE: tuple-index name spec ; > ] keep - [ add-storable ] dip - ] [ drop ] if - [ tuple-collection name>> ] [ _id>> ] bi ; inline + over needs-store? mdb-dirty-handling? get and + [ over [ (( tuple -- assoc )) call-effect ] dip + [ tuple-collection name>> ] keep + [ add-storable ] dip + ] [ drop ] if + [ tuple-collection name>> ] [ _id>> ] bi ; inline : write-field ( value quot: ( tuple -- assoc ) -- value' ) { diff --git a/mongodb/tuple/state/state.factor b/mongodb/tuple/state/state.factor index b358cd8e38..955f66c6ce 100644 --- a/mongodb/tuple/state/state.factor +++ b/mongodb/tuple/state/state.factor @@ -12,6 +12,8 @@ CONSTANT: MDB_DIRTY_ADVICE "mdb-dirty-set" PRIVATE> +SYMBOL: mdb-dirty-handling? + : advised-with? ( name word loc -- ? ) word-prop key? ; inline From c936517c4528d64bf6db74f8abb60247defac70c Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Tue, 14 Apr 2009 15:14:43 +0200 Subject: [PATCH 065/101] reworked connection handling, added mdb-pool connection pooling --- mongodb/connection/connection.factor | 82 ++++++++++++++ mongodb/driver/driver-docs.factor | 30 ----- mongodb/driver/driver.factor | 126 ++++++--------------- mongodb/tuple/collection/collection.factor | 3 +- mongodb/tuple/persistent/persistent.factor | 10 +- mongodb/tuple/tuple.factor | 5 +- 6 files changed, 124 insertions(+), 132 deletions(-) create mode 100644 mongodb/connection/connection.factor diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor new file mode 100644 index 0000000000..06394ecf0f --- /dev/null +++ b/mongodb/connection/connection.factor @@ -0,0 +1,82 @@ +USING: accessors assocs fry io.encodings.binary io.sockets kernel math +math.parser mongodb.msg mongodb.operations namespaces destructors +constructors sequences splitting ; + +IN: mongodb.connection + +TUPLE: mdb-db name username password nodes collections ; + +TUPLE: mdb-node master? inet ; + +CONSTRUCTOR: mdb-node ( inet master? -- mdb-node ) ; + +TUPLE: mdb-connection instance handle remote local ; + +: () ( name nodes -- mdb-db ) + mdb-db new swap >>nodes swap >>name H{ } clone >>collections ; + +: master-node ( mdb -- inet ) + nodes>> [ t ] dip at inet>> ; + +: slave-node ( mdb -- inet ) + nodes>> [ f ] dip at inet>> ; + +: >mdb-connection ( stream -- ) + mdb-connection set ; inline + +: mdb-connection> ( -- stream ) + mdb-connection get ; inline + +: mdb-instance ( -- mdb ) + mdb-connection> instance>> ; + + + 1 >>return# '[ _ write-message read-message ] with-client + objects>> first ; + +: split-host-str ( hoststr -- host port ) + ":" split [ first ] keep + second string>number ; inline + +: eval-ismaster-result ( node result -- node result ) + [ [ "ismaster" ] dip at + >fixnum 1 = + [ t >>master? ] [ f >>master? ] if ] keep ; + +: check-node ( node -- node remote ) + dup inet>> ismaster-cmd + eval-ismaster-result + [ "remote" ] dip at ; + +PRIVATE> + +: check-nodes ( node -- nodelist ) + check-node + [ V{ } clone [ push ] keep ] dip + [ split-host-str [ f ] dip + mdb-node boa check-node drop + swap tuck push + ] when* ; + +: verify-nodes ( -- ) + mdb-instance nodes>> [ t ] dip at + check-nodes + H{ } clone tuck + '[ dup master?>> _ set-at ] each + [ mdb-instance ] dip >>nodes drop ; + +: mdb-open ( mdb -- connection ) + mdb-connection new swap + [ >>instance ] keep + master-node [ >>remote ] keep + binary [ >>handle ] dip >>local ; inline + +: mdb-close ( mdb-connection -- ) + [ dispose f ] change-handle drop ; + +M: mdb-connection dispose + mdb-close ; \ No newline at end of file diff --git a/mongodb/driver/driver-docs.factor b/mongodb/driver/driver-docs.factor index 591a84a528..1788d81e83 100644 --- a/mongodb/driver/driver-docs.factor +++ b/mongodb/driver/driver-docs.factor @@ -212,29 +212,12 @@ HELP: load-index-list } { $description "" } ; -HELP: master>> -{ $values - { "mdb" null } - { "inet" null } -} -{ $description "" } ; - -HELP: mdb -{ $values - - { "mdb" null } -} -{ $description "" } ; - HELP: mdb-collection { $var-description "" } ; HELP: mdb-cursor { $var-description "" } ; -HELP: mdb-db -{ $var-description "" } ; - HELP: mdb-error { $values { "id" null } @@ -242,12 +225,6 @@ HELP: mdb-error } { $description "" } ; -HELP: mdb-instance -{ $var-description "" } ; - -HELP: mdb-node -{ $var-description "" } ; - HELP: r/ { $values { "token" null } @@ -277,13 +254,6 @@ HELP: skip } { $description "" } ; -HELP: slave>> -{ $values - { "mdb" null } - { "inet" null } -} -{ $description "" } ; - HELP: sort { $values { "mdb-query" null } diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index e15fe9b679..9f445d71a9 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -1,14 +1,12 @@ USING: accessors assocs bson.constants bson.writer combinators -constructors continuations destructors formatting fry io -io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs -math math.parser memoize mongodb.msg mongodb.operations namespaces -parser prettyprint sequences sets splitting strings uuid ; +constructors continuations destructors formatting fry io io.pools +io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs hashtables +math math.parser memoize mongodb.connection mongodb.msg mongodb.operations namespaces +parser prettyprint sequences sets splitting strings uuid arrays ; IN: mongodb.driver -TUPLE: mdb-node master? inet ; - -TUPLE: mdb-db name nodes collections ; +TUPLE: mdb-pool < pool { mdb mdb-db } ; TUPLE: mdb-cursor collection id return# ; @@ -23,6 +21,11 @@ TUPLE: mdb-collection : ( name -- collection ) [ mdb-collection new ] dip >>name ; inline +M: mdb-pool make-connection + mdb>> mdb-open ; + +: ( mdb -- pool ) mdb-pool swap >>mdb ; + CONSTANT: MDB-GENERAL-ERROR 1 CONSTANT: PARTIAL? "partial?" @@ -30,49 +33,24 @@ CONSTANT: DIRTY? "dirty?" ERROR: mdb-error id msg ; -SYMBOL: mdb-instance - -: mdb ( -- mdb ) - mdb-instance get ; inline - -: master>> ( mdb -- inet ) - nodes>> [ t ] dip at inet>> ; - -: slave>> ( mdb -- inet ) - nodes>> [ f ] dip at inet>> ; - >mdb-stream ( stream -- ) - mdb-socket-stream set ; inline - -: mdb-stream>> ( -- stream ) - mdb-socket-stream get ; inline - : check-ok ( result -- ? ) [ "ok" ] dip key? ; inline : >mdbregexp ( value -- regexp ) first ; inline -: prepare-mdb-session ( mdb -- stream ) - [ mdb-instance set ] keep - master>> [ remote-address set ] keep - binary local-address set ; inline - PRIVATE> SYNTAX: r/ ( token -- mdbregexp ) \ / [ >mdbregexp ] parse-literal ; : with-db ( mdb quot -- ... ) - [ [ prepare-mdb-session ] dip - [ >>mdb-stream ] prepose - with-disposal ] with-scope ; inline + swap [ mdb-open &dispose >mdb-connection ] curry + prepose with-destructors ; inline : build-id-selector ( assoc -- selector ) [ MDB_OID_FIELD swap at ] keep @@ -81,76 +59,41 @@ SYNTAX: r/ ( token -- mdbregexp ) > "%s.system.indexes" sprintf ; inline + mdb-instance name>> "%s.system.indexes" sprintf ; inline : namespaces-collection ( -- ns ) - mdb name>> "%s.system.namespaces" sprintf ; inline + mdb-instance name>> "%s.system.namespaces" sprintf ; inline : cmd-collection ( -- ns ) - mdb name>> "%s.$cmd" sprintf ; inline + mdb-instance name>> "%s.$cmd" sprintf ; inline : index-ns ( colname -- index-ns ) - [ mdb name>> ] dip "%s.%s" sprintf ; inline - -: ismaster-cmd ( node -- result ) - binary "admin.$cmd" H{ { "ismaster" 1 } } - 1 >>return# '[ _ write-message read-message ] with-client - objects>> first ; - -: split-host-str ( hoststr -- host port ) - ":" split [ first ] keep - second string>number ; inline - -: eval-ismaster-result ( node result -- node result ) - [ [ "ismaster" ] dip at - >fixnum 1 = - [ t >>master? ] [ f >>master? ] if ] keep ; - -: check-node ( node -- node remote ) - dup inet>> ismaster-cmd - eval-ismaster-result - [ "remote" ] dip at ; - -: check-nodes ( node -- nodelist ) - check-node - [ V{ } clone [ push ] keep ] dip - [ split-host-str [ f ] dip - mdb-node boa check-node drop - swap tuck push - ] when* ; - -: verify-nodes ( -- ) - mdb nodes>> [ t ] dip at - check-nodes - H{ } clone tuck - '[ dup master?>> _ set-at ] each - [ mdb ] dip >>nodes drop ; + [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline : send-message ( message -- ) - [ mdb-stream>> ] dip '[ _ write-message ] with-stream* ; + [ mdb-connection> handle>> ] dip '[ _ write-message ] with-stream* ; : send-query-plain ( query-message -- result ) - [ mdb-stream>> ] dip + [ mdb-connection> handle>> ] dip '[ _ write-message read-message ] with-stream* ; -: send-query ( query-message -- cursor result ) +: make-cursor ( mdb-result-msg -- cursor/f ) + dup cursor>> 0 > + [ [ cursor>> ] [ collection>> ] [ requested#>> ] tri ] + [ drop f ] if ; + +: send-query ( query-message -- cursor/f result ) [ send-query-plain ] keep - { [ collection>> >>collection drop ] - [ return#>> >>requested# ] - } 2cleave - [ [ cursor>> 0 > ] keep - '[ _ [ cursor>> ] [ collection>> ] [ requested#>> ] tri ] - [ f ] if - ] [ objects>> ] bi ; + [ collection>> >>collection drop ] + [ return#>> >>requested# ] 2bi + [ make-cursor ] [ objects>> ] bi ; PRIVATE> : ( db host port -- mdb ) - [ f ] 2dip mdb-node boa - check-nodes - H{ } clone tuck - '[ dup master?>> _ set-at ] each - H{ } clone mdb-db boa ; + f + check-nodes [ [ master?>> ] keep 2array ] map + >hashtable () ; GENERIC: create-collection ( name -- ) M: string create-collection @@ -181,7 +124,7 @@ M: mdb-collection create-collection ( mdb-collection -- ) '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline : (ensure-collection) ( collection -- ) - mdb collections>> dup keys length 0 = + mdb-instance collections>> dup keys length 0 = [ load-collection-list [ [ "options" ] dip key? ] filter [ [ "name" ] dip at "." split second ] map @@ -196,11 +139,11 @@ PRIVATE> MEMO: ensure-collection ( collection -- fq-collection ) dup mdb-collection? [ name>> ] when - "." split1 over mdb name>> = + "." split1 over mdb-instance name>> = [ nip ] [ drop ] if [ ] [ reserved-namespace? ] bi [ [ (ensure-collection) ] keep ] unless - [ mdb name>> ] dip "%s.%s" sprintf ; inline + [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline : ( collection query -- mdb-query ) [ ensure-collection ] dip @@ -243,7 +186,8 @@ M: mdb-query-msg explain. GENERIC: find-one ( mdb-query -- result/f ) M: mdb-query-msg find-one - 1 >>return# send-query-plain objects>> [ first ] [ f ] if* ; + 1 >>return# send-query-plain objects>> + dup empty? [ drop f ] [ first ] if ; GENERIC: count ( collection selector -- result ) M: assoc count diff --git a/mongodb/tuple/collection/collection.factor b/mongodb/tuple/collection/collection.factor index 939223b0b1..6b1371eaf1 100644 --- a/mongodb/tuple/collection/collection.factor +++ b/mongodb/tuple/collection/collection.factor @@ -66,8 +66,7 @@ PRIVATE> [ ] [ MDB_ADDON_SLOTS prepend ] if ; inline : set-slot-map ( class options -- ) - '[ _ optl>map MDB_SLOTDEF_LIST set-word-prop ] keep - dup tuple-collection link-collection ; inline + optl>map MDB_SLOTDEF_LIST set-word-prop ; inline M: tuple-class tuple-collection ( tuple -- mdb-collection ) (mdb-collection) ; diff --git a/mongodb/tuple/persistent/persistent.factor b/mongodb/tuple/persistent/persistent.factor index 9a8a5f8dc7..061b27dd1b 100644 --- a/mongodb/tuple/persistent/persistent.factor +++ b/mongodb/tuple/persistent/persistent.factor @@ -52,12 +52,10 @@ TUPLE: cond-value value quot ; CONSTRUCTOR: cond-value ( value quot -- cond-value ) ; : write-mdb-persistent ( value quot: ( tuple -- assoc ) -- value' ) - over needs-store? mdb-dirty-handling? get and - [ over [ (( tuple -- assoc )) call-effect ] dip - [ tuple-collection name>> ] keep - [ add-storable ] dip - ] [ drop ] if - [ tuple-collection name>> ] [ _id>> ] bi ; inline + over [ (( tuple -- assoc )) call-effect ] dip + [ tuple-collection name>> ] keep + [ add-storable ] dip + [ tuple-collection name>> ] [ _id>> ] bi ; inline : write-field ( value quot: ( tuple -- assoc ) -- value' ) { diff --git a/mongodb/tuple/tuple.factor b/mongodb/tuple/tuple.factor index f99e32aaf1..beb7f41384 100644 --- a/mongodb/tuple/tuple.factor +++ b/mongodb/tuple/tuple.factor @@ -11,10 +11,9 @@ SYNTAX: MDBTUPLE: define-tuple-class ; : define-persistent ( class collection options -- ) - [ ] dip - [ [ dup ] dip link-collection ] dip ! cl options + [ [ dupd link-collection ] when* ] dip [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip - [ dup annotate-writers ] dip + ! [ dup annotate-writers ] dip set-slot-map ; : ensure-table ( class -- ) From d78dc167b676b4275198003fb4e28c7f86d4a16f Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 17 Apr 2009 08:04:49 +0200 Subject: [PATCH 066/101] count word now takes a "normal" query object as argument refactored the creation/validation of collections --- mongodb/driver/driver.factor | 33 ++++++++++++++++++--------------- 1 file changed, 18 insertions(+), 15 deletions(-) diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 9f445d71a9..cfa374be7a 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -73,7 +73,9 @@ SYNTAX: r/ ( token -- mdbregexp ) : send-message ( message -- ) [ mdb-connection> handle>> ] dip '[ _ write-message ] with-stream* ; +DEFER: check-collection : send-query-plain ( query-message -- result ) + [ check-collection ] change-collection [ mdb-connection> handle>> ] dip '[ _ write-message read-message ] with-stream* ; @@ -135,9 +137,7 @@ M: mdb-collection create-collection ( mdb-collection -- ) MEMO: reserved-namespace? ( name -- ? ) [ "$cmd" = ] [ "system" head? ] bi or ; -PRIVATE> - -MEMO: ensure-collection ( collection -- fq-collection ) +MEMO: check-collection ( collection -- fq-collection ) dup mdb-collection? [ name>> ] when "." split1 over mdb-instance name>> = [ nip ] [ drop ] if @@ -145,8 +145,9 @@ MEMO: ensure-collection ( collection -- fq-collection ) [ [ (ensure-collection) ] keep ] unless [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline +PRIVATE> + : ( collection query -- mdb-query ) - [ ensure-collection ] dip ; inline GENERIC# limit 1 ( mdb-query limit# -- mdb-query ) @@ -183,19 +184,18 @@ GENERIC: explain. ( mdb-query -- ) M: mdb-query-msg explain. t >>explain find nip . ; - GENERIC: find-one ( mdb-query -- result/f ) M: mdb-query-msg find-one 1 >>return# send-query-plain objects>> dup empty? [ drop f ] [ first ] if ; -GENERIC: count ( collection selector -- result ) -M: assoc count - [ "count" H{ } clone [ set-at ] keep ] dip - [ over [ "query" ] dip set-at ] when* +GENERIC: count ( mdb-query -- result ) +M: mdb-query-msg count + [ collection>> "count" H{ } clone [ set-at ] keep ] keep + query>> [ over [ "query" ] dip set-at ] when* [ cmd-collection ] dip find-one [ check-ok ] keep '[ "n" _ at >fixnum ] [ f ] if ; - + : lasterror ( -- error ) cmd-collection H{ { "getlasterror" 1 } } find-one [ "err" ] dip at ; @@ -218,12 +218,12 @@ PRIVATE> GENERIC: save ( collection assoc -- ) M: assoc save - [ ensure-collection ] dip + [ check-collection ] dip send-message-check-error ; GENERIC: save-unsafe ( collection object -- ) M: assoc save-unsafe - [ ensure-collection ] dip + [ check-collection ] dip send-message ; GENERIC: ensure-index ( collection name spec -- ) @@ -244,7 +244,7 @@ M: assoc ensure-index check-ok [ "could not drop index" throw ] unless ; : ( collection selector object -- update-msg ) - [ ensure-collection ] 2dip ; + [ check-collection ] 2dip ; : >upsert ( mdb-update-msg -- mdb-update-msg ) 1 >>upsert? ; @@ -259,18 +259,21 @@ M: mdb-update-msg update-unsafe GENERIC: delete ( collection selector -- ) M: assoc delete - [ ensure-collection ] dip + [ check-collection ] dip send-message-check-error ; GENERIC: delete-unsafe ( collection selector -- ) M: assoc delete-unsafe - [ ensure-collection ] dip + [ check-collection ] dip send-message ; : load-index-list ( -- index-list ) index-collection H{ } clone find nip ; +: ensure-collection ( name -- ) + check-collection drop ; + : drop-collection ( name -- ) [ cmd-collection ] dip "drop" H{ } clone [ set-at ] keep From ea87b380f38604b95819e29445e3d55d152a3ff0 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Wed, 22 Apr 2009 16:09:03 +0200 Subject: [PATCH 067/101] made auto node discovery work --- bson/writer/writer.factor | 5 +- mongodb/benchmark/benchmark.factor | 28 ++-- mongodb/connection/connection.factor | 165 ++++++++++++++------- mongodb/driver/driver.factor | 47 ++---- mongodb/tuple/collection/collection.factor | 4 +- mongodb/tuple/state/state.factor | 18 +-- 6 files changed, 148 insertions(+), 119 deletions(-) diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 4ad1d7fdcc..ae12ca0a03 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -4,7 +4,7 @@ USING: accessors assocs bson.constants byte-arrays byte-vectors calendar fry io io.binary io.encodings io.encodings.binary io.encodings.utf8 io.streams.byte-array kernel math math.parser namespaces quotations sequences sequences.private serialize strings -words combinators.short-circuit ; +words combinators.short-circuit literals ; IN: bson.writer @@ -29,7 +29,6 @@ CONSTANT: INT64-SIZE 8 [ set-nth-unsafe ] keep write ] each ; inline - PRIVATE> : reset-buffer ( buffer -- ) @@ -147,7 +146,7 @@ M: sequence bson-write ( array -- ) [ [ MDB_OID_FIELD ] dip write-pair ] when* ; inline : skip-field? ( name -- boolean ) - { "_id" "_mfd" } member? ; inline + { $[ MDB_OID_FIELD MDB_META_FIELD ] } member? ; inline M: assoc bson-write ( assoc -- ) '[ _ [ write-oid ] keep diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index 424aa7732c..683f41b83b 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -131,12 +131,12 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : (insert) ( quot: ( i -- doc ) collection -- ) [ trial-size ] 2dip - '[ _ call [ _ ] dip + '[ _ call( i -- doc ) [ _ ] dip result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ; inline -: (prepare-batch) ( i b quot: ( i -- doc ) -- ) +: (prepare-batch) ( i b quot: ( i -- doc ) -- batch-seq ) [ [ * ] keep 1 range boa ] dip - '[ _ call ] map ; inline + '[ _ call( i -- doc ) ] map ; inline : (insert-batch) ( quot: ( i -- doc ) collection -- ) [ trial-size batch-size [ / ] keep ] 2dip @@ -170,10 +170,10 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ; : serialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) - '[ trial-size [ _ call assoc>bv drop ] each-integer ] ; inline + '[ trial-size [ _ call( i -- doc ) assoc>bv drop ] each-integer ] ; inline : deserialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) - [ 0 ] dip call assoc>bv + [ 0 ] dip call( i -- doc ) assoc>bv '[ trial-size [ _ binary [ H{ } stream>assoc 2drop ] with-byte-reader ] times ] ; inline : check-for-key ( assoc key -- ) @@ -240,41 +240,41 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } [ ] prepose [ print-result ] compose with-scope ; inline -: bench-quot ( feat-seq op-word -- quot: ( elt -- ) ) +: [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) ) '[ _ swap _ - '[ [ [ _ execute ] dip - [ execute ] each _ execute benchmark ] with-result ] each + '[ [ [ _ execute( -- quot: ( i -- doc ) ) ] dip + [ execute( -- ) ] each _ execute( -- quot: ( -- ) ) benchmark ] with-result ] each print-separator ] ; inline : run-serialization-bench ( doc-word-seq feat-seq -- ) "Serialization Tests" print print-separator-bold - \ serialize bench-quot each ; inline + \ serialize [bench-quot] each ; inline : run-deserialization-bench ( doc-word-seq feat-seq -- ) "Deserialization Tests" print print-separator-bold - \ deserialize bench-quot each ; inline + \ deserialize [bench-quot] each ; inline : run-insert-bench ( doc-word-seq feat-seq -- ) "Insert Tests" print print-separator-bold - \ insert bench-quot each ; inline + \ insert [bench-quot] each ; inline : run-find-one-bench ( doc-word-seq feat-seq -- ) "Query Tests - Find-One" print print-separator-bold - \ find-one bench-quot each ; inline + \ find-one [bench-quot] each ; inline : run-find-all-bench ( doc-word-seq feat-seq -- ) "Query Tests - Find-All" print print-separator-bold - \ find-all bench-quot each ; inline + \ find-all [bench-quot] each ; inline : run-find-range-bench ( doc-word-seq feat-seq -- ) "Query Tests - Find-Range" print print-separator-bold - \ find-range bench-quot each ; inline + \ find-range [bench-quot] each ; inline : run-benchmarks ( -- ) diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor index 06394ecf0f..87718a9788 100644 --- a/mongodb/connection/connection.factor +++ b/mongodb/connection/connection.factor @@ -1,79 +1,142 @@ USING: accessors assocs fry io.encodings.binary io.sockets kernel math math.parser mongodb.msg mongodb.operations namespaces destructors -constructors sequences splitting ; +constructors sequences splitting checksums checksums.md5 formatting +io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart +arrays hashtables sequences.deep vectors locals ; IN: mongodb.connection -TUPLE: mdb-db name username password nodes collections ; +: md5-checksum ( string -- digest ) + utf8 encode md5 checksum-bytes hex-string ; inline -TUPLE: mdb-node master? inet ; +TUPLE: mdb-db name username pwd-digest nodes collections ; -CONSTRUCTOR: mdb-node ( inet master? -- mdb-node ) ; +TUPLE: mdb-node master? { address inet } remote ; -TUPLE: mdb-connection instance handle remote local ; +CONSTRUCTOR: mdb-node ( address master? -- mdb-node ) ; -: () ( name nodes -- mdb-db ) +TUPLE: mdb-connection instance node handle remote local ; + +CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ; + +: check-ok ( result -- ? ) + [ "ok" ] dip at >integer 1 = ; inline + +: ( name nodes -- mdb-db ) mdb-db new swap >>nodes swap >>name H{ } clone >>collections ; -: master-node ( mdb -- inet ) - nodes>> [ t ] dip at inet>> ; +: master-node ( mdb -- node ) + nodes>> t swap at ; -: slave-node ( mdb -- inet ) - nodes>> [ f ] dip at inet>> ; - -: >mdb-connection ( stream -- ) - mdb-connection set ; inline - -: mdb-connection> ( -- stream ) - mdb-connection get ; inline +: slave-node ( mdb -- node ) + nodes>> f swap at ; +: with-connection ( connection quot -- * ) + [ mdb-connection set ] prepose with-scope ; inline + : mdb-instance ( -- mdb ) - mdb-connection> instance>> ; + mdb-connection get instance>> ; inline + +: index-collection ( -- ns ) + mdb-instance name>> "%s.system.indexes" sprintf ; inline + +: namespaces-collection ( -- ns ) + mdb-instance name>> "%s.system.namespaces" sprintf ; inline + +: cmd-collection ( -- ns ) + mdb-instance name>> "%s.$cmd" sprintf ; inline + +: index-ns ( colname -- index-ns ) + [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline + +: send-message ( message -- ) + [ mdb-connection get handle>> ] dip '[ _ write-message ] with-stream* ; + +: send-query-plain ( query-message -- result ) + [ mdb-connection get handle>> ] dip + '[ _ write-message read-message ] with-stream* ; + +: send-query-1result ( collection assoc -- result ) + + 1 >>return# + send-query-plain objects>> + [ f ] [ first ] if-empty ; - 1 >>return# '[ _ write-message read-message ] with-client - objects>> first ; +: auth? ( mdb -- ? ) + [ username>> ] [ pwd-digest>> ] bi and ; + +: calculate-key-digest ( nonce -- digest ) + mdb-instance + [ username>> ] + [ pwd-digest>> ] bi + 3array concat md5-checksum ; inline + +: build-auth-query ( -- query-assoc ) + { "authenticate" 1 } + "user" mdb-instance username>> 2array + "nonce" get-nonce 2array + 3array >hashtable + [ [ "nonce" ] dip at calculate-key-digest "key" ] keep + [ set-at ] keep ; inline + +: perform-authentication ( -- ) + cmd-collection build-auth-query send-query-1result + dup check-ok [ drop ] [ [ "errmsg" ] dip at throw ] if ; inline + +: authenticate-connection ( mdb-connection -- ) + [ mdb-connection get instance>> auth? + [ perform-authentication ] when + ] with-connection ; inline + +: open-connection ( mdb-connection node -- mdb-connection ) + [ >>node ] [ address>> ] bi + [ >>remote ] keep binary + [ >>handle ] dip >>local ; + +: get-ismaster ( -- result ) + "admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ; : split-host-str ( hoststr -- host port ) - ":" split [ first ] keep - second string>number ; inline + ":" split [ first ] [ second string>number ] bi ; inline -: eval-ismaster-result ( node result -- node result ) - [ [ "ismaster" ] dip at - >fixnum 1 = - [ t >>master? ] [ f >>master? ] if ] keep ; +: eval-ismaster-result ( node result -- ) + [ [ "ismaster" ] dip at >integer 1 = >>master? drop ] + [ [ "remote" ] dip at + [ split-host-str f >>remote ] when* + drop ] 2bi ; -: check-node ( node -- node remote ) - dup inet>> ismaster-cmd - eval-ismaster-result - [ "remote" ] dip at ; +: check-node ( mdb node -- ) + [ &dispose ] dip + [ open-connection ] keep swap + [ get-ismaster eval-ismaster-result ] with-connection ; +: nodelist>table ( seq -- assoc ) + [ [ master?>> ] keep 2array ] map >hashtable ; + PRIVATE> -: check-nodes ( node -- nodelist ) - check-node - [ V{ } clone [ push ] keep ] dip - [ split-host-str [ f ] dip - mdb-node boa check-node drop - swap tuck push - ] when* ; - -: verify-nodes ( -- ) - mdb-instance nodes>> [ t ] dip at - check-nodes - H{ } clone tuck - '[ dup master?>> _ set-at ] each - [ mdb-instance ] dip >>nodes drop ; - -: mdb-open ( mdb -- connection ) - mdb-connection new swap - [ >>instance ] keep - master-node [ >>remote ] keep - binary [ >>handle ] dip >>local ; inline +:: verify-nodes ( mdb -- ) + [ [let* | acc [ V{ } clone ] + node1 [ mdb dup master-node [ check-node ] keep ] + node2 [ mdb node1 remote>> + [ [ check-node ] keep ] + [ drop f ] if* ] + | node1 [ acc push ] when* + node2 [ acc push ] when* + mdb acc nodelist>table >>nodes drop + ] + ] with-destructors ; + +: mdb-open ( mdb -- mdb-connection ) + clone [ ] keep + master-node open-connection + [ authenticate-connection ] keep ; inline : mdb-close ( mdb-connection -- ) [ dispose f ] change-handle drop ; diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 9f445d71a9..3c61c8e4f0 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -6,7 +6,7 @@ parser prettyprint sequences sets splitting strings uuid arrays ; IN: mongodb.driver -TUPLE: mdb-pool < pool { mdb mdb-db } ; +TUPLE: mdb-pool < pool mdb ; TUPLE: mdb-cursor collection id return# ; @@ -37,9 +37,6 @@ ERROR: mdb-error id msg ; CONSTRUCTOR: mdb-cursor ( id collection return# -- cursor ) ; -: check-ok ( result -- ? ) - [ "ok" ] dip key? ; inline - : >mdbregexp ( value -- regexp ) first ; inline @@ -49,8 +46,7 @@ SYNTAX: r/ ( token -- mdbregexp ) \ / [ >mdbregexp ] parse-literal ; : with-db ( mdb quot -- ... ) - swap [ mdb-open &dispose >mdb-connection ] curry - prepose with-destructors ; inline + '[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline : build-id-selector ( assoc -- selector ) [ MDB_OID_FIELD swap at ] keep @@ -58,25 +54,6 @@ SYNTAX: r/ ( token -- mdbregexp ) > "%s.system.indexes" sprintf ; inline - -: namespaces-collection ( -- ns ) - mdb-instance name>> "%s.system.namespaces" sprintf ; inline - -: cmd-collection ( -- ns ) - mdb-instance name>> "%s.$cmd" sprintf ; inline - -: index-ns ( colname -- index-ns ) - [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline - -: send-message ( message -- ) - [ mdb-connection> handle>> ] dip '[ _ write-message ] with-stream* ; - -: send-query-plain ( query-message -- result ) - [ mdb-connection> handle>> ] dip - '[ _ write-message read-message ] with-stream* ; - : make-cursor ( mdb-result-msg -- cursor/f ) dup cursor>> 0 > [ [ cursor>> ] [ collection>> ] [ requested#>> ] tri ] @@ -91,9 +68,9 @@ SYNTAX: r/ ( token -- mdbregexp ) PRIVATE> : ( db host port -- mdb ) - f - check-nodes [ [ master?>> ] keep 2array ] map - >hashtable () ; + t [ ] keep + H{ } clone [ set-at ] keep + [ verify-nodes ] keep ; GENERIC: create-collection ( name -- ) M: string create-collection @@ -123,7 +100,10 @@ M: mdb-collection create-collection ( mdb-collection -- ) [ ";$." intersect length 0 > ] keep '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline +USE: tools.continuations + : (ensure-collection) ( collection -- ) + break mdb-instance collections>> dup keys length 0 = [ load-collection-list [ [ "options" ] dip key? ] filter @@ -240,8 +220,8 @@ M: assoc ensure-index H{ } clone [ [ "index" ] dip set-at ] keep [ [ "deleteIndexes" ] dip set-at ] keep - [ cmd-collection ] dip find-one - check-ok [ "could not drop index" throw ] unless ; + [ cmd-collection ] dip + find-one drop ; : ( collection selector object -- update-msg ) [ ensure-collection ] 2dip ; @@ -274,5 +254,8 @@ M: assoc delete-unsafe : drop-collection ( name -- ) [ cmd-collection ] dip "drop" H{ } clone [ set-at ] keep - find-one check-ok - [ "could not drop collection" throw ] unless ; + find-one drop ; + +: >pwd-digest ( user password -- digest ) + "mongo" swap 3array ":" join md5-checksum ; + diff --git a/mongodb/tuple/collection/collection.factor b/mongodb/tuple/collection/collection.factor index 6b1371eaf1..a4f86cd6a3 100644 --- a/mongodb/tuple/collection/collection.factor +++ b/mongodb/tuple/collection/collection.factor @@ -1,7 +1,7 @@ USING: accessors arrays assocs bson.constants classes classes.tuple combinators continuations fry kernel mongodb.driver sequences strings -vectors words combinators.smart ; +vectors words combinators.smart literals ; IN: mongodb.tuple @@ -50,7 +50,7 @@ CONSTANT: MDB_COLLECTION_MAP "_mdb_col_map" PRIVATE> : MDB_ADDON_SLOTS ( -- slots ) - [ MDB_OID_FIELD MDB_META_FIELD ] output>array ; inline + { $[ MDB_OID_FIELD MDB_META_FIELD ] } ; inline : link-class ( collection class -- ) over classes>> diff --git a/mongodb/tuple/state/state.factor b/mongodb/tuple/state/state.factor index 955f66c6ce..21923637e5 100644 --- a/mongodb/tuple/state/state.factor +++ b/mongodb/tuple/state/state.factor @@ -1,5 +1,5 @@ USING: classes kernel accessors sequences fry assocs mongodb.tuple.collection -advice words classes.tuple slots generic ; +words classes.tuple slots generic ; IN: mongodb.tuple.state @@ -50,19 +50,3 @@ SYMBOL: mdb-dirty-handling? : needs-store? ( tuple -- ? ) [ persistent? not ] [ dirty? ] bi or ; - - -: annotate-writers ( class -- ) - dup all-slots [ name>> ] map - MDB_ADDON_SLOTS '[ _ memq? not ] filter - [ (annotate-writer) ] with each ; \ No newline at end of file From 449f677ad8262c2c98d94a6369dad3deb3682215 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 24 Apr 2009 08:24:12 +0200 Subject: [PATCH 068/101] removed inlines from benchmark.factor added call( and execute( statements to make code compile --- mongodb/benchmark/benchmark.factor | 88 +++++++++++++++------------- mongodb/connection/connection.factor | 7 ++- mongodb/driver/driver.factor | 9 ++- 3 files changed, 54 insertions(+), 50 deletions(-) diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index 683f41b83b..ff963bcebc 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -1,6 +1,7 @@ USING: calendar math fry kernel assocs math.ranges bson.reader io.streams.byte-array sequences formatting combinators namespaces io tools.time prettyprint io.encodings.binary -accessors words mongodb.driver strings math.parser tools.walker bson.writer ; +accessors words mongodb.driver strings math.parser tools.walker bson.writer +tools.continuations ; IN: mongodb.benchmark @@ -106,25 +107,25 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : set-doc ( name -- ) [ result ] dip '[ _ >>doc ] change ; inline -: small-doc ( -- ) - "small" set-doc ; inline +: small-doc ( -- quot ) + "small" set-doc [ ] ; inline -: medium-doc ( -- ) - "medium" set-doc ; inline +: medium-doc ( -- quot ) + "medium" set-doc [ ] ; inline -: large-doc ( -- ) - "large" set-doc ; inline +: large-doc ( -- quot ) + "large" set-doc [ ] ; inline : small-doc-prepare ( -- quot: ( i -- doc ) ) - small-doc - '[ "x" DOC-SMALL clone [ set-at ] keep ] ; inline + small-doc drop + '[ "x" DOC-SMALL clone [ set-at ] keep ] ; : medium-doc-prepare ( -- quot: ( i -- doc ) ) - medium-doc - '[ "x" DOC-MEDIUM clone [ set-at ] keep ] ; inline + medium-doc drop + '[ "x" DOC-MEDIUM clone [ set-at ] keep ] ; : large-doc-prepare ( -- quot: ( i -- doc ) ) - large-doc + large-doc drop [ "x" DOC-LARGE clone [ set-at ] keep [ now "access-time" ] dip [ set-at ] keep ] ; @@ -132,36 +133,36 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : (insert) ( quot: ( i -- doc ) collection -- ) [ trial-size ] 2dip '[ _ call( i -- doc ) [ _ ] dip - result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ; inline + result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ; : (prepare-batch) ( i b quot: ( i -- doc ) -- batch-seq ) [ [ * ] keep 1 range boa ] dip - '[ _ call( i -- doc ) ] map ; inline + '[ _ call( i -- doc ) ] map ; : (insert-batch) ( quot: ( i -- doc ) collection -- ) [ trial-size batch-size [ / ] keep ] 2dip '[ _ _ (prepare-batch) [ _ ] dip result get lasterror>> [ save ] [ save-unsafe ] if - ] each-integer ; inline + ] each-integer ; : bchar ( boolean -- char ) - [ "t" ] [ "f" ] if ; inline + [ "t" ] [ "f" ] if ; inline : collection-name ( -- collection ) collection "benchmark" get* result get doc>> result get index>> bchar "%s-%s-%s" sprintf - [ [ result get ] dip >>collection drop ] keep ; inline + [ [ result get ] dip >>collection drop ] keep ; : prepare-collection ( -- collection ) collection-name [ "_x_idx" drop-index ] keep [ drop-collection ] keep - [ create-collection ] keep ; inline + [ create-collection ] keep ; : prepare-index ( collection -- ) - "_x_idx" H{ { "x" 1 } } ensure-index ; inline + "_x_idx" H{ { "x" 1 } } ensure-index ; : insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) prepare-collection @@ -170,14 +171,14 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ; : serialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) - '[ trial-size [ _ call( i -- doc ) assoc>bv drop ] each-integer ] ; inline + '[ trial-size [ _ call( i -- doc ) assoc>bv drop ] each-integer ] ; : deserialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) [ 0 ] dip call( i -- doc ) assoc>bv - '[ trial-size [ _ binary [ H{ } stream>assoc 2drop ] with-byte-reader ] times ] ; inline + '[ trial-size [ _ binary [ H{ } stream>assoc 2drop ] with-byte-reader ] times ] ; : check-for-key ( assoc key -- ) - CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ; inline + CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ; : (check-find-result) ( result -- ) "x" check-for-key ; inline @@ -185,24 +186,28 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } : (find) ( cursor -- ) [ find [ (check-find-result) ] each (find) ] when* ; inline recursive -: find-one ( -- quot: ( -- ) ) +: find-one ( quot -- quot: ( -- ) ) + drop [ trial-size collection-name trial-size 2 / "x" H{ } clone [ set-at ] keep '[ _ _ 1 limit (find) ] times ] ; -: find-all ( -- quot: ( -- ) ) - collection-name - H{ } clone - '[ _ _ (find) ] ; +: find-all ( quot -- quot: ( -- ) ) + drop + collection-name + H{ } clone + '[ _ _ (find) ] ; -: find-range ( -- quot: ( -- ) ) +: find-range ( quot -- quot: ( -- ) ) + break + drop [ trial-size batch-size /i collection-name trial-size 2 / "$gt" H{ } clone [ set-at ] keep [ trial-size 2 / batch-size + "$lt" ] dip [ set-at ] keep "x" H{ } clone [ set-at ] keep - '[ _ _ find [ "x" check-for-key ] each drop ] times ] ; + '[ _ _ (find) ] times ] ; : batch ( -- ) result [ t >>batch ] change ; inline @@ -221,7 +226,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } trial-size ] dip 1000000 / /i "%-18s: {batch:%s,index:%s;errchk:%s} %10s docs/s" - sprintf print flush ; inline + sprintf print flush ; : print-separator ( -- ) "----------------------------------------------------------------" print flush ; inline @@ -236,45 +241,44 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } sprintf print flush print-separator-bold ; -: with-result ( quot: ( -- ) -- ) - [ ] prepose - [ print-result ] compose with-scope ; inline +: with-result ( options quot -- ) + '[ _ call( options -- time ) print-result ] with-scope ; : [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) ) '[ _ swap _ - '[ [ [ _ execute( -- quot: ( i -- doc ) ) ] dip - [ execute( -- ) ] each _ execute( -- quot: ( -- ) ) benchmark ] with-result ] each - print-separator ] ; inline + '[ [ [ _ execute( -- quot ) ] dip + [ execute( -- ) ] each _ execute( quot -- quot ) benchmark ] with-result ] each + print-separator ] ; : run-serialization-bench ( doc-word-seq feat-seq -- ) "Serialization Tests" print print-separator-bold - \ serialize [bench-quot] each ; inline + \ serialize [bench-quot] '[ _ call( doc-word -- ) ] each ; : run-deserialization-bench ( doc-word-seq feat-seq -- ) "Deserialization Tests" print print-separator-bold - \ deserialize [bench-quot] each ; inline + \ deserialize [bench-quot] '[ _ call( doc-word -- ) ] each ; : run-insert-bench ( doc-word-seq feat-seq -- ) "Insert Tests" print print-separator-bold - \ insert [bench-quot] each ; inline + \ insert [bench-quot] '[ _ call( doc-word -- ) ] each ; : run-find-one-bench ( doc-word-seq feat-seq -- ) "Query Tests - Find-One" print print-separator-bold - \ find-one [bench-quot] each ; inline + \ find-one [bench-quot] '[ _ call( doc-word -- ) ] each ; : run-find-all-bench ( doc-word-seq feat-seq -- ) "Query Tests - Find-All" print print-separator-bold - \ find-all [bench-quot] each ; inline + \ find-all [bench-quot] '[ _ call( doc-word -- ) ] each ; : run-find-range-bench ( doc-word-seq feat-seq -- ) "Query Tests - Find-Range" print print-separator-bold - \ find-range [bench-quot] each ; inline + \ find-range [bench-quot] '[ _ call( doc-word -- ) ] each ; : run-benchmarks ( -- ) diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor index 87718a9788..7e5bd81f58 100644 --- a/mongodb/connection/connection.factor +++ b/mongodb/connection/connection.factor @@ -19,8 +19,9 @@ TUPLE: mdb-connection instance node handle remote local ; CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ; -: check-ok ( result -- ? ) - [ "ok" ] dip at >integer 1 = ; inline +: check-ok ( result -- errmsg ? ) + [ [ "errmsg" ] dip at ] + [ [ "ok" ] dip at >integer 1 = ] bi ; inline : ( name nodes -- mdb-db ) mdb-db new swap >>nodes swap >>name H{ } clone >>collections ; @@ -87,7 +88,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ; : perform-authentication ( -- ) cmd-collection build-auth-query send-query-1result - dup check-ok [ drop ] [ [ "errmsg" ] dip at throw ] if ; inline + check-ok [ drop ] [ throw ] if ; inline : authenticate-connection ( mdb-connection -- ) [ mdb-connection get instance>> auth? diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 426167b08e..02b2f1b7c8 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -86,7 +86,7 @@ M: mdb-collection create-collection ( mdb-collection -- ) ] 2bi ] keep 1 >>return# send-query-plain objects>> first check-ok - [ "could not create collection" throw ] unless ; + [ drop ] [ throw ] if ; : load-collection-list ( -- collection-list ) namespaces-collection @@ -101,7 +101,6 @@ M: mdb-collection create-collection ( mdb-collection -- ) USE: tools.continuations : (ensure-collection) ( collection -- ) - break mdb-instance collections>> dup keys length 0 = [ load-collection-list [ [ "options" ] dip key? ] filter @@ -170,7 +169,7 @@ M: mdb-query-msg count [ collection>> "count" H{ } clone [ set-at ] keep ] keep query>> [ over [ "query" ] dip set-at ] when* [ cmd-collection ] dip find-one - [ check-ok ] keep '[ "n" _ at >fixnum ] [ f ] if ; + [ check-ok nip ] keep '[ "n" _ at >fixnum ] [ f ] if ; : lasterror ( -- error ) cmd-collection H{ { "getlasterror" 1 } } @@ -180,8 +179,8 @@ GENERIC: validate. ( collection -- ) M: string validate. [ cmd-collection ] dip "validate" H{ } clone [ set-at ] keep - find-one [ check-ok ] keep - '[ "result" _ at print ] when ; + find-one [ check-ok nip ] keep + '[ "result" _ at print ] [ ] if ; M: mdb-collection validate. name>> validate. ; From 56bad90e732e4e0f5de9e649c49f5138d517bc78 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 24 Apr 2009 09:32:00 +0200 Subject: [PATCH 069/101] fixed collection problem (query) --- mongodb/driver/driver.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 02b2f1b7c8..d488dcc872 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -120,6 +120,9 @@ MEMO: check-collection ( collection -- fq-collection ) [ [ (ensure-collection) ] keep ] unless [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline +: fix-query-collection ( mdb-query -- mdb-query ) + [ check-collection ] change-collection ; inline + PRIVATE> : ( collection query -- mdb-query ) @@ -151,7 +154,7 @@ M: mdb-cursor get-more ( mdb-cursor -- mdb-cursor objects ) GENERIC: find ( mdb-query -- cursor result ) M: mdb-query-msg find - send-query ; + fix-query-collection send-query ; M: mdb-cursor find get-more ; @@ -161,6 +164,7 @@ M: mdb-query-msg explain. GENERIC: find-one ( mdb-query -- result/f ) M: mdb-query-msg find-one + fix-query-collection 1 >>return# send-query-plain objects>> dup empty? [ drop f ] [ first ] if ; From 7b0d5b2432d784162dd234f6f724d8ec242828fa Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 24 Apr 2009 09:32:22 +0200 Subject: [PATCH 070/101] removed breakpoint --- mongodb/benchmark/benchmark.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index ff963bcebc..110a4b5091 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -200,7 +200,6 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } '[ _ _ (find) ] ; : find-range ( quot -- quot: ( -- ) ) - break drop [ trial-size batch-size /i collection-name From d6cb050942478fdeeae07a05829f8d96897bac56 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 25 Apr 2009 10:03:09 +0200 Subject: [PATCH 071/101] removed some more inlines --- bson/reader/reader.factor | 2 +- mongodb/connection/connection.factor | 4 ++-- mongodb/driver/driver.factor | 8 +++----- mongodb/operations/operations.factor | 2 +- 4 files changed, 7 insertions(+), 9 deletions(-) diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index 94728b2622..20a0e5fbc0 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -15,7 +15,7 @@ TUPLE: state [ state new ] dip [ clone >>exemplar ] keep clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi - V{ } clone [ T_Object "" element boa swap push ] keep >>element ; inline + V{ } clone [ T_Object "" element boa swap push ] keep >>element ; PREDICATE: bson-eoo < integer T_EOO = ; PREDICATE: bson-not-eoo < integer T_EOO > ; diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor index 7e5bd81f58..7477ee5486 100644 --- a/mongodb/connection/connection.factor +++ b/mongodb/connection/connection.factor @@ -84,7 +84,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ; "nonce" get-nonce 2array 3array >hashtable [ [ "nonce" ] dip at calculate-key-digest "key" ] keep - [ set-at ] keep ; inline + [ set-at ] keep ; : perform-authentication ( -- ) cmd-collection build-auth-query send-query-1result @@ -137,7 +137,7 @@ PRIVATE> : mdb-open ( mdb -- mdb-connection ) clone [ ] keep master-node open-connection - [ authenticate-connection ] keep ; inline + [ authenticate-connection ] keep ; : mdb-close ( mdb-connection -- ) [ dispose f ] change-handle drop ; diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index d488dcc872..42ee62f1d5 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -84,9 +84,7 @@ M: mdb-collection create-collection ( mdb-collection -- ) [ [ size>> "size" ] dip set-at ] [ [ max>> "max" ] dip set-at ] 2tri ] when ] 2bi - ] keep 1 >>return# send-query-plain - objects>> first check-ok - [ drop ] [ throw ] if ; + ] keep 1 >>return# send-query-plain drop ; : load-collection-list ( -- collection-list ) namespaces-collection @@ -107,7 +105,7 @@ USE: tools.continuations [ [ "name" ] dip at "." split second ] map over '[ [ ] [ name>> ] bi _ set-at ] each ] [ ] if [ dup ] dip key? [ drop ] - [ [ ensure-valid-collection-name ] keep create-collection ] if ; inline + [ [ ensure-valid-collection-name ] keep create-collection ] if ; MEMO: reserved-namespace? ( name -- ? ) [ "$cmd" = ] [ "system" head? ] bi or ; @@ -118,7 +116,7 @@ MEMO: check-collection ( collection -- fq-collection ) [ nip ] [ drop ] if [ ] [ reserved-namespace? ] bi [ [ (ensure-collection) ] keep ] unless - [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline + [ mdb-instance name>> ] dip "%s.%s" sprintf ; : fix-query-collection ( mdb-query -- mdb-query ) [ check-collection ] change-collection ; inline diff --git a/mongodb/operations/operations.factor b/mongodb/operations/operations.factor index 6d4300fa50..001e8443e4 100644 --- a/mongodb/operations/operations.factor +++ b/mongodb/operations/operations.factor @@ -161,7 +161,7 @@ USE: tools.walker [ query>> "query" selector set-at ] } cleave selector - ] ; inline flushable + ] ; PRIVATE> From 3a94b8a90878753bafad9fdfb7f0a0458d99ec6e Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Tue, 28 Apr 2009 22:03:39 +0200 Subject: [PATCH 072/101] added functionality to deal with dead cursors (requery with offset=already read objects) --- mongodb/driver/driver.factor | 41 +++++++++++++++++++++++++++--------- mongodb/msg/msg.factor | 25 +++++++++++++--------- 2 files changed, 46 insertions(+), 20 deletions(-) diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 42ee62f1d5..267b052928 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -8,7 +8,7 @@ IN: mongodb.driver TUPLE: mdb-pool < pool mdb ; -TUPLE: mdb-cursor collection id return# ; +TUPLE: mdb-cursor id query ; UNION: boolean t POSTPONE: f ; @@ -35,7 +35,11 @@ ERROR: mdb-error id msg ; ( id query/get-more -- cursor ) +M: mdb-query-msg + mdb-cursor boa ; +M: mdb-getmore-msg + query>> mdb-cursor boa ; : >mdbregexp ( value -- regexp ) first ; inline @@ -52,16 +56,32 @@ SYNTAX: r/ ( token -- mdbregexp ) [ MDB_OID_FIELD swap at ] keep H{ } clone [ set-at ] keep ; -: make-cursor ( mdb-result-msg -- cursor/f ) - dup cursor>> 0 > - [ [ cursor>> ] [ collection>> ] [ requested#>> ] tri ] - [ drop f ] if ; +GENERIC: update-query ( result query/cursor -- ) +M: mdb-query-msg update-query + swap [ start#>> ] [ returned#>> ] bi + >>skip# drop ; +M: mdb-getmore-msg update-query + query>> update-query ; + +: make-cursor ( mdb-result-msg query/cursor -- cursor/f ) + over cursor>> 0 > + [ [ update-query ] + [ [ cursor>> ] dip ] 2bi + ] [ 2drop f ] if ; -: send-query ( query-message -- cursor/f result ) +DEFER: send-query +GENERIC: verify-query-result ( result query/get-more -- mdb-result-msg query/get-more ) +M: mdb-query-msg verify-query-result ; +M: mdb-getmore-msg verify-query-result + over flags>> ResultFlag_CursorNotFound = + [ nip query>> [ send-query-plain ] keep ] when ; + +: send-query ( query/get-more -- cursor/f result ) [ send-query-plain ] keep + verify-query-result [ collection>> >>collection drop ] - [ return#>> >>requested# ] 2bi - [ make-cursor ] [ objects>> ] bi ; + [ return#>> >>requested# ] + [ make-cursor ] 2tri + swap objects>> ; PRIVATE> @@ -147,7 +167,8 @@ M: mdb-query-msg hint ( mdb-query index-hint -- mdb-query ) GENERIC: get-more ( mdb-cursor -- mdb-cursor objects ) M: mdb-cursor get-more ( mdb-cursor -- mdb-cursor objects ) - [ [ collection>> ] [ return#>> ] [ id>> ] tri send-query ] + [ [ query>> dup [ collection>> ] [ return#>> ] bi ] + [ id>> ] bi swap >>query send-query ] [ f f ] if* ; GENERIC: find ( mdb-query -- cursor result ) diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index 7d1a8058b0..d7f8f501a5 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -12,6 +12,10 @@ CONSTANT: OP_GetMore 2005 CONSTANT: OP_Delete 2006 CONSTANT: OP_KillCursors 2007 +CONSTANT: ResultFlag_CursorNotFound 1 ! /* returned, with zero results, when getMore is called but the cursor id is not valid at the server. */ +CONSTANT: ResultFlag_ErrSet 2 ! /* { $err : ... } is being returned */ +CONSTANT: ResultFlag_ShardConfigStale 4 ! /* have to update config from the server, usually $err is also set */ + TUPLE: mdb-msg { opcode integer } { req-id integer initial: 0 } @@ -19,6 +23,15 @@ TUPLE: mdb-msg { length integer initial: 0 } { flags integer initial: 0 } ; +TUPLE: mdb-query-msg < mdb-msg +{ collection string } +{ skip# integer initial: 0 } +{ return# integer initial: 0 } +{ query assoc } +{ returnfields assoc } +{ orderby sequence } +explain hint ; + TUPLE: mdb-insert-msg < mdb-msg { collection string } { objects sequence } ; @@ -36,21 +49,13 @@ TUPLE: mdb-delete-msg < mdb-msg TUPLE: mdb-getmore-msg < mdb-msg { collection string } { return# integer initial: 0 } -{ cursor integer initial: 0 } ; +{ cursor integer initial: 0 } +{ query mdb-query-msg } ; TUPLE: mdb-killcursors-msg < mdb-msg { cursors# integer initial: 0 } { cursors sequence } ; -TUPLE: mdb-query-msg < mdb-msg -{ collection string } -{ skip# integer initial: 0 } -{ return# integer initial: 0 } -{ query assoc } -{ returnfields assoc } -{ orderby sequence } -explain hint ; - TUPLE: mdb-reply-msg < mdb-msg { collection string } { cursor integer initial: 0 } From a362ea7d6df1a73583d8081b48b0ff2479eccc98 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 22:10:18 -0500 Subject: [PATCH 073/101] Tweak http.client docs --- basis/http/client/client-docs.factor | 9 ++++++--- basis/http/client/post-data/post-data-docs.factor | 6 ++++++ 2 files changed, 12 insertions(+), 3 deletions(-) create mode 100644 basis/http/client/post-data/post-data-docs.factor diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index 0d7f7851e2..e00f8e2263 100644 --- a/basis/http/client/client-docs.factor +++ b/basis/http/client/client-docs.factor @@ -1,6 +1,7 @@ USING: http help.markup help.syntax io.pathnames io.streams.string io.encodings.8-bit io.encodings.binary kernel strings urls -urls.encoding byte-arrays strings assocs sequences destructors ; +urls.encoding byte-arrays strings assocs sequences destructors +http.client.post-data.private ; IN: http.client HELP: download-failed @@ -71,7 +72,7 @@ ARTICLE: "http.client.get" "GET requests with the HTTP client" { $subsection with-http-get } { $subsection with-http-request } ; -ARTICLE: "http.client.post-data" "HTTP client submission data" +ARTICLE: "http.client.post-data" "HTTP client post data" "HTTP POST and PUT request words take a post data parameter, which can be one of the following:" { $list { "a " { $link byte-array } ": the data is sent the server without further encoding" } @@ -85,7 +86,9 @@ ARTICLE: "http.client.post-data" "HTTP client submission data" { $code "\"my-large-post-request.txt\" ascii " "[ URL\" http://www.my-company.com/web-service\" http-post ] with-disposal" -} ; +} +"An internal word used to convert objects to " { $link post-data } " instances:" +{ $subsection >post-data } ; ARTICLE: "http.client.post" "POST requests with the HTTP client" "Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:" diff --git a/basis/http/client/post-data/post-data-docs.factor b/basis/http/client/post-data/post-data-docs.factor new file mode 100644 index 0000000000..24325e9ebd --- /dev/null +++ b/basis/http/client/post-data/post-data-docs.factor @@ -0,0 +1,6 @@ +IN: http.client.post-data +USING: http http.client.post-data.private help.markup help.syntax kernel ; + +HELP: >post-data +{ $values { "object" object } { "post-data" { $maybe post-data } } } +{ $description "Converts an object into a " { $link post-data } " tuple instance." } ; From b8b7d3861b13e81fe15fcf0bf846d55f57fdab95 Mon Sep 17 00:00:00 2001 From: slava Date: Thu, 30 Apr 2009 23:50:53 -0400 Subject: [PATCH 074/101] Fix some compiler warnings --- build-support/factor.sh | 2 +- vm/debug.c | 2 +- vm/utilities.c | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index 3ece72306a..ba5815cfc1 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -205,7 +205,7 @@ find_architecture() { write_test_program() { echo "#include " > $C_WORD.c - echo "int main(){printf(\"%ld\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c + echo "int main(){printf(\"%ld\", (long)(8*sizeof(void*))); return 0; }" >> $C_WORD.c } c_find_word_size() { diff --git a/vm/debug.c b/vm/debug.c index 6f7e883785..a9afd2c3c0 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -414,7 +414,7 @@ void factorbug(void) if(strcmp(cmd,"d") == 0) { CELL addr = read_cell_hex(); - scanf(" "); + if(scanf(" ") < 0) break; CELL count = read_cell_hex(); dump_memory(addr,addr+count); } diff --git a/vm/utilities.c b/vm/utilities.c index d97b540884..ac52772b4e 100755 --- a/vm/utilities.c +++ b/vm/utilities.c @@ -50,6 +50,6 @@ void print_fixnum(F_FIXNUM x) CELL read_cell_hex(void) { CELL cell; - scanf(CELL_HEX_FORMAT,&cell); + if(scanf(CELL_HEX_FORMAT,&cell) < 0) exit(1); return cell; }; From a70a2c0e31deac15a2921db4b0e81d81edc0228f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 22:56:15 -0500 Subject: [PATCH 075/101] Fix some test failures and add an unportable tag --- basis/compiler/tests/call-effect.factor | 9 ++++++++- basis/delegate/delegate-tests.factor | 2 +- basis/stack-checker/call-effect/call-effect.factor | 2 +- core/io/files/files-tests.factor | 2 +- core/slots/slots-tests.factor | 2 +- core/strings/strings-tests.factor | 2 +- extra/modules/using/tests/tags.txt | 1 + 7 files changed, 14 insertions(+), 6 deletions(-) create mode 100644 extra/modules/using/tests/tags.txt diff --git a/basis/compiler/tests/call-effect.factor b/basis/compiler/tests/call-effect.factor index 407250a685..a9fd313d64 100644 --- a/basis/compiler/tests/call-effect.factor +++ b/basis/compiler/tests/call-effect.factor @@ -4,4 +4,11 @@ USING: tools.test combinators generic.single sequences kernel ; : execute-ic-test ( a b -- c ) execute( a -- c ) ; ! VM type check error -[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with \ No newline at end of file +[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with + +: call-test ( q -- ) call( -- ) ; + +[ ] [ [ ] call-test ] unit-test +[ ] [ f [ drop ] curry call-test ] unit-test +[ ] [ [ ] [ ] compose call-test ] unit-test +[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with \ No newline at end of file diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index f6a40d8dc8..9f9aca8702 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -1,6 +1,6 @@ USING: delegate kernel arrays tools.test words math definitions compiler.units parser generic prettyprint io.streams.string -accessors eval multiline generic.standard delegate.protocols +accessors eval multiline generic.single delegate.protocols delegate.private assocs see ; IN: delegate.tests diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/stack-checker/call-effect/call-effect.factor index 4adc5952fd..b3b678d93d 100644 --- a/basis/stack-checker/call-effect/call-effect.factor +++ b/basis/stack-checker/call-effect/call-effect.factor @@ -19,7 +19,7 @@ IN: stack-checker.call-effect TUPLE: inline-cache value ; : cache-hit? ( word/quot ic -- ? ) - [ value>> ] [ value>> eq? ] bi and ; inline + [ value>> eq? ] [ value>> ] bi and ; inline SINGLETON: +unknown+ diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 8f0fb9e97a..f57dafbdc6 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,7 +1,7 @@ USING: arrays debugger.threads destructors io io.directories io.encodings.8-bit io.encodings.ascii io.encodings.binary io.files io.files.private io.files.temp io.files.unique kernel -make math sequences system threads tools.test generic.standard ; +make math sequences system threads tools.test generic.single ; IN: io.files.tests [ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor index 7ac8446842..1365e81524 100644 --- a/core/slots/slots-tests.factor +++ b/core/slots/slots-tests.factor @@ -1,5 +1,5 @@ IN: slots.tests -USING: math accessors slots strings generic.standard kernel +USING: math accessors slots strings generic.single kernel tools.test generic words parser eval math.functions ; TUPLE: r/w-test foo ; diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 5b71b13552..22bf7bb821 100644 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -58,7 +58,7 @@ unit-test [ "\u001234bc\0\0\0" ] [ 6 "\u001234bc" resize-string ] unit-test ! Random tester found this -[ 2 -7 resize-string ] [ { "kernel-error" 3 12 -7 } = ] must-fail-with +[ 2 -7 resize-string ] [ { "kernel-error" 3 11 -7 } = ] must-fail-with ! Make sure 24-bit strings work "hello world" "s" set diff --git a/extra/modules/using/tests/tags.txt b/extra/modules/using/tests/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/modules/using/tests/tags.txt @@ -0,0 +1 @@ +unportable From ed21047b78fb00770077841145c99647f2b4f798 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 22:59:20 -0500 Subject: [PATCH 076/101] drills.deployed: add unportable tag since it uses Cocoa binding --- extra/drills/deployed/tags.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 extra/drills/deployed/tags.txt diff --git a/extra/drills/deployed/tags.txt b/extra/drills/deployed/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/drills/deployed/tags.txt @@ -0,0 +1 @@ +unportable From 44845fdf04d0319afb8452a02c39875cb200528b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 30 Apr 2009 23:46:37 -0500 Subject: [PATCH 077/101] byte-array>sha1-hmac -> sequence>sha1-hmac etc, make more words private --- extra/crypto/hmac/hmac-tests.factor | 39 ++++++++++++++++++++++++----- extra/crypto/hmac/hmac.factor | 9 +++++-- 2 files changed, 40 insertions(+), 8 deletions(-) diff --git a/extra/crypto/hmac/hmac-tests.factor b/extra/crypto/hmac/hmac-tests.factor index eff95bbcd6..274e99d2f6 100755 --- a/extra/crypto/hmac/hmac-tests.factor +++ b/extra/crypto/hmac/hmac-tests.factor @@ -2,10 +2,37 @@ USING: kernel io strings byte-arrays sequences namespaces math parser crypto.hmac tools.test ; IN: crypto.hmac.tests -[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 "Hi There" byte-array>md5-hmac >string ] unit-test -[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" byte-array>md5-hmac >string ] unit-test -[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa 50 HEX: dd >byte-array byte-array>md5-hmac >string ] unit-test +[ + "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" +] [ + 16 11 "Hi There" sequence>md5-hmac >string ] unit-test -[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test -[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test -[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa 50 HEX: dd >byte-array byte-array>sha1-hmac >string ] unit-test +[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] +[ "Jefe" "what do ya want for nothing?" sequence>md5-hmac >string ] unit-test + +[ + "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" +] +[ + 16 HEX: aa + 50 HEX: dd sequence>md5-hmac >string +] unit-test + +[ + "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" +] [ + 16 11 "Hi There" sequence>sha1-hmac >string +] unit-test + +[ + "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" +] [ + "Jefe" "what do ya want for nothing?" sequence>sha1-hmac >string +] unit-test + +[ + "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" +] [ + 16 HEX: aa + 50 HEX: dd sequence>sha1-hmac >string +] unit-test diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor index 73b15b9473..6e6229f182 100755 --- a/extra/crypto/hmac/hmac.factor +++ b/extra/crypto/hmac/hmac.factor @@ -6,6 +6,8 @@ io.streams.byte-array kernel math math.vectors memoize sequences io.encodings.binary ; IN: crypto.hmac +sha1 get-sha1 @@ -24,6 +26,7 @@ IN: crypto.hmac [ bitxor ] 2map ; MEMO: ipad ( -- seq ) 64 HEX: 36 ; + MEMO: opad ( -- seq ) 64 HEX: 5c ; : init-hmac ( K -- o i ) @@ -31,13 +34,15 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; [ opad seq-bitxor ] keep ipad seq-bitxor ; +PRIVATE> + : stream>sha1-hmac ( K stream -- hmac ) [ init-hmac sha1-hmac ] with-input-stream ; : file>sha1-hmac ( K path -- hmac ) binary stream>sha1-hmac ; -: byte-array>sha1-hmac ( K string -- hmac ) +: sequence>sha1-hmac ( K sequence -- hmac ) binary stream>sha1-hmac ; : stream>md5-hmac ( K stream -- hmac ) @@ -46,5 +51,5 @@ MEMO: opad ( -- seq ) 64 HEX: 5c ; : file>md5-hmac ( K path -- hmac ) binary stream>md5-hmac ; -: byte-array>md5-hmac ( K string -- hmac ) +: sequence>md5-hmac ( K sequence -- hmac ) binary stream>md5-hmac ; From 982d409a8bc0694f1ee5ec857258a53ea0cac0c1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 May 2009 02:01:43 -0500 Subject: [PATCH 078/101] Fix VM compilation on Windows --- Makefile | 1 - vm/Config.unix | 1 + 2 files changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 Makefile mode change 100644 => 100755 vm/Config.unix diff --git a/Makefile b/Makefile old mode 100644 new mode 100755 index 36538b041d..33d42217a2 --- a/Makefile +++ b/Makefile @@ -10,7 +10,6 @@ VERSION = 0.92 BUNDLE = Factor.app LIBPATH = -L/usr/X11R6/lib CFLAGS = -Wall -Werror -FFI_TEST_CFLAGS = -fPIC ifdef DEBUG CFLAGS += -g -DFACTOR_DEBUG diff --git a/vm/Config.unix b/vm/Config.unix old mode 100644 new mode 100755 index 1f48847542..d7214a622b --- a/vm/Config.unix +++ b/vm/Config.unix @@ -18,6 +18,7 @@ else endif # CFLAGS += -fPIC +FFI_TEST_CFLAGS = -fPIC # LINKER = gcc -shared -o # LINK_WITH_ENGINE = '-Wl,-rpath,$$ORIGIN' -lfactor From 9d1c4f39a823e2e72654e6b9a25cd4fb722a6df5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 May 2009 02:03:22 -0500 Subject: [PATCH 079/101] Some gold plating --- basis/alien/libraries/libraries-docs.factor | 2 +- basis/io/styles/styles-docs.factor | 22 ++++++------ basis/macros/macros-docs.factor | 3 +- basis/refs/refs-docs.factor | 36 +++++++++++-------- basis/stack-checker/errors/errors-docs.factor | 7 ++-- basis/tuple-arrays/summary.txt | 1 + basis/tuple-arrays/tags.txt | 1 + core/combinators/combinators-docs.factor | 2 +- core/combinators/combinators-tests.factor | 0 core/hashtables/hashtables-docs.factor | 2 +- core/namespaces/namespaces-docs.factor | 12 +++---- core/sets/sets-docs.factor | 6 ++-- 12 files changed, 54 insertions(+), 40 deletions(-) mode change 100644 => 100755 basis/alien/libraries/libraries-docs.factor mode change 100644 => 100755 basis/io/styles/styles-docs.factor mode change 100644 => 100755 basis/macros/macros-docs.factor mode change 100644 => 100755 basis/refs/refs-docs.factor mode change 100644 => 100755 basis/stack-checker/errors/errors-docs.factor create mode 100755 basis/tuple-arrays/summary.txt create mode 100755 basis/tuple-arrays/tags.txt mode change 100644 => 100755 core/combinators/combinators-docs.factor mode change 100644 => 100755 core/combinators/combinators-tests.factor mode change 100644 => 100755 core/hashtables/hashtables-docs.factor mode change 100644 => 100755 core/namespaces/namespaces-docs.factor diff --git a/basis/alien/libraries/libraries-docs.factor b/basis/alien/libraries/libraries-docs.factor old mode 100644 new mode 100755 index c555061e58..eac7655c38 --- a/basis/alien/libraries/libraries-docs.factor +++ b/basis/alien/libraries/libraries-docs.factor @@ -15,7 +15,7 @@ HELP: libraries { $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ; HELP: library -{ $values { "name" "a string" } { "library" "a hashtable" } } +{ $values { "name" "a string" } { "library" assoc } } { $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:" { $list { { $snippet "name" } " - the full path of the C library binary" } diff --git a/basis/io/styles/styles-docs.factor b/basis/io/styles/styles-docs.factor old mode 100644 new mode 100755 index 6148394c57..8fcf12aae9 --- a/basis/io/styles/styles-docs.factor +++ b/basis/io/styles/styles-docs.factor @@ -1,17 +1,17 @@ USING: help.markup help.syntax io.streams.plain io strings -hashtables kernel quotations colors ; +hashtables kernel quotations colors assocs ; IN: io.styles HELP: stream-format -{ $values { "str" string } { "style" "a hashtable" } { "stream" "an output stream" } } +{ $values { "str" string } { "style" assoc } { "stream" "an output stream" } } { $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." $nl -"The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." } +"The " { $snippet "style" } " assoc holds character style information. See " { $link "character-styles" } "." } { $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." } $io-error ; HELP: make-block-stream -{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } } +{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" "an output stream" } } { $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "." $nl "Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output." @@ -21,7 +21,7 @@ $nl $io-error ; HELP: stream-write-table -{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" "a hashtable" } { "stream" "an output stream" } } +{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" assoc } { "stream" "an output stream" } } { $contract "Prints a table of cells produced by " { $link with-cell } "." $nl "The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." } @@ -29,13 +29,13 @@ $nl $io-error ; HELP: make-cell-stream -{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } } +{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" object } } { $contract "Creates an output stream which writes to a table cell object." } { $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." } $io-error ; HELP: make-span-stream -{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } } +{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" "an output stream" } } { $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "." $nl "Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." } @@ -43,19 +43,19 @@ $nl $io-error ; HELP: format -{ $values { "str" string } { "style" "a hashtable" } } +{ $values { "str" string } { "style" assoc } } { $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } { $notes "Details are in the documentation for " { $link stream-format } "." } $io-error ; HELP: with-nesting -{ $values { "style" "a hashtable" } { "quot" quotation } } +{ $values { "style" assoc } { "quot" quotation } } { $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." } { $notes "Details are in the documentation for " { $link make-block-stream } "." } $io-error ; HELP: tabular-output -{ $values { "style" "a hashtable" } { "quot" quotation } } +{ $values { "style" assoc } { "quot" quotation } } { $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "." $nl "The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." } @@ -85,7 +85,7 @@ HELP: write-cell $io-error ; HELP: with-style -{ $values { "style" "a hashtable" } { "quot" quotation } } +{ $values { "style" assoc } { "quot" quotation } } { $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." } { $notes "Details are in the documentation for " { $link make-span-stream } "." } $io-error ; diff --git a/basis/macros/macros-docs.factor b/basis/macros/macros-docs.factor old mode 100644 new mode 100755 index acd2c3383f..6a4672bea0 --- a/basis/macros/macros-docs.factor +++ b/basis/macros/macros-docs.factor @@ -49,6 +49,7 @@ $nl { $subsection POSTPONE: MACRO: } "A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion." { $subsection define-transform } -"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated." ; +"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated." +{ $see-also "generalizations" "fry" } ; ABOUT: "macros" diff --git a/basis/refs/refs-docs.factor b/basis/refs/refs-docs.factor old mode 100644 new mode 100755 index 9c10641c4c..9971a1d4fa --- a/basis/refs/refs-docs.factor +++ b/basis/refs/refs-docs.factor @@ -1,14 +1,18 @@ ! Copyright (C) 2007 Slava Pestov, 2009 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: boxes help.markup help.syntax kernel math namespaces ; +USING: boxes help.markup help.syntax kernel math namespaces assocs ; IN: refs ARTICLE: "refs" "References" -"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing the " { $link "refs-protocol" } "." -{ $subsection get-ref } -{ $subsection set-ref } -{ $subsection set-ref* } -{ $subsection delete-ref } +"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing a protocol." +{ $subsection "refs-protocol" } +{ $subsection "refs-impls" } +{ $subsection "refs-utils" } +"References are used by the " { $link "ui-inspector" } "." ; + +ABOUT: "refs" + +ARTICLE: "refs-impls" "Reference implementations" "References to objects:" { $subsection obj-ref } { $subsection } @@ -27,20 +31,24 @@ ARTICLE: "refs" "References" { $subsection slot-ref } { $subsection } "Using boxes as references:" -{ $subsection "box-refs" } -"References are used by the UI inspector." ; +{ $subsection "box-refs" } ; -ABOUT: "refs" +ARTICLE: "refs-utils" "Reference utilities" +{ $subsection ref-on } +{ $subsection ref-off } +{ $subsection ref-inc } +{ $subsection ref-dec } +{ $subsection set-ref* } ; -ARTICLE: "refs-protocol" "Reference Protocol" +ARTICLE: "refs-protocol" "Reference protocol" "To use a class of objects as references you must implement the reference protocol for that class, and mark your class as an instance of the " { $link ref } " mixin class. All references must implement these two words:" { $subsection get-ref } { $subsection set-ref } "References may also implement:" { $subsection delete-ref } ; -ARTICLE: "box-refs" "Using Boxes as References" -"Boxes are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ; +ARTICLE: "box-refs" "Boxes as references" +{ $link "boxes" } " are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ; HELP: ref { $class-description "A mixin class whose instances encapsulate a value which can be read, written, and deleted. Instantiable members of this class include:" { $link obj-ref } ", " { $link var-ref } ", " { $link global-var-ref } ", " { $link slot-ref } ", " { $link box } ", " { $link key-ref } ", and " { $link value-ref } "." } ; @@ -89,14 +97,14 @@ HELP: key-ref { $class-description "Instances of this class identify a key in an associative structure. New key references are created by calling " { $link } "." } ; HELP: -{ $values { "assoc" "an assoc" } { "key" object } { "key-ref" key-ref } } +{ $values { "assoc" assoc } { "key" object } { "key-ref" key-ref } } { $description "Creates a reference to a key stored in an assoc." } ; HELP: value-ref { $class-description "Instances of this class identify a value associated to a key in an associative structure. New value references are created by calling " { $link } "." } ; HELP: -{ $values { "assoc" "an assoc" } { "key" object } { "value-ref" value-ref } } +{ $values { "assoc" assoc } { "key" object } { "value-ref" value-ref } } { $description "Creates a reference to the value associated with " { $snippet "key" } " in " { $snippet "assoc" } "." } ; { get-ref set-ref delete-ref set-ref* } related-words diff --git a/basis/stack-checker/errors/errors-docs.factor b/basis/stack-checker/errors/errors-docs.factor old mode 100644 new mode 100755 index 7a87ab988d..6a67b815cd --- a/basis/stack-checker/errors/errors-docs.factor +++ b/basis/stack-checker/errors/errors-docs.factor @@ -84,8 +84,11 @@ HELP: inconsistent-recursive-call-error } ; ARTICLE: "inference-errors" "Stack checker errors" -"These conditions are thrown by " { $link "inference" } ", as well as the " { $link "compiler" } "." -$nl +"These " { $link "inference" } " failure conditions are reported in one of two ways:" +{ $list + { { $link "tools.inference" } " throws them as errors" } + { "The " { $link "compiler" } " reports them via " { $link "tools.errors" } } +} "Error thrown when insufficient information is available to calculate the stack effect of a combinator call (see " { $link "inference-combinators" } "):" { $subsection literal-expected } "Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:" diff --git a/basis/tuple-arrays/summary.txt b/basis/tuple-arrays/summary.txt new file mode 100755 index 0000000000..6f5c8b7244 --- /dev/null +++ b/basis/tuple-arrays/summary.txt @@ -0,0 +1 @@ +Efficient arrays of tuples with value semantics for elements diff --git a/basis/tuple-arrays/tags.txt b/basis/tuple-arrays/tags.txt new file mode 100755 index 0000000000..42d711b32b --- /dev/null +++ b/basis/tuple-arrays/tags.txt @@ -0,0 +1 @@ +collections diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor old mode 100644 new mode 100755 index cbef25ac38..8b301affbd --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -290,7 +290,6 @@ $nl "The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:" { $subsection call-effect } { $subsection execute-effect } -{ $subsection "call-unsafe" } "The combinator variants that do not take an effect declaration can only be used if the compiler is able to infer the stack effect by other means. See " { $link "inference-combinators" } "." { $subsection "call-unsafe" } { $see-also "effects" "inference" } ; @@ -306,6 +305,7 @@ ARTICLE: "combinators" "Combinators" { $subsection "combinators.smart" } "More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "." { $subsection "combinators-quot" } +{ $subsection "generalizations" } { $see-also "quotations" } ; ABOUT: "combinators" diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor old mode 100644 new mode 100755 diff --git a/core/hashtables/hashtables-docs.factor b/core/hashtables/hashtables-docs.factor old mode 100644 new mode 100755 index 5a19cce351..0619e798dc --- a/core/hashtables/hashtables-docs.factor +++ b/core/hashtables/hashtables-docs.factor @@ -116,7 +116,7 @@ HELP: ?set-at { $description "If the third input is an assoc, stores the key/value pair into that assoc, or else creates a new hashtable with the key/value pair as its only entry." } ; HELP: >hashtable -{ $values { "assoc" "an assoc" } { "hashtable" "a hashtable" } } +{ $values { "assoc" assoc } { "hashtable" hashtable } } { $description "Constructs a hashtable from any assoc." } ; HELP: rehash diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor old mode 100644 new mode 100755 index de4737e7b0..cd66e781d2 --- a/core/namespaces/namespaces-docs.factor +++ b/core/namespaces/namespaces-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private sequences words namespaces.private quotations vectors -math.parser math words.symbol ; +math.parser math words.symbol assocs ; IN: namespaces ARTICLE: "namespaces-combinators" "Namespace combinators" @@ -119,19 +119,19 @@ HELP: with-variable } ; HELP: make-assoc -{ $values { "quot" quotation } { "exemplar" "an assoc" } { "hash" "a new hashtable" } } +{ $values { "quot" quotation } { "exemplar" assoc } { "hash" "a new assoc" } } { $description "Calls the quotation in a new namespace of the same type as " { $snippet "exemplar" } ", and outputs this namespace when the quotation returns. Useful for quickly building assocs." } ; HELP: bind -{ $values { "ns" "a hashtable" } { "quot" quotation } } +{ $values { "ns" assoc } { "quot" quotation } } { $description "Calls the quotation in the dynamic scope of " { $snippet "ns" } ". When variables are looked up by the quotation, " { $snippet "ns" } " is checked first, and setting variables in the quotation stores them in " { $snippet "ns" } "." } ; HELP: namespace -{ $values { "namespace" "an assoc" } } +{ $values { "namespace" assoc } } { $description "Outputs the current namespace. Calls to " { $link set } " modify this namespace." } ; HELP: global -{ $values { "g" "an assoc" } } +{ $values { "g" assoc } } { $description "Outputs the global namespace. The global namespace is always checked last when looking up variable values." } ; HELP: get-global @@ -156,7 +156,7 @@ HELP: set-namestack { $description "Replaces the name stack with a copy of the given vector." } ; HELP: >n -{ $values { "namespace" "an assoc" } } +{ $values { "namespace" assoc } } { $description "Pushes a namespace on the name stack." } ; HELP: ndrop diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index a122aa1240..3670b10d3c 100755 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -1,4 +1,4 @@ -USING: kernel help.markup help.syntax sequences quotations ; +USING: kernel help.markup help.syntax sequences quotations assocs ; IN: sets ARTICLE: "sets" "Set-theoretic operations on sequences" @@ -42,7 +42,7 @@ HELP: adjoin { $side-effects "seq" } ; HELP: conjoin -{ $values { "elt" object } { "assoc" "an assoc" } } +{ $values { "elt" object } { "assoc" assoc } } { $description "Stores a key/value pair, both equal to " { $snippet "elt" } ", into the assoc." } { $examples { $example @@ -54,7 +54,7 @@ HELP: conjoin { $side-effects "assoc" } ; HELP: unique -{ $values { "seq" "a sequence" } { "assoc" "an assoc" } } +{ $values { "seq" "a sequence" } { "assoc" assoc } } { $description "Outputs a new assoc where the keys and values are equal." } { $examples { $example "USING: sets prettyprint ;" "{ 1 1 2 2 3 3 } unique ." "H{ { 1 1 } { 2 2 } { 3 3 } }" } From 85bd9209f92bc1531a0079a7216e36ee6b58ddf0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 May 2009 02:44:29 -0500 Subject: [PATCH 080/101] tools.disassembler.udis: fix careless usage --- basis/tools/disassembler/disassembler-tests.factor | 6 ++---- basis/tools/disassembler/udis/udis.factor | 13 +++++++++---- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/basis/tools/disassembler/disassembler-tests.factor b/basis/tools/disassembler/disassembler-tests.factor index 49cfb054a1..89ca265bf6 100644 --- a/basis/tools/disassembler/disassembler-tests.factor +++ b/basis/tools/disassembler/disassembler-tests.factor @@ -1,6 +1,4 @@ IN: tools.disassembler.tests -USING: math classes.tuple prettyprint.custom -tools.disassembler tools.test strings ; +USING: kernel fry vocabs tools.disassembler tools.test sequences ; -[ ] [ \ + disassemble ] unit-test -[ ] [ M\ string pprint* disassemble ] unit-test +"math" words [ [ [ ] ] dip '[ _ disassemble ] unit-test ] each \ No newline at end of file diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index 51e399c1c3..cd9dd9cf4b 100755 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -3,7 +3,7 @@ USING: tools.disassembler namespaces combinators alien alien.syntax alien.c-types lexer parser kernel sequences layouts math math.order alien.libraries -math.parser system make fry arrays ; +math.parser system make fry arrays libc destructors ; IN: tools.disassembler.udis << @@ -47,11 +47,14 @@ FUNCTION: uint ud_insn_len ( ud* u ) ; FUNCTION: char* ud_lookup_mnemonic ( int c ) ; : ( -- ud ) - "ud" + "ud" malloc-object &free dup ud_init dup cell-bits ud_set_mode dup UD_SYN_INTEL ud_set_syntax ; +: with-ud ( quot: ( ud -- ) -- ) + [ [ ] dip call ] with-destructors ; inline + SINGLETON: udis-disassembler : buf/len ( from to -- buf len ) [ drop ] [ swap - ] 2bi ; @@ -82,10 +85,12 @@ SINGLETON: udis-disassembler ] { } make ; M: udis-disassembler disassemble* ( from to -- buffer ) - [ ] 2dip { + '[ + _ _ [ drop ud_set_pc ] [ buf/len ud_set_input_buffer ] [ 2drop (disassemble) format-disassembly ] - } 3cleave ; + 3tri + ] with-ud ; udis-disassembler disassembler-backend set-global From e9e095f2407ac4c6f9373e1f1f103d1b378a93be Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 May 2009 05:52:05 -0500 Subject: [PATCH 081/101] Rename enable/disable-compiler to enable/disable-optimizer, and add with-optimizer and without-optimizer combinators --- basis/bootstrap/compiler/compiler.factor | 2 +- basis/compiler/compiler-docs.factor | 8 ++++---- basis/compiler/compiler.factor | 7 +++++-- basis/cpu/x86/32/32.factor | 2 +- basis/peg/peg-tests.factor | 4 ++-- core/compiler/units/units-tests.factor | 4 ++-- core/compiler/units/units.factor | 3 +++ 7 files changed, 18 insertions(+), 12 deletions(-) diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 6e82e16268..7940703140 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -23,7 +23,7 @@ IN: bootstrap.compiler "cpu." cpu name>> append require -enable-compiler +enable-optimizer ! Push all tuple layouts to tenured space to improve method caching gc diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index 49511fe579..306ab515a8 100644 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -4,16 +4,16 @@ compiler.units help.markup help.syntax io parser quotations sequences words ; IN: compiler -HELP: enable-compiler +HELP: enable-optimizer { $description "Enables the optimizing compiler." } ; -HELP: disable-compiler +HELP: disable-optimizer { $description "Disable the optimizing compiler." } ; ARTICLE: "compiler-usage" "Calling the optimizing compiler" "Normally, new word definitions are recompiled automatically. This can be changed:" -{ $subsection disable-compiler } -{ $subsection enable-compiler } +{ $subsection disable-optimizer } +{ $subsection enable-optimizer } "Removing a word's optimized definition:" { $subsection decompile } "Compiling a single quotation:" diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index cc9899878a..e418f0ef60 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -192,10 +192,13 @@ M: optimizing-compiler recompile ( words -- alist ) compiled get >alist ] with-scope ; -: enable-compiler ( -- ) +: with-optimizer ( quot -- ) + [ optimizing-compiler compiler-impl ] dip with-variable ; inline + +: enable-optimizer ( -- ) optimizing-compiler compiler-impl set-global ; -: disable-compiler ( -- ) +: disable-optimizer ( -- ) f compiler-impl set-global ; : recompile-all ( -- ) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index b280afc01e..10cd9c8657 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -309,7 +309,7 @@ FUNCTION: bool check_sse2 ( ) ; check_sse2 ; "-no-sse2" (command-line) member? [ - optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable + [ { check_sse2 } compile ] with-optimizer "Checking if your CPU supports SSE2..." print flush sse2? [ diff --git a/basis/peg/peg-tests.factor b/basis/peg/peg-tests.factor index 683fa328d8..cae1e05dc8 100644 --- a/basis/peg/peg-tests.factor +++ b/basis/peg/peg-tests.factor @@ -199,10 +199,10 @@ IN: peg.tests USE: compiler -[ ] [ disable-compiler ] unit-test +[ ] [ disable-optimizer ] unit-test [ ] [ "" epsilon parse drop ] unit-test -[ ] [ enable-compiler ] unit-test +[ ] [ enable-optimizer ] unit-test [ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index da2dce128f..8dce12f411 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -19,7 +19,7 @@ IN: compiler.units.tests ] unit-test [ "A" "B" ] [ - disable-compiler + disable-optimizer gensym "a" set gensym "b" set @@ -33,7 +33,7 @@ IN: compiler.units.tests ] with-compilation-unit "b" get execute - enable-compiler + enable-optimizer ] unit-test ! Check that we notify observers diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index c4a137b2ba..01ee815511 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -43,6 +43,9 @@ HOOK: recompile compiler-impl ( words -- alist ) ! Non-optimizing compiler M: f recompile [ dup def>> ] { } map>assoc ; +: without-optimizer ( quot -- ) + [ f compiler-impl ] dip with-variable ; inline + ! Trivial compiler. We don't want to touch the code heap ! during stage1 bootstrap, it would just waste time. SINGLETON: dummy-compiler From 05ecd04e2f3a90c07fdea05e6713360db2f7a337 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 May 2009 05:52:34 -0500 Subject: [PATCH 082/101] macro call sites don't need an inlined-dependency on the macro --- basis/stack-checker/transforms/transforms.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index ad46a0d227..8113a662d6 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -19,7 +19,6 @@ IN: stack-checker.transforms rstate recursive-state [ word stack quot call-transformer ] with-variable [ - word inlined-dependency depends-on values [ length meta-d shorten-by ] [ #drop, ] bi rstate infer-quot ] [ word infer-word ] if* ; From 92781739c81a6c94f25b7dfb5ff9beda651b5159 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 May 2009 06:48:33 -0500 Subject: [PATCH 083/101] Some new compiler tests --- basis/compiler/tests/generic.factor | 11 ++++++ basis/compiler/tests/redefine14.factor | 10 +++--- basis/compiler/tests/redefine17.factor | 49 ++++++++++++++++++++++++++ 3 files changed, 65 insertions(+), 5 deletions(-) create mode 100644 basis/compiler/tests/generic.factor create mode 100644 basis/compiler/tests/redefine17.factor diff --git a/basis/compiler/tests/generic.factor b/basis/compiler/tests/generic.factor new file mode 100644 index 0000000000..6b0ef2d439 --- /dev/null +++ b/basis/compiler/tests/generic.factor @@ -0,0 +1,11 @@ +IN: compiler.tests.generic +USING: tools.test math kernel compiler.units definitions ; + +GENERIC: bad ( -- ) +M: integer bad ; +M: object bad ; + +[ 0 bad ] must-fail +[ "" bad ] must-fail + +[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/redefine14.factor b/basis/compiler/tests/redefine14.factor index 807f3ed2c7..6a04eed088 100644 --- a/basis/compiler/tests/redefine14.factor +++ b/basis/compiler/tests/redefine14.factor @@ -1,8 +1,8 @@ USING: compiler.units definitions tools.test sequences ; IN: compiler.tests.redefine14 -! TUPLE: bad ; -! -! M: bad length 1 2 3 ; -! -! [ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test +TUPLE: bad ; + +M: bad length 1 2 3 ; + +[ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test diff --git a/basis/compiler/tests/redefine17.factor b/basis/compiler/tests/redefine17.factor new file mode 100644 index 0000000000..4ed3e36f4d --- /dev/null +++ b/basis/compiler/tests/redefine17.factor @@ -0,0 +1,49 @@ +IN: compiler.tests.redefine17 +USING: tools.test classes.mixin compiler.units arrays kernel.private +strings sequences vocabs definitions kernel ; + +<< "compiler.tests.redefine17" words forget-all >> + +GENERIC: bong ( a -- b ) + +M: array bong ; + +M: string bong length ; + +MIXIN: mixin + +INSTANCE: array mixin + +: blah ( a -- b ) { mixin } declare bong ; + +[ { } ] [ { } blah ] unit-test + +[ ] [ [ \ array \ mixin remove-mixin-instance ] with-compilation-unit ] unit-test + +[ ] [ [ \ string \ mixin add-mixin-instance ] with-compilation-unit ] unit-test + +[ 0 ] [ "" blah ] unit-test + +MIXIN: mixin1 + +INSTANCE: string mixin1 + +MIXIN: mixin2 + +GENERIC: billy ( a -- b ) + +M: mixin2 billy ; + +M: array billy drop "BILLY" ; + +INSTANCE: string mixin2 + +: bully ( a -- b ) { mixin1 } declare billy ; + +[ "" ] [ "" bully ] unit-test + +[ ] [ [ \ string \ mixin1 remove-mixin-instance ] with-compilation-unit ] unit-test + +[ ] [ [ \ array \ mixin1 add-mixin-instance ] with-compilation-unit ] unit-test + +[ "BILLY" ] [ { } bully ] unit-test From ff6de8a2627fe73edbe2872c7581060c88d74d12 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 1 May 2009 14:03:29 +0200 Subject: [PATCH 084/101] fixed reading boolean values --- bson/reader/reader.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bson/reader/reader.factor b/bson/reader/reader.factor index 20a0e5fbc0..96cde41c2b 100644 --- a/bson/reader/reader.factor +++ b/bson/reader/reader.factor @@ -158,7 +158,7 @@ M: bson-double element-data-read ( type -- double ) M: bson-boolean element-data-read ( type -- boolean ) drop - read-byte t = ; + read-byte 1 = ; M: bson-date element-data-read ( type -- timestamp ) drop From 661ec38c02e6f082d09ae3212f821071eb38ceab Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 1 May 2009 14:03:55 +0200 Subject: [PATCH 085/101] added metadata to mongodb.driver --- mongodb/driver/authors.txt | 1 + mongodb/driver/summary.txt | 1 + mongodb/driver/tags.txt | 1 + 3 files changed, 3 insertions(+) create mode 100644 mongodb/driver/authors.txt create mode 100644 mongodb/driver/summary.txt create mode 100644 mongodb/driver/tags.txt diff --git a/mongodb/driver/authors.txt b/mongodb/driver/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/mongodb/driver/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/mongodb/driver/summary.txt b/mongodb/driver/summary.txt new file mode 100644 index 0000000000..2ac1f95c9c --- /dev/null +++ b/mongodb/driver/summary.txt @@ -0,0 +1 @@ +A driver for the MongoDB document-oriented database (http://www.mongodb.org) diff --git a/mongodb/driver/tags.txt b/mongodb/driver/tags.txt new file mode 100644 index 0000000000..aa0d57e895 --- /dev/null +++ b/mongodb/driver/tags.txt @@ -0,0 +1 @@ +database From 8c0927f17aac60d501c8bf7452101cf949a81094 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 1 May 2009 14:04:25 +0200 Subject: [PATCH 086/101] reworked index creation added documentation for most of mongodb.driver --- mongodb/benchmark/benchmark.factor | 2 +- mongodb/driver/driver-docs.factor | 179 ++++++++++++++--------------- mongodb/driver/driver.factor | 173 ++++++++++++++++------------ mongodb/msg/msg.factor | 2 +- 4 files changed, 184 insertions(+), 172 deletions(-) diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor index 110a4b5091..02dfa8add9 100644 --- a/mongodb/benchmark/benchmark.factor +++ b/mongodb/benchmark/benchmark.factor @@ -162,7 +162,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } [ create-collection ] keep ; : prepare-index ( collection -- ) - "_x_idx" H{ { "x" 1 } } ensure-index ; + "_x_idx" [ "x" asc ] key-spec unique-index ensure-index ; : insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) prepare-collection diff --git a/mongodb/driver/driver-docs.factor b/mongodb/driver/driver-docs.factor index 1788d81e83..48d7f7b65f 100644 --- a/mongodb/driver/driver-docs.factor +++ b/mongodb/driver/driver-docs.factor @@ -10,7 +10,8 @@ HELP: } { $description "Creates a new mdb-collection instance. Use this to create capped/limited collections. See also: " { $link mdb-collection } } { $examples - { $example "\"mycollection\" t >>capped" } } ; + { $example "! creates a mdb-collection instance capped to a maximum of 1000000 entries" + "\"mycollection\" t >>capped 1000000 >>max" } } ; HELP: { $values @@ -26,8 +27,8 @@ HELP: HELP: { $values { "collection" "collection to query" } - { "query" "query assoc" } - { "mdb-query" "mdb-query-msg instance" } + { "assoc" "query assoc" } + { "mdb-query-msg" "mdb-query-msg instance" } } { $description "Creates a new mdb-query-msg instance. " "This word must be called from within a with-db scope." @@ -41,176 +42,164 @@ HELP: { "collection" "collection to update" } { "selector" "selector assoc (selects which object(s) to update" } { "object" "updated object or update instruction" } - { "update-msg" "mdb-update-msg instance" } + { "mdb-update-msg" "mdb-update-msg instance" } } -{ $description "" } ; +{ $description "Creates an update message for the object(s) identified by the given selector." + "MongoDB supports full object updates as well as partial update modifiers such as $set, $inc or $push" + "For more information see: " { $url "http://www.mongodb.org/display/DOCS/Updates" } } ; HELP: >upsert { $values - { "mdb-update-msg" null } - { "mdb-update-msg" null } + { "mdb-update-msg" "a mdb-update-msg" } + { "mdb-update-msg" "mdb-update-msg with the upsert indicator set to t" } } -{ $description "" } ; - -HELP: DIRTY? -{ $values - - { "value" null } -} -{ $description "" } ; - -HELP: MDB-GENERAL-ERROR -{ $values - - { "value" null } -} -{ $description "" } ; +{ $description "Marks a mdb-update-msg as upsert operation" + "(inserts object identified by the update selector if it doesn't exist in the collection)" } ; HELP: PARTIAL? -{ $values - - { "value" null } +{ $values + { "value" "partial?" } } -{ $description "" } ; +{ $description "key which refers to a partially loaded object" } ; HELP: asc { $values - { "key" null } - { "spec" null } + { "key" "sort key" } + { "spec" "sort spec" } } -{ $description "" } ; - -HELP: boolean -{ $var-description "" } ; +{ $description "indicates that the values of the specified key should be sorted in ascending order" } ; HELP: count { $values - { "collection" null } - { "query" null } - { "result" null } + { "mdb-query-msg" "query" } + { "result" "number of objects in the collection that match the query" } } -{ $description "" } ; +{ $description "count objects in a collection" } ; HELP: create-collection { $values - { "name" null } + { "name" "collection name" } } -{ $description "" } ; +{ $description "Creates a new collection with the given name." } ; HELP: delete { $values - { "collection" null } - { "selector" null } + { "collection" "a collection" } + { "selector" "assoc which identifies the objects to be removed from the collection" } } -{ $description "" } ; +{ $description "removes objects from the collection (with lasterror check)" } ; HELP: delete-unsafe { $values - { "collection" null } - { "selector" null } + { "collection" "a collection" } + { "selector" "assoc which identifies the objects to be removed from the collection" } } -{ $description "" } ; +{ $description "removes objects from the collection (without error check)" } ; HELP: desc { $values - { "key" null } - { "spec" null } + { "key" "sort key" } + { "spec" "sort spec" } } -{ $description "" } ; +{ $description "indicates that the values of the specified key should be sorted in descending order" } ; HELP: drop-collection { $values - { "name" null } + { "name" "a collection" } } -{ $description "" } ; +{ $description "removes the collection and all objects in it from the database" } ; HELP: drop-index { $values - { "collection" null } - { "name" null } + { "collection" "a collection" } + { "name" "an index name" } } -{ $description "" } ; +{ $description "drops the specified index from the collection" } ; HELP: ensure-collection { $values - { "collection" null } - { "fq-collection" null } + { "collection" "a collection; e.g. mycollection " } + { "fq-collection" "full qualified collection name; e.g. db.mycollection" } } -{ $description "" } ; +{ $description "ensures that the collection exists in the database and returns its full qualified name" } ; HELP: ensure-index { $values - { "collection" null } - { "name" null } - { "spec" null } + { "collection" "a collection" } + { "name" "index name" } + { "spec" "index spec" } } -{ $description "" } ; +{ $description "Ensures the existence of the given index. " + "For more information on MongoDB indexes see: " { $url "http://www.mongodb.org/display/DOCS/Indexes" } } +{ $examples + { $example "\"mycollection\" nameIdx [ \"name\" asc ] keyspec ensure-index" } + { $example "\"mycollection\" nameIdx [ \"name\" asc ] keyspec unique-index ensure-index" } } ; HELP: explain. { $values - { "mdb-query" null } + { "mdb-query-msg" "a query message" } } -{ $description "" } ; +{ $description "Prints the execution plan for the given query" } ; HELP: find { $values - { "mdb-query" null } - { "cursor" null } - { "result" null } + { "mdb-query" "a query" } + { "cursor" "a cursor (if there are more results) or f" } + { "result" "a sequences of objects" } } -{ $description "" } ; +{ $description "executes the given query" } +{ $examples + { $example "\"mycollection\" H{ { \"name\" \"Alfred\" } } find " } } ; HELP: find-one { $values - { "mdb-query" null } - { "result" null } + { "mdb-query" "a query" } + { "result" "a single object or f" } } -{ $description "" } ; - -HELP: get-more -{ $values - { "mdb-cursor" null } - { "mdb-cursor" null } - { "objects" null } -} -{ $description "" } ; +{ $description "Executes the query and returns one object at most" } ; HELP: hint { $values - { "mdb-query" null } - { "index-hint" null } - { "mdb-query" null } + { "mdb-query" "a query" } + { "index-hint" "a hint to an index" } + { "mdb-query" "modified query object" } } -{ $description "" } ; +{ $description "Annotates the query with a hint to an index. " + "For detailed information see: " { $url "http://www.mongodb.org/display/DOCS/Optimizing+Mongo+Performance#OptimizingMongoPerformance-Hint" } } +{ $examples + { $example "\"mycollection\" H{ { \"name\" \"Alfred\" } { \"age\" 70 } } H{ { \"name\" 1 } } hint find" } } ; HELP: lasterror { $values - { "error" null } + { "error" "error message or f" } } -{ $description "" } ; +{ $description "Checks if the last operation resulted in an error on the MongoDB side" + "For more information see: " { $url "http://www.mongodb.org/display/DOCS/Mongo+Commands#MongoCommands-LastErrorCommands" } } ; HELP: limit { $values - { "mdb-query" null } - { "limit#" null } - { "mdb-query" null } + { "mdb-query" "a query" } + { "limit#" "number of objects that should be returned at most" } + { "mdb-query" "modified query object" } } -{ $description "" } ; +{ $description "Limits the number of returned objects to limit#" } +{ $examples + { $example "\"mycollection\" H{ } 10 limit find" } } ; HELP: load-collection-list { $values - { "collection-list" null } + { "collection-list" "list of collections in the current database" } } -{ $description "" } ; +{ $description "Returns a list of all collections that exist in the current database" } ; HELP: load-index-list { $values - { "index-list" null } + { "index-list" "list of indexes" } } -{ $description "" } ; +{ $description "Returns a list of all indexes that exist in the current database" } ; HELP: mdb-collection { $var-description "" } ; @@ -220,8 +209,7 @@ HELP: mdb-cursor HELP: mdb-error { $values - { "id" null } - { "msg" null } + { "msg" "error message" } } { $description "" } ; @@ -234,10 +222,11 @@ HELP: r/ HELP: save { $values - { "collection" null } - { "assoc" assoc } + { "collection" "a collection" } + { "assoc" "object" } } -{ $description "" } ; +{ $description "Saves the object to the given collection." + " If the object contains a field name \"_id\" this command automatically performs an update (with upsert) instead of a plain save" } ; HELP: save-unsafe { $values diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index 267b052928..355838b82d 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -1,8 +1,8 @@ -USING: accessors assocs bson.constants bson.writer combinators +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 -math math.parser memoize mongodb.connection mongodb.msg mongodb.operations namespaces -parser prettyprint sequences sets splitting strings uuid arrays ; +namespaces parser prettyprint sequences sets splitting strings uuid arrays +math math.parser memoize mongodb.connection mongodb.msg mongodb.operations ; IN: mongodb.driver @@ -10,72 +10,72 @@ TUPLE: mdb-pool < pool mdb ; TUPLE: mdb-cursor id query ; -UNION: boolean t POSTPONE: f ; - TUPLE: mdb-collection { name string } { capped boolean initial: f } { size integer initial: -1 } { max integer initial: -1 } ; -: ( name -- collection ) - [ mdb-collection new ] dip >>name ; inline +CONSTRUCTOR: mdb-collection ( name -- collection ) ; + +TUPLE: index-spec +{ ns string } { name string } { key hashtable } { unique? boolean initial: f } ; + +CONSTRUCTOR: index-spec ( ns name key -- index-spec ) ; + +: unique-index ( index-spec -- index-spec ) + t >>unique? ; M: mdb-pool make-connection mdb>> mdb-open ; -: ( mdb -- pool ) mdb-pool swap >>mdb ; - -CONSTANT: MDB-GENERAL-ERROR 1 +: ( mdb -- pool ) [ mdb-pool ] dip >>mdb ; inline CONSTANT: PARTIAL? "partial?" -CONSTANT: DIRTY? "dirty?" -ERROR: mdb-error id msg ; +ERROR: mdb-error msg ; + +: >pwd-digest ( user password -- digest ) + "mongo" swap 3array ":" join md5-checksum ; ( id query/get-more -- cursor ) +GENERIC: ( id mdb-query-msg/mdb-getmore-msg -- mdb-cursor ) + M: mdb-query-msg mdb-cursor boa ; + M: mdb-getmore-msg query>> mdb-cursor boa ; : >mdbregexp ( value -- regexp ) first ; inline -PRIVATE> +GENERIC: update-query ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- ) -SYNTAX: r/ ( token -- mdbregexp ) - \ / [ >mdbregexp ] parse-literal ; - -: with-db ( mdb quot -- ... ) - '[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline - -: build-id-selector ( assoc -- selector ) - [ MDB_OID_FIELD swap at ] keep - H{ } clone [ set-at ] keep ; - -GENERIC: update-query ( result query/cursor -- ) M: mdb-query-msg update-query swap [ start#>> ] [ returned#>> ] bi + >>skip# drop ; + M: mdb-getmore-msg update-query query>> update-query ; -: make-cursor ( mdb-result-msg query/cursor -- cursor/f ) +: make-cursor ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f ) over cursor>> 0 > [ [ update-query ] [ [ cursor>> ] dip ] 2bi ] [ 2drop f ] if ; DEFER: send-query -GENERIC: verify-query-result ( result query/get-more -- mdb-result-msg query/get-more ) + +GENERIC: verify-query-result ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-result-msg mdb-query-msg/mdb-getmore-msg ) + M: mdb-query-msg verify-query-result ; + M: mdb-getmore-msg verify-query-result over flags>> ResultFlag_CursorNotFound = [ nip query>> [ send-query-plain ] keep ] when ; -: send-query ( query/get-more -- cursor/f result ) +: send-query ( mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f seq ) [ send-query-plain ] keep verify-query-result [ collection>> >>collection drop ] @@ -85,16 +85,27 @@ M: mdb-getmore-msg verify-query-result PRIVATE> +SYNTAX: r/ ( token -- mdbregexp ) + \ / [ >mdbregexp ] parse-literal ; + +: with-db ( mdb quot -- * ) + '[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline + +: >id-selector ( assoc -- selector ) + [ MDB_OID_FIELD swap at ] keep + H{ } clone [ set-at ] keep ; + : ( db host port -- mdb ) t [ ] keep H{ } clone [ set-at ] keep [ verify-nodes ] keep ; GENERIC: create-collection ( name -- ) + M: string create-collection create-collection ; -M: mdb-collection create-collection ( mdb-collection -- ) +M: mdb-collection create-collection [ cmd-collection ] dip [ [ [ name>> "create" ] dip set-at ] @@ -116,8 +127,6 @@ M: mdb-collection create-collection ( mdb-collection -- ) [ ";$." intersect length 0 > ] keep '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline -USE: tools.continuations - : (ensure-collection) ( collection -- ) mdb-instance collections>> dup keys length 0 = [ load-collection-list @@ -127,10 +136,10 @@ USE: tools.continuations [ dup ] dip key? [ drop ] [ [ ensure-valid-collection-name ] keep create-collection ] if ; -MEMO: reserved-namespace? ( name -- ? ) +: reserved-namespace? ( name -- ? ) [ "$cmd" = ] [ "system" head? ] bi or ; - -MEMO: check-collection ( collection -- fq-collection ) + +: check-collection ( collection -- fq-collection ) dup mdb-collection? [ name>> ] when "." split1 over mdb-instance name>> = [ nip ] [ drop ] if @@ -140,54 +149,67 @@ MEMO: check-collection ( collection -- fq-collection ) : fix-query-collection ( mdb-query -- mdb-query ) [ check-collection ] change-collection ; inline - -PRIVATE> -: ( collection query -- mdb-query ) - ; inline +GENERIC: get-more ( mdb-cursor -- mdb-cursor seq ) -GENERIC# limit 1 ( mdb-query limit# -- mdb-query ) -M: mdb-query-msg limit ( query limit# -- mdb-query ) - >>return# ; inline - -GENERIC# skip 1 ( mdb-query skip# -- mdb-query ) -M: mdb-query-msg skip ( query skip# -- mdb-query ) - >>skip# ; inline - -: asc ( key -- spec ) [ 1 ] dip H{ } clone [ set-at ] keep ; inline -: desc ( key -- spec ) [ -1 ] dip H{ } clone [ set-at ] keep ; inline - -GENERIC# sort 1 ( mdb-query quot -- mdb-query ) -M: mdb-query-msg sort ( query qout -- mdb-query ) - [ { } ] dip with-datastack >>orderby ; - -GENERIC# hint 1 ( mdb-query index-hint -- mdb-query ) -M: mdb-query-msg hint ( mdb-query index-hint -- mdb-query ) - >>hint ; - -GENERIC: get-more ( mdb-cursor -- mdb-cursor objects ) -M: mdb-cursor get-more ( mdb-cursor -- mdb-cursor objects ) +M: mdb-cursor get-more [ [ query>> dup [ collection>> ] [ return#>> ] bi ] [ id>> ] bi swap >>query send-query ] [ f f ] if* ; -GENERIC: find ( mdb-query -- cursor result ) +PRIVATE> + +: ( collection assoc -- mdb-query-msg ) + ; inline + +GENERIC# limit 1 ( mdb-query-msg limit# -- mdb-query ) + +M: mdb-query-msg limit + >>return# ; inline + +GENERIC# skip 1 ( mdb-query-msg skip# -- mdb-query-msg ) + +M: mdb-query-msg skip + >>skip# ; inline + +: asc ( key -- spec ) 1 2array ; inline +: desc ( key -- spec ) -1 2array ; inline + +GENERIC# sort 1 ( mdb-query-msg sort-quot -- mdb-query-msg ) + +M: mdb-query-msg sort + output>array >>orderby ; inline + +: key-spec ( spec-quot -- spec-assoc ) + output>array >hashtable ; inline + +GENERIC# hint 1 ( mdb-query-msg index-hint -- mdb-query-msg ) + +M: mdb-query-msg hint + >>hint ; + +GENERIC: find ( mdb-query-msg/mdb-cursor -- mdb-cursor seq ) + M: mdb-query-msg find fix-query-collection send-query ; + M: mdb-cursor find get-more ; -GENERIC: explain. ( mdb-query -- ) +GENERIC: explain. ( mdb-query-msg -- ) + M: mdb-query-msg explain. t >>explain find nip . ; -GENERIC: find-one ( mdb-query -- result/f ) +GENERIC: find-one ( mdb-query-msg -- result/f ) + M: mdb-query-msg find-one fix-query-collection 1 >>return# send-query-plain objects>> dup empty? [ drop f ] [ first ] if ; -GENERIC: count ( mdb-query -- result ) +GENERIC: count ( mdb-query-msg -- result ) + M: mdb-query-msg count [ collection>> "count" H{ } clone [ set-at ] keep ] keep query>> [ over [ "query" ] dip set-at ] when* @@ -199,18 +221,20 @@ M: mdb-query-msg count find-one [ "err" ] dip at ; GENERIC: validate. ( collection -- ) + M: string validate. [ cmd-collection ] dip "validate" H{ } clone [ set-at ] keep find-one [ check-ok nip ] keep '[ "result" _ at print ] [ ] if ; + M: mdb-collection validate. name>> validate. ; @@ -224,15 +248,16 @@ M: assoc save-unsafe [ check-collection ] dip send-message ; -GENERIC: ensure-index ( collection name spec -- ) -M: assoc ensure-index - H{ } clone - [ [ uuid1 "_id" ] dip set-at ] keep - [ [ "key" ] dip set-at ] keep - [ [ "name" ] dip set-at ] keep - [ [ index-ns "ns" ] dip set-at ] keep - [ index-collection ] dip - save ; +GENERIC: ensure-index ( index-spec -- ) +M: index-spec ensure-index + [ [ uuid1 "_id" ] dip set-at ] keep + [ { [ [ name>> "name" ] dip set-at ] + [ [ ns>> index-ns "ns" ] dip set-at ] + [ [ key>> "key" ] dip set-at ] + [ swap unique?>> + [ swap [ "unique" ] dip set-at ] [ drop ] if* ] } 2cleave + ] keep + [ index-collection ] dip save ; : drop-index ( collection name -- ) H{ } clone @@ -277,6 +302,4 @@ M: assoc delete-unsafe "drop" H{ } clone [ set-at ] keep find-one drop ; -: >pwd-digest ( user password -- digest ) - "mongo" swap 3array ":" join md5-checksum ; diff --git a/mongodb/msg/msg.factor b/mongodb/msg/msg.factor index d7f8f501a5..dd8bae8438 100644 --- a/mongodb/msg/msg.factor +++ b/mongodb/msg/msg.factor @@ -91,7 +91,7 @@ M: sequence ( collection sequence -- mdb-insert-msg ) [ >>collection ] dip >>objects OP_Insert >>opcode ; -M: hashtable ( collection assoc -- mdb-insert-msg ) +M: assoc ( collection assoc -- mdb-insert-msg ) [ mdb-insert-msg new ] 2dip [ >>collection ] dip V{ } clone tuck push From 38cc644eca6d74f3bede557b7dab3d05af8fba94 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 May 2009 07:05:41 -0500 Subject: [PATCH 087/101] tools.deploy.test: close stdin --- basis/tools/deploy/test/test.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/tools/deploy/test/test.factor b/basis/tools/deploy/test/test.factor index eb780e40cc..f997a6eb3a 100644 --- a/basis/tools/deploy/test/test.factor +++ b/basis/tools/deploy/test/test.factor @@ -16,4 +16,5 @@ IN: tools.deploy.test : run-temp-image ( -- ) vm "-i=" "test.image" temp-file append - 2array try-process ; \ No newline at end of file + 2array + swap >>command +closed+ >>stdin try-process ; \ No newline at end of file From b79245dc6ccc3ba89a4fbdf5ef29b8a6d9ea86d4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 May 2009 07:21:56 -0500 Subject: [PATCH 088/101] Adding and removing vocabs now updates all-vocabs-seq --- basis/tools/vocabs/vocabs.factor | 11 +++++++++-- core/vocabs/vocabs.factor | 23 ++++++++++++++++++++--- 2 files changed, 29 insertions(+), 5 deletions(-) diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index ba99a41eba..4b9a72a443 100644 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -74,8 +74,6 @@ SYMBOL: failures SYMBOL: changed-vocabs -[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook - : changed-vocab ( vocab -- ) dup vocab changed-vocabs get and [ dup changed-vocabs get set-at ] [ drop ] if ; @@ -287,3 +285,12 @@ MEMO: all-authors ( -- seq ) \ all-vocabs-seq reset-memoized \ all-authors reset-memoized \ all-tags reset-memoized ; + +SINGLETON: cache-observer + +M: cache-observer vocabs-changed drop reset-cache ; + +[ + f changed-vocabs set-global + cache-observer add-vocab-observer +] "tools.vocabs" add-init-hook \ No newline at end of file diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 2b978e8666..73ffd1a80c 100644 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs strings kernel sorting namespaces -sequences definitions ; +sequences definitions init ; IN: vocabs SYMBOL: dictionary @@ -65,8 +65,24 @@ M: object vocab-main vocab vocab-main ; M: f vocab-main ; +SYMBOL: vocab-observers + +GENERIC: vocabs-changed ( obj -- ) + +[ V{ } clone vocab-observers set-global ] "vocabs" add-init-hook + +: add-vocab-observer ( obj -- ) + vocab-observers get push ; + +: remove-vocab-observer ( obj -- ) + vocab-observers get delq ; + +: notify-vocab-observers ( -- ) + vocab-observers get [ vocabs-changed ] each ; + : create-vocab ( name -- vocab ) - dictionary get [ ] cache ; + dictionary get [ ] cache + notify-vocab-observers ; ERROR: no-vocab name ; @@ -99,7 +115,8 @@ M: string >vocab-link dup vocab [ ] [ ] ?if ; : forget-vocab ( vocab -- ) dup words forget-all - vocab-name dictionary get delete-at ; + vocab-name dictionary get delete-at + notify-vocab-observers ; M: vocab-spec forget* forget-vocab ; From a1d28c8243d4280b4712ae0229223930e996b154 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 May 2009 07:29:03 -0500 Subject: [PATCH 089/101] Improve UI listener completion behavior --- basis/documents/elements/elements.factor | 7 +++++++ basis/ui/tools/listener/completion/completion.factor | 6 +++--- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/basis/documents/elements/elements.factor b/basis/documents/elements/elements.factor index f485f1bec1..0776f8f158 100644 --- a/basis/documents/elements/elements.factor +++ b/basis/documents/elements/elements.factor @@ -79,6 +79,13 @@ M: one-word-elt next-elt drop [ f next-word ] modify-col ; +SINGLETON: word-start-elt + +M: word-start-elt prev-elt + drop one-word-elt prev-elt ; + +M: word-start-elt next-elt 2drop ; + SINGLETON: word-elt M: word-elt prev-elt diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor index 17216bd656..fdba400c3d 100644 --- a/basis/ui/tools/listener/completion/completion.factor +++ b/basis/ui/tools/listener/completion/completion.factor @@ -39,7 +39,7 @@ M: history-completion completion-quot drop '[ drop _ history-list ] ; GENERIC: completion-element ( completion-mode -- element ) -M: object completion-element drop one-word-elt ; +M: object completion-element drop word-start-elt ; M: history-completion completion-element drop one-line-elt ; GENERIC: completion-banner ( completion-mode -- string ) @@ -72,13 +72,13 @@ M: vocab-completion row-color drop vocab? COLOR: black COLOR: dark-gray ? ; : complete-IN:/USE:? ( tokens -- ? ) - 2 short tail* { "IN:" "USE:" } intersects? ; + 1 short head* 2 short tail* { "IN:" "USE:" } intersects? ; : chop-; ( seq -- seq' ) { ";" } split1-last [ ] [ ] ?if ; : complete-USING:? ( tokens -- ? ) - chop-; { "USING:" } intersects? ; + chop-; 1 short head* { "USING:" } intersects? ; : complete-CHAR:? ( tokens -- ? ) 2 short tail* "CHAR:" swap member? ; From cc5655a55708d6e2f4f6e8c385ad27489fcd64a3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 May 2009 07:36:31 -0500 Subject: [PATCH 090/101] gesture>string: S+C+z not S+C+Z --- basis/ui/gestures/gestures.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index c7db0839d7..7e038ef2e0 100644 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -310,16 +310,16 @@ HOOK: keysym>string os ( keysym -- string ) M: macosx keysym>string >upper ; -M: object keysym>string ; +M: object keysym>string dup length 1 = [ >lower ] when ; M: key-down gesture>string [ mods>> ] [ sym>> ] bi { { [ dup { [ length 1 = ] [ first LETTER? ] } 1&& ] [ [ S+ prefix ] dip ] } { [ dup " " = ] [ drop "SPACE" ] } - [ keysym>string ] + [ ] } cond - [ modifiers>string ] dip append ; + [ modifiers>string ] [ keysym>string ] bi* append ; M: button-up gesture>string [ From eed7b20c7f7dc1f7cceb819d768e317db6048732 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 May 2009 07:36:47 -0500 Subject: [PATCH 091/101] ui.tools.browser: don't add current page to history if re-displaying it again --- basis/ui/tools/browser/browser.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index a493d5d7d2..1b8af1dd03 100644 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -25,7 +25,10 @@ M: browser-gadget set-history-value : show-help ( link browser-gadget -- ) [ >link ] dip - [ [ add-recent ] [ history>> add-history ] bi* ] + [ + 2dup model>> value>> = + [ 2drop ] [ [ add-recent ] [ history>> add-history ] bi* ] if + ] [ model>> set-model ] 2bi ; From 31c2ede034fe312a8358e618c03213fe7972619c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 May 2009 07:43:50 -0500 Subject: [PATCH 092/101] ui.gadgets.sliders: fix usability issue --- basis/ui/gadgets/sliders/sliders.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index 6cfb83a49a..80829d7b66 100644 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/basis/ui/gadgets/sliders/sliders.factor @@ -53,8 +53,8 @@ CONSTANT: min-thumb-dim 30 [ slider-max* 1 max ] bi / ; -: slider>screen ( m slider -- n ) slider-scale * elevator-padding + ; -: screen>slider ( m slider -- n ) [ elevator-padding - ] dip slider-scale / ; +: slider>screen ( m slider -- n ) slider-scale * ; +: screen>slider ( m slider -- n ) slider-scale / ; M: slider model-changed nip elevator>> relayout-1 ; @@ -133,7 +133,7 @@ elevator H{ swap >>orientation ; : thumb-loc ( slider -- loc ) - [ slider-value ] keep slider>screen ; + [ slider-value ] keep slider>screen elevator-padding + ; : layout-thumb-loc ( thumb slider -- ) [ thumb-loc ] [ orientation>> ] bi n*v From 5e32a53011b1f5c19048080d81c67b9c70d4e3fa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 May 2009 08:05:48 -0500 Subject: [PATCH 093/101] Fix circularity --- core/continuations/continuations.factor | 4 +++- core/init/init.factor | 5 ++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 56ac4a71e9..d46b73f83d 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays vectors kernel kernel.private sequences namespaces make math splitting sorting quotations assocs -combinators combinators.private accessors words ; +combinators combinators.private accessors words init ; IN: continuations SYMBOL: error @@ -200,3 +200,5 @@ M: condition compute-restarts "kernel-error" 6 setenv ; PRIVATE> + +[ init-catchstack init-error-handler ] "continuations" add-init-hook \ No newline at end of file diff --git a/core/init/init.factor b/core/init/init.factor index 5d8e88b85f..70464a4ba4 100644 --- a/core/init/init.factor +++ b/core/init/init.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: continuations continuations.private kernel -kernel.private sequences assocs namespaces namespaces.private ; +USING: kernel kernel.private sequences assocs namespaces namespaces.private ; IN: init SYMBOL: init-hooks @@ -15,7 +14,7 @@ init-hooks global [ drop V{ } clone ] cache drop dup init-hooks get at [ over call( -- ) ] unless init-hooks get set-at ; -: boot ( -- ) init-namespaces init-catchstack init-error-handler ; +: boot ( -- ) init-namespaces ; : boot-quot ( -- quot ) 20 getenv ; From 0b9212a2d63261a96a7a0526d895b91ffbae879a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 May 2009 08:21:31 -0500 Subject: [PATCH 094/101] Oops --- core/compiler/units/units.factor | 4 ++++ core/continuations/continuations.factor | 4 +--- core/init/init.factor | 6 ++++-- core/vocabs/vocabs.factor | 4 +--- 4 files changed, 10 insertions(+), 8 deletions(-) diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 01ee815511..f1f9131f08 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -61,6 +61,10 @@ GENERIC: definitions-changed ( assoc obj -- ) [ V{ } clone definition-observers set-global ] "compiler.units" add-init-hook +! This goes here because vocabs cannot depend on init +[ V{ } clone vocab-observers set-global ] +"vocabs" add-init-hook + : add-definition-observer ( obj -- ) definition-observers get push ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index d46b73f83d..56ac4a71e9 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays vectors kernel kernel.private sequences namespaces make math splitting sorting quotations assocs -combinators combinators.private accessors words init ; +combinators combinators.private accessors words ; IN: continuations SYMBOL: error @@ -200,5 +200,3 @@ M: condition compute-restarts "kernel-error" 6 setenv ; PRIVATE> - -[ init-catchstack init-error-handler ] "continuations" add-init-hook \ No newline at end of file diff --git a/core/init/init.factor b/core/init/init.factor index 70464a4ba4..0140fcc0e8 100644 --- a/core/init/init.factor +++ b/core/init/init.factor @@ -1,6 +1,8 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private sequences assocs namespaces namespaces.private ; +USING: continuations continuations.private kernel +kernel.private sequences assocs namespaces namespaces.private +continuations continuations.private ; IN: init SYMBOL: init-hooks @@ -14,7 +16,7 @@ init-hooks global [ drop V{ } clone ] cache drop dup init-hooks get at [ over call( -- ) ] unless init-hooks get set-at ; -: boot ( -- ) init-namespaces ; +: boot ( -- ) init-namespaces init-catchstack init-error-handler ; : boot-quot ( -- quot ) 20 getenv ; diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 73ffd1a80c..6c12b7b325 100644 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs strings kernel sorting namespaces -sequences definitions init ; +sequences definitions ; IN: vocabs SYMBOL: dictionary @@ -69,8 +69,6 @@ SYMBOL: vocab-observers GENERIC: vocabs-changed ( obj -- ) -[ V{ } clone vocab-observers set-global ] "vocabs" add-init-hook - : add-vocab-observer ( obj -- ) vocab-observers get push ; From 21ac396128ef8a820d1e991e8cab9e73213797c5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 May 2009 08:29:04 -0500 Subject: [PATCH 095/101] Fix typo in redefine14 test --- basis/compiler/tests/redefine14.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compiler/tests/redefine14.factor b/basis/compiler/tests/redefine14.factor index 6a04eed088..a72db4833c 100644 --- a/basis/compiler/tests/redefine14.factor +++ b/basis/compiler/tests/redefine14.factor @@ -5,4 +5,4 @@ TUPLE: bad ; M: bad length 1 2 3 ; -[ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test +[ ] [ [ M\ bad length forget ] with-compilation-unit ] unit-test From 45bf6d15b049ae8365ca320c8d8a33e22c7019ae Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 1 May 2009 16:06:18 +0200 Subject: [PATCH 096/101] fixed missing use --- extra/mongodb/mmm/mmm.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/mongodb/mmm/mmm.factor b/extra/mongodb/mmm/mmm.factor index 467070859e..25c4c88203 100644 --- a/extra/mongodb/mmm/mmm.factor +++ b/extra/mongodb/mmm/mmm.factor @@ -1,6 +1,6 @@ USING: accessors fry io io.encodings.binary io.servers.connection io.sockets io.streams.byte-array kernel math mongodb.msg classes formatting -namespaces prettyprint tools.walker calendar calendar.format +namespaces prettyprint tools.walker calendar calendar.format bson.writer.private json.writer mongodb.operations.private mongodb.operations ; IN: mongodb.mmm From cce0341e28dfaf0868a858fd8fa6712cf585f7a9 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 1 May 2009 16:13:51 +0200 Subject: [PATCH 097/101] fixed compile errors --- extra/mongodb/tuple/tuple.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor index beb7f41384..e4c2e5b69a 100644 --- a/extra/mongodb/tuple/tuple.factor +++ b/extra/mongodb/tuple/tuple.factor @@ -20,7 +20,7 @@ SYNTAX: MDBTUPLE: tuple-collection [ create-collection ] [ [ tuple-index-list ] keep - '[ _ name>> swap [ name>> ] [ spec>> ] bi ensure-index ] each + '[ _ name>> swap [ name>> ] [ spec>> ] bi ensure-index ] each ] bi ; : ensure-tables ( classes -- ) @@ -80,4 +80,4 @@ PRIVATE> : count-tuples ( tuple/query -- n ) dup mdb-query-msg? [ tuple>query ] unless - [ collection>> ] [ query>> ] bi count ; + [ collection>> ] [ query>> ] bi count ; From 286026d5d5abd6b0c5c32e2b3d634633cca52d77 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 1 May 2009 16:22:48 +0200 Subject: [PATCH 098/101] fixed tuple query --- extra/mongodb/tuple/tuple.factor | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor index e4c2e5b69a..19281b769a 100644 --- a/extra/mongodb/tuple/tuple.factor +++ b/extra/mongodb/tuple/tuple.factor @@ -71,13 +71,12 @@ PRIVATE> tuple>selector ; : select-tuple ( tuple/query -- tuple/f ) - dup mdb-query-msg? [ ] [ tuple>query ] if + dup mdb-query-msg? [ tuple>query ] unless find-one [ assoc>tuple ] [ f ] if* ; : select-tuples ( tuple/query -- cursor tuples/f ) - dup mdb-query-msg? [ ] [ tuple>query ] if + dup mdb-query-msg? [ tuple>query ] unless find [ assoc>tuple ] map ; : count-tuples ( tuple/query -- n ) - dup mdb-query-msg? [ tuple>query ] unless - [ collection>> ] [ query>> ] bi count ; + dup mdb-query-msg? [ tuple>query ] unless count ; From 62846be4f6155f3e572ac277b4460dcb5cbf23bf Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 1 May 2009 16:23:06 +0200 Subject: [PATCH 099/101] removed trash / reformatted some lines --- extra/bson/writer/writer.factor | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/extra/bson/writer/writer.factor b/extra/bson/writer/writer.factor index ae12ca0a03..1b9d45b124 100644 --- a/extra/bson/writer/writer.factor +++ b/extra/bson/writer/writer.factor @@ -6,11 +6,8 @@ io.encodings.utf8 io.streams.byte-array kernel math math.parser namespaces quotations sequences sequences.private serialize strings words combinators.short-circuit literals ; - IN: bson.writer -#! Writes the object out to a byte-vector in BSON format - [ shared-buffer set ] keep ] unless* ; inline : >le-stream ( x n -- ) - ! >le write - swap '[ _ swap nth-byte 0 B{ 0 } - [ set-nth-unsafe ] keep write ] each - ; inline + swap + '[ _ swap nth-byte 0 B{ 0 } + [ set-nth-unsafe ] keep write ] each ; inline PRIVATE> From f2ec59d6589d8bf94032ba26a9ad2c01fa8068b0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 May 2009 09:36:53 -0500 Subject: [PATCH 100/101] Fix infinite loop when compiling a word containing a tuple literal with circular structure in it. This was triggered by call( inline caching in core-foundation.fsevents on Mac OS X --- basis/compiler/tree/propagation/info/info.factor | 15 ++++++--------- .../tree/propagation/propagation-tests.factor | 7 ++++++- .../compiler/tree/propagation/slots/slots.factor | 7 ++++++- 3 files changed, 18 insertions(+), 11 deletions(-) diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 2776ed914f..4d4b22218d 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -59,21 +59,18 @@ CONSTANT: object-info T{ value-info f object full-interval } : ( -- info ) \ value-info new ; -: read-only-slots ( values class -- slots ) - all-slots - [ read-only>> [ drop f ] unless ] 2map - f prefix ; - DEFER: +: tuple-slot-infos ( tuple -- slots ) + [ tuple-slots ] [ class all-slots ] bi + [ read-only>> [ ] [ drop f ] if ] 2map + f prefix ; + : init-literal-info ( info -- info ) dup literal>> class >>class dup literal>> dup real? [ [a,a] >>interval ] [ [ [-inf,inf] >>interval ] dip - dup tuple? [ - [ tuple-slots [ ] map ] [ class ] bi - read-only-slots >>slots - ] [ drop ] if + dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if ] if ; inline : init-value-info ( info -- info ) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index ed8d2983b5..eba41dbfdf 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use compiler.tree.debugger compiler.tree.checker slots.private words hashtables classes assocs locals specialized-arrays.double system sorting math.libm -math.intervals ; +math.intervals quotations ; IN: compiler.tree.propagation.tests [ V{ } ] [ [ ] final-classes ] unit-test @@ -686,3 +686,8 @@ TUPLE: littledan-2 { from read-only } { to read-only } ; [ V{ 0 } ] [ [ { } length ] final-literals ] unit-test [ V{ 1 } ] [ [ { } length 1+ f length ] final-literals ] unit-test + +! Mutable tuples with circularity should not cause problems +TUPLE: circle me ; + +[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 89c2bada8b..86114772f7 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -30,8 +30,13 @@ UNION: fixed-length-sequence array byte-array string ; [ [ literal>> ] map ] dip prefix >tuple ; +: read-only-slots ( values class -- slots ) + all-slots + [ read-only>> [ value-info ] [ drop f ] if ] 2map + f prefix ; + : (propagate-tuple-constructor) ( values class -- info ) - [ [ value-info ] map ] dip [ read-only-slots ] keep + [ read-only-slots ] keep over rest-slice [ dup [ literal?>> ] when ] all? [ [ rest-slice ] dip fold- ] [ From abac42a00118e2892c6af208cb33b153a8060d53 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 1 May 2009 18:31:19 +0200 Subject: [PATCH 101/101] fixed driver documentation --- extra/mongodb/driver/driver-docs.factor | 110 ++++++++++++------------ extra/mongodb/driver/driver.factor | 8 +- 2 files changed, 61 insertions(+), 57 deletions(-) diff --git a/extra/mongodb/driver/driver-docs.factor b/extra/mongodb/driver/driver-docs.factor index 48d7f7b65f..1086105306 100644 --- a/extra/mongodb/driver/driver-docs.factor +++ b/extra/mongodb/driver/driver-docs.factor @@ -8,10 +8,8 @@ HELP: { "name" "name of the collection" } { "collection" "mdb-collection instance" } } -{ $description "Creates a new mdb-collection instance. Use this to create capped/limited collections. See also: " { $link mdb-collection } } -{ $examples - { $example "! creates a mdb-collection instance capped to a maximum of 1000000 entries" - "\"mycollection\" t >>capped 1000000 >>max" } } ; +{ $examples { $unchecked-example "USING: mongodb.driver ;" "\"mycollection\" t >>capped 1000000 >>max" "" } } +{ $description "Creates a new mdb-collection instance. Use this to create capped/limited collections." } ; HELP: { $values @@ -22,7 +20,7 @@ HELP: } { $description "Create a new mdb-db instance and automatically resolves master/slave information in a paired MongoDB setup." } { $examples - { $example "\"db\" \"127.0.0.1\" 27017 " } } ; + { $unchecked-example "USING: mongodb.driver ;" "\"db\" \"127.0.0.1\" 27017 " "" } } ; HELP: { $values @@ -35,7 +33,7 @@ HELP: "For more see: " { $link with-db } } { $examples - { $example "\"mycollection\" H{ } " } } ; + { $unchecked-example "USING: mongodb.driver ;" "\"mycollection\" H{ } " "" } } ; HELP: { $values @@ -118,22 +116,22 @@ HELP: drop-index HELP: ensure-collection { $values - { "collection" "a collection; e.g. mycollection " } - { "fq-collection" "full qualified collection name; e.g. db.mycollection" } + { "name" "a collection; e.g. mycollection " } } -{ $description "ensures that the collection exists in the database and returns its full qualified name" } ; +{ $description "ensures that the collection exists in the database" } ; HELP: ensure-index { $values - { "collection" "a collection" } - { "name" "index name" } - { "spec" "index spec" } + { "index-spec" "an index specification" } } { $description "Ensures the existence of the given index. " "For more information on MongoDB indexes see: " { $url "http://www.mongodb.org/display/DOCS/Indexes" } } { $examples - { $example "\"mycollection\" nameIdx [ \"name\" asc ] keyspec ensure-index" } - { $example "\"mycollection\" nameIdx [ \"name\" asc ] keyspec unique-index ensure-index" } } ; + { $unchecked-example "USING: mongodb.driver ;" + "\"db\" \"127.0.0.1\" 27017 " + "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec ensure-index ] with-db" "" } + { $unchecked-example "USING: mongodb.driver ;" + "\"db\" \"127.0.0.1\" 27017 " "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec unique-index ensure-index ] with-db" "" } } ; HELP: explain. { $values @@ -143,31 +141,35 @@ HELP: explain. HELP: find { $values - { "mdb-query" "a query" } - { "cursor" "a cursor (if there are more results) or f" } - { "result" "a sequences of objects" } + { "selector" "a mdb-query or mdb-cursor" } + { "mdb-cursor/f" "a cursor (if there are more results) or f" } + { "seq" "a sequences of objects" } } { $description "executes the given query" } { $examples - { $example "\"mycollection\" H{ { \"name\" \"Alfred\" } } find " } } ; + { $unchecked-example "USING: mongodb.driver ;" + "\"db\" \"127.0.0.1\" 27017 " + "[ \"mycollection\" H{ { \"name\" \"Alfred\" } } find ] with-db" "" } } ; HELP: find-one { $values - { "mdb-query" "a query" } - { "result" "a single object or f" } + { "mdb-query-msg" "a query" } + { "result/f" "a single object or f" } } { $description "Executes the query and returns one object at most" } ; HELP: hint { $values - { "mdb-query" "a query" } + { "mdb-query-msg" "a query" } { "index-hint" "a hint to an index" } - { "mdb-query" "modified query object" } + { "mdb-query-msg" "modified query object" } } { $description "Annotates the query with a hint to an index. " "For detailed information see: " { $url "http://www.mongodb.org/display/DOCS/Optimizing+Mongo+Performance#OptimizingMongoPerformance-Hint" } } { $examples - { $example "\"mycollection\" H{ { \"name\" \"Alfred\" } { \"age\" 70 } } H{ { \"name\" 1 } } hint find" } } ; + { $unchecked-example "USING: mongodb.driver ;" + "\"db\" \"127.0.0.1\" 27017 " + "[ \"mycollection\" H{ { \"name\" \"Alfred\" } { \"age\" 70 } } H{ { \"name\" 1 } } hint find ] with-db" "" } } ; HELP: lasterror { $values @@ -179,13 +181,15 @@ HELP: lasterror HELP: limit { $values - { "mdb-query" "a query" } + { "mdb-query-msg" "a query" } { "limit#" "number of objects that should be returned at most" } - { "mdb-query" "modified query object" } + { "mdb-query-msg" "modified query object" } } { $description "Limits the number of returned objects to limit#" } { $examples - { $example "\"mycollection\" H{ } 10 limit find" } } ; + { $unchecked-example "USING: mongodb.driver ;" + "\"db\" \"127.0.0.1\" 27017 " + "[ \"mycollection\" H{ } 10 limit find ] with-db" "" } } ; HELP: load-collection-list { $values @@ -202,23 +206,23 @@ HELP: load-index-list { $description "Returns a list of all indexes that exist in the current database" } ; HELP: mdb-collection -{ $var-description "" } ; +{ $var-description "MongoDB collection" } ; HELP: mdb-cursor -{ $var-description "" } ; +{ $var-description "MongoDB cursor" } ; HELP: mdb-error { $values { "msg" "error message" } } -{ $description "" } ; +{ $description "error class" } ; HELP: r/ { $values - { "token" null } - { "mdbregexp" null } + { "token" "a regexp string" } + { "mdbregexp" "a mdbregexp tuple instance" } } -{ $description "" } ; +{ $description "creates a new mdbregexp instance" } ; HELP: save { $values @@ -230,53 +234,53 @@ HELP: save HELP: save-unsafe { $values - { "collection" null } - { "object" object } + { "collection" "a collection" } + { "assoc" "object" } } -{ $description "" } ; +{ $description "Save the object to the given collection without automatic error check" } ; HELP: skip { $values - { "mdb-query" null } - { "skip#" null } - { "mdb-query" null } + { "mdb-query-msg" "a query message" } + { "skip#" "number of objects to skip" } + { "mdb-query-msg" "annotated query message" } } -{ $description "" } ; +{ $description "annotates a query message with a number of objects to skip when returning the results" } ; HELP: sort { $values - { "mdb-query" null } - { "quot" quotation } - { "mdb-query" null } + { "mdb-query-msg" "a query message" } + { "sort-quot" "a quotation with sort specifiers" } + { "mdb-query-msg" "annotated query message" } } -{ $description "" } ; +{ $description "annotates the query message for sort specifiers" } ; HELP: update { $values - { "mdb-update-msg" null } + { "mdb-update-msg" "a mdb-update message" } } -{ $description "" } ; +{ $description "performs an update" } ; HELP: update-unsafe { $values - { "mdb-update-msg" null } + { "mdb-update-msg" "a mdb-update message" } } -{ $description "" } ; +{ $description "performs an update without automatic error check" } ; HELP: validate. { $values - { "collection" null } + { "collection" "collection to validate" } } -{ $description "" } ; +{ $description "validates the collection" } ; HELP: with-db { $values - { "mdb" null } - { "quot" quotation } + { "mdb" "mdb instance" } + { "quot" "quotation to execute with the given mdb instance as context" } } -{ $description "" } ; +{ $description "executes a quotation with the given mdb instance in its context" } ; -ARTICLE: "mongodb.driver" "mongodb.driver" +ARTICLE: "mongodb.driver" "MongoDB factor driver" { $vocab-link "mongodb.driver" } ; diff --git a/extra/mongodb/driver/driver.factor b/extra/mongodb/driver/driver.factor index 355838b82d..a972d1c380 100644 --- a/extra/mongodb/driver/driver.factor +++ b/extra/mongodb/driver/driver.factor @@ -162,7 +162,7 @@ PRIVATE> : ( collection assoc -- mdb-query-msg ) ; inline -GENERIC# limit 1 ( mdb-query-msg limit# -- mdb-query ) +GENERIC# limit 1 ( mdb-query-msg limit# -- mdb-query-msg ) M: mdb-query-msg limit >>return# ; inline @@ -188,7 +188,7 @@ GENERIC# hint 1 ( mdb-query-msg index-hint -- mdb-query-msg ) M: mdb-query-msg hint >>hint ; -GENERIC: find ( mdb-query-msg/mdb-cursor -- mdb-cursor seq ) +GENERIC: find ( selector -- mdb-cursor/f seq ) M: mdb-query-msg find fix-query-collection send-query ; @@ -243,7 +243,7 @@ M: assoc save [ check-collection ] dip send-message-check-error ; -GENERIC: save-unsafe ( collection object -- ) +GENERIC: save-unsafe ( collection assoc -- ) M: assoc save-unsafe [ check-collection ] dip send-message ; @@ -266,7 +266,7 @@ M: index-spec ensure-index [ cmd-collection ] dip find-one drop ; -: ( collection selector object -- update-msg ) +: ( collection selector object -- mdb-update-msg ) [ check-collection ] 2dip ; : >upsert ( mdb-update-msg -- mdb-update-msg )