better type check for mssql+ado binary null strip
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Componentised.pm
1 package # hide from PAUSE
2     DBIx::Class::Componentised;
3
4 use strict;
5 use warnings;
6
7 use base 'Class::C3::Componentised';
8 use mro 'c3';
9
10 use DBIx::Class::Carp '^DBIx::Class|^Class::C3::Componentised';
11
12 # this warns of subtle bugs introduced by UTF8Columns hacky handling of store_column
13 # if and only if it is placed before something overriding store_column
14 sub inject_base {
15   my $class = shift;
16   my ($target, @complist) = @_;
17
18   # we already did load the component
19   my $keep_checking = ! (
20     $target->isa ('DBIx::Class::UTF8Columns')
21       ||
22     $target->isa ('DBIx::Class::ForceUTF8')
23   );
24
25   my @target_isa;
26
27   while ($keep_checking && @complist) {
28
29     @target_isa = do { no strict 'refs'; @{"$target\::ISA"} }
30       unless @target_isa;
31
32     my $comp = pop @complist;
33
34     # warn here on use of either component, as we have no access to ForceUTF8,
35     # the author does not respond, and the Catalyst wiki used to recommend it
36     for (qw/DBIx::Class::UTF8Columns DBIx::Class::ForceUTF8/) {
37       if ($comp->isa ($_) ) {
38         $keep_checking = 0; # no use to check from this point on
39         carp_once "Use of $_ is strongly discouraged. See documentation of DBIx::Class::UTF8Columns for more info\n"
40           unless $ENV{DBIC_UTF8COLUMNS_OK};
41         last;
42       }
43     }
44
45     # something unset $keep_checking - we got a unicode mangler
46     if (! $keep_checking) {
47
48       my $base_store_column = do { require DBIx::Class::Row; DBIx::Class::Row->can ('store_column') };
49
50       my @broken;
51       for my $existing_comp (@target_isa) {
52         my $sc = $existing_comp->can ('store_column')
53           or next;
54
55         if ($sc ne $base_store_column) {
56           require B;
57           my $definer = B::svref_2object($sc)->STASH->NAME;
58           push @broken, ($definer eq $existing_comp)
59             ? $existing_comp
60             : "$existing_comp (via $definer)"
61           ;
62         }
63       }
64
65       carp "Incorrect loading order of $comp by $target will affect other components overriding 'store_column' ("
66           . join (', ', @broken)
67           .'). Refer to the documentation of DBIx::Class::UTF8Columns for more info'
68         if @broken;
69     }
70
71     unshift @target_isa, $comp;
72   }
73
74   $class->next::method(@_);
75 }
76
77 1;