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