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