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