view release on metacpan or  search on metacpan

lib/App/CatalystStarter/Bloated.pm  view on Meta::CPAN

    ## model can have the dsn
    if (defined $ARGV{'--model'} and $ARGV{'--model'} =~ /^dbi:/i ) {
        $ARGV{'--dsn'} = $ARGV{'--model'};
        $ARGV{'--model'} = 1;
    }

    ## dsn gets a brush up
    if ($ARGV{'--dsn'}) {

        if ( $ARGV{'--dsnfix'} ) {
            $ARGV{'--dsn'} = _prepare_dsn( $ARGV{'--dsn'} );
            $ARGV{'-dsn'} = $ARGV{'--dsn'};
        }

        if ( not defined $ARGV{'--model'} ) {
            $ARGV{'--model'} = 1;
        }

    }

    ## model might have defaults
    if ( $ARGV{'--model'} ) {

        if ( $ARGV{'--model'} eq '1' ) {
            $ARGV{'--model'} = $ARGV{'--name'} . 'DB';
        }

        $ARGV{'--model'} =~ s/^AppNameDB$/$ARGV{'--name'}DB/;
        $ARGV{'-model'} = $ARGV{'--model'};

        if ( not $ARGV{'--schema'} or $ARGV{'--schema'} eq "1" ) {
            $ARGV{'--schema'} = $ARGV{'--name'} . '::Schema';

            $ARGV{'-schema'} = $ARGV{'--schema'};

        }

    }
    else {
        delete $ARGV{'--schema'};
        delete $ARGV{'-schema'};
    }

    ## some defaults that will work for sqlite at least
    $ARGV{'--dbuser'} //= "";
    $ARGV{'--dbpass'} //= "";

    if ( defined $dsn_0 and $dsn_0 ne $ARGV{'--dsn'} ) {
        l->debug( "dsn changed to '$ARGV{'--dsn'}'" );
    }

} ## finalize_argv.t

## dsn related
sub _prepare_dsn {

    my $dsn = shift;

    return $dsn if $ARGV{'--nodsnfix'};

    ## unlikely but guess it could happen
    l->debug("Prepended litteral 'dbi' to dsn") if $dsn =~ s/^:/dbi:/;

    ## if it doesn't start with dbi: by now, we'll nicely provide that
    if ( lc substr( $dsn, 0, 4 ) ne "dbi:" ) {
        l->debug("Prepended 'dbi:' to dsn");
        $dsn = "dbi:" . $dsn;
    }

    ## taking care of case, should there be issues
    l->info("Setting dsn scheme to lowercase 'dbi:'" )
        if $dsn =~ /^.{0,2}[DBI]/;
    $dsn =~ s/^dbi:/dbi:/i;

    ## if it doesn't end with a ":" but has one alerady, we'll append
    ## one, should be enough to make it parseable by DBI, ie dbi:Pg
    ## will do
    if ( $dsn =~ y/:// == 1 and $dsn =~ /^dbi:/ and $dsn !~ /:$/ ) {
        l->info("Appending ':' to make dsn valid");
        $dsn .= ":";
    }

    ## offer to correct the driver
    my @parts = DBI->parse_dsn( $dsn );
    my $driver = _fix_dbi_driver_case( $parts[1] );

    my $case_fixed_dsn = sprintf(
        "%s:%s%s:%s",
        $parts[0],
        $driver, $parts[2]||"",
        $parts[4]
    );

    my $pgpass_fixed_dsn = _complete_dsn_from_pgpass($case_fixed_dsn);
    return $pgpass_fixed_dsn;

} ## dsn.t
sub _parse_dbi_dsn {

    my $dsn = shift;

    return unless defined $dsn;

    my @pairs = split /;/, $dsn;

    my %data;

    for (@pairs) {
        my ($k,$v) = split /=/, $_;
        $data{$k} = $v;
    }

    my $db = first {$_} delete @data{qw/db database dbname/};
    $data{database} = $db;

    my $host = first {$_} delete @data{qw/host hostname/};
    $data{host} = $host;

    $data{port} //= undef;

    return %data;