1package Data::Model::Schema::Properties;
2use strict;
3use warnings;
4use base qw(Data::Model::Accessor);
5
6use Carp ();
7$Carp::Internal{(__PACKAGE__)}++;
8
9use Class::Trigger qw( pre_insert pre_save post_save post_load pre_update pre_inflate post_inflate pre_deflate post_deflate );
10use Encode ();
11use Params::Validate ':all';
12
13use Data::Model::Schema;
14use Data::Model::Schema::Inflate;
15use Data::Model::Schema::SQL;
16
17__PACKAGE__->mk_accessors(qw/ driver schema_class model class column columns index unique key options has_inflate has_deflate alias_column aluas_column_revers_map /);
18
19
20our @RESERVED = qw(
21    update save new
22    add_trigger call_trigger remove_trigger
23);
24
25
26sub new {
27    my($class, %args) = @_;
28    bless { %args }, $class;
29}
30
31sub new_obj {
32    my $self = shift;
33    $self->{class}->new(@_);
34}
35
36sub has_index {
37    $_[0]->{unique}->{$_[1]} || $_[0]->{index}->{$_[1]}
38}
39
40sub add_keys {
41    my($self, $key, %args) = @_;
42    $self->{key} = ref($key) eq 'ARRAY' ? $key : [ $key ];
43}
44
45BEGIN {
46    for my $name (qw/ unique index /) {
47        no strict 'refs';
48        *{"add_$name"} = sub {
49            my($self, $index, $columns, %args) = @_;
50            my $key = $columns || $index;
51            Carp::croak sprintf '%s::%s : %s name is require', $self->schema_class, $self->name, $name
52                if ref($index) || !defined $index;
53            $key = [ $key ] unless ref($key) eq 'ARRAY';
54            $self->{$name}->{$index} = $key;
55        };
56    }
57}
58
59sub add_column {
60    my $self = shift;
61    my($column, $type, $options) = @_;
62    return $self->add_column_sugar(@_) if $column =~ /^[^\.+]+\.[^\.+]+$/;
63    Carp::croak "Column can't be called '$column': reserved name"
64            if grep { lc $_ eq lc $column } @RESERVED;
65
66    Carp::croak 'The multiplex definition of "require" and the "required" is carried out.'
67            if exists $options->{require} && exists $options->{required};
68    if (exists $options->{require}) {
69        $options->{required} = delete $options->{require};
70    }
71
72    # validation for $options
73    if ($Data::Model::RUN_VALIDATION) {
74        my @p = %{ $options };
75        validate(
76            @p, {
77                size   => {
78                    type     => SCALAR,
79                    regex    => qr/\A[0-9]+\z/,
80                    optional => 1,
81                },
82                required   => {
83                    type     => BOOLEAN,
84                    optional => 1,
85                },
86                null       => {
87                    type     => BOOLEAN,
88                    optional => 1,
89                },
90                signed     => {
91                    type     => BOOLEAN,
92                    optional => 1,
93                },
94                unsigned   => {
95                    type     => BOOLEAN,
96                    optional => 1,
97                },
98                decimals   => {
99                    type     => BOOLEAN,
100                    optional => 1,
101                },
102                zerofill   => {
103                    type     => BOOLEAN,
104                    optional => 1,
105                },
106                binary     => {
107                    type     => BOOLEAN,
108                    optional => 1,
109                },
110                ascii      => {
111                    type     => BOOLEAN,
112                    optional => 1,
113                },
114                unicode    => {
115                    type     => BOOLEAN,
116                    optional => 1,
117                },
118                default    => {
119                    type     => SCALAR | CODEREF,
120                    optional => 1,
121                },
122                # validation => {},
123                auto_increment => {
124                    type     => BOOLEAN,
125                    optional => 1,
126                },
127                inflate => {
128                    type     => SCALAR | CODEREF,
129                    optional => 1,
130                },
131                deflate => {
132                    type     => SCALAR | CODEREF,
133                    optional => 1,
134                },
135            }
136        );
137    }
138
139    $self->{utf8_columns}->{$column} = 1
140        if delete $self->{_build_tmp}->{utf8_column}->{$column};
141
142    push @{ $self->{columns} }, $column;
143    $self->{column}->{$column} = +{
144        type    => $type    || 'char',
145        options => $options || +{},
146    };
147}
148sub add_utf8_column {
149    my $self = shift;
150    my($column) = @_;
151
152    $self->{_build_tmp}->{utf8_column} ||= {};
153    $self->{_build_tmp}->{utf8_column}->{$column} = 1;
154    $self->add_column(@_);
155}
156
157sub add_alias_column {
158    my $self = shift;
159    my($base_name, $alias_name, $args) = @_;
160    $self->{aluas_column_revers_map}->{$base_name} ||= [];
161    push @{ $self->{aluas_column_revers_map}->{$base_name} }, $alias_name;
162    $self->{alias_column}->{$alias_name} = +{
163        %{ $args || {} },
164        base    => $base_name,
165    };
166}
167
168sub add_column_sugar {
169    my $self   = shift;
170    my $name   = shift;
171    my $sugar = Data::Model::Schema->get_column_sugar($self);
172    Carp::croak "Undefined column of '$name'"
173        unless exists $sugar->{$name} && $sugar->{$name};
174
175    my $conf = $sugar->{$name};
176    my %clone = (
177        type    => $conf->{type},
178        options => +{ %{ $conf->{options} } },
179    );
180    my $column;
181    if (@_ == 0 || ref($_[0])) {
182        my $model;
183        ($model, $column) = split /\./, $name;
184        unless ($self->{model} eq $model) {
185            $column = join '_', $model, $column;
186        }
187    } else {
188        $column = shift;
189    }
190    if (@_ && ref($_[0]) eq 'HASH') {
191        $clone{options} = +{ %{ $clone{options} }, %{ ( shift ) } }
192    }
193    if (my $alias_args = delete $clone{options}->{alias}) {
194        my $rename_map = delete $clone{options}->{alias_rename} || {};
195        while (my($alias_name, $args) = each %{ $alias_args }) {
196            $self->add_alias_column($column, $rename_map->{$alias_name} || $alias_name, $args);
197        }
198    }
199
200    $self->{utf8_columns}->{$column} = 1
201        if delete $self->{_build_tmp}->{utf8_column}->{$name};
202
203    $self->add_column($column, $clone{type}, $clone{options});
204}
205
206sub add_options {
207    my $self = shift;
208    if (ref($_[0]) eq 'HASH') {
209        $self->{options} = shift;
210    } elsif (!(@_ % 2)) {
211        while (my($key, $value) = splice @_, 0, 2) {
212            $self->{options}->{$key} = $value;
213        }
214    }
215}
216
217sub column_names {
218    my $self = shift;
219    @{ $self->{columns} };
220}
221
222sub column_type {
223    my($self, $column) = @_;
224    return 'char' unless $column && $self->{column}->{$column} && $self->{column}->{$column}->{type};
225    $self->{column}->{$column}->{type};
226}
227sub column_options {
228    my($self, $column) = @_;
229    $self->{column}->{$column}->{options} || +{};
230}
231
232sub setup_inflate {
233    my $self = shift;
234
235    $self->{inflate_columns} = [];
236    $self->{deflate_columns} = [];
237
238    while (my($column, $data) = each %{ $self->{column} }) {
239        my $opts = $data->{options};
240
241        my $inflate = $opts->{inflate};
242        if ($inflate && ref($inflate) ne 'CODE') {
243            $opts->{inflate} = Data::Model::Schema::Inflate->get_inflate($inflate);
244            $opts->{deflate} = $inflate;
245            $inflate = $opts->{inflate};
246        }
247        if (ref($inflate) eq 'CODE') {
248            push @{ $self->{inflate_columns} }, $column;
249            $self->{has_inflate} = 1;
250        } else {
251            delete $opts->{inflate};
252        }
253
254        my $deflate = $opts->{deflate};
255        if ($deflate && ref($deflate) ne 'CODE') {
256            $opts->{deflate} = Data::Model::Schema::Inflate->get_deflate($deflate);
257            $deflate = $opts->{deflate};
258        }
259        if (ref($deflate) eq 'CODE') {
260            push @{ $self->{deflate_columns} }, $column;
261            $self->{has_deflate} = 1;
262        } else {
263            delete $opts->{deflate};
264        }
265    }
266
267    if (scalar(%{ $self->{utf8_columns} })) {
268        $self->{has_inflate} = $self->{has_deflate} = 1;
269        my @columns = keys %{ $self->{column} };
270        $self->{inflate_columns} = \@columns;
271        $self->{deflate_columns} = \@columns;
272    }
273
274    # for alias
275    while (my($base, $list) = each %{ $self->{aluas_column_revers_map} }) {
276        for my $alias (@{ $list }) {
277            my $args    = $self->{alias_column}->{$alias};
278            my $inflate = $args->{inflate};
279
280            if ($inflate && ref($inflate) ne 'CODE') {
281                $args->{inflate} = Data::Model::Schema::Inflate->get_inflate($inflate);
282                $args->{deflate} = Data::Model::Schema::Inflate->get_deflate($inflate);
283            }
284
285            my $inflate_code = $args->{inflate};
286            my $is_utf8      = $args->{is_utf8};
287            my $charset      = $args->{charset} || 'utf8';
288
289            # make inflate2alias
290            my $code;
291
292            if ($is_utf8 && $inflate_code) {
293                $code = sub {
294                    $_[0]->{alias_values}->{$alias} = $inflate_code->( Encode::decode( $charset, $_[0]->{column_values}->{$base} ) );
295                };
296            } elsif ($is_utf8) {
297                $code = sub {
298                    $_[0]->{alias_values}->{$alias} = Encode::decode( $charset, $_[0]->{column_values}->{$base} );
299                };
300            } elsif ($inflate_code) {
301                $code = sub {
302                    $_[0]->{alias_values}->{$alias} = $inflate_code->( $_[0]->{column_values}->{$base} );
303                };
304            } else {
305                $code = sub {
306                    $_[0]->{alias_values}->{$alias} = $_[0]->{column_values}->{$base};
307                };
308            }
309            $args->{inflate2alias} = $code;
310        }
311    }
312}
313
314sub inflate {
315    if  ($_[0]->{has_inflate}) {
316        my($self, $columns) = @_;
317        my $orig_columns;
318        if (ref($columns) eq $self->{class}) {
319            $orig_columns = $columns;
320            $columns = $columns->{column_values};
321        } elsif (ref($columns) ne 'HASH') {
322            Carp::croak "required types 'HASH' or '$self->{class}' of inflate";
323        }
324        $self->call_trigger('pre_inflate', $columns, $orig_columns);
325
326        for my $column (@{ $self->{inflate_columns} }) {
327            next unless defined $columns->{$column};
328
329            my $opts = $self->{column}->{$column}->{options};
330            my $val = $columns->{$column};
331
332            if ($self->{utf8_columns}->{$column}) {
333                my $charset = $opts->{charset} || 'utf8';
334                $val = Encode::decode($charset, $val);
335            }
336
337            $val = $opts->{inflate}->($val) if ref($opts->{inflate}) eq 'CODE';
338
339            $orig_columns->{original_cols}->{$column} ||= $orig_columns->{column_values}->{$column}
340                if $orig_columns && $columns->{$column} ne $val;
341
342            $columns->{$column} = $val;
343        }
344        $self->call_trigger('post_inflate', $columns, $orig_columns);
345    }
346}
347
348sub deflate {
349    return unless $_[0]->{has_deflate};
350    my($self, $columns) = @_;
351    my $orig_columns;
352    if (ref($columns) eq $self->{class}) {
353        $orig_columns = $columns;
354        $columns = $columns->{column_values};
355    } elsif (ref($columns) ne 'HASH') {
356        Carp::croak "required types 'HASH' or '$self->{class}' of inflate";
357    }
358    $self->call_trigger('pre_deflate', $columns, $orig_columns);
359
360    for my $column (@{ $self->{deflate_columns} }) {
361        next unless defined $columns->{$column};
362
363        my $opts = $self->{column}->{$column}->{options};
364        my $val = $columns->{$column};
365        $val = $opts->{deflate}->($val) if ref($opts->{deflate}) eq 'CODE';
366
367        if ($self->{utf8_columns}->{$column}) {
368            my $charset = $opts->{charset} || 'utf8';
369            $val = Encode::encode($charset, $val);
370        }
371        $columns->{$column} = $val;
372    }
373    $self->call_trigger('post_deflate', $columns, $orig_columns);
374}
375
376sub set_default {
377    my($self, $columns) = @_;
378
379    while (my($name, $conf) = each %{ $self->{column} }) {
380        next if exists $columns->{$name};
381        next unless exists $conf->{options};
382        next unless exists $conf->{options}->{default};
383
384        my $default = $conf->{options}->{default};
385        if (ref($default) eq 'CODE') {
386            $columns->{$name} = $default->($self, $columns);
387        } else {
388            $columns->{$name} = $default;
389        }
390    }
391}
392
393sub get_key_array_by_hash {
394    my($self, $hash, $index) = @_;
395
396    my $key;
397    $key = $self->{unique}->{$index} || $self->{index}->{$index} if $index;
398    $key ||= $self->{key};
399    $key = [ $key ] unless ref($key) eq 'ARRAY';
400
401    my @keys;
402    for my $key (@{ $key }) {
403        last unless defined $hash->{$key};
404        push @keys, $hash->{$key};
405    }
406    \@keys;
407}
408
409sub get_columns_hash_by_key_array_and_hash {
410    my($self, $hash, $array, $index) = @_;
411    my $ret = {};
412
413    # by column
414    for my $column (keys %{ $self->{column} }) {
415        next unless exists $hash->{$column};
416        $ret->{$column} = $hash->{$column};
417    }
418
419    # by key
420    my $key;
421    $key = $self->{unique}->{$index} || $self->{index}->{$index} || Carp::croak "Cannot find index '$index'" if $index;
422    $key ||= $self->{key};
423    $key = [ $key ] unless ref($key) eq 'ARRAY';
424
425    @{ $ret }{@{ $key }} = @{ $array };
426    $ret;
427}
428
429
430sub sql {
431    my $self = shift;
432    $self->{sql} ||= Data::Model::Schema::SQL->new($self);
433}
434
435
4361;
437