lib/DBIx/Class/UTF8Columns.pm

   1 package DBIx::Class::UTF8Columns;
   2 use strict;
   3 use warnings;
   4 use base qw/DBIx::Class/;
   5
   6 BEGIN {
   7
   8     # Perl 5.8.0 doesn't have utf8::is_utf8()
   9     # Yes, 5.8.0 support for Unicode is suboptimal, but things like RHEL3 ship with it.
  10     if ($] <= 5.008000) {
  11         require Encode;
  12     } else {
  13         require utf8;
  14     }
  15 }
  16
  17 __PACKAGE__->mk_classdata( '_utf8_columns' );
  18
  19 =head1 NAME
  20
  21 DBIx::Class::UTF8Columns - Force UTF8 (Unicode) flag on columns
  22
  23 =head1 SYNOPSIS
  24
  25     package Artist;
  26     use base 'DBIx::Class::Core';
  27
  28     __PACKAGE__->load_components(qw/UTF8Columns/);
  29     __PACKAGE__->utf8_columns(qw/name description/);
  30
  31     # then belows return strings with utf8 flag
  32     $artist->name;
  33     $artist->get_column('description');
  34
  35 =head1 DESCRIPTION
  36
  37 This module allows you to get columns data that have utf8 (Unicode) flag.
  38
  39 =head1 SEE ALSO
  40
  41 L<Template::Stash::ForceUTF8>, L<DBIx::Class::UUIDColumns>.
  42
  43 =head1 METHODS
  44
  45 =head2 utf8_columns
  46
  47 =cut
  48
  49 sub utf8_columns {
  50     my $self = shift;
  51     if (@_) {
  52         foreach my $col (@_) {
  53             $self->throw_exception("column $col doesn't exist")
  54                 unless $self->has_column($col);
  55         }
  56         return $self->_utf8_columns({ map { $_ => 1 } @_ });
  57     } else {
  58         return $self->_utf8_columns;
  59     }
  60 }
  61
  62 =head1 EXTENDED METHODS
  63
  64 =head2 get_column
  65
  66 =cut
  67
  68 sub get_column {
  69     my ( $self, $column ) = @_;
  70     my $value = $self->next::method($column);
  71
  72     my $cols = $self->_utf8_columns;
  73     if ( $cols and defined $value and $cols->{$column} ) {
  74
  75         if ($] <= 5.008000) {
  76             Encode::_utf8_on($value) unless Encode::is_utf8($value);
  77         } else {
  78             utf8::decode($value) unless utf8::is_utf8($value);
  79         }
  80     }
  81
  82     $value;
  83 }
  84
  85 =head2 get_columns
  86
  87 =cut
  88
  89 sub get_columns {
  90     my $self = shift;
  91     my %data = $self->next::method(@_);
  92
  93     foreach my $col (grep { defined $data{$_} } keys %{ $self->_utf8_columns || {} }) {
  94
  95         if ($] <= 5.008000) {
  96             Encode::_utf8_on($data{$col}) unless Encode::is_utf8($data{$col});
  97         } else {
  98             utf8::decode($data{$col}) unless utf8::is_utf8($data{$col});
  99         }
 100     }
 101
 102     %data;
 103 }
 104
 105 =head2 store_column
 106
 107 =cut
 108
 109 sub store_column {
 110     my ( $self, $column, $value ) = @_;
 111
 112     my $cols = $self->_utf8_columns;
 113     if ( $cols and defined $value and $cols->{$column} ) {
 114
 115         if ($] <= 5.008000) {
 116             Encode::_utf8_off($value) if Encode::is_utf8($value);
 117         } else {
 118             utf8::encode($value) if utf8::is_utf8($value);
 119         }
 120     }
 121
 122     $self->next::method( $column, $value );
 123 }
 124
 125 =head1 AUTHOR
 126
 127 Daisuke Murase <typester@cpan.org>
 128
 129 =head1 COPYRIGHT
 130
 131 This program is free software; you can redistribute
 132 it and/or modify it under the same terms as Perl itself.
 133
 134 The full text of the license can be found in the
 135 LICENSE file included with this module.
 136
 137 =cut
 138
 139 1;
 140