[catagits/Catalyst-Model-DBIC-Schema.git] / lib / Catalyst / Helper / Model / DBIC / Schema.pm

package Catalyst::Helper::Model::DBIC::Schema;

use namespace::autoclean;
use Moose;
no warnings 'uninitialized';

our $VERSION = '0.43';
$VERSION = eval $VERSION;

use Carp;
use Tie::IxHash ();
use Data::Dumper ();
use List::Util 'first';
use MooseX::Types::Moose qw/Str HashRef Bool ArrayRef/;
use Catalyst::Model::DBIC::Schema::Types 'CreateOption';
use List::MoreUtils 'firstidx';
use Scalar::Util 'looks_like_number';

=head1 NAME

Catalyst::Helper::Model::DBIC::Schema - Helper for DBIC Schema Models

=head1 SYNOPSIS

  script/create.pl model CatalystModelName DBIC::Schema MyApp::SchemaClass \
    [ create=dynamic | create=static ] [ traits=trait1,trait2... ] \
    [ Schema::Loader opts ] [ dsn user pass ] \
    [ other connect_info args ]

=head1 DESCRIPTION

Helper for the DBIC Schema Models.

=head2 Arguments:

C<CatalystModelName> is the short name for the Catalyst Model class
being generated (i.e. callable with C<$c-E<gt>model('CatalystModelName')>).

C<MyApp::SchemaClass> is the fully qualified classname of your Schema,
which might or might not yet exist.  Note that you should have a good
reason to create this under a new global namespace, otherwise use an
existing top level namespace for your schema class.

C<create=dynamic> instructs this Helper to generate the named Schema
class for you, basing it on L<DBIx::Class::Schema::Loader> (which
means the table information will always be dynamically loaded at
runtime from the database).

C<create=static> instructs this Helper to generate the named Schema
class for you, using L<DBIx::Class::Schema::Loader> in "one shot"
mode to create a standard, manually-defined L<DBIx::Class::Schema>
setup, based on what the Loader sees in your database at this moment.
A Schema/Model pair generated this way will not require
L<DBIx::Class::Schema::Loader> at runtime, and will not automatically
adapt itself to changes in your database structure.  You can edit
the generated classes by hand to refine them.

C<traits> is the list of traits to apply to the model, see
L<Catalyst::Model::DBIC::Schema> for details.

C<Schema::Loader opts> are described in L</TYPICAL EXAMPLES> below.

C<connect_info> arguments are the same as what
DBIx::Class::Schema::connect expects, and are storage_type-specific.
For DBI-based storage, these arguments are the dsn, username,
password, and connect options, respectively.  These are optional for
existing Schemas, but required if you use either of the C<create=>
options.

username and password can be omitted for C<SQLite> dsns.

Use of either of the C<create=> options requires L<DBIx::Class::Schema::Loader>.

=head1 TYPICAL EXAMPLES

Use DBIx::Class::Schema::Loader to create a static DBIx::Class::Schema,
and a Model which references it:

  script/myapp_create.pl model CatalystModelName DBIC::Schema \
    MyApp::SchemaClass create=static dbi:mysql:foodb myuname mypass

Same, with extra connect_info args
user and pass can be omitted for sqlite, since they are always empty

  script/myapp_create.pl model CatalystModelName DBIC::Schema \
    MyApp::SchemaClass create=static dbi:SQLite:foo.db \
    AutoCommit=1 cursor_class=DBIx::Class::Cursor::Cached \
    on_connect_do='["select 1", "select 2"]' quote_char='"'

If using a 2 character quote_char:

  script/myapp_create.pl ... quote_char='[]'

B<ON WINDOWS COMMAND LINES QUOTING RULES ARE DIFFERENT>

In C<cmd.exe> the above example would be:

  script/myapp_create.pl model CatalystModelName DBIC::Schema \
    MyApp::SchemaClass create=static dbi:SQLite:foo.db \
    AutoCommit=1 cursor_class=DBIx::Class::Cursor::Cached \
    on_connect_do="[\"select 1\", \"select 2\"]" quote_char="\""

Same, but with extra Schema::Loader args (separate multiple values by commas):

  script/myapp_create.pl model CatalystModelName DBIC::Schema \
    MyApp::SchemaClass create=static db_schema=foodb components=Foo,Bar \
    exclude='^(wibble|wobble)$' moniker_map='{ foo => "FOO" }' \
    dbi:Pg:dbname=foodb myuname mypass

Coderefs are also supported:

  script/myapp_create.pl model CatalystModelName DBIC::Schema \
    MyApp::SchemaClass create=static \
    inflect_singular='sub { $_[0] =~ /\A(.+?)(_id)?\z/; $1 }' \
    moniker_map='sub { join(q{}, map ucfirst, split(/[\W_]+/, lc $_[0])); }' \
    dbi:mysql:foodb myuname mypass

See L<DBIx::Class::Schema::Loader::Base> for a list of options

Create a dynamic DBIx::Class::Schema::Loader-based Schema,
and a Model which references it (B<DEPRECATED>):

  script/myapp_create.pl model CatalystModelName DBIC::Schema \
    MyApp::SchemaClass create=dynamic dbi:mysql:foodb myuname mypass

Reference an existing Schema of any kind, and provide some connection information for ->config:

  script/myapp_create.pl model CatalystModelName DBIC::Schema \
    MyApp::SchemaClass dbi:mysql:foodb myuname mypass

Same, but don't supply connect information yet (you'll need to do this
in your app config, or [not recommended] in the schema itself).

  script/myapp_create.pl model ModelName DBIC::Schema My::SchemaClass

=cut

has helper => (is => 'ro', isa => 'Catalyst::Helper', required => 1);
has create => (is => 'rw', isa => CreateOption);
has args => (is => 'ro', isa => ArrayRef);
has traits => (is => 'rw', isa => ArrayRef);
has schema_class => (is => 'ro', isa => Str, required => 1);
has loader_args => (is => 'rw', isa => HashRef);
has connect_info => (is => 'rw', isa => HashRef);
has old_schema => (is => 'rw', isa => Bool, lazy_build => 1);
has components => (is => 'rw', isa => ArrayRef);

