Commit | Line | Data |
83eef562 |
1 | use DBIx::Class::Optional::Dependencies -skip_all_without => 'cdbicompat'; |
2 | |
525035fb |
3 | use strict; |
4a233f30 |
4 | use warnings; |
83eef562 |
5 | |
525035fb |
6 | use Test::More; |
83eef562 |
7 | use Test::Exception; |
525035fb |
8 | |
50891152 |
9 | use lib 't/cdbi/testlib'; |
525035fb |
10 | use Film; |
11 | |
12 | sub valid_rating { |
9a440a19 |
13 | my $value = shift; |
14 | my $ok = grep $value eq $_, qw/U Uc PG 12 15 18/; |
15 | return $ok; |
525035fb |
16 | } |
17 | |
18 | Film->add_constraint('valid rating', Rating => \&valid_rating); |
19 | |
20 | my %info = ( |
9a440a19 |
21 | Title => 'La Double Vie De Veronique', |
22 | Director => 'Kryzstof Kieslowski', |
23 | Rating => '18', |
525035fb |
24 | ); |
25 | |
26 | { |
9a440a19 |
27 | local $info{Title} = "nonsense"; |
28 | local $info{Rating} = 19; |
29 | eval { Film->create({%info}) }; |
30 | ok $@, $@; |
31 | ok !Film->retrieve($info{Title}), "No film created"; |
32 | is(Film->retrieve_all, 0, "So no films"); |
525035fb |
33 | } |
34 | |
35 | ok(my $ver = Film->create({%info}), "Can create with valid rating"); |
36 | is $ver->Rating, 18, "Rating 18"; |
37 | |
38 | ok $ver->Rating(12), "Change to 12"; |
39 | ok $ver->update, "And update"; |
40 | is $ver->Rating, 12, "Rating now 12"; |
41 | |
42 | eval { |
9a440a19 |
43 | $ver->Rating(13); |
44 | $ver->update; |
525035fb |
45 | }; |
46 | ok $@, $@; |
47 | is $ver->Rating, 12, "Rating still 12"; |
48 | ok $ver->delete, "Delete"; |
49 | |
50 | # this threw an infinite loop in old versions |
51 | Film->add_constraint('valid director', Director => sub { 1 }); |
52 | my $fred = Film->create({ Rating => '12' }); |
53 | |
54 | # this test is a bit problematical because we don't supply a primary key |
55 | # to the create() and the table doesn't use auto_increment or a sequence. |
56 | ok $fred, "Got fred"; |
57 | |
58 | { |
9a440a19 |
59 | ok +Film->constrain_column(rating => [qw/U PG 12 15 19/]), |
60 | "constraint_column"; |
61 | my $narrower = eval { Film->create({ Rating => 'Uc' }) }; |
62 | like $@, qr/fails.*constraint/, "Fails listref constraint"; |
63 | my $ok = eval { Film->create({ Rating => 'U' }) }; |
64 | is $@, '', "Can create with rating U"; |
83eef562 |
65 | { |
66 | local $TODO = "No column objects"; |
67 | lives_ok { Film->find_column('rating')->is_constrained || die } "Rating is constrained"; |
68 | lives_ok { Film->find_column('director')->is_constrained || die } "Director is not"; |
525035fb |
69 | } |
70 | } |
71 | |
72 | { |
9a440a19 |
73 | ok +Film->constrain_column(title => qr/The/), "constraint_column"; |
74 | my $inferno = eval { Film->create({ Title => 'Towering Infero' }) }; |
75 | like $@, qr/fails.*constraint/, "Can't create towering inferno"; |
76 | my $the_inferno = eval { Film->create({ Title => 'The Towering Infero' }) }; |
77 | is $@, '', "But can create THE towering inferno"; |
525035fb |
78 | } |
79 | |
80 | { |
81 | |
9a440a19 |
82 | sub Film::_constrain_by_untaint { |
83 | my ($class, $col, $string, $type) = @_; |
84 | $class->add_constraint( |
85 | untaint => $col => sub { |
86 | my ($value, $self, $column_name, $changing) = @_; |
87 | $value eq "today" ? $changing->{$column_name} = "2001-03-03" : 0; |
88 | } |
89 | ); |
90 | } |
91 | eval { Film->constrain_column(codirector => Untaint => 'date') }; |
92 | is $@, '', 'Can constrain with untaint'; |
157270d0 |
93 | |
9a440a19 |
94 | my $freeaa = |
95 | eval { Film->create({ title => "The Freaa", codirector => 'today' }) }; |
157270d0 |
96 | is $@, '', "Can create codirector"; |
97 | is $freeaa && $freeaa->codirector, '2001-03-03', "Set the codirector"; |
525035fb |
98 | } |
99 | |
d9bd5195 |
100 | done_testing; |
101 | |
525035fb |
102 | __DATA__ |
103 | |
104 | use CGI::Untaint; |
105 | |
106 | sub _constrain_by_untaint { |
9a440a19 |
107 | my ($class, $col, $string, $type) = @_; |
108 | $class->add_constraint(untaint => $col => sub { |
109 | my ($value, $self, $column_name, $changing) = @_; |
110 | my $h = CGI::Untaint->new({ %$changing }); |
111 | return unless my $val = $h->extract("-as_$type" => $column_name); |
112 | $changing->{$column_name} = $val; |
113 | return 1; |
114 | }); |
525035fb |
115 | } |