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