As clear as it gets
[dbsrgits/DBIx-Class-Historic.git] / 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