=head1 METHODS

=head2 mk_compclass

This is called by L<Catalyst::Helper> with the commandline args to generate the
files.

=cut

sub mk_compclass {
    my ($package, $helper, $schema_class, @args) = @_;

    my $self = $package->new(
        helper => $helper,
        schema_class => $schema_class,
        args => \@args
    );

    $self->run;
}

sub BUILD {
    my $self   = shift;
    my $helper = $self->helper;
    my @args   = @{ $self->args || [] };

    $helper->{schema_class} = $self->schema_class;

    @args = $self->_cleanup_args(\@args);

    my ($traits_idx, $traits);
    if (($traits_idx = firstidx { ($traits) = /^traits=(\S*)\z/ } @args) != -1) {
        my @traits = split /,/ => $traits;

        $self->traits(\@traits);

        $helper->{traits} = '['
            .(join ',' => map { qq{'$_'} } @traits)
            .']';

        splice @args, $traits_idx, 1, ();
    }

    if ($args[0] && $args[0] =~ /^create=(\S*)\z/) {
        $self->create($1);
        shift @args;

        if (@args) {
            $self->_parse_loader_args(\@args);

            $helper->{loader_args} = $self->_build_helper_loader_args;
        }
    }

    my $dbi_dsn_part;
    if (first { ($dbi_dsn_part) = /^(dbi):/i } @args) {
        die
qq{DSN must start with 'dbi:' not '$dbi_dsn_part' (case matters!)}
            if $dbi_dsn_part ne 'dbi';

        $helper->{setup_connect_info} = 1;

        $helper->{connect_info} =
            $self->_build_helper_connect_info(\@args);

        $self->_parse_connect_info(\@args);
    }

    $helper->{generator} = ref $self;
    $helper->{generator_version} = $VERSION;
}

=head2 run

Can be called on an instance to generate the files.

=cut

sub run {
    my $self = shift;

    if ($self->create eq 'dynamic') {
        $self->_print_dynamic_deprecation_warning;
        $self->_gen_dynamic_schema;
    } elsif ($self->create eq 'static') {
        $self->_gen_static_schema;
    }

    $self->_gen_model;
}

sub _parse_loader_args {
    my ($self, $args) = @_;

    my %loader_args = $self->_read_loader_args($args);

    while (my ($key, $val) = each %loader_args) {
        next if $key =~ /^(?:components|constraint|exclude)\z/;

        $loader_args{$key} = $self->_eval($val);
        die "syntax error for loader args key '$key' with value '$val': $@"
            if $@;
    }

    my @components = $self->_build_loader_components(
        delete $loader_args{components},
        $loader_args{use_namespaces},
    );

    $self->components(\@components);

    for my $re_opt (qw/constraint exclude/) {
        $loader_args{$re_opt} = qr/$loader_args{$re_opt}/
        if exists $loader_args{$re_opt};
    }

    tie my %result, 'Tie::IxHash';

    %result = (
        relationships => 1,
        use_moose => 1,
        (!$self->old_schema ? (
                use_namespaces => 1
            ) : ()),
        (@components ? (
                components => \@components
            ) : ()),
        (%loader_args ? %loader_args : ()),
    );

    $self->loader_args(\%result);

    wantarray ? %result : \%result;
}

sub _read_loader_args {
    my ($self, $args) = @_;

    my %loader_args;

    while (@$args && $args->[0] !~ /^dbi:/i) {
        my ($key, $val) = split /=/, shift(@$args), 2;

        if ($self->_is_struct($val)) {
            $loader_args{$key} = $val;
        } elsif ((my @vals = split /,/ => $val) > 1) {
            $loader_args{$key} = \@vals;
        } else {
            $loader_args{$key} = $val;
        }
    }

    wantarray ? %loader_args : \%loader_args;
}

sub _build_helper_loader_args {
    my $self = shift;

    my $args = $self->loader_args;

    tie my %loader_args, 'Tie::IxHash';

    while (my ($arg, $val) = each %$args) {
        if (ref $val) {
            $loader_args{$arg} = $self->_data_struct_to_string($val);
        } else {
            $loader_args{$arg} = qq{'$val'};
        }
    }

    \%loader_args
}

sub _build_loader_components {
    my ($self, $components, $use_namespaces) = @_;

    my @components = $self->old_schema && (not $use_namespaces) ? ()
        : ('InflateColumn::DateTime');

    if ($components) {
        $components = [ $components ] if !ref $components;
        push @components, @$components;
    }

    wantarray ? @components : \@components;
}

