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