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     __PACKAGE__->load_components(qw/UTF8Columns Core/);
  27     __PACKAGE__->utf8_columns(qw/name description/);
  28
  29     # then belows return strings with utf8 flag
  30     $artist->name;
  31     $artist->get_column('description');
  32
  33 =head1 DESCRIPTION
  34
  35 This module allows you to get columns data that have utf8 (Unicode) flag.
  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     my $cols = $self->_utf8_columns;
  71     if ( $cols and defined $value and $cols->{$column} ) {
  72
  73         if ($] <= 5.008000) {
  74             Encode::_utf8_on($value) unless Encode::is_utf8($value);
  75         } else {
  76             utf8::decode($value) unless utf8::is_utf8($value);
  77         }
  78     }
  79
  80     $value;
  81 }
  82
  83 =head2 get_columns
  84
  85 =cut
  86
  87 sub get_columns {
  88     my $self = shift;
  89     my %data = $self->next::method(@_);
  90
  91     foreach my $col (grep { defined $data{$_} } keys %{ $self->_utf8_columns || {} }) {
  92
  93         if ($] <= 5.008000) {
  94             Encode::_utf8_on($data{$col}) unless Encode::is_utf8($data{$col});
  95         } else {
  96             utf8::decode($data{$col}) unless utf8::is_utf8($data{$col});
  97         }
  98     }
  99
 100     %data;
 101 }
 102
 103 =head2 store_column
 104
 105 =cut
 106
 107 sub store_column {
 108     my ( $self, $column, $value ) = @_;
 109
 110     my $cols = $self->_utf8_columns;
 111     if ( $cols and defined $value and $cols->{$column} ) {
 112
 113         if ($] <= 5.008000) {
 114             Encode::_utf8_off($value) if Encode::is_utf8($value);
 115         } else {
 116             utf8::encode($value) if utf8::is_utf8($value);
 117         }
 118     }
 119
 120     $self->next::method( $column, $value );
 121 }
 122
 123 =head1 AUTHOR
 124
 125 Daisuke Murase <typester@cpan.org>
 126
 127 =head1 COPYRIGHT
 128
 129 This program is free software; you can redistribute
 130 it and/or modify it under the same terms as Perl itself.
 131
 132 The full text of the license can be found in the
 133 LICENSE file included with this module.
 134
 135 =cut
 136
 137 1;
 138