From dc825d21c565c320d27354c8e2042d12c93881c9 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Tue, 16 Dec 2008 14:17:00 +0100 Subject: [PATCH 002/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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/246] 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 8806a0b18b446c949c274b608b7f2d00b1d6861b Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Wed, 15 Apr 2009 16:12:31 -0700 Subject: [PATCH 066/246] Make fuel auto-use the existing using in fuel-debug--uses-for-file. --- extra/fuel/fuel.factor | 28 +++++++++++++++++++++++++--- misc/fuel/fuel-debug-uses.el | 12 +++++++++--- 2 files changed, 34 insertions(+), 6 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 403708e880..a8c2adc3e1 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs compiler.units fuel.eval fuel.help fuel.remote fuel.xref -help.topics io.pathnames kernel namespaces parser sequences -tools.scaffold vocabs.loader ; +USING: accessors assocs compiler.units continuations fuel.eval fuel.help +fuel.remote fuel.xref help.topics io.pathnames kernel math namespaces parser +sequences tools.scaffold vocabs.loader ; IN: fuel @@ -28,6 +28,24 @@ IN: fuel > [ "Use the " head? ] [ " vocabulary" tail? ] bi and ; + +: get-restart-vocab ( restart -- vocab ) + [ "Use the " length ] dip + name>> [ length " vocabulary" length - ] keep + subseq ; + +: is-suggested-restart ( restart -- ? ) + dup is-use-restart [ + get-restart-vocab :uses-suggestions get member? + ] [ drop f ] if ; + +: try-suggested-restarts ( -- ) + restarts get [ is-suggested-restart ] filter + dup length 1 = [ first restart ] [ drop ] if ; : fuel-set-use-hook ( -- ) [ amended-use get clone :uses prefix fuel-eval-set-result ] @@ -38,6 +56,10 @@ SYMBOL: :uses PRIVATE> +: fuel-use-suggested-vocabs ( ... suggestions quot: ( ... -- ... ) -- ... ) + [ :uses-suggestions set ] dip + [ try-suggested-restarts rethrow ] recover ; + : fuel-run-file ( path -- ) [ fuel-set-use-hook run-file ] curry with-scope ; inline diff --git a/misc/fuel/fuel-debug-uses.el b/misc/fuel/fuel-debug-uses.el index 4842f960d1..8b25744011 100644 --- a/misc/fuel/fuel-debug-uses.el +++ b/misc/fuel/fuel-debug-uses.el @@ -88,9 +88,16 @@ fuel-debug--uses nil fuel-debug--uses-restarts nil)) +(defun fuel-debug--current-usings (file) + (with-current-buffer (find-file-noselect file) + (sort (fuel-syntax--find-usings t) 'string<))) + (defun fuel-debug--uses-for-file (file) (let* ((lines (fuel-debug--file-lines file)) - (cmd `(:fuel ((V{ ,@lines } fuel-get-uses)) t t))) + (old-usings (fuel-debug--current-usings file)) + (cmd `(:fuel ((V{ ,@old-usings } + [ V{ ,@lines } fuel-get-uses ] + fuel-use-suggested-vocabs)) t t))) (fuel-debug--uses-prepare file) (fuel--with-popup (fuel-debug--uses-buffer) (insert "Asking Factor. Please, wait ...\n") @@ -105,8 +112,7 @@ (defun fuel-debug--uses-display (uses) (let* ((inhibit-read-only t) - (old (with-current-buffer (find-file-noselect fuel-debug--uses-file) - (sort (fuel-syntax--find-usings t) 'string<))) + (old (fuel-debug--current-usings fuel-debug--uses-file)) (new (sort uses 'string<))) (erase-buffer) (fuel-debug--uses-insert-title) From d78dc167b676b4275198003fb4e28c7f86d4a16f Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 17 Apr 2009 08:04:49 +0200 Subject: [PATCH 067/246] 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 af7ecb16cfd617c78c4987895b96a52328879f27 Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Sun, 19 Apr 2009 14:52:24 -0700 Subject: [PATCH 068/246] Determine restart vocab thru obj>> instead of error string --- extra/fuel/fuel.factor | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 3c623212b0..12eb5bdbfc 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs compiler.units continuations fuel.eval fuel.help -fuel.remote fuel.xref help.topics io.pathnames kernel math namespaces parser -sequences tools.scaffold vocabs.loader ; +fuel.remote fuel.xref help.topics io.pathnames kernel namespaces parser +sequences tools.scaffold vocabs.loader words ; IN: fuel @@ -33,10 +33,8 @@ SYMBOL: :uses-suggestions : is-use-restart ( restart -- ? ) name>> [ "Use the " head? ] [ " vocabulary" tail? ] bi and ; -: get-restart-vocab ( restart -- vocab ) - [ "Use the " length ] dip - name>> [ length " vocabulary" length - ] keep - subseq ; +: get-restart-vocab ( restart -- vocab/f ) + obj>> dup word? [ vocabulary>> ] [ drop f ] if ; : is-suggested-restart ( restart -- ? ) dup is-use-restart [ @@ -56,9 +54,9 @@ SYMBOL: :uses-suggestions PRIVATE> -: fuel-use-suggested-vocabs ( ... suggestions quot: ( ... -- ... ) -- ... ) +: fuel-use-suggested-vocabs ( suggestions quot ... suggestions quot: ( ... -- ... ) -- ... ) [ :uses-suggestions set ] dip - [ try-suggested-restarts rethrow ] recover ; + [ try-suggested-restarts rethrow ] recover ; inline : fuel-run-file ( path -- ) [ fuel-set-use-hook run-file ] curry with-scope ; inline From 18b5090892e20b5016affc51846340d9e3e52c00 Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Sun, 19 Apr 2009 19:57:35 -0700 Subject: [PATCH 069/246] Add tests for auto-USING selection --- extra/fuel/fuel-tests.factor | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) create mode 100644 extra/fuel/fuel-tests.factor diff --git a/extra/fuel/fuel-tests.factor b/extra/fuel/fuel-tests.factor new file mode 100644 index 0000000000..a0cab888e8 --- /dev/null +++ b/extra/fuel/fuel-tests.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2009 Nicholas Seckar. +! See http://factorcode.org/license.txt for BSD license. +USING: continuations eval fuel fuel.private namespaces tools.test words ; +IN: fuel.tests + +: fake-continuation ( -- continuation ) + f f f "fake" f ; + +: make-uses-restart ( -- restart ) + "Use the words vocabulary" \ word? + fake-continuation ; + +: make-defer-restart ( -- restart ) + "Defer word in current vocabulary" f + fake-continuation ; + +{ f } [ make-defer-restart is-use-restart ] unit-test +{ t } [ make-uses-restart is-use-restart ] unit-test + +{ "words" } [ make-uses-restart get-restart-vocab ] unit-test + +{ f } [ make-defer-restart is-suggested-restart ] unit-test +{ f } [ make-uses-restart is-suggested-restart ] unit-test +{ f } [ { "io" } :uses-suggestions + [ make-uses-restart is-suggested-restart ] with-variable +] unit-test +{ t } [ { "words" } :uses-suggestions + [ make-uses-restart is-suggested-restart ] with-variable +] unit-test + +{ } [ + { "kernel" } [ "\\ dup drop" eval( -- ) ] fuel-use-suggested-vocabs +] unit-test From ea87b380f38604b95819e29445e3d55d152a3ff0 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Wed, 22 Apr 2009 16:09:03 +0200 Subject: [PATCH 070/246] 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 47064cd1af6c1ddc6448928acea86f371e293840 Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Wed, 22 Apr 2009 15:40:17 -0700 Subject: [PATCH 071/246] Fix stack effect of fuel-use-suggested-vocabs --- extra/fuel/fuel.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 12eb5bdbfc..a9ed17877e 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -54,7 +54,7 @@ SYMBOL: :uses-suggestions PRIVATE> -: fuel-use-suggested-vocabs ( suggestions quot ... suggestions quot: ( ... -- ... ) -- ... ) +: fuel-use-suggested-vocabs ( suggestions quot -- ... ) [ :uses-suggestions set ] dip [ try-suggested-restarts rethrow ] recover ; inline From 449f677ad8262c2c98d94a6369dad3deb3682215 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 24 Apr 2009 08:24:12 +0200 Subject: [PATCH 072/246] 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 073/246] 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 074/246] 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 e4055005ea0cbdfda801f507761fb1d1652f4147 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Fri, 24 Apr 2009 22:03:38 +0200 Subject: [PATCH 075/246] FUEL: Fixes for string highlighting. --- misc/fuel/fuel-syntax.el | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 6b646511ca..61aa2b7cdd 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -241,18 +241,17 @@ table)) (defconst fuel-syntax--syntactic-keywords - `(;; Comments - ("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">")) - ("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">")) - ;; Strings and chars - ("CHAR: \\(\"\\) [^\\\"]*?\\(\"\\)\\([^\\\"]\\|\\\\.\\)*?\\(\"\\)" - (1 "w") (2 "\"") (4 "\"")) - ("\\(CHAR:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w")) - ("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" - (3 "\"") (5 "\"")) - ("\\_<\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" (1 "\"") (3 "\"")) + `(;; Strings and chars ("\\_<<\\(\"\\)\\_>" (1 "\\_>" (1 ">b")) + ("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)?\\(\"\\)\\(\\([^\n\r\f\"\\]\\|\\\\.\\)*\\)\\(\"\\)" + (3 "\"") (6 "\"")) + ("CHAR: \\(\"\\) [^\\\"]*?\\(\"\\)\\([^\\\"]\\|\\\\.\\)*?\\(\"\\)" + (1 "w") (2 "b")) + ("\\(CHAR:\\|\\\\\\) \\(\\w\\|!\\)\\( \\|$\\)" (2 "w")) + ;; Comments + ("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">")) + ("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">")) ;; postpone ("\\_b")) ;; Multiline constructs From 9b19b341268834751631f1ae69ce870672b33046 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Fri, 24 Apr 2009 22:15:20 +0200 Subject: [PATCH 076/246] FUEL: Fix for C-cC-eC-l (make factor command ( -- )). --- misc/fuel/fuel-mode.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index aa9a7d944e..0186392f34 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -140,7 +140,7 @@ for details." (interactive) (message "Loading all vocabularies in USING: form ...") (let ((err (fuel-eval--retort-error - (fuel-eval--send/wait '(:fuel* (t) t :usings) 120000)))) + (fuel-eval--send/wait '(:fuel* (t .) t :usings) 120000)))) (message (if err "Warning: some vocabularies failed to load" "All vocabularies loaded")))) From 8c5b0373a83955d0f94b86055c6a3623145d8e79 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 15:31:06 -0500 Subject: [PATCH 077/246] Working on new method dispatch system --- Makefile | 3 +- .../known-words/known-words.factor | 3 + core/bootstrap/primitives.factor | 2 + core/generic/standard/compiler/authors.txt | 1 + .../generic/standard/compiler/compiler.factor | 174 ++++++++++++++++++ vm/data_heap.c | 2 +- vm/dispatch.c | 108 +++++++++++ vm/dispatch.h | 1 + vm/layouts.h | 2 +- vm/master.h | 1 + vm/primitives.c | 3 +- 11 files changed, 296 insertions(+), 4 deletions(-) create mode 100644 core/generic/standard/compiler/authors.txt create mode 100644 core/generic/standard/compiler/compiler.factor create mode 100644 vm/dispatch.c create mode 100644 vm/dispatch.h diff --git a/Makefile b/Makefile index 35a5ba58bf..511c191711 100644 --- a/Makefile +++ b/Makefile @@ -35,6 +35,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/data_gc.o \ vm/data_heap.o \ vm/debug.o \ + vm/dispatch.o \ vm/errors.o \ vm/factor.o \ vm/image.o \ @@ -182,5 +183,5 @@ vm/ffi_test.o: vm/ffi_test.c .m.o: $(CC) -c $(CFLAGS) -o $@ $< - + .PHONY: factor diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index eade33e52b..ab205b4a16 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -12,6 +12,7 @@ classes.tuple.private vectors vectors.private words definitions words.private assocs summary compiler.units system.private combinators locals locals.backend locals.types words.private quotations.private combinators.private stack-checker.values +generic.standard.private alien.libraries stack-checker.alien stack-checker.state @@ -676,3 +677,5 @@ M: object infer-call* \ gc-stats { } { array } define-primitive \ jit-compile { quotation } { } define-primitive + +\ lookup-method { object array } { word } define-primitive \ No newline at end of file diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 1258da8a4d..a8e23cd336 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -69,6 +69,7 @@ bootstrapping? on "classes.predicate" "compiler.units" "continuations.private" + "generic.standard.private" "growable" "hashtables" "hashtables.private" @@ -532,6 +533,7 @@ tuple { "jit-compile" "quotations" (( quot -- )) } { "load-locals" "locals.backend" (( ... n -- )) } { "check-datastack" "kernel.private" (( array in# out# -- ? )) } + { "lookup-method" "generic.standard.private" (( object methods -- method )) } } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number diff --git a/core/generic/standard/compiler/authors.txt b/core/generic/standard/compiler/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/core/generic/standard/compiler/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/core/generic/standard/compiler/compiler.factor b/core/generic/standard/compiler/compiler.factor new file mode 100644 index 0000000000..0456918b49 --- /dev/null +++ b/core/generic/standard/compiler/compiler.factor @@ -0,0 +1,174 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs classes.algebra math combinators +generic.standard.engines hashtables kernel kernel.private layouts +namespaces sequences words sorting quotations effects +generic.standard.private words.private ; +IN: generic.standard.compiler + +! ! ! Build an engine ! ! ! + +! 1. Flatten methods +TUPLE: predicate-engine methods ; + +: ( methods -- engine ) predicate-engine boa ; + +: push-method ( method specializer atomic assoc -- ) + [ + [ H{ } clone ] unless* + [ methods>> set-at ] keep + ] change-at ; + +: flatten-method ( class method assoc -- ) + [ [ flatten-class keys ] keep ] 2dip [ + [ spin ] dip push-method + ] 3curry each ; + +: flatten-methods ( assoc -- assoc' ) + H{ } clone [ [ flatten-method ] curry assoc-each ] keep ; + +! 2. Convert methods +: convert-methods ( assoc class word -- assoc' ) + over [ split-methods ] 2dip pick assoc-empty? + [ 3drop ] [ [ execute ] dip pick set-at ] if ; inline + +! 2.1 Convert tuple methods +TUPLE: echelon-dispatch-engine n methods ; + +C: echelon-dispatch-engine + +TUPLE: tuple-dispatch-engine echelons ; + +: push-echelon ( class method assoc -- ) + [ swap dup "layout" word-prop third ] dip + [ ?set-at ] change-at ; + +: echelon-sort ( assoc -- assoc' ) + H{ } clone [ [ push-echelon ] curry assoc-each ] keep ; + +: ( methods -- engine ) + echelon-sort + [ dupd ] assoc-map + \ tuple-dispatch-engine boa ; + +: convert-tuple-methods ( assoc -- assoc' ) + tuple bootstrap-word + \ convert-methods ; + +! 2.2 Convert hi-tag methods +TUPLE: hi-tag-dispatch-engine methods ; + +C: hi-tag-dispatch-engine + +: convert-hi-tag-methods ( assoc -- assoc' ) + \ hi-tag bootstrap-word + \ convert-methods ; + +! 3 Tag methods +TUPLE: tag-dispatch-engine methods ; + +C: tag-dispatch-engine + +: ( assoc -- engine ) + flatten-methods + convert-tuple-methods + convert-hi-tag-methods + ; + +! ! ! Compile engine ! ! ! +SYMBOL: assumed +SYMBOL: default +SYMBOL: generic-word + +GENERIC: compile-engine ( engine -- obj ) + +: compile-engines ( assoc -- assoc' ) + [ compile-engine ] assoc-map ; + +: compile-engines* ( assoc -- assoc' ) + [ over assumed [ compile-engine ] with-variable ] assoc-map ; + +: direct-dispatch-table ( assoc n -- table ) + default get [ swap update ] keep ; + +M: tag-dispatch-engine compile-engine + methods>> compile-engines* + [ [ tag-number ] dip ] assoc-map + num-tags get direct-dispatch-table ; + +: hi-tag-number ( class -- n ) "type" word-prop ; + +: num-hi-tags ( -- n ) + num-types get num-tags get - ; + +M: hi-tag-dispatch-engine compile-engine + methods>> compile-engines* + [ [ hi-tag-number num-tags get - ] dip ] assoc-map + num-hi-tags direct-dispatch-table ; + +: build-fast-hash ( methods -- buckets ) + >alist V{ } clone [ hashcode 1array ] distribute-buckets + [ compile-engines* >alist >array ] map ; + +M: echelon-dispatch-engine compile-engine + methods>> compile-engines* build-fast-hash ; + +M: tuple-dispatch-engine compile-engine + tuple assumed [ + echelons>> compile-engines + dup keys supremum f default get prefix + [ swap update ] keep + ] with-variable ; + +: sort-methods ( assoc -- assoc' ) + >alist [ keys sort-classes ] keep extract-keys ; + +: literalize-methods ( assoc -- assoc' ) + [ [ ] curry \ drop prefix ] assoc-map ; + +: methods-with-default ( engine -- assoc ) + methods>> clone default get object bootstrap-word pick set-at ; + +: keep-going? ( assoc -- ? ) + assumed get swap second first class<= ; + +: prune-redundant-predicates ( assoc -- default assoc' ) + { + { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] } + { [ dup length 1 = ] [ first second { } ] } + { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] } + [ [ first second ] [ rest-slice ] bi ] + } cond ; + +: class-predicates ( assoc -- assoc ) + [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ; + +: predicate-engine-effect ( -- effect ) + (dispatch#) get 1+ dup 1+ ; + +: define-predicate-engine ( alist -- word ) + [ generic-word get name>> "/predicate-engine" append f dup ] dip + predicate-engine-effect define-declared ; + +M: predicate-engine compile-engine + methods-with-default + sort-methods + literalize-methods + prune-redundant-predicates + class-predicates + [ peek wrapped>> ] + [ alist>quot picker prepend define-predicate-engine ] if-empty ; + +M: word compile-engine ; + +M: f compile-engine ; + +: build-engine ( generic combination -- engine ) + [ + #>> (dispatch#) set + [ generic-word set ] + [ "default-method" word-prop default set ] + [ "methods" word-prop ] tri + compile-engine 1quotation + picker [ lookup-method ] surround + ] with-scope ; \ No newline at end of file diff --git a/vm/data_heap.c b/vm/data_heap.c index c5aa42aebe..eb8add544e 100644 --- a/vm/data_heap.c +++ b/vm/data_heap.c @@ -334,7 +334,7 @@ CELL next_object(void) type = untag_header(value); heap_scan_ptr += untagged_object_size(heap_scan_ptr); - return RETAG(obj,type <= HEADER_TYPE ? type : OBJECT_TYPE); + return RETAG(obj,type < HEADER_TYPE ? type : OBJECT_TYPE); } /* Push object at heap scan cursor and advance; pushes f when done */ diff --git a/vm/dispatch.c b/vm/dispatch.c new file mode 100644 index 0000000000..e231d6f431 --- /dev/null +++ b/vm/dispatch.c @@ -0,0 +1,108 @@ +#include "master.h" + +static CELL search_lookup_alist(CELL table, CELL class) +{ + F_ARRAY *pairs = untag_object(table); + F_FIXNUM index = array_capacity(pairs) - 1; + while(index >= 0) + { + F_ARRAY *pair = untag_object(array_nth(pairs,index)); + if(array_nth(pair,0) == class) + return array_nth(pair,1); + else + index--; + } + + return F; +} + +static CELL search_lookup_hash(CELL table, CELL class, CELL hashcode) +{ + F_ARRAY *buckets = untag_object(table); + CELL bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1)); + if(type_of(bucket) == WORD_TYPE || bucket == F) + return bucket; + else + return search_lookup_alist(bucket,class); +} + +static CELL nth_superclass(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon) +{ + CELL *ptr = (CELL *)(layout + 1); + return ptr[echelon * 2]; +} + +static CELL nth_hashcode(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon) +{ + CELL *ptr = (CELL *)(layout + 1); + return ptr[echelon * 2 + 1]; +} + +static CELL lookup_tuple_method(CELL object, CELL methods) +{ + F_ARRAY *echelons = untag_object(methods); + F_TUPLE *tuple = untag_object(object); + F_TUPLE_LAYOUT *layout = untag_object(tuple->layout); + + F_FIXNUM echelon = untag_fixnum_fast(layout->echelon); + F_FIXNUM max_echelon = array_capacity(echelons) - 1; + if(echelon > max_echelon) echelon = max_echelon; + + while(echelon >= 0) + { + CELL echelon_methods = array_nth(echelons,echelon); + + if(type_of(echelon_methods) == WORD_TYPE) + return echelon_methods; + else if(echelon_methods != F) + { + CELL class = nth_superclass(layout,echelon); + CELL hashcode = untag_fixnum_fast(nth_hashcode(layout,echelon)); + CELL result = search_lookup_hash(echelon_methods,class,hashcode); + if(result != F) + return result; + } + + echelon--; + } + + critical_error("Cannot find tuple method",object); + return F; +} + +static CELL lookup_hi_tag_method(CELL object, CELL methods) +{ + F_ARRAY *hi_tag_methods = untag_object(methods); + CELL hi_tag = object_type(object); + return array_nth(hi_tag_methods,hi_tag - HEADER_TYPE); +} + +static CELL lookup_method(CELL object, CELL methods) +{ + F_ARRAY *tag_methods = untag_object(methods); + CELL tag = TAG(object); + CELL element = array_nth(tag_methods,tag); + + if(type_of(element) == WORD_TYPE) + return element; + else + { + switch(tag) + { + case TUPLE_TYPE: + return lookup_tuple_method(object,element); + case OBJECT_TYPE: + return lookup_hi_tag_method(object,element); + default: + critical_error("Bad methods array",methods); + return F; + } + } +} + +void primitive_lookup_method(void) +{ + CELL methods = dpop(); + CELL object = dpop(); + dpush(lookup_method(object,methods)); +} diff --git a/vm/dispatch.h b/vm/dispatch.h new file mode 100644 index 0000000000..6541c8fef1 --- /dev/null +++ b/vm/dispatch.h @@ -0,0 +1 @@ +void primitive_lookup_method(void); diff --git a/vm/layouts.h b/vm/layouts.h index e9cdef6272..9d92d2c386 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -42,7 +42,7 @@ typedef signed long long s64; #define F_TYPE 7 #define F F_TYPE -#define HEADER_TYPE 7 /* anything less than or equal to this is a tag */ +#define HEADER_TYPE 8 /* anything less than this is a tag */ #define GC_COLLECTED 5 /* See gc.c */ diff --git a/vm/master.h b/vm/master.h index 86b5223eaa..e2cafd9a87 100644 --- a/vm/master.h +++ b/vm/master.h @@ -41,6 +41,7 @@ #include "callstack.h" #include "alien.h" #include "quotations.h" +#include "dispatch.h" #include "factor.h" #include "utilities.h" diff --git a/vm/primitives.c b/vm/primitives.c index 80b672d9d2..4281e88fc3 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -144,5 +144,6 @@ void *primitives[] = { primitive_clear_gc_stats, primitive_jit_compile, primitive_load_locals, - primitive_check_datastack + primitive_check_datastack, + primitive_lookup_method }; From c877146531484ef34c93113649e4e26a24687d23 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 16:53:30 -0500 Subject: [PATCH 078/246] Move method-declaration to hints --- basis/hints/hints.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index d445bf72ad..e2506dbe0a 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -42,13 +42,13 @@ SYMBOL: specialize-method? t specialize-method? set-global +: method-declaration ( method -- quot ) + [ "method-generic" word-prop dispatch# object ] + [ "method-class" word-prop ] + bi prefix [ declare ] curry [ ] like ; + : specialize-method ( quot method -- quot' ) - [ - specialize-method? get [ - [ "method-class" word-prop ] [ "method-generic" word-prop ] bi - method-declaration prepend - ] [ drop ] if - ] + [ specialize-method? get [ method-declaration prepend ] [ drop ] if ] [ "method-generic" word-prop "specializer" word-prop ] bi [ specialize-quot ] when* ; From 3dc9fdf9db8113cd6c8276ba0257645c5caab076 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 20:43:01 -0500 Subject: [PATCH 079/246] Fleshed out new dispatch code --- basis/compiler/compiler.factor | 16 +- .../tree/propagation/inlining/inlining.factor | 2 +- basis/debugger/debugger.factor | 2 +- basis/hints/hints.factor | 4 +- basis/see/see.factor | 10 +- basis/stack-checker/backend/backend.factor | 9 +- .../known-words/known-words.factor | 4 +- basis/tools/crossref/crossref.factor | 5 +- .../listener/completion/completion.factor | 12 +- core/bootstrap/primitives.factor | 4 +- .../{standard/compiler => hook}/authors.txt | 0 core/generic/hook/hook-docs.factor | 10 + core/generic/hook/hook.factor | 19 ++ core/generic/single/authors.txt | 1 + core/generic/single/single-docs.factor | 27 +++ .../compiler.factor => single/single.factor} | 125 ++++++++++--- core/generic/standard/authors.txt | 2 +- core/generic/standard/engines/engines.factor | 53 ------ .../engines/predicate/predicate.factor | 38 ---- .../standard/engines/predicate/summary.txt | 1 - core/generic/standard/engines/summary.txt | 1 - core/generic/standard/engines/tag/summary.txt | 1 - core/generic/standard/engines/tag/tag.factor | 71 ------- .../standard/engines/tuple/summary.txt | 1 - .../standard/engines/tuple/tuple.factor | 167 ----------------- core/generic/standard/standard-docs.factor | 35 +--- core/generic/standard/standard.factor | 173 ++---------------- core/generic/standard/summary.txt | 1 - core/syntax/syntax-docs.factor | 4 +- core/syntax/syntax.factor | 2 +- core/words/words.factor | 11 +- 31 files changed, 218 insertions(+), 593 deletions(-) rename core/generic/{standard/compiler => hook}/authors.txt (100%) create mode 100644 core/generic/hook/hook-docs.factor create mode 100644 core/generic/hook/hook.factor create mode 100644 core/generic/single/authors.txt create mode 100644 core/generic/single/single-docs.factor rename core/generic/{standard/compiler/compiler.factor => single/single.factor} (57%) delete mode 100644 core/generic/standard/engines/engines.factor delete mode 100644 core/generic/standard/engines/predicate/predicate.factor delete mode 100644 core/generic/standard/engines/predicate/summary.txt delete mode 100644 core/generic/standard/engines/summary.txt delete mode 100644 core/generic/standard/engines/tag/summary.txt delete mode 100644 core/generic/standard/engines/tag/tag.factor delete mode 100644 core/generic/standard/engines/tuple/summary.txt delete mode 100644 core/generic/standard/engines/tuple/tuple.factor delete mode 100644 core/generic/standard/summary.txt diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index ee91d04b3d..26f9dc47c9 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -2,13 +2,14 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces arrays sequences io words fry continuations vocabs assocs dlists definitions math graphs generic -combinators deques search-deques macros io source-files.errors -stack-checker stack-checker.state stack-checker.inlining -stack-checker.errors combinators.short-circuit compiler.errors -compiler.units compiler.tree.builder compiler.tree.optimizer -compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization -compiler.cfg.two-operand compiler.cfg.linear-scan -compiler.cfg.stack-frame compiler.codegen compiler.utilities ; +generic.single combinators deques search-deques macros io +source-files.errors stack-checker stack-checker.state +stack-checker.inlining stack-checker.errors combinators.short-circuit +compiler.errors compiler.units compiler.tree.builder +compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer +compiler.cfg.linearization compiler.cfg.two-operand +compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen +compiler.utilities ; IN: compiler SYMBOL: compile-queue @@ -19,6 +20,7 @@ SYMBOL: compiled { [ "forgotten" word-prop ] [ compiled get key? ] + [ single-generic? ] [ inlined-block? ] [ primitive? ] } 1|| not ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index aa66b2f6d7..42c47377e0 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel arrays sequences math math.order -math.partial-dispatch generic generic.standard generic.math +math.partial-dispatch generic generic.standard generic.single generic.math classes.algebra classes.union sets quotations assocs combinators words namespaces continuations classes fry combinators.smart hints locals diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index d8ebd5bbf9..2091a26133 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -6,7 +6,7 @@ sequences assocs sequences.private strings io.styles io.pathnames vectors words system splitting math.parser classes.mixin classes.tuple continuations continuations.private combinators generic.math classes.builtin classes compiler.units -generic.standard vocabs init kernel.private io.encodings +generic.standard generic.single vocabs init kernel.private io.encodings accessors math.order destructors source-files parser classes.tuple.parser effects.parser lexer generic.parser strings.parser vocabs.loader vocabs.parser see diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index e2506dbe0a..d83275c750 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser words definitions kernel sequences assocs arrays kernel.private fry combinators accessors vectors strings sbufs byte-arrays byte-vectors io.binary io.streams.string splitting math -math.parser generic generic.standard generic.standard.engines classes +math.parser generic generic.single generic.standard classes hashtables namespaces ; IN: hints diff --git a/basis/see/see.factor b/basis/see/see.factor index 2494c72fa4..37153b5229 100644 --- a/basis/see/see.factor +++ b/basis/see/see.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs classes classes.builtin -classes.intersection classes.mixin classes.predicate -classes.singleton classes.tuple classes.union combinators -definitions effects generic generic.standard io io.pathnames +classes.intersection classes.mixin classes.predicate classes.singleton +classes.tuple classes.union combinators definitions effects generic +generic.single generic.standard generic.hook io io.pathnames io.streams.string io.styles kernel make namespaces prettyprint prettyprint.backend prettyprint.config prettyprint.custom -prettyprint.sections sequences sets sorting strings summary -words words.symbol words.constant words.alias ; +prettyprint.sections sequences sets sorting strings summary words +words.symbol words.constant words.alias ; IN: see GENERIC: synopsis* ( defspec -- ) diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 4fb5bab96f..338b052316 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry arrays generic io io.streams.string kernel math -namespaces parser sequences strings vectors words quotations -effects classes continuations assocs combinators -compiler.errors accessors math.order definitions sets -generic.standard.engines.tuple hints macros stack-checker.state +USING: fry arrays generic io io.streams.string kernel math namespaces +parser sequences strings vectors words quotations effects classes +continuations assocs combinators compiler.errors accessors math.order +definitions sets hints macros stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state ; IN: stack-checker.backend diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index ab205b4a16..a3b0c8d704 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -12,7 +12,7 @@ classes.tuple.private vectors vectors.private words definitions words.private assocs summary compiler.units system.private combinators locals locals.backend locals.types words.private quotations.private combinators.private stack-checker.values -generic.standard.private +generic.single generic.single.private alien.libraries stack-checker.alien stack-checker.state @@ -236,6 +236,8 @@ M: object infer-call* \ effective-method t "no-compile" set-word-prop \ effective-method subwords [ t "no-compile" set-word-prop ] each +\ execute-unsafe t "no-compile" set-word-prop + \ clear t "no-compile" set-word-prop : non-inline-word ( word -- ) diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor index c5cd246f2e..6082933bcb 100644 --- a/basis/tools/crossref/crossref.factor +++ b/basis/tools/crossref/crossref.factor @@ -3,8 +3,7 @@ USING: words assocs definitions io io.pathnames io.styles kernel prettyprint sorting see sets sequences arrays hashtables help.crossref help.topics help.markup quotations accessors source-files namespaces -graphs vocabs generic generic.standard.engines.tuple threads -compiler.units init ; +graphs vocabs generic generic.single threads compiler.units init ; IN: tools.crossref SYMBOL: crossref @@ -82,7 +81,7 @@ M: object irrelevant? drop f ; M: default-method irrelevant? drop t ; -M: engine-word irrelevant? drop t ; +M: predicate-engine irrelevant? drop t ; PRIVATE> diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor index ba66121bc2..70131f3212 100644 --- a/basis/ui/tools/listener/completion/completion.factor +++ b/basis/ui/tools/listener/completion/completion.factor @@ -3,13 +3,13 @@ USING: accessors arrays assocs calendar colors colors.constants documents documents.elements fry kernel words sets splitting math math.vectors models.delay models.arrow combinators.short-circuit -parser present sequences tools.completion help.vocabs generic -generic.standard.engines.tuple fonts definitions.icons ui.images -ui.commands ui.operations ui.gadgets ui.gadgets.editors -ui.gadgets.glass ui.gadgets.scrollers ui.gadgets.tables -ui.gadgets.tracks ui.gadgets.labeled +parser present sequences tools.completion help.vocabs generic fonts +definitions.icons ui.images ui.commands ui.operations ui.gadgets +ui.gadgets.editors ui.gadgets.glass ui.gadgets.scrollers +ui.gadgets.tables ui.gadgets.tracks ui.gadgets.labeled ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.pens.solid -ui.tools.listener.history combinators vocabs ui.tools.listener.popups ; +ui.tools.listener.history combinators vocabs ui.tools.listener.popups + ; IN: ui.tools.listener.completion ! We don't directly depend on the listener tool but we use a few slots diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index a8e23cd336..42627531aa 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -69,7 +69,7 @@ bootstrapping? on "classes.predicate" "compiler.units" "continuations.private" - "generic.standard.private" + "generic.single.private" "growable" "hashtables" "hashtables.private" @@ -533,7 +533,7 @@ tuple { "jit-compile" "quotations" (( quot -- )) } { "load-locals" "locals.backend" (( ... n -- )) } { "check-datastack" "kernel.private" (( array in# out# -- ? )) } - { "lookup-method" "generic.standard.private" (( object methods -- method )) } + { "lookup-method" "generic.single.private" (( object methods -- method )) } } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number diff --git a/core/generic/standard/compiler/authors.txt b/core/generic/hook/authors.txt similarity index 100% rename from core/generic/standard/compiler/authors.txt rename to core/generic/hook/authors.txt diff --git a/core/generic/hook/hook-docs.factor b/core/generic/hook/hook-docs.factor new file mode 100644 index 0000000000..9b57d941c0 --- /dev/null +++ b/core/generic/hook/hook-docs.factor @@ -0,0 +1,10 @@ +USING: generic generic.single generic.standard help.markup help.syntax sequences math +math.parser effects ; +IN: generic.hook + +HELP: hook-combination +{ $class-description + "Performs hook method combination . See " { $link POSTPONE: HOOK: } "." +} ; + +{ standard-combination hook-combination } related-words \ No newline at end of file diff --git a/core/generic/hook/hook.factor b/core/generic/hook/hook.factor new file mode 100644 index 0000000000..0574833fab --- /dev/null +++ b/core/generic/hook/hook.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors definitions generic generic.single kernel +namespaces words ; +IN: generic.hook + +TUPLE: hook-combination < single-combination var ; + +C: hook-combination + +PREDICATE: hook-generic < generic + "combination" word-prop hook-combination? ; + +M: hook-combination picker + combination get var>> [ get ] curry ; + +M: hook-combination dispatch# drop 0 ; + +M: hook-generic definer drop \ HOOK: f ; diff --git a/core/generic/single/authors.txt b/core/generic/single/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/core/generic/single/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/core/generic/single/single-docs.factor b/core/generic/single/single-docs.factor new file mode 100644 index 0000000000..8f81be762c --- /dev/null +++ b/core/generic/single/single-docs.factor @@ -0,0 +1,27 @@ +USING: generic help.markup help.syntax sequences math +math.parser effects ; +IN: generic.single + +HELP: no-method +{ $values { "object" "an object" } { "generic" "a generic word" } } +{ $description "Throws a " { $link no-method } " error." } +{ $error-description "Thrown by the " { $snippet "generic" } " word to indicate it does not have a method for the class of " { $snippet "object" } "." } ; + +HELP: inconsistent-next-method +{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." } +{ $examples + "The following code throws this error:" + { $code + "GENERIC: error-test ( object -- )" + "" + "M: string error-test print ;" + "" + "M: integer error-test number>string call-next-method ;" + "" + "123 error-test" + } + "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method." + $nl + "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:" + { $code "M: integer error-test number>string error-test ;" } +} ; \ No newline at end of file diff --git a/core/generic/standard/compiler/compiler.factor b/core/generic/single/single.factor similarity index 57% rename from core/generic/standard/compiler/compiler.factor rename to core/generic/single/single.factor index 0456918b49..d70a378c67 100644 --- a/core/generic/standard/compiler/compiler.factor +++ b/core/generic/single/single.factor @@ -1,13 +1,66 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs classes.algebra math combinators -generic.standard.engines hashtables kernel kernel.private layouts -namespaces sequences words sorting quotations effects -generic.standard.private words.private ; -IN: generic.standard.compiler +USING: accessors arrays assocs classes classes.algebra +combinators definitions generic hashtables kernel +kernel.private layouts make math namespaces quotations +sequences words generic.single.private words.private +effects ; +IN: generic.single + +ERROR: no-method object generic ; + +ERROR: inconsistent-next-method class generic ; + +TUPLE: single-combination ; + +PREDICATE: single-generic < generic + "combination" word-prop single-combination? ; + +GENERIC: dispatch# ( word -- n ) + +M: generic dispatch# "combination" word-prop dispatch# ; + +SYMBOL: assumed +SYMBOL: default +SYMBOL: generic-word +SYMBOL: combination + +: with-combination ( combination quot -- ) + [ combination ] dip with-variable ; inline + +HOOK: picker combination ( -- quot ) + +M: single-combination next-method-quot* + [ + 2dup next-method dup [ + [ + pick "predicate" word-prop % + 1quotation , + [ inconsistent-next-method ] 2curry , + \ if , + ] [ ] make picker prepend + ] [ 3drop f ] if + ] with-combination ; + +: single-effective-method ( obj word -- method ) + [ [ order [ instance? ] with find-last nip ] keep method ] + [ "default-method" word-prop ] + bi or ; + +M: single-generic effective-method + [ [ picker ] with-combination call ] keep single-effective-method ; + +M: single-combination make-default-method + combination [ [ picker ] dip [ no-method ] curry append ] with-variable ; ! ! ! Build an engine ! ! ! +: find-default ( methods -- default ) + #! Side-effects methods. + [ object bootstrap-word ] dip delete-at* [ + drop generic-word get "default-method" word-prop + ] unless ; + ! 1. Flatten methods TUPLE: predicate-engine methods ; @@ -28,6 +81,10 @@ TUPLE: predicate-engine methods ; H{ } clone [ [ flatten-method ] curry assoc-each ] keep ; ! 2. Convert methods +: split-methods ( assoc class -- first second ) + [ [ nip class<= not ] curry assoc-filter ] + [ [ nip class<= ] curry assoc-filter ] 2bi ; + : convert-methods ( assoc class word -- assoc' ) over [ split-methods ] 2dip pick assoc-empty? [ 3drop ] [ [ execute ] dip pick set-at ] if ; inline @@ -76,10 +133,6 @@ C: tag-dispatch-engine ; ! ! ! Compile engine ! ! ! -SYMBOL: assumed -SYMBOL: default -SYMBOL: generic-word - GENERIC: compile-engine ( engine -- obj ) : compile-engines ( assoc -- assoc' ) @@ -98,8 +151,7 @@ M: tag-dispatch-engine compile-engine : hi-tag-number ( class -- n ) "type" word-prop ; -: num-hi-tags ( -- n ) - num-types get num-tags get - ; +: num-hi-tags ( -- n ) num-types get num-tags get - ; M: hi-tag-dispatch-engine compile-engine methods>> compile-engines* @@ -123,8 +175,8 @@ M: tuple-dispatch-engine compile-engine : sort-methods ( assoc -- assoc' ) >alist [ keys sort-classes ] keep extract-keys ; -: literalize-methods ( assoc -- assoc' ) - [ [ ] curry \ drop prefix ] assoc-map ; +: quote-methods ( assoc -- assoc' ) + [ 1quotation \ drop prefix ] assoc-map ; : methods-with-default ( engine -- assoc ) methods>> clone default get object bootstrap-word pick set-at ; @@ -141,34 +193,49 @@ M: tuple-dispatch-engine compile-engine } cond ; : class-predicates ( assoc -- assoc ) - [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ; + [ [ "predicate" word-prop [ dup ] prepend ] dip ] assoc-map ; -: predicate-engine-effect ( -- effect ) - (dispatch#) get 1+ dup 1+ ; +PREDICATE: predicate-engine-word < word "owner-generic" word-prop ; + +: ( -- word ) + generic-word get name>> "/predicate-engine" append f + dup generic-word get "owner-generic" set-word-prop ; + +M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ; : define-predicate-engine ( alist -- word ) - [ generic-word get name>> "/predicate-engine" append f dup ] dip - predicate-engine-effect define-declared ; + [ ] dip + [ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ; M: predicate-engine compile-engine methods-with-default sort-methods - literalize-methods + quote-methods prune-redundant-predicates class-predicates - [ peek wrapped>> ] - [ alist>quot picker prepend define-predicate-engine ] if-empty ; + [ peek ] [ alist>quot picker prepend define-predicate-engine ] if-empty ; M: word compile-engine ; M: f compile-engine ; -: build-engine ( generic combination -- engine ) - [ - #>> (dispatch#) set +: build-decision-tree ( generic -- methods ) + { [ generic-word set ] - [ "default-method" word-prop default set ] - [ "methods" word-prop ] tri - compile-engine 1quotation - picker [ lookup-method ] surround - ] with-scope ; \ No newline at end of file + [ "engines" word-prop forget-all ] + [ V{ } clone "engines" set-word-prop ] + [ + "methods" word-prop clone + [ find-default default set ] + [ compile-engine ] bi + ] + } cleave ; + +: execute-unsafe ( word -- ) (execute) ; + +M: single-combination perform-combination + [ + dup build-decision-tree + [ "decision-tree" set-word-prop ] + [ 1quotation picker [ lookup-method execute-unsafe ] surround define ] 2bi + ] with-combination ; \ No newline at end of file diff --git a/core/generic/standard/authors.txt b/core/generic/standard/authors.txt index 1901f27a24..d4f5d6b3ae 100644 --- a/core/generic/standard/authors.txt +++ b/core/generic/standard/authors.txt @@ -1 +1 @@ -Slava Pestov +Slava Pestov \ No newline at end of file diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor deleted file mode 100644 index b6cb9fc9f7..0000000000 --- a/core/generic/standard/engines/engines.factor +++ /dev/null @@ -1,53 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel kernel.private namespaces quotations -generic math sequences combinators words classes.algebra arrays -; -IN: generic.standard.engines - -SYMBOL: default -SYMBOL: assumed -SYMBOL: (dispatch#) - -GENERIC: engine>quot ( engine -- quot ) - -: engines>quots ( assoc -- assoc' ) - [ engine>quot ] assoc-map ; - -: engines>quots* ( assoc -- assoc' ) - [ over assumed [ engine>quot ] with-variable ] assoc-map ; - -: if-small? ( assoc true false -- ) - [ dup assoc-size 4 <= ] 2dip if ; inline - -: linear-dispatch-quot ( alist -- quot ) - default get [ drop ] prepend swap - [ - [ [ dup ] swap [ eq? ] curry compose ] - [ [ drop ] prepose ] - bi* [ ] like - ] assoc-map - alist>quot ; - -: split-methods ( assoc class -- first second ) - [ [ nip class<= not ] curry assoc-filter ] - [ [ nip class<= ] curry assoc-filter ] 2bi ; - -: convert-methods ( assoc class word -- assoc' ) - over [ split-methods ] 2dip pick assoc-empty? [ - 3drop - ] [ - [ execute ] dip pick set-at - ] if ; inline - -: (picker) ( n -- quot ) - { - { 0 [ [ dup ] ] } - { 1 [ [ over ] ] } - { 2 [ [ pick ] ] } - [ 1- (picker) [ dip swap ] curry ] - } case ; - -: picker ( -- quot ) \ (dispatch#) get (picker) ; - -GENERIC: extra-values ( generic -- n ) diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor deleted file mode 100644 index 152b112c2a..0000000000 --- a/core/generic/standard/engines/predicate/predicate.factor +++ /dev/null @@ -1,38 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: generic.standard.engines generic namespaces kernel -kernel.private sequences classes.algebra accessors words -combinators assocs arrays ; -IN: generic.standard.engines.predicate - -TUPLE: predicate-dispatch-engine methods ; - -C: predicate-dispatch-engine - -: class-predicates ( assoc -- assoc ) - [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ; - -: keep-going? ( assoc -- ? ) - assumed get swap second first class<= ; - -: prune-redundant-predicates ( assoc -- default assoc' ) - { - { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] } - { [ dup length 1 = ] [ first second { } ] } - { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] } - [ [ first second ] [ rest-slice ] bi ] - } cond ; - -: sort-methods ( assoc -- assoc' ) - >alist [ keys sort-classes ] keep extract-keys ; - -: methods-with-default ( engine -- assoc ) - methods>> clone default get object bootstrap-word pick set-at ; - -M: predicate-dispatch-engine engine>quot - methods-with-default - engines>quots - sort-methods - prune-redundant-predicates - class-predicates - alist>quot ; diff --git a/core/generic/standard/engines/predicate/summary.txt b/core/generic/standard/engines/predicate/summary.txt deleted file mode 100644 index 47fee09ee5..0000000000 --- a/core/generic/standard/engines/predicate/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Chained-conditional dispatch strategy diff --git a/core/generic/standard/engines/summary.txt b/core/generic/standard/engines/summary.txt deleted file mode 100644 index 209190799b..0000000000 --- a/core/generic/standard/engines/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Generic word dispatch strategy implementation diff --git a/core/generic/standard/engines/tag/summary.txt b/core/generic/standard/engines/tag/summary.txt deleted file mode 100644 index 3eea4b11cf..0000000000 --- a/core/generic/standard/engines/tag/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Jump table keyed by pointer tag dispatch strategy diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor deleted file mode 100644 index 5ed33009c0..0000000000 --- a/core/generic/standard/engines/tag/tag.factor +++ /dev/null @@ -1,71 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: classes.private generic.standard.engines namespaces make -arrays assocs sequences.private quotations kernel.private -math slots.private math.private kernel accessors words -layouts sorting sequences combinators ; -IN: generic.standard.engines.tag - -TUPLE: lo-tag-dispatch-engine methods ; - -C: lo-tag-dispatch-engine - -: direct-dispatch-quot ( alist n -- quot ) - default get - [ swap update ] keep - [ dispatch ] curry >quotation ; - -: lo-tag-number ( class -- n ) - dup \ hi-tag bootstrap-word eq? [ - drop \ hi-tag tag-number - ] [ - "type" word-prop - ] if ; - -: sort-tags ( assoc -- alist ) >alist sort-keys reverse ; - -: tag-dispatch-test ( tag# -- quot ) - picker [ tag ] append swap [ eq? ] curry append ; - -: tag-dispatch-quot ( alist -- quot ) - [ default get ] dip - [ [ tag-dispatch-test ] dip ] assoc-map - alist>quot ; - -M: lo-tag-dispatch-engine engine>quot - methods>> engines>quots* - [ [ lo-tag-number ] dip ] assoc-map - [ - [ sort-tags tag-dispatch-quot ] - [ picker % [ tag ] % num-tags get direct-dispatch-quot ] - if-small? % - ] [ ] make ; - -TUPLE: hi-tag-dispatch-engine methods ; - -C: hi-tag-dispatch-engine - -: convert-hi-tag-methods ( assoc -- assoc' ) - \ hi-tag bootstrap-word - \ convert-methods ; - -: num-hi-tags ( -- n ) num-types get num-tags get - ; - -: hi-tag-number ( class -- n ) - "type" word-prop ; - -: hi-tag-quot ( -- quot ) - \ hi-tag def>> ; - -M: hi-tag-dispatch-engine engine>quot - methods>> engines>quots* - [ [ hi-tag-number ] dip ] assoc-map - [ - picker % hi-tag-quot % [ - sort-tags linear-dispatch-quot - ] [ - num-tags get , \ fixnum-fast , - [ [ num-tags get - ] dip ] assoc-map - num-hi-tags direct-dispatch-quot - ] if-small? % - ] [ ] make ; diff --git a/core/generic/standard/engines/tuple/summary.txt b/core/generic/standard/engines/tuple/summary.txt deleted file mode 100644 index cb18ac5c78..0000000000 --- a/core/generic/standard/engines/tuple/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Tuple class dispatch strategy diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor deleted file mode 100644 index a0711af095..0000000000 --- a/core/generic/standard/engines/tuple/tuple.factor +++ /dev/null @@ -1,167 +0,0 @@ -! Copyright (c) 2008 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: kernel classes.tuple.private hashtables assocs sorting -accessors combinators sequences slots.private math.parser words -effects namespaces make generic generic.standard.engines -classes.algebra math math.private kernel.private -quotations arrays definitions ; -IN: generic.standard.engines.tuple - -: nth-superclass% ( n -- ) 2 * 5 + , \ slot , ; inline - -: nth-hashcode% ( n -- ) 2 * 6 + , \ slot , ; inline - -: tuple-layout% ( -- ) - [ { tuple } declare 1 slot { array } declare ] % ; inline - -: tuple-layout-echelon% ( -- ) - [ 4 slot ] % ; inline - -TUPLE: echelon-dispatch-engine n methods ; - -C: echelon-dispatch-engine - -TUPLE: trivial-tuple-dispatch-engine n methods ; - -C: trivial-tuple-dispatch-engine - -TUPLE: tuple-dispatch-engine echelons ; - -: push-echelon ( class method assoc -- ) - [ swap dup "layout" word-prop third ] dip - [ ?set-at ] change-at ; - -: echelon-sort ( assoc -- assoc' ) - V{ } clone [ - [ - push-echelon - ] curry assoc-each - ] keep sort-keys ; - -: ( methods -- engine ) - echelon-sort - [ dupd ] assoc-map - \ tuple-dispatch-engine boa ; - -: convert-tuple-methods ( assoc -- assoc' ) - tuple bootstrap-word - \ convert-methods ; - -M: trivial-tuple-dispatch-engine engine>quot - [ n>> ] [ methods>> ] bi dup assoc-empty? [ - 2drop default get [ drop ] prepend - ] [ - [ - [ nth-superclass% ] - [ engines>quots* linear-dispatch-quot % ] bi* - ] [ ] make - ] if ; - -: hash-methods ( n methods -- buckets ) - >alist V{ } clone [ hashcode 1array ] distribute-buckets - [ ] with map ; - -: class-hash-dispatch-quot ( n methods -- quot ) - [ - \ dup , - [ drop nth-hashcode% ] - [ hash-methods [ engine>quot ] map hash-dispatch-quot % ] 2bi - ] [ ] make ; - -: engine-word-name ( -- string ) - generic get name>> "/tuple-dispatch-engine" append ; - -PREDICATE: engine-word < word - "tuple-dispatch-generic" word-prop generic? ; - -M: engine-word stack-effect - "tuple-dispatch-generic" word-prop - [ extra-values ] [ stack-effect ] bi - dup [ - [ in>> length + ] [ out>> ] [ terminated?>> ] tri - effect boa - ] [ 2drop f ] if ; - -M: engine-word where "tuple-dispatch-generic" word-prop where ; - -M: engine-word crossref? "forgotten" word-prop not ; - -: remember-engine ( word -- ) - generic get "engines" word-prop push ; - -: ( -- word ) - engine-word-name f - dup generic get "tuple-dispatch-generic" set-word-prop ; - -: define-engine-word ( quot -- word ) - [ dup ] dip define ; - -: tuple-dispatch-engine-body ( engine -- quot ) - [ - picker % - tuple-layout% - [ n>> ] [ methods>> ] bi - [ engine>quot ] - [ class-hash-dispatch-quot ] - if-small? % - ] [ ] make ; - -M: echelon-dispatch-engine engine>quot - dup n>> zero? [ - methods>> dup assoc-empty? - [ drop default get ] [ values first engine>quot ] if - ] [ - tuple-dispatch-engine-body - ] if ; - -: >=-case-quot ( default alist -- quot ) - [ [ drop ] prepend ] dip - [ - [ [ dup ] swap [ fixnum>= ] curry compose ] - [ [ drop ] prepose ] - bi* [ ] like - ] assoc-map - alist>quot ; - -: simplify-echelon-alist ( default alist -- default' alist' ) - dup empty? [ - dup first first 1 <= [ - nip unclip second swap - simplify-echelon-alist - ] when - ] unless ; - -: echelon-case-quot ( alist -- quot ) - #! We don't have to test for echelon 1 since all tuple - #! classes are at least at depth 1 in the inheritance - #! hierarchy. - default get swap simplify-echelon-alist - [ - [ - picker % - tuple-layout% - tuple-layout-echelon% - >=-case-quot % - ] [ ] make - ] unless-empty ; - -M: tuple-dispatch-engine engine>quot - [ - [ - tuple assumed set - echelons>> unclip-last - [ - [ - engine>quot - over 0 = [ - define-engine-word - [ remember-engine ] [ 1quotation ] bi - ] unless - dup default set - ] assoc-map - ] - [ first2 engine>quot 2array ] bi* - suffix - ] with-scope - echelon-case-quot % - ] [ ] make ; diff --git a/core/generic/standard/standard-docs.factor b/core/generic/standard/standard-docs.factor index 6e788eb947..33da0037b3 100644 --- a/core/generic/standard/standard-docs.factor +++ b/core/generic/standard/standard-docs.factor @@ -1,12 +1,7 @@ -USING: generic help.markup help.syntax sequences math +USING: generic generic.single help.markup help.syntax sequences math math.parser effects ; IN: generic.standard -HELP: no-method -{ $values { "object" "an object" } { "generic" "a generic word" } } -{ $description "Throws a " { $link no-method } " error." } -{ $error-description "Thrown by the " { $snippet "generic" } " word to indicate it does not have a method for the class of " { $snippet "object" } "." } ; - HELP: standard-combination { $class-description "Performs standard method combination." @@ -22,32 +17,6 @@ HELP: standard-combination } } ; -HELP: hook-combination -{ $class-description - "Performs hook method combination . See " { $link POSTPONE: HOOK: } "." -} ; - HELP: define-simple-generic { $values { "word" "a word" } { "effect" effect } } -{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ; - -{ standard-combination hook-combination } related-words - -HELP: inconsistent-next-method -{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." } -{ $examples - "The following code throws this error:" - { $code - "GENERIC: error-test ( object -- )" - "" - "M: string error-test print ;" - "" - "M: integer error-test number>string call-next-method ;" - "" - "123 error-test" - } - "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method." - $nl - "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:" - { $code "M: integer error-test number>string error-test ;" } -} ; +{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ; \ No newline at end of file diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 5dbc0d17a1..bbf458ef1d 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -1,100 +1,10 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs kernel kernel.private slots.private math -namespaces make sequences vectors words quotations definitions -hashtables layouts combinators sequences.private generic -classes classes.algebra classes.private generic.standard.engines -generic.standard.engines.tag generic.standard.engines.predicate -generic.standard.engines.tuple accessors ; +USING: accessors definitions generic generic.single kernel +namespaces words math combinators ; IN: generic.standard -GENERIC: dispatch# ( word -- n ) - -M: generic dispatch# - "combination" word-prop dispatch# ; - -GENERIC: method-declaration ( class generic -- quot ) - -M: generic method-declaration - "combination" word-prop method-declaration ; - -M: quotation engine>quot - assumed get generic get method-declaration prepend ; - -ERROR: no-method object generic ; - -: error-method ( word -- quot ) - [ picker ] dip [ no-method ] curry append ; - -: push-method ( method specializer atomic assoc -- ) - [ - [ H{ } clone ] unless* - [ methods>> set-at ] keep - ] change-at ; - -: flatten-method ( class method assoc -- ) - [ [ flatten-class keys ] keep ] 2dip [ - [ spin ] dip push-method - ] 3curry each ; - -: flatten-methods ( assoc -- assoc' ) - H{ } clone [ - [ - flatten-method - ] curry assoc-each - ] keep ; - -: ( assoc -- engine ) - flatten-methods - convert-tuple-methods - convert-hi-tag-methods - ; - -: mangle-method ( method -- quot ) - 1quotation generic get extra-values \ drop - prepend [ ] like ; - -: find-default ( methods -- quot ) - #! Side-effects methods. - [ object bootstrap-word ] dip delete-at* [ - drop generic get "default-method" word-prop mangle-method - ] unless ; - -: ( word -- engine ) - object bootstrap-word assumed set { - [ generic set ] - [ "engines" word-prop forget-all ] - [ V{ } clone "engines" set-word-prop ] - [ - "methods" word-prop - [ mangle-method ] assoc-map - [ find-default default set ] - [ ] - bi - ] - } cleave ; - -: single-combination ( word -- quot ) - [ engine>quot ] with-scope ; - -ERROR: inconsistent-next-method class generic ; - -: single-next-method-quot ( class generic -- quot/f ) - 2dup next-method dup [ - [ - pick "predicate" word-prop % - 1quotation , - [ inconsistent-next-method ] 2curry , - \ if , - ] [ ] make - ] [ 3drop f ] if ; - -: single-effective-method ( obj word -- method ) - [ [ order [ instance? ] with find-last nip ] keep method ] - [ "default-method" word-prop ] - bi or ; - -TUPLE: standard-combination # ; +TUPLE: standard-combination < single-combination # ; C: standard-combination @@ -102,79 +12,26 @@ PREDICATE: standard-generic < generic "combination" word-prop standard-combination? ; PREDICATE: simple-generic < standard-generic - "combination" word-prop #>> zero? ; + "combination" word-prop #>> 0 = ; CONSTANT: simple-combination T{ standard-combination f 0 } : define-simple-generic ( word effect -- ) [ simple-combination ] dip define-generic ; -: with-standard ( combination quot -- quot' ) - [ #>> (dispatch#) ] dip with-variable ; inline +: (picker) ( n -- quot ) + { + { 0 [ [ dup ] ] } + { 1 [ [ over ] ] } + { 2 [ [ pick ] ] } + [ 1- (picker) [ dip swap ] curry ] + } case ; -M: standard-generic extra-values drop 0 ; - -M: standard-combination make-default-method - [ error-method ] with-standard ; - -M: standard-combination perform-combination - [ drop ] [ [ single-combination ] with-standard ] 2bi define ; +M: standard-combination picker + combination get #>> (picker) ; M: standard-combination dispatch# #>> ; -M: standard-combination method-declaration - dispatch# object swap prefix [ declare ] curry [ ] like ; - -M: standard-combination next-method-quot* - [ - single-next-method-quot - dup [ picker prepend ] when - ] with-standard ; - -M: standard-generic effective-method - [ dispatch# (picker) call ] keep single-effective-method ; - -TUPLE: hook-combination var ; - -C: hook-combination - -PREDICATE: hook-generic < generic - "combination" word-prop hook-combination? ; - -: with-hook ( combination quot -- quot' ) - 0 (dispatch#) [ - [ hook-combination ] dip with-variable - ] with-variable ; inline - -: prepend-hook-var ( quot -- quot' ) - hook-combination get var>> [ get ] curry prepend ; - -M: hook-combination dispatch# drop 0 ; - -M: hook-combination method-declaration 2drop [ ] ; - -M: hook-generic extra-values drop 1 ; - -M: hook-generic effective-method - [ "combination" word-prop var>> get ] keep - single-effective-method ; - -M: hook-combination make-default-method - [ error-method prepend-hook-var ] with-hook ; - -M: hook-combination perform-combination - [ drop ] [ - [ single-combination prepend-hook-var ] with-hook - ] 2bi define ; - -M: hook-combination next-method-quot* - [ - single-next-method-quot - dup [ prepend-hook-var ] when - ] with-hook ; - M: simple-generic definer drop \ GENERIC: f ; -M: standard-generic definer drop \ GENERIC# f ; - -M: hook-generic definer drop \ HOOK: f ; +M: standard-generic definer drop \ GENERIC# f ; \ No newline at end of file diff --git a/core/generic/standard/summary.txt b/core/generic/standard/summary.txt deleted file mode 100644 index 5e731c6f15..0000000000 --- a/core/generic/standard/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Standard method combination used for most generic words diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 7ab287fd20..e8f86faa9d 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -1,7 +1,7 @@ USING: generic help.syntax help.markup kernel math parser words effects classes generic.standard classes.tuple generic.math -generic.standard arrays io.pathnames vocabs.loader io sequences -assocs words.symbol words.alias words.constant combinators ; +generic.standard generic.single arrays io.pathnames vocabs.loader io +sequences assocs words.symbol words.alias words.constant combinators ; IN: syntax ARTICLE: "parser-algorithm" "Parser algorithm" diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 2e072f72d8..3512b92e4c 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -4,7 +4,7 @@ USING: accessors alien arrays byte-arrays definitions generic hashtables kernel math namespaces parser lexer sequences strings strings.parser sbufs vectors words words.symbol words.constant words.alias quotations io assocs splitting classes.tuple -generic.standard generic.math generic.parser classes +generic.standard generic.hook generic.math generic.parser classes io.pathnames vocabs vocabs.parser classes.parser classes.union classes.intersection classes.mixin classes.predicate classes.singleton classes.tuple.parser compiler.units diff --git a/core/words/words.factor b/core/words/words.factor index eb0599db78..894b671494 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -154,8 +154,15 @@ M: word reset-word : reset-generic ( word -- ) [ subwords forget-all ] [ reset-word ] - [ { "methods" "combination" "default-method" } reset-props ] - tri ; + [ + { + "methods" + "combination" + "default-method" + "engines" + "decision-tree" + } reset-props + ] tri ; : gensym ( -- word ) "( gensym )" f ; From d03b1eef01778242512c6fb0a7fd542fb7ab78e7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 20:54:30 -0500 Subject: [PATCH 080/246] Compile methods of generic words since the generic word itself doesn't get compiled --- basis/compiler/compiler.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 26f9dc47c9..efa6294c98 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -163,7 +163,10 @@ M: optimizing-compiler recompile ( words -- alist ) [ compile-queue set H{ } clone compiled set - [ queue-compile ] each + [ + [ queue-compile ] + [ subwords [ compile-dependency ] each ] bi + ] each compile-queue get compile-loop compiled get >alist ] with-scope ; From b31f8a0d15775357aabbd0ce8e04dea4ad7c3810 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Fri, 24 Apr 2009 23:23:02 -0500 Subject: [PATCH 081/246] peg lexer changes --- extra/peg-lexer/peg-lexer.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/peg-lexer/peg-lexer.factor b/extra/peg-lexer/peg-lexer.factor index e7acf1f5bb..e58d8dd65b 100644 --- a/extra/peg-lexer/peg-lexer.factor +++ b/extra/peg-lexer/peg-lexer.factor @@ -1,5 +1,6 @@ USING: hashtables assocs sequences locals math accessors multiline delegate strings -delegate.protocols kernel peg peg.ebnf lexer namespaces combinators parser words ; +delegate.protocols kernel peg peg.ebnf peg.private lexer namespaces combinators parser +words ; IN: peg-lexer TUPLE: lex-hash hash ; @@ -43,11 +44,11 @@ M: lex-hash at* : parse* ( parser -- ast ) compile - [ execute( -- result ) [ error-stack get first throw ] unless* ] with-global-lexer + [ execute [ error-stack get first throw ] unless* ] with-global-lexer ast>> ; : create-bnf ( name parser -- ) - reset-tokenizer [ lexer get skip-blank parse* parsed ] curry + reset-tokenizer [ lexer get skip-blank parse* dup ignore? [ drop ] [ parsed ] if ] curry define-syntax ; SYNTAX: ON-BNF: From 8be8357e4d7393d114a588b2bee38ec2abdb6632 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Fri, 24 Apr 2009 23:23:35 -0500 Subject: [PATCH 082/246] ui.gadgets.alerts updated for new ui --- extra/ui/gadgets/alerts/alerts.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/ui/gadgets/alerts/alerts.factor b/extra/ui/gadgets/alerts/alerts.factor index 04c6b013df..03d60957fa 100644 --- a/extra/ui/gadgets/alerts/alerts.factor +++ b/extra/ui/gadgets/alerts/alerts.factor @@ -1,4 +1,4 @@ -USING: accessors ui ui.gadgets ui.gadgets.labels ui.gadgets.buttons ui.gadgets.packs locals sequences io.styles ; +USING: accessors ui ui.gadgets ui.gadgets.labels ui.gadgets.buttons ui.gadgets.packs locals sequences fonts io.styles ; IN: ui.gadgets.alerts -:: alert ( quot string -- ) { 10 10 } >>gap 1 >>align string