Mango-0.22/000755 000765 000024 00000000000 12254224346 012442 5ustar00sristaff000000 000000 Mango-0.22/Changes000644 000765 000024 00000007765 12254223735 013755 0ustar00sristaff000000 000000 0.22 2013-12-18 - Added options method to Mango::Collection. 0.21 2013-12-04 - Improved handling of missing files in Mango::GridFS::Reader. 0.20 2013-11-30 - Added from_string method to Mango. 0.19 2013-11-18 - Improved Mango::Cursor to allow $query key in queries. 0.18 2013-11-11 - Fixed concurrency bugs in Mango. - Fixed bug in Mango::BSON where all objects that stringify to "1" were considered booleans. 0.17 2013-10-30 - Added cursor and collection support for aggregation. - Added add_batch method to Mango::Cursor. - Added from_epoch method to Mango::BSON::ObjectID. 0.16 2013-10-12 - Added support for fallback servers. - Fixed reconnect bugs. 0.15 2013-10-11 - Fixed mongos compatibility bugs. 0.14 2013-10-06 - Added DBRef support. - Added dereference method to Mango::Database. - Added bson_dbref function to Mango::BSON. 0.13 2013-09-21 - Added fields argument to find and find_one methods in Mango::Collection. 0.12 2013-08-17 - Fixed rewind bug in Mango::Cursor where the cursor would not be killed on the server. 0.11 2013-08-14 - Changed return values of remove and update methods in Mango::Collection. 0.10 2013-08-06 - Improved connection management to be more fault-tolerant. 0.09 2013-07-28 - Added connection event to Mango. - Improved connection management to be fork-safe. 0.08 2013-07-20 - Removed is_active method from Mango. - Added max_scan attribute to Mango::Cursor. - Added backlog method to Mango. 0.07 2013-07-18 - Added is_closed method to Mango::GridFS::Writer. 0.06 2013-07-17 - Added GridFS support. - Added modules Mango::GridFS, Mango::GridFS::Reader and Mango::GridFS::Writer. - Added gridfs method to Mango::Database. - Improved Mango::BSON performance. (avkhozov) - Fixed non-blocking connection pool timing bug. - Fixed ensure_index argument bug. 0.05 2013-07-06 - Changed heuristics for number detection in Mango::BSON to better line up with user expectations. - Changed to_epoch in Mango::BSON::Time to return a high resolution time. - Added connection pool support for non-blocking operations. - Added max_connections attribute to Mango. - Added drop_index, index_information and stats methods to Mango::Collection. - Added to_string method to Mango::BSON::ObjectID. - Added to_string method to Mango::BSON::Time. - Added stats method to Mango::Database. - Added TO_JSON method to Mango::BSON::Binary. - Added TO_JSON method to Mango::BSON::Time. - Improved compatibility with Mojolicious 4.0. - Improved Mango::BSON performance. (avkhozov) - Improved Mango::BSON::ObjectID to validate object ids. - Improved exception handling for commands. - Fixed support for empty keys in Mango::BSON. - Fixed a few memory leaks. 0.04 2013-02-10 - Added collection_names method to Mango::Database. - Added aggregate, build_index_name, find_and_modify map_reduce and save methods to Mango::Collection. - Added distinct method to Mango::Cursor. - Changed remove and update methods in Mango::Collection to return the number of documents affected. - Fixed exception handling for commands. 0.03 2013-02-09 - Added hint, snapshot and tailable attributes to Mango::Cursor. - Added create, drop and ensure_index methods to Mango::Collection. - Added build_query, clone and explain methods to Mango::Cursor. - Added command_error and query_failure methods to Mango::Protocol. - Fixed array encoding in Mango::BSON. - Fixed small exception handling bugs in Mango. 0.02 2013-02-07 - Added batch_size attribute to Mango::Cursor. - Added count method to Mango::Cursor. - Added next_id method to Mango::Protocol. - Added multi and upsert options to update method in Mango::Collection. - Added single option to remove method in Mango::Collection. - Changed reply format from array to hash. - Fixed a few exception handling bugs. - Fixed limit functionality in Mango::Cursor. - Fixed a few small timing bugs in Mango::Cursor. 0.01 2013-02-06 - First release. Mango-0.22/CONTRIBUTING.md000644 000765 000024 00000000256 12127157107 014675 0ustar00sristaff000000 000000 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. Mango-0.22/lib/000755 000765 000024 00000000000 12254224346 013210 5ustar00sristaff000000 000000 Mango-0.22/LICENSE000644 000765 000024 00000021413 12045730313 013442 0ustar00sristaff000000 000000 The Artistic License 2.0 Copyright (c) 2000-2006, The Perl Foundation. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble This license establishes the terms under which a given free software Package may be copied, modified, distributed, and/or redistributed. The intent is that the Copyright Holder maintains some artistic control over the development of that Package while still keeping the Package available as open source and free software. You are always permitted to make arrangements wholly outside of this license directly with the Copyright Holder of a given Package. If the terms of this license do not permit the full use that you propose to make of the Package, you should contact the Copyright Holder and seek a different licensing arrangement. Definitions "Copyright Holder" means the individual(s) or organization(s) named in the copyright notice for the entire Package. "Contributor" means any party that has contributed code or other material to the Package, in accordance with the Copyright Holder's procedures. "You" and "your" means any person who would like to copy, distribute, or modify the Package. "Package" means the collection of files distributed by the Copyright Holder, and derivatives of that collection and/or of those files. A given Package may consist of either the Standard Version, or a Modified Version. "Distribute" means providing a copy of the Package or making it accessible to anyone else, or in the case of a company or organization, to others outside of your company or organization. "Distributor Fee" means any fee that you charge for Distributing this Package or providing support for this Package to another party. It does not mean licensing fees. "Standard Version" refers to the Package if it has not been modified, or has been modified only in ways explicitly requested by the Copyright Holder. "Modified Version" means the Package, if it has been changed, and such changes were not explicitly requested by the Copyright Holder. "Original License" means this Artistic License as Distributed with the Standard Version of the Package, in its current version or as it may be modified by The Perl Foundation in the future. "Source" form means the source code, documentation source, and configuration files for the Package. "Compiled" form means the compiled bytecode, object code, binary, or any other form resulting from mechanical transformation or translation of the Source form. Permission for Use and Modification Without Distribution (1) You are permitted to use the Standard Version and create and use Modified Versions for any purpose without restriction, provided that you do not Distribute the Modified Version. Permissions for Redistribution of the Standard Version (2) You may Distribute verbatim copies of the Source form of the Standard Version of this Package in any medium without restriction, either gratis or for a Distributor Fee, provided that you duplicate all of the original copyright notices and associated disclaimers. At your discretion, such verbatim copies may or may not include a Compiled form of the Package. (3) You may apply any bug fixes, portability changes, and other modifications made available from the Copyright Holder. The resulting Package will still be considered the Standard Version, and as such will be subject to the Original License. Distribution of Modified Versions of the Package as Source (4) You may Distribute your Modified Version as Source (either gratis or for a Distributor Fee, and with or without a Compiled form of the Modified Version) provided that you clearly document how it differs from the Standard Version, including, but not limited to, documenting any non-standard features, executables, or modules, and provided that you do at least ONE of the following: (a) make the Modified Version available to the Copyright Holder of the Standard Version, under the Original License, so that the Copyright Holder may include your modifications in the Standard Version. (b) ensure that installation of your Modified Version does not prevent the user installing or running the Standard Version. In addition, the Modified Version must bear a name that is different from the name of the Standard Version. (c) allow anyone who receives a copy of the Modified Version to make the Source form of the Modified Version available to others under (i) the Original License or (ii) a license that permits the licensee to freely copy, modify and redistribute the Modified Version using the same licensing terms that apply to the copy that the licensee received, and requires that the Source form of the Modified Version, and of any works derived from it, be made freely available in that license fees are prohibited but Distributor Fees are allowed. Distribution of Compiled Forms of the Standard Version or Modified Versions without the Source (5) You may Distribute Compiled forms of the Standard Version without the Source, provided that you include complete instructions on how to get the Source of the Standard Version. Such instructions must be valid at the time of your distribution. If these instructions, at any time while you are carrying out such distribution, become invalid, you must provide new instructions on demand or cease further distribution. If you provide valid instructions or cease distribution within thirty days after you become aware that the instructions are invalid, then you do not forfeit any of your rights under this license. (6) You may Distribute a Modified Version in Compiled form without the Source, provided that you comply with Section 4 with respect to the Source of the Modified Version. Aggregating or Linking the Package (7) You may aggregate the Package (either the Standard Version or Modified Version) with other packages and Distribute the resulting aggregation provided that you do not charge a licensing fee for the Package. Distributor Fees are permitted, and licensing fees for other components in the aggregation are permitted. The terms of this license apply to the use and Distribution of the Standard or Modified Versions as included in the aggregation. (8) You are permitted to link Modified and Standard Versions with other works, to embed the Package in a larger work of your own, or to build stand-alone binary or bytecode versions of applications that include the Package, and Distribute the result without restriction, provided the result does not expose a direct interface to the Package. Items That are Not Considered Part of a Modified Version (9) Works (including, but not limited to, modules and scripts) that merely extend or make use of the Package, do not, by themselves, cause the Package to be a Modified Version. In addition, such works are not considered parts of the Package itself, and are not subject to the terms of this license. General Provisions (10) Any use, modification, and distribution of the Standard or Modified Versions is governed by this Artistic License. By using, modifying or distributing the Package, you accept this license. Do not use, modify, or distribute the Package, if you do not accept this license. (11) If your Modified Version has been derived from a Modified Version made by someone other than you, you are nevertheless required to ensure that your Modified Version complies with the requirements of this license. (12) This license does not grant you the right to use any trademark, service mark, tradename, or logo of the Copyright Holder. (13) This license includes the non-exclusive, worldwide, free-of-charge patent license to make, have made, use, offer to sell, sell, import and otherwise transfer the Package with respect to any patent claims licensable by the Copyright Holder that are necessarily infringed by the Package. If you institute patent litigation (including a cross-claim or counterclaim) against any party alleging that the Package constitutes direct or contributory patent infringement, then this Artistic License to you shall terminate on the date that such litigation is filed. (14) Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Mango-0.22/Makefile.PL000644 000765 000024 00000001674 12240166557 014430 0ustar00sristaff000000 000000 use 5.010001; use strict; use warnings; use Config; use ExtUtils::MakeMaker; die "Perl with support for quads is required!\n" unless (($Config{use64bitint} // '') eq 'define' || $Config{longsize} >= 8); WriteMakefile( NAME => 'Mango', VERSION_FROM => 'lib/Mango.pm', ABSTRACT => 'Pure-Perl non-blocking I/O MongoDB driver', AUTHOR => 'Sebastian Riedel ', LICENSE => 'artistic_2', META_MERGE => { requires => {perl => '5.010001'}, resources => { homepage => 'http://mojolicio.us', license => 'http://www.opensource.org/licenses/artistic-license-2.0', MailingList => 'http://groups.google.com/group/mojolicious', repository => 'http://github.com/kraih/mango', bugtracker => 'http://github.com/kraih/mango/issues' }, no_index => {directory => ['t']} }, PREREQ_PM => {Mojolicious => '4.56'}, test => {TESTS => 't/*.t t/*/*.t'} ); Mango-0.22/MANIFEST000644 000765 000024 00000001324 12254224346 013573 0ustar00sristaff000000 000000 Changes CONTRIBUTING.md lib/Mango.pm lib/Mango/BSON.pm lib/Mango/BSON/Binary.pm lib/Mango/BSON/Code.pm lib/Mango/BSON/Document.pm lib/Mango/BSON/ObjectID.pm lib/Mango/BSON/Time.pm lib/Mango/BSON/Timestamp.pm lib/Mango/Collection.pm lib/Mango/Cursor.pm lib/Mango/Database.pm lib/Mango/GridFS.pm lib/Mango/GridFS/Reader.pm lib/Mango/GridFS/Writer.pm lib/Mango/Protocol.pm LICENSE Makefile.PL MANIFEST This list of files MANIFEST.SKIP README.md t/bson.t t/collection.t t/connection.t t/cursor.t t/database.t t/gridfs.t t/pod.t t/pod_coverage.t t/protocol.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Mango-0.22/MANIFEST.SKIP000644 000765 000024 00000000115 12114022134 014317 0ustar00sristaff000000 000000 ^\.(?!perltidyrc) .*\.old$ \.tar\.gz$ ^Makefile$ ^MYMETA\. ^blib ^pm_to_blib Mango-0.22/META.json000644 000765 000024 00000002471 12254224346 014067 0ustar00sristaff000000 000000 { "abstract" : "Pure-Perl non-blocking I/O MongoDB driver", "author" : [ "Sebastian Riedel " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.84, CPAN::Meta::Converter version 2.133380", "license" : [ "artistic_2" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Mango", "no_index" : { "directory" : [ "t", "inc", "t" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Mojolicious" : "4.56", "perl" : "5.010001" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://github.com/kraih/mango/issues" }, "homepage" : "http://mojolicio.us", "license" : [ "http://www.opensource.org/licenses/artistic-license-2.0" ], "repository" : { "url" : "http://github.com/kraih/mango" }, "x_MailingList" : "http://groups.google.com/group/mojolicious" }, "version" : "0.22" } Mango-0.22/META.yml000644 000765 000024 00000001427 12254224346 013717 0ustar00sristaff000000 000000 --- abstract: 'Pure-Perl non-blocking I/O MongoDB driver' author: - 'Sebastian Riedel ' build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.84, CPAN::Meta::Converter version 2.133380' license: artistic_2 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Mango no_index: directory: - t - inc - t requires: Mojolicious: 4.56 perl: 5.010001 resources: MailingList: http://groups.google.com/group/mojolicious bugtracker: http://github.com/kraih/mango/issues homepage: http://mojolicio.us license: http://www.opensource.org/licenses/artistic-license-2.0 repository: http://github.com/kraih/mango version: 0.22 Mango-0.22/README.md000644 000765 000024 00000002621 12172765727 013736 0ustar00sristaff000000 000000 # Mango [![Build Status](https://secure.travis-ci.org/kraih/mango.png)](http://travis-ci.org/kraih/mango) Pure-Perl non-blocking I/O MongoDB driver, optimized for use with the [Mojolicious](http://mojolicio.us) real-time web framework. use Mojolicious::Lite; use Mango; use Mango::BSON ':bson'; my $uri = 'mongodb://:@/'; helper mango => sub { state $mango = Mango->new($uri) }; # Store and retrieve information non-blocking get '/' => sub { my $self = shift; my $collection = $self->mango->db->collection('visitors'); my $ip = $self->tx->remote_address; # Store information about current visitor $collection->insert({when => bson_time, from => $ip} => sub { my ($collection, $err, $oid) = @_; return $self->render_exception($err) if $err; # Retrieve information about previous visitors $collection->find->sort({when => -1})->fields({_id => 0})->all(sub { my ($collection, $err, $docs) = @_; return $self->render_exception($err) if $err; # And show it to current visitor $self->render(json => $docs); }); }); }; app->start; ## Installation All you need is a oneliner, it takes less than a minute. $ curl -L cpanmin.us | perl - -n Mango We recommend the use of a [Perlbrew](http://perlbrew.pl) environment. Mango-0.22/t/000755 000765 000024 00000000000 12254224346 012705 5ustar00sristaff000000 000000 Mango-0.22/t/bson.t000644 000765 000024 00000036102 12242765250 014036 0ustar00sristaff000000 000000 package BSONTest; use Mojo::Base -base; has 'something' => sub { {} }; sub TO_JSON { shift->something } package main; use Mojo::Base -strict; use Test::More; use Mango::BSON ':bson'; use Mojo::ByteStream 'b'; use Mojo::JSON 'j'; # Ordered document my $doc = bson_doc(a => 1, c => 2, b => 3); $doc->{d} = 4; $doc->{e} = 5; is_deeply [keys %$doc], [qw(a c b d e)], 'ordered keys'; is_deeply [values %$doc], [qw(1 2 3 4 5)], 'ordered values'; ok exists $doc->{c}, 'value does exist'; is delete $doc->{c}, 2, 'right value'; ok !exists $doc->{x}, 'value does not exist'; is delete $doc->{x}, undef, 'no value'; is_deeply [keys %$doc], [qw(a b d e)], 'ordered keys'; is_deeply [values %$doc], [qw(1 3 4 5)], 'ordered values'; $doc->{d} = 6; is_deeply [keys %$doc], [qw(a b d e)], 'ordered keys'; is_deeply [values %$doc], [qw(1 3 6 5)], 'ordered values'; # Document length prefix is bson_length("\x05"), undef, 'no length'; is bson_length("\x05\x00\x00\x00"), 5, 'right length'; is bson_length("\x05\x00\x00\x00\x00"), 5, 'right length'; is bson_length("\x05\x00\x00\x00\x00\x00"), 5, 'right length'; # Generate object id is length bson_oid, 24, 'right length'; is bson_oid('510d83915867b405b9000000')->to_epoch, 1359840145, 'right epoch time'; my $oid = bson_oid->from_epoch(1359840145); is $oid->to_epoch, 1359840145, 'right epoch time'; isnt $oid, bson_oid->from_epoch(1359840145), 'different object ids'; # Generate Time is length bson_time, length(time) + 3, 'right length'; is length int bson_time->to_epoch, length time, 'right length'; is substr(bson_time->to_epoch, 0, 5), substr(time, 0, 5), 'same start'; is bson_time(1360626536748), 1360626536748, 'right epoch milliseconds'; is bson_time(1360626536748)->to_epoch, 1360626536.748, 'right epoch seconds'; # Empty document my $bson = bson_encode {}; is_deeply bson_decode($bson), {}, 'successful roundtrip'; # Minimal document roundtrip my $bytes = "\x05\x00\x00\x00\x00"; $doc = bson_decode($bytes); is_deeply [keys %$doc], [], 'empty document'; is_deeply $doc, {}, 'empty document'; is bson_encode($doc), $bytes, 'successful roundtrip'; # Empty key and value $bytes = "\x0c\x00\x00\x00\x02\x00\x01\x00\x00\x00\x00\x00"; $doc = bson_decode($bytes); is_deeply $doc, {'' => ''}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; # Incomplete document is bson_decode("\x05\x00\x00\x00"), undef, 'no result'; is bson_decode("\x05\x00\x00"), undef, 'no result'; is bson_decode("\x05\x00"), undef, 'no result'; is bson_decode("\x05"), undef, 'no result'; # Nested document roundtrip $bytes = "\x10\x00\x00\x00\x03\x6e\x6f\x6e\x65\x00\x05\x00\x00\x00\x00\x00"; $doc = bson_decode($bytes); is_deeply $doc, {none => {}}, 'empty nested document'; is bson_encode($doc), $bytes, 'successful roundtrip for hash'; is bson_encode(bson_doc(none => {})), $bytes, 'successful roundtrip for document'; # Document roundtrip with "0" in key is_deeply bson_decode(bson_encode {n0ne => 'n0ne'}), bson_doc(n0ne => 'n0ne'), 'successful roundtrip'; # String roundtrip $bytes = "\x1b\x00\x00\x00\x02\x74\x65\x73\x74\x00\x0c\x00\x00\x00\x68\x65" . "\x6c\x6c\x6f\x20\x77\x6f\x72\x6c\x64\x00\x00"; $doc = bson_decode($bytes); is $doc->{test}, 'hello world', 'right value'; is_deeply [keys %$doc], ['test'], 'one element'; is_deeply $doc, {test => 'hello world'}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; $doc = bson_decode(bson_encode {foo => 'i ♥ mojolicious'}); is $doc->{foo}, 'i ♥ mojolicious', 'successful roundtrip'; # Array $bytes = "\x11\x00\x00\x00\x04\x65\x6d\x70\x74\x79\x00\x05\x00\x00\x00\x00\x00"; $doc = bson_decode($bytes); is_deeply $doc, {empty => []}, 'empty array'; # Array roundtrip $bytes = "\x11\x00\x00\x00\x04\x65\x6d\x70\x74\x79\x00\x05\x00\x00\x00\x00\x00"; $doc = bson_decode($bytes); is_deeply $doc, {empty => []}, 'empty array'; is bson_encode($doc), $bytes, 'successful roundtrip'; $bytes = "\x33\x00\x00\x00\x04\x66\x69\x76\x65\x00\x28\x00\x00\x00\x10\x30\x00\x01" . "\x00\x00\x00\x10\x31\x00\x02\x00\x00\x00\x10\x32\x00\x03\x00\x00\x00\x10" . "\x33\x00\x04\x00\x00\x00\x10\x34\x00\x05\x00\x00\x00\x00\x00"; $doc = bson_decode($bytes); is_deeply $doc, {five => [1, 2, 3, 4, 5]}, 'array with five elements'; is bson_encode($doc), $bytes, 'successful roundtrip'; # Timestamp roundtrip $bytes = "\x13\x00\x00\x00\x11\x74\x65\x73\x74\x00\x14\x00\x00\x00\x04\x00\x00" . "\x00\x00"; $doc = bson_decode($bytes); isa_ok $doc->{test}, 'Mango::BSON::Timestamp', 'right class'; is $doc->{test}->seconds, 4, 'right seconds'; is $doc->{test}->increment, 20, 'right increment'; is bson_encode($doc), $bytes, 'successful roundtrip'; # Double roundtrip $bytes = "\x14\x00\x00\x00\x01\x68\x65\x6c\x6c\x6f\x00\x00\x00\x00\x00\x00\x00" . "\xf8\x3f\x00"; $doc = bson_decode($bytes); is_deeply $doc, {hello => 1.5}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; $doc = bson_decode(bson_encode {test => -1.5}); is $doc->{test}, -1.5, 'successful roundtrip'; # Int32 roundtrip $bytes = "\x0f\x00\x00\x00\x10\x6d\x69\x6b\x65\x00\x64\x00\x00\x00\x00"; $doc = bson_decode($bytes); is_deeply $doc, {mike => 100}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; $doc = bson_decode(bson_encode {test => -100}); is $doc->{test}, -100, 'successful roundtrip'; # Int64 roundtrip $bytes = "\x13\x00\x00\x00\x12\x6d\x69\x6b\x65\x00\x01\x00\x00\x80\x00\x00\x00" . "\x00\x00"; $doc = bson_decode($bytes); is_deeply $doc, {mike => 2147483649}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; $doc = bson_decode(bson_encode {test => -2147483648}); is $doc->{test}, -2147483648, 'successful roundtrip'; # Boolean roundtrip $bytes = "\x0c\x00\x00\x00\x08\x74\x72\x75\x65\x00\x01\x00"; $doc = bson_decode($bytes); is_deeply $doc, {true => bson_true()}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; $bytes = "\x0d\x00\x00\x00\x08\x66\x61\x6c\x73\x65\x00\x00\x00"; $doc = bson_decode($bytes); is_deeply $doc, {false => bson_false()}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; # Null roundtrip $bytes = "\x0b\x00\x00\x00\x0a\x74\x65\x73\x74\x00\x00"; $doc = bson_decode($bytes); is_deeply $doc, {test => undef}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; # Max key roundtrip $bytes = "\x0b\x00\x00\x00\x7f\x74\x65\x73\x74\x00\x00"; $doc = bson_decode($bytes); is_deeply $doc, {test => bson_max()}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; # Min key roundtrip $bytes = "\x0b\x00\x00\x00\xff\x74\x65\x73\x74\x00\x00"; $doc = bson_decode($bytes); is_deeply $doc, {test => bson_min()}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; # Object id roundtrip my $id = '000102030405060708090a0b'; $bytes = "\x16\x00\x00\x00\x07\x6f\x69\x64\x00\x00" . "\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x00"; $doc = bson_decode($bytes); isa_ok $doc->{oid}, 'Mango::BSON::ObjectID', 'right class'; is $doc->{oid}->to_epoch, 66051, 'right epoch time'; is_deeply $doc, {oid => $id}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; # Regex roundtrip $bytes = "\x12\x00\x00\x00\x0b\x72\x65\x67\x65\x78\x00\x61\x2a\x62\x00\x69\x00\x00"; $doc = bson_decode($bytes); is_deeply $doc, {regex => qr/a*b/i}, 'right document'; like 'AAB', $doc->{regex}, 'regex works'; like 'ab', $doc->{regex}, 'regex works'; unlike 'Ax', $doc->{regex}, 'regex works'; is bson_encode($doc), $bytes, 'successful roundtrip'; # Code roundtrip $bytes = "\x1c\x00\x00\x00\x0d\x66\x6f\x6f\x00\x0e\x00\x00\x00\x76\x61\x72\x20" . "\x66\x6f\x6f\x20\x3d\x20\x32\x33\x3b\x00\x00"; $doc = bson_decode($bytes); isa_ok $doc->{foo}, 'Mango::BSON::Code', 'right class'; is_deeply $doc, {foo => bson_code('var foo = 23;')}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; # Code with scope roundtrip $bytes = "\x32\x00\x00\x00\x0f\x66\x6f\x6f\x00\x24\x00\x00\x00\x0e\x00\x00\x00\x76" . "\x61\x72\x20\x66\x6f\x6f\x20\x3d\x20\x32\x34\x3b\x00\x12\x00\x00\x00\x02\x66" . "\x6f\x6f\x00\x04\x00\x00\x00\x62\x61\x72\x00\x00\x00"; $doc = bson_decode($bytes); isa_ok $doc->{foo}, 'Mango::BSON::Code', 'right class'; is_deeply $doc, {foo => bson_code('var foo = 24;')->scope({foo => 'bar'})}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; # Time roundtrip $bytes = "\x14\x00\x00\x00\x09\x74\x6f\x64\x61\x79\x00\x4e\x61\xbc\x00\x00\x00" . "\x00\x00\x00"; $doc = bson_decode($bytes); isa_ok $doc->{today}, 'Mango::BSON::Time', 'right class'; is_deeply $doc, {today => bson_time(12345678)}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; is_deeply bson_decode(bson_encode({time => bson_time(1360627440269)})), {time => 1360627440269}, 'successful roundtrip'; # Generic binary roundtrip $bytes = "\x14\x00\x00\x00\x05\x66\x6f\x6f\x00\x05\x00\x00\x00\x00\x31\x32\x33" . "\x34\x35\x00"; $doc = bson_decode($bytes); isa_ok $doc->{foo}, 'Mango::BSON::Binary', 'right class'; is $doc->{foo}->type, 'generic', 'right type'; is_deeply $doc, {foo => bson_bin('12345')}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; # Function binary roundtrip $bytes = "\x14\x00\x00\x00\x05\x66\x6f\x6f\x00\x05\x00\x00\x00\x01\x31\x32\x33" . "\x34\x35\x00"; $doc = bson_decode($bytes); isa_ok $doc->{foo}, 'Mango::BSON::Binary', 'right class'; is $doc->{foo}->type, 'function', 'right type'; is_deeply $doc, {foo => bson_bin('12345')->type('function')}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; # MD5 binary roundtrip $bytes = "\x14\x00\x00\x00\x05\x66\x6f\x6f\x00\x05\x00\x00\x00\x05\x31\x32\x33" . "\x34\x35\x00"; $doc = bson_decode($bytes); isa_ok $doc->{foo}, 'Mango::BSON::Binary', 'right class'; is $doc->{foo}->type, 'md5', 'right type'; is_deeply $doc, {foo => bson_bin('12345')->type('md5')}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; # UUID binary roundtrip $bytes = "\x14\x00\x00\x00\x05\x66\x6f\x6f\x00\x05\x00\x00\x00\x04\x31\x32\x33" . "\x34\x35\x00"; $doc = bson_decode($bytes); isa_ok $doc->{foo}, 'Mango::BSON::Binary', 'right class'; is $doc->{foo}->type, 'uuid', 'right type'; is_deeply $doc, {foo => bson_bin('12345')->type('uuid')}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; # User defined binary roundtrip $bytes = "\x14\x00\x00\x00\x05\x66\x6f\x6f\x00\x05\x00\x00\x00\x80\x31\x32\x33" . "\x34\x35\x00"; $doc = bson_decode($bytes); isa_ok $doc->{foo}, 'Mango::BSON::Binary', 'right class'; is $doc->{foo}->type, 'user_defined', 'right type'; is_deeply $doc, {foo => bson_bin('12345')->type('user_defined')}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; # DBRef roundtrip $bytes = "\x31\x00\x00\x00\x03\x64\x62\x72\x65\x66\x00\x25\x00\x00\x00\x07\x24\x69" . "\x64\x00\x52\x51\x39\xd8\x58\x67\xb4\x57\x14\x02\x00\x00\x02\x24\x72\x65" . "\x66\x00\x05\x00\x00\x00\x74\x65\x73\x74\x00\x00\x00"; $doc = bson_decode($bytes); is $doc->{dbref}{'$ref'}, 'test', 'right collection name'; is $doc->{dbref}{'$id'}->to_string, '525139d85867b45714020000', 'right object id'; is bson_encode($doc), $bytes, 'successful roundtrip'; # Unicode roundtrip $bytes = "\x21\x00\x00\x00\x02\xe2\x98\x83\x00\x13\x00\x00\x00\x49\x20\xe2\x99" . "\xa5\x20\x4d\x6f\x6a\x6f\x6c\x69\x63\x69\x6f\x75\x73\x21\x00\x00"; $doc = bson_decode($bytes); is_deeply $doc, {'☃' => 'I ♥ Mojolicious!'}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; # Object stringifies to "1" $bytes = "\x10\x00\x00\x00\x05\x66\x6f\x6f\x00\x01\x00\x00\x00\x00\x31\x00"; $doc = bson_decode($bytes); isa_ok $doc->{foo}, 'Mango::BSON::Binary', 'right class'; is $doc->{foo}->type, 'generic', 'right type'; is_deeply $doc, {foo => bson_bin('1')}, 'right document'; is bson_encode($doc), $bytes, 'successful roundtrip'; is bson_bin('1'), '1', 'right result'; # Blessed reference $bytes = bson_encode {test => b('test')}; is_deeply bson_decode($bytes), {test => 'test'}, 'successful roundtrip'; # Blessed reference with TO_JSON method $bytes = bson_encode({test => BSONTest->new}); is_deeply bson_decode($bytes), {test => {}}, 'successful roundtrip'; $bytes = bson_encode( { test => BSONTest->new( something => {just => 'works'}, else => {not => 'working'} ) } ); is_deeply bson_decode($bytes), {test => {just => 'works'}}, 'successful roundtrip'; # Boolean shortcut is_deeply bson_decode(bson_encode({true => \1})), {true => bson_true}, 'encode true boolean from constant reference'; is_deeply bson_decode(bson_encode({false => \0})), {false => bson_false}, 'encode false boolean from constant reference'; $bytes = 'some true value'; is_deeply bson_decode(bson_encode({true => \!!$bytes})), {true => bson_true}, 'encode true boolean from double negated reference'; is_deeply bson_decode(bson_encode({true => \$bytes})), {true => bson_true}, 'encode true boolean from reference'; $bytes = ''; is_deeply bson_decode(bson_encode({false => \!!$bytes})), {false => bson_false}, 'encode false boolean from double negated reference'; is_deeply bson_decode(bson_encode({false => \$bytes})), {false => bson_false}, 'encode false boolean from reference'; # Mojo::JSON booleans is_deeply bson_decode(bson_encode {test => Mojo::JSON->true}), {test => bson_true}, 'encode true boolean from Mojo::JSON'; is_deeply bson_decode(bson_encode {test => Mojo::JSON->false}), {test => bson_false}, 'encode false boolean from Mojo::JSON'; # Upgraded numbers my $num = 3; my $str = "$num"; is_deeply bson_decode(bson_encode {test => [$num, $str]}), {test => [3, "3"]}, 'upgraded number detected'; $num = 1.5; $str = "$num"; is_deeply bson_decode(bson_encode {test => [$num, $str]}), {test => [1.5, "1.5"]}, 'upgraded number detected'; $str = '0 but true'; $num = 1 + $str; is_deeply bson_decode(bson_encode {test => [$num, $str]}), {test => [1, 0]}, 'upgraded number detected'; # "inf" and "nan" is_deeply bson_decode(bson_encode {test => [9**9**9]}), {test => [9**9**9]}, 'successful roundtrip'; is_deeply bson_decode(bson_encode {test => [-sin(9**9**9)]}), {test => [-sin(9**9**9)]}, 'successful roundtrip'; # Time to JSON is j({time => bson_time(1360626536748)}), '{"time":1360626536748}', 'right JSON'; # Binary to JSON is j({bin => bson_bin('Hello World!')}), '{"bin":"SGVsbG8gV29ybGQh"}', 'right JSON'; # DBRef to JSON is j({dbref => bson_dbref('test', bson_oid('525139d85867b45714020000'))}), '{"dbref":{"$ref":"test","$id":"525139d85867b45714020000"}}', 'right JSON'; # Validate object id is bson_oid('123456789012345678abcdef'), '123456789012345678abcdef', 'valid object id'; is bson_oid('123456789012345678ABCDEF'), '123456789012345678ABCDEF', 'valid object id'; eval { bson_oid('123456789012345678abcde') }; like $@, qr/Invalid object id "123456789012345678abcde"/, 'object id too short'; eval { bson_oid('123456789012345678abcdeff') }; like $@, qr/Invalid object id "123456789012345678abcdeff"/, 'object id too long'; eval { bson_oid('123456789012345678abcdgf') }; like $@, qr/Invalid object id "123456789012345678abcdgf"/, 'invalid object id'; eval { bson_oid(0) }; like $@, qr/Invalid object id "0"/, 'invalid object id'; done_testing(); Mango-0.22/t/collection.t000644 000765 000024 00000037212 12254223726 015233 0ustar00sristaff000000 000000 use Mojo::Base -strict; use Test::More; plan skip_all => 'set TEST_ONLINE to enable this test' unless $ENV{TEST_ONLINE}; use Mango; use Mango::BSON qw(bson_code bson_doc bson_oid bson_true); use Mojo::IOLoop; # Clean up before start my $mango = Mango->new($ENV{TEST_ONLINE}); my $collection = $mango->db->collection('collection_test'); $collection->drop if $collection->options; # Collection names is $collection->name, 'collection_test', 'right collection name'; is $collection->full_name, join('.', $mango->db->name, $collection->name), 'right full collection name'; # Index names is $collection->build_index_name({foo => 1}), 'foo', 'right index name'; is $collection->build_index_name(bson_doc(foo => 1, bar => -1)), 'foo_bar', 'right index name'; is $collection->build_index_name(bson_doc(foo => 1, 'bar.baz' => -1)), 'foo_bar.baz', 'right index name'; is $collection->build_index_name(bson_doc(foo => 1, bar => -1, baz => '2d')), 'foo_bar_baz', 'right index name'; # Insert documents blocking my $oids = $collection->insert([{foo => 'bar'}, {foo => 'baz'}]); isa_ok $oids->[0], 'Mango::BSON::ObjectID', 'right class'; isa_ok $oids->[1], 'Mango::BSON::ObjectID', 'right class'; is $collection->find_one($oids->[0])->{foo}, 'bar', 'right value'; is $collection->find_one($oids->[1])->{foo}, 'baz', 'right value'; # Get collection statistics blocking is $collection->stats->{count}, 2, 'right number of documents'; # Get collection statistics non-blocking my ($fail, $result) = @_; $collection->stats( sub { my ($collection, $err, $stats) = @_; $fail = $err; $result = $stats; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; is $result->{count}, 2, 'right number of documents'; # Update documents blocking is $collection->update({}, {'$set' => {bar => 'works'}}, {multi => 1})->{n}, 2, 'two documents updated'; is $collection->update({}, {'$set' => {baz => 'too'}})->{n}, 1, 'one document updated'; is $collection->find_one($oids->[0])->{bar}, 'works', 'right value'; is $collection->find_one($oids->[1])->{bar}, 'works', 'right value'; is $collection->update({missing => 1}, {now => 'there'}, {upsert => 1})->{n}, 1, 'one document updated'; is $collection->update({missing => 1}, {now => 'there'}, {upsert => 1})->{n}, 1, 'one document updated'; is $collection->remove({now => 'there'}, {single => 1})->{n}, 1, 'one document removed'; is $collection->remove({now => 'there'}, {single => 1})->{n}, 1, 'one document removed'; # Remove one document blocking is $collection->remove({foo => 'baz'})->{n}, 1, 'one document removed'; ok $collection->find_one($oids->[0]), 'document still exists'; ok !$collection->find_one($oids->[1]), 'no document'; is $collection->remove->{n}, 1, 'one document removed'; ok !$collection->find_one($oids->[0]), 'no document'; # Find and modify document blocking my $oid = $collection->insert({atomic => 1}); is $collection->find_one($oid)->{atomic}, 1, 'right document'; my $doc = $collection->find_and_modify( {query => {atomic => 1}, update => {'$set' => {atomic => 2}}}); is $doc->{atomic}, 1, 'right document'; is $collection->find_one($oid)->{atomic}, 2, 'right document'; is $collection->remove({atomic => 2})->{n}, 1, 'removed one document'; # Find and modify document non-blocking $oid = $collection->insert({atomic => 1}); is $collection->find_one($oid)->{atomic}, 1, 'right document'; ($fail, $result) = (); $collection->find_and_modify( {query => {atomic => 1}, update => {'$set' => {atomic => 2}}} => sub { my ($collection, $err, $doc) = @_; $fail = $err; $result = $doc; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; is $result->{atomic}, 1, 'right document'; is $collection->find_one($oid)->{atomic}, 2, 'right document'; is $collection->remove({atomic => 2})->{n}, 1, 'removed one document'; # Get options blocking is $collection->options->{name}, $collection->full_name, 'right name'; # Get options non-blocking ($fail, $result) = (); $collection->options( sub { my ($collection, $err, $doc) = @_; $fail = $err; $result = $doc; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; is $result->{name}, $collection->full_name, 'right name'; # Get options blocking (missing collection) is $mango->db->collection('collection_test2')->options, undef, 'collection does not exist'; # Get options non-blocking (missing collection) ($fail, $result) = (); $mango->db->collection('collection_test2')->options( sub { my ($collection, $err, $doc) = @_; $fail = $err; $result = $doc; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; is $result, undef, 'collection does not exist'; # Aggregate collection blocking $collection->insert([{more => 1}, {more => 2}, {more => 3}]); my $docs = $collection->aggregate( [{'$group' => {_id => undef, total => {'$sum' => '$more'}}}]); is $docs->[0]{total}, 6, 'right result'; is $collection->remove({more => {'$exists' => 1}})->{n}, 3, 'three documents removed'; # Aggregate collection non-blocking $collection->insert([{more => 1}, {more => 2}, {more => 3}]); ($fail, $result) = (); $collection->aggregate( [{'$group' => {_id => undef, total => {'$sum' => '$more'}}}] => sub { my ($collection, $err, $docs) = @_; $fail = $err; $result = $docs; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; is $result->[0]{total}, 6, 'right result'; is $collection->remove({more => {'$exists' => 1}})->{n}, 3, 'three documents removed'; # Aggregate with cursors and collections SKIP: { my $version = $mango->db->command('buildInfo')->{versionArray}; skip 'MongoDB 2.5 required!', 11 unless join('.', @$version[0, 1]) >= '2.5'; # Aggregate with cursor $collection->insert({stuff => $_}) for 1 .. 30; my $cursor = $collection->aggregate([{'$match' => {stuff => {'$gt' => 0}}}], {cursor => {}}); ok !$cursor->id, 'no cursor id'; is scalar @{$cursor->all}, 30, 'thirty documents found'; is $collection->remove->{n}, 30, 'thirty documents removed'; # Aggregate with collections $collection->insert({stuff => $_}) for 1 .. 30; my $out = $collection->aggregate( [ {'$match' => {stuff => {'$gt' => 0}}}, {'$out' => 'collection_test_results'} ] ); is $out->name, 'collection_test_results', 'right name'; is $out->find->count, 30, 'thirty documents found'; $out->drop; is $collection->remove->{n}, 30, 'thirty documents removed'; # Aggregate with cursor blocking (multiple batches) $collection->insert({stuff => $_}) for 1 .. 30; $cursor = $collection->aggregate([{'$match' => {stuff => {'$gt' => 0}}}], {cursor => {batchSize => 5}}); ok $cursor->id, 'cursor has id'; is scalar @{$cursor->all}, 30, 'thirty documents found'; is $collection->remove->{n}, 30, 'thirty documents removed'; # Aggregate with cursor non-blocking (multiple batches) $collection->insert({stuff => $_}) for 1 .. 30; ($fail, $result) = (); my $delay = Mojo::IOLoop->delay( sub { my $delay = shift; $collection->aggregate( [{'$match' => {stuff => {'$gt' => 0}}}], {cursor => {batchSize => 5}}, $delay->begin ); }, sub { my ($delay, $err, $cursor) = @_; $fail = $err; $cursor->all($delay->begin); }, sub { my ($delay, $err, $docs) = @_; $fail ||= $err; $result = $docs; } ); $delay->wait; is scalar @$result, 30, 'thirty documents found'; is $collection->remove->{n}, 30, 'thirty documents removed'; } # Save document blocking $oid = $collection->save({update => 'me'}); $doc = $collection->find_one($oid); is $doc->{update}, 'me', 'right document'; $doc->{update} = 'too'; is $collection->save($doc), $oid, 'same object id'; $doc = $collection->find_one($oid); is $doc->{update}, 'too', 'right document'; is $collection->remove({_id => $oid})->{n}, 1, 'one document removed'; $oid = bson_oid; $doc = bson_doc _id => $oid, save => 'me'; is $collection->save($doc), $oid, 'same object id'; $doc = $collection->find_one($oid); is $doc->{save}, 'me', 'right document'; is $collection->remove({_id => $oid})->{n}, 1, 'one document removed'; # Save document non-blocking ($fail, $result) = (); $collection->save( {update => 'me'} => sub { my ($collection, $err, $oid) = @_; $fail = $err; $result = $oid; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; $doc = $collection->find_one($result); is $doc->{update}, 'me', 'right document'; $doc->{update} = 'too'; $oid = $result; ($fail, $result) = (); $collection->save( $doc => sub { my ($collection, $err, $oid) = @_; $fail = $err; $result = $oid; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; is $oid, $result, 'same object id'; $doc = $collection->find_one($oid); is $doc->{update}, 'too', 'right document'; is $collection->remove({_id => $oid})->{n}, 1, 'one document removed'; $oid = bson_oid; $doc = bson_doc _id => $oid, save => 'me'; ($fail, $result) = (); $collection->save( $doc => sub { my ($collection, $err, $oid) = @_; $fail = $err; $result = $oid; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; is $oid, $result, 'same object id'; $doc = $collection->find_one($oid, {_id => 0}); is_deeply $doc, {save => 'me'}, 'right document'; is $collection->remove({_id => $oid})->{n}, 1, 'one document removed'; # Drop collection blocking $oid = $collection->insert({just => 'works'}); is $collection->find_one($oid)->{just}, 'works', 'right document'; $collection->drop; ok !$collection->find_one($oid), 'no document'; # Drop collection non-blocking $oid = $collection->insert({just => 'works'}); is $collection->find_one($oid)->{just}, 'works', 'right document'; $fail = undef; $collection->drop( sub { my ($collection, $err) = @_; $fail = $err; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; ok !$collection->find_one($oid), 'no document'; # Ensure and drop index blocking $collection->insert({test => 23, foo => 'bar'}); $collection->insert({test => 23, foo => 'baz'}); is $collection->find->count, 2, 'two documents'; $collection->ensure_index({test => 1}, {unique => \1, dropDups => \1}); is $collection->find->count, 1, 'one document'; is $collection->index_information->{test}{unique}, bson_true, 'index is unique'; $collection->drop_index('test'); is $collection->index_information->{test}, undef, 'no index'; $collection->drop; # Ensure and drop index non-blocking $collection->insert({test => 23, foo => 'bar'}); $collection->insert({test => 23, foo => 'baz'}); is $collection->find->count, 2, 'two documents'; ($fail, $result) = (); my $delay = Mojo::IOLoop->delay( sub { my $delay = shift; $collection->ensure_index( ({test => 1}, {unique => \1, dropDups => \1}) => $delay->begin); }, sub { my ($delay, $err) = @_; $fail = $err; $collection->index_information($delay->begin); }, sub { my ($delay, $err, $info) = @_; $fail ||= $err; $result = $info; } ); $delay->wait; ok !$fail, 'no error'; is $collection->find->count, 1, 'one document'; is $result->{test}{unique}, bson_true, 'index is unique'; ($fail, $result) = (); $delay = Mojo::IOLoop->delay( sub { my $delay = shift; $collection->drop_index(test => $delay->begin); }, sub { my ($delay, $err) = @_; $fail = $err; $collection->index_information($delay->begin); }, sub { my ($delay, $err, $info) = @_; $fail ||= $err; $result = $info; } ); $delay->wait; ok !$fail, 'no error'; is $result->{test}, undef, 'no index'; $collection->drop; # Create capped collection blocking $collection->create({capped => \1, max => 2, size => 100000}); $collection->insert([{test => 1}, {test => 2}]); is $collection->find({})->count, 2, 'two documents'; $collection->insert({test => 3}); is $collection->find->count, 2, 'two documents'; $collection->drop; # Create capped collection non-blocking $fail = undef; $collection->create( {capped => \1, max => 2, size => 100000} => sub { my ($collection, $err) = @_; $fail = $err; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; $collection->insert([{test => 1}, {test => 2}]); is $collection->find({})->count, 2, 'two documents'; $collection->insert({test => 3}); is $collection->find->count, 2, 'two documents'; $collection->drop; # Perform map/reduce blocking my $map = <insert({x => 1, tags => [qw(dog cat)]}); $collection->insert({x => 2, tags => ['cat']}); $collection->insert({x => 3, tags => [qw(mouse cat dog)]}); $collection->insert({x => 4, tags => []}); my $out = $collection->map_reduce($map, $reduce, {out => 'collection_test_results'}); $collection->drop; $docs = $out->find->sort({value => -1})->all; is_deeply $docs->[0], {_id => 'cat', value => 3}, 'right document'; is_deeply $docs->[1], {_id => 'dog', value => 2}, 'right document'; is_deeply $docs->[2], {_id => 'mouse', value => 1}, 'right document'; $out->drop; # Perform map/reduce non-blocking $collection->insert({x => 1, tags => [qw(dog cat)]}); $collection->insert({x => 2, tags => ['cat']}); $collection->insert({x => 3, tags => [qw(mouse cat dog)]}); $collection->insert({x => 4, tags => []}); ($fail, $result) = (); $collection->map_reduce( ($map, $reduce, {out => 'collection_test_results'}) => sub { my ($collection, $err, $out) = @_; $fail = $err; $result = $out; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; $collection->drop; $docs = $result->find->sort({value => -1})->all; is_deeply $docs->[0], {_id => 'cat', value => 3}, 'right document'; is_deeply $docs->[1], {_id => 'dog', value => 2}, 'right document'; is_deeply $docs->[2], {_id => 'mouse', value => 1}, 'right document'; $result->drop; # Perform inline map/reduce blocking $collection->insert({x => 1, tags => [qw(dog cat)]}); $collection->insert({x => 2, tags => ['cat']}); $collection->insert({x => 3, tags => [qw(mouse cat dog)]}); $collection->insert({x => 4, tags => []}); $docs = $collection->map_reduce(bson_code($map), bson_code($reduce), {out => {inline => 1}}); $collection->drop; is_deeply $docs->[0], {_id => 'cat', value => 3}, 'right document'; is_deeply $docs->[1], {_id => 'dog', value => 2}, 'right document'; is_deeply $docs->[2], {_id => 'mouse', value => 1}, 'right document'; # Perform inline map/reduce non-blocking $collection->insert({x => 1, tags => [qw(dog cat)]}); $collection->insert({x => 2, tags => ['cat']}); $collection->insert({x => 3, tags => [qw(mouse cat dog)]}); $collection->insert({x => 4, tags => []}); ($fail, $result) = (); $collection->map_reduce( (bson_code($map), bson_code($reduce), {out => {inline => 1}}) => sub { my ($collection, $err, $docs) = @_; $fail = $err; $result = $docs; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; $collection->drop; is_deeply $result->[0], {_id => 'cat', value => 3}, 'right document'; is_deeply $result->[1], {_id => 'dog', value => 2}, 'right document'; is_deeply $result->[2], {_id => 'mouse', value => 1}, 'right document'; # Interrupted non-blocking remove my $port = Mojo::IOLoop->generate_port; $mango = Mango->new("mongodb://localhost:$port"); my $id = Mojo::IOLoop->server((port => $port) => sub { $_[1]->close }); ($fail, $result) = (); $mango->db->collection('collection_test')->remove( sub { my ($collection, $err, $doc) = @_; $fail = $err; $result = $doc; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; Mojo::IOLoop->remove($id); like $fail, qr/Premature connection close/, 'right error'; ok !$result->{n}, 'remove was not successful'; done_testing(); Mango-0.22/t/connection.t000644 000765 000024 00000014273 12254223763 015242 0ustar00sristaff000000 000000 use Mojo::Base -strict; use Test::More; plan skip_all => 'set TEST_ONLINE to enable this test' unless $ENV{TEST_ONLINE}; use Mango; use Mojo::IOLoop; # Defaults my $mango = Mango->new; is_deeply $mango->hosts, [['localhost']], 'right hosts'; is $mango->default_db, 'admin', 'right default database'; is_deeply $mango->credentials, [], 'no credentials'; is $mango->j, 0, 'right j value'; is $mango->w, 1, 'right w value'; is $mango->wtimeout, 1000, 'right wtimeout value'; is $mango->backlog, 0, 'no operations waiting'; # Simple connection string $mango = Mango->new('mongodb://127.0.0.1:3000'); is_deeply $mango->hosts, [['127.0.0.1', 3000]], 'right hosts'; is $mango->default_db, 'admin', 'right default database'; is_deeply $mango->credentials, [], 'no credentials'; is $mango->j, 0, 'right j value'; is $mango->w, 1, 'right w value'; is $mango->wtimeout, 1000, 'right wtimeout value'; # Complex connection string $mango = Mango->new( 'mongodb://x1:y2@foo.bar:5000,baz:3000/test?journal=1&w=2&wtimeoutMS=2000'); is_deeply $mango->hosts, [['foo.bar', 5000], ['baz', 3000]], 'right hosts'; is $mango->default_db, 'test', 'right default database'; is_deeply $mango->credentials, [[qw(test x1 y2)]], 'right credentials'; is $mango->j, 1, 'right j value'; is $mango->w, 2, 'right w value'; is $mango->wtimeout, 2000, 'right wtimeout value'; is $mango->db->name, 'test', 'right database name'; # Invalid connection string eval { Mango->new('http://localhost:3000/test') }; like $@, qr/Invalid MongoDB connection string/, 'right error'; # No port $mango = Mango->new->from_string('mongodb://127.0.0.1,127.0.0.1:5000'); is_deeply $mango->hosts, [['127.0.0.1'], ['127.0.0.1', 5000]], 'right hosts'; # Connection error my $port = Mojo::IOLoop->generate_port; eval { Mango->new("mongodb://127.0.0.1:$port/test")->db->command('getnonce') }; ok $@, 'has error'; # Clean up before start $mango = Mango->new($ENV{TEST_ONLINE}); my $collection = $mango->db->collection('connection_test'); $collection->drop if $collection->options; # Blocking CRUD my $oid = $collection->insert({foo => 'bar'}); is $mango->backlog, 0, 'no operations waiting'; isa_ok $oid, 'Mango::BSON::ObjectID', 'right class'; my $doc = $collection->find_one({foo => 'bar'}); is_deeply $doc, {_id => $oid, foo => 'bar'}, 'right document'; $doc->{foo} = 'yada'; is $collection->update({foo => 'bar'}, $doc)->{n}, 1, 'one document updated'; $doc = $collection->find_one($oid); is_deeply $doc, {_id => $oid, foo => 'yada'}, 'right document'; is $collection->remove->{n}, 1, 'one document removed'; # Non-blocking CRUD my ($fail, $backlog, $created, $updated, $found, $removed); my $delay = Mojo::IOLoop->delay( sub { my $delay = shift; $collection->insert({foo => 'bar'} => $delay->begin); $backlog = $collection->db->mango->backlog; }, sub { my ($delay, $err, $oid) = @_; $fail = $err; $created = $oid; $collection->find_one({foo => 'bar'} => $delay->begin); }, sub { my ($delay, $err, $doc) = @_; $fail ||= $err; $doc->{foo} = 'yada'; $collection->update(({foo => 'bar'}, $doc) => $delay->begin); }, sub { my ($delay, $err, $doc) = @_; $fail ||= $err; $updated = $doc; $collection->find_one($created => $delay->begin); }, sub { my ($delay, $err, $doc) = @_; $fail ||= $err; $found = $doc; $collection->remove($delay->begin); }, sub { my ($delay, $err, $doc) = @_; $fail ||= $err; $removed = $doc; } ); $delay->wait; ok !$fail, 'no error'; is $backlog, 1, 'one operation waiting'; isa_ok $created, 'Mango::BSON::ObjectID', 'right class'; is $updated->{n}, 1, 'one document updated'; is_deeply $found, {_id => $created, foo => 'yada'}, 'right document'; is $removed->{n}, 1, 'one document removed'; # Error in callback $collection->insert({foo => 'bar'} => sub { die 'Oops!' }); $fail = undef; $mango->once( error => sub { my ($mango, $err) = @_; $fail = $err; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; like $fail, qr/Oops!/, 'right error'; is $collection->remove->{n}, 1, 'one document removed'; # Fork safety $mango = Mango->new($ENV{TEST_ONLINE}); $collection = $mango->db->collection('connection_test'); my ($connections, $current); $mango->on( connection => sub { my ($mango, $id) = @_; $connections++; $current = $id; } ); is $collection->find->count, 0, 'no documents'; is $connections, 1, 'one connection'; ok $mango->ioloop->stream($current), 'connection exists'; my $last = $current; is $collection->find->count, 0, 'no documents'; is $connections, 1, 'one connection'; ok $mango->ioloop->stream($current), 'connection exists'; is $last, $current, 'same connection'; { local $$ = -23; is $collection->find->count, 0, 'no documents'; is $connections, 2, 'two connections'; ok $mango->ioloop->stream($current), 'connection exists'; isnt $last, $current, 'different connections'; $last = $current; is $collection->find->count, 0, 'no documents'; is $connections, 2, 'two connections'; ok $mango->ioloop->stream($current), 'connection exists'; is $last, $current, 'same connection'; } # Mixed parallel operations $collection->insert({test => $_}) for 1 .. 3; is $mango->backlog, 0, 'no operations waiting'; $delay = Mojo::IOLoop->delay; $collection->find_one(({test => $_}, {_id => 0}) => $delay->begin) for 1 .. 3; is $mango->backlog, 3, 'three operations waiting'; eval { $collection->find_one({test => 1}) }; like $@, qr/^Non-blocking operations in progress/, 'right error'; my @results = $delay->wait; is $mango->backlog, 0, 'no operations waiting'; ok !$results[0], 'no error'; is_deeply $results[1], {test => 1}, 'right result'; ok !$results[2], 'no error'; is_deeply $results[3], {test => 2}, 'right result'; ok !$results[4], 'no error'; is_deeply $results[5], {test => 3}, 'right result'; is $collection->remove->{n}, 3, 'three documents removed'; # Fallback server $mango = Mango->new($ENV{TEST_ONLINE}); $port = Mojo::IOLoop->generate_port; unshift @{$mango->hosts}, ['127.0.0.1', $port]; ok $mango->db->command('getnonce')->{nonce}, 'command was successful'; is_deeply $mango->hosts->[0], ['127.0.0.1', $port], 'right server'; ok scalar @{$mango->hosts} > 1, 'more than one server'; done_testing(); Mango-0.22/t/cursor.t000644 000765 000024 00000020340 12254224000 014371 0ustar00sristaff000000 000000 use Mojo::Base -strict; use Test::More; plan skip_all => 'set TEST_ONLINE to enable this test' unless $ENV{TEST_ONLINE}; use Mango; use Mojo::IOLoop; # Clean up before start my $mango = Mango->new($ENV{TEST_ONLINE}); my $collection = $mango->db->collection('cursor_test'); $collection->drop if $collection->options; # Add some documents to fetch my $oids = $collection->insert([{test => 3}, {test => 1}, {test => 2}]); is scalar @$oids, 3, 'three documents inserted'; # Fetch documents blocking my $cursor = $collection->find->batch_size(2); my @docs; ok !$cursor->id, 'no cursor id'; push @docs, $cursor->next; ok $cursor->id, 'cursor has id'; push @docs, $cursor->next; push @docs, $cursor->next; ok !$cursor->next, 'no more documents'; @docs = sort { $a->{test} <=> $b->{test} } @docs; is $docs[0]{test}, 1, 'right document'; is $docs[1]{test}, 2, 'right document'; is $docs[2]{test}, 3, 'right document'; # Fetch all documents blocking my $docs = $collection->find->batch_size(2)->all; @$docs = sort { $a->{test} <=> $b->{test} } @$docs; is $docs->[0]{test}, 1, 'right document'; is $docs->[1]{test}, 2, 'right document'; is $docs->[2]{test}, 3, 'right document'; # Fetch two documents blocking $docs = $collection->find->limit(-2)->sort({test => 1})->all; is scalar @$docs, 2, 'two documents'; is $docs->[0]{test}, 1, 'right document'; is $docs->[1]{test}, 2, 'right document'; # Build query $cursor = $collection->find({test => 1}); is_deeply $cursor->build_query, {test => 1}, 'right query'; is_deeply $cursor->build_query(1), {'$query' => {test => 1}, '$explain' => 1}, 'right query'; $cursor->sort({test => -1}); is_deeply $cursor->build_query, {'$query' => {test => 1}, '$orderby' => {test => -1}}, 'right query'; $cursor->sort(undef)->hint({test => 1})->snapshot(1); is_deeply $cursor->build_query, {'$query' => {test => 1}, '$hint' => {test => 1}, '$snapshot' => 1}, 'right query'; $cursor->hint(undef)->snapshot(undef)->max_scan(500); is_deeply $cursor->build_query, {'$query' => {test => 1}, '$maxScan' => 500}, 'right query'; $cursor = $collection->find({'$query' => {foo => 'bar'}, '$foo' => 'bar'}); is_deeply $cursor->build_query, {'$query' => {foo => 'bar'}, '$foo' => 'bar'}, 'right query'; $cursor = $collection->find({'$query' => {foo => 'bar'}, '$foo' => 'bar'}); is_deeply $cursor->build_query(1), {'$query' => {foo => 'bar'}, '$foo' => 'bar', '$explain' => 1}, 'right query'; is_deeply $cursor->query, {'$query' => {foo => 'bar'}, '$foo' => 'bar'}, 'query has not changed'; # Clone cursor $cursor = $collection->find({test => {'$exists' => 1}})->batch_size(2)->limit(3) ->skip(1)->sort({test => 1})->fields({test => 1})->max_scan(100); my $doc = $cursor->next; ok defined $cursor->id, 'has a cursor id'; ok $doc->{test}, 'right document'; my $clone = $cursor->snapshot(1)->hint({test => 1})->tailable(1)->clone; isnt $cursor, $clone, 'different objects'; ok !defined $clone->id, 'has no cursor id'; is $clone->batch_size, 2, 'right batch size'; is_deeply $clone->fields, {test => 1}, 'right fields'; is_deeply $clone->hint, {test => 1}, 'right hint value'; is $clone->limit, 3, 'right limit'; is_deeply $clone->query, {test => {'$exists' => 1}}, 'right query'; is $clone->skip, 1, 'right skip value'; is $clone->snapshot, 1, 'right snapshot value'; is $clone->max_scan, 100, 'right max_scan value'; is $clone->tailable, 1, 'is tailable'; is_deeply $clone->sort, {test => 1}, 'right sort value'; $cursor = $collection->find({foo => 'bar'}, {foo => 1}); is_deeply $cursor->clone->query, {foo => 'bar'}, 'right query'; is_deeply $cursor->clone->fields, {foo => 1}, 'right fields'; # Explain blocking $cursor = $collection->find({test => 2}); $doc = $cursor->explain; is $doc->{n}, 1, 'one document'; $doc = $cursor->next; is $doc->{test}, 2, 'right document'; # Explain non-blocking $cursor = $collection->find({test => 2}); my ($fail, $result); $cursor->explain( sub { my ($cursor, $err, $doc) = @_; $fail = $err; $result = $doc->{n}; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; is $result, 1, 'one document'; is $cursor->next->{test}, 2, 'right document'; # Get distinct values blocking is_deeply [ sort @{$collection->find({test => {'$gt' => 1}})->distinct('test')} ], [2, 3], 'right values'; # Get distinct values non-blocking ($fail, $result) = (); $collection->find({test => {'$gt' => 1}})->distinct( test => sub { my ($cursor, $err, $values) = @_; $fail = $err; $result = $values; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; is_deeply [sort @$result], [2, 3], 'right values'; # Count documents blocking is $collection->find({foo => 'bar'})->count, 0, 'no documents'; is $collection->find->skip(1)->limit(1)->count, 1, 'one document'; is $collection->find->count, 3, 'three documents'; # Count documents non-blocking $fail = undef; my @results; my $delay = Mojo::IOLoop->delay( sub { my $delay = shift; $collection->find->count($delay->begin); }, sub { my ($delay, $err, $count) = @_; $fail = $err; push @results, $count; $collection->find({foo => 'bar'})->count($delay->begin); }, sub { my ($delay, $err, $count) = @_; $fail ||= $err; push @results, $count; } ); $delay->wait; ok !$fail, 'no error'; is_deeply \@results, [3, 0], 'right number of documents'; # Fetch documents non-blocking $cursor = $collection->find->batch_size(2); @docs = (); $fail = undef; $delay = Mojo::IOLoop->delay( sub { my $delay = shift; $cursor->next($delay->begin); }, sub { my ($delay, $err, $doc) = @_; $fail = $err; push @docs, $doc; $cursor->next($delay->begin); }, sub { my ($delay, $err, $doc) = @_; $fail ||= $err; push @docs, $doc; $cursor->next($delay->begin); }, sub { my ($delay, $err, $doc) = @_; $fail ||= $err; push @docs, $doc; } ); $delay->wait; ok !$fail, 'no error'; @docs = sort { $a->{test} <=> $b->{test} } @docs; is $docs[0]{test}, 1, 'right document'; is $docs[1]{test}, 2, 'right document'; is $docs[2]{test}, 3, 'right document'; # Fetch all documents non-blocking @docs = (); $collection->find->batch_size(2)->all( sub { my ($collection, $err, $docs) = @_; @docs = @$docs; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; @docs = sort { $a->{test} <=> $b->{test} } @docs; is $docs[0]{test}, 1, 'right document'; is $docs[1]{test}, 2, 'right document'; is $docs[2]{test}, 3, 'right document'; # Fetch subset of documents sorted $docs = $collection->find->fields({_id => 0})->sort({test => 1})->all; is_deeply $docs, [{test => 1}, {test => 2}, {test => 3}], 'right subset'; # Rewind cursor blocking $cursor = $collection->find; ok !$cursor->id, 'no cursor id'; $cursor->rewind; $doc = $cursor->next; ok $doc, 'found a document'; $cursor->rewind; is_deeply $cursor->next, $doc, 'found same document again'; # Rewind cursor non-blocking $fail = undef; @docs = (); $cursor = $collection->find; $delay = Mojo::IOLoop->delay( sub { my $delay = shift; $cursor->next($delay->begin); }, sub { my ($delay, $err, $doc) = @_; $fail = $err; push @docs, $doc; $cursor->rewind($delay->begin); }, sub { my ($delay, $err) = @_; $fail ||= $err; $cursor->next($delay->begin); }, sub { my ($delay, $err, $doc) = @_; $fail ||= $err; push @docs, $doc; } ); $delay->wait; ok !$fail, 'no error'; is_deeply $docs[0], $docs[1], 'found same document again'; # Tailable cursor $collection->drop; $collection->create({capped => \1, max => 2, size => 100000}); my $collection2 = $mango->db->collection('cursor_test'); $collection2->insert([{test => 1}, {test => 2}]); $cursor = $collection->find->tailable(1); is $cursor->next->{test}, 1, 'right document'; is $cursor->next->{test}, 2, 'right document'; ($fail, $result) = (); my $tail; $delay = Mojo::IOLoop->delay( sub { my $delay = shift; my $end = $delay->begin; $cursor->next($delay->begin); Mojo::IOLoop->timer( 0.5 => sub { $collection2->insert({test => 3} => $end) }); }, sub { my ($delay, $err1, $oid, $err2, $doc) = @_; $fail = $err1 || $err2; $result = $oid; $tail = $doc; } ); $delay->wait; ok !$fail, 'no error'; is $tail->{test}, 3, 'right document'; is $tail->{_id}, $result, 'same document'; $collection->drop; done_testing(); Mango-0.22/t/database.t000644 000765 000024 00000005626 12254224047 014645 0ustar00sristaff000000 000000 use Mojo::Base -strict; use Test::More; plan skip_all => 'set TEST_ONLINE to enable this test' unless $ENV{TEST_ONLINE}; use Mango; use Mango::BSON qw(bson_code bson_dbref); use Mojo::IOLoop; # Run command blocking my $mango = Mango->new($ENV{TEST_ONLINE}); my $db = $mango->db; ok $db->command('getnonce')->{nonce}, 'command was successful'; # Run command non-blocking my ($fail, $result); $db->command( 'getnonce' => sub { my ($db, $err, $doc) = @_; $fail = $err; $result = $doc->{nonce}; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; ok $result, 'command was successful'; # Get database statistics blocking ok exists $db->stats->{objects}, 'has objects'; # Get database statistics non-blocking ($fail, $result) = (); $db->stats( sub { my ($db, $err, $stats) = @_; $fail = $err; $result = $stats; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; ok exists $result->{objects}, 'has objects'; # Get collection names blocking my $collection = $db->collection('database_test'); $collection->insert({test => 1}); ok grep { $_ eq 'database_test' } @{$db->collection_names}, 'found collection'; $collection->drop; # Get collection names non-blocking $collection->insert({test => 1}); ($fail, $result) = (); $db->collection_names( sub { my ($db, $err, $names) = @_; $fail = $err; $result = $names; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; ok grep { $_ eq 'database_test' } @$result, 'found collection'; $collection->drop; # Dereference blocking my $oid = $collection->insert({test => 23}); is $db->dereference(bson_dbref('database_test', $oid))->{test}, 23, 'right result'; $collection->drop; # Dereference non-blocking $oid = $collection->insert({test => 23}); ($fail, $result) = (); $db->dereference( bson_dbref('database_test', $oid) => sub { my ($db, $err, $doc) = @_; $fail = $err; $result = $doc; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; is $result->{test}, 23, 'right result'; $collection->drop; # Interrupted blocking command my $port = Mojo::IOLoop->generate_port; $mango = Mango->new("mongodb://localhost:$port"); my $id = $mango->ioloop->server((port => $port) => sub { $_[1]->close }); eval { $mango->db->command('getnonce') }; like $@, qr/Premature connection close/, 'right error'; $mango->ioloop->remove($id); # Interrupted non-blocking command $port = Mojo::IOLoop->generate_port; $mango = Mango->new("mongodb://localhost:$port"); $id = Mojo::IOLoop->server((port => $port) => sub { $_[1]->close }); ($fail, $result) = (); $mango->db->command( 'getnonce' => sub { my ($db, $err, $doc) = @_; $fail = $err; $result = $doc; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; Mojo::IOLoop->remove($id); like $fail, qr/Premature connection close/, 'right error'; is_deeply $result, {}, 'command was not successful'; done_testing(); Mango-0.22/t/gridfs.t000644 000765 000024 00000020217 12247717341 014356 0ustar00sristaff000000 000000 use Mojo::Base -strict; use Test::More; plan skip_all => 'set TEST_ONLINE to enable this test' unless $ENV{TEST_ONLINE}; use Mango; use Mango::BSON 'bson_oid'; use Mojo::IOLoop; # Clean up before start my $mango = Mango->new($ENV{TEST_ONLINE}); my $gridfs = $mango->db->gridfs; $gridfs->$_->remove for qw(files chunks); # Blocking roundtrip my $writer = $gridfs->writer; $writer->filename('foo.txt')->content_type('text/plain') ->metadata({foo => 'bar'}); ok !$writer->is_closed, 'file has not been closed'; my $oid = $writer->write('hello ')->write('world!')->close; ok $writer->is_closed, 'file has been closed'; my $reader = $gridfs->reader; is $reader->tell, 0, 'right position'; $reader->open($oid); is $reader->filename, 'foo.txt', 'right filename'; is $reader->content_type, 'text/plain', 'right content type'; is_deeply $reader->metadata, {foo => 'bar'}, 'right structure'; is $reader->size, 12, 'right size'; is $reader->chunk_size, 262144, 'right chunk size'; is length $reader->upload_date, length(time) + 3, 'right time format'; my $data; while (defined(my $chunk = $reader->read)) { $data .= $chunk } is $reader->tell, 12, 'right position'; is $data, 'hello world!', 'right content'; $data = undef; $reader->seek(0); is $reader->tell, 0, 'right position'; $reader->seek(2); is $reader->tell, 2, 'right position'; while (defined(my $chunk = $reader->read)) { $data .= $chunk } is $data, 'llo world!', 'right content'; is_deeply $gridfs->list, ['foo.txt'], 'right files'; $gridfs->delete($oid); is_deeply $gridfs->list, [], 'no files'; is $gridfs->chunks->find->count, 0, 'no chunks left'; $gridfs->$_->drop for qw(files chunks); # Non-blocking roundtrip $writer = $gridfs->writer->chunk_size(4); $writer->filename('foo.txt')->content_type('text/plain') ->metadata({foo => 'bar'}); ok !$writer->is_closed, 'file has not been closed'; my ($fail, $result); my $delay = Mojo::IOLoop->delay( sub { my $delay = shift; $writer->write('he' => $delay->begin); }, sub { my ($delay, $err) = @_; $fail = $err; $writer->write('llo ' => $delay->begin); }, sub { my ($delay, $err) = @_; $fail ||= $err; $writer->write('w' => $delay->begin); $writer->write('orld!' => $delay->begin); }, sub { my ($delay, $err) = @_; $fail ||= $err; $writer->close($delay->begin); }, sub { my ($delay, $err, $oid) = @_; $fail ||= $err; $result = $oid; } ); $delay->wait; ok !$fail, 'no error'; ok $writer->is_closed, 'file has been closed'; $reader = $gridfs->reader; $fail = undef; $reader->open( $result => sub { my ($reader, $err) = @_; $fail = $err; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; is $reader->filename, 'foo.txt', 'right filename'; is $reader->content_type, 'text/plain', 'right content type'; is_deeply $reader->metadata, {foo => 'bar'}, 'right structure'; is $reader->size, 12, 'right size'; is $reader->chunk_size, 4, 'right chunk size'; is length $reader->upload_date, length(time) + 3, 'right time format'; ($fail, $data) = (); my $cb; $cb = sub { my ($reader, $err, $chunk) = @_; $fail ||= $err; return Mojo::IOLoop->stop unless defined $chunk; $data .= $chunk; $reader->read($cb); }; $reader->$cb(undef, ''); Mojo::IOLoop->start; ok !$fail, 'no error'; is $data, 'hello world!', 'right content'; my ($before, $after); $fail = undef; $delay = Mojo::IOLoop->delay( sub { $gridfs->list(shift->begin) }, sub { my ($delay, $err, $names) = @_; $fail = $err; $before = $names; $gridfs->delete($result => $delay->begin); }, sub { my ($delay, $err) = @_; $fail ||= $err; $gridfs->list($delay->begin); }, sub { my ($delay, $err, $names) = @_; $fail ||= $err; $after = $names; } ); $delay->wait; ok !$fail, 'no error'; is_deeply $before, ['foo.txt'], 'right files'; is_deeply $after, [], 'no files'; is $gridfs->chunks->find->count, 0, 'no chunks left'; $gridfs->$_->drop for qw(files chunks); # Find and slurp versions blocking my $one = $gridfs->writer->chunk_size(1)->filename('test.txt')->write('One1')->close; my $two = $gridfs->writer->filename('test.txt')->write('Two')->close; is_deeply $gridfs->list, ['test.txt'], 'right files'; is $gridfs->find_version('test.txt', 1), $one, 'right version'; is $gridfs->find_version('test.txt', 2), $two, 'right version'; is $gridfs->find_version('test.txt', 3), undef, 'no version'; is $gridfs->reader->open($one)->slurp, 'One1', 'right content'; is $gridfs->reader->open($one)->seek(1)->slurp, 'ne1', 'right content'; is $gridfs->reader->open($two)->slurp, 'Two', 'right content'; is $gridfs->reader->open($two)->seek(1)->slurp, 'wo', 'right content'; $gridfs->$_->drop for qw(files chunks); # Find and slurp versions non-blocking $one = $gridfs->writer->filename('test.txt')->write('One')->close; $two = $gridfs->writer->filename('test.txt')->write('Two')->close; is_deeply $gridfs->list, ['test.txt'], 'right files'; my @results; $fail = undef; $delay = Mojo::IOLoop->delay( sub { my $delay = shift; $gridfs->find_version(('test.txt', 3) => $delay->begin); $gridfs->find_version(('test.txt', 2) => $delay->begin); $gridfs->find_version(('test.txt', 1) => $delay->begin); }, sub { my ($delay, $three_err, $three, $two_err, $two, $one_err, $one) = @_; $fail = $one_err || $two_err || $three_err; @results = ($one, $two, $three); } ); $delay->wait; ok !$fail, 'no error'; is $results[0], $one, 'right version'; is $results[1], $two, 'right version'; is $results[2], undef, 'no version'; my $one_reader = $gridfs->reader; my $two_reader = $gridfs->reader; ($fail, @results) = (); $delay = Mojo::IOLoop->delay( sub { my $delay = shift; $one_reader->open($one => $delay->begin); $two_reader->open($two => $delay->begin); }, sub { my ($delay, $one_err, $two_err) = @_; $fail = $one_err || $two_err; $one_reader->slurp($delay->begin); $two_reader->slurp($delay->begin); }, sub { my ($delay, $one_err, $one, $two_err, $two) = @_; $fail ||= $one_err || $two_err; @results = ($one, $two); } ); $delay->wait; ok !$fail, 'no error'; is $results[0], 'One', 'right content'; is $results[1], 'Two', 'right content'; $gridfs->$_->drop for qw(files chunks); # File already closed $writer = $gridfs->writer; ok !$writer->is_closed, 'file has not been closed'; $oid = $writer->write('Test')->close; ok $writer->is_closed, 'file has been closed'; eval { $writer->write('123') }; like $@, qr/^File already closed/, 'right error'; $fail = undef; $writer->write( '123' => sub { my ($writer, $err) = @_; $fail = $err; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; like $fail, qr/^File already closed/, 'right error'; ok $writer->is_closed, 'file is still closed'; is $writer->close, $oid, 'right result'; ($fail, $result) = (); $writer->close( sub { my ($writer, $err, $oid) = @_; $fail = $err; $result = $oid; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; is $result, $oid, 'right result'; ok $writer->is_closed, 'file is still closed'; $gridfs->$_->drop for qw(files chunks); # Big chunks and parallel readers $oid = $gridfs->writer->write('x' x 1000000)->close; ($fail, @results) = (); $delay = Mojo::IOLoop->delay( sub { my $delay = shift; $gridfs->reader->open($oid => $delay->begin(0)); $gridfs->reader->open($oid => $delay->begin(0)); }, sub { my ($delay, $reader1, $err1, $reader2, $err2) = @_; $fail = $err1 || $err2; $reader1->slurp($delay->begin); $reader2->slurp($delay->begin); }, sub { my ($delay, $err1, $data1, $err2, $data2) = @_; $fail ||= $err2 || $err2; @results = ($data1, $data2); } ); $delay->wait; ok !$fail, 'no error'; is $results[0], 'x' x 1000000, 'right content'; is $results[1], 'x' x 1000000, 'right content'; $gridfs->$_->drop for qw(files chunks); # Open missing file blocking $oid = bson_oid; eval { $gridfs->reader->open($oid) }; like $@, qr/^$oid does not exist/, 'right error'; # Open missing file non-blocking $fail = undef; $gridfs->reader->open( $oid => sub { my ($reader, $err) = @_; $fail = $err; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; like $fail, qr/^$oid does not exist/, 'right error'; done_testing(); Mango-0.22/t/pod.t000644 000765 000024 00000000377 12200522264 013652 0ustar00sristaff000000 000000 use Mojo::Base -strict; use Test::More; plan skip_all => 'set TEST_POD to enable this test (developer only!)' unless $ENV{TEST_POD}; plan skip_all => 'Test::Pod 1.14 required for this test!' unless eval 'use Test::Pod 1.14; 1'; all_pod_files_ok(); Mango-0.22/t/pod_coverage.t000644 000765 000024 00000000463 12200522267 015524 0ustar00sristaff000000 000000 use Mojo::Base -strict; use Test::More; plan skip_all => 'set TEST_POD to enable this test (developer only!)' unless $ENV{TEST_POD}; plan skip_all => 'Test::Pod::Coverage 1.04 required for this test!' unless eval 'use Test::Pod::Coverage 1.04; 1'; all_pod_coverage_ok({also_private => ['TO_JSON']}); Mango-0.22/t/protocol.t000644 000765 000024 00000013735 12240271573 014743 0ustar00sristaff000000 000000 use Mojo::Base -strict; use Test::More; use Mango::Protocol; # Generate next id my $protocol = Mango::Protocol->new; is $protocol->next_id(1), 2, 'right id'; is $protocol->next_id(2147483646), 2147483647, 'right id'; is $protocol->next_id(2147483647), 1, 'right id'; # Build minimal update is $protocol->build_update(1, 'foo', {}, {}, {}), "\x26\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\xd1\x07\x00\x00\x00\x00" . "\x00\x00\x66\x6f\x6f\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x05\x00\x00" . "\x00\x00", 'minimal update'; # Build update with all flags is $protocol->build_update(1, 'foo', {upsert => 1, multi_update => 1}, {}, {}), "\x26\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\xd1\x07\x00\x00\x00\x00" . "\x00\x00\x66\x6f\x6f\x00\x03\x00\x00\x00\x05\x00\x00\x00\x00\x05\x00\x00" . "\x00\x00", 'update with all flags'; # Build minimal insert is $protocol->build_insert(1, 'foo', {}, {}), "\x1d\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\xd2\x07\x00\x00\x00\x00" . "\x00\x00\x66\x6f\x6f\x00\x05\x00\x00\x00\x00", 'minimal insert'; # Build insert with all flags is $protocol->build_insert(1, 'foo', {continue_on_error => 1}, {}), "\x1d\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\xd2\x07\x00\x00\x01\x00" . "\x00\x00\x66\x6f\x6f\x00\x05\x00\x00\x00\x00", 'insert with all flags'; # Build minimal query is $protocol->build_query(1, 'foo', {}, 0, 10, {}, {}), "\x2a\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\xd4\x07\x00\x00\x00\x00" . "\x00\x00\x66\x6f\x6f\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x05\x00\x00\x00" . "\x00\x05\x00\x00\x00\x00", 'minimal query'; # Build query with all flags my $flags = { tailable_cursor => 1, slave_ok => 1, no_cursor_timeout => 1, await_data => 1, exhaust => 1, partial => 1 }; is $protocol->build_query(1, 'foo', $flags, 0, 10, {}, {}), "\x2a\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\xd4\x07\x00\x00\xf6" . "\x00\x00\x00\x66\x6f\x6f\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x05\x00" . "\x00\x00\x00\x05\x00\x00\x00\x00", 'query with all flags'; # Build minimal get_more is $protocol->build_get_more(1, 'foo', 10, 1), "\x24\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\xd5\x07\x00\x00\x00\x00" . "\x00\x00\x66\x6f\x6f\x00\x0a\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", 'minimal get_more'; # Build minimal delete is $protocol->build_delete(1, 'foo', {}, {}), "\x21\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\xd6\x07\x00\x00\x00\x00" . "\x00\x00\x66\x6f\x6f\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00", 'minimal delete'; # Build delete with all flags is $protocol->build_delete(1, 'foo', {single_remove => 1}, {}), "\x21\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\xd6\x07\x00\x00\x00\x00" . "\x00\x00\x66\x6f\x6f\x00\x01\x00\x00\x00\x05\x00\x00\x00\x00", 'delete with all flags'; # Build minimal kill_cursors is $protocol->build_kill_cursors(1, 1), "\x20\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\xd7\x07\x00\x00\x00\x00" . "\x00\x00\x01\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", 'minimal kill_cursors'; # Parse full reply with leftovers my $buffer = "\x51\x00\x00\x00\x69\xaa\x04\x00\x03\x00\x00\x00\x01\x00\x00\x00\x08\x00" . "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00" . "\x2d\x00\x00\x00\x02\x6e\x6f\x6e\x63\x65\x00\x11\x00\x00\x00\x33\x32\x39" . "\x35\x65\x35\x63\x64\x35\x65\x65\x66\x32\x35\x30\x30\x00\x01\x6f\x6b\x00" . "\x00\x00\x00\x00\x00\x00\xf0\x3f\x00\x51"; my $reply = $protocol->parse_reply(\$buffer); is $buffer, "\x51", 'right leftovers'; my $nonce = { id => 305769, to => 3, flags => {await_capable => 1}, cursor => 0, from => 0, docs => [{nonce => '3295e5cd5eef2500', ok => 1}] }; is_deeply $reply, $nonce, 'right reply'; # Parse query failure $buffer = "\x59\x00\x00\x00\x3b\xd7\x04\x00\x01\x00\x00\x00\x01\x00\x00\x00\x02\x00" . "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00" . "\x35\x00\x00\x00\x02\x24\x65\x72\x72\x00\x1c\x00\x00\x00\x24\x6f\x72\x20" . "\x72\x65\x71\x75\x69\x72\x65\x73\x20\x6e\x6f\x6e\x65\x6d\x70\x74\x79\x20" . "\x61\x72\x72\x61\x79\x00\x10\x63\x6f\x64\x65\x00\xce\x33\x00\x00\x00"; $reply = $protocol->parse_reply(\$buffer); my $query = { id => 317243, to => 1, flags => {query_failure => 1}, cursor => 0, from => 0, docs => [{'$err' => '$or requires nonempty array', code => 13262}] }; is_deeply $reply, $query, 'right reply'; # Parse partial reply my $before = my $after = "\x10"; is $protocol->parse_reply(\$after), undef, 'nothing'; is $before, $after, 'no changes'; $before = $after = "\x00\x01\x00\x00"; is $protocol->parse_reply(\$after), undef, 'nothing'; is $before, $after, 'no changes'; # Parse wrong message type $buffer = $protocol->build_insert(1, 'foo', {}, {}) . "\x00"; is $protocol->parse_reply(\$buffer), undef, 'nothing'; is $buffer, "\x00", 'message has been removed'; # Extract error messages from reply my $unknown = { id => 316991, to => 1, flags => {await_capable => 1}, cursor => 0, from => 0, docs => [ {errmsg => 'no such cmd: whatever', 'bad cmd' => {whatever => 1}, ok => 0} ] }; my $gle = { to => 9, cursor => 0, flags => {await_capable => 1}, from => 0, id => 462265, docs => [ { err => 'E11000 duplicate key error index...', code => 11000, n => 0, connectionId => 41981, ok => 1 } ] }; is $protocol->query_failure(undef), undef, 'no query failure'; is $protocol->query_failure($unknown), undef, 'no query failure'; is $protocol->query_failure($gle), undef, 'no query failure'; is $protocol->query_failure($query), '$or requires nonempty array', 'right query failure'; is $protocol->command_error($unknown), 'no such cmd: whatever', 'right error'; is $protocol->command_error($gle), 'E11000 duplicate key error index...', 'right error'; is $protocol->command_error($query), undef, 'no error'; is $protocol->command_error($nonce), undef, 'no error'; done_testing(); Mango-0.22/lib/Mango/000755 000765 000024 00000000000 12254224346 014251 5ustar00sristaff000000 000000 Mango-0.22/lib/Mango.pm000644 000765 000024 00000043563 12252622134 014615 0ustar00sristaff000000 000000 package Mango; use Mojo::Base 'Mojo::EventEmitter'; use Carp 'croak'; use Mango::BSON qw(bson_doc bson_false bson_true); use Mango::Database; use Mango::Protocol; use Mojo::IOLoop; use Mojo::URL; use Mojo::Util qw(dumper md5_sum monkey_patch); use Scalar::Util 'weaken'; use constant DEBUG => $ENV{MANGO_DEBUG} || 0; use constant DEFAULT_PORT => 27017; has credentials => sub { [] }; has default_db => 'admin'; has hosts => sub { [['localhost']] }; has ioloop => sub { Mojo::IOLoop->new }; has j => 0; has max_connections => 5; has protocol => sub { Mango::Protocol->new }; has w => 1; has wtimeout => 1000; our $VERSION = '0.22'; # Operations with reply for my $name (qw(get_more query)) { monkey_patch __PACKAGE__, $name, sub { my $self = shift; my $cb = ref $_[-1] eq 'CODE' ? pop : undef; my ($next, $msg) = $self->_build($name, @_); $self->_start({id => $next, safe => 1, msg => $msg, cb => $cb}); }; } # Operations followed by getLastError for my $name (qw(delete insert update)) { monkey_patch __PACKAGE__, $name, sub { my ($self, $namespace) = (shift, shift); my $cb = ref $_[-1] eq 'CODE' ? pop : undef; # Make sure both operations can be written together my ($next, $msg) = $self->_build($name, $namespace, @_); $namespace =~ s/\..+$/\.\$cmd/; my $gle = bson_doc getLastError => 1, j => $self->j ? bson_true : bson_false, w => $self->w, wtimeout => $self->wtimeout; ($next, $gle) = $self->_build('query', $namespace, {}, 0, -1, $gle, {}); $self->_start({id => $next, safe => 1, msg => "$msg$gle", cb => $cb}); }; } sub DESTROY { shift->_cleanup } sub new { shift->SUPER::new->from_string(@_) } sub backlog { scalar @{shift->{queue} || []} } sub db { my ($self, $name) = @_; $name //= $self->default_db; my $db = Mango::Database->new(mango => $self, name => $name); weaken $db->{mango}; return $db; } sub from_string { my ($self, $str) = @_; # Protocol return $self unless $str; my $url = Mojo::URL->new($str); croak qq{Invalid MongoDB connection string "$str"} unless $url->protocol eq 'mongodb'; # Hosts my @hosts; /^([^,:]+)(?::(\d+))?/ and push @hosts, $2 ? [$1, $2] : [$1] for split /,/, join(':', map { $_ // '' } $url->host, $url->port); $self->hosts(\@hosts) if @hosts; # Database if (my $db = $url->path->parts->[0]) { $self->default_db($db) } # User and password push @{$self->credentials}, [$self->default_db, $1, $2] if ($url->userinfo // '') =~ /^([^:]+):([^:]+)$/; # Options my $query = $url->query; if (my $j = $query->param('journal')) { $self->j($j) } if (my $w = $query->param('w')) { $self->w($w) } if (my $timeout = $query->param('wtimeoutMS')) { $self->wtimeout($timeout) } return $self; } sub kill_cursors { my $self = shift; my $cb = ref $_[-1] eq 'CODE' ? pop : undef; my ($next, $msg) = $self->_build('kill_cursors', @_); $self->_start({id => $next, safe => 0, msg => $msg, cb => $cb}); } sub _active { my $self = shift; return 1 if $self->backlog; return !!grep { $_->{last} && !$_->{start} } values %{$self->{connections} || {}}; } sub _auth { my ($self, $id, $credentials, $auth, $err, $reply) = @_; my ($db, $user, $pass) = @$auth; # Run "authenticate" command with "nonce" value my $nonce = $reply->{docs}[0]{nonce} // ''; my $key = md5_sum $nonce . $user . md5_sum "$user:mongo:$pass"; my $authenticate = bson_doc(authenticate => 1, user => $user, nonce => $nonce, key => $key); my $cb = sub { shift->_connected($id, $credentials) }; $self->_fast($id, $db, $authenticate, $cb); } sub _build { my ($self, $name) = (shift, shift); my $next = $self->_id; warn "-- Operation #$next ($name)\n@{[dumper [@_]]}" if DEBUG; my $method = "build_$name"; return ($next, $self->protocol->$method($next, @_)); } sub _cleanup { my $self = shift; return unless my $loop = $self->_loop; # Clean up connections delete $self->{pid}; my $connections = delete $self->{connections}; $loop->remove($_) for keys %$connections; # Clean up active operations my $queue = delete $self->{queue} || []; $_->{last} and unshift @$queue, $_->{last} for values %$connections; $self->_finish(undef, $_->{cb}, 'Premature connection close') for @$queue; } sub _connect { my ($self, $hosts) = @_; my ($host, $port) = @{shift @{$hosts ||= [@{$self->hosts}]}}; weaken $self; my $id; $id = $self->_loop->client( {address => $host, port => $port //= DEFAULT_PORT} => sub { my ($loop, $err, $stream) = @_; # Connection error (try next server) if ($err) { return $self->_error($id, $err) unless @$hosts; delete $self->{connections}{$id}; return $self->_connect($hosts); } # Connection established $stream->timeout(0); $stream->on(close => sub { $self->_error($id) }); $stream->on(error => sub { $self && $self->_error($id, pop) }); $stream->on(read => sub { $self->_read($id, pop) }); $self->emit(connection => $id)->_connected($id, [@{$self->credentials}]); } ); $self->{connections}{$id} = {start => 1}; my $num = scalar keys %{$self->{connections}}; warn "-- New connection ($host:$port:$num)\n" if DEBUG; } sub _connected { my ($self, $id, $credentials) = @_; # No authentication return $self->_next unless my $auth = shift @$credentials; # Run "getnonce" command followed by "authenticate" my $cb = sub { shift->_auth($id, $credentials, $auth, @_) }; $self->_fast($id, $auth->[0], {getnonce => 1}, $cb); } sub _error { my ($self, $id, $err) = @_; my $c = delete $self->{connections}{$id}; my $last = $c->{last}; $last //= shift @{$self->{queue}} if $err; $self->_connect if @{$self->{queue}}; return $err ? $self->emit(error => $err) : $self unless $last; $self->_finish(undef, $last->{cb}, $err || 'Premature connection close'); } sub _fast { my ($self, $id, $db, $command, $cb) = @_; # Handle errors my $protocol = $self->protocol; my $wrapper = sub { my ($self, $err, $reply) = @_; $err ||= $protocol->command_error($reply); return $err ? $self->_error($id, $err) : $self->$cb($err, $reply); }; # Skip the queue and run command right away my ($next, $msg) = $self->_build('query', "$db.\$cmd", {}, 0, -1, $command, {}); $self->{connections}{$id}{fast} = {id => $next, safe => 1, msg => $msg, cb => $wrapper}; $self->_next; } sub _finish { my ($self, $reply, $cb, $err) = @_; $self->$cb($err || $self->protocol->query_failure($reply), $reply); } sub _id { $_[0]{id} = $_[0]->protocol->next_id($_[0]{id} // 0) } sub _loop { $_[0]{nb} ? Mojo::IOLoop->singleton : $_[0]->ioloop } sub _next { my ($self, $op) = @_; push @{$self->{queue} ||= []}, $op if $op; my @ids = keys %{$self->{connections}}; my $start; $self->_write($_) and $start++ for @ids; $self->_connect if $op && !$start && @{$self->{queue}} && @ids < $self->max_connections; } sub _read { my ($self, $id, $chunk) = @_; my $c = $self->{connections}{$id}; $c->{buffer} .= $chunk; while (my $reply = $self->protocol->parse_reply(\$c->{buffer})) { warn "-- Client <<< Server (#$reply->{to})\n@{[dumper $reply]}" if DEBUG; next unless $reply->{to} == $c->{last}{id}; $self->_finish($reply, (delete $c->{last})->{cb}); } $self->_next; } sub _start { my ($self, $op) = @_; # Fork safety $self->_cleanup unless ($self->{pid} //= $$) eq $$; # Non-blocking if ($op->{cb}) { # Start non-blocking unless ($self->{nb}) { croak 'Blocking operation in progress' if $self->_active; warn "-- Switching to non-blocking mode\n" if DEBUG; $self->_cleanup; $self->{nb}++; } return $self->_next($op); } # Start blocking if ($self->{nb}) { croak 'Non-blocking operations in progress' if $self->_active; warn "-- Switching to blocking mode\n" if DEBUG; $self->_cleanup; delete $self->{nb}; } my ($err, $reply); $op->{cb} = sub { (my $self, $err, $reply) = @_; $self->ioloop->stop; }; $self->_next($op); $self->ioloop->start; # Throw blocking errors croak $err if $err; return $reply; } sub _write { my ($self, $id) = @_; # Make sure connection has not been corrupted while event loop was stopped my $c = $self->{connections}{$id}; return $c->{start} if $c->{last}; my $loop = $self->_loop; return undef unless my $stream = $loop->stream($id); if (!$loop->is_running && $stream->is_readable) { $stream->close; return undef; } delete $c->{start} unless my $last = delete $c->{fast}; return $c->{start} unless $c->{last} = $last ||= shift @{$self->{queue}}; warn "-- Client >>> Server (#$last->{id})\n" if DEBUG; $stream->write(delete $last->{msg}); # Unsafe operations are done when they are written return $c->{start} if $last->{safe}; weaken $self; $stream->write('', sub { $self->_finish(undef, delete($c->{last})->{cb}) }); return $c->{start}; } 1; =encoding utf8 =head1 NAME Mango - Pure-Perl non-blocking I/O MongoDB driver =head1 SYNOPSIS use Mango; # Insert document my $mango = Mango->new('mongodb://localhost:27017'); my $oid = $mango->db('test')->collection('foo')->insert({bar => 'baz'}); # Find document my $doc = $mango->db('test')->collection('foo')->find_one({bar => 'baz'}); say $doc->{bar}; # Update document $mango->db('test')->collection('foo') ->update({bar => 'baz'}, {bar => 'yada'}); # Remove document $mango->db('test')->collection('foo')->remove({bar => 'yada'}); # Insert document with special BSON types use Mango::BSON ':bson'; my $oid = $mango->db('test')->collection('foo') ->insert({data => bson_bin("\x00\x01"), now => bson_time}); # Blocking parallel find (does not work inside a running event loop) my $delay = Mojo::IOLoop->delay; for my $name (qw(sri marty)) { my $end = $delay->begin(0); $mango->db('test')->collection('users')->find({name => $name})->all(sub { my ($cursor, $err, $docs) = @_; $end->(@$docs); }); } my @docs = $delay->wait; # Non-blocking parallel find (does work inside a running event loop) my $delay = Mojo::IOLoop->delay(sub { my ($delay, @docs) = @_; ... }); for my $name (qw(sri marty)) { my $end = $delay->begin(0); $mango->db('test')->collection('users')->find({name => $name})->all(sub { my ($cursor, $err, $docs) = @_; $end->(@$docs); }); } $delay->wait unless Mojo::IOLoop->is_running; # Event loops such as AnyEvent are supported through EV use EV; use AnyEvent; my $cv = AE::cv; $mango->db('test')->command(buildInfo => sub { my ($db, $err, $doc) = @_; $cv->send($doc->{version}); }); say $cv->recv; =head1 DESCRIPTION L is a pure-Perl non-blocking I/O MongoDB driver, optimized for use with the L real-time web framework, and with multiple event loop support. Since MongoDB is still changing rapidly, only the latest stable version is supported. To learn more about MongoDB you should take a look at the L, the documentation included in this distribution is no replacement for it. Note that this whole distribution is EXPERIMENTAL and will change without warning! Most of the API is not changing much anymore, but you should wait for a stable 1.0 release before using any of the modules in this distribution in a production environment. Unsafe operations are not supported, so far this is considered a feature. Many arguments passed to methods as well as values of attributes get serialized to BSON with L, which provides many helper functions you can use to generate data types that are not available natively in Perl. All connections will be reset automatically if a new process has been forked, this allows multiple processes to share the same L object safely. For better scalability (epoll, kqueue) and to provide IPv6 as well as TLS support, the optional modules L (4.0+), L (0.16+) and L (1.75+) will be used automatically by L if they are installed. Individual features can also be disabled with the MOJO_NO_IPV6 and MOJO_NO_TLS environment variables. =head1 EVENTS L inherits all events from L and can emit the following new ones. =head2 connection $mango->on(connection => sub { my ($mango, $id) = @_; ... }); Emitted when a new connection has been established. =head2 error $mango->on(error => sub { my ($mango, $err) = @_; ... }); Emitted if an error occurs that can't be associated with an operation. $mango->on(error => sub { my ($mango, $err) = @_; say "This looks bad: $err"; }); =head1 ATTRIBUTES L implements the following attributes. =head2 credentials my $credentials = $mango->credentials; $mango = $mango->credentials([['test', 'sri', 's3cret']]); Authentication credentials that will be used on every reconnect. =head2 default_db my $name = $mango->default_db; $mango = $mango->default_db('test'); Default database, defaults to C. =head2 hosts my $hosts = $mango->hosts; $mango = $mango->hosts([['localhost', 3000], ['localhost', 4000]]); Servers to connect to, defaults to C and port C<27017>. =head2 ioloop my $loop = $mango->ioloop; $mango = $mango->ioloop(Mojo::IOLoop->new); Event loop object to use for blocking I/O operations, defaults to a L object. =head2 j my $j = $mango->j; $mango = $mango->j(1); Wait for all operations to have reached the journal, defaults to C<0>. =head2 max_connections my $max = $mango->max_connections; $mango = $mango->max_connections(5); Maximum number of connections to use for non-blocking operations, defaults to C<5>. =head2 protocol my $protocol = $mango->protocol; $mango = $mango->protocol(Mango::Protocol->new); Protocol handler, defaults to a L object. =head2 w my $w = $mango->w; $mango = $mango->w(2); Wait for all operations to have reached at least this many servers, C<1> indicates just primary, C<2> indicates primary and at least one secondary, defaults to C<1>. =head2 wtimeout my $timeout = $mango->wtimeout; $mango = $mango->wtimeout(1); Timeout for write propagation in milliseconds, defaults to C<1000>. =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 new my $mango = Mango->new; my $mango = Mango->new('mongodb://sri:s3cret@localhost:3000/test?w=2'); Construct a new L object and parse connection string with L if necessary. =head2 backlog my $num = $mango->backlog; Number of queued operations that have not yet been assigned to a connection. =head2 db my $db = $mango->db; my $db = $mango->db('test'); Get L object for database, uses L if no name is provided. Note that the reference L is weakened, so the L object needs to be referenced elsewhere as well. =head2 delete my $reply = $mango->delete($namespace, $flags, $query); Perform low level C operation followed by C command. You can also append a callback to perform operation non-blocking. $mango->delete(($namespace, $flags, $query) => sub { my ($mango, $err, $reply) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 from_string $mango = $mango->from_string('mongodb://sri:s3cret@localhost:3000/test?w=2'); Parse configuration from connection string. =head2 get_more my $reply = $mango->get_more($namespace, $return, $cursor); Perform low level C operation. You can also append a callback to perform operation non-blocking. $mango->get_more(($namespace, $return, $cursor) => sub { my ($mango, $err, $reply) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 insert my $reply = $mango->insert($namespace, $flags, @docs); Perform low level C operation followed by C command. You can also append a callback to perform operation non-blocking. $mango->insert(($namespace, $flags, @docs) => sub { my ($mango, $err, $reply) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 kill_cursors $mango->kill_cursors(@ids); Perform low level C operation. You can also append a callback to perform operation non-blocking. $mango->kill_cursors(@ids => sub { my ($mango, $err) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 query my $reply = $mango->query($namespace, $flags, $skip, $return, $query, $fields); Perform low level C operation. You can also append a callback to perform operation non-blocking. $mango->query(($namespace, $flags, $skip, $return, $query, $fields) => sub { my ($mango, $err, $reply) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 update my $reply = $mango->update($namespace, $flags, $query, $update); Perform low level C operation followed by C command. You can also append a callback to perform operation non-blocking. $mango->update(($namespace, $flags, $query, $update) => sub { my ($mango, $err, $reply) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head1 DEBUGGING You can set the C environment variable to get some advanced diagnostics information printed to C. MANGO_DEBUG=1 =head1 SPONSORS Some of the work on this distribution has been sponsored by L, thank you! =head1 AUTHOR Sebastian Riedel, C. =head1 CREDITS In alphabetical order: =over 2 Andrey Khozov =back =head1 COPYRIGHT AND LICENSE Copyright (C) 2013, Sebastian Riedel. This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License version 2.0. =head1 SEE ALSO L, L. =cut Mango-0.22/lib/Mango/BSON/000755 000765 000024 00000000000 12254224346 015012 5ustar00sristaff000000 000000 Mango-0.22/lib/Mango/BSON.pm000644 000765 000024 00000030312 12242773054 015351 0ustar00sristaff000000 000000 package Mango::BSON; use Mojo::Base -strict; use re 'regexp_pattern'; use B; use Carp 'croak'; use Exporter 'import'; use Mango::BSON::Binary; use Mango::BSON::Code; use Mango::BSON::Document; use Mango::BSON::ObjectID; use Mango::BSON::Time; use Mango::BSON::Timestamp; use Mojo::JSON; use Scalar::Util 'blessed'; my @BSON = ( qw(bson_bin bson_code bson_dbref bson_decode bson_doc bson_encode), qw(bson_false bson_length bson_max bson_min bson_oid bson_time bson_true), qw(bson_ts) ); our @EXPORT_OK = ( @BSON, qw(decode_int32 decode_int64 encode_cstring encode_int32 encode_int64), ); our %EXPORT_TAGS = (bson => \@BSON); # Types use constant { DOUBLE => "\x01", STRING => "\x02", DOCUMENT => "\x03", ARRAY => "\x04", BINARY => "\x05", OBJECT_ID => "\x07", BOOL => "\x08", DATETIME => "\x09", NULL => "\x0a", REGEX => "\x0b", CODE => "\x0d", CODE_SCOPE => "\x0f", INT32 => "\x10", TIMESTAMP => "\x11", INT64 => "\x12", MIN_KEY => "\x7f", MAX_KEY => "\xff" }; # Binary subtypes use constant { BINARY_GENERIC => "\x00", BINARY_FUNCTION => "\x01", BINARY_UUID => "\x04", BINARY_MD5 => "\x05", BINARY_USER_DEFINED => "\x80" }; # 32bit integer range use constant {INT32_MIN => -(1 << 31) + 1, INT32_MAX => (1 << 31) - 1}; # Reuse boolean singletons my $FALSE = Mojo::JSON->false; my $TRUE = Mojo::JSON->true; my $BOOL = blessed $TRUE; my $MAXKEY = bless {}, 'Mango::BSON::_MaxKey'; my $MINKEY = bless {}, 'Mango::BSON::_MinKey'; sub bson_bin { Mango::BSON::Binary->new(data => shift) } sub bson_code { Mango::BSON::Code->new(code => shift) } sub bson_dbref { bson_doc('$ref' => shift, '$id' => shift) } sub bson_decode { my $bson = shift; return undef unless my $len = bson_length($bson); return length $bson == $len ? _decode_doc(\$bson) : undef; } sub bson_doc { tie my %hash, 'Mango::BSON::Document', @_; return \%hash; } sub bson_encode { my $doc = shift; my $bson = ''; while (my ($key, $value) = each %$doc) { $bson .= _encode_value(encode_cstring($key), $value); } # Document ends with null byte return encode_int32(length($bson) + 5) . $bson . "\x00"; } sub bson_false {$FALSE} sub bson_length { length $_[0] < 4 ? undef : decode_int32(substr $_[0], 0, 4) } sub bson_max {$MAXKEY} sub bson_min {$MINKEY} sub bson_oid { Mango::BSON::ObjectID->new(@_) } sub bson_time { Mango::BSON::Time->new(@_) } sub bson_ts { Mango::BSON::Timestamp->new(seconds => shift, increment => shift); } sub bson_true {$TRUE} sub decode_int32 { unpack 'l<', shift } sub decode_int64 { unpack 'q<', shift } sub encode_cstring { my $str = shift; utf8::encode $str; return pack 'Z*', $str; } sub encode_int32 { pack 'l<', shift } sub encode_int64 { pack 'q<', shift } sub _decode_binary { my $bsonref = shift; my $len = decode_int32(substr $$bsonref, 0, 4, ''); my $subtype = substr $$bsonref, 0, 1, ''; my $binary = substr $$bsonref, 0, $len, ''; return bson_bin($binary)->type('function') if $subtype eq BINARY_FUNCTION; return bson_bin($binary)->type('md5') if $subtype eq BINARY_MD5; return bson_bin($binary)->type('uuid') if $subtype eq BINARY_UUID; return bson_bin($binary)->type('user_defined') if $subtype eq BINARY_USER_DEFINED; return bson_bin($binary)->type('generic'); } sub _decode_cstring { my $bsonref = shift; $$bsonref =~ s/^([^\x00]*)\x00//; my $str = $1; utf8::decode $str; return $str; } sub _decode_doc { my $bsonref = shift; # Every element starts with a type my $doc = bson_doc(); substr $$bsonref, 0, 4, ''; while (my $type = substr $$bsonref, 0, 1, '') { # Null byte (end of document) last if $type eq "\x00"; my $name = _decode_cstring($bsonref); $doc->{$name} = _decode_value($type, $bsonref); } return $doc; } sub _decode_string { my $bsonref = shift; my $len = decode_int32(substr $$bsonref, 0, 4, ''); substr $$bsonref, $len - 1, 1, ''; my $str = substr $$bsonref, 0, $len - 1, ''; utf8::decode $str; return $str; } sub _decode_value { my ($type, $bsonref) = @_; # String return _decode_string($bsonref) if $type eq STRING; # Object ID return bson_oid(unpack 'H*', substr $$bsonref, 0, 12, '') if $type eq OBJECT_ID; # Double/Int32/Int64 return unpack 'd<', substr $$bsonref, 0, 8, '' if $type eq DOUBLE; return decode_int32(substr $$bsonref, 0, 4, '') if $type eq INT32; return decode_int64(substr $$bsonref, 0, 8, '') if $type eq INT64; # Document return _decode_doc($bsonref) if $type eq DOCUMENT; # Array return [values %{_decode_doc($bsonref)}] if $type eq ARRAY; # Booleans and Null return substr($$bsonref, 0, 1, '') eq "\x00" ? bson_false() : bson_true() if $type eq BOOL; return undef if $type eq NULL; # Time return bson_time(decode_int64(substr $$bsonref, 0, 8, '')) if $type eq DATETIME; # Regex return eval join '/', 'qr', _decode_cstring($bsonref), _decode_cstring($bsonref) if $type eq REGEX; # Binary (with subtypes) return _decode_binary($bsonref) if $type eq BINARY; # Min/Max return bson_min() if $type eq MIN_KEY; return bson_max() if $type eq MAX_KEY; # Code (with and without scope) return bson_code(_decode_string($bsonref)) if $type eq CODE; if ($type eq CODE_SCOPE) { decode_int32(substr $$bsonref, 0, 4, ''); return bson_code(_decode_string($bsonref))->scope(_decode_doc($bsonref)); } # Timestamp return bson_ts( reverse map({decode_int32(substr $$_, 0, 4, '')} $bsonref, $bsonref)) if $type eq TIMESTAMP; # Unknown croak 'Unknown BSON type'; } sub _encode_binary { my ($e, $subtype, $value) = @_; return BINARY . $e . encode_int32(length $value) . $subtype . $value; } sub _encode_object { my ($e, $value, $class) = @_; # ObjectID return OBJECT_ID . $e . pack('H*', $value) if $class eq 'Mango::BSON::ObjectID'; # Boolean return BOOL . $e . ($value ? "\x01" : "\x00") if $class eq $BOOL; # Time return DATETIME . $e . encode_int64($value) if $class eq 'Mango::BSON::Time'; # Regex if ($class eq 'Regexp') { my ($p, $m) = regexp_pattern($value); return REGEX . $e . encode_cstring($p) . encode_cstring($m); } # Binary if ($class eq 'Mango::BSON::Binary') { my $type = $value->type // 'generic'; my $data = $value->data; return _encode_binary($e, BINARY_FUNCTION, $data) if $type eq 'function'; return _encode_binary($e, BINARY_MD5, $data) if $type eq 'md5'; return _encode_binary($e, BINARY_USER_DEFINED, $data) if $type eq 'user_defined'; return _encode_binary($e, BINARY_UUID, $data) if $type eq 'uuid'; return _encode_binary($e, BINARY_GENERIC, $data); } # Code if ($class eq 'Mango::BSON::Code') { # With scope if (my $scope = $value->scope) { my $code = _encode_string($value->code) . bson_encode($scope); return CODE_SCOPE . $e . encode_int32(length $code) . $code; } # Without scope return CODE . $e . _encode_string($value->code); } # Timestamp return join '', TIMESTAMP, $e, map { encode_int32 $_} $value->increment, $value->seconds if $class eq 'Mango::BSON::Timestamp'; # Blessed reference with TO_JSON method if (my $sub = $value->can('TO_JSON')) { return _encode_value($e, $value->$sub); } # Stringify return STRING . $e . _encode_string($value); } sub _encode_string { my $str = shift; utf8::encode $str; return encode_int32(length($str) + 1) . "$str\x00"; } sub _encode_value { my ($e, $value) = @_; # Null return NULL . $e unless defined $value; # Blessed if (my $class = blessed $value) { # Max return MAX_KEY . $e if $value eq $MAXKEY; # Min return MIN_KEY . $e if $value eq $MINKEY; # Multiple classes return _encode_object($e, $value, $class); } # Reference elsif (my $ref = ref $value) { # Hash (Document) return DOCUMENT . $e . bson_encode($value) if $ref eq 'HASH'; # Array if ($ref eq 'ARRAY') { my $array = bson_doc(); my $i = 0; $array->{$i++} = $_ for @$value; return ARRAY . $e . bson_encode($array); } # Scalar (boolean shortcut) return _encode_value($e, $$value ? $TRUE : $FALSE) if $ref eq 'SCALAR'; } # Double my $flags = B::svref_2object(\$value)->FLAGS; return DOUBLE . $e . pack('d<', $value) if $flags & B::SVp_NOK; if ($flags & B::SVp_IOK) { # Int32 return INT32 . $e . encode_int32($value) if $value <= INT32_MAX && $value >= INT32_MIN; # Int64 return INT64 . $e . encode_int64($value); } # String return STRING . $e . _encode_string("$value"); } # Constants package Mango::BSON::_MaxKey; package Mango::BSON::_MinKey; 1; =encoding utf8 =head1 NAME Mango::BSON - BSON =head1 SYNOPSIS use Mango::BSON ':bson'; my $bson = bson_encode { foo => 'bar', baz => 0.42, unordered => {one => [1, 2, 3], two => bson_time}, ordered => bson_doc(one => qr/test/i, two => bson_true) }; my $doc = bson_decode $bson; =head1 DESCRIPTION L is a minimalistic implementation of L. In addition to a bunch of custom BSON data types it supports normal Perl data types like C, C, C, C reference, C reference and will try to call the C method on blessed references, or stringify them if it doesn't exist. C references will be used to generate booleans, based on if their values are true or false. =head1 FUNCTIONS L implements the following functions. =head2 bson_bin my $bin = bson_bin $bytes; Create new BSON element of the binary type with L, defaults to the C binary subtype. # Function bson_bin($bytes)->type('function'); # MD5 bson_bin($bytes)->type('md5'); # UUID bson_bin($bytes)->type('uuid'); # User defined bson_bin($bytes)->type('user_defined'); =head2 bson_code my $code = bson_code 'function () {}'; Create new BSON element of the code type with L. # With scope bson_code('function () {}')->scope({foo => 'bar'}); =head2 bson_dbref my $dbref = bson_dbref('test', $oid); Create a new database reference. =head2 bson_decode my $doc = bson_decode $bson; Decode BSON into Perl data structures. =head2 bson_doc my $doc = bson_doc; my $doc = bson_doc foo => 'bar', baz => 0.42, yada => {yada => [1, 2, 3]}; Create new BSON document with L, which can also be used as a generic ordered hash. # Order is preserved my $hash = bson_doc one => 1, two => 2, three => 3; $hash->{four} = 4; delete $hash->{two}; say for keys %$hash; =head2 bson_encode my $bson = bson_encode $doc; my $bson = bson_encode {}; Encode Perl data structures into BSON. =head2 bson_false my $false = bson_false; Create new BSON element of the boolean type false. =head2 bson_length my $len = bson_length $bson; Check BSON length prefix. =head2 bson_max my $max_key = bson_max; Create new BSON element of the max key type. =head2 bson_min my $min_key = bson_min; Create new BSON element of the min key type. =head2 bson_oid my $oid = bson_oid; my $oid = bson_oid '1a2b3c4e5f60718293a4b5c6'; Create new BSON element of the object id type with L, defaults to generating a new unique object id. # Generate object id with specific epoch time my $oid = bson_oid->from_epoch(1359840145); =head2 bson_time my $now = bson_time; my $time = bson_time time * 1000; Create new BSON element of the UTC datetime type with L, defaults to milliseconds since the UNIX epoch. =head2 bson_true my $true = bson_true; Create new BSON element of the boolean type true. =head2 bson_ts my $timestamp = bson_ts 23, 24; Create new BSON element of the timestamp type with L. =head2 decode_int32 my $int32 = decode_int32 $bytes; Decode 32bit integer. =head2 decode_int64 my $int64 = decode_int64 $bytes; Decode 64bit integer. =head2 encode_cstring my $bytes = encode_cstring $cstring; Encode cstring. =head2 encode_int32 my $bytes = encode_int32 $int32; Encode 32bit integer. =head2 encode_int64 my $bytes = encode_int64 $int64; Encode 64bit integer. =head1 SEE ALSO L, L, L. =cut Mango-0.22/lib/Mango/Collection.pm000644 000765 000024 00000034152 12254223731 016704 0ustar00sristaff000000 000000 package Mango::Collection; use Mojo::Base -base; use Carp 'croak'; use Mango::BSON qw(bson_code bson_doc bson_oid bson_true); use Mango::Cursor; has [qw(db name)]; sub aggregate { my ($self, $pipeline) = (shift, shift); my $cb = ref $_[-1] eq 'CODE' ? pop : undef; my $command = bson_doc(aggregate => $self->name, pipeline => $pipeline, %{shift // {}}); # Blocking return $self->_aggregate($pipeline, $self->db->command($command)) unless $cb; # Non-blocking return $self->db->command($command, sub { shift; $self->$cb(shift, $self->_aggregate($pipeline, shift)) }); } sub build_index_name { join '_', keys %{$_[1]} } sub create { my $self = shift; my $cb = ref $_[-1] eq 'CODE' ? pop : undef; return $self->_command(bson_doc(create => $self->name, %{shift // {}}), undef, $cb); } sub drop { $_[0]->_command(bson_doc(drop => $_[0]->name), undef, $_[1]) } sub drop_index { my ($self, $name) = (shift, shift); return $self->_command(bson_doc(dropIndexes => $self->name, index => $name), undef, @_); } sub ensure_index { my ($self, $spec) = (shift, shift); my $cb = ref $_[-1] eq 'CODE' ? pop : undef; my $doc = shift // {}; $doc->{name} //= $self->build_index_name($spec); $doc->{ns} = $self->full_name; $doc->{key} = $spec; # Non-blocking my $collection = $self->db->collection('system.indexes'); return $collection->insert($doc => sub { shift; $self->$cb(shift) }) if $cb; # Blocking $collection->insert($doc); } sub find { Mango::Cursor->new( collection => shift, query => shift // {}, fields => shift // {} ); } sub find_and_modify { my ($self, $opts) = (shift, shift); return $self->_command(bson_doc(findAndModify => $self->name, %$opts), 'value', @_); } sub find_one { my ($self, $query) = (shift, shift); $query = {_id => $query} if ref $query eq 'Mango::BSON::ObjectID'; my $cb = ref $_[-1] eq 'CODE' ? pop : undef; # Non-blocking my $cursor = $self->find($query, @_)->limit(-1); return $cursor->next(sub { shift; $self->$cb(@_) }) if $cb; # Blocking return $cursor->next; } sub full_name { join '.', $_[0]->db->name, $_[0]->name } sub index_information { my ($self, $cb) = @_; # Non-blocking my $collection = $self->db->collection('system.indexes'); my $cursor = $collection->find({ns => $self->full_name})->fields({ns => 0}); return $cursor->all(sub { shift; $self->$cb(shift, _indexes(shift)) }) if $cb; # Blocking return _indexes($cursor->all); } sub insert { my ($self, $docs) = @_; $docs = [$docs] unless ref $docs eq 'ARRAY'; my $cb = ref $_[-1] eq 'CODE' ? pop : undef; # Make sure all documents have ids my @ids = map { $_->{_id} //= bson_oid } @$docs; # Non-blocking my $mango = $self->db->mango; return $mango->insert( ($self->full_name, {}, @$docs) => sub { my ($mango, $err, $reply) = @_; $err ||= $mango->protocol->command_error($reply); $self->$cb($err, @ids > 1 ? \@ids : $ids[0]); } ) if $cb; # Blocking my $reply = $mango->insert($self->full_name, {}, @$docs); if (my $err = $mango->protocol->command_error($reply)) { croak $err } return @ids > 1 ? \@ids : $ids[0]; } sub map_reduce { my ($self, $map, $reduce) = (shift, shift, shift); my $cb = ref $_[-1] eq 'CODE' ? pop : undef; my $command = bson_doc mapreduce => $self->name, map => ref $map ? $map : bson_code($map), reduce => ref $reduce ? $reduce : bson_code($reduce), %{shift // {}}; # Blocking return $self->_map_reduce($self->db->command($command)) unless $cb; # Non-blocking return $self->db->command( $command => sub { shift; $self->$cb(shift, $self->_map_reduce(shift)) }); } sub options { my ($self, $cb) = @_; # Non-blocking my $query = {name => $self->full_name}; my $namespaces = $self->db->collection('system.namespaces'); return $namespaces->find_one($query => sub { shift; $self->$cb(@_) }) if $cb; # Blocking return $namespaces->find_one($query); } sub remove { my $self = shift; my $query = ref $_[0] eq 'CODE' ? {} : shift // {}; my $flags = ref $_[0] eq 'CODE' ? {} : shift // {}; $flags->{single_remove} = 1 if delete $flags->{single}; return $self->_handle('delete', $flags, $query, @_); } sub save { my ($self, $doc, $cb) = @_; # New document return $self->insert($doc, $cb) unless $doc->{_id}; # Update non-blocking my @update = ({_id => $doc->{_id}}, $doc, {upsert => 1}); return $self->update(@update => sub { shift->$cb(shift, $doc->{_id}) }) if $cb; # Update blocking $self->update(@update); return $doc->{_id}; } sub stats { $_[0]->_command(bson_doc(collstats => $_[0]->name), undef, $_[1]) } sub update { my ($self, $query, $update) = (shift, shift, shift); my $flags = ref $_[0] eq 'CODE' ? {} : shift // {}; $flags->{multi_update} = 1 if delete $flags->{multi}; return $self->_handle('update', $flags, $query, $update, @_); } sub _aggregate { my ($self, $pipeline, $doc) = @_; my $out = $pipeline->[-1]{'$out'}; return $self->db->collection($out) if defined $out; return $doc->{cursor} ? $self->_cursor($doc) : $doc->{result}; } sub _command { my ($self, $command, $field, $cb) = @_; # Non-blocking return $self->db->command( $command => sub { my ($db, $err, $doc) = @_; $self->$cb($err, $field ? $doc->{$field} : $doc); } ) if $cb; # Blocking my $doc = $self->db->command($command); return $field ? $doc->{$field} : $doc; } sub _cursor { my ($self, $doc) = @_; my $cursor = $doc->{cursor}; return Mango::Cursor->new(collection => $self, id => $cursor->{id}) ->add_batch($cursor->{firstBatch}); } sub _handle { my ($self, $method) = (shift, shift); my $cb = ref $_[-1] eq 'CODE' ? pop : undef; # Non-blocking my $mango = $self->db->mango; return $mango->$method( ($self->full_name, @_) => sub { my ($mango, $err, $reply) = @_; $err ||= $mango->protocol->command_error($reply); $self->$cb($err, $reply->{docs}[0]); } ) if $cb; # Blocking my $reply = $mango->$method($self->full_name, @_); if (my $err = $mango->protocol->command_error($reply)) { croak $err } return $reply->{docs}[0]; } sub _indexes { my $indexes = bson_doc; if (my $docs = shift) { $indexes->{delete $_->{name}} = $_ for @$docs } return $indexes; } sub _map_reduce { my ($self, $doc) = @_; return $doc->{results} unless $doc->{result}; return $self->db->collection($doc->{result}); } 1; =encoding utf8 =head1 NAME Mango::Collection - MongoDB collection =head1 SYNOPSIS use Mango::Collection; my $collection = Mango::Collection->new(db => $db); my $cursor = $collection->find({foo => 'bar'}); =head1 DESCRIPTION L is a container for MongoDB collections used by L. =head1 ATTRIBUTES L implements the following attributes. =head2 db my $db = $collection->db; $collection = $collection->db(Mango::Database->new); L object this collection belongs to. =head2 name my $name = $collection->name; $collection = $collection->name('bar'); Name of this collection. =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 aggregate my $docs = $collection->aggregate( [{'$group' => {_id => undef, total => {'$sum' => '$foo'}}}]); my $cursor = $collection->aggregate( [{'$match' => {'$gt' => 23}}], {cursor => {}}); my $collection = $collection->aggregate( [{'$match' => {'$gt' => 23}}, {'$out' => 'some_collection'}]); Aggregate collection with aggregation framework, additional options will be passed along to the server verbatim.. You can also append a callback to perform operation non-blocking. my $pipeline = [{'$group' => {_id => undef, total => {'$sum' => '$foo'}}}]; $collection->aggregate($pipeline => sub { my ($collection, $err, $docs) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 build_index_name my $name = $collection->build_index_name(bson_doc(foo => 1, bar => -1)); my $name = $collection->build_index_name({foo => 1}); Build name for index specification, the order of keys matters for compound indexes. =head2 create $collection->create; $collection->create({capped => bson_true, max => 5, size => 10000}); Create collection. You can also append a callback to perform operation non-blocking. $collection->create({capped => bson_true, max => 5, size => 10000} => sub { my ($collection, $err) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 drop $collection->drop; Drop collection. You can also append a callback to perform operation non-blocking. $collection->drop(sub { my ($collection, $err) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 drop_index $collection->drop_index('foo'); Drop index. You can also append a callback to perform operation non-blocking. $collection->drop_index(foo => sub { my ($collection, $err) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 ensure_index $collection->ensure_index(bson_doc(foo => 1, bar => -1)); $collection->ensure_index({foo => 1}); $collection->ensure_index({foo => 1}, {unique => bson_true}); Make sure an index exists, the order of keys matters for compound indexes, additional options will be passed along to the server verbatim. You can also append a callback to perform operation non-blocking. $collection->ensure_index(({foo => 1}, {unique => bson_true}) => sub { my ($collection, $err) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 find my $cursor = $collection->find; my $cursor = $collection->find({foo => 'bar'}); my $cursor = $collection->find({foo => 'bar'}, {foo => 1}); Get L object for query. =head2 find_and_modify my $doc = $collection->find_and_modify( {query => {foo => 'bar'}, update => {'$set' => {foo => 'baz'}}}); Update document atomically. You can also append a callback to perform operation non-blocking. my $opts = {query => {foo => 'bar'}, update => {'$set' => {foo => 'baz'}}}; $collection->find_and_modify($opts => sub { my ($collection, $err, $doc) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 find_one my $doc = $collection->find_one({foo => 'bar'}); my $doc = $collection->find_one({foo => 'bar'}, {foo => 1}); my $doc = $collection->find_one($oid, {foo => 1}); Find one document. You can also append a callback to perform operation non-blocking. $collection->find_one({foo => 'bar'} => sub { my ($collection, $err, $doc) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 full_name my $name = $collection->full_name; Full name of this collection. =head2 index_information my $info = $collection->index_information; Get index information for collection. You can also append a callback to perform operation non-blocking. $collection->index_information(sub { my ($collection, $err, $info) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 insert my $oid = $collection->insert({foo => 'bar'}); my $oids = $collection->insert([{foo => 'bar'}, {baz => 'yada'}]); Insert one or more documents into collection. You can also append a callback to perform operation non-blocking. $collection->insert({foo => 'bar'} => sub { my ($collection, $err, $oid) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 map_reduce my $foo = $collection->map_reduce($map, $reduce, {out => 'foo'}); my $docs = $collection->map_reduce($map, $reduce, {out => {inline => 1}}); my $docs = $collection->map_reduce( bson_code($map), bson_code($reduce), {out => {inline => 1}}); Perform map/reduce operation on this collection, additional options will be passed along to the server verbatim. You can also append a callback to perform operation non-blocking. $collection->map_reduce(($map, $reduce, {out => {inline => 1}}) => sub { my ($collection, $err, $docs) = @_; ... } ); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 options my $doc = $collection->options; Get options for this collection. You can also append a callback to perform operation non-blocking. $collection->options(sub { my ($collection, $err, $doc) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 remove my $doc = $collection->remove; my $doc = $collection->remove({foo => 'bar'}); my $doc = $collection->remove({foo => 'bar'}, {single => 1}); Remove documents from collection. You can also append a callback to perform operation non-blocking. $collection->remove(({foo => 'bar'}, {single => 1}) => sub { my ($collection, $err, $doc) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; These options are currently available: =over 2 =item single single => 1 Remove only one document. =back =head2 save my $oid = $collection->save({foo => 'bar'}); Save document to collection. You can also append a callback to perform operation non-blocking. $collection->save({foo => 'bar'} => sub { my ($collection, $err, $oid) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 stats my $stats = $collection->stats; Get collection statistics. You can also append a callback to perform operation non-blocking. $collection->stats(sub { my ($collection, $err, $stats) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 update my $doc = $collection->update({foo => 'bar'}, {foo => 'baz'}); my $doc = $collection->update({foo => 'bar'}, {foo => 'baz'}, {multi => 1}); Update document in collection. You can also append a callback to perform operation non-blocking. $collection->update(({foo => 'bar'}, {foo => 'baz'}, {multi => 1}) => sub { my ($collection, $err, $doc) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; These options are currently available: =over 2 =item multi multi => 1 Update more than one document. =item upsert upsert => 1 Insert document if none could be updated. =back =head1 SEE ALSO L, L, L. =cut Mango-0.22/lib/Mango/Cursor.pm000644 000765 000024 00000021767 12242773047 016105 0ustar00sristaff000000 000000 package Mango::Cursor; use Mojo::Base -base; use Mango::BSON 'bson_doc'; use Mojo::IOLoop; has [qw(batch_size limit skip)] => 0; has [qw(collection hint id max_scan snapshot sort tailable)]; has [qw(fields query)] => sub { {} }; sub add_batch { my ($self, $docs) = @_; push @{$self->{results} ||= []}, @$docs; return $self; } sub all { my ($self, $cb) = @_; # Non-blocking my @all; return $self->next(sub { shift->_collect(\@all, $cb, @_) }) if $cb; # Blocking while (my $next = $self->next) { push @all, $next } return \@all; } sub build_query { my ($self, $explain) = @_; my $query = $self->query; my $hint = $self->hint; my $max_scan = $self->max_scan; my $snapshot = $self->snapshot; my $sort = $self->sort; return $query unless $explain || $hint || $max_scan || $snapshot || $sort; $query = bson_doc $query->{'$query'} ? %$query : ('$query' => $query); $query->{'$explain'} = 1 if $explain; $query->{'$hint'} = $hint if $hint; $query->{'$maxScan'} = $max_scan if $max_scan; $query->{'$snapshot'} = 1 if $snapshot; $query->{'$orderby'} = $sort if $sort; return $query; } sub clone { my $self = shift; my $clone = $self->new; $clone->$_($self->$_) for qw(batch_size collection fields hint limit); $clone->$_($self->$_) for qw(max_scan query skip snapshot sort tailable); return $clone; } sub count { my $self = shift; my $cb = ref $_[-1] eq 'CODE' ? pop : undef; my $collection = $self->collection; my $command = bson_doc count => $collection->name, query => $self->build_query, skip => $self->skip, limit => $self->limit; # Non-blocking return $collection->db->command( $command => sub { my ($collection, $err, $doc) = @_; $self->$cb($err, $doc ? $doc->{n} : 0); } ) if $cb; # Blocking my $doc = $collection->db->command($command); return $doc ? $doc->{n} : 0; } sub distinct { my ($self, $key) = (shift, shift); my $cb = ref $_[-1] eq 'CODE' ? pop : undef; my $collection = $self->collection; my $command = bson_doc distinct => $collection->name, key => $key, query => $self->build_query; # Blocking my $db = $collection->db; return $db->command($command)->{values} unless $cb; # Non-blocking $db->command($command => sub { shift; $self->$cb(shift, shift->{values}) }); } sub explain { my ($self, $cb) = @_; # Non-blocking my $clone = $self->clone->query($self->build_query(1))->sort(undef); return $clone->next(sub { shift; $self->$cb(@_) }) if $cb; # Blocking return $clone->next; } sub next { my ($self, $cb) = @_; return defined $self->id ? $self->_continue($cb) : $self->_start($cb); } sub rewind { my ($self, $cb) = @_; delete @$self{qw(num results)}; return $cb ? $self->_defer($cb) : undef unless defined(my $id = $self->id); $self->id(undef); # Non-blocking my $mango = $self->collection->db->mango; return $mango->kill_cursors($id => sub { shift; $self->$cb(@_) }) if $cb; # Blocking $mango->kill_cursors($id); } sub _collect { my ($self, $all, $cb, $err, $doc) = @_; return $self->_defer($cb, $err, $all) if $err || !$doc; push @$all, $doc; $self->next(sub { shift->_collect($all, $cb, @_) }); } sub _continue { my ($self, $cb) = @_; my $collection = $self->collection; my $name = $collection->full_name; my $mango = $collection->db->mango; # Non-blocking if ($cb) { return $self->_defer($cb, undef, $self->_dequeue) if $self->_enough; return $mango->get_more(($name, $self->_max, $self->id) => sub { shift; $self->$cb(shift, $self->_enqueue(shift)) }); } # Blocking return $self->_dequeue if $self->_enough; return $self->_enqueue($mango->get_more($name, $self->_max, $self->id)); } sub _defer { my ($self, $cb, @args) = @_; Mojo::IOLoop->timer(0 => sub { $self->$cb(@args) }); } sub _dequeue { my $self = shift; return undef if $self->_finished; $self->{num}++; return shift @{$self->{results}}; } sub _enough { my $self = shift; return $self->id eq '0' || $self->_finished || !!@{$self->{results} // []}; } sub _enqueue { my ($self, $reply) = @_; return unless $reply; return $self->add_batch($reply->{docs})->id($reply->{cursor})->_dequeue; } sub _finished { my $self = shift; return undef unless my $limit = $self->limit; return ($self->{num} // 0) >= abs($limit) ? 1 : undef; } sub _max { my $self = shift; my $limit = $self->limit; my $size = $self->batch_size; return $limit == 0 || $size < $limit ? $size : $limit; } sub _start { my ($self, $cb) = @_; my $collection = $self->collection; my $name = $collection->full_name; my $flags = $self->tailable ? {tailable_cursor => 1, await_data => 1} : {}; my @query = ( $name, $flags, $self->skip, $self->_max, $self->build_query, $self->fields ); # Non-blocking return $collection->db->mango->query( @query => sub { shift; $self->$cb(shift, $self->_enqueue(shift)) }) if $cb; # Blocking return $self->_enqueue($collection->db->mango->query(@query)); } 1; =encoding utf8 =head1 NAME Mango::Cursor - MongoDB cursor =head1 SYNOPSIS use Mango::Cursor; my $cursor = Mango::Cursor->new(collection => $collection); my $docs = $cursor->all; =head1 DESCRIPTION L is a container for MongoDB cursors used by L. =head1 ATTRIBUTES L implements the following attributes. =head2 batch_size my $size = $cursor->batch_size; $cursor = $cursor->batch_size(10); Number of documents to fetch in one batch, defaults to C<0>. =head2 collection my $collection = $cursor->collection; $cursor = $cursor->collection(Mango::Collection->new); L object this cursor belongs to. =head2 fields my $fields = $cursor->fields; $cursor = $cursor->fields({foo => 1}); Select fields from documents. =head2 hint my $hint = $cursor->hint; $cursor = $cursor->hint({foo => 1}); Force a specific index to be used. =head2 id my $id = $cursor->id; $cursor = $cursor->id(123456); Cursor id. =head2 limit my $limit = $cursor->limit; $cursor = $cursor->limit(10); Limit the number of documents, defaults to C<0>. =head2 max_scan my $max = $cursor->max_scan; $cursor = $cursor->max_scan(500); Limit the number of documents to scan. =head2 query my $query = $cursor->query; $cursor = $cursor->query({foo => 'bar'}); Original query. =head2 skip my $skip = $cursor->skip; $cursor = $cursor->skip(5); Number of documents to skip, defaults to C<0>. =head2 snapshot my $snapshot = $cursor->snapshot; $cursor = $cursor->snapshot(1); Use snapshot mode. =head2 sort my $sort = $cursor->sort; $cursor = $cursor->sort({foo => 1}); $cursor = $cursor->sort(bson_doc(foo => 1, bar => -1)); Sort documents, the order of keys matters. =head2 tailable my $tailable = $cursor->tailable; $cursor = $cursor->tailable(1); Tailable cursor. =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 add_batch $cursor = $cursor->add_batch($docs); Add batch of documents to cursor. =head2 all my $docs = $cursor->all; Fetch all documents at once. You can also append a callback to perform operation non-blocking. $cursor->all(sub { my ($cursor, $err, $docs) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 build_query my $query = $cursor->build_query; my $query = $cursor->build_query($explain); Generate final query with cursor attributes. =head2 clone my $clone = $cursor->clone; Clone cursor. =head2 count my $count = $cursor->count; Count number of documents this cursor can return. You can also append a callback to perform operation non-blocking. $cursor->count(sub { my ($cursor, $err, $count) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 distinct my $values = $cursor->distinct('foo'); Get all distinct values for key. You can also append a callback to perform operation non-blocking. $cursor->distinct(foo => sub { my ($cursor, $err, $values) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 explain my $doc = $cursor->explain; Provide information on the query plan. You can also append a callback to perform operation non-blocking. $cursor->explain(sub { my ($cursor, $err, $doc) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 next my $doc = $cursor->next; Fetch next document. You can also append a callback to perform operation non-blocking. $cursor->next(sub { my ($cursor, $err, $doc) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 rewind $cursor->rewind; Rewind cursor and kill it on the server. You can also append a callback to perform operation non-blocking. $cursor->rewind(sub { my ($cursor, $err) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head1 SEE ALSO L, L, L. =cut Mango-0.22/lib/Mango/Database.pm000644 000765 000024 00000010074 12254222771 016315 0ustar00sristaff000000 000000 package Mango::Database; use Mojo::Base -base; use Carp 'croak'; use Mango::BSON qw(bson_code bson_doc); use Mango::Collection; use Mango::GridFS; has [qw(mango name)]; sub collection { my ($self, $name) = @_; return Mango::Collection->new(db => $self, name => $name); } sub collection_names { my ($self, $cb) = @_; my $len = length $self->name; my $collection = $self->collection('system.namespaces'); # Non-blocking return $collection->find->all( sub { my ($cursor, $err, $docs) = @_; $self->$cb($err, [map { substr $_->{name}, $len + 1 } @$docs]); } ) if $cb; # Blocking my $docs = $collection->find->all; return [map { substr $_->{name}, $len + 1 } @$docs]; } sub command { my ($self, $command) = (shift, shift); my $cb = ref $_[-1] eq 'CODE' ? pop : undef; $command = ref $command ? $command : bson_doc($command => 1, @_); # Non-blocking my $collection = $self->collection('$cmd'); my $protocol = $self->mango->protocol; return $collection->find_one( $command => sub { my ($collection, $err, $doc) = @_; $err ||= $protocol->command_error({docs => [$doc]}); $self->$cb($err, $doc // {}); } ) if $cb; # Blocking my $doc = $collection->find_one($command); if (my $err = $protocol->command_error({docs => [$doc]})) { croak $err } return $doc; } sub dereference { my ($self, $dbref, $cb) = @_; # Non-blocking my $collection = $self->collection($dbref->{'$ref'}); return $collection->find_one($dbref->{'$id'} => sub { shift; $self->$cb(@_) } ) if $cb; # Blocking return $collection->find_one($dbref->{'$id'}); } sub gridfs { Mango::GridFS->new(db => shift) } sub stats { shift->command(bson_doc(dbstats => 1), @_) } 1; =encoding utf8 =head1 NAME Mango::Database - MongoDB database =head1 SYNOPSIS use Mango::Database; my $db = Mango::Database->new(mango => $mango); my $collection = $db->collection('foo'); my $gridfs = $db->gridfs; =head1 DESCRIPTION L is a container for MongoDB databases used by L. =head1 ATTRIBUTES L implements the following attributes. =head2 mango my $mango = $db->mango; $db = $db->mango(Mango->new); L object this database belongs to. Note that this reference is usually weakened, so the L object needs to be referenced elsewhere as well. =head2 name my $name = $db->name; $db = $db->name('bar'); Name of this database. =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 collection my $collection = $db->collection('foo'); Get L object for collection. =head2 collection_names my $names = $db->collection_names; Names of all collections in this database. You can also append a callback to perform operation non-blocking. $db->collection_names(sub { my ($db, $err, $names) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 command my $doc = $db->command(bson_doc(text => 'foo.bar', search => 'test')); my $doc = $db->command(bson_doc(getLastError => 1, w => 2)); my $doc = $db->command('getLastError', w => 2); Run command against database. You can also append a callback to run command non-blocking. $db->command(('getLastError', w => 2) => sub { my ($db, $err, $doc) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 dereference my $doc = $db->dereference($dbref); Resolve database reference. You can also append a callback to perform operation non-blocking. $db->dereference($dbref => sub { my ($db, $err, $doc) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 gridfs my $gridfs = $db->gridfs; Get L object. =head2 stats my $stats = $db->stats; Get database statistics. You can also append a callback to perform operation non-blocking. $db->stats(sub { my ($db, $err, $stats) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head1 SEE ALSO L, L, L. =cut Mango-0.22/lib/Mango/GridFS/000755 000765 000024 00000000000 12254224346 015367 5ustar00sristaff000000 000000 Mango-0.22/lib/Mango/GridFS.pm000644 000765 000024 00000010161 12247674654 015741 0ustar00sristaff000000 000000 package Mango::GridFS; use Mojo::Base -base; use Mango::GridFS::Reader; use Mango::GridFS::Writer; has chunks => sub { $_[0]->db->collection($_[0]->prefix . '.chunks') }; has 'db'; has files => sub { $_[0]->db->collection($_[0]->prefix . '.files') }; has prefix => 'fs'; sub delete { my ($self, $oid, $cb) = @_; # Non-blocking return Mojo::IOLoop->delay( sub { my $delay = shift; $self->files->remove({_id => $oid} => $delay->begin); $self->chunks->remove({files_id => $oid} => $delay->begin); }, sub { $self->$cb($_[1] || $_[3]) } ) if $cb; # Blocking $self->files->remove({_id => $oid}); $self->chunks->remove({files_id => $oid}); } sub find_version { my ($self, $name, $version, $cb) = @_; my $cursor = $self->files->find({filename => $name}); $cursor->sort({uploadDate => 1})->limit(-1)->fields({_id => 1}); $cursor->skip($version - 1) if $version; # Non-blocking return $cursor->next( sub { shift; $self->$cb(shift, $_[0] ? $_[0]{_id} : undef) }) if $cb; # Blocking my $doc = $cursor->next; return $doc ? $doc->{_id} : undef; } sub list { my ($self, $cb) = @_; # Blocking return $self->files->find->distinct('filename') unless $cb; # Non-blocking $self->files->find->distinct('filename' => sub { shift; $self->$cb(@_) }); } sub reader { Mango::GridFS::Reader->new(gridfs => shift) } sub writer { Mango::GridFS::Writer->new(gridfs => shift) } 1; =encoding utf8 =head1 NAME Mango::GridFS - GridFS =head1 SYNOPSIS use Mango::GridFS; my $gridfs = Mango::GridFS->new(db => $db); my $reader = $gridfs->reader; my $writer = $gridfs->writer; =head1 DESCRIPTION L is an interface for MongoDB GridFS access. =head1 ATTRIBUTES L implements the following attributes. =head2 chunks my $chunks = $gridfs->chunks; $gridfs = $gridfs->chunks(Mango::Collection->new); L object for C collection, defaults to one based on L. =head2 db my $db = $gridfs->db; $gridfs = $gridfs->db(Mango::Database->new); L object GridFS belongs to. =head2 files my $files = $gridfs->files; $gridfs = $gridfs->files(Mango::Collection->new); L object for C collection, defaults to one based on L. =head2 prefix my $db = $gridfs->prefix; $gridfs = $gridfs->prefix('foo'); Prefix for GridFS collections, defaults to C. =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 delete $gridfs->delete($oid); Delete file. You can also append a callback to perform operation non-blocking. $gridfs->delete($oid => sub { my ($gridfs, $err) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 find_version my $oid = $gridfs->find_version('test.txt', 1); Find a specific version of a file. You can also append a callback to perform operation non-blocking. $gridfs->find_version(('test.txt', 1) => sub { my ($gridfs, $err, $oid) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 list my $names = $gridfs->list; List files. You can also append a callback to perform operation non-blocking. $gridfs->list(sub { my ($gridfs, $err, $names) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 reader my $reader = $gridfs->reader; Get L object. # Read all data at once from newest version of file my $oid = $gridfs->find_version('test.txt', 1); my $data = $gridfs->reader->open($oid)->slurp; # Read all data in chunks from file my $reader = $gridfs->reader->open($oid); while (defined(my $chunk = $reader->read)) { say "Chunk: $chunk" } =head2 writer my $writer = $gridfs->writer; Get L object. # Write all data at once to file with name my $oid = $gridfs->writer->filename('test.txt')->write('Hello!')->close; # Write data in chunks to file my $writer = $gridfs->writer; $writer->write($_) for 1 .. 100; my $oid = $writer->close; =head1 SEE ALSO L, L, L. =cut Mango-0.22/lib/Mango/Protocol.pm000644 000765 000024 00000014234 12242773037 016417 0ustar00sristaff000000 000000 package Mango::Protocol; use Mojo::Base -base; use Mango::BSON qw(bson_decode bson_encode bson_length decode_int32), qw(decode_int64 encode_cstring encode_int32 encode_int64); # Opcodes use constant { REPLY => 1, UPDATE => 2001, INSERT => 2002, QUERY => 2004, GET_MORE => 2005, DELETE => 2006, KILL_CURSORS => 2007 }; sub build_delete { my ($self, $id, $name, $flags, $query) = @_; # Zero and name my $msg = encode_int32(0) . encode_cstring($name); # Flags my $vec = pack 'B*', '0' x 32; vec($vec, 0, 1) = 1 if $flags->{single_remove}; $msg .= encode_int32(unpack 'V', $vec); # Query $msg .= bson_encode $query; # Header return _build_header($id, length($msg), DELETE) . $msg; } sub build_get_more { my ($self, $id, $name, $return, $cursor) = @_; # Zero and name my $msg = encode_int32(0) . encode_cstring($name); # Number to return and cursor id $msg .= encode_int32($return) . encode_int64($cursor); # Header return _build_header($id, length($msg), GET_MORE) . $msg; } sub build_insert { my ($self, $id, $name, $flags) = (shift, shift, shift, shift); # Flags my $vec = pack 'B*', '0' x 32; vec($vec, 0, 1) = 1 if $flags->{continue_on_error}; my $msg = encode_int32(unpack 'V', $vec); # Name $msg .= encode_cstring $name; # Documents $msg .= bson_encode $_ for @_; # Header return _build_header($id, length($msg), INSERT) . $msg; } sub build_kill_cursors { my ($self, $id) = (shift, shift); # Zero and number of cursor ids my $msg = encode_int32(0) . encode_int32(scalar @_); # Cursor ids $msg .= encode_int64 $_ for @_; # Header return _build_header($id, length($msg), KILL_CURSORS) . $msg; } sub build_query { my ($self, $id, $name, $flags, $skip, $return, $query, $fields) = @_; # Flags my $vec = pack 'B*', '0' x 32; vec($vec, 1, 1) = 1 if $flags->{tailable_cursor}; vec($vec, 2, 1) = 1 if $flags->{slave_ok}; vec($vec, 4, 1) = 1 if $flags->{no_cursor_timeout}; vec($vec, 5, 1) = 1 if $flags->{await_data}; vec($vec, 6, 1) = 1 if $flags->{exhaust}; vec($vec, 7, 1) = 1 if $flags->{partial}; my $msg = encode_int32(unpack 'V', $vec); # Name $msg .= encode_cstring $name; # Skip and number to return $msg .= encode_int32($skip) . encode_int32($return); # Query $msg .= bson_encode $query; # Optional field selector $msg .= bson_encode $fields if $fields; # Header return _build_header($id, length($msg), QUERY) . $msg; } sub build_update { my ($self, $id, $name, $flags, $query, $update) = @_; # Zero and name my $msg = encode_int32(0) . encode_cstring($name); # Flags my $vec = pack 'B*', '0' x 32; vec($vec, 0, 1) = 1 if $flags->{upsert}; vec($vec, 1, 1) = 1 if $flags->{multi_update}; $msg .= encode_int32(unpack 'V', $vec); # Query and update specification $msg .= bson_encode($query) . bson_encode($update); # Header return _build_header($id, length($msg), UPDATE) . $msg; } sub command_error { my ($self, $reply) = @_; my $doc = $reply->{docs}[0]; return $doc->{ok} ? $doc->{err} : $doc->{errmsg}; } sub next_id { $_[1] > 2147483646 ? 1 : $_[1] + 1 } sub parse_reply { my ($self, $bufref) = @_; # Make sure we have the whole message return undef unless my $len = bson_length $$bufref; return undef if length $$bufref < $len; my $msg = substr $$bufref, 0, $len, ''; substr $msg, 0, 4, ''; # Header my $id = decode_int32(substr $msg, 0, 4, ''); my $to = decode_int32(substr $msg, 0, 4, ''); my $op = decode_int32(substr $msg, 0, 4, ''); return undef unless $op == REPLY; # Flags my $flags = {}; my $vec = substr $msg, 0, 4, ''; $flags->{cursor_not_found} = 1 if vec $vec, 0, 1; $flags->{query_failure} = 1 if vec $vec, 1, 1; $flags->{await_capable} = 1 if vec $vec, 3, 1; # Cursor id my $cursor = decode_int64(substr $msg, 0, 8, ''); # Starting from my $from = decode_int32(substr $msg, 0, 4, ''); # Documents (remove number of documents prefix) substr $msg, 0, 4, ''; my @docs; push @docs, bson_decode(substr $msg, 0, bson_length($msg), '') while $msg; return { id => $id, to => $to, flags => $flags, cursor => $cursor, from => $from, docs => \@docs }; } sub query_failure { my ($self, $reply) = @_; return undef unless $reply; return $reply->{flags}{query_failure} ? $reply->{docs}[0]{'$err'} : undef; } sub _build_header { my ($id, $length, $op) = @_; return join '', map { encode_int32($_) } $length + 16, $id, 0, $op; } 1; =encoding utf8 =head1 NAME Mango::Protocol - The MongoDB wire protocol =head1 SYNOPSIS use Mango::Protocol; my $protocol = Mango::Protocol->new; my $bytes = $protocol->insert(23, 'foo.bar', {}, {foo => 'bar'}); =head1 DESCRIPTION L is a minimalistic implementation of the MongoDB wire protocol. =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 build_delete my $bytes = $protocol->build_delete($id, $name, $flags, $query); Build message for C operation. =head2 build_get_more my $bytes = $protocol->build_get_more($id, $name, $return, $cursor); Build message for C operation. =head2 build_insert my $bytes = $protocol->build_insert($id, $name, $flags, @docs); Build message for C operation. =head2 build_kill_cursors my $bytes = $protocol->build_kill_cursors($id, @ids); Build message for C operation. =head2 build_query my $bytes = $protocol->build_query($id, $name, $flags, $skip, $return, $query, $fields); Build message for C operation. =head2 build_update my $bytes = $protocol->build_update($id, $name, $flags, $query, $update); Build message for C operation. =head2 command_error my $err = $protocol->command_error($reply); Check reply for command error. =head2 next_id my $id = $protocol->next_id(23); Generate next id. =head2 parse_reply my $reply = $protocol->parse_reply(\$str); Extract and parse C message. =head2 query_failure my $err = $protocol->query_failure($reply); Check reply for query failure. =head1 SEE ALSO L, L, L. =cut Mango-0.22/lib/Mango/GridFS/Reader.pm000644 000765 000024 00000010210 12247673157 017133 0ustar00sristaff000000 000000 package Mango::GridFS::Reader; use Mojo::Base -base; use Carp 'croak'; has 'gridfs'; sub chunk_size { shift->{meta}{chunkSize} } sub content_type { shift->{meta}{contentType} } sub filename { shift->{meta}{filename} } sub metadata { shift->{meta}{metadata} } sub open { my ($self, $oid, $cb) = @_; # Non-blocking return $self->gridfs->files->find_one( $oid => sub { my ($collection, $err, $doc) = @_; $err //= "$oid does not exist" unless $self->{meta} = $doc; $self->$cb($err); } ) if $cb; # Blocking croak "$oid does not exist" unless $self->{meta} = $self->gridfs->files->find_one($oid); return $self; } sub read { my ($self, $cb) = @_; $self->{pos} //= 0; # EOF if ($self->{pos} >= ($self->size // 0)) { return undef unless $cb; return Mojo::IOLoop->timer(0 => sub { $self->$cb(undef, undef) }); } # Blocking my $n = int($self->{pos} / $self->chunk_size); my $query = {files_id => $self->{meta}{_id}, n => $n}; my $fields = {_id => 0, data => 1}; return $self->_slice($n, $self->gridfs->chunks->find_one($query, $fields)->{data}) unless $cb; # Non-blocking $self->gridfs->chunks->find_one( ($query, $fields) => sub { my ($collection, $err, $doc) = @_; $self->$cb($err, $self->_slice($n, $doc->{data})); } ); } sub seek { my ($self, $pos) = @_; $self->{pos} = $pos; return $self; } sub slurp { my ($self, $cb) = @_; # Blocking my $data; unless ($cb) { while (defined(my $chunk = $self->read)) { $data .= $chunk } return $data; } # Non-blocking $self->_chunk(\$data, $cb); } sub size { shift->{meta}{length} } sub tell { shift->{pos} // 0 } sub upload_date { shift->{meta}{uploadDate} } sub _chunk { my ($self, $dataref, $cb) = @_; $self->read( sub { my ($self, $err, $chunk) = @_; return $self->$cb($err, $$dataref) if $err || !defined $chunk; $$dataref .= $chunk; $self->_chunk($dataref, $cb); } ); } sub _slice { my ($self, $n, $chunk) = @_; my $offset = $self->{pos} - ($n * $self->chunk_size); $self->{pos} += length $chunk; return substr $chunk, $offset; } 1; =encoding utf8 =head1 NAME Mango::GridFS::Reader - GridFS reader =head1 SYNOPSIS use Mango::GridFS::Reader; my $reader = Mango::GridFS::Reader->new(gridfs => $gridfs); =head1 DESCRIPTION L reads files from GridFS. =head1 ATTRIBUTES L implements the following attributes. =head2 gridfs my $gridfs = $reader->gridfs; $reader = $reader->gridfs(Mango::GridFS->new); L object this reader belongs to. =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 chunk_size my $size = $reader->chunk_size; Chunk size in bytes. =head2 content_type my $type = $reader->content_type; Content type of file. =head2 filename my $name = $reader->filename; Name of file. =head2 metadata my $data = $reader->metadata; Additional information. =head2 open $reader = $reader->open($oid); Open file. You can also append a callback to perform operation non-blocking. $reader->open($oid => sub { my ($reader, $err) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 read my $chunk = $reader->read; Read chunk. You can also append a callback to perform operation non-blocking. $reader->read(sub { my ($reader, $err, $chunk) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 seek $reader = $reader->seek(13); Change current position. =head2 size my $size = $reader->size; Size of entire file in bytes. =head2 slurp my $data = $reader->slurp; Slurp all remaining data from file. You can also append a callback to perform operation non-blocking. $reader->slurp(sub { my ($reader, $err, $data) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 tell my $pos = $reader->tell; Current position. =head2 upload_date my $time = $reader->upload_date; Date file was uploaded. =head1 SEE ALSO L, L, L. =cut Mango-0.22/lib/Mango/GridFS/Writer.pm000644 000765 000024 00000012037 12242773013 017201 0ustar00sristaff000000 000000 package Mango::GridFS::Writer; use Mojo::Base -base; use Carp 'croak'; use List::Util 'first'; use Mango::BSON qw(bson_bin bson_doc bson_oid bson_time bson_true); use Mojo::IOLoop; has chunk_size => 262144; has [qw(content_type filename gridfs metadata)]; sub close { my ($self, $cb) = @_; # Already closed if ($self->{closed}++) { my $files_id = $self->{files_id}; return $files_id unless $cb; return Mojo::IOLoop->timer(0 => sub { $self->$cb(undef, $files_id) }); } my @index = (bson_doc(files_id => 1, n => 1), {unique => bson_true}); my $gridfs = $self->gridfs; my $command = bson_doc filemd5 => $self->{files_id}, root => $gridfs->prefix; # Blocking my $files = $gridfs->files; unless ($cb) { $self->_chunk; $files->ensure_index({filename => 1}); $gridfs->chunks->ensure_index(@index); my $md5 = $gridfs->db->command($command)->{md5}; $files->insert($self->_meta($md5)); return $self->{files_id}; } # Non-blocking Mojo::IOLoop->delay( sub { $self->_chunk(shift->begin) }, sub { my ($delay, $err) = @_; return $self->$cb($err) if $err; $files->ensure_index({filename => 1} => $delay->begin); $gridfs->chunks->ensure_index(@index => $delay->begin); }, sub { my ($delay, $files_err, $chunks_err) = @_; if (my $err = $files_err || $chunks_err) { return $self->$cb($err) } $gridfs->db->command($command => $delay->begin); }, sub { my ($delay, $err, $doc) = @_; return $self->$cb($err) if $err; $files->insert($self->_meta($doc->{md5}) => $delay->begin); }, sub { shift; $self->$cb(shift, $self->{files_id}) } ); } sub is_closed { !!shift->{closed} } sub write { my ($self, $chunk, $cb) = @_; # Already closed if ($self->is_closed) { croak 'File already closed' unless $cb; return Mojo::IOLoop->timer(0 => sub { $self->$cb('File already closed') }); } $self->{buffer} .= $chunk; $self->{len} += length $chunk; # Non-blocking my $size = $self->chunk_size; if ($cb) { my $delay = Mojo::IOLoop->delay(sub { shift; $self->_err($cb, @_) }); $self->_chunk($delay->begin) while length $self->{buffer} >= $size; $delay->begin->(undef, undef); } # Blocking else { $self->_chunk while length $self->{buffer} >= $size } return $self; } sub _chunk { my ($self, $cb) = @_; my $chunk = substr $self->{buffer}, 0, $self->chunk_size, ''; return $cb ? Mojo::IOLoop->timer(0 => $cb) : () unless length $chunk; # Blocking my $n = $self->{n}++; my $oid = $self->{files_id} //= bson_oid; my $doc = {files_id => $oid, n => $n, data => bson_bin($chunk)}; return $self->gridfs->chunks->insert($doc) unless $cb; # Non-blocking $self->gridfs->chunks->insert($doc => $cb); } sub _err { my ($self, $cb) = (shift, shift); $self->$cb(first {defined} @_[map { 2 * $_ } 0 .. @_ / 2]); } sub _meta { my ($self, $md5) = @_; my $doc = { _id => $self->{files_id}, length => $self->{len}, chunkSize => $self->chunk_size, uploadDate => bson_time, md5 => $md5 }; if (my $name = $self->filename) { $doc->{filename} = $name } if (my $type = $self->content_type) { $doc->{contentType} = $type } if (my $data = $self->metadata) { $doc->{metadata} = $data } return $doc; } 1; =encoding utf8 =head1 NAME Mango::GridFS::Writer - GridFS writer =head1 SYNOPSIS use Mango::GridFS::Writer; my $writer = Mango::GridFS::Writer->new(gridfs => $gridfs); =head1 DESCRIPTION L writes files to GridFS. =head1 ATTRIBUTES L implements the following attributes. =head2 chunk_size my $size = $writer->chunk_size; $writer = $writer->chunk_size(1024); Chunk size in bytes, defaults to C<262144>. =head2 content_type my $type = $writer->content_type; $writer = $writer->content_type('text/plain'); Content type of file. =head2 filename my $name = $writer->filename; $writer = $writer->filename('foo.txt'); Name of file. =head2 gridfs my $gridfs = $writer->gridfs; $writer = $writer->gridfs(Mango::GridFS->new); L object this writer belongs to. =head2 metadata my $data = $writer->metadata; $writer = $writer->metadata({foo => 'bar'}); Additional information. =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 close my $oid = $writer->close; Close file. You can also append a callback to perform operation non-blocking. $writer->close(sub { my ($writer, $err, $oid) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 is_closed my $success = $writer->is_closed; Check if file has been closed. =head2 write $writer = $writer->write('hello world!'); Write chunk. You can also append a callback to perform operation non-blocking. $writer->write('hello world!' => sub { my ($writer, $err) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head1 SEE ALSO L, L, L. =cut Mango-0.22/lib/Mango/BSON/Binary.pm000644 000765 000024 00000002106 12242773034 016573 0ustar00sristaff000000 000000 package Mango::BSON::Binary; use Mojo::Base -base; use overload '""' => sub { shift->data }, fallback => 1; use Mojo::Util 'b64_encode'; has [qw(data type)]; sub TO_JSON { b64_encode shift->data, '' } 1; =encoding utf8 =head1 NAME Mango::BSON::Binary - Binary type =head1 SYNOPSIS use Mango::BSON::Binary; my $bin = Mango::BSON::Binary->new(data => $bytes, type => 'generic'); say $bin->data; say "$bin"; =head1 DESCRIPTION L is a container for the BSON binary type used by L. For C implementations like L, that support the C method, it will automatically C encode the binary data. =head1 ATTRIBUTES L implements the following attributes. =head2 data my $bytes = $bin->data; $bin = $bin->data($bytes); Binary data. =head2 type my $type = $bin->type; $bin = $bin->type('generic'); Binary subtype. =head1 METHODS L inherits all methods from L. =head1 SEE ALSO L, L, L. =cut Mango-0.22/lib/Mango/BSON/Code.pm000644 000765 000024 00000001413 12242773032 016217 0ustar00sristaff000000 000000 package Mango::BSON::Code; use Mojo::Base -base; has [qw(code scope)]; 1; =encoding utf8 =head1 NAME Mango::BSON::Code - Code type =head1 SYNOPSIS use Mango::BSON::Code; my $code = Mango::BSON::Code->new(code => 'function () {}'); =head1 DESCRIPTION L is a container for the BSON code type used by L. =head1 ATTRIBUTES L implements the following attributes. =head2 code my $js = $code->code; $code = $code->code('function () {}'); JavaScript code. =head2 scope my $scode = $code->scope; $code = $code->scope({foo => 'bar'}); Scope. =head1 METHODS L inherits all methods from L. =head1 SEE ALSO L, L, L. =cut Mango-0.22/lib/Mango/BSON/Document.pm000644 000765 000024 00000002053 12242773030 017122 0ustar00sristaff000000 000000 package Mango::BSON::Document; use Mojo::Base 'Tie::Hash'; sub DELETE { my ($self, $key) = @_; return undef unless exists $self->[0]{$key}; $key eq $self->[1][$_] and splice @{$self->[1]}, $_, 1 and last for 0 .. $#{$self->[1]}; return delete $self->[0]{$key}; } sub EXISTS { exists $_[0][0]{$_[1]} } sub FETCH { $_[0][0]{$_[1]} } sub FIRSTKEY { $_[0][2] = 0; &NEXTKEY; } sub NEXTKEY { $_[0][2] <= $#{$_[0][1]} ? $_[0][1][$_[0][2]++] : undef } sub STORE { my ($self, $key, $value) = @_; push @{$self->[1]}, $key unless exists $self->[0]{$key}; $self->[0]{$key} = $value; } sub TIEHASH { my $self = bless [{}, [], 0], shift; $self->STORE(shift, shift) while @_; return $self; } 1; =encoding utf8 =head1 NAME Mango::BSON::Document - Document type =head1 SYNOPSIS use Mango::BSON::Document; tie my %hash, 'Mango::BSON::Document'; =head1 DESCRIPTION L is a container for the BSON document type used by L. =head1 SEE ALSO L, L, L. =cut Mango-0.22/lib/Mango/BSON/ObjectID.pm000644 000765 000024 00000003720 12242773025 016775 0ustar00sristaff000000 000000 package Mango::BSON::ObjectID; use Mojo::Base -base; use overload '""' => sub { shift->to_string }, fallback => 1; use Carp 'croak'; use Mojo::Util 'md5_bytes'; use Sys::Hostname 'hostname'; # 3 byte machine identifier my $MACHINE = substr md5_bytes(hostname), 0, 3; # Global counter my $COUNTER = 0; sub new { my ($class, $oid) = @_; croak qq{Invalid object id "$oid"} if defined $oid && $oid !~ /^[0-9a-fA-F]{24}$/; return defined $oid ? $class->SUPER::new(oid => $oid) : $class->SUPER::new; } sub from_epoch { my ($self, $epoch) = @_; $self->{oid} = _generate($epoch); return $self; } sub to_epoch { unpack 'N', substr(pack('H*', shift->to_string), 0, 4) } sub to_string { shift->{oid} //= _generate() } sub _generate { # 4 byte time, 3 byte machine identifier and 2 byte process id my $oid = pack('N', shift // time) . $MACHINE . pack('n', $$ % 0xffff); # 3 byte counter $COUNTER = ($COUNTER + 1) % 0xffffff; return unpack 'H*', $oid . substr(pack('V', $COUNTER), 0, 3); } 1; =encoding utf8 =head1 NAME Mango::BSON::ObjectID - Object ID type =head1 SYNOPSIS use Mango::BSON::ObjectID; my $oid = Mango::BSON::ObjectID->new('1a2b3c4e5f60718293a4b5c6'); say $oid->to_epoch; =head1 DESCRIPTION L is a container for the BSON object id type used by L. =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 new my $oid = Mango::BSON::ObjectID->new; my $oid = Mango::BSON::ObjectID->new('1a2b3c4e5f60718293a4b5c6'); Construct a new L object. =head2 from_epoch my $oid = $oid->from_epoch(1359840145); Generate new object id with specific epoch time. =head2 to_epoch my $epoch = $oid->to_epoch; Extract epoch seconds from object id. =head2 to_string my $str = $oid->to_string; my $str = "$oid"; Stringify object id. =head1 SEE ALSO L, L, L. =cut Mango-0.22/lib/Mango/BSON/Time.pm000644 000765 000024 00000002160 12242773023 016243 0ustar00sristaff000000 000000 package Mango::BSON::Time; use Mojo::Base -base; use overload '""' => sub { shift->to_string }, fallback => 1; use Time::HiRes 'time'; sub new { shift->SUPER::new(time => shift // int(time * 1000)) } sub to_epoch { shift->to_string / 1000 } sub to_string { shift->{time} } sub TO_JSON { shift->to_string } 1; =encoding utf8 =head1 NAME Mango::BSON::Time - Datetime type =head1 SYNOPSIS use Mango::BSON::Time; my $time = Mango::BSON::Time->new(time * 1000); say $time->to_epoch; =head1 DESCRIPTION L is a container for the BSON datetime type used by L. =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 new my $time = Mango::BSON::Time->new; my $time = Mango::BSON::Time->new(time * 1000); Construct a new L object. =head2 to_epoch my $epoch = $time->to_epoch; Convert time to floating seconds since the epoch. =head2 to_string my $str = $time->to_string; my $str = "$time"; Stringify time. =head1 SEE ALSO L, L, L. =cut Mango-0.22/lib/Mango/BSON/Timestamp.pm000644 000765 000024 00000001466 12242773021 017316 0ustar00sristaff000000 000000 package Mango::BSON::Timestamp; use Mojo::Base -base; has [qw(seconds increment)]; 1; =encoding utf8 =head1 NAME Mango::BSON::Timestamp - Timestamp type =head1 SYNOPSIS use Mango::BSON::Timestamp; my $ts = Mango::BSON::Timestamp->new(seconds => 23, increment => 5); =head1 DESCRIPTION L is a container for the BSON timestamp type used by L. =head1 ATTRIBUTES L implements the following attributes. =head2 seconds my $seconds = $ts->seconds; $ts = $ts->seconds(23); Seconds. =head2 increment my $inc = $ts->increment; $tz = $ts->increment(5); Increment. =head1 METHODS L inherits all methods from L. =head1 SEE ALSO L, L, L. =cut