Attempt to fix 'Attempt to free unreferenced scalar' on 5.8

[dbsrgits/DBIx-Class-Schema-Loader.git] / script / dbicdump

#!/usr/bin/perl

=encoding UTF-8

=head1 NAME

dbicdump - Dump a schema using DBIx::Class::Schema::Loader

=head1 SYNOPSIS

    dbicdump <configuration_file>
    dbicdump [-I <lib-path>] [-o <loader_option>=<value> ] \
             <schema_class> <connect_info>

Examples:

    $ dbicdump schema.conf

    $ dbicdump -o dump_directory=./lib \
      -o components='["InflateColumn::DateTime"]' \
      MyApp::Schema dbi:SQLite:./foo.db

    $ dbicdump -o dump_directory=./lib \
      -o components='["InflateColumn::DateTime"]' \
      MyApp::Schema dbi:SQLite:./foo.db '{ quote_char => "\"" }'

    $ dbicdump -Ilib -o dump_directory=./lib \
      -o components='["InflateColumn::DateTime"]' \
      -o preserve_case=1 \
      MyApp::Schema dbi:mysql:database=foo user pass \
      '{ quote_char => "`" }'

    $ dbicdump -o dump_directory=./lib \
      -o components='["InflateColumn::DateTime"]' \
      MyApp::Schema 'dbi:mysql:database=foo;host=domain.tld;port=3306' \
      user pass

On Windows that would be:

    $ dbicdump -o dump_directory=.\lib ^
      -o components="[q{InflateColumn::DateTime}]" ^
      -o preserve_case=1 ^
      MyApp::Schema dbi:mysql:database=foo user pass ^
      "{ quote_char => q{`} }"

Configuration files must have schema_class and connect_info sections,
an example of a general config file is as follows:

    schema_class MyApp::Schema

    lib /extra/perl/libs

    # connection string
    <connect_info>
        dsn     dbi:mysql:example
        user    root
        pass    secret
    </connect_info>

    # dbic loader options
    <loader_options>
        dump_directory ./lib
        components     InflateColumn::DateTime
        components     TimeStamp
    </loader_options>

Using a config file requires L<Config::Any> installed.

The optional C<lib> key is equivalent to the C<-I> option.

=head1 DESCRIPTION

Dbicdump generates a L<DBIx::Class> schema using
L<DBIx::Class::Schema::Loader/make_schema_at> and dumps it to disk.

You can pass any L<DBIx::Class::Schema::Loader::Base> constructor option using
C<< -o <option>=<value> >>. For convenience, option names will have C<->
replaced with C<_> and values that look like references or quote-like
operators will be C<eval>-ed before being passed to the constructor.

The C<dump_directory> option defaults to the current directory if not
specified.

=head1 SEE ALSO

L<DBIx::Class::Schema::Loader>, L<DBIx::Class>.

=head1 AUTHORS

See L<DBIx::Class::Schema::Loader/AUTHORS>.

=head1 LICENSE

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

=cut

use strict;
use warnings;
use Getopt::Long;
use Pod::Usage;
use DBIx::Class::Schema::Loader 'make_schema_at';
use DBIx::Class::Schema::Loader::Base ();
use DBIx::Class::Schema::Loader::Optional::Dependencies ();
require lib;

my $loader_options;

Getopt::Long::Configure('gnu_getopt');

GetOptions(
    'I=s'                => sub { shift; lib->import(shift) },
    'loader-option|o=s%' => \&handle_option,
);

$loader_options->{dump_directory} ||= '.';

if (@ARGV == 1) {
    if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('dbicdump_config')) {
        die sprintf "You must install the following CPAN modules to use a config file with dbicdump: %s.\n",
            DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('dbicdump_config');
    }

    my $configuration_file = shift @ARGV;

    my $configurations = Config::Any->load_files({
        use_ext => 1,
        flatten_to_hash => 1,
        files => [$configuration_file]
    });

    my $c = (values %$configurations)[0];

    unless (keys %{$c->{connect_info}} && $c->{schema_class}) {
        pod2usage(1);
    }

    my @libs;

    if ($c->{lib}) {
        if (ref $c->{lib}) {
            @libs = @{ $c->{lib} };
        }

        @libs = ($c->{lib});
    }

    lib->import($_) for @libs;

    my ($dsn, $user, $pass, $options) =
        map { $c->{connect_info}->{$_} } qw/dsn user pass options/;
        $options ||= {};
        $c->{loader_options}->{dump_directory} ||=
            $loader_options->{dump_directory};

    make_schema_at(
        $c->{schema_class},
        $c->{loader_options} || {},
        [ $dsn, $user, $pass, %{$options} ],
    );
}
else {
    my ($schema_class, @loader_connect_info) = @ARGV
        or pod2usage(1);

    my $dsn = shift @loader_connect_info;

    my ($user, $pass) = $dsn =~ /sqlite/i ? ('', '')
        : splice @loader_connect_info, 0, 2;

    my @extra_connect_info_opts = map parse_value($_), @loader_connect_info;

    make_schema_at(
        $schema_class,
        $loader_options,
        [ $dsn, $user, $pass, @extra_connect_info_opts ],
    );
}

exit 0;

sub parse_value {
    my $value = shift;

    $value = eval $value if $value =~ /^\s*(?:sub\s*\{|q\w?\s*[^\w\s]|[[{])/;

    return $value;
}

sub handle_option {
    my ($self, $key, $value) = @_;

    $key =~ tr/-/_/;
    die "Unknown option: $key\n"
        unless DBIx::Class::Schema::Loader::Base->can($key);

    $value = parse_value $value;

    $loader_options->{$key} = $value;
}

1;

__END__