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