t/202_example_Moose_POOP.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7
   8 BEGIN {
   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 $@;
  11     plan tests => 89;
  12 }
  13
  14 use Test::Exception;
  15
  16 BEGIN {
  17     use_ok('Moose');
  18 }
  19
  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
  30 BEGIN {
  31
  32     package Moose::POOP::Meta::Instance;
  33     use Moose;
  34
  35     use DBM::Deep;
  36
  37     extends 'Moose::Meta::Instance';
  38
  39     {
  40         my %INSTANCE_COUNTERS;
  41
  42         my $db = DBM::Deep->new({
  43             file      => "newswriter.db",
  44             autobless => 1,
  45             locking   => 1,
  46         });
  47
  48         sub _reload_db {
  49             #use Data::Dumper;
  50             #warn Dumper $db;
  51             $db = undef;
  52             $db = DBM::Deep->new({
  53                 file      => "newswriter.db",
  54                 autobless => 1,
  55                 locking   => 1,
  56             });
  57         }
  58
  59         sub create_instance {
  60             my $self  = shift;
  61             my $class = $self->{meta}->name;
  62             my $oid   = ++$INSTANCE_COUNTERS{$class};
  63
  64             $db->{$class}->[($oid - 1)] = {};
  65
  66             $self->bless_instance_structure({
  67                 oid      => $oid,
  68                 instance => $db->{$class}->[($oid - 1)]
  69             });
  70         }
  71
  72         sub find_instance {
  73             my ($self, $oid) = @_;
  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;
  88
  89             $self->bless_instance_structure({
  90                 oid      => $oid,
  91                 instance => $clone
  92             });
  93         }
  94     }
  95
  96     sub get_instance_oid {
  97         my ($self, $instance) = @_;
  98         $instance->{oid};
  99     }
 100
 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
 125     package Moose::POOP::Meta::Class;
 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     };
 136
 137 }
 138 {
 139     package Moose::POOP::Object;
 140     use metaclass 'Moose::POOP::Meta::Class' => (
 141         ':instance_metaclass' => 'Moose::POOP::Meta::Instance'
 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     }
 151
 152 }
 153 {
 154     package Newswriter::Author;
 155     use Moose;
 156
 157     extends 'Moose::POOP::Object';
 158
 159     has 'first_name' => (is => 'rw', isa => 'Str');
 160     has 'last_name'  => (is => 'rw', isa => 'Str');
 161
 162     package Newswriter::Article;
 163     use Moose;
 164     use Moose::Util::TypeConstraints;
 165
 166     use DateTime::Format::MySQL;
 167
 168     extends 'Moose::POOP::Object';
 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 @_;
 199         DateTime::Format::MySQL->parse_datetime($c->($self) || return undef);
 200     };
 201 }
 202
 203 { # check the meta stuff first
 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');
 207
 208     is(Moose::POOP::Object->meta->instance_metaclass,
 209       'Moose::POOP::Meta::Instance',
 210       '... got the right instance metaclass name');
 211
 212     isa_ok(Moose::POOP::Object->meta->get_meta_instance, 'Moose::POOP::Meta::Instance');
 213
 214     my $base = Moose::POOP::Object->new;
 215     isa_ok($base, 'Moose::POOP::Object');
 216     isa_ok($base, 'Moose::Object');
 217
 218     isa_ok($base->meta, 'Moose::POOP::Meta::Class');
 219     isa_ok($base->meta, 'Moose::Meta::Class');
 220     isa_ok($base->meta, 'Class::MOP::Class');
 221
 222     is($base->meta->instance_metaclass,
 223       'Moose::POOP::Meta::Instance',
 224       '... got the right instance metaclass name');
 225
 226     isa_ok($base->meta->get_meta_instance, 'Moose::POOP::Meta::Instance');
 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');
 248     isa_ok($article, 'Moose::POOP::Object');
 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
 257     isa_ok($article->meta, 'Moose::POOP::Meta::Class');
 258     isa_ok($article->meta, 'Moose::Meta::Class');
 259     isa_ok($article->meta, 'Class::MOP::Class');
 260
 261     is($article->meta->instance_metaclass,
 262       'Moose::POOP::Meta::Instance',
 263       '... got the right instance metaclass name');
 264
 265     isa_ok($article->meta->get_meta_instance, 'Moose::POOP::Meta::Instance');
 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
 290 Moose::POOP::Meta::Instance->_reload_db();
 291
 292 my $article2_oid;
 293 my $article2_ref;
 294 {
 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');
 311     isa_ok($article2, 'Moose::POOP::Object');
 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
 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');
 340     isa_ok($article, 'Moose::POOP::Object');
 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
 371 Moose::POOP::Meta::Instance->_reload_db();
 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');
 379     isa_ok($article, 'Moose::POOP::Object');
 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');
 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');
 406     isa_ok($article2, 'Moose::POOP::Object');
 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
 428 }
 429
 430 unlink('newswriter.db') if -e 'newswriter.db';