1package Data::Model::Schema;
2use strict;
3use warnings;
4
5use Carp ();
6$Carp::Internal{(__PACKAGE__)}++;
7use Encode ();
8
9use Data::Model::Row;
10use Data::Model::Schema::Properties;
11
12my  $SUGAR_MAP    = +{};
13our $COLUMN_SUGAR = +{};
14
15sub import {
16    my($class, %args) = @_;
17    my $caller = caller;
18    $SUGAR_MAP->{$caller} = $args{sugar} || 'default';
19    $COLUMN_SUGAR->{$SUGAR_MAP->{$caller}} ||= +{};
20
21    if ($caller eq 'Data::Model::Schema::Properties') {
22        $args{skip_import}++;
23    }
24
25    unless ($args{skip_import}) {
26        no strict 'refs';
27        for my $name (qw/ base_driver driver install_model schema column columns key index unique schema_options column_sugar
28                          utf8_column utf8_columns alias_column add_method /) {
29            *{"$caller\::$name"} = \&$name;
30        }
31    }
32
33    my $__properties = +{
34        base_driver  => undef,
35        schema       => +{},
36        __process_tmp => +{
37            class => $caller,
38        },
39    };
40
41    no strict 'refs';
42    no warnings 'redefine';
43    *{"$caller\::__properties"} = sub { $__properties };
44}
45
46my $CALLER = undef;
47sub install_model ($$;%) {
48    my($name, $schema_code, %args) = @_;
49    my $caller = caller;
50
51    my $pkg = "$caller\::$name";
52
53    my $schema = $caller->__properties->{schema}->{$name} = Data::Model::Schema::Properties->new(
54        driver                  => $caller->__properties->{base_driver},
55        schema_class            => $caller,
56        model                   => $name,
57        class                   => $pkg,
58        column                  => {},
59        columns                 => [],
60        index                   => {},
61        unique                  => {},
62        key                     => [],
63        foreign                 => [],
64        triggers                => {},
65        options                 => {},
66        utf8_columns            => {},
67        inflate_columns         => [],
68        deflate_columns         => [],
69        has_inflate             => 0,
70        has_deflate             => 0,
71        alias_column            => {},
72        aluas_column_revers_map => {},
73        _build_tmp              => {},
74    );
75
76    $caller->__properties->{__process_tmp}->{name} = $name;
77    $CALLER = $caller;
78    $schema_code->();
79    $schema->setup_inflate;
80    unless ($schema->options->{bare_row}) {
81        no strict 'refs';
82        @{"$pkg\::ISA"} = ( 'Data::Model::Row' );
83        _install_columns_to_class($schema);
84        _install_alias_columns_to_class($schema);
85    }
86    $CALLER = undef;
87    delete $caller->__properties->{__process_tmp};
88
89    if ($schema->driver) {
90        $schema->driver->attach_model($name, $schema);
91    }
92}
93sub schema (&) { shift }
94
95sub _install_columns_to_class {
96    my $schema = shift;
97    no strict 'refs';
98    while (my($column, $args) = each %{ $schema->column }) {
99        my $alias_list = $schema->aluas_column_revers_map->{$column};
100
101        if ($alias_list) {
102            *{ $schema->class . "::$column" } = sub {
103                my $obj = shift;
104                # getter
105                return $obj->{column_values}->{$column} unless @_;
106                # setter
107                my($val, $flags) = @_;
108                my $old_val = $obj->{column_values}->{$column};
109                $obj->{column_values}->{$column} = $val;
110                unless ($flags && ref($flags) eq 'HASH' && $flags->{no_changed_flag}) {
111                    $obj->{changed_cols}->{$column} = $old_val;
112                }
113                for my $alias (@{ $alias_list }) {
114                    delete $obj->{alias_values}->{$alias};
115                }
116                return $obj->{column_values}->{$column};
117            };
118        } else {
119            *{ $schema->class . "::$column" } = sub {
120                my $obj = shift;
121                # getter
122                return $obj->{column_values}->{$column} unless @_;
123                # setter
124                my($val, $flags) = @_;
125                my $old_val = $obj->{column_values}->{$column};
126                $obj->{column_values}->{$column} = $val;
127                unless ($flags && ref($flags) eq 'HASH' && $flags->{no_changed_flag}) {
128                    $obj->{changed_cols}->{$column} = $old_val;
129                }
130                return $obj->{column_values}->{$column};
131            };
132        }
133    }
134}
135
136sub _install_alias_columns_to_class {
137    my $schema = shift;
138    no strict 'refs';
139    while (my($column, $args) = each %{ $schema->alias_column }) {
140        my $base          = $args->{base};
141        my $deflate_code  = $args->{deflate};
142        my $is_utf8       = $args->{is_utf8};
143        my $charset       = $args->{charset} || 'utf8';
144        my $inflate2alias = $args->{inflate2alias};
145
146        if ($is_utf8 && $deflate_code) {
147            *{ $schema->class . "::$column" } = sub {
148                my $obj = shift;
149                # getter
150                return $obj->{alias_values}->{$column} ||= $inflate2alias->($obj) unless @_;
151                # setter
152                $obj->{alias_values}->{$column} = $_[0];
153                $obj->$base( Encode::encode($charset, $deflate_code->( $_[0] ) ) );
154                return $_[0];
155            };
156        } elsif ($is_utf8) {
157            *{ $schema->class . "::$column" } = sub {
158                my $obj = shift;
159                # getter
160                return $obj->{alias_values}->{$column} ||= $inflate2alias->($obj) unless @_;
161                # setter
162                $obj->{alias_values}->{$column} = $_[0];
163                $obj->$base( Encode::encode($charset, $_[0]) );
164                return $_[0];
165            };
166        } elsif ($deflate_code) {
167            *{ $schema->class . "::$column" } = sub {
168                my $obj = shift;
169                # getter
170                return $obj->{alias_values}->{$column} ||= $inflate2alias->($obj) unless @_;
171                # setter
172                $obj->{alias_values}->{$column} = $_[0];
173                $obj->$base( $deflate_code->($_[0]) );
174                return $_[0];
175            };
176        } else {
177            *{ $schema->class . "::$column" } = sub {
178                my $obj = shift;
179                # getter
180                return $obj->{alias_values}->{$column} ||= $inflate2alias->($obj) unless @_;
181                # setter
182                $obj->{alias_values}->{$column} = $_[0];
183                $obj->$base( $_[0] );
184                return $_[0];
185            };
186        }
187    }
188}
189
190sub _get_model_schema {
191    if ($CALLER) {
192        my $caller = caller(1);
193        my $name = $caller->__properties->{__process_tmp}->{name};
194        return ($name, $caller->__properties->{schema}->{$name});
195    }
196
197    my $method = (caller(1))[3];
198    $method =~ s/.+:://;
199    Carp::croak "'$method' method is target internal only";
200}
201
202sub base_driver ($) {
203    my $caller = caller;
204    return unless $caller->can('__properties');
205    $caller->__properties->{base_driver} = shift;
206}
207
208sub driver ($;%) {
209    my($name, $schema) = _get_model_schema;
210    my($driver, %args) = @_;
211    $schema->driver($driver);
212}
213
214sub column ($;$;$) {
215    my($name, $schema) = _get_model_schema;
216    $schema->add_column(@_);
217}
218sub columns (@) {
219    my($name, $schema) = _get_model_schema;
220    my @columns = @_;
221    for my $column (@columns) {
222        $schema->add_column($column);
223    }
224}
225sub utf8_column ($;$;$) {
226    my($name, $schema) = _get_model_schema;
227    $schema->add_utf8_column(@_);
228}
229sub utf8_columns (@) {
230    my($name, $schema) = _get_model_schema;
231    my @columns = @_;
232    for my $column (@columns) {
233        $schema->add_utf8_column($column);
234    }
235}
236
237sub alias_column {
238    my($name, $schema) = _get_model_schema;
239    $schema->add_alias_column(@_);
240}
241
242sub key ($;%) {
243    my($name, $schema) = _get_model_schema;
244    $schema->add_keys(@_);
245}
246
247sub index ($;$;%) {
248    my($name, $schema) = _get_model_schema;
249    $schema->add_index(@_);
250}
251
252sub unique ($;$;%) {
253    my($name, $schema) = _get_model_schema;
254    $schema->add_unique(@_);
255}
256
257sub schema_options (@) {
258    my($name, $schema) = _get_model_schema;
259    $schema->add_options(@_);
260}
261
262sub add_method {
263    my($name, $schema) = _get_model_schema;
264    my($method, $code) = @_;
265    no strict 'refs';
266    *{$schema->class."::$method"} = $code;
267}
268
269
270sub column_sugar (@) {
271    my($column, $type, $options) = @_;
272    Carp::croak "usage: add_column_sugar 'table_name.column_name' => type => { args };"
273        unless $column =~ /^[^\.+]+\.[^\.+]+$/;
274
275    my $caller = caller;
276    $COLUMN_SUGAR->{$SUGAR_MAP->{$caller}} ||= +{};
277    $COLUMN_SUGAR->{$SUGAR_MAP->{$caller}}->{$column} = +{
278        type    => $type    || 'char',
279        options => $options || +{},
280    };
281}
282
283sub get_column_sugar {
284    my($class, $schema) = @_;
285    $COLUMN_SUGAR->{$SUGAR_MAP->{$schema->{schema_class}}};
286}
287
2881;
289
290__END__
291
292=head1 NAME
293
294Data::Model::Schema - Schema DSL for Data::Model
295
296=head1 SYNOPSIS
297
298  package Your::Model;
299  use base 'Data::Model';
300  use Data::Model::Schema;
301  use Data::Model::Driver::DBI;
302
303  my $dbfile = '/foo/bar.db';
304  my $driver = Data::Model::Driver::DBI->new(
305      dsn => "dbi:SQLite:dbname=$dbfile",
306  );
307  base_driver( $driver ); # set the storage driver for Your::Model
308
309
310  install_model tweet => schema { # CREATE TABLE tweet (
311    key 'id'; # primary key
312    index index_name [qw/ user_id at /]; # index index_name(user_id, at);
313
314    column id
315        => int => {
316            auto_increment => 1,
317            required       => 1,
318            unsigned       => 1,
319        }; # id   UNSIGNED INT NOT NULL AUTO_INCREMENT,
320
321    column user_id
322        => int => {
323            required       => 1,
324            unsigned       => 1,
325        }; # user_id   UNSIGNED INT NOT NULL,
326
327    column at
328        => int => {
329            required       => 1,
330            default        => sub { time() },
331            unsigned       => 1,
332        }; # at   UNSIGNED INT NOT NULL, # If it is empty at the time of insert   time() is used.
333
334    utf8_column body # append to auto utf8 inflating
335        => varchar => {
336            required       => 1,
337            size           => 140,
338            default        => '-',
339        }; # body   VARCHAR(140) NOT NULL DEFAULT'-',
340
341
342    column field_name
343        => char => {
344            default    => 'aaa', # default value
345            auto_increment => 1, # auto_increment
346            inflate => sub { unpack("H*", $_[0]) }, # inflating by original function
347            deflate => sub { pack("H*", $_[0]) },   # deflating by original function
348        };
349
350    column field_name_2
351        => char => {
352            inflate => 'URI', # use URI inflate see L<Data::Model::Schema::Inflate>
353            deflate => 'URI', # use URI deflate see L<Data::Model::Schema::Inflate>
354        };
355
356    columns qw/ foo bar /; # create columns uses default config
357};
358
359=head1 GLOBAL DSL
360
361=head2 install_model, schema
362
363  model name and it schema is set up.
364
365  install_model model_name schema {
366  };
367
368=head2 base_driver
369
370set driver ( Data::Model::Driver::* ) for current package's default.
371
372
373=head2 column_sugar
374
375column_sugar promotes reuse of a schema definition.
376
377see head1 COLUMN SUGAR
378
379=head1 SCHEMA DSL
380
381=head2 driver
382
383driver used only in install_model of current.
384
385  install_model local_driver => schema {
386      my $driver = Data::Mode::Driver::DBI->new( dsn => 'DBI:SQLite:' );
387      driver($driver);
388   }
389
390=head2 column
391
392It is a column definition.
393
394  column column_name => column_type => \%options;
395
396column_name puts in the column name of SQL schema.
397
398column_type puts in the column type of SQL schema. ( INT CHAR BLOB ... )
399
400=head2 columns
401
402some columns are set up. However, options cannot be set.
403
404=head2 utf8_column
405
406column with utf8 inflated.
407
408=head2 utf8_columns
409
410columns with utf8 inflated.
411
412=head2 alias_column
413
414alias is attached to a specific column.
415
416It is helpful. I can use, when leaving original data and inflateing.
417
418    { package Name; use Moose; has 'name' => ( is => 'rw' ); }
419    # in schema
420    columns qw( name nickname );
421    alias_column name     => 'name_name';
422    alias_column nickname => 'nickname_name'
423        => {
424            inflate => sub {
425                my $value = shift;
426                Name->new( name => $value );
427            }
428
429    # in your script
430    is $row->nickname, $row->nickname_name->name;
431
432=head2 key
433
434set the primary key.
435Unless it specifies key, it does not move by lookup and lookup_multi.
436
437  key 'id';
438  key [qw/ id sub_id /]; # multiple key
439
440=head2 index
441
442  index 'name'; # index name(name);
443  index name => [qw/ name name2 /]; # index name(name, name2)
444
445=head2 unique
446
447  unique 'name'; # unique name(name);
448  unique name => [qw/ name name2 /]; # unique name(name, name2)
449
450=head2 add_method
451
452A method is added to Row class which install_model created.
453
454  add_method show_name => sub {
455      my $row = shift;
456      printf "Show %s\n", $row->name;
457  };
458
459  $row->name('yappo');
460  $row->show_name; # print "Show yappo\n"
461
462=head2 schema_options
463
464some option to schema is added.
465
466It is used when using InnoDB in MySQL.
467
468  schema_options create_sql_attributes => {
469      mysql => 'ENGINE=InnoDB',
470  };
471
472=head1 COLUMN OPTIONS
473
474The option which can be used in a column definition.
475
476Pasted the definition of ParamsValidate. It writes later.
477
478=head2 size
479
480                size   => {
481                    type     => SCALAR,
482                    regex    => qr/\A[0-9]+\z/,
483                    optional => 1,
484                },
485
486=head2 required
487
488                required   => {
489                    type     => BOOLEAN,
490                    optional => 1,
491                },
492
493=head2 null
494
495                null       => {
496                    type     => BOOLEAN,
497                    optional => 1,
498                },
499
500=head2 signed
501
502                signed     => {
503                    type     => BOOLEAN,
504                    optional => 1,
505                },
506
507=head2 unsigned
508
509                unsigned   => {
510                    type     => BOOLEAN,
511                    optional => 1,
512                },
513
514=head2 decimals
515
516                decimals   => {
517                    type     => BOOLEAN,
518                    optional => 1,
519                },
520
521=head2 zerofill
522
523                zerofill   => {
524                    type     => BOOLEAN,
525                    optional => 1,
526                },
527
528=head2 binary
529
530                binary     => {
531                    type     => BOOLEAN,
532                    optional => 1,
533                },
534
535=head2 ascii
536
537                ascii      => {
538                    type     => BOOLEAN,
539                    optional => 1,
540                },
541
542=head2 unicode
543
544                unicode    => {
545                    type     => BOOLEAN,
546                    optional => 1,
547                },
548
549=head2 default
550
551                default    => {
552                    type     => SCALAR | CODEREF,
553                    optional => 1,
554                },
555
556=head2 auto_increment
557
558                auto_increment => {
559                    type     => BOOLEAN,
560                    optional => 1,
561                },
562
563=head2 inflate
564
565                inflate => {
566                    type     => SCALAR | CODEREF,
567                    optional => 1,
568                },
569
570=head2 deflate
571
572                deflate => {
573                    type     => SCALAR | CODEREF,
574                    optional => 1,
575                },
576
577
578=head1 COLUMN SUGAR
579
580UNDOCUMENTED
581
582  package Mock::ColumnSugar;
583  use strict;
584  use warnings;
585  use base 'Data::Model';
586  use Data::Model::Schema sugar => 'column_sugar';
587
588  column_sugar 'author.id'
589      => 'int' => +{
590          unsigned => 1,
591          required => 1, # we can used to require or required
592      };
593  column_sugar 'author.name'
594      => 'varchar' => +{
595          size    => 128,
596          require => 1,
597      };
598
599  column_sugar 'book.id'
600      => 'int' => +{
601          unsigned => 1,
602          require  => 1,
603      };
604  column_sugar 'book.title'
605      => 'varchar' => +{
606          size    => 255,
607          require => 1,
608      };
609  column_sugar 'book.description'
610      => 'text' => +{
611          require => 1,
612          default => 'not yet writing'
613      };
614  column_sugar 'book.recommend'
615      => 'text';
616
617
618  install_model author => schema {
619      driver $main::DRIVER;
620      key 'id';
621
622      column 'author.id' => { auto_increment => 1 }; # column name is id
623      column 'author.name'; # column name is name
624  };
625
626  install_model book => schema {
627      driver $main::DRIVER;
628      key 'id';
629      index 'author_id';
630
631      column 'book.id'   => { auto_increment => 1 }; # column name is id
632      column 'author.id'; # column name is author_id
633      column 'author.id' => 'sub_author_id' => { required => 0 }; # column name is sub_author_id
634      column 'book.title'; # column name is title
635      column 'book.description'; # column name is description
636      column 'book.recommend'; # column name is recommend
637  };
638
639=head1 AUTHOR
640
641Kazuhiro Osawa E<lt>yappo <at> shibuya <döt> plE<gt>
642
643=head1 LICENSE
644
645This library is free software; you can redistribute it and/or modify
646it under the same terms as Perl itself.
647
648=cut
649
650