lib/DBIx/Class/UTF8Columns.pm

   1 package DBIx::Class::UTF8Columns;
   2 use strict;
   3 use warnings;
   4 use base qw/DBIx::Class/;
   5
   6 __PACKAGE__->mk_classdata( '_utf8_columns' );
   7
   8 =head1 NAME
   9
  10 DBIx::Class::UTF8Columns - Force UTF8 (Unicode) flag on columns
  11
  12    Please ensure you understand the purpose of this module before use.
  13    Read the warnings below to prevent data corruption through misuse.
  14
  15 =head1 SYNOPSIS
  16
  17     package Artist;
  18     use base 'DBIx::Class::Core';
  19
  20     __PACKAGE__->load_components(qw/UTF8Columns/);
  21     __PACKAGE__->utf8_columns(qw/name description/);
  22
  23     # then belows return strings with utf8 flag
  24     $artist->name;
  25     $artist->get_column('description');
  26
  27 =head1 DESCRIPTION
  28
  29 This module allows you to get and store utf8 (unicode) column data
  30 in a database that does not natively support unicode. It ensures
  31 that column data is correctly serialised as a byte stream when
  32 stored and de-serialised to unicode strings on retrieval.
  33
  34 =head2 Warning - Native Database Unicode Support
  35
  36 If your database natively supports Unicode (as does SQLite with the
  37 C<sqlite_unicode> connect flag, MySQL with C<mysql_enable_utf8>
  38 connect flag or Postgres with the C<pg_enable_utf8> connect flag),
  39 then this component should B<not> be used, and will corrupt unicode
  40 data in a subtle and unexpected manner.
  41
  42 It is far better to do Unicode support within the database if
  43 possible rather convert data into and out of the database on every
  44 round trip.
  45
  46 =head2 Warning - Component Overloading
  47
  48 Note that this module overloads L<DBIx::Class::Row/store_column> in a way
  49 that may prevent other components overloading the same method from working
  50 correctly. This component must be the last one before L<DBIx::Class::Row>
  51 (which is provided by L<DBIx::Class::Core>). DBIx::Class will detect such
  52 incorrect component order and issue an appropriate warning, advising which
  53 components need to be loaded differently.
  54
  55 =head1 SEE ALSO
  56
  57 L<Template::Stash::ForceUTF8>, L<DBIx::Class::UUIDColumns>.
  58
  59 =head1 METHODS
  60
  61 =head2 utf8_columns
  62
  63 =cut
  64
  65 sub utf8_columns {
  66     my $self = shift;
  67     if (@_) {
  68         foreach my $col (@_) {
  69             $self->throw_exception("column $col doesn't exist")
  70                 unless $self->has_column($col);
  71         }
  72         return $self->_utf8_columns({ map { $_ => 1 } @_ });
  73     } else {
  74         return $self->_utf8_columns;
  75     }
  76 }
  77
  78 =head1 EXTENDED METHODS
  79
  80 =head2 get_column
  81
  82 =cut
  83
  84 sub get_column {
  85     my ( $self, $column ) = @_;
  86     my $value = $self->next::method($column);
  87
  88     utf8::decode($value) if (
  89       defined $value and $self->_is_utf8_column($column) and ! utf8::is_utf8($value)
  90     );
  91
  92     return $value;
  93 }
  94
  95 =head2 get_columns
  96
  97 =cut
  98
  99 sub get_columns {
 100     my $self = shift;
 101     my %data = $self->next::method(@_);
 102
 103     foreach my $col (keys %data) {
 104       utf8::decode($data{$col}) if (
 105         exists $data{$col} and defined $data{$col} and $self->_is_utf8_column($col) and ! utf8::is_utf8($data{$col})
 106       );
 107     }
 108
 109     return %data;
 110 }
 111
 112 =head2 store_column
 113
 114 =cut
 115
 116 sub store_column {
 117     my ( $self, $column, $value ) = @_;
 118
 119     # the dirtyness comparison must happen on the non-encoded value
 120     my $copy;
 121
 122     if ( defined $value and $self->_is_utf8_column($column) and utf8::is_utf8($value) ) {
 123       $copy = $value;
 124       utf8::encode($value);
 125     }
 126
 127     $self->next::method( $column, $value );
 128
 129     return $copy || $value;
 130 }
 131
 132 # override this if you want to force everything to be encoded/decoded
 133 sub _is_utf8_column {
 134   # my ($self, $col) = @_;
 135   return ($_[0]->utf8_columns || {})->{$_[1]};
 136 }
 137
 138 =head1 AUTHORS
 139
 140 See L<DBIx::Class/CONTRIBUTORS>.
 141
 142 =head1 LICENSE
 143
 144 You may distribute this code under the same terms as Perl itself.
 145
 146 =cut
 147
 148 1;