t/cdbi-t/24-meta_info.t

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use Test::More tests => 12;
   5 use Test::Warn;
   6
   7 package Temp::DBI;
   8 use base qw(DBIx::Class::CDBICompat);
   9 Temp::DBI->columns(All => qw(id date));
  10 Temp::DBI->has_a( date => 'Time::Piece', inflate => sub {
  11         Time::Piece->strptime(shift, "%Y-%m-%d")
  12 });
  13
  14
  15 package Temp::Person;
  16 use base 'Temp::DBI';
  17 Temp::Person->table('people');
  18 Temp::Person->columns(Info => qw(name pet));
  19 Temp::Person->has_a( pet => 'Temp::Pet' );
  20
  21 package Temp::Pet;
  22 use base 'Temp::DBI';
  23 Temp::Pet->table('pets');
  24 Temp::Pet->columns(Info => qw(name));
  25 Temp::Pet->has_many(owners => 'Temp::Person');
  26
  27 package main;
  28
  29 {
  30     my $pn_meta = Temp::Person->meta_info('has_a');
  31     is_deeply [sort keys %$pn_meta], [qw/date pet/], "Person has Date and Pet";
  32 }
  33
  34 {
  35     my $pt_meta = Temp::Pet->meta_info;
  36     is_deeply [keys %{$pt_meta->{has_a}}], [qw/date/], "Pet has Date";
  37     is_deeply [keys %{$pt_meta->{has_many}}], [qw/owners/], "And owners";
  38 }
  39
  40 {
  41     my $pet = Temp::Person->meta_info( has_a => 'pet' );
  42     is $pet->class,         'Temp::Person';
  43     is $pet->foreign_class, 'Temp::Pet';
  44     is $pet->accessor,      'pet';
  45     is $pet->name,          'has_a';
  46 }
  47
  48 {
  49     my $owners = Temp::Pet->meta_info( has_many => 'owners' );
  50     warning_like {
  51         local $TODO = 'args is unlikely to ever work';
  52
  53         is_deeply $owners->args, {
  54             foreign_key     => 'pet',
  55             mapping         => [],
  56             order_by        => undef
  57         };
  58     } qr/^\Qargs() is unlikely to ever work/;
  59 }
  60
  61 {
  62     my $date = Temp::Pet->meta_info( has_a => 'date' );
  63     is $date->class,            'Temp::DBI';
  64     is $date->foreign_class,    'Time::Piece';
  65     is $date->accessor,         'date';
  66 }