File Coverage

blib/lib/Mandel/Document.pm
Criterion Covered Total %
statement 96 151 63.5
branch 36 64 56.2
condition 7 14 50.0
subroutine 23 36 63.8
pod 13 13 100.0
total 175 278 62.9


line stmt bran cond sub pod time code
1             package Mandel::Document;
2 15     15   844049 use Mojo::Base 'Mojo::Base';
  15         773583  
  15         138  
3 15     15   10704 use Mojo::JSON::Pointer;
  15         9427  
  15         124  
4 15     15   575 use Mojo::Util 'monkey_patch';
  15         32  
  15         1082  
5 15     15   3365 use Mandel::Model;
  15         48  
  15         159  
6 15     15   4055 use Mango::BSON ':bson';
  15         285476  
  15         3320  
7 15     15   134 use Scalar::Util 'looks_like_number';
  15         37  
  15         845  
8 15     15   95 use Carp 'confess';
  15         29  
  15         1104  
9 15 50   15   152 use constant DEBUG => $ENV{MANDEL_CURSOR_DEBUG} ? eval 'require Data::Dumper;1' : 0;
  15         36  
  15         37736  
10              
11             my $POINTER = Mojo::JSON::Pointer->new;
12              
13             sub id {
14 11     11 1 1632 my $self = shift;
15 11         43 my $raw = $self->data;
16              
17 11 100       144 if (@_) {
    100          
18 3         10 $self->dirty->{_id} = 1;
19 3 100       16 $raw->{_id} = ref $_[0] ? $_[0] : bson_oid $_[0];
20 3         59 return $self;
21             }
22             elsif ($raw->{_id}) {
23 6         56 return $raw->{_id};
24             }
25             else {
26 2         18 $self->dirty->{_id} = 1;
27 2         13 return $raw->{_id} = bson_oid;
28             }
29             }
30              
31             has connection => sub { confess "connection required in constructor" };
32             has model => sub { confess "model required in constructor" };
33             has dirty => sub { +{} };
34             has in_storage => 0;
35              
36             has _storage_collection => sub {
37             my $self = shift;
38             $self->connection->_storage_collection($self->model->collection_name);
39             };
40              
41             has data => sub { shift->_build_data }; # raw mongodb document data
42              
43 8     8   96 sub _build_data { +{} }
44              
45             sub new {
46 14     14 1 3946 my $self = shift->SUPER::new(@_);
47 14 100       178 $self->id(delete $self->{id}) if $self->{id};
48 14         80 $self;
49             }
50              
51 1     1 1 909 sub initialize {shift}
52              
53             sub contains {
54 3     3 1 1172 my $self = shift;
55 3         9 $POINTER->data($self->data)->contains(@_);
56             }
57              
58             sub fresh {
59 0     0 1 0 $_[0]->{fresh} = 1;
60 0         0 $_[0];
61             }
62              
63             sub get {
64 2     2 1 1160 my $self = shift;
65 2         8 $POINTER->data($self->data)->get(@_);
66             }
67              
68             sub is_changed {
69 2 100   2 1 13 return 0 unless $_[0]->{dirty};
70 1 50       3 return 0 unless keys %{$_[0]->{dirty}};
  1         6  
71 1         4 return 1;
72             }
73              
74             sub patch {
75 0     0 1 0 my ($self, $changes, $cb) = @_;
76 0         0 my $data = $self->data;
77              
78 0 0       0 if ($changes) {
79 0         0 @$data{keys %$changes} = values %$changes;
80             }
81              
82 0         0 $data = {%$data};
83 0         0 delete $data->{_id}; # Mod on _id not allowed
84              
85             $self->_storage_collection->update(
86             {_id => $self->id},
87             {'$set' => $data},
88             {upsert => bson_true},
89             $cb
90             ? (
91             sub {
92 0 0   0   0 $self->_mark_stored_clean unless $_[1];
93 0         0 $self->$cb($_[1]);
94             }
95             )
96 0 0       0 : (),
97             );
98              
99 0 0       0 $self->_mark_stored_clean unless $cb;
100 0         0 $self;
101             }
102              
103             sub remove {
104 0     0 1 0 my ($self, $cb) = @_;
105 0         0 my $c = $self->_storage_collection;
106 0         0 my @args = ({_id => $self->id}, {single => 1});
107              
108 0         0 warn "[$self\::remove] @{[$self->id]}\n" if DEBUG;
109              
110 0 0       0 if ($cb) {
111             $c->remove(
112             @args,
113             sub {
114 0     0   0 my ($collection, $err, $doc) = @_;
115 0 0       0 $self->_mark_removed_dirty unless $err;
116 0         0 $self->$cb($err);
117             }
118 0         0 );
119             }
120             else {
121 0         0 $c->remove(@args);
122 0         0 $self->_mark_removed_dirty;
123             }
124              
125 0         0 return $self;
126             }
127              
128             sub _mark_removed_dirty {
129 0     0   0 my $self = shift;
130 0         0 $self->dirty->{$_} = 1 for keys %{$self->data};
  0         0  
131 0         0 $self->in_storage(0);
132             }
133              
134             sub save {
135 0     0 1 0 my ($self, $cb) = @_;
136              
137 0 0 0     0 if (!$self->is_changed and $self->in_storage) {
138 0 0       0 $self->$cb('') if $cb;
139 0         0 return $self;
140             }
141              
142 0         0 $self->id; # make sure we have an ObjectID
143              
144 0         0 warn "[$self\::save] ", Data::Dumper->new([$self->data])->Indent(1)->Sortkeys(1)->Terse(1)->Dump if DEBUG;
145 0         0 my $c = $self->_storage_collection;
146              
147 0 0       0 if ($cb) {
148             $c->save(
149             $self->data,
150             sub {
151 0     0   0 my ($collection, $err, $doc) = @_;
152 0 0       0 $self->_mark_stored_clean unless $err;
153 0         0 $self->$cb($err);
154             }
155 0         0 );
156             }
157             else {
158 0         0 $c->save($self->data);
159 0         0 $self->_mark_stored_clean;
160             }
161              
162 0         0 return $self;
163             }
164              
165             sub _mark_stored_clean {
166 0     0   0 my $self = shift;
167 0         0 delete $self->{dirty};
168 0         0 $self->in_storage(1);
169             }
170              
171             sub set {
172 8     8 1 3260 my ($self, $pointer, $val) = @_;
173 8         21 my $raw = $self->data;
174 8         40 my (@path, $field);
175              
176 8 50       52 return $self unless $pointer =~ s!^/!!;
177 8         34 @path = split '/', $pointer;
178 8         16 $field = $path[0];
179              
180 8         19 while (@path) {
181 26         42 my $p = shift @path;
182 26         45 my $type = ref $raw;
183 26 100       78 my $want = looks_like_number $p ? 'INDEX' : 'KEY';
184              
185 26 100       137 if ($type eq 'HASH') {
    100          
186 16 100       32 if (@path) {
187 13 50 66     50 $raw = $raw->{$p} ||= looks_like_number $path[0] ? [] : {};
188             }
189             else {
190 3         12 $raw->{$p} = $val;
191             }
192             }
193             elsif ($type eq 'ARRAY') {
194 8 100       24 if ($want ne 'INDEX') {
    100          
195 1         245 confess "Cannot set $want in $type for /$pointer ($p)";
196             }
197             elsif (@path) {
198 5 50 66     28 $raw = $raw->[$p] ||= looks_like_number $path[0] ? [] : {};
199             }
200             else {
201 2         9 $raw->[$p] = $val;
202             }
203             }
204             else {
205 2         222 confess "Cannot set $want in SCALAR for /$pointer ($p)";
206             }
207             }
208              
209 5 50       20 $self->dirty->{$field} = 1 if defined $field;
210 5         35 $self;
211             }
212              
213             sub import {
214 13     13   555 my $class = shift;
215 13 100       59 my %args = @_ == 1 ? (name => shift) : @_;
216 13         93 my $caller = caller;
217 13         103 my $model = Mandel::Model->new(document_class => $caller, %args);
218 13         116 my $base_class = 'Mandel::Document';
219              
220 13         31 for (qw(name extends)) {
221 26 100 100     128 if ($args{$_} and $args{$_} =~ /::/) {
222 1         4 $base_class = delete $args{$_};
223             }
224             }
225 13 100       45 if (!$args{name}) {
226 11         87 $args{name} = Mojo::Util::decamelize(($caller =~ /(\w+)$/)[0]);
227 11         257 $model->name($args{name});
228             }
229              
230 13     0   218 monkey_patch $caller, belongs_to => sub { $model->relationship(belongs_to => @_)->monkey_patch };
  0     0   0  
231 13     12   266 monkey_patch $caller, field => sub { $model->field(shift, {@_}) };
  12         4870  
232 13     12   227 monkey_patch $caller, has_many => sub { $model->relationship(has_many => @_)->monkey_patch };
  0         0  
233 13     1   204 monkey_patch $caller, has_one => sub { $model->relationship(has_one => @_)->monkey_patch };
  0         0  
234 13     0   249 monkey_patch $caller, list_of => sub { $model->relationship(list_of => @_)->monkey_patch };
  0         0  
235 13     12   298 monkey_patch $caller, model => sub {$model};
  12         8762  
236              
237 13         223 @_ = ($class, $base_class);
238 13         66 goto &Mojo::Base::import;
239             }
240              
241 1     13 1 600 sub TO_JSON { shift->data }
242              
243             sub validate_fields {
244 5     10 1 9 my $self = shift;
245 5 100       19 if (ref $self->{data} eq 'HASH') {
246 4         9 for (grep { $self->can($_) } keys %{ $self->{data} }) {
  4         29  
  4         12  
247 1         44 $self->$_($self->{data}{$_});
248             }
249             }
250 4         34 return $self;
251             }
252              
253             sub _cache {
254 0     0     my $self = shift;
255 0   0       my $cache = $self->{cache} ||= {};
256              
257 0 0         return $cache->{$_[0]} if @_ == 1; # get
258 0           return $cache->{$_[0]} = $_[1]; # set
259             }
260              
261             1;
262              
263             =encoding utf8
264              
265             =head1 NAME
266              
267             Mandel::Document - A single MongoDB document with logic
268              
269             =head1 SYNOPSIS
270              
271             Extend a class with C instead of L:
272              
273             package MyModel::Person;
274             use Mandel::Document "MyDocument::Class";
275              
276             Specify a default collection name, instead of the
277             L. L will think you meant a base
278             class, if this argument contains "::".
279              
280             package MyModel::Person;
281             use Mandel::Document "some_collection_name";
282             use Types::Standard 'Str';
283              
284             field "foo";
285              
286             field "foo" => (
287             isa => Str,
288             builder => sub {
289             my $self = shift;
290             return "default value";
291             },
292             );
293              
294              
295             Spell out the options with a list:
296              
297             package MyModel::Person;
298              
299             use Mandel::Document (
300             extends => "My::Document::Class",
301             collection_name => "some_collection_name",
302             collection_class => "My::Custom::Collection",
303             );
304              
305             =head1 DESCRIPTION
306              
307             L is a simplistic model layer using the L module to interact
308             with a MongoDB backend. The L class defines the overall model,
309             including high level interaction. Individual results, called Types inherit
310             from L.
311              
312             An object of this class gets automatically serialized by L.
313             See L and L for details.
314              
315             Example:
316              
317             use Mojolicious::Lite;
318             # ...
319             get '/some/resource' => sub {
320             my $c = shift;
321             # find some document...
322             $c->render(json => $mandel_doc_object);
323             };
324              
325             =head1 ATTRIBUTES
326              
327             L inherits all attributes from L and implements the
328             following new ones.
329              
330             =head2 id
331              
332             $object_id = $self->id;
333             $self = $self->id("507f1f77bcf86cd799439011");
334             $self = $self->id(Mango::BSON::ObjectID->new);
335              
336             Returns the L object for this document.
337             Will create one if it does not already exist.
338              
339             This can field can also be set.
340              
341             =head2 data
342              
343             $hash = $self->data;
344             $self = $self->data($hash);
345              
346             Holds the raw mongodb document. It is possible to define default values for
347             this attribute by defining L for the
348             fields.
349              
350             =head2 in_storage
351              
352             Boolean true if this document has been fetched from storage or L
353             to storage.
354              
355             =head2 connection
356              
357             An instance of L. This is required.
358              
359             =head2 model
360              
361             Returns a L object. This object is a class variable and
362             therefor shared between all instances.
363              
364             =head2 dirty
365              
366             This attribute holds a hash-ref where the keys are name of fields that has
367             been updated or otherwise not stored in database.
368              
369             TODO: Define what the values should hold. Timestamp? A counter for how
370             many times the field has been updated before saved..?
371              
372             =head1 METHODS
373              
374             L inherits all of the methods from L and
375             implements the following new ones.
376              
377             =head2 new
378              
379             Constructs a new object.
380              
381             =head2 initialize
382              
383             A no-op placeholder useful for initialization. See L.
384              
385             =head2 contains
386              
387             $bool = $self->contains('/json/2/pointer');
388              
389             Use L to check if a value exists inside the raw
390             mongodb document.
391              
392             =head2 fresh
393              
394             $self = $self->fresh;
395              
396             Calling this method will force the next relationship call to return fresh
397             data from database instead of cached. Example:
398              
399             $self->fresh->cats(sub {
400             my($self, $err, $cats) = @_;
401             });
402              
403             =head2 get
404              
405             $any = $self->get('/json/2/pointer');
406              
407             Use L to retrieve a value inside the raw mongodb
408             document.
409              
410             =head2 is_changed
411              
412             Returns true if L contains any field names.
413              
414             =head2 patch
415              
416             $self = $self->patch(\%changes, sub { my($self, $err) = @_ });
417             $self = $self->patch(\%changes);
418              
419             This method will insert/update a partial document. This is useful if C
420             does not contain a complete document.
421              
422             It will also insert the document if a document with L does not already
423             exist.
424              
425             =head2 remove
426              
427             $self = $self->remove(sub { my($self, $err) = @_; });
428             $self = $self->remove;
429              
430             Will remove this object from the L and set mark
431             all fields as L.
432              
433             =head2 save
434              
435             $self = $self->save(sub { my($self, $err) = @_; });
436             $self = $self->save;
437              
438             This method stores the raw data in the database and collection. It clear
439             the L attribute.
440              
441             NOTE: This method will call the callback (with $err set to empty string)
442             immediately unless L is true and L is false.
443              
444             =head2 set
445              
446             $self = $self->set('/json/2/pointer', $val);
447              
448             Use a JSON pointer to set data in the raw mongodb document. This method will
449             die if the pointer points to non-compatible data.
450              
451             =head2 import
452              
453             See L.
454              
455             =head2 TO_JSON
456              
457             Alias for L.
458              
459             This method allow the document to get automatically serialized by
460             L.
461              
462             =head2 validate_fields
463              
464             $self = $self->validate_fields;
465              
466             This method can be used to validate the content of the fields of a document
467             againt the types defined in the model. It can be called after a document has
468             been loaded from MongoDB, e.g. via L. It can be
469             useful if the data in MongoDB might have been altered by something else after
470             it was stored there.
471              
472             =head1 SEE ALSO
473              
474             L, L, L
475              
476             =head1 AUTHOR
477              
478             Jan Henning Thorsen - C
479              
480             =cut