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 my $have_loader = try {
315 Class::MOP::load_class('DBIx::Class::Schema::Loader::Base');
320 while (defined $args->[$i]) {
321 $i++ while $self->_is_struct($args->[$i]);
323 last if not defined $args->[$i];
325 my ($key, $val) = split /=/, $args->[$i], 2;
327 if (not DBIx::Class::Schema::Loader::Base->can($key)) {
332 if ($self->_is_struct($val)) {
333 $loader_args{$key} = $val;
334 } elsif ((my @vals = split /,/ => $val) > 1) {
335 $loader_args{$key} = \@vals;
337 $loader_args{$key} = $val;
340 splice @$args, $i, 1;
344 wantarray ? %loader_args : \%loader_args;
347 sub _build_helper_loader_args {
350 my $args = $self->loader_args;
352 tie my %loader_args, 'Tie::IxHash';
354 while (my ($arg, $val) = each %$args) {
356 $loader_args{$arg} = $self->_data_struct_to_string($val);
358 $loader_args{$arg} = qq{'$val'};
365 sub _build_loader_components {
366 my ($self, $components, $use_namespaces) = @_;
368 my @components = $self->old_schema && (not $use_namespaces) ? ()
369 : ('InflateColumn::DateTime');
372 $components = [ $components ] if !ref $components;
373 push @components, @$components;
376 wantarray ? @components : \@components;
379 sub _build_helper_connect_info {
380 my ($self, $connect_info) = @_;
382 my @connect_info = @$connect_info;
384 my ($dsn, $user, $password) = $self->_get_dsn_user_pass(\@connect_info);
386 tie my %helper_connect_info, 'Tie::IxHash';
388 %helper_connect_info = (
391 password => qq{'$password'}
394 for (@connect_info) {
395 if (/^\s*{.*}\s*\z/) {
396 my $hash = $self->_eval($_);
397 die "Syntax errorr in connect_info hash: $_: $@" if $@;
400 for my $key (keys %hash) {
401 my $val = $hash{$key};
404 $val = $self->_data_struct_to_string($val);
406 $val = $self->_quote($val);
409 $helper_connect_info{$key} = $val;
415 my ($key, $val) = split /=/, $_, 2;
417 if ($key eq 'quote_char') {
418 $helper_connect_info{$key} = length($val) == 1 ?
419 $self->_quote($val) :
420 $self->_data_struct_to_string([split //, $val]);
422 $helper_connect_info{$key} = $self->_quote_unless_struct($val);
426 \%helper_connect_info
429 sub _build_old_schema {
432 return $self->result_namespace eq '' ? 1 : 0;
435 sub _build_is_moose_schema {
438 my @schema_parts = split '::', $self->schema_class;
440 my $result_dir = File::Spec->catfile(
441 $self->helper->{base}, 'lib', @schema_parts, $self->result_namespace
444 # assume yes for new schemas
445 return 1 if not -d $result_dir;
453 return if $File::Find::name !~ /\.pm\z/;
455 open my $fh, '<', $File::Find::name
456 or die "Could not open $File::Find::name: $!";
458 my $code = do { local $/; <$fh> };
461 $uses_moose = 0 if $code !~ /\nuse Moose;\n/;
472 sub _build_result_namespace {
475 my @schema_parts = split '::', $self->schema_class;
477 File::Spec->catfile($self->helper->{base}, 'lib', @schema_parts) . '.pm';
479 if (not -f $schema_pm) {
480 eval { Class::MOP::load_class('DBIx::Class::Schema::Loader') };
482 return 'Result' if $@;
484 return (try { DBIx::Class::Schema::Loader->VERSION('0.05') }) ? 'Result' : '';
487 open my $fh, '<', $schema_pm or die "Could not open $schema_pm: $!";
488 my $code = do { local $/; <$fh> };
491 my ($result_namespace) = $code =~ /result_namespace => '([^']+)'/;
493 return $result_namespace if $result_namespace;
495 return '' if $code =~ /->load_classes/;
500 sub _data_struct_to_string {
501 my ($self, $data) = @_;
503 local $Data::Dumper::Terse = 1;
504 local $Data::Dumper::Quotekeys = 0;
505 local $Data::Dumper::Indent = 0;
506 local $Data::Dumper::Useqq = 1;
508 return Data::Dumper->Dump([$data]);
511 sub _get_dsn_user_pass {
512 my ($self, $connect_info) = @_;
514 my $dsn = shift @$connect_info;
515 my ($user, $password);
517 if ($dsn =~ /sqlite/i) {
518 ($user, $password) = ('', '');
519 shift @$connect_info while @$connect_info and $connect_info->[0] eq '';
521 ($user, $password) = splice @$connect_info, 0, 2;
524 ($dsn, $user, $password)
527 sub _parse_connect_info {
528 my ($self, $connect_info) = @_;
530 my @connect_info = @$connect_info;
532 my ($dsn, $user, $password) = $self->_get_dsn_user_pass(\@connect_info);
534 tie my %connect_info, 'Tie::IxHash';
535 @connect_info{qw/dsn user password/} = ($dsn, $user, $password);
537 for (@connect_info) {
538 if (/^\s*{.*}\s*\z/) {
539 my $hash = $self->_eval($_);
540 die "Syntax errorr in connect_info hash: $_: $@" if $@;
542 %connect_info = (%connect_info, %$hash);
547 my ($key, $val) = split /=/, $_, 2;
549 if ($key eq 'quote_char') {
550 $connect_info{$key} = length($val) == 1 ? $val : [split //, $val];
551 } elsif ($key =~ /^(?:name_sep|limit_dialect)\z/) {
552 $connect_info{$key} = $val;
554 $connect_info{$key} = $self->_eval($val);
557 die "syntax error for connect_info key '$key' with value '$val': $@"
561 $self->connect_info(\%connect_info);
567 my ($self, $val) = @_;
569 return $val =~ /^\s*(?:sub|[[{])/;
573 my ($self, $val) = @_;
575 return 'q{'.$val.'}';
578 sub _quote_unless_struct {
579 my ($self, $val) = @_;
581 $val = $self->_quote($val) if not $self->_is_struct($val);
587 my ($self, $code) = @_;
589 return $code if looks_like_number $code;
591 return $code if not $self->_is_struct($code);
593 return eval "{no strict; $code}";
596 sub _gen_dynamic_schema {
599 my $helper = $self->helper;
601 my @schema_parts = split(/\:\:/, $self->schema_class);
602 my $schema_file_part = pop @schema_parts;
604 my $schema_dir = File::Spec->catfile(
605 $helper->{base}, 'lib', @schema_parts
607 my $schema_file = File::Spec->catfile(
608 $schema_dir, $schema_file_part . '.pm'
611 $helper->mk_dir($schema_dir);
612 $helper->render_file('schemaclass', $schema_file);
615 sub _gen_static_schema {
618 die "cannot load schema without connect info" unless $self->connect_info;
620 my $helper = $self->helper;
622 my $schema_dir = File::Spec->catfile($helper->{base}, 'lib');
625 Class::MOP::load_class('DBIx::Class::Schema::Loader')
628 die "Cannot load DBIx::Class::Schema::Loader: $_";
631 DBIx::Class::Schema::Loader->import(
632 "dump_to_dir:$schema_dir", 'make_schema_at'
638 [$self->connect_info]
642 lib->import($schema_dir);
644 Class::MOP::load_class($self->schema_class);
646 my @sources = $self->schema_class->sources;
650 WARNING: No tables found, did you forget to specify db_schema?
657 my $helper = $self->helper;
659 $helper->render_file('compclass', $helper->{file} );
662 sub _print_dynamic_deprecation_warning {
664 ************************************ WARNING **********************************
665 * create=dynamic is DEPRECATED, please use create=static instead. *
666 *******************************************************************************
668 print "Continue? [y/n]: ";
669 chomp(my $response = <STDIN>);
670 exit 0 if $response =~ /^n(o)?\z/;
674 my ($self, $args) = @_;
676 # remove blanks, ie. someoned doing foo \ bar
677 my @res = grep !/^\s+\z/, @$args;
679 # remove leading whitespace, ie. foo \ bar
687 General Catalyst Stuff:
689 L<Catalyst::Manual>, L<Catalyst::Test>, L<Catalyst::Request>,
690 L<Catalyst::Response>, L<Catalyst::Helper>, L<Catalyst>,
692 Stuff related to DBIC and this Model style:
694 L<DBIx::Class>, L<DBIx::Class::Schema>,
695 L<DBIx::Class::Schema::Loader>, L<Catalyst::Model::DBIC::Schema>
699 See L<Catalyst::Model::DBIC::Schema/AUTHOR> and
700 L<Catalyst::Model::DBIC::Schema/CONTRIBUTORS>.
704 See L<Catalyst::Model::DBIC::Schema/COPYRIGHT>.
708 This library is free software, you can redistribute it and/or modify
709 it under the same terms as Perl itself.
720 package [% schema_class %];
723 use base qw/DBIx::Class::Schema::Loader/;
725 __PACKAGE__->loader_options(
726 [%- FOREACH key = loader_args.keys %]
727 [% key %] => [% loader_args.${key} %],
734 [% schema_class %] - L<DBIx::Class::Schema::Loader> class
742 Dynamic L<DBIx::Class::Schema::Loader> schema for use in L<[% class %]>
746 [% generator %] - [% generator_version %]
750 [% author.replace(',+$', '') %]
754 This library is free software, you can redistribute it and/or modify
755 it under the same terms as Perl itself.
765 use base 'Catalyst::Model::DBIC::Schema';
768 schema_class => '[% schema_class %]',
769 [% IF traits %]traits => [% traits %],[% END %]
770 [% IF setup_connect_info %]connect_info => {
771 [%- FOREACH key = connect_info.keys %]
772 [% key %] => [% connect_info.${key} %],
780 [% class %] - Catalyst DBIC Schema Model
788 L<Catalyst::Model::DBIC::Schema> Model using schema L<[% schema_class %]>
792 [% generator %] - [% generator_version %]
796 [% author.replace(',+$', '') %]
800 This library is free software, you can redistribute it and/or modify
801 it under the same terms as Perl itself.