sub _build_helper_connect_info {
    my ($self, $connect_info) = @_;

    my @connect_info = @$connect_info;

    my ($dsn, $user, $password) = $self->_get_dsn_user_pass(\@connect_info);

    tie my %helper_connect_info, 'Tie::IxHash';

    %helper_connect_info = (
        dsn => qq{'$dsn'},
        user => qq{'$user'},
        password => qq{'$password'}
    );

    for (@connect_info) {
        if (/^\s*{.*}\s*\z/) {
            my $hash = $self->_eval($_);
            die "Syntax errorr in connect_info hash: $_: $@" if $@;
            my %hash = %$hash;

            for my $key (keys %hash) {
                my $val = $hash{$key};

                if (ref $val) {
                    $val = $self->_data_struct_to_string($val);
                } else {
                    $val = $self->_quote($val);
                }

                $helper_connect_info{$key} = $val;
            }

            next;
        }

        my ($key, $val) = split /=/, $_, 2;

        if ($key eq 'quote_char') {
            $helper_connect_info{$key} = length($val) == 1 ?
                $self->_quote($val) :
                $self->_data_struct_to_string([split //, $val]);
        } else {
            $helper_connect_info{$key} = $self->_quote_unless_struct($val);
        }
    }

    \%helper_connect_info
}

sub _build_old_schema {
    my $self = shift;

    my @schema_pm   = split '::', $self->schema_class;
    $schema_pm[-1] .= '.pm';
    my $schema_file =
    File::Spec->catfile($self->helper->{base}, 'lib', @schema_pm);

    if (-f $schema_file) {
        my $schema_code = do { local (@ARGV, $/) = $schema_file; <> };
        return 1 if $schema_code =~ /->load_classes/;
    }

    0;
}

sub _data_struct_to_string {
    my ($self, $data) = @_;

    local $Data::Dumper::Terse = 1;
    local $Data::Dumper::Quotekeys = 0;
    local $Data::Dumper::Indent = 0;
    local $Data::Dumper::Useqq = 1;

    return Data::Dumper->Dump([$data]);
}

sub _get_dsn_user_pass {
    my ($self, $connect_info) = @_;

    my $dsn = shift @$connect_info;
    my ($user, $password);

    if ($dsn =~ /sqlite/i) {
        ($user, $password) = ('', '');
        shift @$connect_info while @$connect_info and $connect_info->[0] eq '';
    } else {
        ($user, $password) = splice @$connect_info, 0, 2;
    }
    
    ($dsn, $user, $password)
}

sub _parse_connect_info {
    my ($self, $connect_info) = @_;

    my @connect_info = @$connect_info;

    my ($dsn, $user, $password) = $self->_get_dsn_user_pass(\@connect_info);

    tie my %connect_info, 'Tie::IxHash';
    @connect_info{qw/dsn user password/} = ($dsn, $user, $password);

    for (@connect_info) {
        if (/^\s*{.*}\s*\z/) {
            my $hash = $self->_eval($_);
            die "Syntax errorr in connect_info hash: $_: $@" if $@;

            %connect_info = (%connect_info, %$hash);

            next;
        }

        my ($key, $val) = split /=/, $_, 2;

        if ($key eq 'quote_char') {
            $connect_info{$key} = length($val) == 1 ? $val : [split //, $val];
        } elsif ($key =~ /^(?:name_sep|limit_dialect)\z/) {
            $connect_info{$key} = $val;
        } else {
            $connect_info{$key} = $self->_eval($val);
        }

        die "syntax error for connect_info key '$key' with value '$val': $@"
            if $@;
    }

    $self->connect_info(\%connect_info);

    \%connect_info
}

sub _is_struct {
    my ($self, $val) = @_;

    return $val =~ /^\s*(?:sub|[[{])/;
}

sub _quote {
    my ($self, $val) = @_;

    return 'q{'.$val.'}';
}

sub _quote_unless_struct {
    my ($self, $val) = @_;

    $val = $self->_quote($val) if not $self->_is_struct($val);

    return $val;
}

sub _eval {
    my ($self, $code) = @_;

    return $code if looks_like_number $code;

    return $code if not $self->_is_struct($code);

    return eval "{no strict; $code}";
}

sub _gen_dynamic_schema {
    my $self = shift;

    my $helper = $self->helper;

    my @schema_parts = split(/\:\:/, $self->schema_class);
    my $schema_file_part = pop @schema_parts;

    my $schema_dir  = File::Spec->catfile(
        $helper->{base}, 'lib', @schema_parts
    );
    my $schema_file = File::Spec->catfile(
        $schema_dir, $schema_file_part . '.pm'
    );

    $helper->mk_dir($schema_dir);
    $helper->render_file('schemaclass', $schema_file);
}

sub _gen_static_schema {
    my $self = shift;

    die "cannot load schema without connect info" unless $self->connect_info;

    my $helper = $self->helper;

    my $schema_dir = File::Spec->catfile($helper->{base}, 'lib');

    eval { Class::MOP::load_class('DBIx::Class::Schema::Loader') };
    die "Cannot load DBIx::Class::Schema::Loader: $@" if $@;

    DBIx::Class::Schema::Loader->import(
        "dump_to_dir:$schema_dir", 'make_schema_at'
    );

    make_schema_at(
        $self->schema_class,
        $self->loader_args,
        [$self->connect_info]
    );
}

sub _gen_model {
    my $self = shift;
    my $helper = $self->helper;

    $helper->render_file('compclass', $helper->{file} );
}

sub _print_dynamic_deprecation_warning {
    warn <<EOF;
************************************ WARNING **********************************
* create=dynamic is DEPRECATED, please use create=static instead.             *
*******************************************************************************
EOF
    print "Continue? [y/n]: ";
    chomp(my $response = <STDIN>);
    exit 0 if $response =~ /^n(o)?\z/;
}

sub _cleanup_args {
    my ($self, $args) = @_;

# remove blanks, ie. someoned doing foo \  bar
    my @res = grep !/^\s+\z/, @$args;

# remove leading whitespace, ie. foo \ bar
    s/^\s*// for @res;

    @res
}

=head1 SEE ALSO

General Catalyst Stuff:

L<Catalyst::Manual>, L<Catalyst::Test>, L<Catalyst::Request>,
L<Catalyst::Response>, L<Catalyst::Helper>, L<Catalyst>,

Stuff related to DBIC and this Model style:

L<DBIx::Class>, L<DBIx::Class::Schema>,
L<DBIx::Class::Schema::Loader>, L<Catalyst::Model::DBIC::Schema>

=head1 AUTHOR

See L<Catalyst::Model::DBIC::Schema/AUTHOR> and
L<Catalyst::Model::DBIC::Schema/CONTRIBUTORS>.

=head1 COPYRIGHT

See L<Catalyst::Model::DBIC::Schema/COPYRIGHT>.

=head1 LICENSE

This library is free software, you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

1;

__DATA__

=begin pod_to_ignore

__schemaclass__
package [% schema_class %];

use strict;
use base qw/DBIx::Class::Schema::Loader/;

__PACKAGE__->loader_options(
    [%- FOREACH key = loader_args.keys %]
    [% key %] => [% loader_args.${key} %],
    [%- END -%]

);

=head1 NAME

[% schema_class %] - L<DBIx::Class::Schema::Loader> class

=head1 SYNOPSIS

See L<[% app %]>

=head1 DESCRIPTION

Dynamic L<DBIx::Class::Schema::Loader> schema for use in L<[% class %]>

=head1 GENERATED BY

[% generator %] - [% generator_version %]

=head1 AUTHOR

[% author.replace(',+$', '') %]

=head1 LICENSE

This library is free software, you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

1;

__compclass__
package [% class %];

use strict;
use base 'Catalyst::Model::DBIC::Schema';

__PACKAGE__->config(
    schema_class => '[% schema_class %]',
    [% IF traits %]traits => [% traits %],[% END %]
    [% IF setup_connect_info %]connect_info => {
        [%- FOREACH key = connect_info.keys %]
        [% key %] => [% connect_info.${key} %],
        [%- END -%]

    }[% END %]
);

=head1 NAME

[% class %] - Catalyst DBIC Schema Model

=head1 SYNOPSIS

See L<[% app %]>

=head1 DESCRIPTION

L<Catalyst::Model::DBIC::Schema> Model using schema L<[% schema_class %]>

=head1 GENERATED BY

[% generator %] - [% generator_version %]

=head1 AUTHOR

[% author.replace(',+$', '') %]

=head1 LICENSE

This library is free software, you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

1;
__END__
# vim:sts=4 sw=4:
Commit	Line	Data
ad91060a	1	package Catalyst::Helper::Model::DBIC::Schema;
ad91060a	2
73f72d28	3	use namespace::autoclean;
f090a149	4	use Moose;
ffbf1967	5	no warnings 'uninitialized';
018eb0e2	6
fdbe669e	7	our $VERSION = '0.43';
4e251d1a	8	$VERSION = eval $VERSION;
2201c2e4	9
0f2fd2c0	10	use Carp;
2201c2e4	11	use Tie::IxHash ();
2201c2e4	12	use Data::Dumper ();
c4fee9b8	13	use List::Util 'first';
4cbe63e7	14	use MooseX::Types::Moose qw/Str HashRef Bool ArrayRef/;
4cbe63e7	15	use Catalyst::Model::DBIC::Schema::Types 'CreateOption';
4cbe63e7	16	use List::MoreUtils 'firstidx';
5f9a34d7	17	use Scalar::Util 'looks_like_number';
2201c2e4	18
ad91060a	19	=head1 NAME
	20
	21	Catalyst::Helper::Model::DBIC::Schema - Helper for DBIC Schema Models
	22
	23	=head1 SYNOPSIS
	24
2201c2e4	25	script/create.pl model CatalystModelName DBIC::Schema MyApp::SchemaClass \
c34bcab6	26	[ create=dynamic \| create=static ] [ traits=trait1,trait2... ] \
2ff00e2b	27	[ Schema::Loader opts ] [ dsn user pass ] \
2ff00e2b	28	[ other connect_info args ]
0f2fd2c0	29
d89e6c8a	30	=head1 DESCRIPTION
	31
	32	Helper for the DBIC Schema Models.
	33
	34	=head2 Arguments:
	35
018eb0e2	36	C<CatalystModelName> is the short name for the Catalyst Model class
018eb0e2	37	being generated (i.e. callable with C<$c-E<gt>model('CatalystModelName')>).
6116daed	38
018eb0e2	39	C<MyApp::SchemaClass> is the fully qualified classname of your Schema,
6116daed	40	which might or might not yet exist. Note that you should have a good
	41	reason to create this under a new global namespace, otherwise use an
	42	existing top level namespace for your schema class.
	43
018eb0e2	44	C<create=dynamic> instructs this Helper to generate the named Schema
6116daed	45	class for you, basing it on L<DBIx::Class::Schema::Loader> (which
	46	means the table information will always be dynamically loaded at
	47	runtime from the database).
	48
018eb0e2	49	C<create=static> instructs this Helper to generate the named Schema
6116daed	50	class for you, using L<DBIx::Class::Schema::Loader> in "one shot"
	51	mode to create a standard, manually-defined L<DBIx::Class::Schema>
	52	setup, based on what the Loader sees in your database at this moment.
	53	A Schema/Model pair generated this way will not require
	54	L<DBIx::Class::Schema::Loader> at runtime, and will not automatically
	55	adapt itself to changes in your database structure. You can edit
	56	the generated classes by hand to refine them.
	57
c34bcab6	58	C<traits> is the list of traits to apply to the model, see
2ff00e2b	59	L<Catalyst::Model::DBIC::Schema> for details.
	60
	61	C<Schema::Loader opts> are described in L</TYPICAL EXAMPLES> below.
	62
018eb0e2	63	C<connect_info> arguments are the same as what
6116daed	64	DBIx::Class::Schema::connect expects, and are storage_type-specific.
	65	For DBI-based storage, these arguments are the dsn, username,
	66	password, and connect options, respectively. These are optional for
	67	existing Schemas, but required if you use either of the C<create=>
	68	options.
d89e6c8a	69
a75b6e58	70	username and password can be omitted for C<SQLite> dsns.
a75b6e58	71
d89e6c8a	72	Use of either of the C<create=> options requires L<DBIx::Class::Schema::Loader>.
0b2a7108	73
	74	=head1 TYPICAL EXAMPLES
	75
a75b6e58	76	Use DBIx::Class::Schema::Loader to create a static DBIx::Class::Schema,
	77	and a Model which references it:
	78
2201c2e4	79	script/myapp_create.pl model CatalystModelName DBIC::Schema \
	80	MyApp::SchemaClass create=static dbi:mysql:foodb myuname mypass
	81
a75b6e58	82	Same, with extra connect_info args
	83	user and pass can be omitted for sqlite, since they are always empty
	84
2201c2e4	85	script/myapp_create.pl model CatalystModelName DBIC::Schema \
a75b6e58	86	MyApp::SchemaClass create=static dbi:SQLite:foo.db \
2201c2e4	87	AutoCommit=1 cursor_class=DBIx::Class::Cursor::Cached \
a75b6e58	88	on_connect_do='["select 1", "select 2"]' quote_char='"'
a75b6e58	89
c34bcab6	90	If using a 2 character quote_char:
	91
	92	script/myapp_create.pl ... quote_char='[]'
	93
a75b6e58	94	B<ON WINDOWS COMMAND LINES QUOTING RULES ARE DIFFERENT>
	95
	96	In C<cmd.exe> the above example would be:
	97
	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_char="\""
	102
	103	Same, but with extra Schema::Loader args (separate multiple values by commas):
0b2a7108	104
2201c2e4	105	script/myapp_create.pl model CatalystModelName DBIC::Schema \
2201c2e4	106	MyApp::SchemaClass create=static db_schema=foodb components=Foo,Bar \
4cbe63e7	107	exclude='^(wibble\|wobble)$' moniker_map='{ foo => "FOO" }' \
2201c2e4	108	dbi:Pg:dbname=foodb myuname mypass
34f036a0	109
ce9e19dc	110	Coderefs are also supported:
	111
	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
	117
a75b6e58	118	See L<DBIx::Class::Schema::Loader::Base> for a list of options
	119
	120	Create a dynamic DBIx::Class::Schema::Loader-based Schema,
	121	and a Model which references it (B<DEPRECATED>):
34f036a0	122
2201c2e4	123	script/myapp_create.pl model CatalystModelName DBIC::Schema \
2201c2e4	124	MyApp::SchemaClass create=dynamic dbi:mysql:foodb myuname mypass
ad91060a	125
a75b6e58	126	Reference an existing Schema of any kind, and provide some connection information for ->config:
a75b6e58	127
2201c2e4	128	script/myapp_create.pl model CatalystModelName DBIC::Schema \
2201c2e4	129	MyApp::SchemaClass dbi:mysql:foodb myuname mypass
ad91060a	130
a75b6e58	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).
	133
d89e6c8a	134	script/myapp_create.pl model ModelName DBIC::Schema My::SchemaClass
ad91060a	135
f090a149	136	=cut
	137
	138	has helper => (is => 'ro', isa => 'Catalyst::Helper', required => 1);
4cbe63e7	139	has create => (is => 'rw', isa => CreateOption);
4cbe63e7	140	has args => (is => 'ro', isa => ArrayRef);
c34bcab6	141	has traits => (is => 'rw', isa => ArrayRef);
61ed82a5	142	has schema_class => (is => 'ro', isa => Str, required => 1);
61ed82a5	143	has loader_args => (is => 'rw', isa => HashRef);
61ed82a5	144	has connect_info => (is => 'rw', isa => HashRef);
61ed82a5	145	has old_schema => (is => 'rw', isa => Bool, lazy_build => 1);
4cbe63e7	146	has components => (is => 'rw', isa => ArrayRef);
f090a149	147
018eb0e2	148	=head1 METHODS
ad91060a	149
018eb0e2	150	=head2 mk_compclass
ad91060a	151
0fbbc8d5	152	This is called by L<Catalyst::Helper> with the commandline args to generate the
	153	files.
	154
ad91060a	155	=cut
	156
	157	sub mk_compclass {
2201c2e4	158	my ($package, $helper, $schema_class, @args) = @_;
2201c2e4	159
4cbe63e7	160	my $self = $package->new(
	161	helper => $helper,
	162	schema_class => $schema_class,
	163	args => \@args
	164	);
0f2fd2c0	165
4cbe63e7	166	$self->run;
	167	}
	168
	169	sub BUILD {
	170	my $self = shift;
	171	my $helper = $self->helper;
7dfd616a	172	my @args = @{ $self->args \|\| [] };
4cbe63e7	173
4cbe63e7	174	$helper->{schema_class} = $self->schema_class;
c4fee9b8	175
c4fee9b8	176	@args = $self->_cleanup_args(\@args);
d89e6c8a	177
c34bcab6	178	my ($traits_idx, $traits);
	179	if (($traits_idx = firstidx { ($traits) = /^traits=(\S*)\z/ } @args) != -1) {
	180	my @traits = split /,/ => $traits;
2201c2e4	181
c34bcab6	182	$self->traits(\@traits);
4cbe63e7	183
c34bcab6	184	$helper->{traits} = '['
7dfd616a	185	.(join ',' => map { qq{'$_'} } @traits)
4cbe63e7	186	.']';
4cbe63e7	187
c34bcab6	188	splice @args, $traits_idx, 1, ();
4cbe63e7	189	}
	190
	191	if ($args[0] && $args[0] =~ /^create=(\S*)\z/) {
	192	$self->create($1);
	193	shift @args;
2ff00e2b	194
2201c2e4	195	if (@args) {
	196	$self->_parse_loader_args(\@args);
	197
4cbe63e7	198	$helper->{loader_args} = $self->_build_helper_loader_args;
ca7cf6f0	199	}
ca7cf6f0	200	}
4cbe63e7	201
ca7cf6f0	202	my $dbi_dsn_part;
	203	if (first { ($dbi_dsn_part) = /^(dbi):/i } @args) {
	204	die
a4803ca6	205	qq{DSN must start with 'dbi:' not '$dbi_dsn_part' (case matters!)}
ca7cf6f0	206	if $dbi_dsn_part ne 'dbi';
a4803ca6	207
ca7cf6f0	208	$helper->{setup_connect_info} = 1;
2201c2e4	209
ca7cf6f0	210	$helper->{connect_info} =
ca7cf6f0	211	$self->_build_helper_connect_info(\@args);
2201c2e4	212
ca7cf6f0	213	$self->_parse_connect_info(\@args);
d89e6c8a	214	}
0f2fd2c0	215
2201c2e4	216	$helper->{generator} = ref $self;
2201c2e4	217	$helper->{generator_version} = $VERSION;
4cbe63e7	218	}
4cbe63e7	219
9f7cc709	220	=head2 run
	221
	222	Can be called on an instance to generate the files.
	223
	224	=cut
	225
4cbe63e7	226	sub run {
4cbe63e7	227	my $self = shift;
2201c2e4	228
4cbe63e7	229	if ($self->create eq 'dynamic') {
c4fee9b8	230	$self->_print_dynamic_deprecation_warning;
2201c2e4	231	$self->_gen_dynamic_schema;
4cbe63e7	232	} elsif ($self->create eq 'static') {
2201c2e4	233	$self->_gen_static_schema;
	234	}
	235
	236	$self->_gen_model;
	237	}
	238
	239	sub _parse_loader_args {
	240	my ($self, $args) = @_;
	241
	242	my %loader_args = $self->_read_loader_args($args);
	243
	244	while (my ($key, $val) = each %loader_args) {
	245	next if $key =~ /^(?:components\|constraint\|exclude)\z/;
	246
5f9a34d7	247	$loader_args{$key} = $self->_eval($val);
c4fee9b8	248	die "syntax error for loader args key '$key' with value '$val': $@"
2201c2e4	249	if $@;
	250	}
	251
7e6a622c	252	my @components = $self->_build_loader_components(
	253	delete $loader_args{components},
	254	$loader_args{use_namespaces},
	255	);
2201c2e4	256
4cbe63e7	257	$self->components(\@components);
4cbe63e7	258
2201c2e4	259	for my $re_opt (qw/constraint exclude/) {
	260	$loader_args{$re_opt} = qr/$loader_args{$re_opt}/
	261	if exists $loader_args{$re_opt};
	262	}
	263
	264	tie my %result, 'Tie::IxHash';
	265
	266	%result = (
	267	relationships => 1,
4f907946	268	use_moose => 1,
f090a149	269	(!$self->old_schema ? (
2201c2e4	270	use_namespaces => 1
	271	) : ()),
	272	(@components ? (
	273	components => \@components
7e6a622c	274	) : ()),
7e6a622c	275	(%loader_args ? %loader_args : ()),
2201c2e4	276	);
	277
	278	$self->loader_args(\%result);
	279
	280	wantarray ? %result : \%result;
	281	}
	282
	283	sub _read_loader_args {
	284	my ($self, $args) = @_;
	285
	286	my %loader_args;
	287
a4803ca6	288	while (@$args && $args->[0] !~ /^dbi:/i) {
2201c2e4	289	my ($key, $val) = split /=/, shift(@$args), 2;
ca14239e	290
4cbe63e7	291	if ($self->_is_struct($val)) {
	292	$loader_args{$key} = $val;
	293	} elsif ((my @vals = split /,/ => $val) > 1) {
2201c2e4	294	$loader_args{$key} = \@vals;
ca14239e	295	} else {
2201c2e4	296	$loader_args{$key} = $val;
ca14239e	297	}
	298	}
	299
2201c2e4	300	wantarray ? %loader_args : \%loader_args;
	301	}
	302
	303	sub _build_helper_loader_args {
	304	my $self = shift;
	305
	306	my $args = $self->loader_args;
	307
	308	tie my %loader_args, 'Tie::IxHash';
	309
	310	while (my ($arg, $val) = each %$args) {
	311	if (ref $val) {
	312	$loader_args{$arg} = $self->_data_struct_to_string($val);
	313	} else {
	314	$loader_args{$arg} = qq{'$val'};
0b2a7108	315	}
0f2fd2c0	316	}
0f2fd2c0	317
2201c2e4	318	\%loader_args
	319	}
	320
	321	sub _build_loader_components {
7e6a622c	322	my ($self, $components, $use_namespaces) = @_;
d89e6c8a	323
7e6a622c	324	my @components = $self->old_schema && (not $use_namespaces) ? ()
7e6a622c	325	: ('InflateColumn::DateTime');
d89e6c8a	326
2201c2e4	327	if ($components) {
	328	$components = [ $components ] if !ref $components;
	329	push @components, @$components;
d89e6c8a	330	}
2201c2e4	331
	332	wantarray ? @components : \@components;
	333	}
	334
	335	sub _build_helper_connect_info {
	336	my ($self, $connect_info) = @_;
	337
	338	my @connect_info = @$connect_info;
	339
a75b6e58	340	my ($dsn, $user, $password) = $self->_get_dsn_user_pass(\@connect_info);
2201c2e4	341
	342	tie my %helper_connect_info, 'Tie::IxHash';
	343
	344	%helper_connect_info = (
	345	dsn => qq{'$dsn'},
	346	user => qq{'$user'},
	347	password => qq{'$password'}
	348	);
	349
	350	for (@connect_info) {
	351	if (/^\s{.}\s*\z/) {
5f9a34d7	352	my $hash = $self->_eval($_);
c4fee9b8	353	die "Syntax errorr in connect_info hash: $_: $@" if $@;
2201c2e4	354	my %hash = %$hash;
	355
	356	for my $key (keys %hash) {
	357	my $val = $hash{$key};
	358
	359	if (ref $val) {
	360	$val = $self->_data_struct_to_string($val);
	361	} else {
c34bcab6	362	$val = $self->_quote($val);
2201c2e4	363	}
	364
	365	$helper_connect_info{$key} = $val;
592cd3ae	366	}
2201c2e4	367
2201c2e4	368	next;
592cd3ae	369	}
592cd3ae	370
2201c2e4	371	my ($key, $val) = split /=/, $_, 2;
1d155058	372
c34bcab6	373	if ($key eq 'quote_char') {
	374	$helper_connect_info{$key} = length($val) == 1 ?
	375	$self->_quote($val) :
	376	$self->_data_struct_to_string([split //, $val]);
	377	} else {
	378	$helper_connect_info{$key} = $self->_quote_unless_struct($val);
	379	}
2201c2e4	380	}
1d155058	381
2201c2e4	382	\%helper_connect_info
2201c2e4	383	}
1d155058	384
61ed82a5	385	sub _build_old_schema {
	386	my $self = shift;
	387
	388	my @schema_pm = split '::', $self->schema_class;
	389	$schema_pm[-1] .= '.pm';
	390	my $schema_file =
	391	File::Spec->catfile($self->helper->{base}, 'lib', @schema_pm);
	392
	393	if (-f $schema_file) {
	394	my $schema_code = do { local (@ARGV, $/) = $schema_file; <> };
	395	return 1 if $schema_code =~ /->load_classes/;
	396	}
	397
	398	0;
	399	}
	400
2201c2e4	401	sub _data_struct_to_string {
2201c2e4	402	my ($self, $data) = @_;
34f036a0	403
2201c2e4	404	local $Data::Dumper::Terse = 1;
	405	local $Data::Dumper::Quotekeys = 0;
	406	local $Data::Dumper::Indent = 0;
	407	local $Data::Dumper::Useqq = 1;
34f036a0	408
2201c2e4	409	return Data::Dumper->Dump([$data]);
2201c2e4	410	}
34f036a0	411
a75b6e58	412	sub _get_dsn_user_pass {
	413	my ($self, $connect_info) = @_;
	414
	415	my $dsn = shift @$connect_info;
	416	my ($user, $password);
	417
	418	if ($dsn =~ /sqlite/i) {
	419	($user, $password) = ('', '');
108a45d1	420	shift @$connect_info while @$connect_info and $connect_info->[0] eq '';
a75b6e58	421	} else {
	422	($user, $password) = splice @$connect_info, 0, 2;
	423	}
	424
	425	($dsn, $user, $password)
	426	}
	427
2201c2e4	428	sub _parse_connect_info {
	429	my ($self, $connect_info) = @_;
	430
	431	my @connect_info = @$connect_info;
	432
a75b6e58	433	my ($dsn, $user, $password) = $self->_get_dsn_user_pass(\@connect_info);
2201c2e4	434
	435	tie my %connect_info, 'Tie::IxHash';
	436	@connect_info{qw/dsn user password/} = ($dsn, $user, $password);
	437
	438	for (@connect_info) {
	439	if (/^\s{.}\s*\z/) {
5f9a34d7	440	my $hash = $self->_eval($_);
c4fee9b8	441	die "Syntax errorr in connect_info hash: $_: $@" if $@;
2201c2e4	442
2201c2e4	443	%connect_info = (%connect_info, %$hash);
ca14239e	444
2201c2e4	445	next;
ca14239e	446	}
ca14239e	447
2201c2e4	448	my ($key, $val) = split /=/, $_, 2;
2201c2e4	449
c34bcab6	450	if ($key eq 'quote_char') {
	451	$connect_info{$key} = length($val) == 1 ? $val : [split //, $val];
	452	} elsif ($key =~ /^(?:name_sep\|limit_dialect)\z/) {
3f139b02	453	$connect_info{$key} = $val;
3f139b02	454	} else {
5f9a34d7	455	$connect_info{$key} = $self->_eval($val);
3f139b02	456	}
3f139b02	457
c4fee9b8	458	die "syntax error for connect_info key '$key' with value '$val': $@"
2201c2e4	459	if $@;
d89e6c8a	460	}
202d09c8	461
2201c2e4	462	$self->connect_info(\%connect_info);
	463
	464	\%connect_info
	465	}
	466
4cbe63e7	467	sub _is_struct {
	468	my ($self, $val) = @_;
	469
ce9e19dc	470	return $val =~ /^\s*(?:sub\|[[{])/;
4cbe63e7	471	}
4cbe63e7	472
c34bcab6	473	sub _quote {
	474	my ($self, $val) = @_;
	475
	476	return 'q{'.$val.'}';
	477	}
	478
2201c2e4	479	sub _quote_unless_struct {
	480	my ($self, $val) = @_;
	481
c34bcab6	482	$val = $self->_quote($val) if not $self->_is_struct($val);
2201c2e4	483
c34bcab6	484	return $val;
2201c2e4	485	}
2201c2e4	486
5f9a34d7	487	sub _eval {
	488	my ($self, $code) = @_;
	489
	490	return $code if looks_like_number $code;
	491
97631b44	492	return $code if not $self->_is_struct($code);
5f9a34d7	493
	494	return eval "{no strict; $code}";
	495	}
	496
2201c2e4	497	sub _gen_dynamic_schema {
	498	my $self = shift;
	499
	500	my $helper = $self->helper;
	501
	502	my @schema_parts = split(/\:\:/, $self->schema_class);
	503	my $schema_file_part = pop @schema_parts;
	504
	505	my $schema_dir = File::Spec->catfile(
	506	$helper->{base}, 'lib', @schema_parts
	507	);
	508	my $schema_file = File::Spec->catfile(
	509	$schema_dir, $schema_file_part . '.pm'
	510	);
	511
	512	$helper->mk_dir($schema_dir);
	513	$helper->render_file('schemaclass', $schema_file);
	514	}
	515
	516	sub _gen_static_schema {
	517	my $self = shift;
	518
c4fee9b8	519	die "cannot load schema without connect info" unless $self->connect_info;
2201c2e4	520
	521	my $helper = $self->helper;
	522
	523	my $schema_dir = File::Spec->catfile($helper->{base}, 'lib');
	524
f090a149	525	eval { Class::MOP::load_class('DBIx::Class::Schema::Loader') };
c4fee9b8	526	die "Cannot load DBIx::Class::Schema::Loader: $@" if $@;
f090a149	527
f090a149	528	DBIx::Class::Schema::Loader->import(
2201c2e4	529	"dump_to_dir:$schema_dir", 'make_schema_at'
f090a149	530	);
2201c2e4	531
	532	make_schema_at(
	533	$self->schema_class,
	534	$self->loader_args,
	535	[$self->connect_info]
	536	);
	537	}
	538
2201c2e4	539	sub _gen_model {
	540	my $self = shift;
	541	my $helper = $self->helper;
	542
	543	$helper->render_file('compclass', $helper->{file} );
ad91060a	544	}
ad91060a	545
c4fee9b8	546	sub _print_dynamic_deprecation_warning {
	547	warn <<EOF;
	548	********************************** WARNING ********************************
	549	* create=dynamic is DEPRECATED, please use create=static instead. *
	550	*******************************************************************************
	551	EOF
	552	print "Continue? [y/n]: ";
	553	chomp(my $response = <STDIN>);
	554	exit 0 if $response =~ /^n(o)?\z/;
	555	}
	556
	557	sub _cleanup_args {
	558	my ($self, $args) = @_;
	559
	560	# remove blanks, ie. someoned doing foo \ bar
61ed82a5	561	my @res = grep !/^\s+\z/, @$args;
c4fee9b8	562
	563	# remove leading whitespace, ie. foo \ bar
	564	s/^\s*// for @res;
	565
	566	@res
	567	}
	568
ad91060a	569	=head1 SEE ALSO
ad91060a	570
7b39f3f0	571	General Catalyst Stuff:
7b39f3f0	572
ad91060a	573	L<Catalyst::Manual>, L<Catalyst::Test>, L<Catalyst::Request>,
7b39f3f0	574	L<Catalyst::Response>, L<Catalyst::Helper>, L<Catalyst>,
	575
	576	Stuff related to DBIC and this Model style:
	577
	578	L<DBIx::Class>, L<DBIx::Class::Schema>,
ef91bcf9	579	L<DBIx::Class::Schema::Loader>, L<Catalyst::Model::DBIC::Schema>
ad91060a	580
	581	=head1 AUTHOR
	582
4e251d1a	583	See L<Catalyst::Model::DBIC::Schema/AUTHOR> and
4e251d1a	584	L<Catalyst::Model::DBIC::Schema/CONTRIBUTORS>.
ad91060a	585
4e251d1a	586	=head1 COPYRIGHT
2ff00e2b	587
4e251d1a	588	See L<Catalyst::Model::DBIC::Schema/COPYRIGHT>.
2ff00e2b	589
ad91060a	590	=head1 LICENSE
	591
	592	This library is free software, you can redistribute it and/or modify
	593	it under the same terms as Perl itself.
	594
	595	=cut
	596
dce0dfe8	597	1;
dce0dfe8	598
ad91060a	599	__DATA__
ad91060a	600
5d11d759	601	=begin pod_to_ignore
5d11d759	602
d89e6c8a	603	__schemaclass__
	604	package [% schema_class %];
	605
	606	use strict;
	607	use base qw/DBIx::Class::Schema::Loader/;
	608
	609	__PACKAGE__->loader_options(
2201c2e4	610	[%- FOREACH key = loader_args.keys %]
	611	[% key %] => [% loader_args.${key} %],
	612	[%- END -%]
	613
d89e6c8a	614	);
	615
	616	=head1 NAME
	617
2201c2e4	618	[% schema_class %] - L<DBIx::Class::Schema::Loader> class
d89e6c8a	619
	620	=head1 SYNOPSIS
	621
	622	See L<[% app %]>
	623
	624	=head1 DESCRIPTION
	625
2201c2e4	626	Dynamic L<DBIx::Class::Schema::Loader> schema for use in L<[% class %]>
	627
	628	=head1 GENERATED BY
	629
	630	[% generator %] - [% generator_version %]
d89e6c8a	631
	632	=head1 AUTHOR
	633
2201c2e4	634	[% author.replace(',+$', '') %]
d89e6c8a	635
	636	=head1 LICENSE
	637
	638	This library is free software, you can redistribute it and/or modify
	639	it under the same terms as Perl itself.
	640
	641	=cut
	642
	643	1;
	644
ad91060a	645	__compclass__
	646	package [% class %];
	647
	648	use strict;
	649	use base 'Catalyst::Model::DBIC::Schema';
	650
	651	__PACKAGE__->config(
0f2fd2c0	652	schema_class => '[% schema_class %]',
c34bcab6	653	[% IF traits %]traits => [% traits %],[% END %]
2201c2e4	654	[% IF setup_connect_info %]connect_info => {
	655	[%- FOREACH key = connect_info.keys %]
	656	[% key %] => [% connect_info.${key} %],
	657	[%- END -%]
	658
	659	}[% END %]
ad91060a	660	);
	661
	662	=head1 NAME
	663
1aeb6e1e	664	[% class %] - Catalyst DBIC Schema Model
2201c2e4	665
ad91060a	666	=head1 SYNOPSIS
	667
	668	See L<[% app %]>
	669
	670	=head1 DESCRIPTION
	671
d89e6c8a	672	L<Catalyst::Model::DBIC::Schema> Model using schema L<[% schema_class %]>
ad91060a	673
2201c2e4	674	=head1 GENERATED BY
	675
	676	[% generator %] - [% generator_version %]
	677
ad91060a	678	=head1 AUTHOR
ad91060a	679
2201c2e4	680	[% author.replace(',+$', '') %]
ad91060a	681
	682	=head1 LICENSE
	683
	684	This library is free software, you can redistribute it and/or modify
	685	it under the same terms as Perl itself.
	686
	687	=cut
	688
	689	1;
a75b6e58	690	__END__
a75b6e58	691	# vim:sts=4 sw=4: