Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Basic flags support and kill for cursor.

  • Loading branch information...
commit f0570aee208e7944e2a57d5eccf7bedd05ca8b23 1 parent 32d665b
Pawel Pabian authored
2  META.info
... ... @@ -1,6 +1,6 @@
1 1 {
2 2 "name" : "MongoDB",
3   - "version" : "0.2",
  3 + "version" : "0.3",
4 4 "description" : "MongoDB driver",
5 5 "author" : "Pawel Pabian",
6 6 "authority" : "bbkr",
14 MongoDB Perl6 driver.xcodeproj/project.pbxproj
@@ -7,9 +7,14 @@
7 7 objects = {
8 8
9 9 /* Begin PBXFileReference section */
  10 + 8128962714A27D3900BDC0AC /* update.t */ = {isa = PBXFileReference; lastKnownFileType = text; path = update.t; sourceTree = "<group>"; xcLanguageSpecificationIdentifier = xcode.lang.perl; };
  11 + 8128962A14A29B0E00BDC0AC /* remove.t */ = {isa = PBXFileReference; lastKnownFileType = text; path = remove.t; sourceTree = "<group>"; xcLanguageSpecificationIdentifier = xcode.lang.perl; };
  12 + 8128962B14A336DA00BDC0AC /* find.t */ = {isa = PBXFileReference; lastKnownFileType = text; path = find.t; sourceTree = "<group>"; xcLanguageSpecificationIdentifier = xcode.lang.perl; };
  13 + 8128962C14A34B6F00BDC0AC /* changelog.txt */ = {isa = PBXFileReference; lastKnownFileType = text; path = changelog.txt; sourceTree = "<group>"; };
10 14 81322EC71441DCD900D0AF15 /* logo_32x32.png */ = {isa = PBXFileReference; lastKnownFileType = image.png; path = logo_32x32.png; sourceTree = "<group>"; };
11 15 81322EC81441DCD900D0AF15 /* META.info */ = {isa = PBXFileReference; lastKnownFileType = text; path = META.info; sourceTree = "<group>"; };
12 16 81619C7014601C4700315881 /* Protocol.pm */ = {isa = PBXFileReference; lastKnownFileType = text.script.perl; path = Protocol.pm; sourceTree = "<group>"; };
  17 + 816DD7FD1486CD8100491105 /* insert.t */ = {isa = PBXFileReference; lastKnownFileType = text; path = insert.t; sourceTree = "<group>"; xcLanguageSpecificationIdentifier = xcode.lang.perl; };
13 18 81C247041416C8BA000A420F /* README */ = {isa = PBXFileReference; lastKnownFileType = text; path = README; sourceTree = "<group>"; };
14 19 81C247071416C8F9000A420F /* Collection.pm */ = {isa = PBXFileReference; lastKnownFileType = text.script.perl; path = Collection.pm; sourceTree = "<group>"; };
15 20 81C247081416C8F9000A420F /* Connection.pm */ = {isa = PBXFileReference; lastKnownFileType = text.script.perl; path = Connection.pm; sourceTree = "<group>"; };
@@ -17,8 +22,6 @@
17 22 81C2470A1416C8F9000A420F /* DataBase.pm */ = {isa = PBXFileReference; lastKnownFileType = text.script.perl; path = DataBase.pm; sourceTree = "<group>"; };
18 23 81C2470B1416C8F9000A420F /* Wire.pm */ = {isa = PBXFileReference; lastKnownFileType = text.script.perl; path = Wire.pm; sourceTree = "<group>"; };
19 24 81C2470C1416C8F9000A420F /* MongoDB.pm */ = {isa = PBXFileReference; lastKnownFileType = text.script.perl; path = MongoDB.pm; sourceTree = "<group>"; };
20   - 81C2470E1416C90A000A420F /* load.t */ = {isa = PBXFileReference; lastKnownFileType = text; path = load.t; sourceTree = "<group>"; };
21   - 81C247101416C90A000A420F /* wire.t */ = {isa = PBXFileReference; lastKnownFileType = text; path = wire.t; sourceTree = "<group>"; };
22 25 /* End PBXFileReference section */
23 26
24 27 /* Begin PBXGroup section */
@@ -33,6 +36,7 @@
33 36 81C246FB1416C6B8000A420F = {
34 37 isa = PBXGroup;
35 38 children = (
  39 + 8128962C14A34B6F00BDC0AC /* changelog.txt */,
36 40 81322EC61441DCD900D0AF15 /* logotype */,
37 41 81322EC81441DCD900D0AF15 /* META.info */,
38 42 81C2470D1416C90A000A420F /* t */,
@@ -66,8 +70,10 @@
66 70 81C2470D1416C90A000A420F /* t */ = {
67 71 isa = PBXGroup;
68 72 children = (
69   - 81C2470E1416C90A000A420F /* load.t */,
70   - 81C247101416C90A000A420F /* wire.t */,
  73 + 816DD7FD1486CD8100491105 /* insert.t */,
  74 + 8128962714A27D3900BDC0AC /* update.t */,
  75 + 8128962A14A29B0E00BDC0AC /* remove.t */,
  76 + 8128962B14A336DA00BDC0AC /* find.t */,
71 77 );
72 78 path = t;
73 79 sourceTree = "<group>";
44 README
@@ -5,11 +5,8 @@ This is working MongoDB driver at early stage of development.
5 5
6 6 VERSION
7 7
8   -This version should be used with BSON 0.2.
9   -
10   -Version 0.2 is compatible with Rakudo 2011.09+,
11   -and will be merged into main branch after Star release.
12   -
  8 +This module is compatible with Rakudo 2011.09+
  9 +and requires BSON 0.2+.
13 10
14 11 SYNOPSIS
15 12
@@ -19,7 +16,7 @@ Let's see what it can do...
19 16 use MongoDB;
20 17
21 18 my $connection = MongoDB::Connection.new( );
22   - my $database = $connection.database( 'test' );
  19 + my $database = $connection.database( 'test' );
23 20 my $collection = $database.collection( 'perl_users' );
24 21 my $cursor;
25 22
@@ -67,13 +64,28 @@ Let's see what it can do...
67 64 $collection.update( { 'nick' => 'andee' }, { '$push' => { 'versions' => 6 } } );
68 65
69 66
70   - #### delete documents from collection ####
  67 + #### remove documents from collection ####
  68 +
  69 + # remove specific documents
  70 + $collection.remove( { 'nick' => 'bbkr' } );
  71 +
  72 + # or remove all documents
  73 + $collection.remove( );
  74 +
71 75
72   - # delete specific documents
73   - $collection.delete( { 'nick' => 'bbkr' } );
  76 +FLAGS
74 77
75   - # or delete all documents
76   - $collection.delete( );
  78 +Flags are boolean values, false by default.
  79 +They can be used anywhere and in any order in methods.
  80 +
  81 + remove( { 'nick' => 'bbkr' }, :single_remove );
  82 + remove( :single_remove, { 'nick' => 'bbkr' } ); # same
  83 +
  84 +Currently supported
  85 + insert - :continue_on_errror
  86 + find - :no_cursor_timeout
  87 + update - :upsert, :multi_update
  88 + remove - :single_remove
77 89
78 90
79 91 FEATURE ROADMAP
@@ -81,22 +93,18 @@ FEATURE ROADMAP
81 93 List of things you may expect in nearest future.
82 94
83 95 * find_one( ) - syntactic sugar for selecting without cursor
84   -* update_one( ) - update only first matching record
85   -* update( ) - with upsert
86 96 * error handler
87 97 * database authentication
88   -* kill( ) - for cursor to abandon remaining data
89 98 * drop database or collection
90 99 * more stuff from http://www.mongodb.org/display/DOCS/Mongo+Driver+Requirements
91 100
92 101
93 102 KNOWN LIMITATIONS
94 103
95   -* lack of Num or Rat support
96   - this is directly related to not yet specified pack/unpack in Perl6
97 104 * big integers (int64)
98   - those are not yet implemented in Rakudo
99   -* speed
  105 +* lack of Num or Rat support,
  106 + this is directly related to not yet specified pack/unpack in Perl6
  107 +* speed,
100 108 protocol correctness and clear code are priorities for now
101 109
102 110
12 changelog.txt
... ... @@ -0,0 +1,12 @@
  1 +0.3
  2 +
  3 +* Basic added to methods (upsert, multi_update, single_remove,...)
  4 +* Kill support for cursor.
  5 +
  6 +0.2
  7 +
  8 +* Adapted to Rakudo NOM 2011.09+.
  9 +
  10 +0.1
  11 +
  12 +* Basic Proof-of-concept working on Rakudo 2011.07.
2  lib/MongoDB.pm
... ... @@ -1,4 +1,4 @@
1   -module MongoDB;
  1 +module MongoDB:ver<0.3>;
2 2
3 3 use MongoDB::Wire;
4 4
44 lib/MongoDB/Collection.pm
@@ -14,23 +14,49 @@ submethod BUILD ( :$database, Str :$name ) {
14 14 $.name = $name;
15 15 }
16 16
17   -method insert ( *@documents ) {
18   - self.wire.OP_INSERT( self, 0, @documents );
  17 +method insert (
  18 + *@documents where { +@documents and [&&]@documents>>.isa( Hash ) },
  19 + Bool :$continue_on_error = False
  20 +) {
  21 +
  22 + my $flags = +$continue_on_error;
  23 +
  24 + self.wire.OP_INSERT( self, $flags, @documents );
19 25 }
20 26
21   -method find ( %query = { } ) {
  27 +method find (
  28 + %query = { },
  29 + Int :$number_to_skip = 0, Int :$number_to_return = 0,
  30 + Bool :$no_cursor_timeout = False
  31 +) {
  32 +
  33 + my $flags = +$no_cursor_timeout +< 4;
  34 + my $OP_REPLY = self.wire.OP_QUERY( self, $flags, $number_to_skip, $number_to_return, %query );
  35 +
22 36
23 37 return MongoDB::Cursor.new(
24 38 collection => self,
25   - query => %query,
  39 + OP_REPLY => $OP_REPLY,
26 40 );
27 41 }
28 42
29   -method update ( %selector, %update ) {
30   - self.wire.OP_UPDATE( self, %selector, %update );
31   -}
  43 +method update (
  44 + %selector, %update,
  45 + Bool :$upsert = False, Bool :$multi_update = False
  46 +) {
  47 +
  48 + my $flags = +$upsert
  49 + + +$multi_update +< 1;
32 50
33   -method delete ( %selector = { } ) {
34   - self.wire.OP_DELETE( self, %selector );
  51 + self.wire.OP_UPDATE( self, $flags, %selector, %update );
35 52 }
36 53
  54 +method remove (
  55 + %selector = { },
  56 + Bool :$single_remove = False
  57 +) {
  58 +
  59 + my $flags = +$single_remove;
  60 +
  61 + self.wire.OP_DELETE( self, $flags, %selector );
  62 +}
20 lib/MongoDB/Cursor.pm
@@ -4,23 +4,16 @@ class MongoDB::Cursor does MongoDB::Protocol;
4 4
5 5 has $.collection is rw;
6 6
7   -has %.query is rw;
8   -
9 7 # int64 (8 byte buffer)
10 8 has Buf $.id is rw;
11 9
12 10 # batch of documents in last response
13 11 has @.documents is rw;
14 12
15   -submethod BUILD ( :$collection, :%query ) {
  13 +submethod BUILD ( :$collection, :%OP_REPLY ) {
16 14
17 15 $.collection = $collection;
18 16
19   - %.query = %query;
20   -
21   - # request first batch of documents
22   - my %OP_REPLY = self.wire.OP_QUERY( self );
23   -
24 17 # assign cursorID
25 18 $.id = %OP_REPLY{ 'cursor_id' };
26 19
@@ -37,7 +30,8 @@ method fetch ( ) {
37 30 # request next batch of documents
38 31 my %OP_REPLY = self.wire.OP_GETMORE( self );
39 32
40   - # assign cursorID
  33 + # assign cursorID,
  34 + # it may change to "0" if there are no more documents to fetch
41 35 $.id = %OP_REPLY{ 'cursor_id' };
42 36
43 37 # assign documents
@@ -47,3 +41,11 @@ method fetch ( ) {
47 41 return @.documents.shift;
48 42 }
49 43
  44 +method kill ( ) {
  45 +
  46 + # invalidate cursor on database
  47 + self.wire.OP_KILL_CURSORS( self );
  48 +
  49 + # invalidate cursor id
  50 + $.id = Buf.new( 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 );
  51 +}
47 lib/MongoDB/Wire.pm
@@ -105,31 +105,31 @@ method OP_INSERT ( $collection, Int $flags, *@documents ) {
105 105 $collection.database.connection.send( $msg_header ~ $OP_INSERT, False );
106 106 }
107 107
108   -method OP_QUERY ( $cursor ) {
  108 +method OP_QUERY ( $collection, $flags, $number_to_skip, $number_to_return, %query ) {
109 109 # http://www.mongodb.org/display/DOCS/Mongo+Wire+Protocol#MongoWireProtocol-OPQUERY
110 110
111 111 my Buf $OP_QUERY =
112 112
113 113 # int32 flags
114 114 # bit vector of query options
115   - self._int32( 0 )
  115 + self._int32( $flags )
116 116
117 117 # cstring fullCollectionName
118 118 # "dbname.collectionname"
119   - ~ self._cstring( join '.', $cursor.collection.database.name, $cursor.collection.name )
  119 + ~ self._cstring( join '.', $collection.database.name, $collection.name )
120 120
121 121 # int32 numberToSkip
122 122 # number of documents to skip
123   - ~ self._int32( 0 )
  123 + ~ self._int32( $number_to_skip )
124 124
125 125 # int32 numberToReturn
126 126 # number of documents to return
127 127 # in the first OP_REPLY batch
128   - ~ self._int32( 0 )
  128 + ~ self._int32( $number_to_return )
129 129
130 130 # document query
131 131 # query object
132   - ~ self._document( $cursor.query );
  132 + ~ self._document( %query );
133 133
134 134 # TODO
135 135 # [ document returnFieldSelector; ]
@@ -140,7 +140,7 @@ method OP_QUERY ( $cursor ) {
140 140 my Buf $msg_header = self._msg_header( $OP_QUERY.elems, 'OP_QUERY' );
141 141
142 142 # send message and wait for response
143   - my Buf $OP_REPLY = $cursor.collection.database.connection.send( $msg_header ~ $OP_QUERY, True );
  143 + my Buf $OP_REPLY = $collection.database.connection.send( $msg_header ~ $OP_QUERY, True );
144 144
145 145 # parse response
146 146 my %OP_REPLY = self.OP_REPLY( $OP_REPLY );
@@ -199,7 +199,34 @@ method OP_GETMORE ( $cursor ) {
199 199 return %OP_REPLY;
200 200 }
201 201
202   -method OP_UPDATE ( $collection, %selector, %update, Int $flags = 2 ) {
  202 +method OP_KILL_CURSORS ( *@cursors ) {
  203 + # http://www.mongodb.org/display/DOCS/Mongo+Wire+Protocol#MongoWireProtocol-OPKILLCURSORS
  204 +
  205 + my Buf $OP_KILL_CURSORS =
  206 +
  207 + # int32 ZERO
  208 + # 0 - reserved for future use
  209 + self._int32( 0 )
  210 +
  211 + # int32 numberOfCursorIDs
  212 + # number of cursorIDs in message
  213 + ~ self._int32( +@cursors );
  214 +
  215 + # int64* cursorIDs
  216 + # sequence of cursorIDs to close
  217 + for @cursors -> $cursor {
  218 + $OP_KILL_CURSORS ~= $cursor.id;
  219 + }
  220 +
  221 + # MsgHeader header
  222 + # standard message header
  223 + my Buf $msg_header = self._msg_header( $OP_KILL_CURSORS.elems, 'OP_KILL_CURSORS' );
  224 +
  225 + # send message without waiting for response
  226 + @cursors[0].collection.database.connection.send( $msg_header ~ $OP_KILL_CURSORS, False );
  227 +}
  228 +
  229 +method OP_UPDATE ( $collection, Int $flags, %selector, %update ) {
203 230 # http://www.mongodb.org/display/DOCS/Mongo+Wire+Protocol#MongoWireProtocol-OPUPDATE
204 231
205 232 my Buf $OP_UPDATE =
@@ -232,7 +259,7 @@ method OP_UPDATE ( $collection, %selector, %update, Int $flags = 2 ) {
232 259 $collection.database.connection.send( $msg_header ~ $OP_UPDATE, False );
233 260 }
234 261
235   -method OP_DELETE ( $collection, %selector, Int $flags = 0 ) {
  262 +method OP_DELETE ( $collection, Int $flags, %selector ) {
236 263 # http://www.mongodb.org/display/DOCS/Mongo+Wire+Protocol#MongoWireProtocol-OPDELETE
237 264
238 265 my Buf $OP_DELETE =
@@ -296,7 +323,7 @@ method OP_REPLY ( Buf $b ) {
296 323
297 324 );
298 325
299   - # extract documents in message
  326 + # extract documents from message
300 327 for ^%OP_REPLY{ 'number_returned' } {
301 328 my %document = self._document( $a );
302 329 %OP_REPLY{ 'documents' }.push( { %document } );
69 t/find.t
... ... @@ -0,0 +1,69 @@
  1 +BEGIN { @*INC.unshift( 'lib' ) }
  2 +
  3 +use Test;
  4 +use MongoDB;
  5 +
  6 +plan( 9 );
  7 +
  8 +my $connection = MongoDB::Connection.new;
  9 +my $database = $connection.database( 'test' );
  10 +my $collection = $database.collection( 'perl6_driver' );
  11 +
  12 +# TODO replace with drop when available
  13 +$collection.remove( );
  14 +
  15 +my (@documents, $cursor);
  16 +
  17 +# feed test data
  18 +@documents.push( { 'foo' => $_} ) for ^128;
  19 +$collection.insert( @documents );
  20 +
  21 +lives_ok {
  22 + $cursor = $collection.find( )
  23 +}, 'initialize cursor for all documents';
  24 +
  25 +lives_ok
  26 +{
  27 + @documents = ( );
  28 + while $cursor.fetch( ) -> %document {
  29 + @documents.push( { %document } );
  30 + }
  31 +}, 'fetch all documents';
  32 +
  33 +# TODO compare documents
  34 +
  35 +lives_ok {
  36 + $cursor = $collection.find( number_to_return => 8 )
  37 +}, 'initialize cursor for given amount of documents';
  38 +
  39 +lives_ok {
  40 + $cursor.kill();
  41 +}, 'kill cursor';
  42 +
  43 +is ([+]$cursor.id.list), 0, 'cursor is killed';
  44 +
  45 +lives_ok
  46 +{
  47 + @documents = ( );
  48 + while $cursor.fetch( ) -> %document {
  49 + @documents.push( { %document } );
  50 + }
  51 +}, 'fetch given amount of documents';
  52 +
  53 +# TODO compare documents
  54 +
  55 +lives_ok {
  56 + $cursor = $collection.find( number_to_return => 1 )
  57 +}, 'initialize cursor for one document';
  58 +
  59 +is ([+]$cursor.id.list), 0, 'cursor for one document is closed automatically';
  60 +
  61 +lives_ok
  62 +{
  63 + @documents = ( );
  64 + while $cursor.fetch( ) -> %document {
  65 + @documents.push( { %document } );
  66 + }
  67 +}, 'fetch one document';
  68 +
  69 +# TODO compare documents
40 t/insert.t
... ... @@ -0,0 +1,40 @@
  1 +BEGIN { @*INC.unshift( 'lib' ) }
  2 +
  3 +use Test;
  4 +use MongoDB;
  5 +
  6 +plan( 5 );
  7 +
  8 +my $connection = MongoDB::Connection.new;
  9 +my $database = $connection.database( 'test' );
  10 +my $collection = $database.collection( 'perl6_driver' );
  11 +
  12 +# TODO replace with drop when available
  13 +$collection.remove( );
  14 +
  15 +lives_ok {
  16 + $collection.insert( { 'foo' => 0 } );
  17 +}, 'insert single document';
  18 +
  19 +lives_ok {
  20 + $collection.insert( { 'bar' => 0 }, { 'bar' => 1 } );
  21 +}, 'insert multiple documents';
  22 +
  23 +# TODO simulate failure, maybe violate constraint?
  24 +lives_ok {
  25 + $collection.insert( { 'baz' => 0 }, :continue_on_error );
  26 +}, 'insert single document with continue_on_error flag';
  27 +
  28 +dies_ok {
  29 + $collection.insert( );
  30 +}, 'insert without documents is forbidden';
  31 +
  32 +dies_ok {
  33 + $collection.insert( 1, "a" );
  34 +}, 'insert fails on incorrect document types';
  35 +
  36 +# TODO check output, expected result
  37 +# { "_id" : ObjectId("..."), "foo" : 0 }
  38 +# { "_id" : ObjectId("..."), "bar" : 0 }
  39 +# { "_id" : ObjectId("..."), "bar" : 1 }
  40 +# { "_id" : ObjectId("..."), "baz" : 0 }
38 t/remove.t
... ... @@ -0,0 +1,38 @@
  1 +BEGIN { @*INC.unshift( 'lib' ) }
  2 +
  3 +use Test;
  4 +use MongoDB;
  5 +
  6 +plan( 4 );
  7 +
  8 +my $connection = MongoDB::Connection.new;
  9 +my $database = $connection.database( 'test' );
  10 +my $collection = $database.collection( 'perl6_driver' );
  11 +
  12 +# TODO replace with drop when available
  13 +$collection.remove( );
  14 +
  15 +# feed test data
  16 +$collection.insert( { 'foo' => 0 }, { 'foo' => 0 }, { 'bar' => 0 }, { 'bar' => 0 } );
  17 +
  18 +lives_ok {
  19 + $collection.remove( { 'foo' => 0 } );
  20 +}, 'remove many documents';
  21 +
  22 +lives_ok {
  23 + $collection.remove( { 'bar' => 0 }, :single_remove );
  24 +}, 'remove single document with single_remove flag';
  25 +
  26 +lives_ok {
  27 + $collection.remove( { 'baz' => 0 } );
  28 +}, 'remove no documents';
  29 +
  30 +# TODO check output, expected result
  31 +# { "_id" : ObjectId("..."), "bar" : 0 }
  32 +
  33 +lives_ok {
  34 + $collection.remove( );
  35 +}, 'remove all documents';
  36 +
  37 +# TODO check output, expected result
  38 +# empty collection
46 t/update.t
... ... @@ -0,0 +1,46 @@
  1 +BEGIN { @*INC.unshift( 'lib' ) }
  2 +
  3 +use Test;
  4 +use MongoDB;
  5 +
  6 +plan( 6 );
  7 +
  8 +my $connection = MongoDB::Connection.new;
  9 +my $database = $connection.database( 'test' );
  10 +my $collection = $database.collection( 'perl6_driver' );
  11 +
  12 +# TODO replace with drop when available
  13 +$collection.remove( );
  14 +
  15 +# feed test data
  16 +$collection.insert( { 'foo' => 0 }, { 'foo' => 0 } );
  17 +
  18 +lives_ok {
  19 + $collection.update( { 'foo' => 0 }, { '$inc' => { 'foo' => 1 } } );
  20 +}, 'update single document';
  21 +
  22 +lives_ok {
  23 + $collection.update( { 'foo' => { '$exists' => True } }, { '$inc' => { 'foo' => 1 } }, :multi_update );
  24 +}, 'update many documents with multi_update flag';
  25 +
  26 +lives_ok {
  27 + $collection.update( { 'bar' => 0 }, { '$inc' => { 'bar' => 1 } } );
  28 +}, 'update nonexisting document';
  29 +
  30 +
  31 +lives_ok {
  32 + $collection.update( { 'bar' => 0 }, { '$inc' => { 'bar' => 1 } }, :upsert );
  33 +}, 'update nonexisting document with upsert flag';
  34 +
  35 +dies_ok {
  36 + $collection.update( );
  37 +}, 'update without selector and document is forbidden';
  38 +
  39 +dies_ok {
  40 + $collection.update( 1, "a" );
  41 +}, 'update fails on incorrect document types';
  42 +
  43 +# TODO check output, expected result
  44 +# { "_id" : ObjectId("..."), "foo" : 2 }
  45 +# { "_id" : ObjectId("..."), "foo" : 1 }
  46 +# { "_id" : ObjectId("..."), "bar" : 1 }

0 comments on commit f0570ae

Please sign in to comment.
Something went wrong with that request. Please try again.