Commit | Line | Data |
7f9a3f70 |
1 | use warnings; |
2 | use strict; |
3 | |
4 | use Test::More; |
5 | use Test::Warn; |
6 | |
7 | use DBIx::Class::_Util 'quote_sub'; |
8 | |
e85eb407 |
9 | ### Test for strictures leakage |
7f9a3f70 |
10 | my $q = do { |
11 | no strict 'vars'; |
e85eb407 |
12 | quote_sub 'DBICTest::QSUB::nostrict' |
13 | => '$x = $x . "buh"; $x += 42'; |
7f9a3f70 |
14 | }; |
15 | |
16 | warnings_exist { |
17 | is $q->(), 42, 'Expected result after uninit and string/num conversion' |
18 | } [ |
19 | qr/Use of uninitialized value/i, |
20 | qr/isn't numeric in addition/, |
21 | ], 'Expected warnings, strict did not leak inside the qsub' |
22 | or do { |
23 | require B::Deparse; |
24 | diag( B::Deparse->new->coderef2text( Sub::Quote::unquote_sub($q) ) ) |
25 | } |
26 | ; |
27 | |
e85eb407 |
28 | my $no_nothing_q = sub { |
7f9a3f70 |
29 | no strict; |
30 | no warnings; |
e85eb407 |
31 | quote_sub 'DBICTest::QSUB::nowarn', <<'EOC'; |
c480ff4a |
32 | BEGIN { warn "-->${^WARNING_BITS}<--\n" }; |
7f9a3f70 |
33 | my $n = "Test::Warn::warnings_exist"; |
34 | warn "-->@{[ *{$n}{CODE} ]}<--\n"; |
7f9a3f70 |
35 | EOC |
36 | }; |
37 | |
38 | my $we_cref = Test::Warn->can('warnings_exist'); |
39 | |
e85eb407 |
40 | warnings_exist { $no_nothing_q->()->() } [ |
c480ff4a |
41 | qr/^\-\-\>\0+\<\-\-$/m, |
7f9a3f70 |
42 | qr/^\Q-->$we_cref<--\E$/m, |
7f9a3f70 |
43 | ], 'Expected warnings, strict did not leak inside the qsub' |
44 | or do { |
45 | require B::Deparse; |
46 | diag( B::Deparse->new->coderef2text( Sub::Quote::unquote_sub($no_nothing_q) ) ) |
47 | } |
48 | ; |
49 | |
140bcb6a |
50 | ### Test the upcoming attributes support |
51 | require DBIx::Class; |
52 | @DBICTest::QSUB::ISA = 'DBIx::Class'; |
53 | |
54 | my $var = \42; |
55 | my $s = quote_sub( |
56 | 'DBICTest::QSUB::attr', |
57 | '$v', |
58 | { '$v' => $var }, |
59 | { |
60 | # use grandfathered 'ResultSet' attribute for starters |
61 | attributes => [qw( ResultSet )], |
62 | package => 'DBICTest::QSUB', |
63 | }, |
64 | ); |
65 | |
66 | is $s, \&DBICTest::QSUB::attr, 'Same cref installed'; |
67 | |
68 | is DBICTest::QSUB::attr(), 42, 'Sub properly installed and callable'; |
69 | |
70 | is_deeply |
71 | [ attributes::get( $s ) ], |
72 | [ 'ResultSet' ], |
73 | 'Attribute installed', |
74 | unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 |
75 | |
7f9a3f70 |
76 | done_testing; |