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