Commit | Line | Data |
fcec2383 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
047248f9 |
6 | use Test::More; |
7 | |
8 | BEGIN { |
f808a99e |
9 | eval "use DBM::Deep 1.0003;"; |
d03bd989 |
10 | plan skip_all => "DBM::Deep 1.0003 (or greater) is required for this test" if $@; |
a60285b3 |
11 | eval "use DateTime::Format::MySQL;"; |
d03bd989 |
12 | plan skip_all => "DateTime::Format::MySQL is required for this test" if $@; |
13 | plan tests => 88; |
047248f9 |
14 | } |
15 | |
fcec2383 |
16 | use Test::Exception; |
17 | |
18 | BEGIN { |
0f051d58 |
19 | # in case there are leftovers |
20 | unlink('newswriter.db') if -e 'newswriter.db'; |
21 | } |
22 | |
23 | END { |
24 | unlink('newswriter.db') if -e 'newswriter.db'; |
25 | } |
26 | |
7ff56534 |
27 | |
fcec2383 |
28 | |
b68e5362 |
29 | =pod |
30 | |
d03bd989 |
31 | This example creates a very basic Object Database which |
32 | links in the instances created with a backend store |
b68e5362 |
33 | (a DBM::Deep hash). It is by no means to be taken seriously |
d03bd989 |
34 | as a real-world ODB, but is a proof of concept of the flexibility |
35 | of the ::Instance protocol. |
b68e5362 |
36 | |
37 | =cut |
38 | |
fcec2383 |
39 | BEGIN { |
d03bd989 |
40 | |
8479d544 |
41 | package Moose::POOP::Meta::Instance; |
fcec2383 |
42 | use Moose; |
d03bd989 |
43 | |
fcec2383 |
44 | use DBM::Deep; |
d03bd989 |
45 | |
fcec2383 |
46 | extends 'Moose::Meta::Instance'; |
d03bd989 |
47 | |
fcec2383 |
48 | { |
b68e5362 |
49 | my %INSTANCE_COUNTERS; |
fcec2383 |
50 | |
51 | my $db = DBM::Deep->new({ |
047248f9 |
52 | file => "newswriter.db", |
53 | autobless => 1, |
54 | locking => 1, |
fcec2383 |
55 | }); |
d03bd989 |
56 | |
fcec2383 |
57 | sub _reload_db { |
b68e5362 |
58 | #use Data::Dumper; |
d03bd989 |
59 | #warn Dumper $db; |
047248f9 |
60 | $db = undef; |
fcec2383 |
61 | $db = DBM::Deep->new({ |
047248f9 |
62 | file => "newswriter.db", |
63 | autobless => 1, |
64 | locking => 1, |
d03bd989 |
65 | }); |
fcec2383 |
66 | } |
d03bd989 |
67 | |
fcec2383 |
68 | sub create_instance { |
b68e5362 |
69 | my $self = shift; |
5cf3dbcf |
70 | my $class = $self->associated_metaclass->name; |
b68e5362 |
71 | my $oid = ++$INSTANCE_COUNTERS{$class}; |
d03bd989 |
72 | |
b68e5362 |
73 | $db->{$class}->[($oid - 1)] = {}; |
d03bd989 |
74 | |
6a4a7c31 |
75 | bless { |
b68e5362 |
76 | oid => $oid, |
77 | instance => $db->{$class}->[($oid - 1)] |
6a4a7c31 |
78 | }, $class; |
fcec2383 |
79 | } |
d03bd989 |
80 | |
fcec2383 |
81 | sub find_instance { |
82 | my ($self, $oid) = @_; |
d03bd989 |
83 | my $instance = $db->{$self->associated_metaclass->name}->[($oid - 1)]; |
6a4a7c31 |
84 | |
85 | bless { |
b68e5362 |
86 | oid => $oid, |
6a4a7c31 |
87 | instance => $instance, |
88 | }, $self->associated_metaclass->name; |
d03bd989 |
89 | } |
90 | |
b68e5362 |
91 | sub clone_instance { |
92 | my ($self, $instance) = @_; |
d03bd989 |
93 | |
b68e5362 |
94 | my $class = $self->{meta}->name; |
95 | my $oid = ++$INSTANCE_COUNTERS{$class}; |
d03bd989 |
96 | |
b68e5362 |
97 | my $clone = tied($instance)->clone; |
d03bd989 |
98 | |
6a4a7c31 |
99 | bless { |
fcec2383 |
100 | oid => $oid, |
6a4a7c31 |
101 | instance => $clone, |
102 | }, $class; |
d03bd989 |
103 | } |
fcec2383 |
104 | } |
d03bd989 |
105 | |
fcec2383 |
106 | sub get_instance_oid { |
107 | my ($self, $instance) = @_; |
108 | $instance->{oid}; |
109 | } |
110 | |
fcec2383 |
111 | sub get_slot_value { |
112 | my ($self, $instance, $slot_name) = @_; |
113 | return $instance->{instance}->{$slot_name}; |
114 | } |
115 | |
116 | sub set_slot_value { |
117 | my ($self, $instance, $slot_name, $value) = @_; |
118 | $instance->{instance}->{$slot_name} = $value; |
119 | } |
120 | |
121 | sub is_slot_initialized { |
122 | my ($self, $instance, $slot_name, $value) = @_; |
123 | exists $instance->{instance}->{$slot_name} ? 1 : 0; |
124 | } |
125 | |
126 | sub weaken_slot_value { |
e67a0fca |
127 | confess "Not sure how well DBM::Deep plays with weak refs, Rob says 'Write a test'"; |
d03bd989 |
128 | } |
129 | |
fcec2383 |
130 | sub inline_slot_access { |
131 | my ($self, $instance, $slot_name) = @_; |
132 | sprintf "%s->{instance}->{%s}", $instance, $slot_name; |
133 | } |
d03bd989 |
134 | |
8479d544 |
135 | package Moose::POOP::Meta::Class; |
d03bd989 |
136 | use Moose; |
137 | |
138 | extends 'Moose::Meta::Class'; |
139 | |
b2df9268 |
140 | override '_construct_instance' => sub { |
d7af0635 |
141 | my $class = shift; |
142 | my $params = @_ == 1 ? $_[0] : {@_}; |
d03bd989 |
143 | return $class->get_meta_instance->find_instance($params->{oid}) |
d7af0635 |
144 | if $params->{oid}; |
fcec2383 |
145 | super(); |
146 | }; |
fcec2383 |
147 | |
8479d544 |
148 | } |
d03bd989 |
149 | { |
8479d544 |
150 | package Moose::POOP::Object; |
8479d544 |
151 | use metaclass 'Moose::POOP::Meta::Class' => ( |
5cf3dbcf |
152 | instance_metaclass => 'Moose::POOP::Meta::Instance' |
d03bd989 |
153 | ); |
fcec2383 |
154 | use Moose; |
d03bd989 |
155 | |
fcec2383 |
156 | sub oid { |
157 | my $self = shift; |
158 | $self->meta |
159 | ->get_meta_instance |
160 | ->get_instance_oid($self); |
161 | } |
8479d544 |
162 | |
163 | } |
d03bd989 |
164 | { |
fcec2383 |
165 | package Newswriter::Author; |
fcec2383 |
166 | use Moose; |
d03bd989 |
167 | |
8479d544 |
168 | extends 'Moose::POOP::Object'; |
d03bd989 |
169 | |
fcec2383 |
170 | has 'first_name' => (is => 'rw', isa => 'Str'); |
d03bd989 |
171 | has 'last_name' => (is => 'rw', isa => 'Str'); |
172 | |
173 | package Newswriter::Article; |
fcec2383 |
174 | use Moose; |
d03bd989 |
175 | use Moose::Util::TypeConstraints; |
176 | |
fcec2383 |
177 | use DateTime::Format::MySQL; |
d03bd989 |
178 | |
179 | extends 'Moose::POOP::Object'; |
fcec2383 |
180 | |
181 | subtype 'Headline' |
182 | => as 'Str' |
183 | => where { length($_) < 100 }; |
d03bd989 |
184 | |
fcec2383 |
185 | subtype 'Summary' |
186 | => as 'Str' |
187 | => where { length($_) < 255 }; |
d03bd989 |
188 | |
fcec2383 |
189 | subtype 'DateTimeFormatString' |
190 | => as 'Str' |
191 | => where { DateTime::Format::MySQL->parse_datetime($_) }; |
d03bd989 |
192 | |
fcec2383 |
193 | enum 'Status' => qw(draft posted pending archive); |
d03bd989 |
194 | |
fcec2383 |
195 | has 'headline' => (is => 'rw', isa => 'Headline'); |
d03bd989 |
196 | has 'summary' => (is => 'rw', isa => 'Summary'); |
197 | has 'article' => (is => 'rw', isa => 'Str'); |
198 | |
fcec2383 |
199 | has 'start_date' => (is => 'rw', isa => 'DateTimeFormatString'); |
d03bd989 |
200 | has 'end_date' => (is => 'rw', isa => 'DateTimeFormatString'); |
201 | |
202 | has 'author' => (is => 'rw', isa => 'Newswriter::Author'); |
203 | |
fcec2383 |
204 | has 'status' => (is => 'rw', isa => 'Status'); |
d03bd989 |
205 | |
fcec2383 |
206 | around 'start_date', 'end_date' => sub { |
207 | my $c = shift; |
208 | my $self = shift; |
d03bd989 |
209 | $c->($self, DateTime::Format::MySQL->format_datetime($_[0])) if @_; |
b68e5362 |
210 | DateTime::Format::MySQL->parse_datetime($c->($self) || return undef); |
d03bd989 |
211 | }; |
fcec2383 |
212 | } |
213 | |
214 | { # check the meta stuff first |
8479d544 |
215 | isa_ok(Moose::POOP::Object->meta, 'Moose::POOP::Meta::Class'); |
d03bd989 |
216 | isa_ok(Moose::POOP::Object->meta, 'Moose::Meta::Class'); |
217 | isa_ok(Moose::POOP::Object->meta, 'Class::MOP::Class'); |
218 | |
219 | is(Moose::POOP::Object->meta->instance_metaclass, |
220 | 'Moose::POOP::Meta::Instance', |
1808c2da |
221 | 'got the right instance metaclass name'); |
d03bd989 |
222 | |
223 | isa_ok(Moose::POOP::Object->meta->get_meta_instance, 'Moose::POOP::Meta::Instance'); |
224 | |
8479d544 |
225 | my $base = Moose::POOP::Object->new; |
d03bd989 |
226 | isa_ok($base, 'Moose::POOP::Object'); |
227 | isa_ok($base, 'Moose::Object'); |
228 | |
8479d544 |
229 | isa_ok($base->meta, 'Moose::POOP::Meta::Class'); |
d03bd989 |
230 | isa_ok($base->meta, 'Moose::Meta::Class'); |
231 | isa_ok($base->meta, 'Class::MOP::Class'); |
232 | |
233 | is($base->meta->instance_metaclass, |
234 | 'Moose::POOP::Meta::Instance', |
1808c2da |
235 | 'got the right instance metaclass name'); |
d03bd989 |
236 | |
237 | isa_ok($base->meta->get_meta_instance, 'Moose::POOP::Meta::Instance'); |
fcec2383 |
238 | } |
239 | |
240 | my $article_oid; |
241 | my $article_ref; |
242 | { |
243 | my $article; |
244 | lives_ok { |
245 | $article = Newswriter::Article->new( |
246 | headline => 'Home Office Redecorated', |
247 | summary => 'The home office was recently redecorated to match the new company colors', |
248 | article => '...', |
d03bd989 |
249 | |
fcec2383 |
250 | author => Newswriter::Author->new( |
251 | first_name => 'Truman', |
252 | last_name => 'Capote' |
253 | ), |
d03bd989 |
254 | |
fcec2383 |
255 | status => 'pending' |
256 | ); |
1808c2da |
257 | } 'created my article successfully'; |
fcec2383 |
258 | isa_ok($article, 'Newswriter::Article'); |
d03bd989 |
259 | isa_ok($article, 'Moose::POOP::Object'); |
260 | |
fcec2383 |
261 | lives_ok { |
262 | $article->start_date(DateTime->new(year => 2006, month => 6, day => 10)); |
263 | $article->end_date(DateTime->new(year => 2006, month => 6, day => 17)); |
1808c2da |
264 | } 'add the article date-time stuff'; |
d03bd989 |
265 | |
fcec2383 |
266 | ## check some meta stuff |
d03bd989 |
267 | |
8479d544 |
268 | isa_ok($article->meta, 'Moose::POOP::Meta::Class'); |
d03bd989 |
269 | isa_ok($article->meta, 'Moose::Meta::Class'); |
270 | isa_ok($article->meta, 'Class::MOP::Class'); |
271 | |
272 | is($article->meta->instance_metaclass, |
273 | 'Moose::POOP::Meta::Instance', |
1808c2da |
274 | 'got the right instance metaclass name'); |
d03bd989 |
275 | |
276 | isa_ok($article->meta->get_meta_instance, 'Moose::POOP::Meta::Instance'); |
277 | |
1808c2da |
278 | ok($article->oid, 'got a oid for the article'); |
fcec2383 |
279 | |
280 | $article_oid = $article->oid; |
281 | $article_ref = "$article"; |
282 | |
283 | is($article->headline, |
284 | 'Home Office Redecorated', |
1808c2da |
285 | 'got the right headline'); |
fcec2383 |
286 | is($article->summary, |
287 | 'The home office was recently redecorated to match the new company colors', |
1808c2da |
288 | 'got the right summary'); |
289 | is($article->article, '...', 'got the right article'); |
d03bd989 |
290 | |
fcec2383 |
291 | isa_ok($article->start_date, 'DateTime'); |
292 | isa_ok($article->end_date, 'DateTime'); |
293 | |
294 | isa_ok($article->author, 'Newswriter::Author'); |
1808c2da |
295 | is($article->author->first_name, 'Truman', 'got the right author first name'); |
296 | is($article->author->last_name, 'Capote', 'got the right author last name'); |
fcec2383 |
297 | |
1808c2da |
298 | is($article->status, 'pending', 'got the right status'); |
fcec2383 |
299 | } |
300 | |
8479d544 |
301 | Moose::POOP::Meta::Instance->_reload_db(); |
fcec2383 |
302 | |
b68e5362 |
303 | my $article2_oid; |
304 | my $article2_ref; |
fcec2383 |
305 | { |
b68e5362 |
306 | my $article2; |
307 | lives_ok { |
308 | $article2 = Newswriter::Article->new( |
309 | headline => 'Company wins Lottery', |
310 | summary => 'An email was received today that informed the company we have won the lottery', |
311 | article => 'WoW', |
d03bd989 |
312 | |
b68e5362 |
313 | author => Newswriter::Author->new( |
314 | first_name => 'Katie', |
315 | last_name => 'Couric' |
316 | ), |
d03bd989 |
317 | |
b68e5362 |
318 | status => 'posted' |
319 | ); |
1808c2da |
320 | } 'created my article successfully'; |
b68e5362 |
321 | isa_ok($article2, 'Newswriter::Article'); |
8479d544 |
322 | isa_ok($article2, 'Moose::POOP::Object'); |
d03bd989 |
323 | |
b68e5362 |
324 | $article2_oid = $article2->oid; |
325 | $article2_ref = "$article2"; |
d03bd989 |
326 | |
b68e5362 |
327 | is($article2->headline, |
328 | 'Company wins Lottery', |
1808c2da |
329 | 'got the right headline'); |
b68e5362 |
330 | is($article2->summary, |
331 | 'An email was received today that informed the company we have won the lottery', |
1808c2da |
332 | 'got the right summary'); |
333 | is($article2->article, 'WoW', 'got the right article'); |
d03bd989 |
334 | |
1808c2da |
335 | ok(!$article2->start_date, 'these two dates are unassigned'); |
336 | ok(!$article2->end_date, 'these two dates are unassigned'); |
b68e5362 |
337 | |
338 | isa_ok($article2->author, 'Newswriter::Author'); |
1808c2da |
339 | is($article2->author->first_name, 'Katie', 'got the right author first name'); |
340 | is($article2->author->last_name, 'Couric', 'got the right author last name'); |
b68e5362 |
341 | |
1808c2da |
342 | is($article2->status, 'posted', 'got the right status'); |
d03bd989 |
343 | |
b68e5362 |
344 | ## orig-article |
d03bd989 |
345 | |
fcec2383 |
346 | my $article; |
347 | lives_ok { |
348 | $article = Newswriter::Article->new(oid => $article_oid); |
1808c2da |
349 | } '(re)-created my article successfully'; |
fcec2383 |
350 | isa_ok($article, 'Newswriter::Article'); |
d03bd989 |
351 | isa_ok($article, 'Moose::POOP::Object'); |
352 | |
1808c2da |
353 | is($article->oid, $article_oid, 'got a oid for the article'); |
354 | isnt($article_ref, "$article", 'got a new article instance'); |
fcec2383 |
355 | |
356 | is($article->headline, |
357 | 'Home Office Redecorated', |
1808c2da |
358 | 'got the right headline'); |
fcec2383 |
359 | is($article->summary, |
360 | 'The home office was recently redecorated to match the new company colors', |
1808c2da |
361 | 'got the right summary'); |
362 | is($article->article, '...', 'got the right article'); |
d03bd989 |
363 | |
fcec2383 |
364 | isa_ok($article->start_date, 'DateTime'); |
365 | isa_ok($article->end_date, 'DateTime'); |
366 | |
367 | isa_ok($article->author, 'Newswriter::Author'); |
1808c2da |
368 | is($article->author->first_name, 'Truman', 'got the right author first name'); |
369 | is($article->author->last_name, 'Capote', 'got the right author last name'); |
d03bd989 |
370 | |
fcec2383 |
371 | lives_ok { |
372 | $article->author->first_name('Dan'); |
d03bd989 |
373 | $article->author->last_name('Rather'); |
1808c2da |
374 | } 'changed the value ok'; |
d03bd989 |
375 | |
1808c2da |
376 | is($article->author->first_name, 'Dan', 'got the changed author first name'); |
377 | is($article->author->last_name, 'Rather', 'got the changed author last name'); |
fcec2383 |
378 | |
1808c2da |
379 | is($article->status, 'pending', 'got the right status'); |
fcec2383 |
380 | } |
381 | |
8479d544 |
382 | Moose::POOP::Meta::Instance->_reload_db(); |
fcec2383 |
383 | |
384 | { |
385 | my $article; |
386 | lives_ok { |
387 | $article = Newswriter::Article->new(oid => $article_oid); |
1808c2da |
388 | } '(re)-created my article successfully'; |
fcec2383 |
389 | isa_ok($article, 'Newswriter::Article'); |
d03bd989 |
390 | isa_ok($article, 'Moose::POOP::Object'); |
391 | |
1808c2da |
392 | is($article->oid, $article_oid, 'got a oid for the article'); |
393 | isnt($article_ref, "$article", 'got a new article instance'); |
fcec2383 |
394 | |
395 | is($article->headline, |
396 | 'Home Office Redecorated', |
1808c2da |
397 | 'got the right headline'); |
fcec2383 |
398 | is($article->summary, |
399 | 'The home office was recently redecorated to match the new company colors', |
1808c2da |
400 | 'got the right summary'); |
401 | is($article->article, '...', 'got the right article'); |
d03bd989 |
402 | |
fcec2383 |
403 | isa_ok($article->start_date, 'DateTime'); |
404 | isa_ok($article->end_date, 'DateTime'); |
405 | |
406 | isa_ok($article->author, 'Newswriter::Author'); |
1808c2da |
407 | is($article->author->first_name, 'Dan', 'got the changed author first name'); |
408 | is($article->author->last_name, 'Rather', 'got the changed author last name'); |
fcec2383 |
409 | |
1808c2da |
410 | is($article->status, 'pending', 'got the right status'); |
d03bd989 |
411 | |
b68e5362 |
412 | my $article2; |
413 | lives_ok { |
414 | $article2 = Newswriter::Article->new(oid => $article2_oid); |
1808c2da |
415 | } '(re)-created my article successfully'; |
b68e5362 |
416 | isa_ok($article2, 'Newswriter::Article'); |
d03bd989 |
417 | isa_ok($article2, 'Moose::POOP::Object'); |
418 | |
1808c2da |
419 | is($article2->oid, $article2_oid, 'got a oid for the article'); |
420 | isnt($article2_ref, "$article2", 'got a new article instance'); |
b68e5362 |
421 | |
422 | is($article2->headline, |
423 | 'Company wins Lottery', |
1808c2da |
424 | 'got the right headline'); |
b68e5362 |
425 | is($article2->summary, |
426 | 'An email was received today that informed the company we have won the lottery', |
1808c2da |
427 | 'got the right summary'); |
428 | is($article2->article, 'WoW', 'got the right article'); |
d03bd989 |
429 | |
1808c2da |
430 | ok(!$article2->start_date, 'these two dates are unassigned'); |
431 | ok(!$article2->end_date, 'these two dates are unassigned'); |
b68e5362 |
432 | |
433 | isa_ok($article2->author, 'Newswriter::Author'); |
1808c2da |
434 | is($article2->author->first_name, 'Katie', 'got the right author first name'); |
435 | is($article2->author->last_name, 'Couric', 'got the right author last name'); |
b68e5362 |
436 | |
1808c2da |
437 | is($article2->status, 'posted', 'got the right status'); |
d03bd989 |
438 | |
fcec2383 |
439 | } |
440 | |