Mango-1.29/0000755000175000017500000000000012734553532010613 5ustar odcodcMango-1.29/MANIFEST0000644000175000017500000000157712734553532011756 0ustar odcodcChanges CONTRIBUTING.md lib/Mango.pm lib/Mango/Auth.pm lib/Mango/Auth/SCRAM.pm lib/Mango/BSON.pm lib/Mango/BSON/Binary.pm lib/Mango/BSON/Code.pm lib/Mango/BSON/Document.pm lib/Mango/BSON/Number.pm lib/Mango/BSON/ObjectID.pm lib/Mango/BSON/Time.pm lib/Mango/BSON/Timestamp.pm lib/Mango/Bulk.pm lib/Mango/Collection.pm lib/Mango/Cursor.pm lib/Mango/Cursor/Query.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/auth/auth.t t/auth/authenticate.t t/bson.t t/bulk.t t/collection.t t/connection.t t/cursor.t t/database.t t/gridfs.t t/leaks/auth.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-1.29/MANIFEST.SKIP0000644000175000017500000000011512627662035012506 0ustar odcodc^\.(?!perltidyrc) .*\.old$ \.tar\.gz$ ^Makefile$ ^MYMETA\. ^blib ^pm_to_blib Mango-1.29/lib/0000755000175000017500000000000012734553532011361 5ustar odcodcMango-1.29/lib/Mango.pm0000644000175000017500000004173112734552764012774 0ustar odcodcpackage Mango; use Mojo::Base 'Mojo::EventEmitter'; use Carp 'croak'; use Hash::Util::FieldHash; use Mango::BSON 'bson_doc'; use Mango::Database; use Mango::Protocol; use Mojo::IOLoop; use Mojo::URL; use Mojo::Util 'dumper'; use Scalar::Util 'weaken'; use constant DEBUG => $ENV{MANGO_DEBUG} || 0; use constant DEFAULT_PORT => 27017; has default_db => 'admin'; has hosts => sub { [['localhost']] }; has [qw(inactivity_timeout j)] => 0; has ioloop => sub { Mojo::IOLoop->new }; has max_bson_size => 16777216; has max_connections => 5; has [qw(max_write_batch_size wtimeout)] => 1000; has protocol => sub { Mango::Protocol->new }; has w => 1; # Private variables are not visible in the object's dump. This # is good for security. Hash::Util::FieldHash::fieldhash my %AUTH; our $VERSION = '1.29'; sub DESTROY { shift->_cleanup } 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 if (($url->userinfo // '') =~ /^([^:]+):([^:]+)$/) { require Mango::Auth::SCRAM; $self->_auth(Mango::Auth::SCRAM->new) ->_auth->_credentials([$self->default_db, $1, $2]); } # 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 get_more { shift->_op('get_more', 1, @_) } sub kill_cursors { shift->_op('kill_cursors', 0, @_) } sub new { shift->SUPER::new->from_string(@_) } sub query { shift->_op('query', 1, @_) } sub _auth { my ($self, $mode) = @_; return $AUTH{$self} unless $mode; $AUTH{$self} = $mode; $AUTH{$self}->mango($self); weaken $AUTH{$self}->{mango}; return $self; } 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 $self->_loop(0); # Clean up connections delete $self->{pid}; my $connections = delete $self->{connections}; for my $c (keys %$connections) { my $loop = $self->_loop($connections->{$c}{nb}); $loop->remove($c) if $loop; } # Clean up active operations my $queue = delete $self->{queue} || []; $_->{last} && !$_->{start} && unshift @$queue, $_->{last} for values %$connections; $self->_finish(undef, $_->{cb}, 'Premature connection close') for @$queue; } sub _close { my ($self, $id) = @_; return unless my $c = delete $self->{connections}{$id}; my $last = $c->{last}; $self->_finish(undef, $last->{cb}, 'Premature connection close') if $last; $self->_connect($c->{nb}) if @{$self->{queue}}; } sub _connect { my ($self, $nb, $hosts) = @_; my ($host, $port) = @{shift @{$hosts ||= [@{$self->hosts}]}}; weaken $self; my $id; $id = $self->_loop($nb)->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($nb, $hosts); } # Connection established $stream->timeout($self->inactivity_timeout); $stream->on(close => sub { $self && $self->_close($id) }); $stream->on(error => sub { $self && $self->_error($id, pop) }); $stream->on(read => sub { $self->_read($id, pop) }); # Check node information with "isMaster" command my $cb = sub { shift->_master($id, $nb, $hosts, pop) }; $self->_fast($id, $self->default_db, {isMaster => 1}, $cb); } ); $self->{connections}{$id} = { nb => $nb, start => 1 }; my $num = scalar keys %{$self->{connections}}; warn "-- New connection ($host:$port:$num)\n" if DEBUG; } sub _error { my ($self, $id, $err) = @_; return unless my $c = delete $self->{connections}{$id}; $self->_loop($c->{nb})->remove($id); my $last = $c->{last} // shift @{$self->{queue}}; $self->_finish(undef, $last->{cb}, $err) if $last; } sub _fast { my ($self, $id, $db, $command, $cb) = @_; # Handle errors my $wrapper = sub { my ($self, $err, $reply) = @_; my $doc = $reply->{docs}[0]; $err ||= $self->protocol->command_error($doc); return $self->$cb(undef, $doc) unless $err; return unless my $last = shift @{$self->{queue}}; $self->_finish(undef, $last->{cb}, $err); }; # 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 { $_[1] ? Mojo::IOLoop->singleton : $_[0]->ioloop } sub _master { my ($self, $id, $nb, $hosts, $doc) = @_; # Check version return $self->_error($id, 'MongoDB version 3.0 required') unless ($doc->{maxWireVersion} || 0) >= 3; # Continue with authentication if we are connected to the primary if ($doc->{ismaster}) { return $self->_auth ? $self->_auth->_authenticate($id) : $self->emit(connection => $id)->_next; } # Get primary and try to connect again unshift @$hosts, [$1, $2] if ($doc->{primary} // '') =~ /^(.+):(\d+)$/; return $self->_error($id, "Couldn't find primary node") unless @$hosts; delete $self->{connections}{$id}; $self->_loop($nb)->remove($id); $self->_connect($nb, $hosts); } sub _next { my ($self, $op) = @_; # Make sure all connections are saturated push @{$self->{queue} ||= []}, $op if $op; my $connections = $self->{connections}; my $start; $self->_write($_) and $start++ for keys %$connections; # Check if we need a blocking connection return unless $op; my @ids = keys %$connections; return $self->_connect(0) if !$op->{nb} && !grep { !$connections->{$_}{nb} } @ids; # Check if we need more non-blocking connections $self->_connect(1) if !$start && @{$self->{queue}} && @ids < $self->max_connections; } sub _op { my ($self, $op, $safe) = (shift, shift, shift); my $cb = ref $_[-1] eq 'CODE' ? pop : undef; my ($next, $msg) = $self->_build($op, @_); $self->_start( {id => $next, safe => $safe, msg => $msg, nb => !!$cb, cb => $cb}); } 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 return $self->_next($op) if $op->{cb}; # Blocking my ($err, $reply); $op->{cb} = sub { shift->ioloop->stop; ($err, $reply) = @_ }; $self->_next($op); $self->ioloop->start; return $err ? croak $err : $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($c->{nb}); return undef unless my $stream = $loop->stream($id); if (!$loop->is_running && $stream->is_readable) { $stream->close; return undef; } # Fast operation delete $c->{start} unless my $last = delete $c->{fast}; # Blocking operations have a higher precedence return $c->{start} unless $last || ($c->{nb} xor !($self->{queue}->[-1] || {})->{nb}); $last ||= $c->{nb} ? shift @{$self->{queue}} : pop @{$self->{queue}}; return $c->{start} unless $c->{last} = $last; 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; # Declare a Mango helper sub mango { state $m = Mango->new('mongodb://localhost:27017') } # or in a Mojolicious::Lite app helper mango => sub { state $m = Mango->new('mongodb://localhost:27017') }; # Insert document 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}); # Non-blocking concurrent find 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; # 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. For MongoDB 2.6 support, use L 1.16. To learn more about MongoDB you should take a look at the L, the documentation included in this distribution is no replacement for it. Look at L for CRUD operations. 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, SOCKS5 as well as TLS support, the optional modules L (4.0+), L (0.20+), L (0.64+) and L (1.84+) will be used automatically if they are installed. Individual features can also be disabled with the C, C and C 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. =head1 ATTRIBUTES L implements the following attributes. =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 inactivity_timeout my $timeout = $mango->inactivity_timeout; $mango = $mango->inactivity_timeout(15); Maximum amount of time in seconds a connection can be inactive before getting closed, defaults to C<0>. Setting the value to C<0> will allow connections to be inactive indefinitely. =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_bson_size my $max = $mango->max_bson_size; $mango = $mango->max_bson_size(16777216); Maximum size for BSON documents in bytes, defaults to C<16777216> (16MB). =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 max_write_batch_size my $max = $mango->max_write_batch_size; $mango = $mango->max_write_batch_size(1000); Maximum number of write operations to batch together, defaults to C<1000>. =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 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'); Build 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 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 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 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. Not that is is B recommended to build your Mango object inside a helper function like shown in the synopsis. This is because the Mango's object reference inside L objects is weakened to avoid memory leaks. This means your Mango instance is quickly going to get undefined after you use the C method. So, use a helper to prevent that. If a username and password are provided, Mango will try to authenticate using SCRAM-SHA1. B this will require L which is not installed by default. =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; =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. Current maintainer: Olivier Duclos C. =head1 CREDITS In alphabetical order: =over 2 alexbyk Andrey Khozov Colin Cyr =back =head1 COPYRIGHT AND LICENSE Copyright (C) 2013-2014, 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, L. =cut Mango-1.29/lib/Mango/0000755000175000017500000000000012734553532012422 5ustar odcodcMango-1.29/lib/Mango/Cursor.pm0000644000175000017500000001114612627662035014240 0ustar odcodcpackage Mango::Cursor; use Mojo::Base -base; use Mojo::IOLoop; has [qw(collection id ns)]; has [qw(batch_size limit)] => 0; 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 next { my ($self, $cb) = @_; return defined $self->id ? $self->_continue($cb) : $self->_start($cb); } sub num_to_return { my $self = shift; my $limit = $self->limit; my $size = $self->batch_size; return $limit == 0 || ($size > 0 && $size < $limit) ? $size : $limit; } 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 = $self->ns // $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->num_to_return, $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->num_to_return, $self->id)); } sub _defer { my ($self, $cb, @args) = @_; Mojo::IOLoop->next_tick(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 undef 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 _start { die 'Cursor cannot be restarted' } 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 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>. =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 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; =head2 num_to_return my $num = $cursor->num_to_return; Number of results to return with next C or C operation based on L and L. =head1 SEE ALSO L, L, L. =cut Mango-1.29/lib/Mango/GridFS.pm0000644000175000017500000001052612627662035014102 0ustar odcodcpackage 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) = @_; # Positive numbers are absolute and negative ones relative my $cursor = $self->files->find({filename => $name}, {_id => 1})->limit(-1); $cursor->sort({uploadDate => $version < 0 ? -1 : 1}) ->skip($version < 0 ? abs($version) - 1 : $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 $prefix = $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 versions of files, positive numbers from C<0> and upwards always point to a specific version, negative ones start with C<-1> for the most recently added version. 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; Build 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; Build 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-1.29/lib/Mango/Cursor/0000755000175000017500000000000012734553532013677 5ustar odcodcMango-1.29/lib/Mango/Cursor/Query.pm0000644000175000017500000001433212627662035015345 0ustar odcodcpackage Mango::Cursor::Query; use Mojo::Base 'Mango::Cursor'; use Mango::BSON 'bson_doc'; has [ qw(await_data comment hint max_scan max_time_ms read_preference snapshot), qw(sort tailable) ]; has [qw(fields query)]; has skip => 0; sub build_query { my ($self, $explain) = @_; my %ext; if (my $comment = $self->comment) { $ext{'$comment'} = $comment } if ($explain) { $ext{'$explain'} = 1 } if (my $hint = $self->hint) { $ext{'$hint'} = $hint } if (my $max_scan = $self->max_scan) { $ext{'$maxScan'} = $max_scan } if (my $max = $self->max_time_ms) { $ext{'$maxTimeMS'} = $max } if (my $pref = $self->read_preference) { $ext{'$readPreference'} = $pref } if (my $snapshot = $self->snapshot) { $ext{'$snapshot'} = 1 } if (my $sort = $self->sort) { $ext{'$orderby'} = $sort } my $query = $self->query; return $query unless keys %ext; return bson_doc $query->{'$query'} ? %$query : ('$query' => $query), %ext; } sub clone { my $self = shift; my $clone = $self->new; $clone->$_($self->$_) for qw(await_data batch_size collection comment); $clone->$_($self->$_) for qw(fields hint limit max_scan max_time_ms query); $clone->$_($self->$_) for qw(read_preference 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 _start { my ($self, $cb) = @_; my $collection = $self->collection; my $name = $collection->full_name; my $flags = {}; $flags->{tailable_cursor} = 1 if $self->tailable; $flags->{await_data} = 1 if $self->await_data; my @query = ( $name, $flags, $self->skip, $self->num_to_return, $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::Query - MongoDB query cursor =head1 SYNOPSIS use Mango::Cursor::Query; my $cursor = Mango::Cursor::Query->new(collection => $collection); my $docs = $cursor->all; =head1 DESCRIPTION L is a container for MongoDB query cursors used by L. =head1 ATTRIBUTES L inherits all attributes from L and implements the following new ones. =head2 await_data my $await = $cursor->await_data; $cursor = $cursor->await_data(1); Await data. =head2 comment my $comment = $cursor->comment; $cursor = $cursor->comment('Fun query!'); A comment to identify query. =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 max_scan my $max = $cursor->max_scan; $cursor = $cursor->max_scan(500); Limit the number of documents to scan. =head2 max_time_ms my $max = $cursor->max_time_ms; $cursor = $cursor->max_time_ms(500); Timeout for query in milliseconds. =head2 query my $query = $cursor->query; $cursor = $cursor->query({foo => 'bar'}); Original query. =head2 read_preference my $pref = $cursor->read_preference; $cursor = $cursor->read_preference({mode => 'SECONDARY'}); Read preference. =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 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; =head1 SEE ALSO L, L, L. =cut Mango-1.29/lib/Mango/BSON/0000755000175000017500000000000012734553532013163 5ustar odcodcMango-1.29/lib/Mango/BSON/ObjectID.pm0000644000175000017500000000445012663373255015152 0ustar odcodcpackage Mango::BSON::ObjectID; use Mojo::Base -base; use overload bool => sub {1}, '""' => 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 = int(rand(0xffffff)); sub from_epoch { my ($self, $epoch) = @_; $self->{oid} = _generate($epoch); return $self; } sub new { my ($class, $oid) = @_; return $class->SUPER::new unless defined $oid; croak qq{Invalid object id "$oid"} if $oid !~ /^[0-9a-fA-F]{24}\z/; return $class->SUPER::new(oid => pack('H*', $oid)); } sub to_bytes { shift->{oid} //= _generate() } sub to_epoch { unpack 'N', substr(shift->to_bytes, 0, 4) } sub to_string { unpack 'H*', shift->to_bytes } sub _generate { $COUNTER = ($COUNTER + 1) % 0xffffff; return pack('N', shift // time) # 4 byte time . $MACHINE # 3 byte machine identifier . pack('n', $$ % 0xffff) # 2 byte process id . substr pack('V', $COUNTER), 0, 3; # 3 byte counter } 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 from_epoch my $oid = $oid->from_epoch(1359840145); Generate new object id with specific epoch time. =head2 new my $oid = Mango::BSON::ObjectID->new; my $oid = Mango::BSON::ObjectID->new('1a2b3c4e5f60718293a4b5c6'); Construct a new L object. =head2 to_bytes my $bytes = $oid->to_bytes; Object id in binary form. =head2 to_epoch my $epoch = $oid->to_epoch; Extract epoch seconds from object id. =head2 to_string my $str = $oid->to_string; Stringify object id. =head1 OPERATORS L overloads the following operators. =head2 bool my $bool = !!$oid; Always true. =head2 stringify my $str = "$oid"; Alias for L. =head1 SEE ALSO L, L, L. =cut Mango-1.29/lib/Mango/BSON/Code.pm0000644000175000017500000000141312627662035014372 0ustar odcodcpackage 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-1.29/lib/Mango/BSON/Binary.pm0000644000175000017500000000256012627662035014750 0ustar odcodcpackage Mango::BSON::Binary; use Mojo::Base -base; use overload bool => sub {1}, '""' => 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; =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 and implements the following new ones. =head2 TO_JSON my $b64 = $bin->TO_JSON; Base64 encode L. =head1 OPERATORS L overloads the following operators. =head2 bool my $bool = !!$bin; Always true. =head2 stringify my $str = "$bin"; Alias for L. =head1 SEE ALSO L, L, L. =cut Mango-1.29/lib/Mango/BSON/Timestamp.pm0000644000175000017500000000146612627662035015473 0ustar odcodcpackage 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 Mango-1.29/lib/Mango/BSON/Number.pm0000644000175000017500000000600112627662035014746 0ustar odcodcpackage Mango::BSON::Number; use Mojo::Base -base; use overload bool => sub { !!shift->value }, '""' => sub { shift->to_string }, fallback => 1; use B; use Carp 'croak'; # 32bit integer range use constant { INT32_MIN => -(1 << 31) + 1, INT32_MAX => (1 << 31) - 1 }; has [qw(value type)]; sub new { my ($class, $value, $type) = @_; $value //= 0; $type //= Mango::BSON::DOUBLE(); if ($type ne Mango::BSON::DOUBLE() && $type ne Mango::BSON::INT32() && $type ne Mango::BSON::INT64()) { croak "Invalid numerical type: '$type'"; } return $class->SUPER::new(value => $value, type => $type); } sub TO_JSON { 0 + shift->value } sub to_string { '' . shift->value } sub isa_number { my $value = shift; my $flags = B::svref_2object(\$value)->FLAGS; if ($flags & (B::SVp_IOK | B::SVp_NOK)) { if ( ( 0 + $value eq $value && $value * 0 == 0) || ( 0 + 'nan' eq $value ) || ( 0 + '+inf' eq $value ) || ( 0 + '-inf' eq $value ) ) { return $flags; } } return undef; } sub guess_type { my $value = shift; if (my $flags = isa_number($value)) { # Double return Mango::BSON::DOUBLE() if $flags & B::SVp_NOK; # Int32 return Mango::BSON::INT32() if $value <= INT32_MAX && $value >= INT32_MIN; # Int64 return Mango::BSON::INT64(); } return undef; } 1; =encoding utf8 =head1 NAME Mango::BSON::Number - Numerical types =head1 SYNOPSIS use Mango::BSON; use Mango::BSON::Number; my $number = Mango::BSON::Number->new(666, Mango::BSON::INT64); say $number; =head1 DESCRIPTION L is a container for numerical values with a strict type. =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 new my $number = Mango::BSON::Number->new(3.14, Mango::BSON::DOUBLE); Construct a new L object. Croak if the value is incompatible with the given type. The 3 supported types are C, C and C. =head2 TO_JSON my $num = $obj->TO_JSON; Return the numerical value. =head2 to_string my $str = $num->to_string; Return the value as a string. =head2 isa_number my $flags = Mango::BSON::Number::isa_number(25); Determine if the given variable is a number by looking at the internal flags of the perl scalar object. Return C if the value is not a number, or a non-null value otherwise. This value contains flags which can be used for finer analysis of the scalar. =head2 guess_type my $mongo_type = Mango::BSON::Number::guess_type(25); Chose which BSON type to use to encode the given numeric value. Possible types are: C, C or C. Return C if the given value is not a number. =head1 OPERATORS L overloads the following operators. =head2 bool my $bool = !!$num; =head2 stringify my $str = "$num"; Alias for L. =head1 SEE ALSO L, L, L. =cut Mango-1.29/lib/Mango/BSON/Document.pm0000644000175000017500000000205312627662035015277 0ustar odcodcpackage 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-1.29/lib/Mango/BSON/Time.pm0000644000175000017500000000312112627662035014414 0ustar odcodcpackage Mango::BSON::Time; use Mojo::Base -base; use overload bool => sub {1}, '""' => sub { shift->to_string }, fallback => 1; use Mojo::Date; use Time::HiRes 'time'; sub new { shift->SUPER::new(time => shift // int(time * 1000)) } sub TO_JSON { 0 + shift->{time} } sub to_datetime { Mojo::Date->new(shift->to_epoch)->to_datetime } sub to_epoch { shift->to_string / 1000 } sub to_string { shift->{time} } 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_JSON my $num = $time->TO_JSON; Numeric representation of time. =head2 to_datetime my $str = $time->to_datetime; Convert time to L date and time. =head2 to_epoch my $epoch = $time->to_epoch; Convert time to floating seconds since the epoch. =head2 to_string my $str = $time->to_string; Stringify time. =head1 OPERATORS L overloads the following operators. =head2 bool my $bool = !!$time; Always true. =head2 stringify my $str = "$time"; Alias for L. =head1 SEE ALSO L, L, L. =cut Mango-1.29/lib/Mango/Collection.pm0000644000175000017500000004017012734550156015054 0ustar odcodcpackage Mango::Collection; use Mojo::Base -base; use Carp 'croak'; use Mango::BSON qw(bson_code bson_doc bson_oid); use Mango::Bulk; use Mango::Cursor; use Mango::Cursor::Query; 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 // {}}); $command->{cursor} //= {} unless $command->{explain}; # Blocking return $self->_aggregate($command, $self->db->command($command)) unless $cb; # Non-blocking return $self->db->command($command, sub { shift; $self->$cb(shift, $self->_aggregate($command, shift)) }); } sub build_index_name { join '_', keys %{$_[1]} } sub bulk { Mango::Bulk->new(collection => shift) } sub create { my $self = shift; my $cb = ref $_[-1] eq 'CODE' ? pop : undef; return $self->_command(bson_doc(create => $self->name, %{shift // {}}), $cb); } sub drop { $_[0]->_command(bson_doc(drop => $_[0]->name), $_[1]) } sub drop_index { my ($self, $name) = (shift, shift); return $self->_command(bson_doc(dropIndexes => $self->name, index => $name), shift); } 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->{key} = $spec; # Non-blocking my $command = bson_doc createIndexes => $self->name, indexes => [$doc]; return $self->db->command($command => sub { shift; $self->$cb(shift) }) if $cb; # Blocking $self->db->command($command); } sub find { Mango::Cursor::Query->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), shift, sub { shift->{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 = shift; my $cb = ref $_[-1] eq 'CODE' ? pop : undef; my $cmd = bson_doc(listIndexes => $self->name, @_); $self->_command($cmd, $cb, sub { my $doc = shift or return bson_doc; bson_doc map { delete $_->{ns}; (delete $_->{name}, $_) } @{$doc->{cursor}->{firstBatch}}; } ); } sub insert { my ($self, $orig_docs, $cb) = @_; $orig_docs = [$orig_docs] unless ref $orig_docs eq 'ARRAY'; # Make a shallow copy of the documents and add an id if needed my @docs = map { bson_doc %$_ } @$orig_docs; my @ids = map { $_->{_id} //= bson_oid } @docs; my $command = bson_doc insert => $self->name, documents => \@docs, ordered => \1, writeConcern => $self->db->build_write_concern; return $self->_command($command, $cb, sub { @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) = @_; my $cmd = bson_doc(listCollections => 1, filter => { name => $self->name }); $self->_command($cmd, $cb, sub { shift->{cursor}->{firstBatch}->[0] }); } sub remove { my $self = shift; my $cb = ref $_[-1] eq 'CODE' ? pop : undef; my $query = shift // {}; my $flags = shift // {}; ($query, $flags) = ({_id => $query}, {single => 1}) if ref $query eq 'Mango::BSON::ObjectID'; my $command = bson_doc delete => $self->name, deletes => [{q => $query, limit => $flags->{single} ? 1 : 0}], ordered => \1, writeConcern => $self->db->build_write_concern; return $self->_command($command, $cb); } sub rename { my ($self, $name, $cb) = @_; my $admin = $self->db->mango->db('admin'); my $dbname = $self->db->name; my $oldname = join '.', $dbname, $self->name; my $newname = join '.', $dbname, $name; my $cmd = bson_doc renameCollection => $oldname, to => $newname; # Non-blocking return $admin->command($cmd, sub { my ($admin_db, $err, $doc) = @_; my $newcol = $doc->{ok} ? $self->db->collection($name) : undef; return $cb->($self, $err, $newcol); }) if $cb; # Blocking my $doc = $admin->command($cmd); return $doc->{ok} ? $self->db->collection($name) : undef; } 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), $_[1]) } sub update { my ($self, $query, $update) = (shift, shift, shift); my $cb = ref $_[-1] eq 'CODE' ? pop : undef; my $flags = shift // {}; $update = { q => ref $query eq 'Mango::BSON::ObjectID' ? {_id => $query} : $query, u => $update, upsert => $flags->{upsert} ? \1 : \0, multi => $flags->{multi} ? \1 : \0 }; my $command = bson_doc update => $self->name, updates => [$update], ordered => \1, writeConcern => $self->db->build_write_concern; return $self->_command($command, $cb); } sub _aggregate { my ($self, $command, $doc) = @_; # Document (explain) return $doc if $command->{explain}; # Collection my $out = $command->{pipeline}[-1]{'$out'}; return $self->db->collection($out) if defined $out; # Cursor my $cursor = $doc->{cursor}; return Mango::Cursor->new(collection => $self, id => $cursor->{id}) ->add_batch($cursor->{firstBatch}); } sub _command { my ($self, $command, $cb, $return) = @_; $return ||= sub {shift}; # Non-blocking my $db = $self->db; my $protocol = $db->mango->protocol; return $db->command( $command => sub { my ($db, $err, $doc) = @_; $err ||= $protocol->write_error($doc); $self->$cb($err, $return->($doc)); } ) if $cb; # Blocking my $doc = $db->command($command); if (my $err = $protocol->write_error($doc)) { croak $err } return $return->($doc); } 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 $cursor = $collection->aggregate( [{'$group' => {_id => undef, total => {'$sum' => '$foo'}}}]); my $collection = $collection->aggregate( [{'$match' => {'$gt' => 23}}, {'$out' => 'some_collection'}]); my $doc = $collection->aggregate( [{'$match' => {'$gt' => 23}}], {explain => bson_true}); 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, $cursor) = @_; ... }); 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 bulk my $bulk = $collection->bulk; Build L object. my $bulk = $collection->bulk; $bulk->insert({foo => $_}) for 1 .. 10; $bulk->find({foo => 4})->update_one({'$set' => {bar => 'baz'}}); $bulk->find({foo => 7})->remove_one; my $results = $bulk->execute; =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}); Build L object for query. # Exclude "_id" field from results my $docs = $collection->find({foo => 'bar'}, {_id => 0})->all; =head2 find_and_modify my $doc = $collection->find_and_modify( {query => {foo => 'bar'}, update => {'$set' => {foo => 'baz'}}}); Fetch and update or remove a 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; By default this method returns the unmodified version of the document. To change this behaviour, add the option C 1>. =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; # return only the 5 first indexes my $info = $collection->index_information(cursor => { batchSize => 5 }); 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; Note that C has to ensure each document has an C<_id> before sending them to MongoDB. To avoid modifying your data, it makes a copy of the documents. This can be a bit slow if you are sending big objects like pictures. To avoid that, consider using C instead. =head2 map_reduce my $collection = $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 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 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 $result = $collection->remove; my $result = $collection->remove($oid); my $result = $collection->remove({foo => 'bar'}); my $result = $collection->remove({foo => 'bar'}, {single => 1}); Remove documents from collection. You can also append a callback to perform operation non-blocking. Returns a WriteResult document. $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 rename my $new_collection = $collection->rename('NewName'); Rename a collection, keeping all of its original contents and options. Returns a new Mango::Collection object pointing to the renamed collection. You can also append a callback to perform operation non-blocking. $collection->rename('NewName' => sub { my ($collection, $err, $oid) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 save my $oid = $collection->save({foo => 'bar'}); Save document to collection. The document MUST have an C<_id>. 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 $result = $collection->update($oid, {foo => 'baz'}); my $result = $collection->update({foo => 'bar'}, {foo => 'baz'}); my $result = $collection->update({foo => 'bar'}, {foo => 'baz'}, {multi => 1}); Update document in collection. You can also append a callback to perform operation non-blocking. Returns a WriteResult document. $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-1.29/lib/Mango/BSON.pm0000644000175000017500000003261412663402643013524 0ustar odcodcpackage Mango::BSON; use Mojo::Base -strict; use re 'regexp_pattern'; use Carp 'croak'; use Exporter 'import'; use Mango::BSON::Binary; use Mango::BSON::Code; use Mango::BSON::Document; use Mango::BSON::Number; 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_double), qw(bson_encode bson_false bson_int32 bson_int64 bson_length bson_max), qw(bson_min bson_oid bson_raw bson_time bson_true bson_ts) ); our @EXPORT_OK = (@BSON, 'encode_cstring'); our %EXPORT_TAGS = (bson => \@BSON); # Types use constant { DOUBLE => "\x01", STRING => "\x02", DOCUMENT => "\x03", ARRAY => "\x04", BINARY => "\x05", UNDEFINED => "\x06", OBJECT_ID => "\x07", BOOL => "\x08", DATETIME => "\x09", NULL => "\x0a", REGEX => "\x0b", CODE => "\x0d", CODE_SCOPE => "\x0f", INT32 => "\x10", TIMESTAMP => "\x11", INT64 => "\x12", MIN_KEY => "\xff", MAX_KEY => "\x7f" }; # Binary subtypes use constant { BINARY_GENERIC => "\x00", BINARY_FUNCTION => "\x01", BINARY_UUID => "\x04", BINARY_MD5 => "\x05", BINARY_USER_DEFINED => "\x80" }; # The pack() format to use for each numeric type my %num_pack_fmt = ( DOUBLE() => 'd<', INT32() => 'l<', INT64() => 'q<' ); # 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_double { Mango::BSON::Number->new(shift, DOUBLE) } sub bson_encode { my $doc = shift; # Embedded BSON return $doc->{'$bson'} if exists $doc->{'$bson'}; my $bson = join '', map { _encode_value(encode_cstring($_), $doc->{$_}) } keys %$doc; # Document ends with null byte return pack('l<', length($bson) + 5) . $bson . "\x00"; } sub bson_false {$FALSE} sub bson_int32 { Mango::BSON::Number->new(shift, INT32) } sub bson_int64 { Mango::BSON::Number->new(shift, INT64) } sub bson_length { length $_[0] < 4 ? undef : unpack 'l<', substr($_[0], 0, 4) } sub bson_max {$MAXKEY} sub bson_min {$MINKEY} sub bson_oid { Mango::BSON::ObjectID->new(@_) } sub bson_raw { bson_doc('$bson' => shift) } sub bson_time { Mango::BSON::Time->new(@_) } sub bson_ts { Mango::BSON::Timestamp->new(seconds => shift, increment => shift); } sub bson_true {$TRUE} sub encode_cstring { my $str = shift; utf8::encode $str; return pack 'Z*', $str; } sub _decode_binary { my $bsonref = shift; my $len = unpack 'l<', 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; my $str = substr $$bsonref, 0, index($$bsonref, "\x00"), ''; utf8::decode $str; substr $$bsonref, 0, 1, ''; return $str; } sub _decode_doc { my $bsonref = shift; # Every element starts with a type my @doc; substr $$bsonref, 0, 4, ''; while (my $type = substr $$bsonref, 0, 1, '') { # Null byte (end of document) last if $type eq "\x00"; push @doc, _decode_cstring($bsonref), _decode_value($type, $bsonref); } return bson_doc(@doc); } sub _decode_string { my $bsonref = shift; my $len = unpack 'l<', substr($$bsonref, 0, 4, ''); my $str = substr $$bsonref, 0, $len - 1, ''; utf8::decode $str; substr $$bsonref, 0, 1, ''; 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 unpack 'l<', substr($$bsonref, 0, 4, '') if $type eq INT32; return unpack 'q<', 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(unpack 'q<', substr($$bsonref, 0, 8, '')) if $type eq DATETIME; # Regex if ($type eq REGEX) { my ($p, $m) = (_decode_cstring($bsonref), _decode_cstring($bsonref)); croak "invalid regex modifier(s) in 'qr/$p/$m'" if length($m) and $m !~ /^[msixpadlun]+\z/; # escape $pat to avoid code injection return eval "qr/\$p/$m"; } # 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) { substr $$bsonref, 0, 4, ''; return bson_code(_decode_string($bsonref))->scope(_decode_doc($bsonref)); } # Timestamp return bson_ts( reverse map({ unpack 'l<', substr($$_, 0, 4, '') } $bsonref, $bsonref)) if $type eq TIMESTAMP; # Undefined - a deprecated type which should not exist anymore # but apparently still does: https://github.com/oliwer/mango/issues/1 return undef if $type eq UNDEFINED; # Unknown croak 'Unknown BSON type'; } sub _encode_binary { my ($e, $subtype, $value) = @_; return BINARY . $e . pack('l<', length $value) . $subtype . $value; } sub _encode_object { my ($e, $value, $class) = @_; # ObjectID return OBJECT_ID . $e . $value->to_bytes if $class eq 'Mango::BSON::ObjectID'; # Boolean return BOOL . $e . ($value ? "\x01" : "\x00") if $class eq $BOOL; # Time return DATETIME . $e . pack('q<', $value) if $class eq 'Mango::BSON::Time'; # Max return MAX_KEY . $e if $value eq $MAXKEY; # Min return MIN_KEY . $e if $value eq $MINKEY; # 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 . pack('l<', length $code) . $code; } # Without scope return CODE . $e . _encode_string($value->code); } # Timestamp return TIMESTAMP, $e, map { pack 'l<', $_ } $value->increment, $value->seconds if $class eq 'Mango::BSON::Timestamp'; # Number if ($class eq 'Mango::BSON::Number') { my $t = $value->type; return $t . $e . pack($num_pack_fmt{$t}, $value->value); } # Blessed reference with TO_JSON method if (my $sub = $value->can('TO_BSON') // $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 pack('l<', length($str) + 1) . "$str\x00"; } sub _encode_value { my ($e, $value) = @_; # Null return NULL . $e unless defined $value; # Reference if (my $ref = ref $value) { # Blessed return _encode_object($e, $value, $ref) if blessed $value; # Hash (Document) return DOCUMENT . $e . bson_encode($value) if $ref eq 'HASH'; # Array if ($ref eq 'ARRAY') { my $i = 0; return ARRAY . $e . bson_encode(bson_doc(map { $i++ => $_ } @$value)); } # Scalar (boolean shortcut) return _encode_object($e, !!$$value, $BOOL) if $ref eq 'SCALAR'; } # Numeric if (my $type = Mango::BSON::Number::guess_type($value)) { return $type . $e . pack($num_pack_fmt{$type}, $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 scalar, regular expression, C, array reference, hash reference and will try to call the C and C methods on blessed references, or stringify them if it doesn't exist. Scalar references will be used to generate booleans, based on if their values are true or false. =head1 FUNCTIONS L implements the following functions, which can be imported individually or at once with the C<:bson> flag. =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. # Longer version my $dbref = {'$ref' => 'test', '$id' => $oid}; =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_double my $doc = { foo => bson_double(13.0) }; Force a scalar value to be encoded as a double in MongoDB. Croaks if the value is incompatible with the double type. =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_int32 my $doc = { foo => bson_int32(13) }; # This will die (integer is too big) my $doc = { foo => bson_int32(2147483648) }; Force a scalar value to be encoded as a 32 bit integer in MongoDB. Croaks if the value is incompatible with the int32 type. =head2 bson_int64 my $doc = { foo => bson_int64(666) }; Force a scalar value to be encoded as a 64 bit integer in MongoDB. Croaks if the value is incompatible with the int64 type. =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_raw my $raw = bson_raw $bson; Pre-encoded BSON document. # Longer version my $raw = {'$bson' => $bson}; # Embed pre-encoded BSON document my $first = bson_encode {foo => 'bar'}; my $second = bson_encode {test => bson_raw $first}; =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. # "1360626536.748" bson_time(1360626536748)->to_epoch; # "2013-02-11T23:48:56.748Z" bson_time(1360626536748)->to_datetime; =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 encode_cstring my $bytes = encode_cstring $cstring; Encode cstring. =head1 SEE ALSO L, L, L. =cut Mango-1.29/lib/Mango/Bulk.pm0000644000175000017500000001363012665112750013654 0ustar odcodcpackage Mango::Bulk; use Mojo::Base -base; use Carp 'croak'; use Mango::BSON qw(bson_doc bson_encode bson_oid bson_raw); use Mojo::IOLoop; has 'collection'; has ordered => 1; sub execute { my ($self, $cb) = @_; # Full results shared with all operations my $full = {upserted => [], writeConcernErrors => [], writeErrors => []}; $full->{$_} = 0 for qw(nInserted nMatched nModified nRemoved nUpserted); # Non-blocking if ($cb) { return Mojo::IOLoop->next_tick(sub { shift; $self->$cb(undef, $full) }) unless my $group = shift @{$self->{ops}}; return $self->_next($group, $full, $cb); } # Blocking my $db = $self->collection->db; my $protocol = $db->mango->protocol; while (my $group = shift @{$self->{ops}}) { my ($type, $offset, $command) = $self->_group($group); _merge($type, $offset, $full, $db->command($command)); if (my $err = $protocol->write_error($full)) { croak $err } } return $full; } sub find { shift->_set(query => shift) } sub insert { my ($self, $doc) = @_; $doc->{_id} //= bson_oid; return $self->_op(insert => $doc); } sub remove { shift->_remove(0) } sub remove_one { shift->_remove(1) } sub update { shift->_update(\1, @_) } sub update_one { shift->_update(\0, @_) } sub upsert { shift->_set(upsert => 1) } sub _group { my ($self, $group) = @_; my ($type, $offset) = splice @$group, 0, 2; my $collection = $self->collection; return $type, $offset, bson_doc $type => $collection->name, $type eq 'insert' ? 'documents' : "${type}s" => $group, ordered => $self->ordered ? \1 : \0, writeConcern => $collection->db->build_write_concern; } sub _merge { my ($type, $offset, $full, $result) = @_; # Insert if ($type eq 'insert') { $full->{nInserted} += $result->{n} } # Update elsif ($type eq 'update') { $full->{nModified} += $result->{n}; # Upsert if (my $upserted = $result->{upserted}) { push @{$full->{upserted}}, map { $_->{index} += $offset; $_ } @$upserted; $full->{nUpserted} += @$upserted; $full->{nMatched} += $result->{n} - @$upserted; } else { $full->{nMatched} += $result->{n} } } # Delete elsif ($type eq 'delete') { $full->{nRemoved} += $result->{n} } # Errors push @{$full->{writeConcernErrors}}, $result->{writeConcernError} if $result->{writeConcernError}; push @{$full->{writeErrors}}, map { $_->{index} += $offset; $_ } @{$result->{writeErrors}}; } sub _next { my ($self, $group, $full, $cb) = @_; my ($type, $offset, $command) = $self->_group($group); $self->collection->db->command( $command => sub { my ($db, $err, $result) = @_; _merge($type, $offset, $full, $result) unless $err; $err ||= $self->collection->db->mango->protocol->write_error($full); return $self->$cb($err, $full) if $err; return $self->$cb(undef, $full) unless my $next = shift @{$self->{ops}}; $self->_next($next, $full, $cb); } ); } sub _op { my ($self, $type, $doc) = @_; # Pre-encode documents my $mango = $self->collection->db->mango; my $bson_max = $mango->max_bson_size; my $batch_max = $mango->max_write_batch_size; my $ops = $self->{ops} ||= []; my $previous = @$ops ? $ops->[-1] : []; my $bson = bson_encode $doc; my $size = length $bson; my $new = ($self->{size} // 0) + $size; my $limit = $new > $bson_max || @$previous >= $batch_max + 2; # Group documents based on type and limits push @$ops, [$type, $self->{offset} || 0] and delete $self->{size} if !@$previous || $previous->[0] ne $type || $limit; push @{$ops->[-1]}, bson_raw $bson; $self->{size} += $size; $self->{offset}++; return $self; } sub _remove { my ($self, $limit) = @_; my $query = delete $self->{query} // {}; return $self->_op(delete => {q => $query, limit => $limit}); } sub _set { my ($self, $key, $value) = @_; $self->{$key} = $value; return $self; } sub _update { my ($self, $multi, $update) = @_; my $query = delete $self->{query} // {}; my $upsert = delete $self->{upsert} ? \1 : \0; return $self->_op( update => {q => $query, u => $update, multi => $multi, upsert => $upsert}); } 1; =encoding utf8 =head1 NAME Mango::Bulk - MongoDB bulk operations =head1 SYNOPSIS use Mango::Bulk; my $bulk = Mango::Bulk->new(collection => $collection); $bulk->insert({foo => 'bar'})->insert({foo => 'baz'})->execute; =head1 DESCRIPTION L is a container for MongoDB bulk operations, all operations will be automatically grouped so they don't exceed L. =head1 ATTRIBUTES L implements the following attributes. =head2 collection my $collection = $bulk->collection; $bulk = $bulk->collection(Mango::Collection->new); L object this bulk operation belongs to. =head2 ordered my $bool = $bulk->ordered; $bulk = $bulk->ordered($bool); Bulk operations are ordered, defaults to a true value. =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 execute my $results = $bulk->execute; Execute bulk operations. You can also append a callback to perform operation non-blocking. $bulk->execute(sub { my ($bulk, $err, $results) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head2 find $bulk = $bulk->find({foo => 'bar'}); Query for next update or remove operation. =head2 insert $bulk = $bulk->insert({foo => 'bar'}); Insert document. =head2 remove $bulk = $bulk->remove; Remove multiple documents. =head2 remove_one $bulk = $bulk->remove_one; Remove one document. =head2 update $bulk = $bulk->update({foo => 'bar'}); Update multiple documents. =head2 update_one $bulk = $bulk->update_one({foo => 'baz'}); Update one document. =head2 upsert $bulk = $bulk->upsert; Next update operation will be an C. =head1 SEE ALSO L, L, L. =cut Mango-1.29/lib/Mango/Auth/0000755000175000017500000000000012734553532013323 5ustar odcodcMango-1.29/lib/Mango/Auth/SCRAM.pm0000644000175000017500000000455412627662035014536 0ustar odcodcpackage Mango::Auth::SCRAM; use Mojo::Base 'Mango::Auth'; use Mojo::Util qw(dumper md5_sum encode b64_encode b64_decode); use Mango::BSON 'bson_doc'; EVAL: { local $@; die "Authen::SCRAM is required to use SCRAM-SHA-1\n" unless eval { require Authen::SCRAM::Client; 1 }; } sub _credentials { my ($self, $creds) = @_; # [db, user, pass] $creds->[2] = md5_sum(encode("UTF-8", $creds->[1] . ":mongo:" . $creds->[2])); $self->{credentials} = $creds; } sub _authenticate { my ($self, $id) = @_; my $mango = $self->mango; my $cnx = $self->mango->{connections}{$id}; my $creds = $self->{credentials}; my ($db, $user, $pass) = @$creds; my $scram_client = Authen::SCRAM::Client->new( skip_saslprep => 1, username => $user, password => $pass ); my $delay = Mojo::IOLoop::Delay->new; my $conv_id; $delay->steps( sub { my ($d, $mango, $err, $doc) = @_; $conv_id = $doc->{conversationId}; my $final_msg = $scram_client->final_msg(b64_decode $doc->{payload}); my $command = $self->_cmd_sasl_continue($conv_id, $final_msg); $mango->_fast($id, $db, $command, $d->begin(0)); }, sub { my ($d, $mango, $err, $doc) = @_; $scram_client->validate(b64_decode $doc->{payload}); my $command = $self->_cmd_sasl_continue($conv_id, ''); $mango->_fast($id, $db, $command, $d->begin(0)); }, sub { my ($d, $mango, $err, $doc) = @_; $mango->emit(connection => $id)->_next; } ); my $command = $self->_cmd_sasl_start($scram_client->first_msg); $mango->_fast($id, $db, $command, $delay->begin(0)); $delay->wait; $delay->ioloop->one_tick; } sub _cmd_sasl_start { my ($self, $first_msg) = @_; bson_doc( 'saslStart' => 1, 'mechanism' => 'SCRAM-SHA-1', 'payload' => b64_encode($first_msg, ''), 'autoAuthorize' => 1, ); } sub _cmd_sasl_continue { my ($self, $conv_id, $final_msg) = @_; bson_doc( 'saslContinue' => 1, 'conversationId' => $conv_id, 'payload' => $final_msg ? b64_encode($final_msg, '') : '' ); } 1; =encoding utf8 =head1 NAME Mango::Auth::SCRAM - SCRAM-SHA-1 Authentication =head1 DESCRIPTION The default authentication backend for L using the SCRAM-SHA-1 algorithm. It requires L. =head1 SEE ALSO L, L, L. =cut Mango-1.29/lib/Mango/Auth.pm0000644000175000017500000000052512627662035013663 0ustar odcodcpackage Mango::Auth; use Mojo::Base -base; has 'mango'; 1; =encoding utf8 =head1 NAME Mango::Auth - Authentication =head1 DESCRIPTION A base class shared by all authentication backends. =head1 ATTRIBUTES =head2 mango The attached L instance. =head1 SEE ALSO L, L, L. =cut Mango-1.29/lib/Mango/GridFS/0000755000175000017500000000000012734553532013540 5ustar odcodcMango-1.29/lib/Mango/GridFS/Reader.pm0000644000175000017500000001036312627662035015303 0ustar odcodcpackage 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 md5 { shift->{meta}{md5} } 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->next_tick(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 md5 my $checksum = $reader->md5; MD5 checksum for 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-1.29/lib/Mango/GridFS/Writer.pm0000644000175000017500000001143612627662035015357 0ustar odcodcpackage 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); use Mojo::IOLoop; has chunk_size => 261120; 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->next_tick(sub { $self->$cb(undef, $files_id) }); } my @index = (bson_doc(files_id => 1, n => 1), {unique => \1}); my $gridfs = $self->gridfs; my $command = bson_doc filemd5 => $self->_files_id, root => $gridfs->prefix; # Non-blocking my $chunks = $gridfs->chunks; my $bulk = $chunks->bulk; my $files = $gridfs->files; return Mojo::IOLoop->delay( sub { $self->_chunk($bulk)->execute(shift->begin) }, sub { my ($delay, $err) = @_; return $delay->pass($err) if $err; $files->ensure_index({filename => 1} => $delay->begin); $chunks->ensure_index(@index => $delay->begin); }, sub { my ($delay, $files_err, $chunks_err) = @_; if (my $err = $files_err || $chunks_err) { return $delay->pass($err) } $gridfs->db->command($command => $delay->begin); }, sub { my ($delay, $err, $doc) = @_; return $delay->pass($err) if $err; $files->insert($self->_meta($doc->{md5}) => $delay->begin); }, sub { shift; $self->$cb(shift, $self->_files_id) } ) if $cb; # Blocking $self->_chunk($bulk)->execute; $files->ensure_index({filename => 1}); $chunks->ensure_index(@index); my $md5 = $gridfs->db->command($command)->{md5}; $files->insert($self->_meta($md5)); return $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->next_tick(sub { $self->$cb('File already closed') }); } $self->{buffer} .= $chunk; $self->{len} += length $chunk; my $bulk = $self->gridfs->chunks->bulk->ordered(0); my $size = $self->chunk_size; $self->_chunk($bulk) while length $self->{buffer} >= $size; # Non-blocking return $bulk->execute(sub { shift; $self->$cb(shift) }) if $cb; # Blocking $bulk->execute; return $self; } sub _chunk { my ($self, $bulk) = @_; my $chunk = substr $self->{buffer}, 0, $self->chunk_size, ''; return $bulk unless length $chunk; my $n = $self->{n}++; return $bulk->insert( {files_id => $self->_files_id, n => $n, data => bson_bin($chunk)}); } sub _files_id { shift->{files_id} //= bson_oid } 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<261120> (255KB). =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-1.29/lib/Mango/Protocol.pm0000644000175000017500000001114012627662035014556 0ustar odcodcpackage Mango::Protocol; use Mojo::Base -base; use Mango::BSON qw(bson_decode bson_encode bson_length encode_cstring); # Opcodes use constant {REPLY => 1, QUERY => 2004, GET_MORE => 2005, KILL_CURSORS => 2007}; sub build_get_more { my ($self, $id, $name, $return, $cursor) = @_; # Zero and name my $msg = pack('l<', 0) . encode_cstring($name); # Number to return and cursor id $msg .= pack('l<', $return) . pack('q<', $cursor); # Header return _build_header($id, length($msg), GET_MORE) . $msg; } sub build_kill_cursors { my ($self, $id) = (shift, shift); # Zero and number of cursor ids my $msg = pack('l<', 0) . pack('l<', scalar @_); # Cursor ids $msg .= pack 'q<', $_ 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 = pack 'l<', unpack('V', $vec); # Name $msg .= encode_cstring $name; # Skip and number to return $msg .= pack('l<', $skip) . pack('l<', $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 command_error { my ($self, $doc) = @_; return $doc->{ok} ? undef : $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 = unpack 'l<', substr($msg, 0, 4, ''); my $to = unpack 'l<', substr($msg, 0, 4, ''); my $op = unpack 'l<', 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 = unpack 'q<', substr($msg, 0, 8, ''); # Starting from my $from = unpack 'l<', 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 write_error { my ($self, $doc) = @_; return undef unless my $errors = $doc->{writeErrors}; return join "\n", map {"Write error at index $_->{index}: $_->{errmsg}"} @$errors; } sub _build_header { my ($id, $length, $op) = @_; return join '', map { pack 'l<', $_ } $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->query(1, 'foo', {}, 0, 10, {}, {}); =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_get_more my $bytes = $protocol->build_get_more($id, $name, $return, $cursor); 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 command_error my $err = $protocol->command_error($doc); Check document 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. =head2 write_error my $err = $protocol->write_error($doc); Check document for write error. =head1 SEE ALSO L, L, L. =cut Mango-1.29/lib/Mango/Database.pm0000644000175000017500000001374012627662035014471 0ustar odcodcpackage 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 build_write_concern { my $mango = shift->mango; return { j => $mango->j ? \1 : \0, w => $mango->w, wtimeout => $mango->wtimeout }; } sub collection { my ($self, $name) = @_; return Mango::Collection->new(db => $self, name => $name); } sub collection_names { my $self = shift; my $cb = ref $_[-1] eq 'CODE' ? pop : undef; # Non-blocking return $self->list_collections(@_ => sub { my ($self, $err, $cursor) = @_; return $self->$cb($err, []) if $err; $cursor->all(sub { my ($cursor, $err, $docs) = @_; @$docs = map { $_->{name} } @$docs; $self->$cb($err, $docs); }); }) if $cb; # Blocking my $docs = $self->list_collections(@_)->all; @$docs = map { $_->{name} } @$docs; return $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 $mango = $self->mango; my $name = $self->name; my $protocol = $mango->protocol; return $mango->query( ("$name.\$cmd", {}, 0, -1, $command, {}) => sub { my ($collection, $err, $reply) = @_; my $doc = $reply->{docs}[0]; $err ||= $protocol->command_error($doc); $self->$cb($err, $doc); } ) if $cb; # Blocking my $doc = $mango->query("$name.\$cmd", {}, 0, -1, $command, {})->{docs}[0]; if (my $err = $protocol->command_error($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 list_collections { my $self = shift; my $cb = ref $_[-1] eq 'CODE' ? pop : undef; my $command = bson_doc(listCollections => 1, @_); # Non-blocking return $self->command($command => sub { my ($self, $err, $res) = @_; $res = $res->{cursor}; my $cursor = Mango::Cursor->new(collection => $self->collection, id => $res->{id}, ns => $res->{ns})->add_batch($res->{firstBatch}); $self->$cb($err, $cursor); }) if $cb; # Blocking my $cursor = $self->command($command)->{cursor}; return Mango::Cursor->new(collection => $self->collection, id => $cursor->{id}, ns => $cursor->{ns}) ->add_batch($cursor->{firstBatch}); } 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 build_write_concern my $concern = $db->build_write_concern; Build write concern based on l settings. =head2 collection my $collection = $db->collection('foo'); Build L object for collection. =head2 collection_names my $names = $db->collection_names; Names of all collections in this database. You can filter the results by using the same arguments as for C. 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; Build L object. =head2 list_collections # return a cursor for all collections my $cursor = $db->list_collections; # only collections which name matchs a regex my $cursor = $db->list_collections(filter => { name => qr{^prefix} }); # only capped collections my $cursor = $db->list_collections(filter => { 'options.capped' => 1 }); # only the first 10 collections my $cursor = $db->list_collections(cursor => { batchSize => 10 }); Returns a L of all collections in this database. Each collection is represented by a document containing at least the keys C and C. You can also append a callback to perform operation non-blocking. $db->list_collections(sub { my ($db, $err, $cursor) = @_; ... }); Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =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-1.29/LICENSE0000644000175000017500000002141312627662035011621 0ustar odcodc 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-1.29/Makefile.PL0000644000175000017500000000167312627662035012574 0ustar odcodcuse 5.010001; use strict; use warnings; use Config; use ExtUtils::MakeMaker; die "64-bit Perl or one built with -Duse64bitint 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 => 'Olivier Duclos ', LICENSE => 'artistic_2', META_MERGE => { requires => {perl => '5.010001'}, resources => { license => 'http://www.opensource.org/licenses/artistic-license-2.0', homepage => 'http://mojolicio.us', bugtracker => 'https://github.com/oliwer/mango/issues', repository => 'https://github.com/oliwer/mango.git', x_IRC => 'irc://irc.perl.org/#mojo' }, no_index => {directory => ['t']} }, PREREQ_PM => {Mojolicious => '5.40'}, test => {TESTS => 't/*.t t/*/*.t'} ); Mango-1.29/t/0000755000175000017500000000000012734553532011056 5ustar odcodcMango-1.29/t/collection.t0000644000175000017500000004245512641523122013375 0ustar odcodcuse 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 $doc1 = { foo => 'bar' }; my $doc2 = { foo => 'baz' }; my $oids = $collection->insert([$doc1, $doc2]); 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'; # Make sure the documents are not modified after insertion is $doc1->{_id}, undef, 'document not modified'; is $doc2->{_id}, undef, 'document not modified'; # 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'; # Rename the collection ok $collection = $collection->rename('renamed'), 'collection renamed'; $collection->rename('collection_test' => sub { my ($orig_collection, $err, $new_collection) = @_; $fail = $err; $result = $new_collection; Mojo::IOLoop->stop; }); Mojo::IOLoop->start; ok !$fail, 'no error'; is $result->name, 'collection_test', 'collection renamed non-blocking'; $collection = $result; # 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'; my $oid = bson_oid; is $collection->update($oid, {foo => 'bar'})->{n}, 0, 'no documents updated'; is $collection->update($oid, {foo => 'bar'}, {upsert => 1})->{n}, 1, 'one document updated'; is $collection->update($oid, {foo => 'works'})->{n}, 1, 'one document updated'; is $collection->find_one($oid)->{foo}, 'works', 'right value'; is $collection->remove($oid)->{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 $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->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->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 $cursor = $collection->aggregate( [{'$group' => {_id => undef, total => {'$sum' => '$more'}}}]); ok !$cursor->id, 'no cursor id'; is $cursor->next->{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, $cursor) = @_; $fail = $err; $result = $cursor; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; is $result->next->{total}, 6, 'right result'; is $collection->remove({more => {'$exists' => 1}})->{n}, 3, 'three documents removed'; # Explain aggregation $collection->insert({stuff => $_}) for 1 .. 30; $doc = $collection->aggregate([{'$match' => {stuff => {'$gt' => 0}}}], {explain => \1}); ok $doc->{stages}, 'right result'; 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) = @_; return $delay->pass($err) if $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($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($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($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->ensure_index({test => 1}, {unique => \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'}); ($fail, $result) = (); $delay = Mojo::IOLoop->delay( sub { my $delay = shift; $collection->ensure_index(({test => 1}, {unique => \1}) => $delay->begin); }, sub { my ($delay, $err) = @_; return $delay->pass($err) if $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) = @_; return $delay->pass($err) if $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 => []}); $out = $collection->map_reduce($map, $reduce, {out => 'collection_test_results'}); $collection->drop; my $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'; # Insert same document twice blocking $doc = bson_doc _id => bson_oid, foo => 'bar'; $collection->insert($doc); eval { $collection->insert($doc) }; like $@, qr/^Write error at index 0: .+/, 'right error'; $collection->drop; # Insert same document twice non-blocking $doc = bson_doc _id => bson_oid, foo => 'bar'; $collection->insert($doc); $fail = undef; $collection->insert( $doc => sub { my ($collection, $err) = @_; $fail = $err; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; like $fail, qr/^Write error at index 0: .+/, 'right error'; # Insert same document twice blocking (upsert) $doc = bson_doc _id => bson_oid, foo => 'bar'; $collection->insert($doc); eval { $collection->update({foo => 'baz'}, $doc, {upsert => 1}) }; like $@, qr/^Write error at index 0: .+/, 'right error'; $collection->drop; # Insert same document twice non-blocking (upsert) $doc = bson_doc _id => bson_oid, foo => 'bar'; $collection->insert($doc); $fail = undef; $collection->update( {foo => 'baz'} => $doc => {upsert => 1} => sub { my ($collection, $err) = @_; $fail = $err; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; like $fail, qr/^Write error at index 0: .+/, 'right error'; # Interrupted non-blocking remove my $id = Mojo::IOLoop->server((address => '127.0.0.1') => sub { $_[1]->close }); my $port = Mojo::IOLoop->acceptor($id)->handle->sockport; $mango = Mango->new("mongodb://localhost:$port"); ($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/timeout|Premature/, 'right error'; ok !$result->{n}, 'remove was not successful'; done_testing(); Mango-1.29/t/bulk.t0000644000175000017500000001256312627662035012207 0ustar odcodcuse 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_doc bson_oid); use Mojo::IOLoop; # Clean up before start my $mango = Mango->new($ENV{TEST_ONLINE}); my $collection = $mango->db->collection('bulk_test'); $collection->drop if $collection->options; # Nothing blocking my $results = $collection->bulk->execute; is $results->{nInserted}, 0, 'no inserts'; is $results->{nMatched}, 0, 'no matches'; is $results->{nModified}, 0, 'no modifications'; is $results->{nRemoved}, 0, 'no removals'; is $results->{nUpserted}, 0, 'no upserts'; is_deeply $results->{upserted}, [], 'no upserts'; is_deeply $results->{writeConcernErrors}, [], 'no write concern errors'; is_deeply $results->{writeErrors}, [], 'no write errors'; # Nothing non-blocking my ($fail, $result); $collection->bulk->execute( sub { my ($bulk, $err, $results) = @_; $fail = $err; $result = $results; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; is $result->{nInserted}, 0, 'no inserts'; is $result->{nMatched}, 0, 'no matches'; is $result->{nModified}, 0, 'no modifications'; is $result->{nRemoved}, 0, 'no removals'; is $result->{nUpserted}, 0, 'no upserts'; is_deeply $result->{upserted}, [], 'no upserts'; is_deeply $result->{writeConcernErrors}, [], 'no write concern errors'; is_deeply $result->{writeErrors}, [], 'no write errors'; # Mixed bulk operations blocking my $bulk = $collection->bulk; ok $bulk->ordered, 'ordered bulk operations'; $bulk->insert({foo => 'bar'}); $bulk->find({foo => 'bar'})->update_one({foo => 'baz'}); $bulk->find({foo => 'yada'})->upsert->update_one({foo => 'baz'}); $bulk->find({foo => 'baz'})->remove; $results = $bulk->execute; is $results->{nInserted}, 1, 'one insert'; is $results->{nMatched}, 1, 'one match'; is $results->{nModified}, 2, 'two modifications'; is $results->{nRemoved}, 2, 'two removals'; is $results->{nUpserted}, 1, 'one upsert'; ok $results->{upserted}[0], 'one upsert'; is_deeply $results->{writeConcernErrors}, [], 'no write concern errors'; is_deeply $results->{writeErrors}, [], 'no write errors'; # Mixed bulk operations non-blocking $bulk = $collection->bulk; $bulk->insert({foo => 'bar'}); $bulk->find({foo => 'bar'})->update_one({foo => 'baz'}); $bulk->find({foo => 'yada'})->upsert->update_one({foo => 'baz'}); $bulk->find({foo => 'baz'})->remove; ($fail, $result) = (); $bulk->execute( sub { my ($bulk, $err, $results) = @_; $fail = $err; $result = $results; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; ok !$fail, 'no error'; is $result->{nInserted}, 1, 'one insert'; is $result->{nMatched}, 1, 'one match'; is $result->{nModified}, 2, 'two modifications'; is $result->{nRemoved}, 2, 'two removals'; is $result->{nUpserted}, 1, 'one upsert'; ok $result->{upserted}[0], 'one upsert'; is_deeply $result->{writeConcernErrors}, [], 'no write concern errors'; is_deeply $result->{writeErrors}, [], 'no write errors'; # All operations $bulk = $collection->bulk; $bulk->insert({foo => 'a'})->insert({foo => 'b'})->insert({foo => 'c'}); $bulk->find({foo => {'$exists' => 1}})->update_one({foo => 'd'}); $results = $bulk->execute; is $results->{nInserted}, 3, 'three inserts'; is $results->{nModified}, 1, 'one modification'; $bulk = $collection->bulk; $bulk->find({foo => {'$exists' => 1}})->remove_one; $bulk->find({foo => {'$exists' => 1}})->update({'$set' => {foo => 'a'}}); $results = $bulk->execute; is $results->{nModified}, 2, 'two modifications'; is $results->{nRemoved}, 1, 'one removal'; $results = $collection->bulk->find->remove->execute; is $results->{nRemoved}, 2, 'two removals'; # Split up documents into multiple commands (many documents) is $mango->max_write_batch_size, 1000, 'right value'; $bulk = $collection->bulk; $bulk->insert({foo => $_}) for 1 .. 1001; $results = $bulk->execute; is $results->{nInserted}, 1001, 'over one thousand inserts'; # Split up documents into multiple commands (large documents) is $mango->max_bson_size, 16777216, 'right value'; my $large = 'x' x 5242880; $bulk = $collection->bulk; $bulk->insert({foo => $large}) for 1 .. 5; $results = $bulk->execute; is $results->{nInserted}, 5, 'five inserts'; # Insert the same document twice blocking (separated by update) my $doc = bson_doc _id => bson_oid, foo => 'bar'; $bulk = $collection->bulk->insert($doc)->find({foo => 'bar'}) ->update_one({'$set' => {foo => 'baz'}})->insert($doc); eval { $bulk->execute }; like $@, qr/^Write error at index 2: .+/, 'right error'; # Insert the same document twice non-blocking (separated by update) $doc = bson_doc _id => bson_oid, foo => 'bar'; $bulk = $collection->bulk->insert($doc)->find({foo => 'bar'}) ->update_one({'$set' => {foo => 'baz'}})->insert($doc); ($fail, $result) = (); $bulk->execute( sub { my ($bulk, $err, $results) = @_; $fail = $err; $result = $results; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; like $fail, qr/^Write error at index 2: .+/, 'right error'; is $result->{nInserted}, 1, 'one insert'; # Insert the same document three times blocking (unordered) $doc = bson_doc _id => bson_oid, foo => 'bar'; $bulk = $collection->bulk->insert($doc)->insert($doc)->insert($doc); eval { $bulk->ordered(0)->execute }; like $@, qr/Write error at index 1: .+/, 'right error'; like $@, qr/Write error at index 2: .+/, 'right error'; done_testing(); Mango-1.29/t/gridfs.t0000644000175000017500000002130512627662035012522 0ustar odcodcuse 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 $reader->md5, 'fc3ff98e8c6a0d3087d515c0473f8677', 'right checksum'; is_deeply $reader->metadata, {foo => 'bar'}, 'right structure'; is $reader->size, 12, 'right size'; is $reader->chunk_size, 261120, '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) = @_; return $delay->pass($err) if $err; $writer->write('llo ' => $delay->begin); }, sub { my ($delay, $err) = @_; return $delay->pass($err) if $err; $writer->write('w' => $delay->begin); $writer->write('orld!' => $delay->begin); }, sub { my ($delay, $err) = @_; return $delay->pass($err) if $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 $reader->md5, 'fc3ff98e8c6a0d3087d515c0473f8677', 'right checksum'; 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) = @_; return $delay->pass($err) if $err; $before = $names; $gridfs->delete($result => $delay->begin); }, sub { my ($delay, $err) = @_; return $delay->pass($err) if $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; is $gridfs->find_version('test.txt', -1), $one, 'right version'; my $two = $gridfs->writer->filename('test.txt')->write('Two')->close; is $gridfs->find_version('test.txt', -1), $two, 'right version'; is $gridfs->find_version('test.txt', -2), $one, 'right version'; is $gridfs->find_version('test.txt', -3), undef, 'no version'; is_deeply $gridfs->list, ['test.txt'], 'right files'; is $gridfs->find_version('test.txt', 0), $one, 'right version'; is $gridfs->find_version('test.txt', 1), $two, 'right version'; is $gridfs->find_version('test.txt', 2), 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', 2) => $delay->begin); $gridfs->find_version(('test.txt', 1) => $delay->begin); $gridfs->find_version(('test.txt', 0) => $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) = @_; if (my $err = $one_err || $two_err) { return $delay->pass($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 concurrent 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) = @_; if (my $err = $err1 || $err2) { return $delay->pass($err) } $reader1->slurp($delay->begin); $reader2->slurp($delay->begin); }, sub { my ($delay, $err1, $data1, $err2, $data2) = @_; $fail = $err1 || $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-1.29/t/connection.t0000644000175000017500000001437712627662035013416 0ustar odcodcuse 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; use Mojo::IOLoop::Server; # Defaults my $mango = Mango->new; is_deeply $mango->hosts, [['localhost']], 'right hosts'; is $mango->default_db, 'admin', 'right default database'; is $mango->inactivity_timeout, 0, 'right timeout value'; 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 $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 $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::Server->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) = @_; return $delay->pass($err) if $err; $created = $oid; $collection->find_one({foo => 'bar'} => $delay->begin); }, sub { my ($delay, $err, $doc) = @_; return $delay->pass($err) if $err; $doc->{foo} = 'yada'; $collection->update(({foo => 'bar'}, $doc) => $delay->begin); }, sub { my ($delay, $err, $doc) = @_; return $delay->pass($err) if $err; $updated = $doc; $collection->find_one($created => $delay->begin); }, sub { my ($delay, $err, $doc) = @_; return $delay->pass($err) if $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 Mojo::IOLoop->singleton->reactor->unsubscribe('error'); $fail = undef; Mojo::IOLoop->singleton->reactor->once( error => sub { $fail .= pop; Mojo::IOLoop->stop }); $collection->insert({foo => 'bar'} => sub { die 'Oops!' }); 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 concurrent operations $collection->insert({test => $_}) for 1 .. 3; is $mango->backlog, 0, 'no operations waiting'; my @results; $delay = Mojo::IOLoop->delay(sub { shift; @results = @_ }); $collection->find_one(({test => $_}, {_id => 0}) => $delay->begin) for 1 .. 3; is $mango->backlog, 3, 'three operations waiting'; is $collection->find_one({test => 1})->{test}, 1, 'right result'; $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::Server->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-1.29/t/protocol.t0000644000175000017500000001053712627662035013112 0ustar odcodcuse 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 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 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_query(1, 'foo', {}, 0, 10, {}, {}) . "\x00"; is $protocol->parse_reply(\$buffer), undef, 'nothing'; is $buffer, "\x00", 'message has been removed'; # Extract error messages from reply is $protocol->query_failure($query), '$or requires nonempty array', 'right query failure'; is $protocol->query_failure(undef), undef, 'no query failure'; is $protocol->query_failure($nonce), undef, 'no query failure'; # Extract error messages from documents my $unknown = {errmsg => 'no such cmd: whatever', 'bad cmd' => {whatever => 1}, ok => 0}; my $write = { n => 0, ok => 1, writeErrors => [ { code => 11000, errmsg => 'insertDocument :: caused by :: 11000 E11000 duplicate' . ' key error index: test.collection_test.$_id_ dup key: ' . '{ : ObjectId(\'53408aad5867b46961a50000\') }', index => 0 } ] }; is $protocol->command_error($unknown), 'no such cmd: whatever', 'right error'; is $protocol->command_error($write), undef, 'no error'; like $protocol->write_error($write), qr/^Write error at index 0: insertDocument/, 'right error'; is $protocol->write_error($unknown), undef, 'no error'; done_testing(); Mango-1.29/t/cursor.t0000644000175000017500000002514512627662035012567 0ustar odcodcuse 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'; # Check cursor defaults my $cursor = $collection->find(); is_deeply $cursor->query, {}, 'cursor query initialized'; is_deeply $cursor->fields, {}, 'cursor fields initialized'; is $cursor->new->fields, undef, 'undefined fields by default'; is $cursor->new->query, undef, 'undefined query by default'; # Fetch documents blocking $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'; $cursor = $collection->find({})->comment('Test!')->max_time_ms(500); is_deeply $cursor->build_query, {'$query' => {}, '$comment' => 'Test!', '$maxTimeMS' => 500}, 'right query'; $cursor = $collection->find({})->read_preference({mode => 'SECONDARY'}); is_deeply $cursor->build_query, {'$query' => {}, '$readPreference' => {mode => 'SECONDARY'}}, 'right query'; # Clone cursor $cursor = $collection->find({test => {'$exists' => 1}})->batch_size(2) ->comment('Test')->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})->max_time_ms(500)->tailable(1) ->await_data(1)->read_preference({mode => 'SECONDARY'})->clone; isnt $cursor, $clone, 'different objects'; ok !defined $clone->id, 'has no cursor id'; is $clone->batch_size, 2, 'right batch size'; is $clone->comment, 'Test', 'right comment'; 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->max_time_ms, 500, 'right max_time_ms value'; is_deeply $clone->read_preference, {mode => 'SECONDARY'}, 'right fields'; is $clone->tailable, 1, 'is tailable'; is $clone->await_data, 1, 'is awaiting data'; 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'; # Number of results to return is $collection->find->num_to_return, 0, 'right number of results'; $cursor = $collection->find; is $cursor->batch_size(5)->num_to_return, 5, 'right number of results'; $cursor = $collection->find; is $cursor->limit(5)->num_to_return, 5, 'right number of results'; $cursor = $collection->find; is $cursor->limit(-5)->num_to_return, -5, 'right number of results'; $cursor = $collection->find; is $cursor->limit(4)->batch_size(2)->num_to_return, 2, 'right number of results'; is $cursor->limit(2)->batch_size(4)->num_to_return, 2, 'right number of results'; is $cursor->limit(-4)->batch_size(2)->num_to_return, -4, 'right number of results'; is $cursor->limit(-2)->batch_size(4)->num_to_return, -2, 'right number of results'; # Explain blocking $cursor = $collection->find({test => 2}); $doc = $cursor->explain; is $doc->{executionStats}{nReturned}, 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->{executionStats}{nReturned}; 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) = @_; return $delay->pass($err) if $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) = @_; return $delay->pass($err) if $err; push @docs, $doc; $cursor->next($delay->begin); }, sub { my ($delay, $err, $doc) = @_; return $delay->pass($err) if $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) = @_; return $delay->pass($err) if $err; push @docs, $doc; $cursor->rewind($delay->begin); }, sub { my ($delay, $err) = @_; return $delay->pass($err) if $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'; is $collection->remove->{n}, 3, 'three documents removed'; # Try to restart aggregate cursor $collection->insert({stuff => $_}) for 1 .. 30; $cursor = $collection->aggregate([{'$match' => {stuff => {'$gt' => 0}}}], {cursor => {batchSize => 5}}); is $cursor->next->{stuff}, 1, 'right result'; ok $cursor->id, 'cursor has id'; $cursor->rewind; ok !$cursor->id, 'no cursor id'; eval { $cursor->next }; like $@, qr/Cursor cannot be restarted/, 'right error'; is $collection->remove->{n}, 30, 'thirty documents removed'; # 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)->await_data(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-1.29/t/pod_coverage.t0000644000175000017500000000042612627662035013702 0ustar odcodcuse 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(); Mango-1.29/t/auth/0000755000175000017500000000000012734553532012017 5ustar odcodcMango-1.29/t/auth/authenticate.t0000644000175000017500000000137612627662035014671 0ustar odcodcpackage main; use Mojo::Base -strict; use Test::More; use Mango; use Data::Dumper; plan skip_all => 'set TEST_ONLINE to enable this test' unless $ENV{TEST_ONLINE}; my (@ARGS, $called, $mango); { package Mango::Auth::Test; use Mojo::Base 'Mango::Auth'; sub _authenticate { @ARGS = @_; $called++; } } # blocking (@ARGS, $called) = (); $mango = Mango->new('mongodb://user:pass@127.0.0.1/test') ->_auth(Mango::Auth::Test->new()); eval { $mango->db->stats() }; is $called, 1, 'was called'; ok !$mango->{connections}{$ARGS[1]}->{nb}, 'blocking'; # nb (@ARGS, $called) = (); $mango->db->stats(sub { Mojo::IOLoop->stop }); eval { Mojo::IOLoop->start }; is $called, 1, 'was called'; ok $mango->{connections}{$ARGS[1]}->{nb}, 'not blocking'; done_testing; Mango-1.29/t/auth/auth.t0000644000175000017500000000151012627662035013142 0ustar odcodcpackage main; use Mojo::Base -strict; use Test::More; use Mango; use Data::Dumper; plan skip_all => 'set TEST_ONLINE to enable this test' unless $ENV{TEST_ONLINE}; { package Mango::Auth::MyTest; use Mojo::Base 'Mango::Auth'; } my $mango = Mango->new(); is $mango->_auth, undef, 'no auth'; $mango = Mango->new('mongodb://127.0.0.1'); is $mango->_auth, undef, 'no auth'; $mango = Mango->new('mongodb://127.0.0.1/mydb'); is $mango->_auth, undef, 'no auth'; my $auth = Mango::Auth::MyTest->new; is $mango->_auth($auth), $mango, 'returns self'; is $auth->mango, $mango, 'mango was installed'; # defaults $mango = Mango->new('mongodb://usr:pwd@127.0.0.1/db'); isa_ok $mango->_auth, 'Mango::Auth::SCRAM'; # ioc $mango = Mango->new('mongodb://SECRET:SECRET@127.0.0.1/db'); like Dumper($mango), qr /^((?!SECRET).)*$/s; done_testing; Mango-1.29/t/leaks/0000755000175000017500000000000012734553532012155 5ustar odcodcMango-1.29/t/leaks/auth.t0000644000175000017500000000177312627662035013313 0ustar odcodcpackage main; use Mojo::Base -strict; use Test::More; use Mango; plan skip_all => 'set TEST_ONLINE to enable this test' unless $ENV{TEST_ONLINE}; my (@DESTROYED, @CREATED); my $destroy = sub { push @DESTROYED, ref shift }; my $new = sub { push @CREATED, shift }; { package Mango::Auth::SCRAM; sub DESTROY { $destroy->(@_) } sub new { $new->(@_); shift->SUPER::new(@_) } package Mango::Auth::MyTest; use Mojo::Base 'Mango::Auth'; sub new { $new->(@_); shift->SUPER::new(@_) } sub DESTROY { $destroy->(@_) } package Mango::My; use Mojo::Base 'Mango'; sub new { $new->(@_); shift->SUPER::new(@_) } sub DESTROY { $destroy->(@_); shift->SUPER::DESTROY } } DEFAULT: { my $mango = Mango::My->new('mongodb://usr:pwd@127.0.0.1/db'); is $mango->_auth->mango, $mango; } CUSTOM: { my $auth = Mango::Auth::MyTest->new; my $mango = Mango::My->new->_auth($auth); is $mango->_auth->mango, $mango; } is @CREATED, 4; is_deeply [sort @DESTROYED], [sort @CREATED]; done_testing; Mango-1.29/t/pod.t0000644000175000017500000000037712627662035012034 0ustar odcodcuse 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-1.29/t/database.t0000644000175000017500000000657612641523162013016 0ustar odcodcuse 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'; # Write concern my $mango2 = Mango->new->w(2)->wtimeout(5000); my $concern = $mango2->db('test')->build_write_concern; is $concern->{w}, 2, 'right w value'; is $concern->{wtimeout}, 5000, 'right wtimeout value'; # 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'; # List collections my $collection = $db->collection('database_test'); $collection->insert({test => 1}); ok @{$db->list_collections->all} > 0, 'found collections'; is $db->list_collections(filter => { name => qr{base_test} })->all->[0]->{name}, 'database_test', 'found collection using filtering'; # non-blocking mode is tested implicitely by collection_names below # Get collection names blocking 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 $loop = $mango->ioloop; my $id = $loop->server((address => '127.0.0.1') => sub { $_[1]->close }); my $port = $loop->acceptor($id)->handle->sockport; $mango = Mango->new("mongodb://localhost:$port")->ioloop($loop); eval { $mango->db->command('getnonce') }; like $@, qr/Premature connection close/, 'right error'; $mango->ioloop->remove($id); # Interrupted non-blocking command $id = Mojo::IOLoop->server((address => '127.0.0.1') => sub { $_[1]->close }); $port = Mojo::IOLoop->acceptor($id)->handle->sockport; $mango = Mango->new("mongodb://localhost:$port"); $fail = undef; $mango->db->command( 'getnonce' => sub { my ($db, $err) = @_; $fail = $err; Mojo::IOLoop->stop; } ); Mojo::IOLoop->start; Mojo::IOLoop->remove($id); like $fail, qr/timeout|Premature/, 'right error'; done_testing(); Mango-1.29/t/bson.t0000644000175000017500000005201112703010042012157 0ustar odcodcpackage BSONTest; use Mojo::Base -base; has 'something' => sub { {} }; sub TO_JSON { shift->something } package BSONTest2; use Mojo::Base 'BSONTest'; sub TO_BSON { {something => shift->something} } package main; use Mojo::Base -strict; no warnings 'portable'; # Mango works on 64bits systems only use Test::More; use Mango::BSON ':bson'; use Mojo::ByteStream 'b'; use Mojo::JSON qw(encode_json decode_json); use Scalar::Util 'dualvar'; # 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'; is bson_time(1360626536748)->to_datetime, '2013-02-11T23:48:56.748Z', 'right format'; # 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'; # Check that string 'nan' is encoded correctly (and *not* as not-a-number # floating point) $bytes = "\x14\x00\x00\x00\x02\x68\x65\x6c\x6c\x6f\x00\x04\x00\x00\x00\x6e\x61" . "\x6e\x00\x00"; is bson_encode({hello => 'nan'}), $bytes, 'right string-nan encoding'; # Double inf roundtrip $bytes = "\x14\x00\x00\x00\x01\x68\x65\x6c\x6c\x6f\x00\x00\x00\x00\x00\x00\x00" . "\xf0\x7f\x00"; $doc = bson_decode($bytes); is_deeply $doc, {hello => 0+'iNf'}, 'right double inf document'; is bson_encode($doc), $bytes, 'successful double inf roundtrip'; # Check that string 'inf' is encoded correctly (and *not* as infinity # floating point) $bytes = "\x14\x00\x00\x00\x02\x68\x65\x6c\x6c\x6f\x00\x04\x00\x00\x00\x69\x6e" . "\x66\x00\x00"; is bson_encode({hello => 'inf'}), $bytes, 'right string-inf encoding'; # Double -inf roundtrip $bytes = "\x14\x00\x00\x00\x01\x68\x65\x6c\x6c\x6f\x00\x00\x00\x00\x00\x00\x00" . "\xf0\xff\x00"; $doc = bson_decode($bytes); is_deeply $doc, {hello => 0+'-iNf'}, 'right double -inf document'; is bson_encode($doc), $bytes, 'successful double -inf roundtrip'; # Check that string '-inf' is encoded correctly (and *not* as minus infinity # floating point) $bytes = "\x15\x00\x00\x00\x02\x68\x65\x6c\x6c\x6f\x00\x05\x00\x00\x00\x2d\x69\x6e" . "\x66\x00\x00"; is bson_encode({hello => '-inf'}), $bytes, 'right string-inf encoding'; # Check explicit double serializations $bytes = "\x10\x00\x00\x00\x01\x78\x00\x00\x00\x00\x00\x00\x00\x37\x40\x00"; is bson_encode({x => bson_double(23.0)}), $bytes, 'encode double to double'; is bson_encode({x => bson_double(23)}), $bytes, 'encode int to double'; is bson_encode({x => bson_double("23")}), $bytes, 'encode string to double'; # 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'; # Check explicit Int32 serializations $bytes = "\x0c\x00\x00\x00\x10\x78\x00\x33\x77\xaa\x55\x00"; is bson_encode({x => bson_int32(0x55aa7733)}), $bytes, 'encode int to Int32'; is bson_encode({x => bson_int32(1437234995)}), $bytes, 'encode int to Int32'; is bson_encode({x => bson_int32(1437234995.3)}), $bytes, 'encode float to Int32 (round down)'; is bson_encode({x => bson_int32("1437234995")}), $bytes, 'encode string to Int32'; is bson_encode({x => bson_int32(0x155aa7733)}), $bytes, 'encode Int64 to Int32 (truncate)'; $bytes = "\x0c\x00\x00\x00\x10\x78\x00\xfe\xff\xff\xff\x00"; is bson_encode({x => bson_int32(0xfffffffe)}), $bytes, 'encode large int to Int32'; is bson_encode({x => bson_int32(-2)}), $bytes, 'encode negative int to Int32'; # 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'; # Check explicit Int64 serializations $bytes = "\x10\x00\x00\x00\x12\x78\x00\x33\x77\xaa\x55\x00\x00\x00\x00\x00"; is bson_encode({x => bson_int64(0x55aa7733)}), $bytes, 'encode int to Int64'; is bson_encode({x => bson_int64(1437234995)}), $bytes, 'encode int to Int64'; is bson_encode({x => bson_int64(1437234995.3)}), $bytes, 'encode float to Int64 (round down)'; is bson_encode({x => bson_int64("1437234995")}), $bytes, 'encode string to Int64'; $bytes = "\x10\x00\x00\x00\x12\x78\x00\x33\x77\xaa\x55\x01\x00\x00\x00\x00"; is bson_encode({x => bson_int64(0x155aa7733)}), $bytes, 'encode int64 to Int64 (truncate)'; $bytes = "\x10\x00\x00\x00\x12\x78\x00\xfe\xff\xff\xff\xff\xff\xff\xff\x00"; is bson_encode({x => bson_int64(0xfffffffffffffffe)}), $bytes, 'encode large int to Int64'; is bson_encode({x => bson_int64(-2)}), $bytes, 'encode negative int to Int64'; # 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'; # Pre-encoded BSON document roundtrip my $raw = bson_raw bson_encode {bar => 'baz'}; is_deeply bson_decode(bson_encode $raw), {bar => 'baz'}, 'successful roundtrip'; is_deeply bson_decode(bson_encode {foo => $raw}), {foo => {bar => 'baz'}}, 'successful roundtrip'; is_deeply bson_decode(bson_encode {foo => [$raw]}), {foo => [{bar => 'baz'}]}, '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'; # Blessed reference with TO_BSON method $bytes = bson_encode({test => BSONTest2->new}); is_deeply bson_decode($bytes), {test => {something => {}}}, 'successful roundtrip'; $bytes = bson_encode( { test => BSONTest2->new( something => {just => 'works'}, else => {not => 'working'} ) } ); is_deeply bson_decode($bytes), {test => {something => {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 bson_encode({test => [$num, $str]}), "\x20\x00\x00\x00\x04\x74\x65\x73\x74" . "\x00\x15\x00\x00\x00\x10\x30\x00\x03\x00\x00\x00\x02\x31\x00\x02\x00\x00" . "\x00\x33\x00\x00\x00", 'upgraded number detected'; $num = 1.5; $str = "$num"; is bson_encode({test => [$num, $str]}), "\x26\x00\x00\x00\x04\x74\x65\x73\x74" . "\x00\x1b\x00\x00\x00\x01\x30\x00\x00\x00\x00\x00\x00\x00\xf8\x3f\x02\x31" . "\x00\x04\x00\x00\x00\x31\x2e\x35\x00\x00\x00", 'upgraded number detected'; $str = '0 but true'; $num = 1 + $str; is bson_encode({test => [$num, $str]}), "\x29\x00\x00\x00\x04\x74\x65\x73\x74\x00\x1e\x00\x00\x00\x10\x30\x00\x01" . "\x00\x00\x00\x02\x31\x00\x0b\x00\x00\x00\x30\x20\x62\x75\x74\x20\x74\x72" . "\x75\x65\x00\x00\x00", 'upgraded number detected'; # Upgraded string $str = "bar"; { no warnings 'numeric'; $num = 23 + $str } is bson_encode({test => [$num, $str]}), "\x26\x00\x00\x00\x04\x74\x65\x73\x74\x00\x1b\x00\x00\x00\x01\x30\x00\x00" . "\x00\x00\x00\x00\x00\x37\x40\x02\x31\x00\x04\x00\x00\x00\x62\x61\x72\x00" . "\x00\x00", 'upgraded string detected'; # dualvar my $dual = dualvar 23, 'twenty three'; is bson_encode({test => $dual}), "\x1c\x00\x00\x00\x02\x74\x65\x73\x74\x00\x0d\x00\x00\x00\x74\x77\x65\x6e" . "\x74\x79\x20\x74\x68\x72\x65\x65\x00\x00", 'dualvar stringified'; # Ensure numbers and strings are not upgraded my $mixed = {test => [3, 'three', '3', 0, "0"]}; $bson = "\x3d\x00\x00\x00\x04\x74\x65\x73\x74\x00\x32\x00\x00\x00\x10\x30\x00" . "\x03\x00\x00\x00\x02\x31\x00\x06\x00\x00\x00\x74\x68\x72\x65\x65\x00\x02" . "\x32\x00\x02\x00\x00\x00\x33\x00\x10\x33\x00\x00\x00\x00\x00\x02\x34\x00" . "\x02\x00\x00\x00\x30\x00\x00\x00"; is bson_encode($mixed), $bson, 'all have been detected correctly'; is bson_encode($mixed), $bson, 'all have been detected correctly again'; # "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 encode_json({time => bson_time(1360626536748)}), '{"time":1360626536748}', 'right JSON'; is encode_json({time => bson_time('1360626536748')}), '{"time":1360626536748}', 'right JSON'; # Binary to JSON is encode_json({bin => bson_bin('Hello World!')}), '{"bin":"SGVsbG8gV29ybGQh"}', 'right JSON'; # DBRef to JSON my $json = encode_json( {dbref => bson_dbref('test', bson_oid('525139d85867b45714020000'))} ); $json = decode_json($json); is $json->{dbref}{'$ref'}, 'test', 'dbref $ref in JSON'; is $json->{dbref}{'$id'}, '525139d85867b45714020000', 'dbref $id in 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-1.29/Changes0000644000175000017500000002534612734553251012116 0ustar odcodc1.29 2016-06-28 - Keep document's members order when doing an insert (thanks Stefan) - Improve Mango->new documentation to explain why you need to use a helper sub (#17) 1.28 2016-04-11 - Fix a BSON to JSON encoding test case failure due to changes in Mojolicious 6.58. (#16) 1.27 2016-02-29 - Fix a reconnection error where Mango was trying to use an old connection after a shutdown. Thanks to fortl. - Fix a small bug in Mango::Bulk where connection errors would be ignored resulting in a wrong error message. (#14) 1.26 2016-02-25 - Fix potential code injection when deserializing regex 1.25 2016-02-16 - Make Mango fork-safe again by fixing ObjectID generation which I broke in the last update. Thanks to Andrey Khozov. 1.24 2016-01-01 - Small optimization in ObjectID generation - Fix Collection::rename (bug #12 - thanks Isage) - Change 'insert' behavior to avoid modifying the original document during serialization. The documentation has also been updated. (#11) - Fix 2 tests which failed with newer versions of Mojolicious. 1.23 2015-11-12 - Fix a nasty bug where Mango would not finish to authenticate to the server before sending the first request, resulting in an authentication error. More details in bug #10 on Github. - Small documentation fix thanks to Mohammad S Anwar. 1.22 2015-11-06 - Fix test with BSON encoding of NaN with perl 5.23+ - Handle the deprecated BSON type 'Undefined' (very rare case) - Fix BSON types MinKey and MaxKey. Their value was switched. 1.21 2015-11-04 - Add new subs: bson_int32, bson_int64 and bson_double to force the type of a numeric value. This is useful when your database is used by strongly typed applications. - Randomize the ObjectID counter at startup (as required by the MongoDB specs) 1.20 2015-08-04 - Fix failing test case when Authen::SCRAM is not installed 1.19 2015-08-03 - Fix packaging issue: Auth::SCRAM was missing from v1.18 1.18 2015-06-04 - Added support for SCRAM-SHA-1 authentication using Authen::SCRAM (alexbyk) The old MONGODB-CR method has been removed. - Removed Mango::credentials - Fix potential DoS attack by properly checking the ObjectID format. Details here: http://sakurity.com/blog/2015/06/04/mongo_ruby_regexp.html - A few documentation changes 1.17 2015-03-23 - ACHTUNG! MongoDB 3.0+ is now requiered. Older versions are no longer supported. - Added Mango::Database::list_collections to query collections with a Mango::Cursor with optional filtering. - Mango::Database::collection_names also gains optional filtering. - Improved Mango::Collection::index_information to accept a maximum number of results, and to be faster (alexbyk). - Breaking change: Mango::Collection::options now returns the short name of the collection instead of the full_name (alexbyk). - Added Mango::Collection::rename. 1.16 2015-02-03 - Fix git repository in Makefile.PL 1.15 2014-10-01 - New Github repository: https://github.com/oliwer/mango - Mango::Cursor::Query attributes 'fields' and 'query' are now undefined by default. Thanks to alexbyk. 1.14 2014-09-22 - Fixed packaging bug. 1.13 2014-09-21 - Updated Makefile.PL for version 2 of the CPAN distribution metadata specification. 1.12 2014-09-12 - Fixed small connection management bug. 1.11 2014-09-11 - Fixed test that was depending on Mojolicious internals. 1.10 2014-09-06 - Added module Mango::Cursor::Query. 1.09 2014-09-01 - Improved Makefile.PL error message for 64-bit requirement. 1.08 2014-08-24 - Improved to_datetime method in Mango::BSON::Time to be able to handle higher precision times. 1.07 2014-08-23 - Fixed small JSON serialization bug in Mango::BSON::Time. 1.06 2014-08-22 - Added to_datetime method to Mango::BSON::Time. 1.05 2014-08-10 - Added read_preference attribute to Mango::Cursor. 1.04 2014-07-25 - Fixed connection leak. 1.03 2014-07-25 - Improved Mango to avoid secondary nodes. 1.02 2014-07-24 - Fixed version handling in Mango::GridFS. 1.01 2014-06-28 - Improved update method in Mango::Collection to accept object ids. (alexbyk) - Fixed small bug in Mango::Cursor where callbacks would sometimes get the wrong number of arguments. 1.0 2014-06-24 - Removed experimental status from distribution. 0.43 2014-06-15 - Improved remove method in Mango::Collection to accept object ids. 0.42 2014-06-04 - Added md5 method to Mango::GridFS::Readers. - Fixed bug in Mango::GridFS::Writer where files could get the wrong MD5 checksum. 0.41 2014-06-02 - Added await_data attribute to Mango::Cursor. 0.40 2014-05-31 - Added inactivity_timeout attribute to Mango. - Fixed Mojolicious 5.0 support. 0.39 2014-05-14 - Improved Mango::BSON performance. 0.38 2014-05-12 - Changed heuristics for number detection in Mango::BSON to better line up with user expectations. 0.37 2014-05-12 - Added support for performing blocking and non-blocking operations at the same time. 0.36 2014-05-05 - Added support for TO_BSON method to Mango::BSON. 0.35 2014-05-04 - Added num_to_return method to Mango::Cursor. - Fixed bug where Mango::Cursor would request too many documents. 0.34 2014-05-02 - Fixed bug where some Mango::Collection methods passed the wrong invocant to callbacks. (alexbyk) 0.33 2014-04-30 - Improved error message for old MongoDB versions. 0.32 2014-04-24 - Added to_bytes method to Mango::BSON::ObjectID. - Improved Mango::BSON performance. 0.31 2014-04-23 - Improved support for pre-encoded BSON documents. 0.30 2014-04-08 - Removed delete, insert and update methods from Mango. - Removed build_delete, build_insert and build_update methods from Mango::Protocol. - Removed decode_int32, decode_int64, encode_int32 and encode_int64 methods from Mango::BSON. - Renamed timeout attribute in Mango::Cursor to max_time_ms. - Added support for MongoDB 2.6 wire protocol, MongoDB 2.4 is no longer supported. - Added support for bulk operations. - Added max_bson_size and max_write_batch_size attributes to Mango. - Added build_write_concern method to Mango::Database. - Added bulk method to Mango::Collection. - Added write_error method to Mango::Protocol. - Added bson_raw function to Mango::BSON. - Improved aggregate method in Mango::Collection to return cursors by default. - Improved aggregate method in Mango::Collection with explain support. - Improved connection management with wire protocol version check. - Improved Mango::BSON performance. - Improved command performance. - Improved storage efficiency of Mango::GridFS::Writer by lowering the default chunk size to 255KB. 0.24 2014-02-27 - Added comment and timeout attributes to Mango::Cursor. 0.23 2014-01-22 - Fixed a few small operator overloading bugs. 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-1.29/META.yml0000664000175000017500000000142112734553532012064 0ustar odcodc--- abstract: 'Pure-Perl non-blocking I/O MongoDB driver' author: - 'Olivier Duclos ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150001' 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: '5.40' perl: '5.010001' resources: IRC: irc://irc.perl.org/#mojo bugtracker: https://github.com/oliwer/mango/issues homepage: http://mojolicio.us license: http://www.opensource.org/licenses/artistic-license-2.0 repository: https://github.com/oliwer/mango.git version: '1.29' Mango-1.29/CONTRIBUTING.md0000644000175000017500000000025612627662035013047 0ustar odcodcPlease 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-1.29/META.json0000664000175000017500000000244712734553532012245 0ustar odcodc{ "abstract" : "Pure-Perl non-blocking I/O MongoDB driver", "author" : [ "Olivier Duclos " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150001", "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" : "5.40", "perl" : "5.010001" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/oliwer/mango/issues" }, "homepage" : "http://mojolicio.us", "license" : [ "http://www.opensource.org/licenses/artistic-license-2.0" ], "repository" : { "url" : "https://github.com/oliwer/mango.git" }, "x_IRC" : "irc://irc.perl.org/#mojo" }, "version" : "1.29" } Mango-1.29/README.md0000644000175000017500000000227712627662035012102 0ustar odcodc Pure-Perl non-blocking I/O MongoDB driver, optimized for use with the [Mojolicious](http://mojolicio.us) real-time web framework. ```perl 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 $c = shift; my $collection = $c->mango->db->collection('visitors'); my $ip = $c->tx->remote_address; # Store information about current visitor $collection->insert({when => bson_time, from => $ip} => sub { my ($collection, $err, $oid) = @_; return $c->reply->exception($err) if $err; # Retrieve information about previous visitors $collection->find->sort({when => -1})->fields({_id => 0})->all(sub { my ($collection, $err, $docs) = @_; return $c->reply->exception($err) if $err; # And show it to current visitor $c->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.