1 package Catalyst::Helper::Model::DBIC::Schema;
3 use namespace::autoclean;
5 no warnings 'uninitialized';
8 $VERSION = eval $VERSION;
13 use List::Util 'first';
14 use MooseX::Types::Moose qw/Str HashRef Bool ArrayRef/;
15 use Catalyst::Model::DBIC::Schema::Types 'CreateOption';
16 use List::MoreUtils 'firstidx';
17 use Scalar::Util 'looks_like_number';
18 use File::Find 'finddepth';
24 Catalyst::Helper::Model::DBIC::Schema - Helper for DBIC Schema Models
28 script/create.pl model CatalystModelName DBIC::Schema MyApp::SchemaClass \
29 [ create=dynamic | create=static ] [ traits=trait1,trait2... ] \
30 [ Schema::Loader opts ] [ dsn user pass ] \
31 [ other connect_info args ]
35 Helper for the DBIC Schema Models.
39 C<CatalystModelName> is the short name for the Catalyst Model class
40 being generated (i.e. callable with C<$c-E<gt>model('CatalystModelName')>).
42 C<MyApp::SchemaClass> is the fully qualified classname of your Schema,
43 which might or might not yet exist. Note that you should have a good
44 reason to create this under a new global namespace, otherwise use an
45 existing top level namespace for your schema class.
47 C<create=dynamic> instructs this Helper to generate the named Schema
48 class for you, basing it on L<DBIx::Class::Schema::Loader> (which
49 means the table information will always be dynamically loaded at
50 runtime from the database).
52 C<create=static> instructs this Helper to generate the named Schema
53 class for you, using L<DBIx::Class::Schema::Loader> in "one shot"
54 mode to create a standard, manually-defined L<DBIx::Class::Schema>
55 setup, based on what the Loader sees in your database at this moment.
56 A Schema/Model pair generated this way will not require
57 L<DBIx::Class::Schema::Loader> at runtime, and will not automatically
58 adapt itself to changes in your database structure. You can edit
59 the generated classes by hand to refine them.
61 C<traits> is the list of traits to apply to the model, see
62 L<Catalyst::Model::DBIC::Schema> for details.
64 C<Schema::Loader opts> are documented in L<DBIx::Class::Schema::Loader::Base>
65 and some examples are given in L</TYPICAL EXAMPLES> below.
67 C<connect_info> arguments are the same as what L<DBIx::Class::Schema/connect>
68 expects, and are storage_type-specific. They are documented in
69 L<DBIx::Class::Storage::DBI/connect_info>. For DBI-based storage, these
70 arguments are the dsn, username, password, and connect options, respectively.
71 These are optional for existing Schemas, but required if you use either of the
74 username and password can be omitted for C<SQLite> dsns.
76 Use of either of the C<create=> options requires L<DBIx::Class::Schema::Loader>.
78 =head1 TYPICAL EXAMPLES
80 Use DBIx::Class::Schema::Loader to create a static DBIx::Class::Schema,
81 and a Model which references it:
83 script/myapp_create.pl model CatalystModelName DBIC::Schema \
84 MyApp::SchemaClass create=static dbi:mysql:foodb myuname mypass
86 Same, with extra connect_info args
87 user and pass can be omitted for sqlite, since they are always empty
89 script/myapp_create.pl model CatalystModelName DBIC::Schema \
90 MyApp::SchemaClass create=static dbi:SQLite:foo.db \
91 AutoCommit=1 cursor_class=DBIx::Class::Cursor::Cached \
92 on_connect_do='["select 1", "select 2"]' quote_names=1
94 B<ON WINDOWS COMMAND LINES QUOTING RULES ARE DIFFERENT>
96 In C<cmd.exe> the above example would be:
98 script/myapp_create.pl model CatalystModelName DBIC::Schema \
99 MyApp::SchemaClass create=static dbi:SQLite:foo.db \
100 AutoCommit=1 cursor_class=DBIx::Class::Cursor::Cached \
101 on_connect_do="[\"select 1\", \"select 2\"]" quote_names=1
103 Same, but with extra Schema::Loader args (separate multiple values by commas):
105 script/myapp_create.pl model CatalystModelName DBIC::Schema \
106 MyApp::SchemaClass create=static db_schema=foodb components=Foo,Bar \
107 exclude='^(wibble|wobble)$' moniker_map='{ foo => "FOO" }' \
108 dbi:Pg:dbname=foodb myuname mypass
110 Coderefs are also supported:
112 script/myapp_create.pl model CatalystModelName DBIC::Schema \
113 MyApp::SchemaClass create=static \
114 inflect_singular='sub { $_[0] =~ /\A(.+?)(_id)?\z/; $1 }' \
115 moniker_map='sub { join(q{}, map ucfirst, split(/[\W_]+/, lc $_[0])); }' \
116 dbi:mysql:foodb myuname mypass
118 See L<DBIx::Class::Schema::Loader::Base> for a list of options
120 Create a dynamic DBIx::Class::Schema::Loader-based Schema,
121 and a Model which references it (B<DEPRECATED>):
123 script/myapp_create.pl model CatalystModelName DBIC::Schema \
124 MyApp::SchemaClass create=dynamic dbi:mysql:foodb myuname mypass
126 Reference an existing Schema of any kind, and provide some connection information for ->config:
128 script/myapp_create.pl model CatalystModelName DBIC::Schema \
129 MyApp::SchemaClass dbi:mysql:foodb myuname mypass
131 Same, but don't supply connect information yet (you'll need to do this
132 in your app config, or [not recommended] in the schema itself).
134 script/myapp_create.pl model ModelName DBIC::Schema My::SchemaClass
138 has helper => (is => 'ro', isa => 'Catalyst::Helper', required => 1);
139 has create => (is => 'rw', isa => CreateOption);
140 has args => (is => 'ro', isa => ArrayRef);
141 has traits => (is => 'rw', isa => ArrayRef);
142 has schema_class => (is => 'ro', isa => Str, required => 1);
143 has loader_args => (is => 'rw', isa => HashRef);
144 has connect_info => (is => 'rw', isa => HashRef);
145 has old_schema => (is => 'rw', isa => Bool, lazy_build => 1);
146 has is_moose_schema => (is => 'rw', isa => Bool, lazy_build => 1);
147 has result_namespace => (is => 'rw', isa => Str, lazy_build => 1);
148 has components => (is => 'rw', isa => ArrayRef);
154 This is called by L<Catalyst::Helper> with the commandline args to generate the
160 my ($package, $helper, $schema_class, @args) = @_;
162 my $self = $package->new(
164 schema_class => $schema_class,
173 my $helper = $self->helper;
174 my @args = @{ $self->args || [] };
176 $helper->{schema_class} = $self->schema_class;
178 @args = $self->_cleanup_args(\@args);
180 my ($traits_idx, $traits);
181 if (($traits_idx = firstidx { ($traits) = /^traits=(\S*)\z/ } @args) != -1) {
182 my @traits = split /,/ => $traits;
184 $self->traits(\@traits);
186 $helper->{traits} = '['
187 .(join ',' => map { qq{'$_'} } @traits)
190 splice @args, $traits_idx, 1, ();
193 if ($args[0] && $args[0] =~ /^create=(\S*)\z/) {
198 $self->_parse_loader_args(\@args);
200 $helper->{loader_args} = $self->_build_helper_loader_args;
205 if (first { ($dbi_dsn_part) = /^(dbi):/i } @args) {
207 qq{DSN must start with 'dbi:' not '$dbi_dsn_part' (case matters!)}
208 if $dbi_dsn_part ne 'dbi';
210 $helper->{setup_connect_info} = 1;
212 $helper->{connect_info} =
213 $self->_build_helper_connect_info(\@args);
215 $self->_parse_connect_info(\@args);
218 $helper->{generator} = ref $self;
219 $helper->{generator_version} = $VERSION;
224 Can be called on an instance to generate the files.
231 if ($self->create eq 'dynamic') {
232 $self->_print_dynamic_deprecation_warning;
233 $self->_gen_dynamic_schema;
234 } elsif ($self->create eq 'static') {
235 $self->_gen_static_schema;
241 sub _parse_loader_args {
242 my ($self, $args) = @_;
244 my %loader_args = $self->_read_loader_args($args);
246 while (my ($key, $val) = each %loader_args) {
247 next if $key =~ /^(?:components|constraint|exclude)\z/;
249 $loader_args{$key} = $self->_eval($val);
250 die "syntax error for loader args key '$key' with value '$val': $@"
254 my @components = $self->_build_loader_components(
255 delete $loader_args{components},
256 $loader_args{use_namespaces},
259 $self->components(\@components);
261 for my $re_opt (qw/constraint exclude/) {
262 $loader_args{$re_opt} = qr/$loader_args{$re_opt}/
263 if exists $loader_args{$re_opt};
266 tie my %result, 'Tie::IxHash';
270 use_moose => $self->is_moose_schema ? 1 : 0,
271 col_collision_map => 'column_%s',
272 (!$self->old_schema ? (
276 components => \@components
278 (%loader_args ? %loader_args : ()),
281 $self->loader_args(\%result);
283 wantarray ? %result : \%result;
286 sub _read_loader_args {
287 my ($self, $args) = @_;
291 while (@$args && $args->[0] !~ /^dbi:/i) {
292 my ($key, $val) = split /=/, shift(@$args), 2;
294 if ($self->_is_struct($val)) {
295 $loader_args{$key} = $val;
296 } elsif ((my @vals = split /,/ => $val) > 1) {
297 $loader_args{$key} = \@vals;
299 $loader_args{$key} = $val;
303 # Use args after connect_info as loader args as well, because people always
304 # get the order confused.
306 if ($args->[0] =~ /sqlite/i) {
307 $i++ if $args->[$i] eq '';
308 $i++ if $args->[$i] eq '';
314 while (defined $args->[$i]) {
315 $i++ while $self->_is_struct($args->[$i]);
317 last if not defined $args->[$i];
319 my ($key, $val) = split /=/, $args->[$i++], 2;
321 if ($self->_is_struct($val)) {
322 $loader_args{$key} = $val;
323 } elsif ((my @vals = split /,/ => $val) > 1) {
324 $loader_args{$key} = \@vals;
326 $loader_args{$key} = $val;
330 wantarray ? %loader_args : \%loader_args;
333 sub _build_helper_loader_args {
336 my $args = $self->loader_args;
338 tie my %loader_args, 'Tie::IxHash';
340 while (my ($arg, $val) = each %$args) {
342 $loader_args{$arg} = $self->_data_struct_to_string($val);
344 $loader_args{$arg} = qq{'$val'};
351 sub _build_loader_components {
352 my ($self, $components, $use_namespaces) = @_;
354 my @components = $self->old_schema && (not $use_namespaces) ? ()
355 : ('InflateColumn::DateTime');
358 $components = [ $components ] if !ref $components;
359 push @components, @$components;
362 wantarray ? @components : \@components;
365 sub _build_helper_connect_info {
366 my ($self, $connect_info) = @_;
368 my @connect_info = @$connect_info;
370 my ($dsn, $user, $password) = $self->_get_dsn_user_pass(\@connect_info);
372 tie my %helper_connect_info, 'Tie::IxHash';
374 %helper_connect_info = (
377 password => qq{'$password'}
380 for (@connect_info) {
381 if (/^\s*{.*}\s*\z/) {
382 my $hash = $self->_eval($_);
383 die "Syntax errorr in connect_info hash: $_: $@" if $@;
386 for my $key (keys %hash) {
387 my $val = $hash{$key};
390 $val = $self->_data_struct_to_string($val);
392 $val = $self->_quote($val);
395 $helper_connect_info{$key} = $val;
401 my ($key, $val) = split /=/, $_, 2;
403 if ($key eq 'quote_char') {
404 $helper_connect_info{$key} = length($val) == 1 ?
405 $self->_quote($val) :
406 $self->_data_struct_to_string([split //, $val]);
408 $helper_connect_info{$key} = $self->_quote_unless_struct($val);
412 \%helper_connect_info
415 sub _build_old_schema {
418 return $self->result_namespace eq '' ? 1 : 0;
421 sub _build_is_moose_schema {
424 my @schema_parts = split '::', $self->schema_class;
426 my $result_dir = File::Spec->catfile(
427 $self->helper->{base}, 'lib', @schema_parts, $self->result_namespace
430 # assume yes for new schemas
431 return 1 if not -d $result_dir;
439 return if $File::Find::name !~ /\.pm\z/;
441 open my $fh, '<', $File::Find::name
442 or die "Could not open $File::Find::name: $!";
444 my $code = do { local $/; <$fh> };
447 $uses_moose = 0 if $code !~ /\nuse Moose;\n/;
458 sub _build_result_namespace {
461 my @schema_parts = split '::', $self->schema_class;
463 File::Spec->catfile($self->helper->{base}, 'lib', @schema_parts) . '.pm';
465 if (not -f $schema_pm) {
466 eval { Class::MOP::load_class('DBIx::Class::Schema::Loader') };
468 return 'Result' if $@;
470 return (try { DBIx::Class::Schema::Loader->VERSION('0.05') }) ? 'Result' : '';
473 open my $fh, '<', $schema_pm or die "Could not open $schema_pm: $!";
474 my $code = do { local $/; <$fh> };
477 my ($result_namespace) = $code =~ /result_namespace => '([^']+)'/;
479 return $result_namespace if $result_namespace;
481 return '' if $code =~ /->load_classes/;
486 sub _data_struct_to_string {
487 my ($self, $data) = @_;
489 local $Data::Dumper::Terse = 1;
490 local $Data::Dumper::Quotekeys = 0;
491 local $Data::Dumper::Indent = 0;
492 local $Data::Dumper::Useqq = 1;
494 return Data::Dumper->Dump([$data]);
497 sub _get_dsn_user_pass {
498 my ($self, $connect_info) = @_;
500 my $dsn = shift @$connect_info;
501 my ($user, $password);
503 if ($dsn =~ /sqlite/i) {
504 ($user, $password) = ('', '');
505 shift @$connect_info while @$connect_info and $connect_info->[0] eq '';
507 ($user, $password) = splice @$connect_info, 0, 2;
510 ($dsn, $user, $password)
513 sub _parse_connect_info {
514 my ($self, $connect_info) = @_;
516 my @connect_info = @$connect_info;
518 my ($dsn, $user, $password) = $self->_get_dsn_user_pass(\@connect_info);
520 tie my %connect_info, 'Tie::IxHash';
521 @connect_info{qw/dsn user password/} = ($dsn, $user, $password);
523 for (@connect_info) {
524 if (/^\s*{.*}\s*\z/) {
525 my $hash = $self->_eval($_);
526 die "Syntax errorr in connect_info hash: $_: $@" if $@;
528 %connect_info = (%connect_info, %$hash);
533 my ($key, $val) = split /=/, $_, 2;
535 if ($key eq 'quote_char') {
536 $connect_info{$key} = length($val) == 1 ? $val : [split //, $val];
537 } elsif ($key =~ /^(?:name_sep|limit_dialect)\z/) {
538 $connect_info{$key} = $val;
540 $connect_info{$key} = $self->_eval($val);
543 die "syntax error for connect_info key '$key' with value '$val': $@"
547 $self->connect_info(\%connect_info);
553 my ($self, $val) = @_;
555 return $val =~ /^\s*(?:sub|[[{])/;
559 my ($self, $val) = @_;
561 return 'q{'.$val.'}';
564 sub _quote_unless_struct {
565 my ($self, $val) = @_;
567 $val = $self->_quote($val) if not $self->_is_struct($val);
573 my ($self, $code) = @_;
575 return $code if looks_like_number $code;
577 return $code if not $self->_is_struct($code);
579 return eval "{no strict; $code}";
582 sub _gen_dynamic_schema {
585 my $helper = $self->helper;
587 my @schema_parts = split(/\:\:/, $self->schema_class);
588 my $schema_file_part = pop @schema_parts;
590 my $schema_dir = File::Spec->catfile(
591 $helper->{base}, 'lib', @schema_parts
593 my $schema_file = File::Spec->catfile(
594 $schema_dir, $schema_file_part . '.pm'
597 $helper->mk_dir($schema_dir);
598 $helper->render_file('schemaclass', $schema_file);
601 sub _gen_static_schema {
604 die "cannot load schema without connect info" unless $self->connect_info;
606 my $helper = $self->helper;
608 my $schema_dir = File::Spec->catfile($helper->{base}, 'lib');
611 Class::MOP::load_class('DBIx::Class::Schema::Loader')
614 die "Cannot load DBIx::Class::Schema::Loader: $_";
617 DBIx::Class::Schema::Loader->import(
618 "dump_to_dir:$schema_dir", 'make_schema_at'
624 [$self->connect_info]
628 lib->import($schema_dir);
630 Class::MOP::load_class($self->schema_class);
632 my @sources = $self->schema_class->sources;
636 WARNING: No tables found, did you forget to specify db_schema?
643 my $helper = $self->helper;
645 $helper->render_file('compclass', $helper->{file} );
648 sub _print_dynamic_deprecation_warning {
650 ************************************ WARNING **********************************
651 * create=dynamic is DEPRECATED, please use create=static instead. *
652 *******************************************************************************
654 print "Continue? [y/n]: ";
655 chomp(my $response = <STDIN>);
656 exit 0 if $response =~ /^n(o)?\z/;
660 my ($self, $args) = @_;
662 # remove blanks, ie. someoned doing foo \ bar
663 my @res = grep !/^\s+\z/, @$args;
665 # remove leading whitespace, ie. foo \ bar
673 General Catalyst Stuff:
675 L<Catalyst::Manual>, L<Catalyst::Test>, L<Catalyst::Request>,
676 L<Catalyst::Response>, L<Catalyst::Helper>, L<Catalyst>,
678 Stuff related to DBIC and this Model style:
680 L<DBIx::Class>, L<DBIx::Class::Schema>,
681 L<DBIx::Class::Schema::Loader>, L<Catalyst::Model::DBIC::Schema>
685 See L<Catalyst::Model::DBIC::Schema/AUTHOR> and
686 L<Catalyst::Model::DBIC::Schema/CONTRIBUTORS>.
690 See L<Catalyst::Model::DBIC::Schema/COPYRIGHT>.
694 This library is free software, you can redistribute it and/or modify
695 it under the same terms as Perl itself.
706 package [% schema_class %];
709 use base qw/DBIx::Class::Schema::Loader/;
711 __PACKAGE__->loader_options(
712 [%- FOREACH key = loader_args.keys %]
713 [% key %] => [% loader_args.${key} %],
720 [% schema_class %] - L<DBIx::Class::Schema::Loader> class
728 Dynamic L<DBIx::Class::Schema::Loader> schema for use in L<[% class %]>
732 [% generator %] - [% generator_version %]
736 [% author.replace(',+$', '') %]
740 This library is free software, you can redistribute it and/or modify
741 it under the same terms as Perl itself.
751 use base 'Catalyst::Model::DBIC::Schema';
754 schema_class => '[% schema_class %]',
755 [% IF traits %]traits => [% traits %],[% END %]
756 [% IF setup_connect_info %]connect_info => {
757 [%- FOREACH key = connect_info.keys %]
758 [% key %] => [% connect_info.${key} %],
766 [% class %] - Catalyst DBIC Schema Model
774 L<Catalyst::Model::DBIC::Schema> Model using schema L<[% schema_class %]>
778 [% generator %] - [% generator_version %]
782 [% author.replace(',+$', '') %]
786 This library is free software, you can redistribute it and/or modify
787 it under the same terms as Perl itself.