├── .gitignore ├── .travis.yml ├── CONTRIBUTING.md ├── Changes ├── LICENSE ├── MANIFEST.SKIP ├── Makefile.PL ├── README.md ├── lib ├── Mango.pm └── Mango │ ├── BSON.pm │ ├── BSON │ ├── Binary.pm │ ├── Code.pm │ ├── Document.pm │ ├── ObjectID.pm │ ├── Time.pm │ └── Timestamp.pm │ ├── Bulk.pm │ ├── Collection.pm │ ├── Cursor.pm │ ├── Cursor │ └── Query.pm │ ├── Database.pm │ ├── GridFS.pm │ ├── GridFS │ ├── Reader.pm │ └── Writer.pm │ └── Protocol.pm └── t ├── bson.t ├── bulk.t ├── collection.t ├── connection.t ├── cursor.t ├── database.t ├── gridfs.t ├── pod.t ├── pod_coverage.t └── protocol.t /.gitignore: -------------------------------------------------------------------------------- 1 | .* 2 | *~ 3 | !.gitignore 4 | !.perltidyrc 5 | !.travis.yml 6 | /blib 7 | /pm_to_blib 8 | /Makefile 9 | /Makefile.old 10 | /MANIFEST* 11 | !MANIFEST.SKIP 12 | /META.* 13 | /MYMETA.* 14 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl 2 | perl: 3 | - "5.20" 4 | - "5.18" 5 | - "5.16" 6 | - "5.14" 7 | - "5.12" 8 | - "5.10" 9 | env: 10 | - "HARNESS_OPTIONS=j9 TEST_POD=1 TEST_ONLINE=mongodb://127.0.0.1:27017/mango" 11 | before_install: 12 | - "sudo apt-key adv --keyserver hkp://keyserver.ubuntu.com:80 --recv 7F0CEB10" 13 | - "echo 'deb http://downloads-distro.mongodb.org/repo/ubuntu-upstart dist 10gen' | sudo tee /etc/apt/sources.list.d/mongodb.list" 14 | - "sudo apt-get update" 15 | - "sudo apt-get install mongodb-org-server" 16 | install: 17 | - "cpanm -n Test::Pod Test::Pod::Coverage" 18 | - "cpanm -n --installdeps ." 19 | before_script: 20 | - "until nc -z localhost 27017; do echo Waiting for MongoDB; sleep 1; done" 21 | notifications: 22 | email: false 23 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | Please read the guide for [contributing to Mojolicious](http://mojolicio.us/perldoc/Mojolicious/Guides/Contributing), Mango is a spin-off project and follows the same rules. 2 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | 2 | 1.15 2014-09-30 3 | - This distribution is now being maintained at 4 | https://github.com/oliwer/mango. 5 | 6 | 1.14 2014-09-22 7 | - Fixed packaging bug. 8 | 9 | 1.13 2014-09-21 10 | - Updated Makefile.PL for version 2 of the CPAN distribution metadata 11 | specification. 12 | 13 | 1.12 2014-09-12 14 | - Fixed small connection management bug. 15 | 16 | 1.11 2014-09-11 17 | - Fixed test that was depending on Mojolicious internals. 18 | 19 | 1.10 2014-09-06 20 | - Added module Mango::Cursor::Query. 21 | 22 | 1.09 2014-09-01 23 | - Improved Makefile.PL error message for 64-bit requirement. 24 | 25 | 1.08 2014-08-24 26 | - Improved to_datetime method in Mango::BSON::Time to be able to handle 27 | higher precision times. 28 | 29 | 1.07 2014-08-23 30 | - Fixed small JSON serialization bug in Mango::BSON::Time. 31 | 32 | 1.06 2014-08-22 33 | - Added to_datetime method to Mango::BSON::Time. 34 | 35 | 1.05 2014-08-10 36 | - Added read_preference attribute to Mango::Cursor. 37 | 38 | 1.04 2014-07-25 39 | - Fixed connection leak. 40 | 41 | 1.03 2014-07-25 42 | - Improved Mango to avoid secondary nodes. 43 | 44 | 1.02 2014-07-24 45 | - Fixed version handling in Mango::GridFS. 46 | 47 | 1.01 2014-06-28 48 | - Improved update method in Mango::Collection to accept object ids. 49 | (alexbyk) 50 | - Fixed small bug in Mango::Cursor where callbacks would sometimes get the 51 | wrong number of arguments. 52 | 53 | 1.0 2014-06-24 54 | - Removed experimental status from distribution. 55 | 56 | 0.43 2014-06-15 57 | - Improved remove method in Mango::Collection to accept object ids. 58 | 59 | 0.42 2014-06-04 60 | - Added md5 method to Mango::GridFS::Readers. 61 | - Fixed bug in Mango::GridFS::Writer where files could get the wrong MD5 62 | checksum. 63 | 64 | 0.41 2014-06-02 65 | - Added await_data attribute to Mango::Cursor. 66 | 67 | 0.40 2014-05-31 68 | - Added inactivity_timeout attribute to Mango. 69 | - Fixed Mojolicious 5.0 support. 70 | 71 | 0.39 2014-05-14 72 | - Improved Mango::BSON performance. 73 | 74 | 0.38 2014-05-12 75 | - Changed heuristics for number detection in Mango::BSON to better line up 76 | with user expectations. 77 | 78 | 0.37 2014-05-12 79 | - Added support for performing blocking and non-blocking operations at the 80 | same time. 81 | 82 | 0.36 2014-05-05 83 | - Added support for TO_BSON method to Mango::BSON. 84 | 85 | 0.35 2014-05-04 86 | - Added num_to_return method to Mango::Cursor. 87 | - Fixed bug where Mango::Cursor would request too many documents. 88 | 89 | 0.34 2014-05-02 90 | - Fixed bug where some Mango::Collection methods passed the wrong invocant 91 | to callbacks. (alexbyk) 92 | 93 | 0.33 2014-04-30 94 | - Improved error message for old MongoDB versions. 95 | 96 | 0.32 2014-04-24 97 | - Added to_bytes method to Mango::BSON::ObjectID. 98 | - Improved Mango::BSON performance. 99 | 100 | 0.31 2014-04-23 101 | - Improved support for pre-encoded BSON documents. 102 | 103 | 0.30 2014-04-08 104 | - Removed delete, insert and update methods from Mango. 105 | - Removed build_delete, build_insert and build_update methods from 106 | Mango::Protocol. 107 | - Removed decode_int32, decode_int64, encode_int32 and encode_int64 methods 108 | from Mango::BSON. 109 | - Renamed timeout attribute in Mango::Cursor to max_time_ms. 110 | - Added support for MongoDB 2.6 wire protocol, MongoDB 2.4 is no longer 111 | supported. 112 | - Added support for bulk operations. 113 | - Added max_bson_size and max_write_batch_size attributes to Mango. 114 | - Added build_write_concern method to Mango::Database. 115 | - Added bulk method to Mango::Collection. 116 | - Added write_error method to Mango::Protocol. 117 | - Added bson_raw function to Mango::BSON. 118 | - Improved aggregate method in Mango::Collection to return cursors by 119 | default. 120 | - Improved aggregate method in Mango::Collection with explain support. 121 | - Improved connection management with wire protocol version check. 122 | - Improved Mango::BSON performance. 123 | - Improved command performance. 124 | - Improved storage efficiency of Mango::GridFS::Writer by lowering the 125 | default chunk size to 255KB. 126 | 127 | 0.24 2014-02-27 128 | - Added comment and timeout attributes to Mango::Cursor. 129 | 130 | 0.23 2014-01-22 131 | - Fixed a few small operator overloading bugs. 132 | 133 | 0.22 2013-12-18 134 | - Added options method to Mango::Collection. 135 | 136 | 0.21 2013-12-04 137 | - Improved handling of missing files in Mango::GridFS::Reader. 138 | 139 | 0.20 2013-11-30 140 | - Added from_string method to Mango. 141 | 142 | 0.19 2013-11-18 143 | - Improved Mango::Cursor to allow $query key in queries. 144 | 145 | 0.18 2013-11-11 146 | - Fixed concurrency bugs in Mango. 147 | - Fixed bug in Mango::BSON where all objects that stringify to "1" were 148 | considered booleans. 149 | 150 | 0.17 2013-10-30 151 | - Added cursor and collection support for aggregation. 152 | - Added add_batch method to Mango::Cursor. 153 | - Added from_epoch method to Mango::BSON::ObjectID. 154 | 155 | 0.16 2013-10-12 156 | - Added support for fallback servers. 157 | - Fixed reconnect bugs. 158 | 159 | 0.15 2013-10-11 160 | - Fixed mongos compatibility bugs. 161 | 162 | 0.14 2013-10-06 163 | - Added DBRef support. 164 | - Added dereference method to Mango::Database. 165 | - Added bson_dbref function to Mango::BSON. 166 | 167 | 0.13 2013-09-21 168 | - Added fields argument to find and find_one methods in Mango::Collection. 169 | 170 | 0.12 2013-08-17 171 | - Fixed rewind bug in Mango::Cursor where the cursor would not be killed on 172 | the server. 173 | 174 | 0.11 2013-08-14 175 | - Changed return values of remove and update methods in Mango::Collection. 176 | 177 | 0.10 2013-08-06 178 | - Improved connection management to be more fault-tolerant. 179 | 180 | 0.09 2013-07-28 181 | - Added connection event to Mango. 182 | - Improved connection management to be fork-safe. 183 | 184 | 0.08 2013-07-20 185 | - Removed is_active method from Mango. 186 | - Added max_scan attribute to Mango::Cursor. 187 | - Added backlog method to Mango. 188 | 189 | 0.07 2013-07-18 190 | - Added is_closed method to Mango::GridFS::Writer. 191 | 192 | 0.06 2013-07-17 193 | - Added GridFS support. 194 | - Added modules Mango::GridFS, Mango::GridFS::Reader and 195 | Mango::GridFS::Writer. 196 | - Added gridfs method to Mango::Database. 197 | - Improved Mango::BSON performance. (avkhozov) 198 | - Fixed non-blocking connection pool timing bug. 199 | - Fixed ensure_index argument bug. 200 | 201 | 0.05 2013-07-06 202 | - Changed heuristics for number detection in Mango::BSON to better line up 203 | with user expectations. 204 | - Changed to_epoch in Mango::BSON::Time to return a high resolution time. 205 | - Added connection pool support for non-blocking operations. 206 | - Added max_connections attribute to Mango. 207 | - Added drop_index, index_information and stats methods to 208 | Mango::Collection. 209 | - Added to_string method to Mango::BSON::ObjectID. 210 | - Added to_string method to Mango::BSON::Time. 211 | - Added stats method to Mango::Database. 212 | - Added TO_JSON method to Mango::BSON::Binary. 213 | - Added TO_JSON method to Mango::BSON::Time. 214 | - Improved compatibility with Mojolicious 4.0. 215 | - Improved Mango::BSON performance. (avkhozov) 216 | - Improved Mango::BSON::ObjectID to validate object ids. 217 | - Improved exception handling for commands. 218 | - Fixed support for empty keys in Mango::BSON. 219 | - Fixed a few memory leaks. 220 | 221 | 0.04 2013-02-10 222 | - Added collection_names method to Mango::Database. 223 | - Added aggregate, build_index_name, find_and_modify map_reduce and save 224 | methods to Mango::Collection. 225 | - Added distinct method to Mango::Cursor. 226 | - Changed remove and update methods in Mango::Collection to return the 227 | number of documents affected. 228 | - Fixed exception handling for commands. 229 | 230 | 0.03 2013-02-09 231 | - Added hint, snapshot and tailable attributes to Mango::Cursor. 232 | - Added create, drop and ensure_index methods to Mango::Collection. 233 | - Added build_query, clone and explain methods to Mango::Cursor. 234 | - Added command_error and query_failure methods to Mango::Protocol. 235 | - Fixed array encoding in Mango::BSON. 236 | - Fixed small exception handling bugs in Mango. 237 | 238 | 0.02 2013-02-07 239 | - Added batch_size attribute to Mango::Cursor. 240 | - Added count method to Mango::Cursor. 241 | - Added next_id method to Mango::Protocol. 242 | - Added multi and upsert options to update method in Mango::Collection. 243 | - Added single option to remove method in Mango::Collection. 244 | - Changed reply format from array to hash. 245 | - Fixed a few exception handling bugs. 246 | - Fixed limit functionality in Mango::Cursor. 247 | - Fixed a few small timing bugs in Mango::Cursor. 248 | 249 | 0.01 2013-02-06 250 | - First release. 251 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The Artistic License 2.0 2 | 3 | Copyright (c) 2000-2006, The Perl Foundation. 4 | 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | This license establishes the terms under which a given free software 11 | Package may be copied, modified, distributed, and/or redistributed. 12 | The intent is that the Copyright Holder maintains some artistic 13 | control over the development of that Package while still keeping the 14 | Package available as open source and free software. 15 | 16 | You are always permitted to make arrangements wholly outside of this 17 | license directly with the Copyright Holder of a given Package. If the 18 | terms of this license do not permit the full use that you propose to 19 | make of the Package, you should contact the Copyright Holder and seek 20 | a different licensing arrangement. 21 | 22 | Definitions 23 | 24 | "Copyright Holder" means the individual(s) or organization(s) 25 | named in the copyright notice for the entire Package. 26 | 27 | "Contributor" means any party that has contributed code or other 28 | material to the Package, in accordance with the Copyright Holder's 29 | procedures. 30 | 31 | "You" and "your" means any person who would like to copy, 32 | distribute, or modify the Package. 33 | 34 | "Package" means the collection of files distributed by the 35 | Copyright Holder, and derivatives of that collection and/or of 36 | those files. A given Package may consist of either the Standard 37 | Version, or a Modified Version. 38 | 39 | "Distribute" means providing a copy of the Package or making it 40 | accessible to anyone else, or in the case of a company or 41 | organization, to others outside of your company or organization. 42 | 43 | "Distributor Fee" means any fee that you charge for Distributing 44 | this Package or providing support for this Package to another 45 | party. It does not mean licensing fees. 46 | 47 | "Standard Version" refers to the Package if it has not been 48 | modified, or has been modified only in ways explicitly requested 49 | by the Copyright Holder. 50 | 51 | "Modified Version" means the Package, if it has been changed, and 52 | such changes were not explicitly requested by the Copyright 53 | Holder. 54 | 55 | "Original License" means this Artistic License as Distributed with 56 | the Standard Version of the Package, in its current version or as 57 | it may be modified by The Perl Foundation in the future. 58 | 59 | "Source" form means the source code, documentation source, and 60 | configuration files for the Package. 61 | 62 | "Compiled" form means the compiled bytecode, object code, binary, 63 | or any other form resulting from mechanical transformation or 64 | translation of the Source form. 65 | 66 | 67 | Permission for Use and Modification Without Distribution 68 | 69 | (1) You are permitted to use the Standard Version and create and use 70 | Modified Versions for any purpose without restriction, provided that 71 | you do not Distribute the Modified Version. 72 | 73 | 74 | Permissions for Redistribution of the Standard Version 75 | 76 | (2) You may Distribute verbatim copies of the Source form of the 77 | Standard Version of this Package in any medium without restriction, 78 | either gratis or for a Distributor Fee, provided that you duplicate 79 | all of the original copyright notices and associated disclaimers. At 80 | your discretion, such verbatim copies may or may not include a 81 | Compiled form of the Package. 82 | 83 | (3) You may apply any bug fixes, portability changes, and other 84 | modifications made available from the Copyright Holder. The resulting 85 | Package will still be considered the Standard Version, and as such 86 | will be subject to the Original License. 87 | 88 | 89 | Distribution of Modified Versions of the Package as Source 90 | 91 | (4) You may Distribute your Modified Version as Source (either gratis 92 | or for a Distributor Fee, and with or without a Compiled form of the 93 | Modified Version) provided that you clearly document how it differs 94 | from the Standard Version, including, but not limited to, documenting 95 | any non-standard features, executables, or modules, and provided that 96 | you do at least ONE of the following: 97 | 98 | (a) make the Modified Version available to the Copyright Holder 99 | of the Standard Version, under the Original License, so that the 100 | Copyright Holder may include your modifications in the Standard 101 | Version. 102 | 103 | (b) ensure that installation of your Modified Version does not 104 | prevent the user installing or running the Standard Version. In 105 | addition, the Modified Version must bear a name that is different 106 | from the name of the Standard Version. 107 | 108 | (c) allow anyone who receives a copy of the Modified Version to 109 | make the Source form of the Modified Version available to others 110 | under 111 | 112 | (i) the Original License or 113 | 114 | (ii) a license that permits the licensee to freely copy, 115 | modify and redistribute the Modified Version using the same 116 | licensing terms that apply to the copy that the licensee 117 | received, and requires that the Source form of the Modified 118 | Version, and of any works derived from it, be made freely 119 | available in that license fees are prohibited but Distributor 120 | Fees are allowed. 121 | 122 | 123 | Distribution of Compiled Forms of the Standard Version 124 | or Modified Versions without the Source 125 | 126 | (5) You may Distribute Compiled forms of the Standard Version without 127 | the Source, provided that you include complete instructions on how to 128 | get the Source of the Standard Version. Such instructions must be 129 | valid at the time of your distribution. If these instructions, at any 130 | time while you are carrying out such distribution, become invalid, you 131 | must provide new instructions on demand or cease further distribution. 132 | If you provide valid instructions or cease distribution within thirty 133 | days after you become aware that the instructions are invalid, then 134 | you do not forfeit any of your rights under this license. 135 | 136 | (6) You may Distribute a Modified Version in Compiled form without 137 | the Source, provided that you comply with Section 4 with respect to 138 | the Source of the Modified Version. 139 | 140 | 141 | Aggregating or Linking the Package 142 | 143 | (7) You may aggregate the Package (either the Standard Version or 144 | Modified Version) with other packages and Distribute the resulting 145 | aggregation provided that you do not charge a licensing fee for the 146 | Package. Distributor Fees are permitted, and licensing fees for other 147 | components in the aggregation are permitted. The terms of this license 148 | apply to the use and Distribution of the Standard or Modified Versions 149 | as included in the aggregation. 150 | 151 | (8) You are permitted to link Modified and Standard Versions with 152 | other works, to embed the Package in a larger work of your own, or to 153 | build stand-alone binary or bytecode versions of applications that 154 | include the Package, and Distribute the result without restriction, 155 | provided the result does not expose a direct interface to the Package. 156 | 157 | 158 | Items That are Not Considered Part of a Modified Version 159 | 160 | (9) Works (including, but not limited to, modules and scripts) that 161 | merely extend or make use of the Package, do not, by themselves, cause 162 | the Package to be a Modified Version. In addition, such works are not 163 | considered parts of the Package itself, and are not subject to the 164 | terms of this license. 165 | 166 | 167 | General Provisions 168 | 169 | (10) Any use, modification, and distribution of the Standard or 170 | Modified Versions is governed by this Artistic License. By using, 171 | modifying or distributing the Package, you accept this license. Do not 172 | use, modify, or distribute the Package, if you do not accept this 173 | license. 174 | 175 | (11) If your Modified Version has been derived from a Modified 176 | Version made by someone other than you, you are nevertheless required 177 | to ensure that your Modified Version complies with the requirements of 178 | this license. 179 | 180 | (12) This license does not grant you the right to use any trademark, 181 | service mark, tradename, or logo of the Copyright Holder. 182 | 183 | (13) This license includes the non-exclusive, worldwide, 184 | free-of-charge patent license to make, have made, use, offer to sell, 185 | sell, import and otherwise transfer the Package with respect to any 186 | patent claims licensable by the Copyright Holder that are necessarily 187 | infringed by the Package. If you institute patent litigation 188 | (including a cross-claim or counterclaim) against any party alleging 189 | that the Package constitutes direct or contributory patent 190 | infringement, then this Artistic License to you shall terminate on the 191 | date that such litigation is filed. 192 | 193 | (14) Disclaimer of Warranty: 194 | THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS 195 | IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED 196 | WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR 197 | NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL 198 | LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL 199 | BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL 200 | DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF 201 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 202 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | ^\.(?!perltidyrc) 2 | .*\.old$ 3 | \.tar\.gz$ 4 | ^Makefile$ 5 | ^MYMETA\. 6 | ^blib 7 | ^pm_to_blib 8 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.010001; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Config; 7 | use ExtUtils::MakeMaker; 8 | 9 | die "64-bit Perl or one built with -Duse64bitint is required!\n" 10 | unless (($Config{use64bitint} // '') eq 'define' || $Config{longsize} >= 8); 11 | 12 | WriteMakefile( 13 | NAME => 'Mango', 14 | VERSION_FROM => 'lib/Mango.pm', 15 | ABSTRACT => 'Pure-Perl non-blocking I/O MongoDB driver', 16 | AUTHOR => 'Sebastian Riedel ', 17 | LICENSE => 'artistic_2', 18 | META_MERGE => { 19 | requires => {perl => '5.010001'}, 20 | resources => { 21 | license => 'http://www.opensource.org/licenses/artistic-license-2.0', 22 | homepage => 'http://mojolicio.us', 23 | bugtracker => 'https://github.com/kraih/mango/issues', 24 | repository => 'https://github.com/kraih/mango.git', 25 | x_IRC => 'irc://irc.perl.org/#mojo' 26 | }, 27 | no_index => {directory => ['t']} 28 | }, 29 | PREREQ_PM => {Mojolicious => '5.40'}, 30 | test => {TESTS => 't/*.t t/*/*.t'} 31 | ); 32 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | # Moved 3 | 4 | Mango is now maintained at [https://github.com/oliwer/mango](https://github.com/oliwer/mango). 5 | -------------------------------------------------------------------------------- /lib/Mango.pm: -------------------------------------------------------------------------------- 1 | package Mango; 2 | use Mojo::Base 'Mojo::EventEmitter'; 3 | 4 | use Carp 'croak'; 5 | use Mango::BSON 'bson_doc'; 6 | use Mango::Database; 7 | use Mango::Protocol; 8 | use Mojo::IOLoop; 9 | use Mojo::URL; 10 | use Mojo::Util qw(dumper md5_sum); 11 | use Scalar::Util 'weaken'; 12 | 13 | use constant DEBUG => $ENV{MANGO_DEBUG} || 0; 14 | use constant DEFAULT_PORT => 27017; 15 | 16 | has credentials => sub { [] }; 17 | has default_db => 'admin'; 18 | has hosts => sub { [['localhost']] }; 19 | has [qw(inactivity_timeout j)] => 0; 20 | has ioloop => sub { Mojo::IOLoop->new }; 21 | has max_bson_size => 16777216; 22 | has max_connections => 5; 23 | has [qw(max_write_batch_size wtimeout)] => 1000; 24 | has protocol => sub { Mango::Protocol->new }; 25 | has w => 1; 26 | 27 | our $VERSION = '1.15'; 28 | 29 | sub DESTROY { shift->_cleanup } 30 | 31 | sub backlog { scalar @{shift->{queue} || []} } 32 | 33 | sub db { 34 | my ($self, $name) = @_; 35 | $name //= $self->default_db; 36 | my $db = Mango::Database->new(mango => $self, name => $name); 37 | weaken $db->{mango}; 38 | return $db; 39 | } 40 | 41 | sub from_string { 42 | my ($self, $str) = @_; 43 | 44 | # Protocol 45 | return $self unless $str; 46 | my $url = Mojo::URL->new($str); 47 | croak qq{Invalid MongoDB connection string "$str"} 48 | unless $url->protocol eq 'mongodb'; 49 | 50 | # Hosts 51 | my @hosts; 52 | /^([^,:]+)(?::(\d+))?/ and push @hosts, $2 ? [$1, $2] : [$1] 53 | for split /,/, join(':', map { $_ // '' } $url->host, $url->port); 54 | $self->hosts(\@hosts) if @hosts; 55 | 56 | # Database 57 | if (my $db = $url->path->parts->[0]) { $self->default_db($db) } 58 | 59 | # User and password 60 | push @{$self->credentials}, [$self->default_db, $1, $2] 61 | if ($url->userinfo // '') =~ /^([^:]+):([^:]+)$/; 62 | 63 | # Options 64 | my $query = $url->query; 65 | if (my $j = $query->param('journal')) { $self->j($j) } 66 | if (my $w = $query->param('w')) { $self->w($w) } 67 | if (my $timeout = $query->param('wtimeoutMS')) { $self->wtimeout($timeout) } 68 | 69 | return $self; 70 | } 71 | 72 | sub get_more { shift->_op('get_more', 1, @_) } 73 | 74 | sub kill_cursors { shift->_op('kill_cursors', 0, @_) } 75 | 76 | sub new { shift->SUPER::new->from_string(@_) } 77 | 78 | sub query { shift->_op('query', 1, @_) } 79 | 80 | sub _auth { 81 | my ($self, $id) = @_; 82 | 83 | # No more authentication (connection is ready) 84 | return $self->emit(connection => $id)->_next 85 | unless my $auth = shift @{$self->{connections}{$id}{credentials}}; 86 | 87 | # Run "getnonce" command followed by "authenticate" 88 | my $cb = sub { shift->_nonce($id, $auth, @_) }; 89 | $self->_fast($id, $auth->[0], {getnonce => 1}, $cb); 90 | } 91 | 92 | sub _build { 93 | my ($self, $name) = (shift, shift); 94 | my $next = $self->_id; 95 | warn "-- Operation #$next ($name)\n@{[dumper [@_]]}" if DEBUG; 96 | my $method = "build_$name"; 97 | return ($next, $self->protocol->$method($next, @_)); 98 | } 99 | 100 | sub _cleanup { 101 | my $self = shift; 102 | return unless $self->_loop(0); 103 | 104 | # Clean up connections 105 | delete $self->{pid}; 106 | my $connections = delete $self->{connections}; 107 | $self->_loop($connections->{$_}{nb})->remove($_) for keys %$connections; 108 | 109 | # Clean up active operations 110 | my $queue = delete $self->{queue} || []; 111 | $_->{last} && !$_->{start} && unshift @$queue, $_->{last} 112 | for values %$connections; 113 | $self->_finish(undef, $_->{cb}, 'Premature connection close') for @$queue; 114 | } 115 | 116 | sub _close { 117 | my ($self, $id) = @_; 118 | 119 | return unless my $c = delete $self->{connections}{$id}; 120 | my $last = $c->{last}; 121 | $self->_finish(undef, $last->{cb}, 'Premature connection close') if $last; 122 | $self->_connect($c->{nb}) if @{$self->{queue}}; 123 | } 124 | 125 | sub _connect { 126 | my ($self, $nb, $hosts) = @_; 127 | 128 | my ($host, $port) = @{shift @{$hosts ||= [@{$self->hosts}]}}; 129 | weaken $self; 130 | my $id; 131 | $id = $self->_loop($nb)->client( 132 | {address => $host, port => $port //= DEFAULT_PORT} => sub { 133 | my ($loop, $err, $stream) = @_; 134 | 135 | # Connection error (try next server) 136 | if ($err) { 137 | return $self->_error($id, $err) unless @$hosts; 138 | delete $self->{connections}{$id}; 139 | return $self->_connect($nb, $hosts); 140 | } 141 | 142 | # Connection established 143 | $stream->timeout($self->inactivity_timeout); 144 | $stream->on(close => sub { $self && $self->_close($id) }); 145 | $stream->on(error => sub { $self && $self->_error($id, pop) }); 146 | $stream->on(read => sub { $self->_read($id, pop) }); 147 | 148 | # Check node information with "isMaster" command 149 | my $cb = sub { shift->_master($id, $nb, $hosts, pop) }; 150 | $self->_fast($id, $self->default_db, {isMaster => 1}, $cb); 151 | } 152 | ); 153 | $self->{connections}{$id} 154 | = {credentials => [@{$self->credentials}], nb => $nb, start => 1}; 155 | 156 | my $num = scalar keys %{$self->{connections}}; 157 | warn "-- New connection ($host:$port:$num)\n" if DEBUG; 158 | } 159 | 160 | sub _error { 161 | my ($self, $id, $err) = @_; 162 | 163 | return unless my $c = delete $self->{connections}{$id}; 164 | $self->_loop($c->{nb})->remove($id); 165 | 166 | my $last = $c->{last} // shift @{$self->{queue}}; 167 | $self->_finish(undef, $last->{cb}, $err) if $last; 168 | } 169 | 170 | sub _fast { 171 | my ($self, $id, $db, $command, $cb) = @_; 172 | 173 | # Handle errors 174 | my $wrapper = sub { 175 | my ($self, $err, $reply) = @_; 176 | 177 | my $doc = $reply->{docs}[0]; 178 | $err ||= $self->protocol->command_error($doc); 179 | return $self->$cb(undef, $doc) unless $err; 180 | 181 | return unless my $last = shift @{$self->{queue}}; 182 | $self->_finish(undef, $last->{cb}, $err); 183 | }; 184 | 185 | # Skip the queue and run command right away 186 | my ($next, $msg) 187 | = $self->_build('query', "$db.\$cmd", {}, 0, -1, $command, {}); 188 | $self->{connections}{$id}{fast} 189 | = {id => $next, safe => 1, msg => $msg, cb => $wrapper}; 190 | $self->_next; 191 | } 192 | 193 | sub _finish { 194 | my ($self, $reply, $cb, $err) = @_; 195 | $self->$cb($err || $self->protocol->query_failure($reply), $reply); 196 | } 197 | 198 | sub _id { $_[0]{id} = $_[0]->protocol->next_id($_[0]{id} // 0) } 199 | 200 | sub _loop { $_[1] ? Mojo::IOLoop->singleton : $_[0]->ioloop } 201 | 202 | sub _master { 203 | my ($self, $id, $nb, $hosts, $doc) = @_; 204 | 205 | # Check version 206 | return $self->_error($id, 'MongoDB version 2.6 required') 207 | unless ($doc->{maxWireVersion} || 0) >= 2; 208 | 209 | # Continue with authentication if we are connected to the primary 210 | return $self->_auth($id) if $doc->{ismaster}; 211 | 212 | # Get primary and try to connect again 213 | unshift @$hosts, [$1, $2] if ($doc->{primary} // '') =~ /^(.+):(\d+)$/; 214 | return $self->_error($id, "Couldn't find primary node") unless @$hosts; 215 | delete $self->{connections}{$id}; 216 | $self->_loop($nb)->remove($id); 217 | $self->_connect($nb, $hosts); 218 | } 219 | 220 | sub _next { 221 | my ($self, $op) = @_; 222 | 223 | # Make sure all connections are saturated 224 | push @{$self->{queue} ||= []}, $op if $op; 225 | my $connections = $self->{connections}; 226 | my $start; 227 | $self->_write($_) and $start++ for my @ids = keys %$connections; 228 | 229 | # Check if we need a blocking connection 230 | return unless $op; 231 | return $self->_connect(0) 232 | if !$op->{nb} && !grep { !$connections->{$_}{nb} } @ids; 233 | 234 | # Check if we need more non-blocking connections 235 | $self->_connect(1) 236 | if !$start && @{$self->{queue}} && @ids < $self->max_connections; 237 | } 238 | 239 | sub _nonce { 240 | my ($self, $id, $auth, $err, $doc) = @_; 241 | 242 | # Run "authenticate" command with "nonce" value 243 | my $nonce = $doc->{nonce} // ''; 244 | my ($db, $user, $pass) = @$auth; 245 | my $key = md5_sum $nonce . $user . md5_sum "$user:mongo:$pass"; 246 | my $command 247 | = bson_doc(authenticate => 1, user => $user, nonce => $nonce, key => $key); 248 | $self->_fast($id, $db, $command, sub { shift->_auth($id) }); 249 | } 250 | 251 | sub _op { 252 | my ($self, $op, $safe) = (shift, shift, shift); 253 | my $cb = ref $_[-1] eq 'CODE' ? pop : undef; 254 | my ($next, $msg) = $self->_build($op, @_); 255 | $self->_start( 256 | {id => $next, safe => $safe, msg => $msg, nb => !!$cb, cb => $cb}); 257 | } 258 | 259 | sub _read { 260 | my ($self, $id, $chunk) = @_; 261 | 262 | my $c = $self->{connections}{$id}; 263 | $c->{buffer} .= $chunk; 264 | while (my $reply = $self->protocol->parse_reply(\$c->{buffer})) { 265 | warn "-- Client <<< Server (#$reply->{to})\n@{[dumper $reply]}" if DEBUG; 266 | next unless $reply->{to} == $c->{last}{id}; 267 | $self->_finish($reply, (delete $c->{last})->{cb}); 268 | } 269 | $self->_next; 270 | } 271 | 272 | sub _start { 273 | my ($self, $op) = @_; 274 | 275 | # Fork safety 276 | $self->_cleanup unless ($self->{pid} //= $$) eq $$; 277 | 278 | # Non-blocking 279 | return $self->_next($op) if $op->{cb}; 280 | 281 | # Blocking 282 | my ($err, $reply); 283 | $op->{cb} = sub { shift->ioloop->stop; ($err, $reply) = @_ }; 284 | $self->_next($op); 285 | $self->ioloop->start; 286 | return $err ? croak $err : $reply; 287 | } 288 | 289 | sub _write { 290 | my ($self, $id) = @_; 291 | 292 | # Make sure connection has not been corrupted while event loop was stopped 293 | my $c = $self->{connections}{$id}; 294 | return $c->{start} if $c->{last}; 295 | my $loop = $self->_loop($c->{nb}); 296 | return undef unless my $stream = $loop->stream($id); 297 | if (!$loop->is_running && $stream->is_readable) { 298 | $stream->close; 299 | return undef; 300 | } 301 | 302 | # Fast operation 303 | delete $c->{start} unless my $last = delete $c->{fast}; 304 | 305 | # Blocking operations have a higher precedence 306 | return $c->{start} 307 | unless $last || ($c->{nb} xor !($self->{queue}->[-1] || {})->{nb}); 308 | $last ||= $c->{nb} ? shift @{$self->{queue}} : pop @{$self->{queue}}; 309 | 310 | return $c->{start} unless $c->{last} = $last; 311 | warn "-- Client >>> Server (#$last->{id})\n" if DEBUG; 312 | $stream->write(delete $last->{msg}); 313 | 314 | # Unsafe operations are done when they are written 315 | return $c->{start} if $last->{safe}; 316 | weaken $self; 317 | $stream->write('', sub { $self->_finish(undef, delete($c->{last})->{cb}) }); 318 | return $c->{start}; 319 | } 320 | 321 | 1; 322 | 323 | =encoding utf8 324 | 325 | =head1 NAME 326 | 327 | Mango - Pure-Perl non-blocking I/O MongoDB driver 328 | 329 | =head1 SYNOPSIS 330 | 331 | use Mango; 332 | 333 | # Insert document 334 | my $mango = Mango->new('mongodb://localhost:27017'); 335 | my $oid = $mango->db('test')->collection('foo')->insert({bar => 'baz'}); 336 | 337 | # Find document 338 | my $doc = $mango->db('test')->collection('foo')->find_one({bar => 'baz'}); 339 | say $doc->{bar}; 340 | 341 | # Update document 342 | $mango->db('test')->collection('foo') 343 | ->update({bar => 'baz'}, {bar => 'yada'}); 344 | 345 | # Remove document 346 | $mango->db('test')->collection('foo')->remove({bar => 'yada'}); 347 | 348 | # Insert document with special BSON types 349 | use Mango::BSON ':bson'; 350 | my $oid = $mango->db('test')->collection('foo') 351 | ->insert({data => bson_bin("\x00\x01"), now => bson_time}); 352 | 353 | # Non-blocking concurrent find 354 | my $delay = Mojo::IOLoop->delay(sub { 355 | my ($delay, @docs) = @_; 356 | ... 357 | }); 358 | for my $name (qw(sri marty)) { 359 | my $end = $delay->begin(0); 360 | $mango->db('test')->collection('users')->find({name => $name})->all(sub { 361 | my ($cursor, $err, $docs) = @_; 362 | $end->(@$docs); 363 | }); 364 | } 365 | $delay->wait; 366 | 367 | # Event loops such as AnyEvent are supported through EV 368 | use EV; 369 | use AnyEvent; 370 | my $cv = AE::cv; 371 | $mango->db('test')->command(buildInfo => sub { 372 | my ($db, $err, $doc) = @_; 373 | $cv->send($doc->{version}); 374 | }); 375 | say $cv->recv; 376 | 377 | =head1 DESCRIPTION 378 | 379 | L is a pure-Perl non-blocking I/O MongoDB driver, optimized for use 380 | with the L real-time web framework, and with multiple event loop 381 | support. Since MongoDB is still changing rapidly, only the latest stable 382 | version is supported. 383 | 384 | To learn more about MongoDB you should take a look at the 385 | L, the documentation included 386 | in this distribution is no replacement for it. 387 | 388 | Many arguments passed to methods as well as values of attributes get 389 | serialized to BSON with L, which provides many helper functions 390 | you can use to generate data types that are not available natively in Perl. 391 | All connections will be reset automatically if a new process has been forked, 392 | this allows multiple processes to share the same L object safely. 393 | 394 | For better scalability (epoll, kqueue) and to provide IPv6, SOCKS5 as well as 395 | TLS support, the optional modules L (4.0+), L (0.20+), 396 | L (0.64+) and L (1.84+) will be used 397 | automatically if they are installed. Individual features can also be disabled 398 | with the C, C and C environment 399 | variables. 400 | 401 | =head1 EVENTS 402 | 403 | L inherits all events from L and can emit the 404 | following new ones. 405 | 406 | =head2 connection 407 | 408 | $mango->on(connection => sub { 409 | my ($mango, $id) = @_; 410 | ... 411 | }); 412 | 413 | Emitted when a new connection has been established. 414 | 415 | =head1 ATTRIBUTES 416 | 417 | L implements the following attributes. 418 | 419 | =head2 credentials 420 | 421 | my $credentials = $mango->credentials; 422 | $mango = $mango->credentials([['test', 'sri', 's3cret']]); 423 | 424 | Authentication credentials that will be used on every reconnect. 425 | 426 | =head2 default_db 427 | 428 | my $name = $mango->default_db; 429 | $mango = $mango->default_db('test'); 430 | 431 | Default database, defaults to C. 432 | 433 | =head2 hosts 434 | 435 | my $hosts = $mango->hosts; 436 | $mango = $mango->hosts([['localhost', 3000], ['localhost', 4000]]); 437 | 438 | Servers to connect to, defaults to C and port C<27017>. 439 | 440 | =head2 inactivity_timeout 441 | 442 | my $timeout = $mango->inactivity_timeout; 443 | $mango = $mango->inactivity_timeout(15); 444 | 445 | Maximum amount of time in seconds a connection can be inactive before getting 446 | closed, defaults to C<0>. Setting the value to C<0> will allow connections to 447 | be inactive indefinitely. 448 | 449 | =head2 ioloop 450 | 451 | my $loop = $mango->ioloop; 452 | $mango = $mango->ioloop(Mojo::IOLoop->new); 453 | 454 | Event loop object to use for blocking I/O operations, defaults to a 455 | L object. 456 | 457 | =head2 j 458 | 459 | my $j = $mango->j; 460 | $mango = $mango->j(1); 461 | 462 | Wait for all operations to have reached the journal, defaults to C<0>. 463 | 464 | =head2 max_bson_size 465 | 466 | my $max = $mango->max_bson_size; 467 | $mango = $mango->max_bson_size(16777216); 468 | 469 | Maximum size for BSON documents in bytes, defaults to C<16777216> (16MB). 470 | 471 | =head2 max_connections 472 | 473 | my $max = $mango->max_connections; 474 | $mango = $mango->max_connections(5); 475 | 476 | Maximum number of connections to use for non-blocking operations, defaults to 477 | C<5>. 478 | 479 | =head2 max_write_batch_size 480 | 481 | my $max = $mango->max_write_batch_size; 482 | $mango = $mango->max_write_batch_size(1000); 483 | 484 | Maximum number of write operations to batch together, defaults to C<1000>. 485 | 486 | =head2 protocol 487 | 488 | my $protocol = $mango->protocol; 489 | $mango = $mango->protocol(Mango::Protocol->new); 490 | 491 | Protocol handler, defaults to a L object. 492 | 493 | =head2 w 494 | 495 | my $w = $mango->w; 496 | $mango = $mango->w(2); 497 | 498 | Wait for all operations to have reached at least this many servers, C<1> 499 | indicates just primary, C<2> indicates primary and at least one secondary, 500 | defaults to C<1>. 501 | 502 | =head2 wtimeout 503 | 504 | my $timeout = $mango->wtimeout; 505 | $mango = $mango->wtimeout(1); 506 | 507 | Timeout for write propagation in milliseconds, defaults to C<1000>. 508 | 509 | =head1 METHODS 510 | 511 | L inherits all methods from L and implements the following 512 | new ones. 513 | 514 | =head2 backlog 515 | 516 | my $num = $mango->backlog; 517 | 518 | Number of queued operations that have not yet been assigned to a connection. 519 | 520 | =head2 db 521 | 522 | my $db = $mango->db; 523 | my $db = $mango->db('test'); 524 | 525 | Build L object for database, uses L if no name 526 | is provided. Note that the reference L is weakened, 527 | so the L object needs to be referenced elsewhere as well. 528 | 529 | =head2 from_string 530 | 531 | $mango 532 | = $mango->from_string('mongodb://sri:s3cret@localhost:3000/test?w=2'); 533 | 534 | Parse configuration from connection string. 535 | 536 | =head2 get_more 537 | 538 | my $reply = $mango->get_more($namespace, $return, $cursor); 539 | 540 | Perform low level C operation. You can also append a callback to 541 | perform operation non-blocking. 542 | 543 | $mango->get_more(($namespace, $return, $cursor) => sub { 544 | my ($mango, $err, $reply) = @_; 545 | ... 546 | }); 547 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 548 | 549 | =head2 kill_cursors 550 | 551 | $mango->kill_cursors(@ids); 552 | 553 | Perform low level C operation. You can also append a callback to 554 | perform operation non-blocking. 555 | 556 | $mango->kill_cursors(@ids => sub { 557 | my ($mango, $err) = @_; 558 | ... 559 | }); 560 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 561 | 562 | =head2 new 563 | 564 | my $mango = Mango->new; 565 | my $mango = Mango->new('mongodb://sri:s3cret@localhost:3000/test?w=2'); 566 | 567 | Construct a new L object and parse connection string with 568 | L if necessary. 569 | 570 | =head2 query 571 | 572 | my $reply 573 | = $mango->query($namespace, $flags, $skip, $return, $query, $fields); 574 | 575 | Perform low level C operation. You can also append a callback to 576 | perform operation non-blocking. 577 | 578 | $mango->query(($namespace, $flags, $skip, $return, $query, $fields) => sub { 579 | my ($mango, $err, $reply) = @_; 580 | ... 581 | }); 582 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 583 | 584 | =head1 DEBUGGING 585 | 586 | You can set the C environment variable to get some advanced 587 | diagnostics information printed to C. 588 | 589 | MANGO_DEBUG=1 590 | 591 | =head1 SPONSORS 592 | 593 | Some of the work on this distribution has been sponsored by 594 | L, thank you! 595 | 596 | =head1 AUTHOR 597 | 598 | Sebastian Riedel, C. 599 | 600 | =head1 CREDITS 601 | 602 | In alphabetical order: 603 | 604 | =over 2 605 | 606 | Andrey Khozov 607 | 608 | Colin Cyr 609 | 610 | =back 611 | 612 | =head1 COPYRIGHT AND LICENSE 613 | 614 | Copyright (C) 2013-2014, Sebastian Riedel. 615 | 616 | This program is free software, you can redistribute it and/or modify it under 617 | the terms of the Artistic License version 2.0. 618 | 619 | =head1 SEE ALSO 620 | 621 | L, L, 622 | L. 623 | 624 | =cut 625 | -------------------------------------------------------------------------------- /lib/Mango/BSON.pm: -------------------------------------------------------------------------------- 1 | package Mango::BSON; 2 | use Mojo::Base -strict; 3 | 4 | use re 'regexp_pattern'; 5 | use B; 6 | use Carp 'croak'; 7 | use Exporter 'import'; 8 | use Mango::BSON::Binary; 9 | use Mango::BSON::Code; 10 | use Mango::BSON::Document; 11 | use Mango::BSON::ObjectID; 12 | use Mango::BSON::Time; 13 | use Mango::BSON::Timestamp; 14 | use Mojo::JSON; 15 | use Scalar::Util 'blessed'; 16 | 17 | my @BSON = ( 18 | qw(bson_bin bson_code bson_dbref bson_decode bson_doc bson_encode), 19 | qw(bson_false bson_length bson_max bson_min bson_oid bson_raw bson_time), 20 | qw(bson_true bson_ts) 21 | ); 22 | our @EXPORT_OK = (@BSON, 'encode_cstring'); 23 | our %EXPORT_TAGS = (bson => \@BSON); 24 | 25 | # Types 26 | use constant { 27 | DOUBLE => "\x01", 28 | STRING => "\x02", 29 | DOCUMENT => "\x03", 30 | ARRAY => "\x04", 31 | BINARY => "\x05", 32 | OBJECT_ID => "\x07", 33 | BOOL => "\x08", 34 | DATETIME => "\x09", 35 | NULL => "\x0a", 36 | REGEX => "\x0b", 37 | CODE => "\x0d", 38 | CODE_SCOPE => "\x0f", 39 | INT32 => "\x10", 40 | TIMESTAMP => "\x11", 41 | INT64 => "\x12", 42 | MIN_KEY => "\x7f", 43 | MAX_KEY => "\xff" 44 | }; 45 | 46 | # Binary subtypes 47 | use constant { 48 | BINARY_GENERIC => "\x00", 49 | BINARY_FUNCTION => "\x01", 50 | BINARY_UUID => "\x04", 51 | BINARY_MD5 => "\x05", 52 | BINARY_USER_DEFINED => "\x80" 53 | }; 54 | 55 | # 32bit integer range 56 | use constant {INT32_MIN => -(1 << 31) + 1, INT32_MAX => (1 << 31) - 1}; 57 | 58 | # Reuse boolean singletons 59 | my $FALSE = Mojo::JSON->false; 60 | my $TRUE = Mojo::JSON->true; 61 | my $BOOL = blessed $TRUE; 62 | 63 | my $MAXKEY = bless {}, 'Mango::BSON::_MaxKey'; 64 | my $MINKEY = bless {}, 'Mango::BSON::_MinKey'; 65 | 66 | sub bson_bin { Mango::BSON::Binary->new(data => shift) } 67 | 68 | sub bson_code { Mango::BSON::Code->new(code => shift) } 69 | 70 | sub bson_dbref { bson_doc('$ref' => shift, '$id' => shift) } 71 | 72 | sub bson_decode { 73 | my $bson = shift; 74 | return undef unless my $len = bson_length($bson); 75 | return length $bson == $len ? _decode_doc(\$bson) : undef; 76 | } 77 | 78 | sub bson_doc { 79 | tie my %hash, 'Mango::BSON::Document', @_; 80 | return \%hash; 81 | } 82 | 83 | sub bson_encode { 84 | my $doc = shift; 85 | 86 | # Embedded BSON 87 | return $doc->{'$bson'} if exists $doc->{'$bson'}; 88 | 89 | my $bson = join '', 90 | map { _encode_value(encode_cstring($_), $doc->{$_}) } keys %$doc; 91 | 92 | # Document ends with null byte 93 | return pack('l<', length($bson) + 5) . $bson . "\x00"; 94 | } 95 | 96 | sub bson_false {$FALSE} 97 | 98 | sub bson_length { length $_[0] < 4 ? undef : unpack 'l<', substr($_[0], 0, 4) } 99 | 100 | sub bson_max {$MAXKEY} 101 | 102 | sub bson_min {$MINKEY} 103 | 104 | sub bson_oid { Mango::BSON::ObjectID->new(@_) } 105 | 106 | sub bson_raw { bson_doc('$bson' => shift) } 107 | 108 | sub bson_time { Mango::BSON::Time->new(@_) } 109 | 110 | sub bson_ts { 111 | Mango::BSON::Timestamp->new(seconds => shift, increment => shift); 112 | } 113 | 114 | sub bson_true {$TRUE} 115 | 116 | sub encode_cstring { 117 | my $str = shift; 118 | utf8::encode $str; 119 | return pack 'Z*', $str; 120 | } 121 | 122 | sub _decode_binary { 123 | my $bsonref = shift; 124 | 125 | my $len = unpack 'l<', substr($$bsonref, 0, 4, ''); 126 | my $subtype = substr $$bsonref, 0, 1, ''; 127 | my $binary = substr $$bsonref, 0, $len, ''; 128 | 129 | return bson_bin($binary)->type('function') if $subtype eq BINARY_FUNCTION; 130 | return bson_bin($binary)->type('md5') if $subtype eq BINARY_MD5; 131 | return bson_bin($binary)->type('uuid') if $subtype eq BINARY_UUID; 132 | return bson_bin($binary)->type('user_defined') 133 | if $subtype eq BINARY_USER_DEFINED; 134 | return bson_bin($binary)->type('generic'); 135 | } 136 | 137 | sub _decode_cstring { 138 | my $bsonref = shift; 139 | my $str = substr $$bsonref, 0, index($$bsonref, "\x00"), ''; 140 | utf8::decode $str; 141 | substr $$bsonref, 0, 1, ''; 142 | return $str; 143 | } 144 | 145 | sub _decode_doc { 146 | my $bsonref = shift; 147 | 148 | # Every element starts with a type 149 | my @doc; 150 | substr $$bsonref, 0, 4, ''; 151 | while (my $type = substr $$bsonref, 0, 1, '') { 152 | 153 | # Null byte (end of document) 154 | last if $type eq "\x00"; 155 | 156 | push @doc, _decode_cstring($bsonref), _decode_value($type, $bsonref); 157 | } 158 | 159 | return bson_doc(@doc); 160 | } 161 | 162 | sub _decode_string { 163 | my $bsonref = shift; 164 | 165 | my $len = unpack 'l<', substr($$bsonref, 0, 4, ''); 166 | my $str = substr $$bsonref, 0, $len - 1, ''; 167 | utf8::decode $str; 168 | substr $$bsonref, 0, 1, ''; 169 | 170 | return $str; 171 | } 172 | 173 | sub _decode_value { 174 | my ($type, $bsonref) = @_; 175 | 176 | # String 177 | return _decode_string($bsonref) if $type eq STRING; 178 | 179 | # Object ID 180 | return bson_oid(unpack 'H*', substr $$bsonref, 0, 12, '') 181 | if $type eq OBJECT_ID; 182 | 183 | # Double/Int32/Int64 184 | return unpack 'd<', substr $$bsonref, 0, 8, '' if $type eq DOUBLE; 185 | return unpack 'l<', substr($$bsonref, 0, 4, '') if $type eq INT32; 186 | return unpack 'q<', substr($$bsonref, 0, 8, '') if $type eq INT64; 187 | 188 | # Document 189 | return _decode_doc($bsonref) if $type eq DOCUMENT; 190 | 191 | # Array 192 | return [values %{_decode_doc($bsonref)}] if $type eq ARRAY; 193 | 194 | # Booleans and Null 195 | return substr($$bsonref, 0, 1, '') eq "\x00" ? bson_false() : bson_true() 196 | if $type eq BOOL; 197 | return undef if $type eq NULL; 198 | 199 | # Time 200 | return bson_time(unpack 'q<', substr($$bsonref, 0, 8, '')) 201 | if $type eq DATETIME; 202 | 203 | # Regex 204 | return eval join '/', 'qr', _decode_cstring($bsonref), 205 | _decode_cstring($bsonref) 206 | if $type eq REGEX; 207 | 208 | # Binary (with subtypes) 209 | return _decode_binary($bsonref) if $type eq BINARY; 210 | 211 | # Min/Max 212 | return bson_min() if $type eq MIN_KEY; 213 | return bson_max() if $type eq MAX_KEY; 214 | 215 | # Code (with and without scope) 216 | return bson_code(_decode_string($bsonref)) if $type eq CODE; 217 | if ($type eq CODE_SCOPE) { 218 | substr $$bsonref, 0, 4, ''; 219 | return bson_code(_decode_string($bsonref))->scope(_decode_doc($bsonref)); 220 | } 221 | 222 | # Timestamp 223 | return bson_ts( 224 | reverse map({ unpack 'l<', substr($$_, 0, 4, '') } $bsonref, $bsonref)) 225 | if $type eq TIMESTAMP; 226 | 227 | # Unknown 228 | croak 'Unknown BSON type'; 229 | } 230 | 231 | sub _encode_binary { 232 | my ($e, $subtype, $value) = @_; 233 | return BINARY . $e . pack('l<', length $value) . $subtype . $value; 234 | } 235 | 236 | sub _encode_object { 237 | my ($e, $value, $class) = @_; 238 | 239 | # ObjectID 240 | return OBJECT_ID . $e . $value->to_bytes 241 | if $class eq 'Mango::BSON::ObjectID'; 242 | 243 | # Boolean 244 | return BOOL . $e . ($value ? "\x01" : "\x00") if $class eq $BOOL; 245 | 246 | # Time 247 | return DATETIME . $e . pack('q<', $value) if $class eq 'Mango::BSON::Time'; 248 | 249 | # Max 250 | return MAX_KEY . $e if $value eq $MAXKEY; 251 | 252 | # Min 253 | return MIN_KEY . $e if $value eq $MINKEY; 254 | 255 | # Regex 256 | if ($class eq 'Regexp') { 257 | my ($p, $m) = regexp_pattern($value); 258 | return REGEX . $e . encode_cstring($p) . encode_cstring($m); 259 | } 260 | 261 | # Binary 262 | if ($class eq 'Mango::BSON::Binary') { 263 | my $type = $value->type // 'generic'; 264 | my $data = $value->data; 265 | return _encode_binary($e, BINARY_FUNCTION, $data) if $type eq 'function'; 266 | return _encode_binary($e, BINARY_MD5, $data) if $type eq 'md5'; 267 | return _encode_binary($e, BINARY_USER_DEFINED, $data) 268 | if $type eq 'user_defined'; 269 | return _encode_binary($e, BINARY_UUID, $data) if $type eq 'uuid'; 270 | return _encode_binary($e, BINARY_GENERIC, $data); 271 | } 272 | 273 | # Code 274 | if ($class eq 'Mango::BSON::Code') { 275 | 276 | # With scope 277 | if (my $scope = $value->scope) { 278 | my $code = _encode_string($value->code) . bson_encode($scope); 279 | return CODE_SCOPE . $e . pack('l<', length $code) . $code; 280 | } 281 | 282 | # Without scope 283 | return CODE . $e . _encode_string($value->code); 284 | } 285 | 286 | # Timestamp 287 | return TIMESTAMP, $e, map { pack 'l<', $_ } $value->increment, 288 | $value->seconds 289 | if $class eq 'Mango::BSON::Timestamp'; 290 | 291 | # Blessed reference with TO_JSON method 292 | if (my $sub = $value->can('TO_BSON') // $value->can('TO_JSON')) { 293 | return _encode_value($e, $value->$sub); 294 | } 295 | 296 | # Stringify 297 | return STRING . $e . _encode_string($value); 298 | } 299 | 300 | sub _encode_string { 301 | my $str = shift; 302 | utf8::encode $str; 303 | return pack('l<', length($str) + 1) . "$str\x00"; 304 | } 305 | 306 | sub _encode_value { 307 | my ($e, $value) = @_; 308 | 309 | # Null 310 | return NULL . $e unless defined $value; 311 | 312 | # Reference 313 | if (my $ref = ref $value) { 314 | 315 | # Blessed 316 | return _encode_object($e, $value, $ref) if blessed $value; 317 | 318 | # Hash (Document) 319 | return DOCUMENT . $e . bson_encode($value) if $ref eq 'HASH'; 320 | 321 | # Array 322 | if ($ref eq 'ARRAY') { 323 | my $i = 0; 324 | return ARRAY . $e . bson_encode(bson_doc(map { $i++ => $_ } @$value)); 325 | } 326 | 327 | # Scalar (boolean shortcut) 328 | return _encode_object($e, !!$$value, $BOOL) if $ref eq 'SCALAR'; 329 | } 330 | 331 | # Numeric 332 | my $flags = B::svref_2object(\$value)->FLAGS; 333 | if ($flags & (B::SVp_IOK | B::SVp_NOK)) { 334 | if (0 + $value eq $value && $value * 0 == 0) { 335 | 336 | # Double 337 | return DOUBLE . $e . pack('d<', $value) if $flags & B::SVp_NOK; 338 | 339 | # Int32 340 | return INT32 . $e . pack('l<', $value) 341 | if $value <= INT32_MAX && $value >= INT32_MIN; 342 | 343 | # Int64 344 | return INT64 . $e . pack('q<', $value); 345 | } 346 | } 347 | 348 | # String 349 | return STRING . $e . _encode_string("$value"); 350 | } 351 | 352 | # Constants 353 | package Mango::BSON::_MaxKey; 354 | 355 | package Mango::BSON::_MinKey; 356 | 357 | 1; 358 | 359 | =encoding utf8 360 | 361 | =head1 NAME 362 | 363 | Mango::BSON - BSON 364 | 365 | =head1 SYNOPSIS 366 | 367 | use Mango::BSON ':bson'; 368 | 369 | my $bson = bson_encode { 370 | foo => 'bar', 371 | baz => 0.42, 372 | unordered => {one => [1, 2, 3], two => bson_time}, 373 | ordered => bson_doc(one => qr/test/i, two => bson_true) 374 | }; 375 | my $doc = bson_decode $bson; 376 | 377 | =head1 DESCRIPTION 378 | 379 | L is a minimalistic implementation of L. 380 | 381 | In addition to a bunch of custom BSON data types it supports normal Perl data 382 | types like scalar, regular expression, C, array reference, hash 383 | reference and will try to call the C and C methods on 384 | blessed references, or stringify them if it doesn't exist. Scalar references 385 | will be used to generate booleans, based on if their values are true or false. 386 | 387 | =head1 FUNCTIONS 388 | 389 | L implements the following functions, which can be imported 390 | individually or at once with the C<:bson> flag. 391 | 392 | =head2 bson_bin 393 | 394 | my $bin = bson_bin $bytes; 395 | 396 | Create new BSON element of the binary type with L, 397 | defaults to the C binary subtype. 398 | 399 | # Function 400 | bson_bin($bytes)->type('function'); 401 | 402 | # MD5 403 | bson_bin($bytes)->type('md5'); 404 | 405 | # UUID 406 | bson_bin($bytes)->type('uuid'); 407 | 408 | # User defined 409 | bson_bin($bytes)->type('user_defined'); 410 | 411 | =head2 bson_code 412 | 413 | my $code = bson_code 'function () {}'; 414 | 415 | Create new BSON element of the code type with L. 416 | 417 | # With scope 418 | bson_code('function () {}')->scope({foo => 'bar'}); 419 | 420 | =head2 bson_dbref 421 | 422 | my $dbref = bson_dbref 'test', $oid; 423 | 424 | Create a new database reference. 425 | 426 | # Longer version 427 | my $dbref = {'$ref' => 'test', '$id' => $oid}; 428 | 429 | =head2 bson_decode 430 | 431 | my $doc = bson_decode $bson; 432 | 433 | Decode BSON into Perl data structures. 434 | 435 | =head2 bson_doc 436 | 437 | my $doc = bson_doc; 438 | my $doc = bson_doc foo => 'bar', baz => 0.42, yada => {yada => [1, 2, 3]}; 439 | 440 | Create new BSON document with L, which can also be used 441 | as a generic ordered hash. 442 | 443 | # Order is preserved 444 | my $hash = bson_doc one => 1, two => 2, three => 3; 445 | $hash->{four} = 4; 446 | delete $hash->{two}; 447 | say for keys %$hash; 448 | 449 | =head2 bson_encode 450 | 451 | my $bson = bson_encode $doc; 452 | my $bson = bson_encode {}; 453 | 454 | Encode Perl data structures into BSON. 455 | 456 | =head2 bson_false 457 | 458 | my $false = bson_false; 459 | 460 | Create new BSON element of the boolean type false. 461 | 462 | =head2 bson_length 463 | 464 | my $len = bson_length $bson; 465 | 466 | Check BSON length prefix. 467 | 468 | =head2 bson_max 469 | 470 | my $max_key = bson_max; 471 | 472 | Create new BSON element of the max key type. 473 | 474 | =head2 bson_min 475 | 476 | my $min_key = bson_min; 477 | 478 | Create new BSON element of the min key type. 479 | 480 | =head2 bson_oid 481 | 482 | my $oid = bson_oid; 483 | my $oid = bson_oid '1a2b3c4e5f60718293a4b5c6'; 484 | 485 | Create new BSON element of the object id type with L, 486 | defaults to generating a new unique object id. 487 | 488 | # Generate object id with specific epoch time 489 | my $oid = bson_oid->from_epoch(1359840145); 490 | 491 | =head2 bson_raw 492 | 493 | my $raw = bson_raw $bson; 494 | 495 | Pre-encoded BSON document. 496 | 497 | # Longer version 498 | my $raw = {'$bson' => $bson}; 499 | 500 | # Embed pre-encoded BSON document 501 | my $first = bson_encode {foo => 'bar'}; 502 | my $second = bson_encode {test => bson_raw $first}; 503 | 504 | =head2 bson_time 505 | 506 | my $now = bson_time; 507 | my $time = bson_time time * 1000; 508 | 509 | Create new BSON element of the UTC datetime type with L, 510 | defaults to milliseconds since the UNIX epoch. 511 | 512 | # "1360626536.748" 513 | bson_time(1360626536748)->to_epoch; 514 | 515 | # "2013-02-11T23:48:56.748Z" 516 | bson_time(1360626536748)->to_datetime; 517 | 518 | =head2 bson_true 519 | 520 | my $true = bson_true; 521 | 522 | Create new BSON element of the boolean type true. 523 | 524 | =head2 bson_ts 525 | 526 | my $timestamp = bson_ts 23, 24; 527 | 528 | Create new BSON element of the timestamp type with L. 529 | 530 | =head2 encode_cstring 531 | 532 | my $bytes = encode_cstring $cstring; 533 | 534 | Encode cstring. 535 | 536 | =head1 SEE ALSO 537 | 538 | L, L, L. 539 | 540 | =cut 541 | -------------------------------------------------------------------------------- /lib/Mango/BSON/Binary.pm: -------------------------------------------------------------------------------- 1 | package Mango::BSON::Binary; 2 | use Mojo::Base -base; 3 | use overload bool => sub {1}, '""' => sub { shift->data }, fallback => 1; 4 | 5 | use Mojo::Util 'b64_encode'; 6 | 7 | has [qw(data type)]; 8 | 9 | sub TO_JSON { b64_encode shift->data, '' } 10 | 11 | 1; 12 | 13 | =encoding utf8 14 | 15 | =head1 NAME 16 | 17 | Mango::BSON::Binary - Binary type 18 | 19 | =head1 SYNOPSIS 20 | 21 | use Mango::BSON::Binary; 22 | 23 | my $bin = Mango::BSON::Binary->new(data => $bytes, type => 'generic'); 24 | say $bin->data; 25 | 26 | =head1 DESCRIPTION 27 | 28 | L is a container for the BSON binary type used by 29 | L. For C implementations like L, that support 30 | the C method, it will automatically C encode the binary data. 31 | 32 | =head1 ATTRIBUTES 33 | 34 | L implements the following attributes. 35 | 36 | =head2 data 37 | 38 | my $bytes = $bin->data; 39 | $bin = $bin->data($bytes); 40 | 41 | Binary data. 42 | 43 | =head2 type 44 | 45 | my $type = $bin->type; 46 | $bin = $bin->type('generic'); 47 | 48 | Binary subtype. 49 | 50 | =head1 METHODS 51 | 52 | L inherits all methods from L and implements 53 | the following new ones. 54 | 55 | =head2 TO_JSON 56 | 57 | my $b64 = $bin->TO_JSON; 58 | 59 | Base64 encode L. 60 | 61 | =head1 OPERATORS 62 | 63 | L overloads the following operators. 64 | 65 | =head2 bool 66 | 67 | my $bool = !!$bin; 68 | 69 | Always true. 70 | 71 | =head2 stringify 72 | 73 | my $str = "$bin"; 74 | 75 | Alias for L. 76 | 77 | =head1 SEE ALSO 78 | 79 | L, L, L. 80 | 81 | =cut 82 | -------------------------------------------------------------------------------- /lib/Mango/BSON/Code.pm: -------------------------------------------------------------------------------- 1 | package Mango::BSON::Code; 2 | use Mojo::Base -base; 3 | 4 | has [qw(code scope)]; 5 | 6 | 1; 7 | 8 | =encoding utf8 9 | 10 | =head1 NAME 11 | 12 | Mango::BSON::Code - Code type 13 | 14 | =head1 SYNOPSIS 15 | 16 | use Mango::BSON::Code; 17 | 18 | my $code = Mango::BSON::Code->new(code => 'function () {}'); 19 | 20 | =head1 DESCRIPTION 21 | 22 | L is a container for the BSON code type used by 23 | L. 24 | 25 | =head1 ATTRIBUTES 26 | 27 | L implements the following attributes. 28 | 29 | =head2 code 30 | 31 | my $js = $code->code; 32 | $code = $code->code('function () {}'); 33 | 34 | JavaScript code. 35 | 36 | =head2 scope 37 | 38 | my $scode = $code->scope; 39 | $code = $code->scope({foo => 'bar'}); 40 | 41 | Scope. 42 | 43 | =head1 METHODS 44 | 45 | L inherits all methods from L. 46 | 47 | =head1 SEE ALSO 48 | 49 | L, L, L. 50 | 51 | =cut 52 | -------------------------------------------------------------------------------- /lib/Mango/BSON/Document.pm: -------------------------------------------------------------------------------- 1 | package Mango::BSON::Document; 2 | use Mojo::Base 'Tie::Hash'; 3 | 4 | sub DELETE { 5 | my ($self, $key) = @_; 6 | return undef unless exists $self->[0]{$key}; 7 | $key eq $self->[1][$_] and splice @{$self->[1]}, $_, 1 and last 8 | for 0 .. $#{$self->[1]}; 9 | return delete $self->[0]{$key}; 10 | } 11 | 12 | sub EXISTS { exists $_[0][0]{$_[1]} } 13 | 14 | sub FETCH { $_[0][0]{$_[1]} } 15 | 16 | sub FIRSTKEY { 17 | $_[0][2] = 0; 18 | &NEXTKEY; 19 | } 20 | 21 | sub NEXTKEY { $_[0][2] <= $#{$_[0][1]} ? $_[0][1][$_[0][2]++] : undef } 22 | 23 | sub STORE { 24 | my ($self, $key, $value) = @_; 25 | push @{$self->[1]}, $key unless exists $self->[0]{$key}; 26 | $self->[0]{$key} = $value; 27 | } 28 | 29 | sub TIEHASH { 30 | my $self = bless [{}, [], 0], shift; 31 | $self->STORE(shift, shift) while @_; 32 | return $self; 33 | } 34 | 35 | 1; 36 | 37 | =encoding utf8 38 | 39 | =head1 NAME 40 | 41 | Mango::BSON::Document - Document type 42 | 43 | =head1 SYNOPSIS 44 | 45 | use Mango::BSON::Document; 46 | 47 | tie my %hash, 'Mango::BSON::Document'; 48 | 49 | =head1 DESCRIPTION 50 | 51 | L is a container for the BSON document type used by 52 | L. 53 | 54 | =head1 SEE ALSO 55 | 56 | L, L, L. 57 | 58 | =cut 59 | -------------------------------------------------------------------------------- /lib/Mango/BSON/ObjectID.pm: -------------------------------------------------------------------------------- 1 | package Mango::BSON::ObjectID; 2 | use Mojo::Base -base; 3 | use overload bool => sub {1}, '""' => sub { shift->to_string }, fallback => 1; 4 | 5 | use Carp 'croak'; 6 | use Mojo::Util 'md5_bytes'; 7 | use Sys::Hostname 'hostname'; 8 | 9 | # 3 byte machine identifier 10 | my $MACHINE = substr md5_bytes(hostname), 0, 3; 11 | 12 | # Global counter 13 | my $COUNTER = 0; 14 | 15 | sub from_epoch { 16 | my ($self, $epoch) = @_; 17 | $self->{oid} = _generate($epoch); 18 | return $self; 19 | } 20 | 21 | sub new { 22 | my $class = shift; 23 | return $class->SUPER::new unless defined(my $oid = shift); 24 | croak qq{Invalid object id "$oid"} if $oid !~ /^[0-9a-fA-F]{24}$/; 25 | return $class->SUPER::new(oid => pack('H*', $oid)); 26 | } 27 | 28 | sub to_bytes { shift->{oid} //= _generate() } 29 | 30 | sub to_epoch { unpack 'N', substr(shift->to_bytes, 0, 4) } 31 | 32 | sub to_string { unpack 'H*', shift->to_bytes } 33 | 34 | sub _generate { 35 | 36 | # 4 byte time, 3 byte machine identifier and 2 byte process id 37 | my $oid = pack('N', shift // time) . $MACHINE . pack('n', $$ % 0xffff); 38 | 39 | # 3 byte counter 40 | $COUNTER = ($COUNTER + 1) % 0xffffff; 41 | return $oid . substr pack('V', $COUNTER), 0, 3; 42 | } 43 | 44 | 1; 45 | 46 | =encoding utf8 47 | 48 | =head1 NAME 49 | 50 | Mango::BSON::ObjectID - Object ID type 51 | 52 | =head1 SYNOPSIS 53 | 54 | use Mango::BSON::ObjectID; 55 | 56 | my $oid = Mango::BSON::ObjectID->new('1a2b3c4e5f60718293a4b5c6'); 57 | say $oid->to_epoch; 58 | 59 | =head1 DESCRIPTION 60 | 61 | L is a container for the BSON object id type used by 62 | L. 63 | 64 | =head1 METHODS 65 | 66 | L inherits all methods from L and 67 | implements the following new ones. 68 | 69 | =head2 from_epoch 70 | 71 | my $oid = $oid->from_epoch(1359840145); 72 | 73 | Generate new object id with specific epoch time. 74 | 75 | =head2 new 76 | 77 | my $oid = Mango::BSON::ObjectID->new; 78 | my $oid = Mango::BSON::ObjectID->new('1a2b3c4e5f60718293a4b5c6'); 79 | 80 | Construct a new L object. 81 | 82 | =head2 to_bytes 83 | 84 | my $bytes = $oid->to_bytes; 85 | 86 | Object id in binary form. 87 | 88 | =head2 to_epoch 89 | 90 | my $epoch = $oid->to_epoch; 91 | 92 | Extract epoch seconds from object id. 93 | 94 | =head2 to_string 95 | 96 | my $str = $oid->to_string; 97 | 98 | Stringify object id. 99 | 100 | =head1 OPERATORS 101 | 102 | L overloads the following operators. 103 | 104 | =head2 bool 105 | 106 | my $bool = !!$oid; 107 | 108 | Always true. 109 | 110 | =head2 stringify 111 | 112 | my $str = "$oid"; 113 | 114 | Alias for L. 115 | 116 | =head1 SEE ALSO 117 | 118 | L, L, L. 119 | 120 | =cut 121 | -------------------------------------------------------------------------------- /lib/Mango/BSON/Time.pm: -------------------------------------------------------------------------------- 1 | package Mango::BSON::Time; 2 | use Mojo::Base -base; 3 | use overload bool => sub {1}, '""' => sub { shift->to_string }, fallback => 1; 4 | 5 | use Mojo::Date; 6 | use Time::HiRes 'time'; 7 | 8 | sub new { shift->SUPER::new(time => shift // int(time * 1000)) } 9 | 10 | sub TO_JSON { 0 + shift->{time} } 11 | 12 | sub to_datetime { Mojo::Date->new(shift->to_epoch)->to_datetime } 13 | 14 | sub to_epoch { shift->to_string / 1000 } 15 | 16 | sub to_string { shift->{time} } 17 | 18 | 1; 19 | 20 | =encoding utf8 21 | 22 | =head1 NAME 23 | 24 | Mango::BSON::Time - Datetime type 25 | 26 | =head1 SYNOPSIS 27 | 28 | use Mango::BSON::Time; 29 | 30 | my $time = Mango::BSON::Time->new(time * 1000); 31 | say $time->to_epoch; 32 | 33 | =head1 DESCRIPTION 34 | 35 | L is a container for the BSON datetime type used by 36 | L. 37 | 38 | =head1 METHODS 39 | 40 | L inherits all methods from L and implements 41 | the following new ones. 42 | 43 | =head2 new 44 | 45 | my $time = Mango::BSON::Time->new; 46 | my $time = Mango::BSON::Time->new(time * 1000); 47 | 48 | Construct a new L object. 49 | 50 | =head2 TO_JSON 51 | 52 | my $num = $time->TO_JSON; 53 | 54 | Numeric representation of time. 55 | 56 | =head2 to_datetime 57 | 58 | my $str = $time->to_datetime; 59 | 60 | Convert time to L date and time. 61 | 62 | =head2 to_epoch 63 | 64 | my $epoch = $time->to_epoch; 65 | 66 | Convert time to floating seconds since the epoch. 67 | 68 | =head2 to_string 69 | 70 | my $str = $time->to_string; 71 | 72 | Stringify time. 73 | 74 | =head1 OPERATORS 75 | 76 | L overloads the following operators. 77 | 78 | =head2 bool 79 | 80 | my $bool = !!$time; 81 | 82 | Always true. 83 | 84 | =head2 stringify 85 | 86 | my $str = "$time"; 87 | 88 | Alias for L. 89 | 90 | =head1 SEE ALSO 91 | 92 | L, L, L. 93 | 94 | =cut 95 | -------------------------------------------------------------------------------- /lib/Mango/BSON/Timestamp.pm: -------------------------------------------------------------------------------- 1 | package Mango::BSON::Timestamp; 2 | use Mojo::Base -base; 3 | 4 | has [qw(seconds increment)]; 5 | 6 | 1; 7 | 8 | =encoding utf8 9 | 10 | =head1 NAME 11 | 12 | Mango::BSON::Timestamp - Timestamp type 13 | 14 | =head1 SYNOPSIS 15 | 16 | use Mango::BSON::Timestamp; 17 | 18 | my $ts = Mango::BSON::Timestamp->new(seconds => 23, increment => 5); 19 | 20 | =head1 DESCRIPTION 21 | 22 | L is a container for the BSON timestamp type used by 23 | L. 24 | 25 | =head1 ATTRIBUTES 26 | 27 | L implements the following attributes. 28 | 29 | =head2 seconds 30 | 31 | my $seconds = $ts->seconds; 32 | $ts = $ts->seconds(23); 33 | 34 | Seconds. 35 | 36 | =head2 increment 37 | 38 | my $inc = $ts->increment; 39 | $tz = $ts->increment(5); 40 | 41 | Increment. 42 | 43 | =head1 METHODS 44 | 45 | L inherits all methods from L. 46 | 47 | =head1 SEE ALSO 48 | 49 | L, L, L. 50 | 51 | =cut 52 | -------------------------------------------------------------------------------- /lib/Mango/Bulk.pm: -------------------------------------------------------------------------------- 1 | package Mango::Bulk; 2 | use Mojo::Base -base; 3 | 4 | use Carp 'croak'; 5 | use Mango::BSON qw(bson_doc bson_encode bson_oid bson_raw); 6 | use Mojo::IOLoop; 7 | 8 | has 'collection'; 9 | has ordered => 1; 10 | 11 | sub execute { 12 | my ($self, $cb) = @_; 13 | 14 | # Full results shared with all operations 15 | my $full = {upserted => [], writeConcernErrors => [], writeErrors => []}; 16 | $full->{$_} = 0 for qw(nInserted nMatched nModified nRemoved nUpserted); 17 | 18 | # Non-blocking 19 | if ($cb) { 20 | return Mojo::IOLoop->next_tick(sub { shift; $self->$cb(undef, $full) }) 21 | unless my $group = shift @{$self->{ops}}; 22 | return $self->_next($group, $full, $cb); 23 | } 24 | 25 | # Blocking 26 | my $db = $self->collection->db; 27 | my $protocol = $db->mango->protocol; 28 | while (my $group = shift @{$self->{ops}}) { 29 | my ($type, $offset, $command) = $self->_group($group); 30 | _merge($type, $offset, $full, $db->command($command)); 31 | if (my $err = $protocol->write_error($full)) { croak $err } 32 | } 33 | 34 | return $full; 35 | } 36 | 37 | sub find { shift->_set(query => shift) } 38 | 39 | sub insert { 40 | my ($self, $doc) = @_; 41 | $doc->{_id} //= bson_oid; 42 | return $self->_op(insert => $doc); 43 | } 44 | 45 | sub remove { shift->_remove(0) } 46 | sub remove_one { shift->_remove(1) } 47 | 48 | sub update { shift->_update(\1, @_) } 49 | sub update_one { shift->_update(\0, @_) } 50 | 51 | sub upsert { shift->_set(upsert => 1) } 52 | 53 | sub _group { 54 | my ($self, $group) = @_; 55 | 56 | my ($type, $offset) = splice @$group, 0, 2; 57 | my $collection = $self->collection; 58 | return $type, $offset, bson_doc $type => $collection->name, 59 | $type eq 'insert' ? 'documents' : "${type}s" => $group, 60 | ordered => $self->ordered ? \1 : \0, 61 | writeConcern => $collection->db->build_write_concern; 62 | } 63 | 64 | sub _merge { 65 | my ($type, $offset, $full, $result) = @_; 66 | 67 | # Insert 68 | if ($type eq 'insert') { $full->{nInserted} += $result->{n} } 69 | 70 | # Update 71 | elsif ($type eq 'update') { 72 | $full->{nModified} += $result->{n}; 73 | 74 | # Upsert 75 | if (my $upserted = $result->{upserted}) { 76 | push @{$full->{upserted}}, map { $_->{index} += $offset; $_ } @$upserted; 77 | $full->{nUpserted} += @$upserted; 78 | $full->{nMatched} += $result->{n} - @$upserted; 79 | } 80 | 81 | else { $full->{nMatched} += $result->{n} } 82 | } 83 | 84 | # Delete 85 | elsif ($type eq 'delete') { $full->{nRemoved} += $result->{n} } 86 | 87 | # Errors 88 | push @{$full->{writeConcernErrors}}, $result->{writeConcernError} 89 | if $result->{writeConcernError}; 90 | push @{$full->{writeErrors}}, 91 | map { $_->{index} += $offset; $_ } @{$result->{writeErrors}}; 92 | } 93 | 94 | sub _next { 95 | my ($self, $group, $full, $cb) = @_; 96 | 97 | my ($type, $offset, $command) = $self->_group($group); 98 | $self->collection->db->command( 99 | $command => sub { 100 | my ($db, $err, $result) = @_; 101 | 102 | _merge($type, $offset, $full, $result); 103 | $err ||= $self->collection->db->mango->protocol->write_error($full); 104 | return $self->$cb($err, $full) if $err; 105 | 106 | return $self->$cb(undef, $full) unless my $next = shift @{$self->{ops}}; 107 | $self->_next($next, $full, $cb); 108 | } 109 | ); 110 | } 111 | 112 | sub _op { 113 | my ($self, $type, $doc) = @_; 114 | 115 | # Pre-encode documents 116 | my $mango = $self->collection->db->mango; 117 | my $bson_max = $mango->max_bson_size; 118 | my $batch_max = $mango->max_write_batch_size; 119 | my $ops = $self->{ops} ||= []; 120 | my $previous = @$ops ? $ops->[-1] : []; 121 | my $bson = bson_encode $doc; 122 | my $size = length $bson; 123 | my $new = ($self->{size} // 0) + $size; 124 | my $limit = $new > $bson_max || @$previous >= $batch_max + 2; 125 | 126 | # Group documents based on type and limits 127 | push @$ops, [$type, $self->{offset} || 0] and delete $self->{size} 128 | if !@$previous || $previous->[0] ne $type || $limit; 129 | push @{$ops->[-1]}, bson_raw $bson; 130 | $self->{size} += $size; 131 | $self->{offset}++; 132 | 133 | return $self; 134 | } 135 | 136 | sub _remove { 137 | my ($self, $limit) = @_; 138 | my $query = delete $self->{query} // {}; 139 | return $self->_op(delete => {q => $query, limit => $limit}); 140 | } 141 | 142 | sub _set { 143 | my ($self, $key, $value) = @_; 144 | $self->{$key} = $value; 145 | return $self; 146 | } 147 | 148 | sub _update { 149 | my ($self, $multi, $update) = @_; 150 | my $query = delete $self->{query} // {}; 151 | my $upsert = delete $self->{upsert} ? \1 : \0; 152 | return $self->_op( 153 | update => {q => $query, u => $update, multi => $multi, upsert => $upsert}); 154 | } 155 | 156 | 1; 157 | 158 | =encoding utf8 159 | 160 | =head1 NAME 161 | 162 | Mango::Bulk - MongoDB bulk operations 163 | 164 | =head1 SYNOPSIS 165 | 166 | use Mango::Bulk; 167 | 168 | my $bulk = Mango::Bulk->new(collection => $collection); 169 | $bulk->insert({foo => 'bar'})->insert({foo => 'baz'})->execute; 170 | 171 | =head1 DESCRIPTION 172 | 173 | L is a container for MongoDB bulk operations, all operations will 174 | be automatically grouped so they don't exceed L. 175 | 176 | =head1 ATTRIBUTES 177 | 178 | L implements the following attributes. 179 | 180 | =head2 collection 181 | 182 | my $collection = $bulk->collection; 183 | $bulk = $bulk->collection(Mango::Collection->new); 184 | 185 | L object this bulk operation belongs to. 186 | 187 | =head2 ordered 188 | 189 | my $bool = $bulk->ordered; 190 | $bulk = $bulk->ordered($bool); 191 | 192 | Bulk operations are ordered, defaults to a true value. 193 | 194 | =head1 METHODS 195 | 196 | L inherits all methods from L and implements the 197 | following new ones. 198 | 199 | =head2 execute 200 | 201 | my $results = $bulk->execute; 202 | 203 | Execute bulk operations. You can also append a callback to perform operation 204 | non-blocking. 205 | 206 | $bulk->execute(sub { 207 | my ($bulk, $err, $results) = @_; 208 | ... 209 | }); 210 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 211 | 212 | =head2 find 213 | 214 | $bulk = $bulk->find({foo => 'bar'}); 215 | 216 | Query for next update or remove operation. 217 | 218 | =head2 insert 219 | 220 | $bulk = $bulk->insert({foo => 'bar'}); 221 | 222 | Insert document. 223 | 224 | =head2 remove 225 | 226 | $bulk = $bulk->remove; 227 | 228 | Remove multiple documents. 229 | 230 | =head2 remove_one 231 | 232 | $bulk = $bulk->remove_one; 233 | 234 | Remove one document. 235 | 236 | =head2 update 237 | 238 | $bulk = $bulk->update({foo => 'bar'}); 239 | 240 | Update multiple documents. 241 | 242 | =head2 update_one 243 | 244 | $bulk = $bulk->update_one({foo => 'baz'}); 245 | 246 | Update one document. 247 | 248 | =head2 upsert 249 | 250 | $bulk = $bulk->upsert; 251 | 252 | Next update operation will be an C. 253 | 254 | =head1 SEE ALSO 255 | 256 | L, L, L. 257 | 258 | =cut 259 | -------------------------------------------------------------------------------- /lib/Mango/Collection.pm: -------------------------------------------------------------------------------- 1 | package Mango::Collection; 2 | use Mojo::Base -base; 3 | 4 | use Carp 'croak'; 5 | use Mango::BSON qw(bson_code bson_doc bson_oid); 6 | use Mango::Bulk; 7 | use Mango::Cursor; 8 | use Mango::Cursor::Query; 9 | 10 | has [qw(db name)]; 11 | 12 | sub aggregate { 13 | my ($self, $pipeline) = (shift, shift); 14 | my $cb = ref $_[-1] eq 'CODE' ? pop : undef; 15 | 16 | my $command = bson_doc(aggregate => $self->name, pipeline => $pipeline, 17 | %{shift // {}}); 18 | $command->{cursor} //= {} unless $command->{explain}; 19 | 20 | # Blocking 21 | return $self->_aggregate($command, $self->db->command($command)) unless $cb; 22 | 23 | # Non-blocking 24 | return $self->db->command($command, 25 | sub { shift; $self->$cb(shift, $self->_aggregate($command, shift)) }); 26 | } 27 | 28 | sub build_index_name { join '_', keys %{$_[1]} } 29 | 30 | sub bulk { Mango::Bulk->new(collection => shift) } 31 | 32 | sub create { 33 | my $self = shift; 34 | my $cb = ref $_[-1] eq 'CODE' ? pop : undef; 35 | return $self->_command(bson_doc(create => $self->name, %{shift // {}}), $cb); 36 | } 37 | 38 | sub drop { $_[0]->_command(bson_doc(drop => $_[0]->name), $_[1]) } 39 | 40 | sub drop_index { 41 | my ($self, $name) = (shift, shift); 42 | return $self->_command(bson_doc(dropIndexes => $self->name, index => $name), 43 | shift); 44 | } 45 | 46 | sub ensure_index { 47 | my ($self, $spec) = (shift, shift); 48 | my $cb = ref $_[-1] eq 'CODE' ? pop : undef; 49 | my $doc = shift // {}; 50 | 51 | $doc->{name} //= $self->build_index_name($spec); 52 | $doc->{key} = $spec; 53 | 54 | # Non-blocking 55 | my $command = bson_doc createIndexes => $self->name, indexes => [$doc]; 56 | return $self->db->command($command => sub { shift; $self->$cb(shift) }) 57 | if $cb; 58 | 59 | # Blocking 60 | $self->db->command($command); 61 | } 62 | 63 | sub find { 64 | Mango::Cursor::Query->new( 65 | collection => shift, 66 | query => shift // {}, 67 | fields => shift // {} 68 | ); 69 | } 70 | 71 | sub find_and_modify { 72 | my ($self, $opts) = (shift, shift); 73 | return $self->_command(bson_doc(findAndModify => $self->name, %$opts), 74 | shift, sub { shift->{value} }); 75 | } 76 | 77 | sub find_one { 78 | my ($self, $query) = (shift, shift); 79 | $query = {_id => $query} if ref $query eq 'Mango::BSON::ObjectID'; 80 | my $cb = ref $_[-1] eq 'CODE' ? pop : undef; 81 | 82 | # Non-blocking 83 | my $cursor = $self->find($query, @_)->limit(-1); 84 | return $cursor->next(sub { shift; $self->$cb(@_) }) if $cb; 85 | 86 | # Blocking 87 | return $cursor->next; 88 | } 89 | 90 | sub full_name { join '.', $_[0]->db->name, $_[0]->name } 91 | 92 | sub index_information { 93 | my ($self, $cb) = @_; 94 | 95 | # Non-blocking 96 | my $collection = $self->db->collection('system.indexes'); 97 | my $cursor = $collection->find({ns => $self->full_name})->fields({ns => 0}); 98 | return $cursor->all(sub { shift; $self->$cb(shift, _indexes(shift)) }) 99 | if $cb; 100 | 101 | # Blocking 102 | return _indexes($cursor->all); 103 | } 104 | 105 | sub insert { 106 | my ($self, $docs) = @_; 107 | $docs = [$docs] unless ref $docs eq 'ARRAY'; 108 | my $cb = ref $_[-1] eq 'CODE' ? pop : undef; 109 | 110 | # Make sure all documents have ids 111 | my @ids = map { $_->{_id} //= bson_oid } @$docs; 112 | my $command = bson_doc 113 | insert => $self->name, 114 | documents => $docs, 115 | ordered => \1, 116 | writeConcern => $self->db->build_write_concern; 117 | 118 | return $self->_command($command, $cb, sub { @ids > 1 ? \@ids : $ids[0] }); 119 | } 120 | 121 | sub map_reduce { 122 | my ($self, $map, $reduce) = (shift, shift, shift); 123 | my $cb = ref $_[-1] eq 'CODE' ? pop : undef; 124 | my $command = bson_doc 125 | mapreduce => $self->name, 126 | map => ref $map ? $map : bson_code($map), 127 | reduce => ref $reduce ? $reduce : bson_code($reduce), 128 | %{shift // {}}; 129 | 130 | # Blocking 131 | return $self->_map_reduce($self->db->command($command)) unless $cb; 132 | 133 | # Non-blocking 134 | return $self->db->command( 135 | $command => sub { shift; $self->$cb(shift, $self->_map_reduce(shift)) }); 136 | } 137 | 138 | sub options { 139 | my ($self, $cb) = @_; 140 | 141 | # Non-blocking 142 | my $query = {name => $self->full_name}; 143 | my $namespaces = $self->db->collection('system.namespaces'); 144 | return $namespaces->find_one($query => sub { shift; $self->$cb(@_) }) if $cb; 145 | 146 | # Blocking 147 | return $namespaces->find_one($query); 148 | } 149 | 150 | sub remove { 151 | my $self = shift; 152 | my $cb = ref $_[-1] eq 'CODE' ? pop : undef; 153 | my $query = shift // {}; 154 | my $flags = shift // {}; 155 | 156 | ($query, $flags) = ({_id => $query}, {single => 1}) 157 | if ref $query eq 'Mango::BSON::ObjectID'; 158 | my $command = bson_doc 159 | delete => $self->name, 160 | deletes => [{q => $query, limit => $flags->{single} ? 1 : 0}], 161 | ordered => \1, 162 | writeConcern => $self->db->build_write_concern; 163 | 164 | return $self->_command($command, $cb); 165 | } 166 | 167 | sub save { 168 | my ($self, $doc, $cb) = @_; 169 | 170 | # New document 171 | return $self->insert($doc, $cb) unless $doc->{_id}; 172 | 173 | # Update non-blocking 174 | my @update = ({_id => $doc->{_id}}, $doc, {upsert => 1}); 175 | return $self->update(@update => sub { shift->$cb(shift, $doc->{_id}) }) 176 | if $cb; 177 | 178 | # Update blocking 179 | $self->update(@update); 180 | return $doc->{_id}; 181 | } 182 | 183 | sub stats { $_[0]->_command(bson_doc(collstats => $_[0]->name), $_[1]) } 184 | 185 | sub update { 186 | my ($self, $query, $update) = (shift, shift, shift); 187 | my $cb = ref $_[-1] eq 'CODE' ? pop : undef; 188 | my $flags = shift // {}; 189 | 190 | $update = { 191 | q => ref $query eq 'Mango::BSON::ObjectID' ? {_id => $query} : $query, 192 | u => $update, 193 | upsert => $flags->{upsert} ? \1 : \0, 194 | multi => $flags->{multi} ? \1 : \0 195 | }; 196 | my $command = bson_doc 197 | update => $self->name, 198 | updates => [$update], 199 | ordered => \1, 200 | writeConcern => $self->db->build_write_concern; 201 | 202 | return $self->_command($command, $cb); 203 | } 204 | 205 | sub _aggregate { 206 | my ($self, $command, $doc) = @_; 207 | 208 | # Document (explain) 209 | return $doc if $command->{explain}; 210 | 211 | # Collection 212 | my $out = $command->{pipeline}[-1]{'$out'}; 213 | return $self->db->collection($out) if defined $out; 214 | 215 | # Cursor 216 | my $cursor = $doc->{cursor}; 217 | return Mango::Cursor->new(collection => $self, id => $cursor->{id}) 218 | ->add_batch($cursor->{firstBatch}); 219 | } 220 | 221 | sub _command { 222 | my ($self, $command, $cb, $return) = @_; 223 | $return ||= sub {shift}; 224 | 225 | # Non-blocking 226 | my $db = $self->db; 227 | my $protocol = $db->mango->protocol; 228 | return $db->command( 229 | $command => sub { 230 | my ($db, $err, $doc) = @_; 231 | $err ||= $protocol->write_error($doc); 232 | $self->$cb($err, $return->($doc)); 233 | } 234 | ) if $cb; 235 | 236 | # Blocking 237 | my $doc = $db->command($command); 238 | if (my $err = $protocol->write_error($doc)) { croak $err } 239 | return $return->($doc); 240 | } 241 | 242 | sub _indexes { 243 | my $indexes = bson_doc; 244 | if (my $docs = shift) { $indexes->{delete $_->{name}} = $_ for @$docs } 245 | return $indexes; 246 | } 247 | 248 | sub _map_reduce { 249 | my ($self, $doc) = @_; 250 | return $doc->{results} unless $doc->{result}; 251 | return $self->db->collection($doc->{result}); 252 | } 253 | 254 | 1; 255 | 256 | =encoding utf8 257 | 258 | =head1 NAME 259 | 260 | Mango::Collection - MongoDB collection 261 | 262 | =head1 SYNOPSIS 263 | 264 | use Mango::Collection; 265 | 266 | my $collection = Mango::Collection->new(db => $db); 267 | my $cursor = $collection->find({foo => 'bar'}); 268 | 269 | =head1 DESCRIPTION 270 | 271 | L is a container for MongoDB collections used by 272 | L. 273 | 274 | =head1 ATTRIBUTES 275 | 276 | L implements the following attributes. 277 | 278 | =head2 db 279 | 280 | my $db = $collection->db; 281 | $collection = $collection->db(Mango::Database->new); 282 | 283 | L object this collection belongs to. 284 | 285 | =head2 name 286 | 287 | my $name = $collection->name; 288 | $collection = $collection->name('bar'); 289 | 290 | Name of this collection. 291 | 292 | =head1 METHODS 293 | 294 | L inherits all methods from L and implements 295 | the following new ones. 296 | 297 | =head2 aggregate 298 | 299 | my $cursor = $collection->aggregate( 300 | [{'$group' => {_id => undef, total => {'$sum' => '$foo'}}}]); 301 | my $collection = $collection->aggregate( 302 | [{'$match' => {'$gt' => 23}}, {'$out' => 'some_collection'}]); 303 | my $doc = $collection->aggregate( 304 | [{'$match' => {'$gt' => 23}}], {explain => bson_true}); 305 | 306 | Aggregate collection with aggregation framework, additional options will be 307 | passed along to the server verbatim. You can also append a callback to perform 308 | operation non-blocking. 309 | 310 | my $pipeline = [{'$group' => {_id => undef, total => {'$sum' => '$foo'}}}]; 311 | $collection->aggregate($pipeline => sub { 312 | my ($collection, $err, $cursor) = @_; 313 | ... 314 | }); 315 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 316 | 317 | =head2 build_index_name 318 | 319 | my $name = $collection->build_index_name(bson_doc(foo => 1, bar => -1)); 320 | my $name = $collection->build_index_name({foo => 1}); 321 | 322 | Build name for index specification, the order of keys matters for compound 323 | indexes. 324 | 325 | =head2 bulk 326 | 327 | my $bulk = $collection->bulk; 328 | 329 | Build L object. 330 | 331 | my $bulk = $collection->bulk; 332 | $bulk->insert({foo => $_}) for 1 .. 10; 333 | $bulk->find({foo => 4})->update_one({'$set' => {bar => 'baz'}}); 334 | $bulk->find({foo => 7})->remove_one; 335 | my $results = $bulk->execute; 336 | 337 | =head2 create 338 | 339 | $collection->create; 340 | $collection->create({capped => bson_true, max => 5, size => 10000}); 341 | 342 | Create collection. You can also append a callback to perform operation 343 | non-blocking. 344 | 345 | $collection->create({capped => bson_true, max => 5, size => 10000} => sub { 346 | my ($collection, $err) = @_; 347 | ... 348 | }); 349 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 350 | 351 | =head2 drop 352 | 353 | $collection->drop; 354 | 355 | Drop collection. You can also append a callback to perform operation 356 | non-blocking. 357 | 358 | $collection->drop(sub { 359 | my ($collection, $err) = @_; 360 | ... 361 | }); 362 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 363 | 364 | =head2 drop_index 365 | 366 | $collection->drop_index('foo'); 367 | 368 | Drop index. You can also append a callback to perform operation non-blocking. 369 | 370 | $collection->drop_index(foo => sub { 371 | my ($collection, $err) = @_; 372 | ... 373 | }); 374 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 375 | 376 | =head2 ensure_index 377 | 378 | $collection->ensure_index(bson_doc(foo => 1, bar => -1)); 379 | $collection->ensure_index({foo => 1}); 380 | $collection->ensure_index({foo => 1}, {unique => bson_true}); 381 | 382 | Make sure an index exists, the order of keys matters for compound indexes, 383 | additional options will be passed along to the server verbatim. You can also 384 | append a callback to perform operation non-blocking. 385 | 386 | $collection->ensure_index(({foo => 1}, {unique => bson_true}) => sub { 387 | my ($collection, $err) = @_; 388 | ... 389 | }); 390 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 391 | 392 | =head2 find 393 | 394 | my $cursor = $collection->find; 395 | my $cursor = $collection->find({foo => 'bar'}); 396 | my $cursor = $collection->find({foo => 'bar'}, {foo => 1}); 397 | 398 | Build L object for query. 399 | 400 | # Exclude "_id" field from results 401 | my $docs = $collection->find({foo => 'bar'}, {_id => 0})->all; 402 | 403 | =head2 find_and_modify 404 | 405 | my $doc = $collection->find_and_modify( 406 | {query => {foo => 'bar'}, update => {'$set' => {foo => 'baz'}}}); 407 | 408 | Update document atomically. You can also append a callback to perform 409 | operation non-blocking. 410 | 411 | my $opts = {query => {foo => 'bar'}, update => {'$set' => {foo => 'baz'}}}; 412 | $collection->find_and_modify($opts => sub { 413 | my ($collection, $err, $doc) = @_; 414 | ... 415 | }); 416 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 417 | 418 | =head2 find_one 419 | 420 | my $doc = $collection->find_one({foo => 'bar'}); 421 | my $doc = $collection->find_one({foo => 'bar'}, {foo => 1}); 422 | my $doc = $collection->find_one($oid, {foo => 1}); 423 | 424 | Find one document. You can also append a callback to perform operation 425 | non-blocking. 426 | 427 | $collection->find_one({foo => 'bar'} => sub { 428 | my ($collection, $err, $doc) = @_; 429 | ... 430 | }); 431 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 432 | 433 | =head2 full_name 434 | 435 | my $name = $collection->full_name; 436 | 437 | Full name of this collection. 438 | 439 | =head2 index_information 440 | 441 | my $info = $collection->index_information; 442 | 443 | Get index information for collection. You can also append a callback to 444 | perform operation non-blocking. 445 | 446 | $collection->index_information(sub { 447 | my ($collection, $err, $info) = @_; 448 | ... 449 | }); 450 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 451 | 452 | =head2 insert 453 | 454 | my $oid = $collection->insert({foo => 'bar'}); 455 | my $oids = $collection->insert([{foo => 'bar'}, {baz => 'yada'}]); 456 | 457 | Insert one or more documents into collection. You can also append a callback 458 | to perform operation non-blocking. 459 | 460 | $collection->insert({foo => 'bar'} => sub { 461 | my ($collection, $err, $oid) = @_; 462 | ... 463 | }); 464 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 465 | 466 | =head2 map_reduce 467 | 468 | my $collection = $collection->map_reduce($map, $reduce, {out => 'foo'}); 469 | my $docs = $collection->map_reduce($map, $reduce, {out => {inline => 1}}); 470 | my $docs = $collection->map_reduce( 471 | bson_code($map), bson_code($reduce), {out => {inline => 1}}); 472 | 473 | Perform map/reduce operation on collection, additional options will be passed 474 | along to the server verbatim. You can also append a callback to perform 475 | operation non-blocking. 476 | 477 | $collection->map_reduce(($map, $reduce, {out => {inline => 1}}) => sub { 478 | my ($collection, $err, $docs) = @_; 479 | ... 480 | } 481 | ); 482 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 483 | 484 | =head2 options 485 | 486 | my $doc = $collection->options; 487 | 488 | Get options for collection. You can also append a callback to perform 489 | operation non-blocking. 490 | 491 | $collection->options(sub { 492 | my ($collection, $err, $doc) = @_; 493 | ... 494 | }); 495 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 496 | 497 | =head2 remove 498 | 499 | my $doc = $collection->remove; 500 | my $doc = $collection->remove($oid); 501 | my $doc = $collection->remove({foo => 'bar'}); 502 | my $doc = $collection->remove({foo => 'bar'}, {single => 1}); 503 | 504 | Remove documents from collection. You can also append a callback to perform 505 | operation non-blocking. 506 | 507 | $collection->remove(({foo => 'bar'}, {single => 1}) => sub { 508 | my ($collection, $err, $doc) = @_; 509 | ... 510 | }); 511 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 512 | 513 | These options are currently available: 514 | 515 | =over 2 516 | 517 | =item single 518 | 519 | single => 1 520 | 521 | Remove only one document. 522 | 523 | =back 524 | 525 | =head2 save 526 | 527 | my $oid = $collection->save({foo => 'bar'}); 528 | 529 | Save document to collection. You can also append a callback to perform 530 | operation non-blocking. 531 | 532 | $collection->save({foo => 'bar'} => sub { 533 | my ($collection, $err, $oid) = @_; 534 | ... 535 | }); 536 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 537 | 538 | =head2 stats 539 | 540 | my $stats = $collection->stats; 541 | 542 | Get collection statistics. You can also append a callback to perform operation 543 | non-blocking. 544 | 545 | $collection->stats(sub { 546 | my ($collection, $err, $stats) = @_; 547 | ... 548 | }); 549 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 550 | 551 | =head2 update 552 | 553 | my $doc = $collection->update($oid, {foo => 'baz'}); 554 | my $doc = $collection->update({foo => 'bar'}, {foo => 'baz'}); 555 | my $doc = $collection->update({foo => 'bar'}, {foo => 'baz'}, {multi => 1}); 556 | 557 | Update document in collection. You can also append a callback to perform 558 | operation non-blocking. 559 | 560 | $collection->update(({foo => 'bar'}, {foo => 'baz'}, {multi => 1}) => sub { 561 | my ($collection, $err, $doc) = @_; 562 | ... 563 | }); 564 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 565 | 566 | These options are currently available: 567 | 568 | =over 2 569 | 570 | =item multi 571 | 572 | multi => 1 573 | 574 | Update more than one document. 575 | 576 | =item upsert 577 | 578 | upsert => 1 579 | 580 | Insert document if none could be updated. 581 | 582 | =back 583 | 584 | =head1 SEE ALSO 585 | 586 | L, L, L. 587 | 588 | =cut 589 | -------------------------------------------------------------------------------- /lib/Mango/Cursor.pm: -------------------------------------------------------------------------------- 1 | package Mango::Cursor; 2 | use Mojo::Base -base; 3 | 4 | use Mojo::IOLoop; 5 | 6 | has [qw(collection id)]; 7 | has [qw(batch_size limit)] => 0; 8 | 9 | sub add_batch { 10 | my ($self, $docs) = @_; 11 | push @{$self->{results} ||= []}, @$docs; 12 | return $self; 13 | } 14 | 15 | sub all { 16 | my ($self, $cb) = @_; 17 | 18 | # Non-blocking 19 | my @all; 20 | return $self->next(sub { shift->_collect(\@all, $cb, @_) }) if $cb; 21 | 22 | # Blocking 23 | while (my $next = $self->next) { push @all, $next } 24 | return \@all; 25 | } 26 | 27 | sub next { 28 | my ($self, $cb) = @_; 29 | return defined $self->id ? $self->_continue($cb) : $self->_start($cb); 30 | } 31 | 32 | sub num_to_return { 33 | my $self = shift; 34 | my $limit = $self->limit; 35 | my $size = $self->batch_size; 36 | return $limit == 0 || ($size > 0 && $size < $limit) ? $size : $limit; 37 | } 38 | 39 | sub rewind { 40 | my ($self, $cb) = @_; 41 | 42 | delete @$self{qw(num results)}; 43 | return $cb ? $self->_defer($cb) : undef unless defined(my $id = $self->id); 44 | $self->id(undef); 45 | 46 | # Non-blocking 47 | my $mango = $self->collection->db->mango; 48 | return $mango->kill_cursors($id => sub { shift; $self->$cb(@_) }) if $cb; 49 | 50 | # Blocking 51 | $mango->kill_cursors($id); 52 | } 53 | 54 | sub _collect { 55 | my ($self, $all, $cb, $err, $doc) = @_; 56 | return $self->_defer($cb, $err, $all) if $err || !$doc; 57 | push @$all, $doc; 58 | $self->next(sub { shift->_collect($all, $cb, @_) }); 59 | } 60 | 61 | sub _continue { 62 | my ($self, $cb) = @_; 63 | 64 | my $collection = $self->collection; 65 | my $name = $collection->full_name; 66 | my $mango = $collection->db->mango; 67 | 68 | # Non-blocking 69 | if ($cb) { 70 | return $self->_defer($cb, undef, $self->_dequeue) if $self->_enough; 71 | return $mango->get_more(($name, $self->num_to_return, $self->id) => 72 | sub { shift; $self->$cb(shift, $self->_enqueue(shift)) }); 73 | } 74 | 75 | # Blocking 76 | return $self->_dequeue if $self->_enough; 77 | return $self->_enqueue( 78 | $mango->get_more($name, $self->num_to_return, $self->id)); 79 | } 80 | 81 | sub _defer { 82 | my ($self, $cb, @args) = @_; 83 | Mojo::IOLoop->next_tick(sub { $self->$cb(@args) }); 84 | } 85 | 86 | sub _dequeue { 87 | my $self = shift; 88 | return undef if $self->_finished; 89 | $self->{num}++; 90 | return shift @{$self->{results}}; 91 | } 92 | 93 | sub _enough { 94 | my $self = shift; 95 | return $self->id eq '0' || $self->_finished || !!@{$self->{results} // []}; 96 | } 97 | 98 | sub _enqueue { 99 | my ($self, $reply) = @_; 100 | return undef unless $reply; 101 | return $self->add_batch($reply->{docs})->id($reply->{cursor})->_dequeue; 102 | } 103 | 104 | sub _finished { 105 | my $self = shift; 106 | return undef unless my $limit = $self->limit; 107 | return ($self->{num} // 0) >= abs($limit) ? 1 : undef; 108 | } 109 | 110 | sub _start { die 'Cursor cannot be restarted' } 111 | 112 | 1; 113 | 114 | =encoding utf8 115 | 116 | =head1 NAME 117 | 118 | Mango::Cursor - MongoDB cursor 119 | 120 | =head1 SYNOPSIS 121 | 122 | use Mango::Cursor; 123 | 124 | my $cursor = Mango::Cursor->new(collection => $collection); 125 | my $docs = $cursor->all; 126 | 127 | =head1 DESCRIPTION 128 | 129 | L is a container for MongoDB cursors used by 130 | L. 131 | 132 | =head1 ATTRIBUTES 133 | 134 | L implements the following attributes. 135 | 136 | =head2 batch_size 137 | 138 | my $size = $cursor->batch_size; 139 | $cursor = $cursor->batch_size(10); 140 | 141 | Number of documents to fetch in one batch, defaults to C<0>. 142 | 143 | =head2 collection 144 | 145 | my $collection = $cursor->collection; 146 | $cursor = $cursor->collection(Mango::Collection->new); 147 | 148 | L object this cursor belongs to. 149 | 150 | =head2 id 151 | 152 | my $id = $cursor->id; 153 | $cursor = $cursor->id(123456); 154 | 155 | Cursor id. 156 | 157 | =head2 limit 158 | 159 | my $limit = $cursor->limit; 160 | $cursor = $cursor->limit(10); 161 | 162 | Limit the number of documents, defaults to C<0>. 163 | 164 | =head1 METHODS 165 | 166 | L inherits all methods from L and implements the 167 | following new ones. 168 | 169 | =head2 add_batch 170 | 171 | $cursor = $cursor->add_batch($docs); 172 | 173 | Add batch of documents to cursor. 174 | 175 | =head2 all 176 | 177 | my $docs = $cursor->all; 178 | 179 | Fetch all documents at once. You can also append a callback to perform 180 | operation non-blocking. 181 | 182 | $cursor->all(sub { 183 | my ($cursor, $err, $docs) = @_; 184 | ... 185 | }); 186 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 187 | 188 | =head2 next 189 | 190 | my $doc = $cursor->next; 191 | 192 | Fetch next document. You can also append a callback to perform operation 193 | non-blocking. 194 | 195 | $cursor->next(sub { 196 | my ($cursor, $err, $doc) = @_; 197 | ... 198 | }); 199 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 200 | 201 | =head2 rewind 202 | 203 | $cursor->rewind; 204 | 205 | Rewind cursor and kill it on the server. You can also append a callback to 206 | perform operation non-blocking. 207 | 208 | $cursor->rewind(sub { 209 | my ($cursor, $err) = @_; 210 | ... 211 | }); 212 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 213 | 214 | =head2 num_to_return 215 | 216 | my $num = $cursor->num_to_return; 217 | 218 | Number of results to return with next C or C operation based 219 | on L and L. 220 | 221 | =head1 SEE ALSO 222 | 223 | L, L, L. 224 | 225 | =cut 226 | -------------------------------------------------------------------------------- /lib/Mango/Cursor/Query.pm: -------------------------------------------------------------------------------- 1 | package Mango::Cursor::Query; 2 | use Mojo::Base 'Mango::Cursor'; 3 | 4 | use Mango::BSON 'bson_doc'; 5 | 6 | has [ 7 | qw(await_data comment hint max_scan max_time_ms read_preference snapshot), 8 | qw(sort tailable) 9 | ]; 10 | has [qw(fields query)] => sub { {} }; 11 | has skip => 0; 12 | 13 | sub build_query { 14 | my ($self, $explain) = @_; 15 | 16 | my %ext; 17 | if (my $comment = $self->comment) { $ext{'$comment'} = $comment } 18 | if ($explain) { $ext{'$explain'} = 1 } 19 | if (my $hint = $self->hint) { $ext{'$hint'} = $hint } 20 | if (my $max_scan = $self->max_scan) { $ext{'$maxScan'} = $max_scan } 21 | if (my $max = $self->max_time_ms) { $ext{'$maxTimeMS'} = $max } 22 | if (my $pref = $self->read_preference) { $ext{'$readPreference'} = $pref } 23 | if (my $snapshot = $self->snapshot) { $ext{'$snapshot'} = 1 } 24 | if (my $sort = $self->sort) { $ext{'$orderby'} = $sort } 25 | 26 | my $query = $self->query; 27 | return $query unless keys %ext; 28 | return bson_doc $query->{'$query'} ? %$query : ('$query' => $query), %ext; 29 | } 30 | 31 | sub clone { 32 | my $self = shift; 33 | my $clone = $self->new; 34 | $clone->$_($self->$_) for qw(await_data batch_size collection comment); 35 | $clone->$_($self->$_) for qw(fields hint limit max_scan max_time_ms query); 36 | $clone->$_($self->$_) for qw(read_preference skip snapshot sort tailable); 37 | return $clone; 38 | } 39 | 40 | sub count { 41 | my $self = shift; 42 | my $cb = ref $_[-1] eq 'CODE' ? pop : undef; 43 | 44 | my $collection = $self->collection; 45 | my $command = bson_doc 46 | count => $collection->name, 47 | query => $self->build_query, 48 | skip => $self->skip, 49 | limit => $self->limit; 50 | 51 | # Non-blocking 52 | return $collection->db->command( 53 | $command => sub { 54 | my ($collection, $err, $doc) = @_; 55 | $self->$cb($err, $doc ? $doc->{n} : 0); 56 | } 57 | ) if $cb; 58 | 59 | # Blocking 60 | my $doc = $collection->db->command($command); 61 | return $doc ? $doc->{n} : 0; 62 | } 63 | 64 | sub distinct { 65 | my ($self, $key) = (shift, shift); 66 | my $cb = ref $_[-1] eq 'CODE' ? pop : undef; 67 | 68 | my $collection = $self->collection; 69 | my $command = bson_doc 70 | distinct => $collection->name, 71 | key => $key, 72 | query => $self->build_query; 73 | 74 | # Blocking 75 | my $db = $collection->db; 76 | return $db->command($command)->{values} unless $cb; 77 | 78 | # Non-blocking 79 | $db->command($command => sub { shift; $self->$cb(shift, shift->{values}) }); 80 | } 81 | 82 | sub explain { 83 | my ($self, $cb) = @_; 84 | 85 | # Non-blocking 86 | my $clone = $self->clone->query($self->build_query(1))->sort(undef); 87 | return $clone->next(sub { shift; $self->$cb(@_) }) if $cb; 88 | 89 | # Blocking 90 | return $clone->next; 91 | } 92 | 93 | sub _start { 94 | my ($self, $cb) = @_; 95 | 96 | my $collection = $self->collection; 97 | my $name = $collection->full_name; 98 | my $flags = {}; 99 | $flags->{tailable_cursor} = 1 if $self->tailable; 100 | $flags->{await_data} = 1 if $self->await_data; 101 | my @query = ( 102 | $name, $flags, $self->skip, $self->num_to_return, $self->build_query, 103 | $self->fields 104 | ); 105 | 106 | # Non-blocking 107 | return $collection->db->mango->query( 108 | @query => sub { shift; $self->$cb(shift, $self->_enqueue(shift)) }) 109 | if $cb; 110 | 111 | # Blocking 112 | return $self->_enqueue($collection->db->mango->query(@query)); 113 | } 114 | 115 | 1; 116 | 117 | =encoding utf8 118 | 119 | =head1 NAME 120 | 121 | Mango::Cursor::Query - MongoDB query cursor 122 | 123 | =head1 SYNOPSIS 124 | 125 | use Mango::Cursor::Query; 126 | 127 | my $cursor = Mango::Cursor::Query->new(collection => $collection); 128 | my $docs = $cursor->all; 129 | 130 | =head1 DESCRIPTION 131 | 132 | L is a container for MongoDB query cursors used by 133 | L. 134 | 135 | =head1 ATTRIBUTES 136 | 137 | L inherits all attributes from L and 138 | implements the following new ones. 139 | 140 | =head2 await_data 141 | 142 | my $await = $cursor->await_data; 143 | $cursor = $cursor->await_data(1); 144 | 145 | Await data. 146 | 147 | =head2 comment 148 | 149 | my $comment = $cursor->comment; 150 | $cursor = $cursor->comment('Fun query!'); 151 | 152 | A comment to identify query. 153 | 154 | =head2 fields 155 | 156 | my $fields = $cursor->fields; 157 | $cursor = $cursor->fields({foo => 1}); 158 | 159 | Select fields from documents. 160 | 161 | =head2 hint 162 | 163 | my $hint = $cursor->hint; 164 | $cursor = $cursor->hint({foo => 1}); 165 | 166 | Force a specific index to be used. 167 | 168 | =head2 max_scan 169 | 170 | my $max = $cursor->max_scan; 171 | $cursor = $cursor->max_scan(500); 172 | 173 | Limit the number of documents to scan. 174 | 175 | =head2 max_time_ms 176 | 177 | my $max = $cursor->max_time_ms; 178 | $cursor = $cursor->max_time_ms(500); 179 | 180 | Timeout for query in milliseconds. 181 | 182 | =head2 query 183 | 184 | my $query = $cursor->query; 185 | $cursor = $cursor->query({foo => 'bar'}); 186 | 187 | Original query. 188 | 189 | =head2 read_preference 190 | 191 | my $pref = $cursor->read_preference; 192 | $cursor = $cursor->read_preference({mode => 'SECONDARY'}); 193 | 194 | Read preference. 195 | 196 | =head2 skip 197 | 198 | my $skip = $cursor->skip; 199 | $cursor = $cursor->skip(5); 200 | 201 | Number of documents to skip, defaults to C<0>. 202 | 203 | =head2 snapshot 204 | 205 | my $snapshot = $cursor->snapshot; 206 | $cursor = $cursor->snapshot(1); 207 | 208 | Use snapshot mode. 209 | 210 | =head2 sort 211 | 212 | my $sort = $cursor->sort; 213 | $cursor = $cursor->sort({foo => 1}); 214 | $cursor = $cursor->sort(bson_doc(foo => 1, bar => -1)); 215 | 216 | Sort documents, the order of keys matters. 217 | 218 | =head2 tailable 219 | 220 | my $tailable = $cursor->tailable; 221 | $cursor = $cursor->tailable(1); 222 | 223 | Tailable cursor. 224 | 225 | =head1 METHODS 226 | 227 | L inherits all methods from L and 228 | implements the following new ones. 229 | 230 | =head2 build_query 231 | 232 | my $query = $cursor->build_query; 233 | my $query = $cursor->build_query($explain); 234 | 235 | Generate final query with cursor attributes. 236 | 237 | =head2 clone 238 | 239 | my $clone = $cursor->clone; 240 | 241 | Clone cursor. 242 | 243 | =head2 count 244 | 245 | my $count = $cursor->count; 246 | 247 | Count number of documents this cursor can return. You can also append a 248 | callback to perform operation non-blocking. 249 | 250 | $cursor->count(sub { 251 | my ($cursor, $err, $count) = @_; 252 | ... 253 | }); 254 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 255 | 256 | =head2 distinct 257 | 258 | my $values = $cursor->distinct('foo'); 259 | 260 | Get all distinct values for key. You can also append a callback to perform 261 | operation non-blocking. 262 | 263 | $cursor->distinct(foo => sub { 264 | my ($cursor, $err, $values) = @_; 265 | ... 266 | }); 267 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 268 | 269 | =head2 explain 270 | 271 | my $doc = $cursor->explain; 272 | 273 | Provide information on the query plan. You can also append a callback to 274 | perform operation non-blocking. 275 | 276 | $cursor->explain(sub { 277 | my ($cursor, $err, $doc) = @_; 278 | ... 279 | }); 280 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 281 | 282 | =head1 SEE ALSO 283 | 284 | L, L, L. 285 | 286 | =cut 287 | -------------------------------------------------------------------------------- /lib/Mango/Database.pm: -------------------------------------------------------------------------------- 1 | package Mango::Database; 2 | use Mojo::Base -base; 3 | 4 | use Carp 'croak'; 5 | use Mango::BSON qw(bson_code bson_doc); 6 | use Mango::Collection; 7 | use Mango::GridFS; 8 | 9 | has [qw(mango name)]; 10 | 11 | sub build_write_concern { 12 | my $mango = shift->mango; 13 | return { 14 | j => $mango->j ? \1 : \0, 15 | w => $mango->w, 16 | wtimeout => $mango->wtimeout 17 | }; 18 | } 19 | 20 | sub collection { 21 | my ($self, $name) = @_; 22 | return Mango::Collection->new(db => $self, name => $name); 23 | } 24 | 25 | sub collection_names { 26 | my ($self, $cb) = @_; 27 | 28 | my $len = length $self->name; 29 | my $collection = $self->collection('system.namespaces'); 30 | 31 | # Non-blocking 32 | return $collection->find->all( 33 | sub { 34 | my ($cursor, $err, $docs) = @_; 35 | $self->$cb($err, [map { substr $_->{name}, $len + 1 } @$docs]); 36 | } 37 | ) if $cb; 38 | 39 | # Blocking 40 | my $docs = $collection->find->all; 41 | return [map { substr $_->{name}, $len + 1 } @$docs]; 42 | } 43 | 44 | sub command { 45 | my ($self, $command) = (shift, shift); 46 | my $cb = ref $_[-1] eq 'CODE' ? pop : undef; 47 | $command = ref $command ? $command : bson_doc($command => 1, @_); 48 | 49 | # Non-blocking 50 | my $mango = $self->mango; 51 | my $name = $self->name; 52 | my $protocol = $mango->protocol; 53 | return $mango->query( 54 | ("$name.\$cmd", {}, 0, -1, $command, {}) => sub { 55 | my ($collection, $err, $reply) = @_; 56 | my $doc = $reply->{docs}[0]; 57 | $err ||= $protocol->command_error($doc); 58 | $self->$cb($err, $doc); 59 | } 60 | ) if $cb; 61 | 62 | # Blocking 63 | my $doc = $mango->query("$name.\$cmd", {}, 0, -1, $command, {})->{docs}[0]; 64 | if (my $err = $protocol->command_error($doc)) { croak $err } 65 | return $doc; 66 | } 67 | 68 | sub dereference { 69 | my ($self, $dbref, $cb) = @_; 70 | 71 | # Non-blocking 72 | my $collection = $self->collection($dbref->{'$ref'}); 73 | return $collection->find_one($dbref->{'$id'} => sub { shift; $self->$cb(@_) } 74 | ) if $cb; 75 | 76 | # Blocking 77 | return $collection->find_one($dbref->{'$id'}); 78 | } 79 | 80 | sub gridfs { Mango::GridFS->new(db => shift) } 81 | 82 | sub stats { shift->command(bson_doc(dbstats => 1), @_) } 83 | 84 | 1; 85 | 86 | =encoding utf8 87 | 88 | =head1 NAME 89 | 90 | Mango::Database - MongoDB database 91 | 92 | =head1 SYNOPSIS 93 | 94 | use Mango::Database; 95 | 96 | my $db = Mango::Database->new(mango => $mango); 97 | my $collection = $db->collection('foo'); 98 | my $gridfs = $db->gridfs; 99 | 100 | =head1 DESCRIPTION 101 | 102 | L is a container for MongoDB databases used by L. 103 | 104 | =head1 ATTRIBUTES 105 | 106 | L implements the following attributes. 107 | 108 | =head2 mango 109 | 110 | my $mango = $db->mango; 111 | $db = $db->mango(Mango->new); 112 | 113 | L object this database belongs to. Note that this reference is usually 114 | weakened, so the L object needs to be referenced elsewhere as well. 115 | 116 | =head2 name 117 | 118 | my $name = $db->name; 119 | $db = $db->name('bar'); 120 | 121 | Name of this database. 122 | 123 | =head1 METHODS 124 | 125 | L inherits all methods from L and implements the 126 | following new ones. 127 | 128 | =head2 build_write_concern 129 | 130 | my $concern = $db->build_write_concern; 131 | 132 | Build write concern based on l settings. 133 | 134 | =head2 collection 135 | 136 | my $collection = $db->collection('foo'); 137 | 138 | Build L object for collection. 139 | 140 | =head2 collection_names 141 | 142 | my $names = $db->collection_names; 143 | 144 | Names of all collections in this database. You can also append a callback to 145 | perform operation non-blocking. 146 | 147 | $db->collection_names(sub { 148 | my ($db, $err, $names) = @_; 149 | ... 150 | }); 151 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 152 | 153 | =head2 command 154 | 155 | my $doc = $db->command(bson_doc(text => 'foo.bar', search => 'test')); 156 | my $doc = $db->command(bson_doc(getLastError => 1, w => 2)); 157 | my $doc = $db->command('getLastError', w => 2); 158 | 159 | Run command against database. You can also append a callback to run command 160 | non-blocking. 161 | 162 | $db->command(('getLastError', w => 2) => sub { 163 | my ($db, $err, $doc) = @_; 164 | ... 165 | }); 166 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 167 | 168 | =head2 dereference 169 | 170 | my $doc = $db->dereference($dbref); 171 | 172 | Resolve database reference. You can also append a callback to perform 173 | operation non-blocking. 174 | 175 | $db->dereference($dbref => sub { 176 | my ($db, $err, $doc) = @_; 177 | ... 178 | }); 179 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 180 | 181 | =head2 gridfs 182 | 183 | my $gridfs = $db->gridfs; 184 | 185 | Build L object. 186 | 187 | =head2 stats 188 | 189 | my $stats = $db->stats; 190 | 191 | Get database statistics. You can also append a callback to perform operation 192 | non-blocking. 193 | 194 | $db->stats(sub { 195 | my ($db, $err, $stats) = @_; 196 | ... 197 | }); 198 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 199 | 200 | =head1 SEE ALSO 201 | 202 | L, L, L. 203 | 204 | =cut 205 | -------------------------------------------------------------------------------- /lib/Mango/GridFS.pm: -------------------------------------------------------------------------------- 1 | package Mango::GridFS; 2 | use Mojo::Base -base; 3 | 4 | use Mango::GridFS::Reader; 5 | use Mango::GridFS::Writer; 6 | 7 | has chunks => sub { $_[0]->db->collection($_[0]->prefix . '.chunks') }; 8 | has 'db'; 9 | has files => sub { $_[0]->db->collection($_[0]->prefix . '.files') }; 10 | has prefix => 'fs'; 11 | 12 | sub delete { 13 | my ($self, $oid, $cb) = @_; 14 | 15 | # Non-blocking 16 | return Mojo::IOLoop->delay( 17 | sub { 18 | my $delay = shift; 19 | $self->files->remove({_id => $oid} => $delay->begin); 20 | $self->chunks->remove({files_id => $oid} => $delay->begin); 21 | }, 22 | sub { $self->$cb($_[1] || $_[3]) } 23 | ) if $cb; 24 | 25 | # Blocking 26 | $self->files->remove({_id => $oid}); 27 | $self->chunks->remove({files_id => $oid}); 28 | } 29 | 30 | sub find_version { 31 | my ($self, $name, $version, $cb) = @_; 32 | 33 | # Positive numbers are absolute and negative ones relative 34 | my $cursor = $self->files->find({filename => $name}, {_id => 1})->limit(-1); 35 | $cursor->sort({uploadDate => $version < 0 ? -1 : 1}) 36 | ->skip($version < 0 ? abs($version) - 1 : $version); 37 | 38 | # Non-blocking 39 | return $cursor->next( 40 | sub { shift; $self->$cb(shift, $_[0] ? $_[0]{_id} : undef) }) 41 | if $cb; 42 | 43 | # Blocking 44 | my $doc = $cursor->next; 45 | return $doc ? $doc->{_id} : undef; 46 | } 47 | 48 | sub list { 49 | my ($self, $cb) = @_; 50 | 51 | # Blocking 52 | return $self->files->find->distinct('filename') unless $cb; 53 | 54 | # Non-blocking 55 | $self->files->find->distinct('filename' => sub { shift; $self->$cb(@_) }); 56 | } 57 | 58 | sub reader { Mango::GridFS::Reader->new(gridfs => shift) } 59 | sub writer { Mango::GridFS::Writer->new(gridfs => shift) } 60 | 61 | 1; 62 | 63 | =encoding utf8 64 | 65 | =head1 NAME 66 | 67 | Mango::GridFS - GridFS 68 | 69 | =head1 SYNOPSIS 70 | 71 | use Mango::GridFS; 72 | 73 | my $gridfs = Mango::GridFS->new(db => $db); 74 | my $reader = $gridfs->reader; 75 | my $writer = $gridfs->writer; 76 | 77 | =head1 DESCRIPTION 78 | 79 | L is an interface for MongoDB GridFS access. 80 | 81 | =head1 ATTRIBUTES 82 | 83 | L implements the following attributes. 84 | 85 | =head2 chunks 86 | 87 | my $chunks = $gridfs->chunks; 88 | $gridfs = $gridfs->chunks(Mango::Collection->new); 89 | 90 | L object for C collection, defaults to one based on 91 | L. 92 | 93 | =head2 db 94 | 95 | my $db = $gridfs->db; 96 | $gridfs = $gridfs->db(Mango::Database->new); 97 | 98 | L object GridFS belongs to. 99 | 100 | =head2 files 101 | 102 | my $files = $gridfs->files; 103 | $gridfs = $gridfs->files(Mango::Collection->new); 104 | 105 | L object for C collection, defaults to one based on 106 | L. 107 | 108 | =head2 prefix 109 | 110 | my $prefix = $gridfs->prefix; 111 | $gridfs = $gridfs->prefix('foo'); 112 | 113 | Prefix for GridFS collections, defaults to C. 114 | 115 | =head1 METHODS 116 | 117 | L inherits all methods from L and implements the 118 | following new ones. 119 | 120 | =head2 delete 121 | 122 | $gridfs->delete($oid); 123 | 124 | Delete file. You can also append a callback to perform operation non-blocking. 125 | 126 | $gridfs->delete($oid => sub { 127 | my ($gridfs, $err) = @_; 128 | ... 129 | }); 130 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 131 | 132 | =head2 find_version 133 | 134 | my $oid = $gridfs->find_version('test.txt', 1); 135 | 136 | Find versions of files, positive numbers from C<0> and upwards always point to 137 | a specific version, negative ones start with C<-1> for the most recently added 138 | version. You can also append a callback to perform operation non-blocking. 139 | 140 | $gridfs->find_version(('test.txt', 1) => sub { 141 | my ($gridfs, $err, $oid) = @_; 142 | ... 143 | }); 144 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 145 | 146 | =head2 list 147 | 148 | my $names = $gridfs->list; 149 | 150 | List files. You can also append a callback to perform operation non-blocking. 151 | 152 | $gridfs->list(sub { 153 | my ($gridfs, $err, $names) = @_; 154 | ... 155 | }); 156 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 157 | 158 | =head2 reader 159 | 160 | my $reader = $gridfs->reader; 161 | 162 | Build L object. 163 | 164 | # Read all data at once from newest version of file 165 | my $oid = $gridfs->find_version('test.txt', -1); 166 | my $data = $gridfs->reader->open($oid)->slurp; 167 | 168 | # Read all data in chunks from file 169 | my $reader = $gridfs->reader->open($oid); 170 | while (defined(my $chunk = $reader->read)) { say "Chunk: $chunk" } 171 | 172 | =head2 writer 173 | 174 | my $writer = $gridfs->writer; 175 | 176 | Build L object. 177 | 178 | # Write all data at once to file with name 179 | my $oid = $gridfs->writer->filename('test.txt')->write('Hello!')->close; 180 | 181 | # Write data in chunks to file 182 | my $writer = $gridfs->writer; 183 | $writer->write($_) for 1 .. 100; 184 | my $oid = $writer->close; 185 | 186 | =head1 SEE ALSO 187 | 188 | L, L, L. 189 | 190 | =cut 191 | -------------------------------------------------------------------------------- /lib/Mango/GridFS/Reader.pm: -------------------------------------------------------------------------------- 1 | package Mango::GridFS::Reader; 2 | use Mojo::Base -base; 3 | 4 | use Carp 'croak'; 5 | 6 | has 'gridfs'; 7 | 8 | sub chunk_size { shift->{meta}{chunkSize} } 9 | sub content_type { shift->{meta}{contentType} } 10 | sub filename { shift->{meta}{filename} } 11 | sub md5 { shift->{meta}{md5} } 12 | sub metadata { shift->{meta}{metadata} } 13 | 14 | sub open { 15 | my ($self, $oid, $cb) = @_; 16 | 17 | # Non-blocking 18 | return $self->gridfs->files->find_one( 19 | $oid => sub { 20 | my ($collection, $err, $doc) = @_; 21 | $err //= "$oid does not exist" unless $self->{meta} = $doc; 22 | $self->$cb($err); 23 | } 24 | ) if $cb; 25 | 26 | # Blocking 27 | croak "$oid does not exist" 28 | unless $self->{meta} = $self->gridfs->files->find_one($oid); 29 | return $self; 30 | } 31 | 32 | sub read { 33 | my ($self, $cb) = @_; 34 | 35 | $self->{pos} //= 0; 36 | 37 | # EOF 38 | if ($self->{pos} >= ($self->size // 0)) { 39 | return undef unless $cb; 40 | return Mojo::IOLoop->next_tick(sub { $self->$cb(undef, undef) }); 41 | } 42 | 43 | # Blocking 44 | my $n = int($self->{pos} / $self->chunk_size); 45 | my $query = {files_id => $self->{meta}{_id}, n => $n}; 46 | my $fields = {_id => 0, data => 1}; 47 | return $self->_slice($n, 48 | $self->gridfs->chunks->find_one($query, $fields)->{data}) 49 | unless $cb; 50 | 51 | # Non-blocking 52 | $self->gridfs->chunks->find_one( 53 | ($query, $fields) => sub { 54 | my ($collection, $err, $doc) = @_; 55 | $self->$cb($err, $self->_slice($n, $doc->{data})); 56 | } 57 | ); 58 | } 59 | 60 | sub seek { 61 | my ($self, $pos) = @_; 62 | $self->{pos} = $pos; 63 | return $self; 64 | } 65 | 66 | sub slurp { 67 | my ($self, $cb) = @_; 68 | 69 | # Blocking 70 | my $data; 71 | unless ($cb) { 72 | while (defined(my $chunk = $self->read)) { $data .= $chunk } 73 | return $data; 74 | } 75 | 76 | # Non-blocking 77 | $self->_chunk(\$data, $cb); 78 | } 79 | 80 | sub size { shift->{meta}{length} } 81 | 82 | sub tell { shift->{pos} // 0 } 83 | 84 | sub upload_date { shift->{meta}{uploadDate} } 85 | 86 | sub _chunk { 87 | my ($self, $dataref, $cb) = @_; 88 | 89 | $self->read( 90 | sub { 91 | my ($self, $err, $chunk) = @_; 92 | return $self->$cb($err, $$dataref) if $err || !defined $chunk; 93 | $$dataref .= $chunk; 94 | $self->_chunk($dataref, $cb); 95 | } 96 | ); 97 | } 98 | 99 | sub _slice { 100 | my ($self, $n, $chunk) = @_; 101 | my $offset = $self->{pos} - ($n * $self->chunk_size); 102 | $self->{pos} += length $chunk; 103 | return substr $chunk, $offset; 104 | } 105 | 106 | 1; 107 | 108 | =encoding utf8 109 | 110 | =head1 NAME 111 | 112 | Mango::GridFS::Reader - GridFS reader 113 | 114 | =head1 SYNOPSIS 115 | 116 | use Mango::GridFS::Reader; 117 | 118 | my $reader = Mango::GridFS::Reader->new(gridfs => $gridfs); 119 | 120 | =head1 DESCRIPTION 121 | 122 | L reads files from GridFS. 123 | 124 | =head1 ATTRIBUTES 125 | 126 | L implements the following attributes. 127 | 128 | =head2 gridfs 129 | 130 | my $gridfs = $reader->gridfs; 131 | $reader = $reader->gridfs(Mango::GridFS->new); 132 | 133 | L object this reader belongs to. 134 | 135 | =head1 METHODS 136 | 137 | L inherits all methods from L and 138 | implements the following new ones. 139 | 140 | =head2 chunk_size 141 | 142 | my $size = $reader->chunk_size; 143 | 144 | Chunk size in bytes. 145 | 146 | =head2 content_type 147 | 148 | my $type = $reader->content_type; 149 | 150 | Content type of file. 151 | 152 | =head2 filename 153 | 154 | my $name = $reader->filename; 155 | 156 | Name of file. 157 | 158 | =head2 md5 159 | 160 | my $checksum = $reader->md5; 161 | 162 | MD5 checksum for file. 163 | 164 | =head2 metadata 165 | 166 | my $data = $reader->metadata; 167 | 168 | Additional information. 169 | 170 | =head2 open 171 | 172 | $reader = $reader->open($oid); 173 | 174 | Open file. You can also append a callback to perform operation non-blocking. 175 | 176 | $reader->open($oid => sub { 177 | my ($reader, $err) = @_; 178 | ... 179 | }); 180 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 181 | 182 | =head2 read 183 | 184 | my $chunk = $reader->read; 185 | 186 | Read chunk. You can also append a callback to perform operation non-blocking. 187 | 188 | $reader->read(sub { 189 | my ($reader, $err, $chunk) = @_; 190 | ... 191 | }); 192 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 193 | 194 | =head2 seek 195 | 196 | $reader = $reader->seek(13); 197 | 198 | Change current position. 199 | 200 | =head2 size 201 | 202 | my $size = $reader->size; 203 | 204 | Size of entire file in bytes. 205 | 206 | =head2 slurp 207 | 208 | my $data = $reader->slurp; 209 | 210 | Slurp all remaining data from file. You can also append a callback to perform 211 | operation non-blocking. 212 | 213 | $reader->slurp(sub { 214 | my ($reader, $err, $data) = @_; 215 | ... 216 | }); 217 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 218 | 219 | =head2 tell 220 | 221 | my $pos = $reader->tell; 222 | 223 | Current position. 224 | 225 | =head2 upload_date 226 | 227 | my $time = $reader->upload_date; 228 | 229 | Date file was uploaded. 230 | 231 | =head1 SEE ALSO 232 | 233 | L, L, L. 234 | 235 | =cut 236 | -------------------------------------------------------------------------------- /lib/Mango/GridFS/Writer.pm: -------------------------------------------------------------------------------- 1 | package Mango::GridFS::Writer; 2 | use Mojo::Base -base; 3 | 4 | use Carp 'croak'; 5 | use List::Util 'first'; 6 | use Mango::BSON qw(bson_bin bson_doc bson_oid bson_time); 7 | use Mojo::IOLoop; 8 | 9 | has chunk_size => 261120; 10 | has [qw(content_type filename gridfs metadata)]; 11 | 12 | sub close { 13 | my ($self, $cb) = @_; 14 | 15 | # Already closed 16 | if ($self->{closed}++) { 17 | my $files_id = $self->_files_id; 18 | return $files_id unless $cb; 19 | return Mojo::IOLoop->next_tick(sub { $self->$cb(undef, $files_id) }); 20 | } 21 | 22 | my @index = (bson_doc(files_id => 1, n => 1), {unique => \1}); 23 | my $gridfs = $self->gridfs; 24 | my $command = bson_doc filemd5 => $self->_files_id, root => $gridfs->prefix; 25 | 26 | # Non-blocking 27 | my $chunks = $gridfs->chunks; 28 | my $bulk = $chunks->bulk; 29 | my $files = $gridfs->files; 30 | return Mojo::IOLoop->delay( 31 | sub { $self->_chunk($bulk)->execute(shift->begin) }, 32 | sub { 33 | my ($delay, $err) = @_; 34 | return $delay->pass($err) if $err; 35 | $files->ensure_index({filename => 1} => $delay->begin); 36 | $chunks->ensure_index(@index => $delay->begin); 37 | }, 38 | sub { 39 | my ($delay, $files_err, $chunks_err) = @_; 40 | if (my $err = $files_err || $chunks_err) { return $delay->pass($err) } 41 | $gridfs->db->command($command => $delay->begin); 42 | }, 43 | sub { 44 | my ($delay, $err, $doc) = @_; 45 | return $delay->pass($err) if $err; 46 | $files->insert($self->_meta($doc->{md5}) => $delay->begin); 47 | }, 48 | sub { shift; $self->$cb(shift, $self->_files_id) } 49 | ) if $cb; 50 | 51 | # Blocking 52 | $self->_chunk($bulk)->execute; 53 | $files->ensure_index({filename => 1}); 54 | $chunks->ensure_index(@index); 55 | my $md5 = $gridfs->db->command($command)->{md5}; 56 | $files->insert($self->_meta($md5)); 57 | return $self->_files_id; 58 | } 59 | 60 | sub is_closed { !!shift->{closed} } 61 | 62 | sub write { 63 | my ($self, $chunk, $cb) = @_; 64 | 65 | # Already closed 66 | if ($self->is_closed) { 67 | croak 'File already closed' unless $cb; 68 | return Mojo::IOLoop->next_tick(sub { $self->$cb('File already closed') }); 69 | } 70 | 71 | $self->{buffer} .= $chunk; 72 | $self->{len} += length $chunk; 73 | 74 | my $bulk = $self->gridfs->chunks->bulk->ordered(0); 75 | my $size = $self->chunk_size; 76 | $self->_chunk($bulk) while length $self->{buffer} >= $size; 77 | 78 | # Non-blocking 79 | return $bulk->execute(sub { shift; $self->$cb(shift) }) if $cb; 80 | 81 | # Blocking 82 | $bulk->execute; 83 | return $self; 84 | } 85 | 86 | sub _chunk { 87 | my ($self, $bulk) = @_; 88 | 89 | my $chunk = substr $self->{buffer}, 0, $self->chunk_size, ''; 90 | return $bulk unless length $chunk; 91 | 92 | my $n = $self->{n}++; 93 | return $bulk->insert( 94 | {files_id => $self->_files_id, n => $n, data => bson_bin($chunk)}); 95 | } 96 | 97 | sub _files_id { shift->{files_id} //= bson_oid } 98 | 99 | sub _meta { 100 | my ($self, $md5) = @_; 101 | 102 | my $doc = { 103 | _id => $self->_files_id, 104 | length => $self->{len}, 105 | chunkSize => $self->chunk_size, 106 | uploadDate => bson_time, 107 | md5 => $md5 108 | }; 109 | if (my $name = $self->filename) { $doc->{filename} = $name } 110 | if (my $type = $self->content_type) { $doc->{contentType} = $type } 111 | if (my $data = $self->metadata) { $doc->{metadata} = $data } 112 | 113 | return $doc; 114 | } 115 | 116 | 1; 117 | 118 | =encoding utf8 119 | 120 | =head1 NAME 121 | 122 | Mango::GridFS::Writer - GridFS writer 123 | 124 | =head1 SYNOPSIS 125 | 126 | use Mango::GridFS::Writer; 127 | 128 | my $writer = Mango::GridFS::Writer->new(gridfs => $gridfs); 129 | 130 | =head1 DESCRIPTION 131 | 132 | L writes files to GridFS. 133 | 134 | =head1 ATTRIBUTES 135 | 136 | L implements the following attributes. 137 | 138 | =head2 chunk_size 139 | 140 | my $size = $writer->chunk_size; 141 | $writer = $writer->chunk_size(1024); 142 | 143 | Chunk size in bytes, defaults to C<261120> (255KB). 144 | 145 | =head2 content_type 146 | 147 | my $type = $writer->content_type; 148 | $writer = $writer->content_type('text/plain'); 149 | 150 | Content type of file. 151 | 152 | =head2 filename 153 | 154 | my $name = $writer->filename; 155 | $writer = $writer->filename('foo.txt'); 156 | 157 | Name of file. 158 | 159 | =head2 gridfs 160 | 161 | my $gridfs = $writer->gridfs; 162 | $writer = $writer->gridfs(Mango::GridFS->new); 163 | 164 | L object this writer belongs to. 165 | 166 | =head2 metadata 167 | 168 | my $data = $writer->metadata; 169 | $writer = $writer->metadata({foo => 'bar'}); 170 | 171 | Additional information. 172 | 173 | =head1 METHODS 174 | 175 | L inherits all methods from L and 176 | implements the following new ones. 177 | 178 | =head2 close 179 | 180 | my $oid = $writer->close; 181 | 182 | Close file. You can also append a callback to perform operation non-blocking. 183 | 184 | $writer->close(sub { 185 | my ($writer, $err, $oid) = @_; 186 | ... 187 | }); 188 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 189 | 190 | =head2 is_closed 191 | 192 | my $success = $writer->is_closed; 193 | 194 | Check if file has been closed. 195 | 196 | =head2 write 197 | 198 | $writer = $writer->write('hello world!'); 199 | 200 | Write chunk. You can also append a callback to perform operation non-blocking. 201 | 202 | $writer->write('hello world!' => sub { 203 | my ($writer, $err) = @_; 204 | ... 205 | }); 206 | Mojo::IOLoop->start unless Mojo::IOLoop->is_running; 207 | 208 | =head1 SEE ALSO 209 | 210 | L, L, L. 211 | 212 | =cut 213 | -------------------------------------------------------------------------------- /lib/Mango/Protocol.pm: -------------------------------------------------------------------------------- 1 | package Mango::Protocol; 2 | use Mojo::Base -base; 3 | 4 | use Mango::BSON qw(bson_decode bson_encode bson_length encode_cstring); 5 | 6 | # Opcodes 7 | use constant {REPLY => 1, QUERY => 2004, GET_MORE => 2005, 8 | KILL_CURSORS => 2007}; 9 | 10 | sub build_get_more { 11 | my ($self, $id, $name, $return, $cursor) = @_; 12 | 13 | # Zero and name 14 | my $msg = pack('l<', 0) . encode_cstring($name); 15 | 16 | # Number to return and cursor id 17 | $msg .= pack('l<', $return) . pack('q<', $cursor); 18 | 19 | # Header 20 | return _build_header($id, length($msg), GET_MORE) . $msg; 21 | } 22 | 23 | sub build_kill_cursors { 24 | my ($self, $id) = (shift, shift); 25 | 26 | # Zero and number of cursor ids 27 | my $msg = pack('l<', 0) . pack('l<', scalar @_); 28 | 29 | # Cursor ids 30 | $msg .= pack 'q<', $_ for @_; 31 | 32 | # Header 33 | return _build_header($id, length($msg), KILL_CURSORS) . $msg; 34 | } 35 | 36 | sub build_query { 37 | my ($self, $id, $name, $flags, $skip, $return, $query, $fields) = @_; 38 | 39 | # Flags 40 | my $vec = pack 'B*', '0' x 32; 41 | vec($vec, 1, 1) = 1 if $flags->{tailable_cursor}; 42 | vec($vec, 2, 1) = 1 if $flags->{slave_ok}; 43 | vec($vec, 4, 1) = 1 if $flags->{no_cursor_timeout}; 44 | vec($vec, 5, 1) = 1 if $flags->{await_data}; 45 | vec($vec, 6, 1) = 1 if $flags->{exhaust}; 46 | vec($vec, 7, 1) = 1 if $flags->{partial}; 47 | my $msg = pack 'l<', unpack('V', $vec); 48 | 49 | # Name 50 | $msg .= encode_cstring $name; 51 | 52 | # Skip and number to return 53 | $msg .= pack('l<', $skip) . pack('l<', $return); 54 | 55 | # Query 56 | $msg .= bson_encode $query; 57 | 58 | # Optional field selector 59 | $msg .= bson_encode $fields if $fields; 60 | 61 | # Header 62 | return _build_header($id, length($msg), QUERY) . $msg; 63 | } 64 | 65 | sub command_error { 66 | my ($self, $doc) = @_; 67 | return $doc->{ok} ? undef : $doc->{errmsg}; 68 | } 69 | 70 | sub next_id { $_[1] > 2147483646 ? 1 : $_[1] + 1 } 71 | 72 | sub parse_reply { 73 | my ($self, $bufref) = @_; 74 | 75 | # Make sure we have the whole message 76 | return undef unless my $len = bson_length $$bufref; 77 | return undef if length $$bufref < $len; 78 | my $msg = substr $$bufref, 0, $len, ''; 79 | substr $msg, 0, 4, ''; 80 | 81 | # Header 82 | my $id = unpack 'l<', substr($msg, 0, 4, ''); 83 | my $to = unpack 'l<', substr($msg, 0, 4, ''); 84 | my $op = unpack 'l<', substr($msg, 0, 4, ''); 85 | return undef unless $op == REPLY; 86 | 87 | # Flags 88 | my $flags = {}; 89 | my $vec = substr $msg, 0, 4, ''; 90 | $flags->{cursor_not_found} = 1 if vec $vec, 0, 1; 91 | $flags->{query_failure} = 1 if vec $vec, 1, 1; 92 | $flags->{await_capable} = 1 if vec $vec, 3, 1; 93 | 94 | # Cursor id 95 | my $cursor = unpack 'q<', substr($msg, 0, 8, ''); 96 | 97 | # Starting from 98 | my $from = unpack 'l<', substr($msg, 0, 4, ''); 99 | 100 | # Documents (remove number of documents prefix) 101 | substr $msg, 0, 4, ''; 102 | my @docs; 103 | push @docs, bson_decode(substr $msg, 0, bson_length($msg), '') while $msg; 104 | 105 | return { 106 | id => $id, 107 | to => $to, 108 | flags => $flags, 109 | cursor => $cursor, 110 | from => $from, 111 | docs => \@docs 112 | }; 113 | } 114 | 115 | sub query_failure { 116 | my ($self, $reply) = @_; 117 | return undef unless $reply; 118 | return $reply->{flags}{query_failure} ? $reply->{docs}[0]{'$err'} : undef; 119 | } 120 | 121 | sub write_error { 122 | my ($self, $doc) = @_; 123 | return undef unless my $errors = $doc->{writeErrors}; 124 | return join "\n", 125 | map {"Write error at index $_->{index}: $_->{errmsg}"} @$errors; 126 | } 127 | 128 | sub _build_header { 129 | my ($id, $length, $op) = @_; 130 | return join '', map { pack 'l<', $_ } $length + 16, $id, 0, $op; 131 | } 132 | 133 | 1; 134 | 135 | =encoding utf8 136 | 137 | =head1 NAME 138 | 139 | Mango::Protocol - The MongoDB wire protocol 140 | 141 | =head1 SYNOPSIS 142 | 143 | use Mango::Protocol; 144 | 145 | my $protocol = Mango::Protocol->new; 146 | my $bytes = $protocol->query(1, 'foo', {}, 0, 10, {}, {}); 147 | 148 | =head1 DESCRIPTION 149 | 150 | L is a minimalistic implementation of the MongoDB wire 151 | protocol. 152 | 153 | =head1 METHODS 154 | 155 | L inherits all methods from L and implements the 156 | following new ones. 157 | 158 | =head2 build_get_more 159 | 160 | my $bytes = $protocol->build_get_more($id, $name, $return, $cursor); 161 | 162 | Build message for C operation. 163 | 164 | =head2 build_kill_cursors 165 | 166 | my $bytes = $protocol->build_kill_cursors($id, @ids); 167 | 168 | Build message for C operation. 169 | 170 | =head2 build_query 171 | 172 | my $bytes = $protocol->build_query($id, $name, $flags, $skip, $return, 173 | $query, $fields); 174 | 175 | Build message for C operation. 176 | 177 | =head2 command_error 178 | 179 | my $err = $protocol->command_error($doc); 180 | 181 | Check document for command error. 182 | 183 | =head2 next_id 184 | 185 | my $id = $protocol->next_id(23); 186 | 187 | Generate next id. 188 | 189 | =head2 parse_reply 190 | 191 | my $reply = $protocol->parse_reply(\$str); 192 | 193 | Extract and parse C message. 194 | 195 | =head2 query_failure 196 | 197 | my $err = $protocol->query_failure($reply); 198 | 199 | Check reply for query failure. 200 | 201 | =head2 write_error 202 | 203 | my $err = $protocol->write_error($doc); 204 | 205 | Check document for write error. 206 | 207 | =head1 SEE ALSO 208 | 209 | L, L, L. 210 | 211 | =cut 212 | -------------------------------------------------------------------------------- /t/bson.t: -------------------------------------------------------------------------------- 1 | package BSONTest; 2 | use Mojo::Base -base; 3 | 4 | has 'something' => sub { {} }; 5 | 6 | sub TO_JSON { shift->something } 7 | 8 | package BSONTest2; 9 | use Mojo::Base 'BSONTest'; 10 | 11 | sub TO_BSON { {something => shift->something} } 12 | 13 | package main; 14 | use Mojo::Base -strict; 15 | 16 | use Test::More; 17 | use Mango::BSON ':bson'; 18 | use Mojo::ByteStream 'b'; 19 | use Mojo::JSON 'encode_json'; 20 | use Scalar::Util 'dualvar'; 21 | 22 | # Ordered document 23 | my $doc = bson_doc(a => 1, c => 2, b => 3); 24 | $doc->{d} = 4; 25 | $doc->{e} = 5; 26 | is_deeply [keys %$doc], [qw(a c b d e)], 'ordered keys'; 27 | is_deeply [values %$doc], [qw(1 2 3 4 5)], 'ordered values'; 28 | ok exists $doc->{c}, 'value does exist'; 29 | is delete $doc->{c}, 2, 'right value'; 30 | ok !exists $doc->{x}, 'value does not exist'; 31 | is delete $doc->{x}, undef, 'no value'; 32 | is_deeply [keys %$doc], [qw(a b d e)], 'ordered keys'; 33 | is_deeply [values %$doc], [qw(1 3 4 5)], 'ordered values'; 34 | $doc->{d} = 6; 35 | is_deeply [keys %$doc], [qw(a b d e)], 'ordered keys'; 36 | is_deeply [values %$doc], [qw(1 3 6 5)], 'ordered values'; 37 | 38 | # Document length prefix 39 | is bson_length("\x05"), undef, 'no length'; 40 | is bson_length("\x05\x00\x00\x00"), 5, 'right length'; 41 | is bson_length("\x05\x00\x00\x00\x00"), 5, 'right length'; 42 | is bson_length("\x05\x00\x00\x00\x00\x00"), 5, 'right length'; 43 | 44 | # Generate object id 45 | is length bson_oid, 24, 'right length'; 46 | is bson_oid('510d83915867b405b9000000')->to_epoch, 1359840145, 47 | 'right epoch time'; 48 | my $oid = bson_oid->from_epoch(1359840145); 49 | is $oid->to_epoch, 1359840145, 'right epoch time'; 50 | isnt $oid, bson_oid->from_epoch(1359840145), 'different object ids'; 51 | 52 | # Generate Time 53 | is length bson_time, length(time) + 3, 'right length'; 54 | is length int bson_time->to_epoch, length time, 'right length'; 55 | is substr(bson_time->to_epoch, 0, 5), substr(time, 0, 5), 'same start'; 56 | is bson_time(1360626536748), 1360626536748, 'right epoch milliseconds'; 57 | is bson_time(1360626536748)->to_epoch, 1360626536.748, 'right epoch seconds'; 58 | is bson_time(1360626536748)->to_datetime, '2013-02-11T23:48:56.748Z', 59 | 'right format'; 60 | 61 | # Empty document 62 | my $bson = bson_encode {}; 63 | is_deeply bson_decode($bson), {}, 'successful roundtrip'; 64 | 65 | # Minimal document roundtrip 66 | my $bytes = "\x05\x00\x00\x00\x00"; 67 | $doc = bson_decode($bytes); 68 | is_deeply [keys %$doc], [], 'empty document'; 69 | is_deeply $doc, {}, 'empty document'; 70 | is bson_encode($doc), $bytes, 'successful roundtrip'; 71 | 72 | # Empty key and value 73 | $bytes = "\x0c\x00\x00\x00\x02\x00\x01\x00\x00\x00\x00\x00"; 74 | $doc = bson_decode($bytes); 75 | is_deeply $doc, {'' => ''}, 'right document'; 76 | is bson_encode($doc), $bytes, 'successful roundtrip'; 77 | 78 | # Incomplete document 79 | is bson_decode("\x05\x00\x00\x00"), undef, 'no result'; 80 | is bson_decode("\x05\x00\x00"), undef, 'no result'; 81 | is bson_decode("\x05\x00"), undef, 'no result'; 82 | is bson_decode("\x05"), undef, 'no result'; 83 | 84 | # Nested document roundtrip 85 | $bytes = "\x10\x00\x00\x00\x03\x6e\x6f\x6e\x65\x00\x05\x00\x00\x00\x00\x00"; 86 | $doc = bson_decode($bytes); 87 | is_deeply $doc, {none => {}}, 'empty nested document'; 88 | is bson_encode($doc), $bytes, 'successful roundtrip for hash'; 89 | is bson_encode(bson_doc(none => {})), $bytes, 90 | 'successful roundtrip for document'; 91 | 92 | # Document roundtrip with "0" in key 93 | is_deeply bson_decode(bson_encode {n0ne => 'n0ne'}), bson_doc(n0ne => 'n0ne'), 94 | 'successful roundtrip'; 95 | 96 | # String roundtrip 97 | $bytes = "\x1b\x00\x00\x00\x02\x74\x65\x73\x74\x00\x0c\x00\x00\x00\x68\x65" 98 | . "\x6c\x6c\x6f\x20\x77\x6f\x72\x6c\x64\x00\x00"; 99 | $doc = bson_decode($bytes); 100 | is $doc->{test}, 'hello world', 'right value'; 101 | is_deeply [keys %$doc], ['test'], 'one element'; 102 | is_deeply $doc, {test => 'hello world'}, 'right document'; 103 | is bson_encode($doc), $bytes, 'successful roundtrip'; 104 | $doc = bson_decode(bson_encode {foo => 'i ♥ mojolicious'}); 105 | is $doc->{foo}, 'i ♥ mojolicious', 'successful roundtrip'; 106 | 107 | # Array 108 | $bytes 109 | = "\x11\x00\x00\x00\x04\x65\x6d\x70\x74\x79\x00\x05\x00\x00\x00\x00\x00"; 110 | $doc = bson_decode($bytes); 111 | is_deeply $doc, {empty => []}, 'empty array'; 112 | 113 | # Array roundtrip 114 | $bytes 115 | = "\x11\x00\x00\x00\x04\x65\x6d\x70\x74\x79\x00\x05\x00\x00\x00\x00\x00"; 116 | $doc = bson_decode($bytes); 117 | is_deeply $doc, {empty => []}, 'empty array'; 118 | is bson_encode($doc), $bytes, 'successful roundtrip'; 119 | $bytes 120 | = "\x33\x00\x00\x00\x04\x66\x69\x76\x65\x00\x28\x00\x00\x00\x10\x30\x00\x01" 121 | . "\x00\x00\x00\x10\x31\x00\x02\x00\x00\x00\x10\x32\x00\x03\x00\x00\x00\x10" 122 | . "\x33\x00\x04\x00\x00\x00\x10\x34\x00\x05\x00\x00\x00\x00\x00"; 123 | $doc = bson_decode($bytes); 124 | is_deeply $doc, {five => [1, 2, 3, 4, 5]}, 'array with five elements'; 125 | is bson_encode($doc), $bytes, 'successful roundtrip'; 126 | 127 | # Timestamp roundtrip 128 | $bytes = "\x13\x00\x00\x00\x11\x74\x65\x73\x74\x00\x14\x00\x00\x00\x04\x00\x00" 129 | . "\x00\x00"; 130 | $doc = bson_decode($bytes); 131 | isa_ok $doc->{test}, 'Mango::BSON::Timestamp', 'right class'; 132 | is $doc->{test}->seconds, 4, 'right seconds'; 133 | is $doc->{test}->increment, 20, 'right increment'; 134 | is bson_encode($doc), $bytes, 'successful roundtrip'; 135 | 136 | # Double roundtrip 137 | $bytes = "\x14\x00\x00\x00\x01\x68\x65\x6c\x6c\x6f\x00\x00\x00\x00\x00\x00\x00" 138 | . "\xf8\x3f\x00"; 139 | $doc = bson_decode($bytes); 140 | is_deeply $doc, {hello => 1.5}, 'right document'; 141 | is bson_encode($doc), $bytes, 'successful roundtrip'; 142 | $doc = bson_decode(bson_encode {test => -1.5}); 143 | is $doc->{test}, -1.5, 'successful roundtrip'; 144 | 145 | # Int32 roundtrip 146 | $bytes = "\x0f\x00\x00\x00\x10\x6d\x69\x6b\x65\x00\x64\x00\x00\x00\x00"; 147 | $doc = bson_decode($bytes); 148 | is_deeply $doc, {mike => 100}, 'right document'; 149 | is bson_encode($doc), $bytes, 'successful roundtrip'; 150 | $doc = bson_decode(bson_encode {test => -100}); 151 | is $doc->{test}, -100, 'successful roundtrip'; 152 | 153 | # Int64 roundtrip 154 | $bytes = "\x13\x00\x00\x00\x12\x6d\x69\x6b\x65\x00\x01\x00\x00\x80\x00\x00\x00" 155 | . "\x00\x00"; 156 | $doc = bson_decode($bytes); 157 | is_deeply $doc, {mike => 2147483649}, 'right document'; 158 | is bson_encode($doc), $bytes, 'successful roundtrip'; 159 | $doc = bson_decode(bson_encode {test => -2147483648}); 160 | is $doc->{test}, -2147483648, 'successful roundtrip'; 161 | 162 | # Boolean roundtrip 163 | $bytes = "\x0c\x00\x00\x00\x08\x74\x72\x75\x65\x00\x01\x00"; 164 | $doc = bson_decode($bytes); 165 | is_deeply $doc, {true => bson_true()}, 'right document'; 166 | is bson_encode($doc), $bytes, 'successful roundtrip'; 167 | $bytes = "\x0d\x00\x00\x00\x08\x66\x61\x6c\x73\x65\x00\x00\x00"; 168 | $doc = bson_decode($bytes); 169 | is_deeply $doc, {false => bson_false()}, 'right document'; 170 | is bson_encode($doc), $bytes, 'successful roundtrip'; 171 | 172 | # Null roundtrip 173 | $bytes = "\x0b\x00\x00\x00\x0a\x74\x65\x73\x74\x00\x00"; 174 | $doc = bson_decode($bytes); 175 | is_deeply $doc, {test => undef}, 'right document'; 176 | is bson_encode($doc), $bytes, 'successful roundtrip'; 177 | 178 | # Max key roundtrip 179 | $bytes = "\x0b\x00\x00\x00\x7f\x74\x65\x73\x74\x00\x00"; 180 | $doc = bson_decode($bytes); 181 | is_deeply $doc, {test => bson_max()}, 'right document'; 182 | is bson_encode($doc), $bytes, 'successful roundtrip'; 183 | 184 | # Min key roundtrip 185 | $bytes = "\x0b\x00\x00\x00\xff\x74\x65\x73\x74\x00\x00"; 186 | $doc = bson_decode($bytes); 187 | is_deeply $doc, {test => bson_min()}, 'right document'; 188 | is bson_encode($doc), $bytes, 'successful roundtrip'; 189 | 190 | # Object id roundtrip 191 | my $id = '000102030405060708090a0b'; 192 | $bytes = "\x16\x00\x00\x00\x07\x6f\x69\x64\x00\x00" 193 | . "\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x00"; 194 | $doc = bson_decode($bytes); 195 | isa_ok $doc->{oid}, 'Mango::BSON::ObjectID', 'right class'; 196 | is $doc->{oid}->to_epoch, 66051, 'right epoch time'; 197 | is_deeply $doc, {oid => $id}, 'right document'; 198 | is bson_encode($doc), $bytes, 'successful roundtrip'; 199 | 200 | # Regex roundtrip 201 | $bytes 202 | = "\x12\x00\x00\x00\x0b\x72\x65\x67\x65\x78\x00\x61\x2a\x62\x00\x69\x00\x00"; 203 | $doc = bson_decode($bytes); 204 | is_deeply $doc, {regex => qr/a*b/i}, 'right document'; 205 | like 'AAB', $doc->{regex}, 'regex works'; 206 | like 'ab', $doc->{regex}, 'regex works'; 207 | unlike 'Ax', $doc->{regex}, 'regex works'; 208 | is bson_encode($doc), $bytes, 'successful roundtrip'; 209 | 210 | # Code roundtrip 211 | $bytes = "\x1c\x00\x00\x00\x0d\x66\x6f\x6f\x00\x0e\x00\x00\x00\x76\x61\x72\x20" 212 | . "\x66\x6f\x6f\x20\x3d\x20\x32\x33\x3b\x00\x00"; 213 | $doc = bson_decode($bytes); 214 | isa_ok $doc->{foo}, 'Mango::BSON::Code', 'right class'; 215 | is_deeply $doc, {foo => bson_code('var foo = 23;')}, 'right document'; 216 | is bson_encode($doc), $bytes, 'successful roundtrip'; 217 | 218 | # Code with scope roundtrip 219 | $bytes 220 | = "\x32\x00\x00\x00\x0f\x66\x6f\x6f\x00\x24\x00\x00\x00\x0e\x00\x00\x00\x76" 221 | . "\x61\x72\x20\x66\x6f\x6f\x20\x3d\x20\x32\x34\x3b\x00\x12\x00\x00\x00\x02\x66" 222 | . "\x6f\x6f\x00\x04\x00\x00\x00\x62\x61\x72\x00\x00\x00"; 223 | $doc = bson_decode($bytes); 224 | isa_ok $doc->{foo}, 'Mango::BSON::Code', 'right class'; 225 | is_deeply $doc, {foo => bson_code('var foo = 24;')->scope({foo => 'bar'})}, 226 | 'right document'; 227 | is bson_encode($doc), $bytes, 'successful roundtrip'; 228 | 229 | # Time roundtrip 230 | $bytes = "\x14\x00\x00\x00\x09\x74\x6f\x64\x61\x79\x00\x4e\x61\xbc\x00\x00\x00" 231 | . "\x00\x00\x00"; 232 | $doc = bson_decode($bytes); 233 | isa_ok $doc->{today}, 'Mango::BSON::Time', 'right class'; 234 | is_deeply $doc, {today => bson_time(12345678)}, 'right document'; 235 | is bson_encode($doc), $bytes, 'successful roundtrip'; 236 | is_deeply bson_decode(bson_encode({time => bson_time(1360627440269)})), 237 | {time => 1360627440269}, 'successful roundtrip'; 238 | 239 | # Generic binary roundtrip 240 | $bytes = "\x14\x00\x00\x00\x05\x66\x6f\x6f\x00\x05\x00\x00\x00\x00\x31\x32\x33" 241 | . "\x34\x35\x00"; 242 | $doc = bson_decode($bytes); 243 | isa_ok $doc->{foo}, 'Mango::BSON::Binary', 'right class'; 244 | is $doc->{foo}->type, 'generic', 'right type'; 245 | is_deeply $doc, {foo => bson_bin('12345')}, 'right document'; 246 | is bson_encode($doc), $bytes, 'successful roundtrip'; 247 | 248 | # Function binary roundtrip 249 | $bytes = "\x14\x00\x00\x00\x05\x66\x6f\x6f\x00\x05\x00\x00\x00\x01\x31\x32\x33" 250 | . "\x34\x35\x00"; 251 | $doc = bson_decode($bytes); 252 | isa_ok $doc->{foo}, 'Mango::BSON::Binary', 'right class'; 253 | is $doc->{foo}->type, 'function', 'right type'; 254 | is_deeply $doc, {foo => bson_bin('12345')->type('function')}, 'right document'; 255 | is bson_encode($doc), $bytes, 'successful roundtrip'; 256 | 257 | # MD5 binary roundtrip 258 | $bytes = "\x14\x00\x00\x00\x05\x66\x6f\x6f\x00\x05\x00\x00\x00\x05\x31\x32\x33" 259 | . "\x34\x35\x00"; 260 | $doc = bson_decode($bytes); 261 | isa_ok $doc->{foo}, 'Mango::BSON::Binary', 'right class'; 262 | is $doc->{foo}->type, 'md5', 'right type'; 263 | is_deeply $doc, {foo => bson_bin('12345')->type('md5')}, 'right document'; 264 | is bson_encode($doc), $bytes, 'successful roundtrip'; 265 | 266 | # UUID binary roundtrip 267 | $bytes = "\x14\x00\x00\x00\x05\x66\x6f\x6f\x00\x05\x00\x00\x00\x04\x31\x32\x33" 268 | . "\x34\x35\x00"; 269 | $doc = bson_decode($bytes); 270 | isa_ok $doc->{foo}, 'Mango::BSON::Binary', 'right class'; 271 | is $doc->{foo}->type, 'uuid', 'right type'; 272 | is_deeply $doc, {foo => bson_bin('12345')->type('uuid')}, 'right document'; 273 | is bson_encode($doc), $bytes, 'successful roundtrip'; 274 | 275 | # User defined binary roundtrip 276 | $bytes = "\x14\x00\x00\x00\x05\x66\x6f\x6f\x00\x05\x00\x00\x00\x80\x31\x32\x33" 277 | . "\x34\x35\x00"; 278 | $doc = bson_decode($bytes); 279 | isa_ok $doc->{foo}, 'Mango::BSON::Binary', 'right class'; 280 | is $doc->{foo}->type, 'user_defined', 'right type'; 281 | is_deeply $doc, {foo => bson_bin('12345')->type('user_defined')}, 282 | 'right document'; 283 | is bson_encode($doc), $bytes, 'successful roundtrip'; 284 | 285 | # Pre-encoded BSON document roundtrip 286 | my $raw = bson_raw bson_encode {bar => 'baz'}; 287 | is_deeply bson_decode(bson_encode $raw), {bar => 'baz'}, 288 | 'successful roundtrip'; 289 | is_deeply bson_decode(bson_encode {foo => $raw}), {foo => {bar => 'baz'}}, 290 | 'successful roundtrip'; 291 | is_deeply bson_decode(bson_encode {foo => [$raw]}), {foo => [{bar => 'baz'}]}, 292 | 'successful roundtrip'; 293 | 294 | # DBRef roundtrip 295 | $bytes 296 | = "\x31\x00\x00\x00\x03\x64\x62\x72\x65\x66\x00\x25\x00\x00\x00\x07\x24\x69" 297 | . "\x64\x00\x52\x51\x39\xd8\x58\x67\xb4\x57\x14\x02\x00\x00\x02\x24\x72\x65" 298 | . "\x66\x00\x05\x00\x00\x00\x74\x65\x73\x74\x00\x00\x00"; 299 | $doc = bson_decode($bytes); 300 | is $doc->{dbref}{'$ref'}, 'test', 'right collection name'; 301 | is $doc->{dbref}{'$id'}->to_string, '525139d85867b45714020000', 302 | 'right object id'; 303 | is bson_encode($doc), $bytes, 'successful roundtrip'; 304 | 305 | # Unicode roundtrip 306 | $bytes = "\x21\x00\x00\x00\x02\xe2\x98\x83\x00\x13\x00\x00\x00\x49\x20\xe2\x99" 307 | . "\xa5\x20\x4d\x6f\x6a\x6f\x6c\x69\x63\x69\x6f\x75\x73\x21\x00\x00"; 308 | $doc = bson_decode($bytes); 309 | is_deeply $doc, {'☃' => 'I ♥ Mojolicious!'}, 'right document'; 310 | is bson_encode($doc), $bytes, 'successful roundtrip'; 311 | 312 | # Object stringifies to "1" 313 | $bytes = "\x10\x00\x00\x00\x05\x66\x6f\x6f\x00\x01\x00\x00\x00\x00\x31\x00"; 314 | $doc = bson_decode($bytes); 315 | isa_ok $doc->{foo}, 'Mango::BSON::Binary', 'right class'; 316 | is $doc->{foo}->type, 'generic', 'right type'; 317 | is_deeply $doc, {foo => bson_bin('1')}, 'right document'; 318 | is bson_encode($doc), $bytes, 'successful roundtrip'; 319 | is bson_bin('1'), '1', 'right result'; 320 | 321 | # Blessed reference 322 | $bytes = bson_encode {test => b('test')}; 323 | is_deeply bson_decode($bytes), {test => 'test'}, 'successful roundtrip'; 324 | 325 | # Blessed reference with TO_JSON method 326 | $bytes = bson_encode({test => BSONTest->new}); 327 | is_deeply bson_decode($bytes), {test => {}}, 'successful roundtrip'; 328 | $bytes = bson_encode( 329 | { 330 | test => BSONTest->new( 331 | something => {just => 'works'}, 332 | else => {not => 'working'} 333 | ) 334 | } 335 | ); 336 | is_deeply bson_decode($bytes), {test => {just => 'works'}}, 337 | 'successful roundtrip'; 338 | 339 | # Blessed reference with TO_BSON method 340 | $bytes = bson_encode({test => BSONTest2->new}); 341 | is_deeply bson_decode($bytes), {test => {something => {}}}, 342 | 'successful roundtrip'; 343 | $bytes = bson_encode( 344 | { 345 | test => BSONTest2->new( 346 | something => {just => 'works'}, 347 | else => {not => 'working'} 348 | ) 349 | } 350 | ); 351 | is_deeply bson_decode($bytes), {test => {something => {just => 'works'}}}, 352 | 'successful roundtrip'; 353 | 354 | # Boolean shortcut 355 | is_deeply bson_decode(bson_encode({true => \1})), {true => bson_true}, 356 | 'encode true boolean from constant reference'; 357 | is_deeply bson_decode(bson_encode({false => \0})), {false => bson_false}, 358 | 'encode false boolean from constant reference'; 359 | $bytes = 'some true value'; 360 | is_deeply bson_decode(bson_encode({true => \!!$bytes})), {true => bson_true}, 361 | 'encode true boolean from double negated reference'; 362 | is_deeply bson_decode(bson_encode({true => \$bytes})), {true => bson_true}, 363 | 'encode true boolean from reference'; 364 | $bytes = ''; 365 | is_deeply bson_decode(bson_encode({false => \!!$bytes})), 366 | {false => bson_false}, 'encode false boolean from double negated reference'; 367 | is_deeply bson_decode(bson_encode({false => \$bytes})), {false => bson_false}, 368 | 'encode false boolean from reference'; 369 | 370 | # Mojo::JSON booleans 371 | is_deeply bson_decode(bson_encode {test => Mojo::JSON->true}), 372 | {test => bson_true}, 'encode true boolean from Mojo::JSON'; 373 | is_deeply bson_decode(bson_encode {test => Mojo::JSON->false}), 374 | {test => bson_false}, 'encode false boolean from Mojo::JSON'; 375 | 376 | # Upgraded numbers 377 | my $num = 3; 378 | my $str = "$num"; 379 | is bson_encode({test => [$num, $str]}), 380 | "\x20\x00\x00\x00\x04\x74\x65\x73\x74" 381 | . "\x00\x15\x00\x00\x00\x10\x30\x00\x03\x00\x00\x00\x02\x31\x00\x02\x00\x00" 382 | . "\x00\x33\x00\x00\x00", 'upgraded number detected'; 383 | $num = 1.5; 384 | $str = "$num"; 385 | is bson_encode({test => [$num, $str]}), 386 | "\x26\x00\x00\x00\x04\x74\x65\x73\x74" 387 | . "\x00\x1b\x00\x00\x00\x01\x30\x00\x00\x00\x00\x00\x00\x00\xf8\x3f\x02\x31" 388 | . "\x00\x04\x00\x00\x00\x31\x2e\x35\x00\x00\x00", 'upgraded number detected'; 389 | $str = '0 but true'; 390 | $num = 1 + $str; 391 | is bson_encode({test => [$num, $str]}), 392 | "\x29\x00\x00\x00\x04\x74\x65\x73\x74\x00\x1e\x00\x00\x00\x10\x30\x00\x01" 393 | . "\x00\x00\x00\x02\x31\x00\x0b\x00\x00\x00\x30\x20\x62\x75\x74\x20\x74\x72" 394 | . "\x75\x65\x00\x00\x00", 'upgraded number detected'; 395 | 396 | # Upgraded string 397 | $str = "bar"; 398 | { no warnings 'numeric'; $num = 23 + $str } 399 | is bson_encode({test => [$num, $str]}), 400 | "\x26\x00\x00\x00\x04\x74\x65\x73\x74\x00\x1b\x00\x00\x00\x01\x30\x00\x00" 401 | . "\x00\x00\x00\x00\x00\x37\x40\x02\x31\x00\x04\x00\x00\x00\x62\x61\x72\x00" 402 | . "\x00\x00", 'upgraded string detected'; 403 | 404 | # dualvar 405 | my $dual = dualvar 23, 'twenty three'; 406 | is bson_encode({test => $dual}), 407 | "\x1c\x00\x00\x00\x02\x74\x65\x73\x74\x00\x0d\x00\x00\x00\x74\x77\x65\x6e" 408 | . "\x74\x79\x20\x74\x68\x72\x65\x65\x00\x00", 'dualvar stringified'; 409 | 410 | # Ensure numbers and strings are not upgraded 411 | my $mixed = {test => [3, 'three', '3', 0, "0"]}; 412 | $bson 413 | = "\x3d\x00\x00\x00\x04\x74\x65\x73\x74\x00\x32\x00\x00\x00\x10\x30\x00" 414 | . "\x03\x00\x00\x00\x02\x31\x00\x06\x00\x00\x00\x74\x68\x72\x65\x65\x00\x02" 415 | . "\x32\x00\x02\x00\x00\x00\x33\x00\x10\x33\x00\x00\x00\x00\x00\x02\x34\x00" 416 | . "\x02\x00\x00\x00\x30\x00\x00\x00"; 417 | is bson_encode($mixed), $bson, 'all have been detected correctly'; 418 | is bson_encode($mixed), $bson, 'all have been detected correctly again'; 419 | 420 | # "inf" and "nan" 421 | is_deeply bson_decode(bson_encode {test => [9**9**9]}), {test => [9**9**9]}, 422 | 'successful roundtrip'; 423 | is_deeply bson_decode(bson_encode {test => [-sin(9**9**9)]}), 424 | {test => [-sin(9**9**9)]}, 'successful roundtrip'; 425 | 426 | # Time to JSON 427 | is encode_json({time => bson_time(1360626536748)}), '{"time":1360626536748}', 428 | 'right JSON'; 429 | is encode_json({time => bson_time('1360626536748')}), 430 | '{"time":1360626536748}', 'right JSON'; 431 | 432 | # Binary to JSON 433 | is encode_json({bin => bson_bin('Hello World!')}), 434 | '{"bin":"SGVsbG8gV29ybGQh"}', 'right JSON'; 435 | 436 | # DBRef to JSON 437 | is encode_json( 438 | {dbref => bson_dbref('test', bson_oid('525139d85867b45714020000'))}), 439 | '{"dbref":{"$ref":"test","$id":"525139d85867b45714020000"}}', 'right JSON'; 440 | 441 | # Validate object id 442 | is bson_oid('123456789012345678abcdef'), '123456789012345678abcdef', 443 | 'valid object id'; 444 | is bson_oid('123456789012345678ABCDEF'), '123456789012345678abcdef', 445 | 'valid object id'; 446 | eval { bson_oid('123456789012345678abcde') }; 447 | like $@, qr/Invalid object id "123456789012345678abcde"/, 448 | 'object id too short'; 449 | eval { bson_oid('123456789012345678abcdeff') }; 450 | like $@, qr/Invalid object id "123456789012345678abcdeff"/, 451 | 'object id too long'; 452 | eval { bson_oid('123456789012345678abcdgf') }; 453 | like $@, qr/Invalid object id "123456789012345678abcdgf"/, 'invalid object id'; 454 | eval { bson_oid(0) }; 455 | like $@, qr/Invalid object id "0"/, 'invalid object id'; 456 | 457 | done_testing(); 458 | -------------------------------------------------------------------------------- /t/bulk.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | 3 | use Test::More; 4 | 5 | plan skip_all => 'set TEST_ONLINE to enable this test' 6 | unless $ENV{TEST_ONLINE}; 7 | 8 | use Mango; 9 | use Mango::BSON qw(bson_doc bson_oid); 10 | use Mojo::IOLoop; 11 | 12 | # Clean up before start 13 | my $mango = Mango->new($ENV{TEST_ONLINE}); 14 | my $collection = $mango->db->collection('bulk_test'); 15 | $collection->drop if $collection->options; 16 | 17 | # Nothing blocking 18 | my $results = $collection->bulk->execute; 19 | is $results->{nInserted}, 0, 'no inserts'; 20 | is $results->{nMatched}, 0, 'no matches'; 21 | is $results->{nModified}, 0, 'no modifications'; 22 | is $results->{nRemoved}, 0, 'no removals'; 23 | is $results->{nUpserted}, 0, 'no upserts'; 24 | is_deeply $results->{upserted}, [], 'no upserts'; 25 | is_deeply $results->{writeConcernErrors}, [], 'no write concern errors'; 26 | is_deeply $results->{writeErrors}, [], 'no write errors'; 27 | 28 | # Nothing non-blocking 29 | my ($fail, $result); 30 | $collection->bulk->execute( 31 | sub { 32 | my ($bulk, $err, $results) = @_; 33 | $fail = $err; 34 | $result = $results; 35 | Mojo::IOLoop->stop; 36 | } 37 | ); 38 | Mojo::IOLoop->start; 39 | ok !$fail, 'no error'; 40 | is $result->{nInserted}, 0, 'no inserts'; 41 | is $result->{nMatched}, 0, 'no matches'; 42 | is $result->{nModified}, 0, 'no modifications'; 43 | is $result->{nRemoved}, 0, 'no removals'; 44 | is $result->{nUpserted}, 0, 'no upserts'; 45 | is_deeply $result->{upserted}, [], 'no upserts'; 46 | is_deeply $result->{writeConcernErrors}, [], 'no write concern errors'; 47 | is_deeply $result->{writeErrors}, [], 'no write errors'; 48 | 49 | # Mixed bulk operations blocking 50 | my $bulk = $collection->bulk; 51 | ok $bulk->ordered, 'ordered bulk operations'; 52 | $bulk->insert({foo => 'bar'}); 53 | $bulk->find({foo => 'bar'})->update_one({foo => 'baz'}); 54 | $bulk->find({foo => 'yada'})->upsert->update_one({foo => 'baz'}); 55 | $bulk->find({foo => 'baz'})->remove; 56 | $results = $bulk->execute; 57 | is $results->{nInserted}, 1, 'one insert'; 58 | is $results->{nMatched}, 1, 'one match'; 59 | is $results->{nModified}, 2, 'two modifications'; 60 | is $results->{nRemoved}, 2, 'two removals'; 61 | is $results->{nUpserted}, 1, 'one upsert'; 62 | ok $results->{upserted}[0], 'one upsert'; 63 | is_deeply $results->{writeConcernErrors}, [], 'no write concern errors'; 64 | is_deeply $results->{writeErrors}, [], 'no write errors'; 65 | 66 | # Mixed bulk operations non-blocking 67 | $bulk = $collection->bulk; 68 | $bulk->insert({foo => 'bar'}); 69 | $bulk->find({foo => 'bar'})->update_one({foo => 'baz'}); 70 | $bulk->find({foo => 'yada'})->upsert->update_one({foo => 'baz'}); 71 | $bulk->find({foo => 'baz'})->remove; 72 | ($fail, $result) = (); 73 | $bulk->execute( 74 | sub { 75 | my ($bulk, $err, $results) = @_; 76 | $fail = $err; 77 | $result = $results; 78 | Mojo::IOLoop->stop; 79 | } 80 | ); 81 | Mojo::IOLoop->start; 82 | ok !$fail, 'no error'; 83 | is $result->{nInserted}, 1, 'one insert'; 84 | is $result->{nMatched}, 1, 'one match'; 85 | is $result->{nModified}, 2, 'two modifications'; 86 | is $result->{nRemoved}, 2, 'two removals'; 87 | is $result->{nUpserted}, 1, 'one upsert'; 88 | ok $result->{upserted}[0], 'one upsert'; 89 | is_deeply $result->{writeConcernErrors}, [], 'no write concern errors'; 90 | is_deeply $result->{writeErrors}, [], 'no write errors'; 91 | 92 | # All operations 93 | $bulk = $collection->bulk; 94 | $bulk->insert({foo => 'a'})->insert({foo => 'b'})->insert({foo => 'c'}); 95 | $bulk->find({foo => {'$exists' => 1}})->update_one({foo => 'd'}); 96 | $results = $bulk->execute; 97 | is $results->{nInserted}, 3, 'three inserts'; 98 | is $results->{nModified}, 1, 'one modification'; 99 | $bulk = $collection->bulk; 100 | $bulk->find({foo => {'$exists' => 1}})->remove_one; 101 | $bulk->find({foo => {'$exists' => 1}})->update({'$set' => {foo => 'a'}}); 102 | $results = $bulk->execute; 103 | is $results->{nModified}, 2, 'two modifications'; 104 | is $results->{nRemoved}, 1, 'one removal'; 105 | $results = $collection->bulk->find->remove->execute; 106 | is $results->{nRemoved}, 2, 'two removals'; 107 | 108 | # Split up documents into multiple commands (many documents) 109 | is $mango->max_write_batch_size, 1000, 'right value'; 110 | $bulk = $collection->bulk; 111 | $bulk->insert({foo => $_}) for 1 .. 1001; 112 | $results = $bulk->execute; 113 | is $results->{nInserted}, 1001, 'over one thousand inserts'; 114 | 115 | # Split up documents into multiple commands (large documents) 116 | is $mango->max_bson_size, 16777216, 'right value'; 117 | my $large = 'x' x 5242880; 118 | $bulk = $collection->bulk; 119 | $bulk->insert({foo => $large}) for 1 .. 5; 120 | $results = $bulk->execute; 121 | is $results->{nInserted}, 5, 'five inserts'; 122 | 123 | # Insert the same document twice blocking (separated by update) 124 | my $doc = bson_doc _id => bson_oid, foo => 'bar'; 125 | $bulk = $collection->bulk->insert($doc)->find({foo => 'bar'}) 126 | ->update_one({'$set' => {foo => 'baz'}})->insert($doc); 127 | eval { $bulk->execute }; 128 | like $@, qr/^Write error at index 2: .+/, 'right error'; 129 | 130 | # Insert the same document twice non-blocking (separated by update) 131 | $doc = bson_doc _id => bson_oid, foo => 'bar'; 132 | $bulk = $collection->bulk->insert($doc)->find({foo => 'bar'}) 133 | ->update_one({'$set' => {foo => 'baz'}})->insert($doc); 134 | ($fail, $result) = (); 135 | $bulk->execute( 136 | sub { 137 | my ($bulk, $err, $results) = @_; 138 | $fail = $err; 139 | $result = $results; 140 | Mojo::IOLoop->stop; 141 | } 142 | ); 143 | Mojo::IOLoop->start; 144 | like $fail, qr/^Write error at index 2: .+/, 'right error'; 145 | is $result->{nInserted}, 1, 'one insert'; 146 | 147 | # Insert the same document three times blocking (unordered) 148 | $doc = bson_doc _id => bson_oid, foo => 'bar'; 149 | $bulk = $collection->bulk->insert($doc)->insert($doc)->insert($doc); 150 | eval { $bulk->ordered(0)->execute }; 151 | like $@, qr/Write error at index 1: .+/, 'right error'; 152 | like $@, qr/Write error at index 2: .+/, 'right error'; 153 | 154 | done_testing(); 155 | -------------------------------------------------------------------------------- /t/collection.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | 3 | use Test::More; 4 | 5 | plan skip_all => 'set TEST_ONLINE to enable this test' 6 | unless $ENV{TEST_ONLINE}; 7 | 8 | use Mango; 9 | use Mango::BSON qw(bson_code bson_doc bson_oid bson_true); 10 | use Mojo::IOLoop; 11 | 12 | # Clean up before start 13 | my $mango = Mango->new($ENV{TEST_ONLINE}); 14 | my $collection = $mango->db->collection('collection_test'); 15 | $collection->drop if $collection->options; 16 | 17 | # Collection names 18 | is $collection->name, 'collection_test', 'right collection name'; 19 | is $collection->full_name, join('.', $mango->db->name, $collection->name), 20 | 'right full collection name'; 21 | 22 | # Index names 23 | is $collection->build_index_name({foo => 1}), 'foo', 'right index name'; 24 | is $collection->build_index_name(bson_doc(foo => 1, bar => -1)), 'foo_bar', 25 | 'right index name'; 26 | is $collection->build_index_name(bson_doc(foo => 1, 'bar.baz' => -1)), 27 | 'foo_bar.baz', 'right index name'; 28 | is $collection->build_index_name(bson_doc(foo => 1, bar => -1, baz => '2d')), 29 | 'foo_bar_baz', 'right index name'; 30 | 31 | # Insert documents blocking 32 | my $oids = $collection->insert([{foo => 'bar'}, {foo => 'baz'}]); 33 | isa_ok $oids->[0], 'Mango::BSON::ObjectID', 'right class'; 34 | isa_ok $oids->[1], 'Mango::BSON::ObjectID', 'right class'; 35 | is $collection->find_one($oids->[0])->{foo}, 'bar', 'right value'; 36 | is $collection->find_one($oids->[1])->{foo}, 'baz', 'right value'; 37 | 38 | # Get collection statistics blocking 39 | is $collection->stats->{count}, 2, 'right number of documents'; 40 | 41 | # Get collection statistics non-blocking 42 | my ($fail, $result) = @_; 43 | $collection->stats( 44 | sub { 45 | my ($collection, $err, $stats) = @_; 46 | $fail = $err; 47 | $result = $stats; 48 | Mojo::IOLoop->stop; 49 | } 50 | ); 51 | Mojo::IOLoop->start; 52 | ok !$fail, 'no error'; 53 | is $result->{count}, 2, 'right number of documents'; 54 | 55 | # Update documents blocking 56 | is $collection->update({}, {'$set' => {bar => 'works'}}, {multi => 1})->{n}, 57 | 2, 'two documents updated'; 58 | is $collection->update({}, {'$set' => {baz => 'too'}})->{n}, 1, 59 | 'one document updated'; 60 | is $collection->find_one($oids->[0])->{bar}, 'works', 'right value'; 61 | is $collection->find_one($oids->[1])->{bar}, 'works', 'right value'; 62 | is $collection->update({missing => 1}, {now => 'there'}, {upsert => 1})->{n}, 63 | 1, 'one document updated'; 64 | is $collection->update({missing => 1}, {now => 'there'}, {upsert => 1})->{n}, 65 | 1, 'one document updated'; 66 | is $collection->remove({now => 'there'}, {single => 1})->{n}, 1, 67 | 'one document removed'; 68 | is $collection->remove({now => 'there'}, {single => 1})->{n}, 1, 69 | 'one document removed'; 70 | my $oid = bson_oid; 71 | is $collection->update($oid, {foo => 'bar'})->{n}, 0, 'no documents updated'; 72 | is $collection->update($oid, {foo => 'bar'}, {upsert => 1})->{n}, 1, 73 | 'one document updated'; 74 | is $collection->update($oid, {foo => 'works'})->{n}, 1, 'one document updated'; 75 | is $collection->find_one($oid)->{foo}, 'works', 'right value'; 76 | is $collection->remove($oid)->{n}, 1, 'one document removed'; 77 | 78 | # Remove one document blocking 79 | is $collection->remove({foo => 'baz'})->{n}, 1, 'one document removed'; 80 | ok $collection->find_one($oids->[0]), 'document still exists'; 81 | ok !$collection->find_one($oids->[1]), 'no document'; 82 | is $collection->remove->{n}, 1, 'one document removed'; 83 | ok !$collection->find_one($oids->[0]), 'no document'; 84 | 85 | # Find and modify document blocking 86 | $oid = $collection->insert({atomic => 1}); 87 | is $collection->find_one($oid)->{atomic}, 1, 'right document'; 88 | my $doc = $collection->find_and_modify( 89 | {query => {atomic => 1}, update => {'$set' => {atomic => 2}}}); 90 | is $doc->{atomic}, 1, 'right document'; 91 | is $collection->find_one($oid)->{atomic}, 2, 'right document'; 92 | is $collection->remove({atomic => 2})->{n}, 1, 'removed one document'; 93 | 94 | # Find and modify document non-blocking 95 | $oid = $collection->insert({atomic => 1}); 96 | is $collection->find_one($oid)->{atomic}, 1, 'right document'; 97 | ($fail, $result) = (); 98 | $collection->find_and_modify( 99 | {query => {atomic => 1}, update => {'$set' => {atomic => 2}}} => sub { 100 | my ($collection, $err, $doc) = @_; 101 | $fail = $err; 102 | $result = $doc; 103 | Mojo::IOLoop->stop; 104 | } 105 | ); 106 | Mojo::IOLoop->start; 107 | ok !$fail, 'no error'; 108 | is $result->{atomic}, 1, 'right document'; 109 | is $collection->find_one($oid)->{atomic}, 2, 'right document'; 110 | is $collection->remove({atomic => 2})->{n}, 1, 'removed one document'; 111 | 112 | # Get options blocking 113 | is $collection->options->{name}, $collection->full_name, 'right name'; 114 | 115 | # Get options non-blocking 116 | ($fail, $result) = (); 117 | $collection->options( 118 | sub { 119 | my ($collection, $err, $doc) = @_; 120 | $fail = $err; 121 | $result = $doc; 122 | Mojo::IOLoop->stop; 123 | } 124 | ); 125 | Mojo::IOLoop->start; 126 | ok !$fail, 'no error'; 127 | is $result->{name}, $collection->full_name, 'right name'; 128 | 129 | # Get options blocking (missing collection) 130 | is $mango->db->collection('collection_test2')->options, undef, 131 | 'collection does not exist'; 132 | 133 | # Get options non-blocking (missing collection) 134 | ($fail, $result) = (); 135 | $mango->db->collection('collection_test2')->options( 136 | sub { 137 | my ($collection, $err, $doc) = @_; 138 | $fail = $err; 139 | $result = $doc; 140 | Mojo::IOLoop->stop; 141 | } 142 | ); 143 | Mojo::IOLoop->start; 144 | ok !$fail, 'no error'; 145 | is $result, undef, 'collection does not exist'; 146 | 147 | # Aggregate collection blocking 148 | $collection->insert([{more => 1}, {more => 2}, {more => 3}]); 149 | my $cursor = $collection->aggregate( 150 | [{'$group' => {_id => undef, total => {'$sum' => '$more'}}}]); 151 | ok !$cursor->id, 'no cursor id'; 152 | is $cursor->next->{total}, 6, 'right result'; 153 | is $collection->remove({more => {'$exists' => 1}})->{n}, 3, 154 | 'three documents removed'; 155 | 156 | # Aggregate collection non-blocking 157 | $collection->insert([{more => 1}, {more => 2}, {more => 3}]); 158 | ($fail, $result) = (); 159 | $collection->aggregate( 160 | [{'$group' => {_id => undef, total => {'$sum' => '$more'}}}] => sub { 161 | my ($collection, $err, $cursor) = @_; 162 | $fail = $err; 163 | $result = $cursor; 164 | Mojo::IOLoop->stop; 165 | } 166 | ); 167 | Mojo::IOLoop->start; 168 | ok !$fail, 'no error'; 169 | is $result->next->{total}, 6, 'right result'; 170 | is $collection->remove({more => {'$exists' => 1}})->{n}, 3, 171 | 'three documents removed'; 172 | 173 | # Explain aggregation 174 | $collection->insert({stuff => $_}) for 1 .. 30; 175 | $doc = $collection->aggregate([{'$match' => {stuff => {'$gt' => 0}}}], 176 | {explain => \1}); 177 | ok $doc->{stages}, 'right result'; 178 | is $collection->remove->{n}, 30, 'thirty documents removed'; 179 | 180 | # Aggregate with collections 181 | $collection->insert({stuff => $_}) for 1 .. 30; 182 | my $out = $collection->aggregate( 183 | [ 184 | {'$match' => {stuff => {'$gt' => 0}}}, 185 | {'$out' => 'collection_test_results'} 186 | ] 187 | ); 188 | is $out->name, 'collection_test_results', 'right name'; 189 | is $out->find->count, 30, 'thirty documents found'; 190 | $out->drop; 191 | is $collection->remove->{n}, 30, 'thirty documents removed'; 192 | 193 | # Aggregate with cursor blocking (multiple batches) 194 | $collection->insert({stuff => $_}) for 1 .. 30; 195 | $cursor = $collection->aggregate([{'$match' => {stuff => {'$gt' => 0}}}], 196 | {cursor => {batchSize => 5}}); 197 | ok $cursor->id, 'cursor has id'; 198 | is scalar @{$cursor->all}, 30, 'thirty documents found'; 199 | is $collection->remove->{n}, 30, 'thirty documents removed'; 200 | 201 | # Aggregate with cursor non-blocking (multiple batches) 202 | $collection->insert({stuff => $_}) for 1 .. 30; 203 | ($fail, $result) = (); 204 | my $delay = Mojo::IOLoop->delay( 205 | sub { 206 | my $delay = shift; 207 | $collection->aggregate( 208 | [{'$match' => {stuff => {'$gt' => 0}}}], 209 | {cursor => {batchSize => 5}}, 210 | $delay->begin 211 | ); 212 | }, 213 | sub { 214 | my ($delay, $err, $cursor) = @_; 215 | return $delay->pass($err) if $err; 216 | $cursor->all($delay->begin); 217 | }, 218 | sub { 219 | my ($delay, $err, $docs) = @_; 220 | $fail = $err; 221 | $result = $docs; 222 | } 223 | ); 224 | $delay->wait; 225 | is scalar @$result, 30, 'thirty documents found'; 226 | is $collection->remove->{n}, 30, 'thirty documents removed'; 227 | 228 | # Save document blocking 229 | $oid = $collection->save({update => 'me'}); 230 | $doc = $collection->find_one($oid); 231 | is $doc->{update}, 'me', 'right document'; 232 | $doc->{update} = 'too'; 233 | is $collection->save($doc), $oid, 'same object id'; 234 | $doc = $collection->find_one($oid); 235 | is $doc->{update}, 'too', 'right document'; 236 | is $collection->remove($oid)->{n}, 1, 'one document removed'; 237 | $oid = bson_oid; 238 | $doc = bson_doc _id => $oid, save => 'me'; 239 | is $collection->save($doc), $oid, 'same object id'; 240 | $doc = $collection->find_one($oid); 241 | is $doc->{save}, 'me', 'right document'; 242 | is $collection->remove({_id => $oid})->{n}, 1, 'one document removed'; 243 | 244 | # Save document non-blocking 245 | ($fail, $result) = (); 246 | $collection->save( 247 | {update => 'me'} => sub { 248 | my ($collection, $err, $oid) = @_; 249 | $fail = $err; 250 | $result = $oid; 251 | Mojo::IOLoop->stop; 252 | } 253 | ); 254 | Mojo::IOLoop->start; 255 | ok !$fail, 'no error'; 256 | $doc = $collection->find_one($result); 257 | is $doc->{update}, 'me', 'right document'; 258 | $doc->{update} = 'too'; 259 | $oid = $result; 260 | ($fail, $result) = (); 261 | $collection->save( 262 | $doc => sub { 263 | my ($collection, $err, $oid) = @_; 264 | $fail = $err; 265 | $result = $oid; 266 | Mojo::IOLoop->stop; 267 | } 268 | ); 269 | Mojo::IOLoop->start; 270 | ok !$fail, 'no error'; 271 | is $oid, $result, 'same object id'; 272 | $doc = $collection->find_one($oid); 273 | is $doc->{update}, 'too', 'right document'; 274 | is $collection->remove($oid)->{n}, 1, 'one document removed'; 275 | $oid = bson_oid; 276 | $doc = bson_doc _id => $oid, save => 'me'; 277 | ($fail, $result) = (); 278 | $collection->save( 279 | $doc => sub { 280 | my ($collection, $err, $oid) = @_; 281 | $fail = $err; 282 | $result = $oid; 283 | Mojo::IOLoop->stop; 284 | } 285 | ); 286 | Mojo::IOLoop->start; 287 | ok !$fail, 'no error'; 288 | is $oid, $result, 'same object id'; 289 | $doc = $collection->find_one($oid, {_id => 0}); 290 | is_deeply $doc, {save => 'me'}, 'right document'; 291 | is $collection->remove($oid)->{n}, 1, 'one document removed'; 292 | 293 | # Drop collection blocking 294 | $oid = $collection->insert({just => 'works'}); 295 | is $collection->find_one($oid)->{just}, 'works', 'right document'; 296 | $collection->drop; 297 | ok !$collection->find_one($oid), 'no document'; 298 | 299 | # Drop collection non-blocking 300 | $oid = $collection->insert({just => 'works'}); 301 | is $collection->find_one($oid)->{just}, 'works', 'right document'; 302 | $fail = undef; 303 | $collection->drop( 304 | sub { 305 | my ($collection, $err) = @_; 306 | $fail = $err; 307 | Mojo::IOLoop->stop; 308 | } 309 | ); 310 | Mojo::IOLoop->start; 311 | ok !$fail, 'no error'; 312 | ok !$collection->find_one($oid), 'no document'; 313 | 314 | # Ensure and drop index blocking 315 | $collection->insert({test => 23, foo => 'bar'}); 316 | $collection->ensure_index({test => 1}, {unique => \1}); 317 | is $collection->find->count, 1, 'one document'; 318 | is $collection->index_information->{test}{unique}, bson_true, 319 | 'index is unique'; 320 | $collection->drop_index('test'); 321 | is $collection->index_information->{test}, undef, 'no index'; 322 | $collection->drop; 323 | 324 | # Ensure and drop index non-blocking 325 | $collection->insert({test => 23, foo => 'bar'}); 326 | ($fail, $result) = (); 327 | $delay = Mojo::IOLoop->delay( 328 | sub { 329 | my $delay = shift; 330 | $collection->ensure_index(({test => 1}, {unique => \1}) => $delay->begin); 331 | }, 332 | sub { 333 | my ($delay, $err) = @_; 334 | return $delay->pass($err) if $err; 335 | $collection->index_information($delay->begin); 336 | }, 337 | sub { 338 | my ($delay, $err, $info) = @_; 339 | $fail = $err; 340 | $result = $info; 341 | } 342 | ); 343 | $delay->wait; 344 | ok !$fail, 'no error'; 345 | is $collection->find->count, 1, 'one document'; 346 | is $result->{test}{unique}, bson_true, 'index is unique'; 347 | ($fail, $result) = (); 348 | $delay = Mojo::IOLoop->delay( 349 | sub { 350 | my $delay = shift; 351 | $collection->drop_index(test => $delay->begin); 352 | }, 353 | sub { 354 | my ($delay, $err) = @_; 355 | return $delay->pass($err) if $err; 356 | $collection->index_information($delay->begin); 357 | }, 358 | sub { 359 | my ($delay, $err, $info) = @_; 360 | $fail = $err; 361 | $result = $info; 362 | } 363 | ); 364 | $delay->wait; 365 | ok !$fail, 'no error'; 366 | is $result->{test}, undef, 'no index'; 367 | $collection->drop; 368 | 369 | # Create capped collection blocking 370 | $collection->create({capped => \1, max => 2, size => 100000}); 371 | $collection->insert([{test => 1}, {test => 2}]); 372 | is $collection->find({})->count, 2, 'two documents'; 373 | $collection->insert({test => 3}); 374 | is $collection->find->count, 2, 'two documents'; 375 | $collection->drop; 376 | 377 | # Create capped collection non-blocking 378 | $fail = undef; 379 | $collection->create( 380 | {capped => \1, max => 2, size => 100000} => sub { 381 | my ($collection, $err) = @_; 382 | $fail = $err; 383 | Mojo::IOLoop->stop; 384 | } 385 | ); 386 | Mojo::IOLoop->start; 387 | ok !$fail, 'no error'; 388 | $collection->insert([{test => 1}, {test => 2}]); 389 | is $collection->find({})->count, 2, 'two documents'; 390 | $collection->insert({test => 3}); 391 | is $collection->find->count, 2, 'two documents'; 392 | $collection->drop; 393 | 394 | # Perform map/reduce blocking 395 | my $map = <insert({x => 1, tags => [qw(dog cat)]}); 412 | $collection->insert({x => 2, tags => ['cat']}); 413 | $collection->insert({x => 3, tags => [qw(mouse cat dog)]}); 414 | $collection->insert({x => 4, tags => []}); 415 | $out 416 | = $collection->map_reduce($map, $reduce, {out => 'collection_test_results'}); 417 | $collection->drop; 418 | my $docs = $out->find->sort({value => -1})->all; 419 | is_deeply $docs->[0], {_id => 'cat', value => 3}, 'right document'; 420 | is_deeply $docs->[1], {_id => 'dog', value => 2}, 'right document'; 421 | is_deeply $docs->[2], {_id => 'mouse', value => 1}, 'right document'; 422 | $out->drop; 423 | 424 | # Perform map/reduce non-blocking 425 | $collection->insert({x => 1, tags => [qw(dog cat)]}); 426 | $collection->insert({x => 2, tags => ['cat']}); 427 | $collection->insert({x => 3, tags => [qw(mouse cat dog)]}); 428 | $collection->insert({x => 4, tags => []}); 429 | ($fail, $result) = (); 430 | $collection->map_reduce( 431 | ($map, $reduce, {out => 'collection_test_results'}) => sub { 432 | my ($collection, $err, $out) = @_; 433 | $fail = $err; 434 | $result = $out; 435 | Mojo::IOLoop->stop; 436 | } 437 | ); 438 | Mojo::IOLoop->start; 439 | ok !$fail, 'no error'; 440 | $collection->drop; 441 | $docs = $result->find->sort({value => -1})->all; 442 | is_deeply $docs->[0], {_id => 'cat', value => 3}, 'right document'; 443 | is_deeply $docs->[1], {_id => 'dog', value => 2}, 'right document'; 444 | is_deeply $docs->[2], {_id => 'mouse', value => 1}, 'right document'; 445 | $result->drop; 446 | 447 | # Perform inline map/reduce blocking 448 | $collection->insert({x => 1, tags => [qw(dog cat)]}); 449 | $collection->insert({x => 2, tags => ['cat']}); 450 | $collection->insert({x => 3, tags => [qw(mouse cat dog)]}); 451 | $collection->insert({x => 4, tags => []}); 452 | $docs = $collection->map_reduce(bson_code($map), bson_code($reduce), 453 | {out => {inline => 1}}); 454 | $collection->drop; 455 | is_deeply $docs->[0], {_id => 'cat', value => 3}, 'right document'; 456 | is_deeply $docs->[1], {_id => 'dog', value => 2}, 'right document'; 457 | is_deeply $docs->[2], {_id => 'mouse', value => 1}, 'right document'; 458 | 459 | # Perform inline map/reduce non-blocking 460 | $collection->insert({x => 1, tags => [qw(dog cat)]}); 461 | $collection->insert({x => 2, tags => ['cat']}); 462 | $collection->insert({x => 3, tags => [qw(mouse cat dog)]}); 463 | $collection->insert({x => 4, tags => []}); 464 | ($fail, $result) = (); 465 | $collection->map_reduce( 466 | (bson_code($map), bson_code($reduce), {out => {inline => 1}}) => sub { 467 | my ($collection, $err, $docs) = @_; 468 | $fail = $err; 469 | $result = $docs; 470 | Mojo::IOLoop->stop; 471 | } 472 | ); 473 | Mojo::IOLoop->start; 474 | ok !$fail, 'no error'; 475 | $collection->drop; 476 | is_deeply $result->[0], {_id => 'cat', value => 3}, 'right document'; 477 | is_deeply $result->[1], {_id => 'dog', value => 2}, 'right document'; 478 | is_deeply $result->[2], {_id => 'mouse', value => 1}, 'right document'; 479 | 480 | # Insert same document twice blocking 481 | $doc = bson_doc _id => bson_oid, foo => 'bar'; 482 | $collection->insert($doc); 483 | eval { $collection->insert($doc) }; 484 | like $@, qr/^Write error at index 0: .+/, 'right error'; 485 | $collection->drop; 486 | 487 | # Insert same document twice non-blocking 488 | $doc = bson_doc _id => bson_oid, foo => 'bar'; 489 | $collection->insert($doc); 490 | $fail = undef; 491 | $collection->insert( 492 | $doc => sub { 493 | my ($collection, $err) = @_; 494 | $fail = $err; 495 | Mojo::IOLoop->stop; 496 | } 497 | ); 498 | Mojo::IOLoop->start; 499 | like $fail, qr/^Write error at index 0: .+/, 'right error'; 500 | 501 | # Insert same document twice blocking (upsert) 502 | $doc = bson_doc _id => bson_oid, foo => 'bar'; 503 | $collection->insert($doc); 504 | eval { $collection->update({foo => 'baz'}, $doc, {upsert => 1}) }; 505 | like $@, qr/^Write error at index 0: .+/, 'right error'; 506 | $collection->drop; 507 | 508 | # Insert same document twice non-blocking (upsert) 509 | $doc = bson_doc _id => bson_oid, foo => 'bar'; 510 | $collection->insert($doc); 511 | $fail = undef; 512 | $collection->update( 513 | {foo => 'baz'} => $doc => {upsert => 1} => sub { 514 | my ($collection, $err) = @_; 515 | $fail = $err; 516 | Mojo::IOLoop->stop; 517 | } 518 | ); 519 | Mojo::IOLoop->start; 520 | like $fail, qr/^Write error at index 0: .+/, 'right error'; 521 | 522 | # Interrupted non-blocking remove 523 | my $id 524 | = Mojo::IOLoop->server((address => '127.0.0.1') => sub { $_[1]->close }); 525 | my $port = Mojo::IOLoop->acceptor($id)->handle->sockport; 526 | $mango = Mango->new("mongodb://localhost:$port"); 527 | ($fail, $result) = (); 528 | $mango->db->collection('collection_test')->remove( 529 | sub { 530 | my ($collection, $err, $doc) = @_; 531 | $fail = $err; 532 | $result = $doc; 533 | Mojo::IOLoop->stop; 534 | } 535 | ); 536 | Mojo::IOLoop->start; 537 | Mojo::IOLoop->remove($id); 538 | like $fail, qr/Premature connection close/, 'right error'; 539 | ok !$result->{n}, 'remove was not successful'; 540 | 541 | done_testing(); 542 | -------------------------------------------------------------------------------- /t/connection.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | 3 | use Test::More; 4 | 5 | plan skip_all => 'set TEST_ONLINE to enable this test' 6 | unless $ENV{TEST_ONLINE}; 7 | 8 | use Mango; 9 | use Mojo::IOLoop; 10 | use Mojo::IOLoop::Server; 11 | 12 | # Defaults 13 | my $mango = Mango->new; 14 | is_deeply $mango->hosts, [['localhost']], 'right hosts'; 15 | is $mango->default_db, 'admin', 'right default database'; 16 | is_deeply $mango->credentials, [], 'no credentials'; 17 | is $mango->inactivity_timeout, 0, 'right timeout value'; 18 | is $mango->j, 0, 'right j value'; 19 | is $mango->w, 1, 'right w value'; 20 | is $mango->wtimeout, 1000, 'right wtimeout value'; 21 | is $mango->backlog, 0, 'no operations waiting'; 22 | 23 | # Simple connection string 24 | $mango = Mango->new('mongodb://127.0.0.1:3000'); 25 | is_deeply $mango->hosts, [['127.0.0.1', 3000]], 'right hosts'; 26 | is $mango->default_db, 'admin', 'right default database'; 27 | is_deeply $mango->credentials, [], 'no credentials'; 28 | is $mango->j, 0, 'right j value'; 29 | is $mango->w, 1, 'right w value'; 30 | is $mango->wtimeout, 1000, 'right wtimeout value'; 31 | 32 | # Complex connection string 33 | $mango = Mango->new( 34 | 'mongodb://x1:y2@foo.bar:5000,baz:3000/test?journal=1&w=2&wtimeoutMS=2000'); 35 | is_deeply $mango->hosts, [['foo.bar', 5000], ['baz', 3000]], 'right hosts'; 36 | is $mango->default_db, 'test', 'right default database'; 37 | is_deeply $mango->credentials, [[qw(test x1 y2)]], 'right credentials'; 38 | is $mango->j, 1, 'right j value'; 39 | is $mango->w, 2, 'right w value'; 40 | is $mango->wtimeout, 2000, 'right wtimeout value'; 41 | is $mango->db->name, 'test', 'right database name'; 42 | 43 | # Invalid connection string 44 | eval { Mango->new('http://localhost:3000/test') }; 45 | like $@, qr/Invalid MongoDB connection string/, 'right error'; 46 | 47 | # No port 48 | $mango = Mango->new->from_string('mongodb://127.0.0.1,127.0.0.1:5000'); 49 | is_deeply $mango->hosts, [['127.0.0.1'], ['127.0.0.1', 5000]], 'right hosts'; 50 | 51 | # Connection error 52 | my $port = Mojo::IOLoop::Server->generate_port; 53 | eval { Mango->new("mongodb://127.0.0.1:$port/test")->db->command('getnonce') }; 54 | ok $@, 'has error'; 55 | 56 | # Clean up before start 57 | $mango = Mango->new($ENV{TEST_ONLINE}); 58 | my $collection = $mango->db->collection('connection_test'); 59 | $collection->drop if $collection->options; 60 | 61 | # Blocking CRUD 62 | my $oid = $collection->insert({foo => 'bar'}); 63 | is $mango->backlog, 0, 'no operations waiting'; 64 | isa_ok $oid, 'Mango::BSON::ObjectID', 'right class'; 65 | my $doc = $collection->find_one({foo => 'bar'}); 66 | is_deeply $doc, {_id => $oid, foo => 'bar'}, 'right document'; 67 | $doc->{foo} = 'yada'; 68 | is $collection->update({foo => 'bar'}, $doc)->{n}, 1, 'one document updated'; 69 | $doc = $collection->find_one($oid); 70 | is_deeply $doc, {_id => $oid, foo => 'yada'}, 'right document'; 71 | is $collection->remove->{n}, 1, 'one document removed'; 72 | 73 | # Non-blocking CRUD 74 | my ($fail, $backlog, $created, $updated, $found, $removed); 75 | my $delay = Mojo::IOLoop->delay( 76 | sub { 77 | my $delay = shift; 78 | $collection->insert({foo => 'bar'} => $delay->begin); 79 | $backlog = $collection->db->mango->backlog; 80 | }, 81 | sub { 82 | my ($delay, $err, $oid) = @_; 83 | return $delay->pass($err) if $err; 84 | $created = $oid; 85 | $collection->find_one({foo => 'bar'} => $delay->begin); 86 | }, 87 | sub { 88 | my ($delay, $err, $doc) = @_; 89 | return $delay->pass($err) if $err; 90 | $doc->{foo} = 'yada'; 91 | $collection->update(({foo => 'bar'}, $doc) => $delay->begin); 92 | }, 93 | sub { 94 | my ($delay, $err, $doc) = @_; 95 | return $delay->pass($err) if $err; 96 | $updated = $doc; 97 | $collection->find_one($created => $delay->begin); 98 | }, 99 | sub { 100 | my ($delay, $err, $doc) = @_; 101 | return $delay->pass($err) if $err; 102 | $found = $doc; 103 | $collection->remove($delay->begin); 104 | }, 105 | sub { 106 | my ($delay, $err, $doc) = @_; 107 | $fail = $err; 108 | $removed = $doc; 109 | } 110 | ); 111 | $delay->wait; 112 | ok !$fail, 'no error'; 113 | is $backlog, 1, 'one operation waiting'; 114 | isa_ok $created, 'Mango::BSON::ObjectID', 'right class'; 115 | is $updated->{n}, 1, 'one document updated'; 116 | is_deeply $found, {_id => $created, foo => 'yada'}, 'right document'; 117 | is $removed->{n}, 1, 'one document removed'; 118 | 119 | # Error in callback 120 | Mojo::IOLoop->singleton->reactor->unsubscribe('error'); 121 | $fail = undef; 122 | Mojo::IOLoop->singleton->reactor->once( 123 | error => sub { $fail .= pop; Mojo::IOLoop->stop }); 124 | $collection->insert({foo => 'bar'} => sub { die 'Oops!' }); 125 | Mojo::IOLoop->start; 126 | like $fail, qr/Oops!/, 'right error'; 127 | is $collection->remove->{n}, 1, 'one document removed'; 128 | 129 | # Fork safety 130 | $mango = Mango->new($ENV{TEST_ONLINE}); 131 | $collection = $mango->db->collection('connection_test'); 132 | my ($connections, $current); 133 | $mango->on( 134 | connection => sub { 135 | my ($mango, $id) = @_; 136 | $connections++; 137 | $current = $id; 138 | } 139 | ); 140 | is $collection->find->count, 0, 'no documents'; 141 | is $connections, 1, 'one connection'; 142 | ok $mango->ioloop->stream($current), 'connection exists'; 143 | my $last = $current; 144 | is $collection->find->count, 0, 'no documents'; 145 | is $connections, 1, 'one connection'; 146 | ok $mango->ioloop->stream($current), 'connection exists'; 147 | is $last, $current, 'same connection'; 148 | { 149 | local $$ = -23; 150 | is $collection->find->count, 0, 'no documents'; 151 | is $connections, 2, 'two connections'; 152 | ok $mango->ioloop->stream($current), 'connection exists'; 153 | isnt $last, $current, 'different connections'; 154 | $last = $current; 155 | is $collection->find->count, 0, 'no documents'; 156 | is $connections, 2, 'two connections'; 157 | ok $mango->ioloop->stream($current), 'connection exists'; 158 | is $last, $current, 'same connection'; 159 | } 160 | 161 | # Mixed concurrent operations 162 | $collection->insert({test => $_}) for 1 .. 3; 163 | is $mango->backlog, 0, 'no operations waiting'; 164 | my @results; 165 | $delay = Mojo::IOLoop->delay(sub { shift; @results = @_ }); 166 | $collection->find_one(({test => $_}, {_id => 0}) => $delay->begin) for 1 .. 3; 167 | is $mango->backlog, 3, 'three operations waiting'; 168 | is $collection->find_one({test => 1})->{test}, 1, 'right result'; 169 | $delay->wait; 170 | is $mango->backlog, 0, 'no operations waiting'; 171 | ok !$results[0], 'no error'; 172 | is_deeply $results[1], {test => 1}, 'right result'; 173 | ok !$results[2], 'no error'; 174 | is_deeply $results[3], {test => 2}, 'right result'; 175 | ok !$results[4], 'no error'; 176 | is_deeply $results[5], {test => 3}, 'right result'; 177 | is $collection->remove->{n}, 3, 'three documents removed'; 178 | 179 | # Fallback server 180 | $mango = Mango->new($ENV{TEST_ONLINE}); 181 | $port = Mojo::IOLoop::Server->generate_port; 182 | unshift @{$mango->hosts}, ['127.0.0.1', $port]; 183 | ok $mango->db->command('getnonce')->{nonce}, 'command was successful'; 184 | is_deeply $mango->hosts->[0], ['127.0.0.1', $port], 'right server'; 185 | ok scalar @{$mango->hosts} > 1, 'more than one server'; 186 | 187 | done_testing(); 188 | -------------------------------------------------------------------------------- /t/cursor.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | 3 | use Test::More; 4 | 5 | plan skip_all => 'set TEST_ONLINE to enable this test' 6 | unless $ENV{TEST_ONLINE}; 7 | 8 | use Mango; 9 | use Mojo::IOLoop; 10 | 11 | # Clean up before start 12 | my $mango = Mango->new($ENV{TEST_ONLINE}); 13 | my $collection = $mango->db->collection('cursor_test'); 14 | $collection->drop if $collection->options; 15 | 16 | # Add some documents to fetch 17 | my $oids = $collection->insert([{test => 3}, {test => 1}, {test => 2}]); 18 | is scalar @$oids, 3, 'three documents inserted'; 19 | 20 | # Fetch documents blocking 21 | my $cursor = $collection->find->batch_size(2); 22 | my @docs; 23 | ok !$cursor->id, 'no cursor id'; 24 | push @docs, $cursor->next; 25 | ok $cursor->id, 'cursor has id'; 26 | push @docs, $cursor->next; 27 | push @docs, $cursor->next; 28 | ok !$cursor->next, 'no more documents'; 29 | @docs = sort { $a->{test} <=> $b->{test} } @docs; 30 | is $docs[0]{test}, 1, 'right document'; 31 | is $docs[1]{test}, 2, 'right document'; 32 | is $docs[2]{test}, 3, 'right document'; 33 | 34 | # Fetch all documents blocking 35 | my $docs = $collection->find->batch_size(2)->all; 36 | @$docs = sort { $a->{test} <=> $b->{test} } @$docs; 37 | is $docs->[0]{test}, 1, 'right document'; 38 | is $docs->[1]{test}, 2, 'right document'; 39 | is $docs->[2]{test}, 3, 'right document'; 40 | 41 | # Fetch two documents blocking 42 | $docs = $collection->find->limit(-2)->sort({test => 1})->all; 43 | is scalar @$docs, 2, 'two documents'; 44 | is $docs->[0]{test}, 1, 'right document'; 45 | is $docs->[1]{test}, 2, 'right document'; 46 | 47 | # Build query 48 | $cursor = $collection->find({test => 1}); 49 | is_deeply $cursor->build_query, {test => 1}, 'right query'; 50 | is_deeply $cursor->build_query(1), {'$query' => {test => 1}, '$explain' => 1}, 51 | 'right query'; 52 | $cursor->sort({test => -1}); 53 | is_deeply $cursor->build_query, 54 | {'$query' => {test => 1}, '$orderby' => {test => -1}}, 'right query'; 55 | $cursor->sort(undef)->hint({test => 1})->snapshot(1); 56 | is_deeply $cursor->build_query, 57 | {'$query' => {test => 1}, '$hint' => {test => 1}, '$snapshot' => 1}, 58 | 'right query'; 59 | $cursor->hint(undef)->snapshot(undef)->max_scan(500); 60 | is_deeply $cursor->build_query, {'$query' => {test => 1}, '$maxScan' => 500}, 61 | 'right query'; 62 | $cursor = $collection->find({'$query' => {foo => 'bar'}, '$foo' => 'bar'}); 63 | is_deeply $cursor->build_query, {'$query' => {foo => 'bar'}, '$foo' => 'bar'}, 64 | 'right query'; 65 | $cursor = $collection->find({'$query' => {foo => 'bar'}, '$foo' => 'bar'}); 66 | is_deeply $cursor->build_query(1), 67 | {'$query' => {foo => 'bar'}, '$foo' => 'bar', '$explain' => 1}, 68 | 'right query'; 69 | is_deeply $cursor->query, {'$query' => {foo => 'bar'}, '$foo' => 'bar'}, 70 | 'query has not changed'; 71 | $cursor = $collection->find({})->comment('Test!')->max_time_ms(500); 72 | is_deeply $cursor->build_query, 73 | {'$query' => {}, '$comment' => 'Test!', '$maxTimeMS' => 500}, 'right query'; 74 | $cursor = $collection->find({})->read_preference({mode => 'SECONDARY'}); 75 | is_deeply $cursor->build_query, 76 | {'$query' => {}, '$readPreference' => {mode => 'SECONDARY'}}, 'right query'; 77 | 78 | # Clone cursor 79 | $cursor 80 | = $collection->find({test => {'$exists' => 1}})->batch_size(2) 81 | ->comment('Test')->limit(3)->skip(1)->sort({test => 1})->fields({test => 1}) 82 | ->max_scan(100); 83 | my $doc = $cursor->next; 84 | ok defined $cursor->id, 'has a cursor id'; 85 | ok $doc->{test}, 'right document'; 86 | my $clone 87 | = $cursor->snapshot(1)->hint({test => 1})->max_time_ms(500)->tailable(1) 88 | ->await_data(1)->read_preference({mode => 'SECONDARY'})->clone; 89 | isnt $cursor, $clone, 'different objects'; 90 | ok !defined $clone->id, 'has no cursor id'; 91 | is $clone->batch_size, 2, 'right batch size'; 92 | is $clone->comment, 'Test', 'right comment'; 93 | is_deeply $clone->fields, {test => 1}, 'right fields'; 94 | is_deeply $clone->hint, {test => 1}, 'right hint value'; 95 | is $clone->limit, 3, 'right limit'; 96 | is_deeply $clone->query, {test => {'$exists' => 1}}, 'right query'; 97 | is $clone->skip, 1, 'right skip value'; 98 | is $clone->snapshot, 1, 'right snapshot value'; 99 | is $clone->max_scan, 100, 'right max_scan value'; 100 | is $clone->max_time_ms, 500, 'right max_time_ms value'; 101 | is_deeply $clone->read_preference, {mode => 'SECONDARY'}, 'right fields'; 102 | is $clone->tailable, 1, 'is tailable'; 103 | is $clone->await_data, 1, 'is awaiting data'; 104 | is_deeply $clone->sort, {test => 1}, 'right sort value'; 105 | $cursor = $collection->find({foo => 'bar'}, {foo => 1}); 106 | is_deeply $cursor->clone->query, {foo => 'bar'}, 'right query'; 107 | is_deeply $cursor->clone->fields, {foo => 1}, 'right fields'; 108 | 109 | # Number of results to return 110 | is $collection->find->num_to_return, 0, 'right number of results'; 111 | $cursor = $collection->find; 112 | is $cursor->batch_size(5)->num_to_return, 5, 'right number of results'; 113 | $cursor = $collection->find; 114 | is $cursor->limit(5)->num_to_return, 5, 'right number of results'; 115 | $cursor = $collection->find; 116 | is $cursor->limit(-5)->num_to_return, -5, 'right number of results'; 117 | $cursor = $collection->find; 118 | is $cursor->limit(4)->batch_size(2)->num_to_return, 2, 119 | 'right number of results'; 120 | is $cursor->limit(2)->batch_size(4)->num_to_return, 2, 121 | 'right number of results'; 122 | is $cursor->limit(-4)->batch_size(2)->num_to_return, -4, 123 | 'right number of results'; 124 | is $cursor->limit(-2)->batch_size(4)->num_to_return, -2, 125 | 'right number of results'; 126 | 127 | # Explain blocking 128 | $cursor = $collection->find({test => 2}); 129 | $doc = $cursor->explain; 130 | is $doc->{n}, 1, 'one document'; 131 | $doc = $cursor->next; 132 | is $doc->{test}, 2, 'right document'; 133 | 134 | # Explain non-blocking 135 | $cursor = $collection->find({test => 2}); 136 | my ($fail, $result); 137 | $cursor->explain( 138 | sub { 139 | my ($cursor, $err, $doc) = @_; 140 | $fail = $err; 141 | $result = $doc->{n}; 142 | Mojo::IOLoop->stop; 143 | } 144 | ); 145 | Mojo::IOLoop->start; 146 | ok !$fail, 'no error'; 147 | is $result, 1, 'one document'; 148 | is $cursor->next->{test}, 2, 'right document'; 149 | 150 | # Get distinct values blocking 151 | is_deeply [ 152 | sort @{$collection->find({test => {'$gt' => 1}})->distinct('test')} 153 | ], [2, 3], 'right values'; 154 | 155 | # Get distinct values non-blocking 156 | ($fail, $result) = (); 157 | $collection->find({test => {'$gt' => 1}})->distinct( 158 | test => sub { 159 | my ($cursor, $err, $values) = @_; 160 | $fail = $err; 161 | $result = $values; 162 | Mojo::IOLoop->stop; 163 | } 164 | ); 165 | Mojo::IOLoop->start; 166 | ok !$fail, 'no error'; 167 | is_deeply [sort @$result], [2, 3], 'right values'; 168 | 169 | # Count documents blocking 170 | is $collection->find({foo => 'bar'})->count, 0, 'no documents'; 171 | is $collection->find->skip(1)->limit(1)->count, 1, 'one document'; 172 | is $collection->find->count, 3, 'three documents'; 173 | 174 | # Count documents non-blocking 175 | $fail = undef; 176 | my @results; 177 | my $delay = Mojo::IOLoop->delay( 178 | sub { 179 | my $delay = shift; 180 | $collection->find->count($delay->begin); 181 | }, 182 | sub { 183 | my ($delay, $err, $count) = @_; 184 | return $delay->pass($err) if $err; 185 | push @results, $count; 186 | $collection->find({foo => 'bar'})->count($delay->begin); 187 | }, 188 | sub { 189 | my ($delay, $err, $count) = @_; 190 | $fail = $err; 191 | push @results, $count; 192 | } 193 | ); 194 | $delay->wait; 195 | ok !$fail, 'no error'; 196 | is_deeply \@results, [3, 0], 'right number of documents'; 197 | 198 | # Fetch documents non-blocking 199 | $cursor = $collection->find->batch_size(2); 200 | @docs = (); 201 | $fail = undef; 202 | $delay = Mojo::IOLoop->delay( 203 | sub { 204 | my $delay = shift; 205 | $cursor->next($delay->begin); 206 | }, 207 | sub { 208 | my ($delay, $err, $doc) = @_; 209 | return $delay->pass($err) if $err; 210 | push @docs, $doc; 211 | $cursor->next($delay->begin); 212 | }, 213 | sub { 214 | my ($delay, $err, $doc) = @_; 215 | return $delay->pass($err) if $err; 216 | push @docs, $doc; 217 | $cursor->next($delay->begin); 218 | }, 219 | sub { 220 | my ($delay, $err, $doc) = @_; 221 | $fail = $err; 222 | push @docs, $doc; 223 | } 224 | ); 225 | $delay->wait; 226 | ok !$fail, 'no error'; 227 | @docs = sort { $a->{test} <=> $b->{test} } @docs; 228 | is $docs[0]{test}, 1, 'right document'; 229 | is $docs[1]{test}, 2, 'right document'; 230 | is $docs[2]{test}, 3, 'right document'; 231 | 232 | # Fetch all documents non-blocking 233 | @docs = (); 234 | $collection->find->batch_size(2)->all( 235 | sub { 236 | my ($collection, $err, $docs) = @_; 237 | @docs = @$docs; 238 | Mojo::IOLoop->stop; 239 | } 240 | ); 241 | Mojo::IOLoop->start; 242 | @docs = sort { $a->{test} <=> $b->{test} } @docs; 243 | is $docs[0]{test}, 1, 'right document'; 244 | is $docs[1]{test}, 2, 'right document'; 245 | is $docs[2]{test}, 3, 'right document'; 246 | 247 | # Fetch subset of documents sorted 248 | $docs = $collection->find->fields({_id => 0})->sort({test => 1})->all; 249 | is_deeply $docs, [{test => 1}, {test => 2}, {test => 3}], 'right subset'; 250 | 251 | # Rewind cursor blocking 252 | $cursor = $collection->find; 253 | ok !$cursor->id, 'no cursor id'; 254 | $cursor->rewind; 255 | $doc = $cursor->next; 256 | ok $doc, 'found a document'; 257 | $cursor->rewind; 258 | is_deeply $cursor->next, $doc, 'found same document again'; 259 | 260 | # Rewind cursor non-blocking 261 | $fail = undef; 262 | @docs = (); 263 | $cursor = $collection->find; 264 | $delay = Mojo::IOLoop->delay( 265 | sub { 266 | my $delay = shift; 267 | $cursor->next($delay->begin); 268 | }, 269 | sub { 270 | my ($delay, $err, $doc) = @_; 271 | return $delay->pass($err) if $err; 272 | push @docs, $doc; 273 | $cursor->rewind($delay->begin); 274 | }, 275 | sub { 276 | my ($delay, $err) = @_; 277 | return $delay->pass($err) if $err; 278 | $cursor->next($delay->begin); 279 | }, 280 | sub { 281 | my ($delay, $err, $doc) = @_; 282 | $fail = $err; 283 | push @docs, $doc; 284 | } 285 | ); 286 | $delay->wait; 287 | ok !$fail, 'no error'; 288 | is_deeply $docs[0], $docs[1], 'found same document again'; 289 | is $collection->remove->{n}, 3, 'three documents removed'; 290 | 291 | # Try to restart aggregate cursor 292 | $collection->insert({stuff => $_}) for 1 .. 30; 293 | $cursor = $collection->aggregate([{'$match' => {stuff => {'$gt' => 0}}}], 294 | {cursor => {batchSize => 5}}); 295 | is $cursor->next->{stuff}, 1, 'right result'; 296 | ok $cursor->id, 'cursor has id'; 297 | $cursor->rewind; 298 | ok !$cursor->id, 'no cursor id'; 299 | eval { $cursor->next }; 300 | like $@, qr/Cursor cannot be restarted/, 'right error'; 301 | is $collection->remove->{n}, 30, 'thirty documents removed'; 302 | 303 | # Tailable cursor 304 | $collection->drop; 305 | $collection->create({capped => \1, max => 2, size => 100000}); 306 | my $collection2 = $mango->db->collection('cursor_test'); 307 | $collection2->insert([{test => 1}, {test => 2}]); 308 | $cursor = $collection->find->tailable(1)->await_data(1); 309 | is $cursor->next->{test}, 1, 'right document'; 310 | is $cursor->next->{test}, 2, 'right document'; 311 | ($fail, $result) = (); 312 | my $tail; 313 | $delay = Mojo::IOLoop->delay( 314 | sub { 315 | my $delay = shift; 316 | my $end = $delay->begin; 317 | $cursor->next($delay->begin); 318 | Mojo::IOLoop->timer( 319 | 0.5 => sub { $collection2->insert({test => 3} => $end) }); 320 | }, 321 | sub { 322 | my ($delay, $err1, $oid, $err2, $doc) = @_; 323 | $fail = $err1 || $err2; 324 | $result = $oid; 325 | $tail = $doc; 326 | } 327 | ); 328 | $delay->wait; 329 | ok !$fail, 'no error'; 330 | is $tail->{test}, 3, 'right document'; 331 | is $tail->{_id}, $result, 'same document'; 332 | $collection->drop; 333 | 334 | done_testing(); 335 | -------------------------------------------------------------------------------- /t/database.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | 3 | use Test::More; 4 | 5 | plan skip_all => 'set TEST_ONLINE to enable this test' 6 | unless $ENV{TEST_ONLINE}; 7 | 8 | use Mango; 9 | use Mango::BSON qw(bson_code bson_dbref); 10 | use Mojo::IOLoop; 11 | 12 | # Run command blocking 13 | my $mango = Mango->new($ENV{TEST_ONLINE}); 14 | my $db = $mango->db; 15 | ok $db->command('getnonce')->{nonce}, 'command was successful'; 16 | 17 | # Run command non-blocking 18 | my ($fail, $result); 19 | $db->command( 20 | 'getnonce' => sub { 21 | my ($db, $err, $doc) = @_; 22 | $fail = $err; 23 | $result = $doc->{nonce}; 24 | Mojo::IOLoop->stop; 25 | } 26 | ); 27 | Mojo::IOLoop->start; 28 | ok !$fail, 'no error'; 29 | ok $result, 'command was successful'; 30 | 31 | # Write concern 32 | my $mango2 = Mango->new->w(2)->wtimeout(5000); 33 | my $concern = $mango2->db('test')->build_write_concern; 34 | is $concern->{w}, 2, 'right w value'; 35 | is $concern->{wtimeout}, 5000, 'right wtimeout value'; 36 | 37 | # Get database statistics blocking 38 | ok exists $db->stats->{objects}, 'has objects'; 39 | 40 | # Get database statistics non-blocking 41 | ($fail, $result) = (); 42 | $db->stats( 43 | sub { 44 | my ($db, $err, $stats) = @_; 45 | $fail = $err; 46 | $result = $stats; 47 | Mojo::IOLoop->stop; 48 | } 49 | ); 50 | Mojo::IOLoop->start; 51 | ok !$fail, 'no error'; 52 | ok exists $result->{objects}, 'has objects'; 53 | 54 | # Get collection names blocking 55 | my $collection = $db->collection('database_test'); 56 | $collection->insert({test => 1}); 57 | ok grep { $_ eq 'database_test' } @{$db->collection_names}, 'found collection'; 58 | $collection->drop; 59 | 60 | # Get collection names non-blocking 61 | $collection->insert({test => 1}); 62 | ($fail, $result) = (); 63 | $db->collection_names( 64 | sub { 65 | my ($db, $err, $names) = @_; 66 | $fail = $err; 67 | $result = $names; 68 | Mojo::IOLoop->stop; 69 | } 70 | ); 71 | Mojo::IOLoop->start; 72 | ok !$fail, 'no error'; 73 | ok grep { $_ eq 'database_test' } @$result, 'found collection'; 74 | $collection->drop; 75 | 76 | # Dereference blocking 77 | my $oid = $collection->insert({test => 23}); 78 | is $db->dereference(bson_dbref('database_test', $oid))->{test}, 23, 79 | 'right result'; 80 | $collection->drop; 81 | 82 | # Dereference non-blocking 83 | $oid = $collection->insert({test => 23}); 84 | ($fail, $result) = (); 85 | $db->dereference( 86 | bson_dbref('database_test', $oid) => sub { 87 | my ($db, $err, $doc) = @_; 88 | $fail = $err; 89 | $result = $doc; 90 | Mojo::IOLoop->stop; 91 | } 92 | ); 93 | Mojo::IOLoop->start; 94 | ok !$fail, 'no error'; 95 | is $result->{test}, 23, 'right result'; 96 | $collection->drop; 97 | 98 | # Interrupted blocking command 99 | my $loop = $mango->ioloop; 100 | my $id = $loop->server((address => '127.0.0.1') => sub { $_[1]->close }); 101 | my $port = $loop->acceptor($id)->handle->sockport; 102 | $mango = Mango->new("mongodb://localhost:$port")->ioloop($loop); 103 | eval { $mango->db->command('getnonce') }; 104 | like $@, qr/Premature connection close/, 'right error'; 105 | $mango->ioloop->remove($id); 106 | 107 | # Interrupted non-blocking command 108 | $id = Mojo::IOLoop->server((address => '127.0.0.1') => sub { $_[1]->close }); 109 | $port = Mojo::IOLoop->acceptor($id)->handle->sockport; 110 | $mango = Mango->new("mongodb://localhost:$port"); 111 | $fail = undef; 112 | $mango->db->command( 113 | 'getnonce' => sub { 114 | my ($db, $err) = @_; 115 | $fail = $err; 116 | Mojo::IOLoop->stop; 117 | } 118 | ); 119 | Mojo::IOLoop->start; 120 | Mojo::IOLoop->remove($id); 121 | like $fail, qr/Premature connection close/, 'right error'; 122 | 123 | done_testing(); 124 | -------------------------------------------------------------------------------- /t/gridfs.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | 3 | use Test::More; 4 | 5 | plan skip_all => 'set TEST_ONLINE to enable this test' 6 | unless $ENV{TEST_ONLINE}; 7 | 8 | use Mango; 9 | use Mango::BSON 'bson_oid'; 10 | use Mojo::IOLoop; 11 | 12 | # Clean up before start 13 | my $mango = Mango->new($ENV{TEST_ONLINE}); 14 | my $gridfs = $mango->db->gridfs; 15 | $gridfs->$_->remove for qw(files chunks); 16 | 17 | # Blocking roundtrip 18 | my $writer = $gridfs->writer; 19 | $writer->filename('foo.txt')->content_type('text/plain') 20 | ->metadata({foo => 'bar'}); 21 | ok !$writer->is_closed, 'file has not been closed'; 22 | my $oid = $writer->write('hello ')->write('world!')->close; 23 | ok $writer->is_closed, 'file has been closed'; 24 | my $reader = $gridfs->reader; 25 | is $reader->tell, 0, 'right position'; 26 | $reader->open($oid); 27 | is $reader->filename, 'foo.txt', 'right filename'; 28 | is $reader->content_type, 'text/plain', 'right content type'; 29 | is $reader->md5, 'fc3ff98e8c6a0d3087d515c0473f8677', 'right checksum'; 30 | is_deeply $reader->metadata, {foo => 'bar'}, 'right structure'; 31 | is $reader->size, 12, 'right size'; 32 | is $reader->chunk_size, 261120, 'right chunk size'; 33 | is length $reader->upload_date, length(time) + 3, 'right time format'; 34 | my $data; 35 | while (defined(my $chunk = $reader->read)) { $data .= $chunk } 36 | is $reader->tell, 12, 'right position'; 37 | is $data, 'hello world!', 'right content'; 38 | $data = undef; 39 | $reader->seek(0); 40 | is $reader->tell, 0, 'right position'; 41 | $reader->seek(2); 42 | is $reader->tell, 2, 'right position'; 43 | while (defined(my $chunk = $reader->read)) { $data .= $chunk } 44 | is $data, 'llo world!', 'right content'; 45 | is_deeply $gridfs->list, ['foo.txt'], 'right files'; 46 | $gridfs->delete($oid); 47 | is_deeply $gridfs->list, [], 'no files'; 48 | is $gridfs->chunks->find->count, 0, 'no chunks left'; 49 | $gridfs->$_->drop for qw(files chunks); 50 | 51 | # Non-blocking roundtrip 52 | $writer = $gridfs->writer->chunk_size(4); 53 | $writer->filename('foo.txt')->content_type('text/plain') 54 | ->metadata({foo => 'bar'}); 55 | ok !$writer->is_closed, 'file has not been closed'; 56 | my ($fail, $result); 57 | my $delay = Mojo::IOLoop->delay( 58 | sub { 59 | my $delay = shift; 60 | $writer->write('he' => $delay->begin); 61 | }, 62 | sub { 63 | my ($delay, $err) = @_; 64 | return $delay->pass($err) if $err; 65 | $writer->write('llo ' => $delay->begin); 66 | }, 67 | sub { 68 | my ($delay, $err) = @_; 69 | return $delay->pass($err) if $err; 70 | $writer->write('w' => $delay->begin); 71 | $writer->write('orld!' => $delay->begin); 72 | }, 73 | sub { 74 | my ($delay, $err) = @_; 75 | return $delay->pass($err) if $err; 76 | $writer->close($delay->begin); 77 | }, 78 | sub { 79 | my ($delay, $err, $oid) = @_; 80 | $fail = $err; 81 | $result = $oid; 82 | } 83 | ); 84 | $delay->wait; 85 | ok !$fail, 'no error'; 86 | ok $writer->is_closed, 'file has been closed'; 87 | $reader = $gridfs->reader; 88 | $fail = undef; 89 | $reader->open( 90 | $result => sub { 91 | my ($reader, $err) = @_; 92 | $fail = $err; 93 | Mojo::IOLoop->stop; 94 | } 95 | ); 96 | Mojo::IOLoop->start; 97 | ok !$fail, 'no error'; 98 | is $reader->filename, 'foo.txt', 'right filename'; 99 | is $reader->content_type, 'text/plain', 'right content type'; 100 | is $reader->md5, 'fc3ff98e8c6a0d3087d515c0473f8677', 'right checksum'; 101 | is_deeply $reader->metadata, {foo => 'bar'}, 'right structure'; 102 | is $reader->size, 12, 'right size'; 103 | is $reader->chunk_size, 4, 'right chunk size'; 104 | is length $reader->upload_date, length(time) + 3, 'right time format'; 105 | ($fail, $data) = (); 106 | my $cb; 107 | $cb = sub { 108 | my ($reader, $err, $chunk) = @_; 109 | $fail ||= $err; 110 | return Mojo::IOLoop->stop unless defined $chunk; 111 | $data .= $chunk; 112 | $reader->read($cb); 113 | }; 114 | $reader->$cb(undef, ''); 115 | Mojo::IOLoop->start; 116 | ok !$fail, 'no error'; 117 | is $data, 'hello world!', 'right content'; 118 | my ($before, $after); 119 | $fail = undef; 120 | $delay = Mojo::IOLoop->delay( 121 | sub { $gridfs->list(shift->begin) }, 122 | sub { 123 | my ($delay, $err, $names) = @_; 124 | return $delay->pass($err) if $err; 125 | $before = $names; 126 | $gridfs->delete($result => $delay->begin); 127 | }, 128 | sub { 129 | my ($delay, $err) = @_; 130 | return $delay->pass($err) if $err; 131 | $gridfs->list($delay->begin); 132 | }, 133 | sub { 134 | my ($delay, $err, $names) = @_; 135 | $fail = $err; 136 | $after = $names; 137 | } 138 | ); 139 | $delay->wait; 140 | ok !$fail, 'no error'; 141 | is_deeply $before, ['foo.txt'], 'right files'; 142 | is_deeply $after, [], 'no files'; 143 | is $gridfs->chunks->find->count, 0, 'no chunks left'; 144 | $gridfs->$_->drop for qw(files chunks); 145 | 146 | # Find and slurp versions blocking 147 | my $one 148 | = $gridfs->writer->chunk_size(1)->filename('test.txt')->write('One1')->close; 149 | is $gridfs->find_version('test.txt', -1), $one, 'right version'; 150 | my $two = $gridfs->writer->filename('test.txt')->write('Two')->close; 151 | is $gridfs->find_version('test.txt', -1), $two, 'right version'; 152 | is $gridfs->find_version('test.txt', -2), $one, 'right version'; 153 | is $gridfs->find_version('test.txt', -3), undef, 'no version'; 154 | is_deeply $gridfs->list, ['test.txt'], 'right files'; 155 | is $gridfs->find_version('test.txt', 0), $one, 'right version'; 156 | is $gridfs->find_version('test.txt', 1), $two, 'right version'; 157 | is $gridfs->find_version('test.txt', 2), undef, 'no version'; 158 | is $gridfs->reader->open($one)->slurp, 'One1', 'right content'; 159 | is $gridfs->reader->open($one)->seek(1)->slurp, 'ne1', 'right content'; 160 | is $gridfs->reader->open($two)->slurp, 'Two', 'right content'; 161 | is $gridfs->reader->open($two)->seek(1)->slurp, 'wo', 'right content'; 162 | $gridfs->$_->drop for qw(files chunks); 163 | 164 | # Find and slurp versions non-blocking 165 | $one = $gridfs->writer->filename('test.txt')->write('One')->close; 166 | $two = $gridfs->writer->filename('test.txt')->write('Two')->close; 167 | is_deeply $gridfs->list, ['test.txt'], 'right files'; 168 | my @results; 169 | $fail = undef; 170 | $delay = Mojo::IOLoop->delay( 171 | sub { 172 | my $delay = shift; 173 | $gridfs->find_version(('test.txt', 2) => $delay->begin); 174 | $gridfs->find_version(('test.txt', 1) => $delay->begin); 175 | $gridfs->find_version(('test.txt', 0) => $delay->begin); 176 | }, 177 | sub { 178 | my ($delay, $three_err, $three, $two_err, $two, $one_err, $one) = @_; 179 | $fail = $one_err || $two_err || $three_err; 180 | @results = ($one, $two, $three); 181 | } 182 | ); 183 | $delay->wait; 184 | ok !$fail, 'no error'; 185 | is $results[0], $one, 'right version'; 186 | is $results[1], $two, 'right version'; 187 | is $results[2], undef, 'no version'; 188 | my $one_reader = $gridfs->reader; 189 | my $two_reader = $gridfs->reader; 190 | ($fail, @results) = (); 191 | $delay = Mojo::IOLoop->delay( 192 | sub { 193 | my $delay = shift; 194 | $one_reader->open($one => $delay->begin); 195 | $two_reader->open($two => $delay->begin); 196 | }, 197 | sub { 198 | my ($delay, $one_err, $two_err) = @_; 199 | if (my $err = $one_err || $two_err) { return $delay->pass($err) } 200 | $one_reader->slurp($delay->begin); 201 | $two_reader->slurp($delay->begin); 202 | }, 203 | sub { 204 | my ($delay, $one_err, $one, $two_err, $two) = @_; 205 | $fail = $one_err || $two_err; 206 | @results = ($one, $two); 207 | } 208 | ); 209 | $delay->wait; 210 | ok !$fail, 'no error'; 211 | is $results[0], 'One', 'right content'; 212 | is $results[1], 'Two', 'right content'; 213 | $gridfs->$_->drop for qw(files chunks); 214 | 215 | # File already closed 216 | $writer = $gridfs->writer; 217 | ok !$writer->is_closed, 'file has not been closed'; 218 | $oid = $writer->write('Test')->close; 219 | ok $writer->is_closed, 'file has been closed'; 220 | eval { $writer->write('123') }; 221 | like $@, qr/^File already closed/, 'right error'; 222 | $fail = undef; 223 | $writer->write( 224 | '123' => sub { 225 | my ($writer, $err) = @_; 226 | $fail = $err; 227 | Mojo::IOLoop->stop; 228 | } 229 | ); 230 | Mojo::IOLoop->start; 231 | like $fail, qr/^File already closed/, 'right error'; 232 | ok $writer->is_closed, 'file is still closed'; 233 | is $writer->close, $oid, 'right result'; 234 | ($fail, $result) = (); 235 | $writer->close( 236 | sub { 237 | my ($writer, $err, $oid) = @_; 238 | $fail = $err; 239 | $result = $oid; 240 | Mojo::IOLoop->stop; 241 | } 242 | ); 243 | Mojo::IOLoop->start; 244 | ok !$fail, 'no error'; 245 | is $result, $oid, 'right result'; 246 | ok $writer->is_closed, 'file is still closed'; 247 | $gridfs->$_->drop for qw(files chunks); 248 | 249 | # Big chunks and concurrent readers 250 | $oid = $gridfs->writer->write('x' x 1000000)->close; 251 | ($fail, @results) = (); 252 | $delay = Mojo::IOLoop->delay( 253 | sub { 254 | my $delay = shift; 255 | $gridfs->reader->open($oid => $delay->begin(0)); 256 | $gridfs->reader->open($oid => $delay->begin(0)); 257 | }, 258 | sub { 259 | my ($delay, $reader1, $err1, $reader2, $err2) = @_; 260 | if (my $err = $err1 || $err2) { return $delay->pass($err) } 261 | $reader1->slurp($delay->begin); 262 | $reader2->slurp($delay->begin); 263 | }, 264 | sub { 265 | my ($delay, $err1, $data1, $err2, $data2) = @_; 266 | $fail = $err1 || $err2; 267 | @results = ($data1, $data2); 268 | } 269 | ); 270 | $delay->wait; 271 | ok !$fail, 'no error'; 272 | is $results[0], 'x' x 1000000, 'right content'; 273 | is $results[1], 'x' x 1000000, 'right content'; 274 | $gridfs->$_->drop for qw(files chunks); 275 | 276 | # Open missing file blocking 277 | $oid = bson_oid; 278 | eval { $gridfs->reader->open($oid) }; 279 | like $@, qr/^$oid does not exist/, 'right error'; 280 | 281 | # Open missing file non-blocking 282 | $fail = undef; 283 | $gridfs->reader->open( 284 | $oid => sub { 285 | my ($reader, $err) = @_; 286 | $fail = $err; 287 | Mojo::IOLoop->stop; 288 | } 289 | ); 290 | Mojo::IOLoop->start; 291 | like $fail, qr/^$oid does not exist/, 'right error'; 292 | 293 | done_testing(); 294 | -------------------------------------------------------------------------------- /t/pod.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | 3 | use Test::More; 4 | 5 | plan skip_all => 'set TEST_POD to enable this test (developer only!)' 6 | unless $ENV{TEST_POD}; 7 | plan skip_all => 'Test::Pod 1.14 required for this test!' 8 | unless eval 'use Test::Pod 1.14; 1'; 9 | 10 | all_pod_files_ok(); 11 | -------------------------------------------------------------------------------- /t/pod_coverage.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | 3 | use Test::More; 4 | 5 | plan skip_all => 'set TEST_POD to enable this test (developer only!)' 6 | unless $ENV{TEST_POD}; 7 | plan skip_all => 'Test::Pod::Coverage 1.04 required for this test!' 8 | unless eval 'use Test::Pod::Coverage 1.04; 1'; 9 | 10 | all_pod_coverage_ok(); 11 | -------------------------------------------------------------------------------- /t/protocol.t: -------------------------------------------------------------------------------- 1 | use Mojo::Base -strict; 2 | 3 | use Test::More; 4 | use Mango::Protocol; 5 | 6 | # Generate next id 7 | my $protocol = Mango::Protocol->new; 8 | is $protocol->next_id(1), 2, 'right id'; 9 | is $protocol->next_id(2147483646), 2147483647, 'right id'; 10 | is $protocol->next_id(2147483647), 1, 'right id'; 11 | 12 | # Build minimal query 13 | is $protocol->build_query(1, 'foo', {}, 0, 10, {}, {}), 14 | "\x2a\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\xd4\x07\x00\x00\x00\x00" 15 | . "\x00\x00\x66\x6f\x6f\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x05\x00\x00\x00" 16 | . "\x00\x05\x00\x00\x00\x00", 'minimal query'; 17 | 18 | # Build query with all flags 19 | my $flags = { 20 | tailable_cursor => 1, 21 | slave_ok => 1, 22 | no_cursor_timeout => 1, 23 | await_data => 1, 24 | exhaust => 1, 25 | partial => 1 26 | }; 27 | is $protocol->build_query(1, 'foo', $flags, 0, 10, {}, {}), 28 | "\x2a\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\xd4\x07\x00\x00\xf6" 29 | . "\x00\x00\x00\x66\x6f\x6f\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x05\x00" 30 | . "\x00\x00\x00\x05\x00\x00\x00\x00", 'query with all flags'; 31 | 32 | # Build minimal get_more 33 | is $protocol->build_get_more(1, 'foo', 10, 1), 34 | "\x24\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\xd5\x07\x00\x00\x00\x00" 35 | . "\x00\x00\x66\x6f\x6f\x00\x0a\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", 36 | 'minimal get_more'; 37 | 38 | # Build minimal kill_cursors 39 | is $protocol->build_kill_cursors(1, 1), 40 | "\x20\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\xd7\x07\x00\x00\x00\x00" 41 | . "\x00\x00\x01\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", 42 | 'minimal kill_cursors'; 43 | 44 | # Parse full reply with leftovers 45 | my $buffer 46 | = "\x51\x00\x00\x00\x69\xaa\x04\x00\x03\x00\x00\x00\x01\x00\x00\x00\x08\x00" 47 | . "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00" 48 | . "\x2d\x00\x00\x00\x02\x6e\x6f\x6e\x63\x65\x00\x11\x00\x00\x00\x33\x32\x39" 49 | . "\x35\x65\x35\x63\x64\x35\x65\x65\x66\x32\x35\x30\x30\x00\x01\x6f\x6b\x00" 50 | . "\x00\x00\x00\x00\x00\x00\xf0\x3f\x00\x51"; 51 | my $reply = $protocol->parse_reply(\$buffer); 52 | is $buffer, "\x51", 'right leftovers'; 53 | my $nonce = { 54 | id => 305769, 55 | to => 3, 56 | flags => {await_capable => 1}, 57 | cursor => 0, 58 | from => 0, 59 | docs => [{nonce => '3295e5cd5eef2500', ok => 1}] 60 | }; 61 | is_deeply $reply, $nonce, 'right reply'; 62 | 63 | # Parse query failure 64 | $buffer 65 | = "\x59\x00\x00\x00\x3b\xd7\x04\x00\x01\x00\x00\x00\x01\x00\x00\x00\x02\x00" 66 | . "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00" 67 | . "\x35\x00\x00\x00\x02\x24\x65\x72\x72\x00\x1c\x00\x00\x00\x24\x6f\x72\x20" 68 | . "\x72\x65\x71\x75\x69\x72\x65\x73\x20\x6e\x6f\x6e\x65\x6d\x70\x74\x79\x20" 69 | . "\x61\x72\x72\x61\x79\x00\x10\x63\x6f\x64\x65\x00\xce\x33\x00\x00\x00"; 70 | $reply = $protocol->parse_reply(\$buffer); 71 | my $query = { 72 | id => 317243, 73 | to => 1, 74 | flags => {query_failure => 1}, 75 | cursor => 0, 76 | from => 0, 77 | docs => [{'$err' => '$or requires nonempty array', code => 13262}] 78 | }; 79 | is_deeply $reply, $query, 'right reply'; 80 | 81 | # Parse partial reply 82 | my $before = my $after = "\x10"; 83 | is $protocol->parse_reply(\$after), undef, 'nothing'; 84 | is $before, $after, 'no changes'; 85 | $before = $after = "\x00\x01\x00\x00"; 86 | is $protocol->parse_reply(\$after), undef, 'nothing'; 87 | is $before, $after, 'no changes'; 88 | 89 | # Parse wrong message type 90 | $buffer = $protocol->build_query(1, 'foo', {}, 0, 10, {}, {}) . "\x00"; 91 | is $protocol->parse_reply(\$buffer), undef, 'nothing'; 92 | is $buffer, "\x00", 'message has been removed'; 93 | 94 | # Extract error messages from reply 95 | is $protocol->query_failure($query), '$or requires nonempty array', 96 | 'right query failure'; 97 | is $protocol->query_failure(undef), undef, 'no query failure'; 98 | is $protocol->query_failure($nonce), undef, 'no query failure'; 99 | 100 | # Extract error messages from documents 101 | my $unknown 102 | = {errmsg => 'no such cmd: whatever', 'bad cmd' => {whatever => 1}, ok => 0}; 103 | my $write = { 104 | n => 0, 105 | ok => 1, 106 | writeErrors => [ 107 | { 108 | code => 11000, 109 | errmsg => 'insertDocument :: caused by :: 11000 E11000 duplicate' 110 | . ' key error index: test.collection_test.$_id_ dup key: ' 111 | . '{ : ObjectId(\'53408aad5867b46961a50000\') }', 112 | index => 0 113 | } 114 | ] 115 | }; 116 | is $protocol->command_error($unknown), 'no such cmd: whatever', 'right error'; 117 | is $protocol->command_error($write), undef, 'no error'; 118 | like $protocol->write_error($write), 119 | qr/^Write error at index 0: insertDocument/, 'right error'; 120 | is $protocol->write_error($unknown), undef, 'no error'; 121 | 122 | done_testing(); 123 | --------------------------------------------------------------------------------