lib/DBIx/Class/UTF8Columns.pm

   1 package DBIx::Class::UTF8Columns;
   2 use strict;
   3 use warnings;
   4 use base qw/DBIx::Class/;
   5
   6 use utf8;
   7
   8 __PACKAGE__->mk_classdata( '_utf8_columns' );
   9
  10 =head1 NAME
  11
  12 DBIx::Class::UTF8Columns - Force UTF8 (Unicode) flag on columns
  13
  14 =head1 SYNOPSIS
  15
  16     package Artist;
  17     __PACKAGE__->load_components(qw/UTF8Columns Core/);
  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 =head1 SEE ALSO
  29
  30 L<Template::Stash::ForceUTF8>, L<DBIx::Class::UUIDColumns>.
  31
  32 =head1 METHODS
  33
  34 =head2 utf8_columns
  35
  36 =cut
  37
  38 sub utf8_columns {
  39     my $self = shift;
  40     if (@_) {
  41         foreach my $col (@_) {
  42             $self->throw_exception("column $col doesn't exist")
  43                 unless $self->has_column($col);
  44         }
  45         return $self->_utf8_columns({ map { $_ => 1 } @_ });
  46     } else {
  47         return $self->_utf8_columns;
  48     }
  49 }
  50
  51 =head1 EXTENDED METHODS
  52
  53 =head2 get_column
  54
  55 =cut
  56
  57 sub get_column {
  58     my ( $self, $column ) = @_;
  59     my $value = $self->next::method($column);
  60
  61     my $cols = $self->_utf8_columns;
  62     if ( $cols and defined $value and $cols->{$column} ) {
  63         utf8::decode($value) unless utf8::is_utf8($value);
  64    }
  65
  66     $value;
  67 }
  68
  69 =head2 get_columns
  70
  71 =cut
  72
  73 sub get_columns {
  74     my $self = shift;
  75     my %data = $self->next::method(@_);
  76
  77     foreach my $col (grep { defined $data{$_} } keys %{ $self->_utf8_columns || {} }) {
  78         utf8::decode($data{$col}) unless utf8::is_utf8($data{$col});
  79     }
  80
  81     %data;
  82 }
  83
  84 =head2 store_column
  85
  86 =cut
  87
  88 sub store_column {
  89     my ( $self, $column, $value ) = @_;
  90
  91     my $cols = $self->_utf8_columns;
  92     if ( $cols and defined $value and $cols->{$column} ) {
  93         utf8::encode($value) if utf8::is_utf8($value);
  94     }
  95
  96     $self->next::method( $column, $value );
  97 }
  98
  99 =head1 AUTHOR
 100
 101 Daisuke Murase <typester@cpan.org>
 102
 103 =head1 COPYRIGHT
 104
 105 This program is free software; you can redistribute
 106 it and/or modify it under the same terms as Perl itself.
 107
 108 The full text of the license can be found in the
 109 LICENSE file included with this module.
 110
 111 =cut
 112
 113 1;
 114