lib/DBIx/Class/UTF8Columns.pm

   1 package DBIx::Class::UTF8Columns;
   2 use strict;
   3 use warnings;
   4 use base qw/DBIx::Class/;
   5 use utf8;
   6
   7 __PACKAGE__->mk_classdata( '_utf8_columns' );
   8
   9 =head1 NAME
  10
  11 DBIx::Class::UTF8Columns - Force UTF8 (Unicode) flag on columns
  12
  13 =head1 SYNOPSIS
  14
  15     package Artist;
  16     use base 'DBIx::Class::Core';
  17
  18     __PACKAGE__->load_components(qw/UTF8Columns/);
  19     __PACKAGE__->utf8_columns(qw/name description/);
  20
  21     # then belows return strings with utf8 flag
  22     $artist->name;
  23     $artist->get_column('description');
  24
  25 =head1 DESCRIPTION
  26
  27 This module allows you to get columns data that have utf8 (Unicode) flag.
  28
  29 =head2 Warning
  30
  31 Note that this module overloads L<DBIx::Class::Row/store_column> in a way
  32 that may prevent other components overloading the same method from working
  33 correctly. This component must be the last one before L<DBIx::Class::Row>
  34 (which is provided by L<DBIx::Class::Core>). DBIx::Class will detect such
  35 incorrect component order and issue an appropriate warning, advising which
  36 components need to be loaded differently.
  37
  38 =head1 SEE ALSO
  39
  40 L<Template::Stash::ForceUTF8>, L<DBIx::Class::UUIDColumns>.
  41
  42 =head1 METHODS
  43
  44 =head2 utf8_columns
  45
  46 =cut
  47
  48 sub utf8_columns {
  49     my $self = shift;
  50     if (@_) {
  51         foreach my $col (@_) {
  52             $self->throw_exception("column $col doesn't exist")
  53                 unless $self->has_column($col);
  54         }
  55         return $self->_utf8_columns({ map { $_ => 1 } @_ });
  56     } else {
  57         return $self->_utf8_columns;
  58     }
  59 }
  60
  61 =head1 EXTENDED METHODS
  62
  63 =head2 get_column
  64
  65 =cut
  66
  67 sub get_column {
  68     my ( $self, $column ) = @_;
  69     my $value = $self->next::method($column);
  70
  71     utf8::decode($value) if (
  72       defined $value and $self->_is_utf8_column($column) and ! utf8::is_utf8($value)
  73     );
  74
  75     return $value;
  76 }
  77
  78 =head2 get_columns
  79
  80 =cut
  81
  82 sub get_columns {
  83     my $self = shift;
  84     my %data = $self->next::method(@_);
  85
  86     foreach my $col (keys %data) {
  87       utf8::decode($data{$col}) if (
  88         exists $data{$col} and defined $data{$col} and $self->_is_utf8_column($col) and ! utf8::is_utf8($data{$col})
  89       );
  90     }
  91
  92     return %data;
  93 }
  94
  95 =head2 store_column
  96
  97 =cut
  98
  99 sub store_column {
 100     my ( $self, $column, $value ) = @_;
 101
 102     # the dirtyness comparison must happen on the non-encoded value
 103     my $copy;
 104
 105     if ( defined $value and $self->_is_utf8_column($column) and utf8::is_utf8($value) ) {
 106       $copy = $value;
 107       utf8::encode($value);
 108     }
 109
 110     $self->next::method( $column, $value );
 111
 112     return $copy || $value;
 113 }
 114
 115 # override this if you want to force everything to be encoded/decoded
 116 sub _is_utf8_column {
 117   return (shift->utf8_columns || {})->{shift};
 118 }
 119
 120 =head1 AUTHORS
 121
 122 See L<DBIx::Class/CONTRIBUTORS>.
 123
 124 =head1 LICENSE
 125
 126 You may distribute this code under the same terms as Perl itself.
 127
 128 =cut
 129
 130 1;