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