package Punk::Sqitch;

use 5.010;
use strict;
use warnings;

our $VERSION = '0.01';

use Carp ();
use Cwd ();
use File::Spec ();
use Config ();

our (%ENGINE, %TYPES, %CLIENT, %TAKES_TARGET);

BEGIN {
    %ENGINE = (
        sqlite     => { engine => 'sqlite',     name => 'dbname',   path => 1 },
        pg         => { engine => 'pg',         name => 'dbname',   path => 0 },
        mysql      => { engine => 'mysql',      name => 'database', path => 0 },
        mariadb    => { engine => 'mysql',      name => 'database', path => 0 },
        oracle     => { engine => 'oracle',     name => 'sid',      path => 0,
                    aliases => [qw(service_name)] },
        firebird   => { engine => 'firebird',   name => 'dbname',   path => 0 },
        clickhouse => { engine => 'clickhouse', name => 'database', path => 0 },
    );

    my %pg = (integer => 'bigint', string => 'text', number => 'double precision',
              boolean => 'boolean', primary_integer => 'bigserial PRIMARY KEY',
              txn => 1, false => 'FALSE');
    %TYPES = (
        sqlite    => { integer => 'INTEGER', string => 'TEXT', number => 'REAL',
                       boolean => 'INTEGER', primary_integer => 'INTEGER PRIMARY KEY AUTOINCREMENT',
                       txn => 1, false => '0' },
        pg        => { %pg },
        cockroach => { %pg },     # Postgres-compatible, SERIAL included
        yugabyte  => { %pg },
        mysql     => { integer => 'BIGINT', string => 'TEXT', number => 'DOUBLE',
                       boolean => 'BOOLEAN', primary_integer => 'BIGINT PRIMARY KEY AUTO_INCREMENT',
                       txn => 0, false => '0' },
        oracle    => { integer => 'NUMBER(19)', string => 'VARCHAR2(4000)', number => 'BINARY_DOUBLE',
                       boolean => 'NUMBER(1)',
                       primary_integer => 'NUMBER(19) GENERATED BY DEFAULT AS IDENTITY PRIMARY KEY',
                       txn => 0, false => '1 = 0' },
        firebird  => { integer => 'BIGINT', string => 'VARCHAR(4000)', number => 'DOUBLE PRECISION',
                       boolean => 'BOOLEAN',
                       primary_integer => 'BIGINT GENERATED BY DEFAULT AS IDENTITY PRIMARY KEY',
                       txn => 0, false => 'FALSE' },
    );

    %CLIENT = (
        sqlite     => { name => 'sqlite3',    args => ['-version'],  min => '3.3.9' },
        pg         => { name => 'psql',       args => ['--version'] },
        cockroach  => { name => 'psql',       args => ['--version'] },
        yugabyte   => { name => 'psql',       args => ['--version'] },
        mysql      => { name => 'mysql',      args => ['--version'] },
        oracle     => { name => 'sqlplus',    args => ['-v'] },
        firebird   => { name => 'fbsql',      args => ['-z'], alternatives => ['isql-fb', 'isql'] },
        vertica    => { name => 'vsql',       args => ['--version'] },
        exasol     => { name => 'exaplus',    args => ['-version'] },
        snowflake  => { name => 'snowsql',    args => ['--version'] },
        clickhouse => { name => 'clickhouse', args => ['--version'], alternatives => ['clickhouse-client'] },
    );

    %TAKES_TARGET = map { $_ => 1 }
        qw(deploy revert verify status log check checkout rebase upgrade bundle);
}

sub engine_for {
    my ($class, $driver, $spec) = @_;
    Carp::croak('Punk::Sqitch: engine_for takes a driver name and a hashref')
        unless defined $driver && ref $spec eq 'HASH';
    Carp::croak("Punk::Sqitch: engine_for $driver: `engine` and `name` are required")
        unless defined $spec->{engine} && defined $spec->{name};
    for my $k (keys %$spec) {
        Carp::croak("Punk::Sqitch: engine_for $driver: unknown key '$k' (engine, name, "
                  . 'path, aliases)') unless $k =~ /\A(?:engine|name|path|aliases)\z/;
    }
    $ENGINE{ lc $driver } = { path => 0, %$spec };
    return;
}

sub engines { my %seen; [ sort grep { !$seen{$_}++ } map { $_->{engine} } values %ENGINE ] }

sub register_types {
    my ($class, $engine, $spec) = @_;
    Carp::croak('Punk::Sqitch: register_types takes an engine name and a hashref')
        unless defined $engine && ref $spec eq 'HASH';
    for my $k (qw(integer string number boolean primary_integer false)) {
        Carp::croak("Punk::Sqitch: register_types $engine: `$k` is required")
            unless defined $spec->{$k};
    }
    for my $k (keys %$spec) {
        Carp::croak("Punk::Sqitch: register_types $engine: unknown key '$k' (integer, "
                  . 'string, number, boolean, primary_integer, txn, false)')
            unless $k =~ /\A(?:integer|string|number|boolean|primary_integer|txn|false)\z/;
    }
    $TYPES{ lc $engine } = { txn => 0, %$spec };
    return;
}

sub register_client {
    my ($class, $engine, $spec) = @_;
    Carp::croak('Punk::Sqitch: register_client takes an engine name and a hashref')
        unless defined $engine && ref $spec eq 'HASH';
    Carp::croak("Punk::Sqitch: register_client $engine: `name` is required")
        unless defined $spec->{name};
    for my $k (keys %$spec) {
        Carp::croak("Punk::Sqitch: register_client $engine: unknown key '$k' (name, "
                  . 'args, min, alternatives)')
            unless $k =~ /\A(?:name|args|min|alternatives)\z/;
    }
    $CLIENT{ lc $engine } = { args => ['--version'], %$spec };
    return;
}

sub target_for {
    my ($class, $db) = @_;
    Carp::croak('Punk::Sqitch: target_for takes the database options hashref')
        unless ref $db eq 'HASH';
    my $password = (defined $db->{password} && length $db->{password})
                 ? $db->{password} : undef;

    # 1. the application's own URI
    if (defined $db->{sqitch_target} && length $db->{sqitch_target}) {
        my $uri = $db->{sqitch_target};
        my ($engine) = $uri =~ /\Adb:([A-Za-z][\w-]*):/
            or Carp::croak("Punk::Sqitch: sqitch_target '$uri' is not a db: URI "
                         . '(db:ENGINE:... - see URI::db)');
        $engine = $db->{sqitch_engine} if defined $db->{sqitch_engine} && length $db->{sqitch_engine};
        return { uri => $uri, engine => lc $engine, password => $password };
    }

    my $dsn = $db->{dsn};
    Carp::croak('Punk::Sqitch: no dsn - add a database keyword, or a '
              . 'database block to punk.yml') unless defined $dsn && length $dsn;

    my ($driver, $spec) = $dsn =~ /\A dbi : ([^:(]+) (?:\([^)]*\))? : (.*) \z/xsi
        or Carp::croak("Punk::Sqitch: '$dsn' is not a DBI dsn (dbi:Driver:...)");
    my $e = $ENGINE{ lc $driver }
        or Carp::croak("Punk::Sqitch: no target mapping for the '$driver' driver. "
                     . 'Either set sqitch_target => "db:ENGINE:..." on the database '
                     . '(the URI Sqitch should use; the password still travels '
                     . 'separately), or register the driver with '
                     . "Punk::Sqitch->engine_for('$driver' => { engine => ..., "
                     . 'name => ... }). Mapped out of the box: '
                     . join(', ', sort keys %ENGINE));

    # key=value pairs; a lone bare token is the database name
    my (%kv, @order);
    for my $part (split /;/, $spec) {
        next unless length $part;
        if ($part =~ /\A([^=]+)=(.*)\z/s) { push @order, $1 unless exists $kv{$1}; $kv{$1} = $2 }
        elsif (!exists $kv{ $e->{name} })  { push @order, $e->{name}; $kv{ $e->{name} } = $part }
        else { Carp::croak("Punk::Sqitch: cannot read '$part' in dsn '$dsn'") }
    }
    my $name_key = $e->{name};
    for my $alias (@{ $e->{aliases} || [] }) {
        $name_key = $alias if !exists $kv{ $e->{name} } && exists $kv{$alias};
    }
    my $name = delete $kv{$name_key};
    Carp::croak("Punk::Sqitch: dsn '$dsn' names no database ($e->{name}=...)")
        unless defined $name && length $name;
    @order = grep { $_ ne $name_key } @order;
    my $engine = (defined $db->{sqitch_engine} && length $db->{sqitch_engine})
               ? lc $db->{sqitch_engine} : $e->{engine};

    my $uri;
    if ($e->{path}) {
        # db:sqlite:PATH - a file, and the only thing SQLite's dsn may say
        Carp::croak("Punk::Sqitch: '$_' in the SQLite dsn has no place in a "
                  . 'target URI') for @order;
        $uri = "db:$engine:$name";
    }
    else {
        my $host = delete $kv{host};
        my $port = delete $kv{port};
        @order = grep { $_ ne 'host' && $_ ne 'port' } @order;
        my $auth = '';
        if (defined $db->{user} && length $db->{user}) {
            $auth = _enc($db->{user}) . '@';
        }
        my $hostport = defined $host && length $host ? $host : '';
        $hostport .= ":$port" if defined $port && length $port;
        $uri = "db:$engine:";
        if (length $auth || length $hostport) { $uri .= "//$auth$hostport/" }
        $uri .= _enc($name);
        if (@order) {
            $uri .= '?' . join '&', map { _enc($_) . '=' . _enc($kv{$_}) } @order;
        }
    }
    return { uri => $uri, engine => $engine, password => $password };
}

sub _enc {
    my ($s) = @_;
    $s =~ s/([^A-Za-z0-9\-._~])/sprintf '%%%02X', ord $1/ge;
    return $s;
}

# ---- the application ------------------------------------------------------------
sub find_root {
    my ($class, $dir) = @_;
    my $here = Cwd::abs_path($dir || Cwd::getcwd()) or return undef;
    for (1 .. 40) {
        return $here if -f File::Spec->catfile($here, 'app.psgi');
        my $up = Cwd::abs_path(File::Spec->catdir($here, File::Spec->updir));
        last if !$up || $up eq $here;
        $here = $up;
    }
    return undef;
}

sub databases_for {
    my ($class, %o) = @_;
    my $root = $o{root} or Carp::croak('Punk::Sqitch: databases_for needs root');
    my $env  = $o{env} || $ENV{PUNK_ENV} || 'production';
    my %dbs;

    if (my $reg = $o{registrar}) {
        if ($reg->can('databases')) {
            my $d = $reg->databases;
            %dbs = %$d if ref $d eq 'HASH';
        }
    }
    my $file = $o{file} || File::Spec->catfile($root, 'config', 'punk.yml');
    if (!%dbs && -f $file) {
        require Punk::Config;
        my $cfg = do {
            local $ENV{PUNK_ENV} = $env;
            Punk::Config->load(file => $file, env => $env);
        };
        my $block = $cfg->get('database');
        if (ref $block eq 'HASH') {
            my $named = grep { ref $_ eq 'HASH' } values %$block;
            if ($named) { %dbs = %$block }
            else        { %dbs = (default => $block) }
        }
    }
    return \%dbs;
}

sub project_dir {
    my ($class, $root) = @_;
    my $sub = File::Spec->catdir($root, 'sqitch');
    for my $f (qw(sqitch.plan sqitch.conf)) {
        return $sub  if -f File::Spec->catfile($sub, $f);
    }
    for my $f (qw(sqitch.plan sqitch.conf)) {
        return $root if -f File::Spec->catfile($root, $f);
    }
    return $sub;
}

sub ensure_target_dir {
    my ($class, $target, $root) = @_;
    return undef unless $target->{engine} eq 'sqlite';
    my ($path) = $target->{uri} =~ /\Adb:sqlite:(.*)\z/s;
    return undef unless defined $path && length $path && $path ne ':memory:';
    $path = File::Spec->rel2abs($path, $root)
        unless File::Spec->file_name_is_absolute($path);
    my ($vol, $dir) = File::Spec->splitpath($path);
    $dir = File::Spec->catpath($vol, $dir, '');
    return undef if !length $dir || -d $dir;
    require File::Path;
    File::Path::make_path($dir);
    return $dir;
}

sub app_class_for {
    my ($class, $root) = @_;
    my $psgi = File::Spec->catfile($root, 'app.psgi');
    open my $fh, '<', $psgi or return undef;
    local $/;
    my $src = <$fh>;
    close $fh;
    return $1 if $src =~ /([A-Za-z_][\w:]*)\s*->\s*to_app\b/;
    return $1 if $src =~ /^\s*use\s+([A-Za-z_][\w:]*)\s*;/m;
    return undef;
}

sub load_app {
    my ($class, $root) = @_;
    my $name = $class->app_class_for($root)
        or Carp::croak("Punk::Sqitch: cannot work out the application class "
                     . "from $root/app.psgi");
    my $lib = File::Spec->catdir($root, 'lib');
    unshift @INC, $lib if -d $lib && !grep { $_ eq $lib } @INC;
    (my $file = "$name.pm") =~ s{::}{/}g;
    unless ($INC{$file}) {
        require Punk::Plugin::Sqitch;
        no warnings 'once';
        local $Punk::Plugin::Sqitch::SKIP_CHECK = 1;
        my $ok = eval { require $file; 1 };
        unless ($ok) {
            my $err = $@;
            $err =~ s/\s+\z//;
            Carp::croak("Punk::Sqitch: cannot load $name to find its plugins' "
                      . "projects: $err");
        }
    }
    return $name;
}

sub projects {
    my ($class, %o) = @_;
    my $root = $o{root} or Carp::croak('Punk::Sqitch: projects needs root');
    my $app  = $class->app_project(%o);
    return [ $app ] if $o{app_only};
    my $name = $class->load_app($root);
    require Punk::Plugin::Sqitch;
    my $plugins = Punk::Plugin::Sqitch->projects_for($name, app_project => $app->{name});
    return $class->project_list($app, $plugins);
}

sub app_project {
    my ($class, %o) = @_;
    my $root = $o{root} or Carp::croak('Punk::Sqitch: app_project needs root');
    my $dir  = $o{dir} || $class->project_dir($root);
    my $conf = $o{conf} || $class->read_conf(File::Spec->catfile($dir, 'sqitch.conf'));
    my $plan_file = $o{plan_file} || $class->plan_file_for($dir, $conf);
    Carp::croak("Punk::Sqitch: no plan at $plan_file - run `punk sqitch init` "
              . 'first') unless -f $plan_file;
    my $plan = $class->read_plan($plan_file);
    return { name => $plan->{project}, dir => $dir, plan_file => $plan_file,
             conf => $conf, plan => $plan, plugin => 0 };
}

sub project_list {
    my ($class, $app, $plugins) = @_;
    my $conf = $app->{conf};
    if (@$plugins) {
        my $reg = $class->conf_get($conf, 'registry');
        Carp::croak("Punk::Sqitch: sqitch.conf names the registry '$reg', and a "
                  . 'plugin project cannot see that: with plugin projects the '
                  . 'registry keeps its default name')
            if defined $reg && $reg ne 'sqitch';
    }
    return [ (map { { %$_, plugin => 1 } } @$plugins), $app ];
}

sub pending_all {
    my ($class, %o) = @_;
    my $projects = $o{projects} || $class->projects(%o);
    my $target = $o{target} || $class->target_for($o{database});
    my @out;
    for my $p (@$projects) {
        push @out, $class->pending(
            root => $p->{dir}, database => $o{database}, target => $target,
            conf => $p->{conf}, plan_file => $p->{plan_file},
            registry_conf => $o{conf});
    }
    return \@out;
}

sub target_abs {
    my ($class, $target, $root) = @_;
    return $target unless $target->{engine} eq 'sqlite';
    my ($path) = $target->{uri} =~ /\Adb:sqlite:(.*)\z/s;
    return $target if File::Spec->file_name_is_absolute($path);
    return { %$target, uri => 'db:sqlite:' . File::Spec->rel2abs($path, $root) };
}

sub database_for {
    my ($class, $dbs, $name) = @_;
    $name = 'default' unless defined $name && length $name;
    return $dbs->{$name} if ref $dbs->{$name} eq 'HASH';
    my @have = sort keys %$dbs;
    Carp::croak("Punk::Sqitch: no database '$name' configured"
              . (@have ? ' (have: ' . join(', ', @have) . ')'
                       : ' - add a database keyword, or a database block to punk.yml'));
}

sub read_conf {
    my ($class, $file) = @_;
    my %conf;
    return \%conf unless defined $file && -f $file;
    open my $fh, '<', $file or Carp::croak("Punk::Sqitch: cannot read $file: $!");
    my $section = '';
    while (my $line = <$fh>) {
        $line =~ s/\s+\z//;
        next if $line =~ /\A\s*(?:[#;]|\z)/;
        if ($line =~ /\A\s*\[\s*([^\s"\]]+)(?:\s+"((?:[^"\\]|\\.)*)")?\s*\]/) {
            my ($name, $sub) = ($1, $2);
            $section = lc $name;
            if (defined $sub) { $sub =~ s/\\(.)/$1/g; $section .= ".$sub" }
            next;
        }
        if ($line =~ /\A\s*([^=\s]+)\s*=\s*(.*)\z/) {
            my ($k, $v) = (lc $1, $2);
            $v =~ s/\s*[#;].*\z// unless $v =~ /\A"/;
            $v =~ s/\A"(.*)"\z/$1/s;
            $v =~ s/\\(.)/$1/g;
            $conf{"$section.$k"} = $v;
        }
    }
    close $fh;
    return \%conf;
}

sub conf_get {
    my ($class, $conf, $key, $engine, $target) = @_;
    for my $k ((defined $target ? "target.$target.$key" : ()),
               (defined $engine ? "engine.$engine.$key" : ()),
               "core.$key") {
        return $conf->{$k} if defined $conf->{$k} && length $conf->{$k};
    }
    return undef;
}

sub plan_file_for {
    my ($class, $root, $conf, $engine) = @_;
    my $pf = $class->conf_get($conf, 'plan_file', $engine);
    if (defined $pf) {
        return File::Spec->file_name_is_absolute($pf) ? $pf
             : File::Spec->catfile($root, $pf);
    }
    my $top = $class->conf_get($conf, 'top_dir', $engine);
    my $dir = !defined $top ? $root
            : File::Spec->file_name_is_absolute($top) ? $top
            : File::Spec->catdir($root, $top);
    return File::Spec->catfile($dir, 'sqitch.plan');
}

sub read_plan {
    my ($class, $file) = @_;
    open my $fh, '<', $file
        or Carp::croak("Punk::Sqitch: cannot read the plan $file: $!");
    my %plan = (file => $file, project => undef, uri => undef,
                changes => [], tags => [], deps => {}, requires => []);
    my %req;
    while (my $line = <$fh>) {
        $line =~ s/\s+\z//;
        next if $line =~ /\A\s*(?:#|\z)/;
        if ($line =~ /\A\s*%\s*([^=\s]+)\s*=\s*(.*?)\s*\z/) {
            my ($k, $v) = ($1, $2);
            $plan{project} = $v if $k eq 'project';
            $plan{uri}     = $v if $k eq 'uri';
            next;
        }
        if ($line =~ /\A\s*@(\S+)/) { push @{ $plan{tags} }, $1; next }
        if ($line =~ /\A\s*(\S+)(?:\s+\[([^\]]*)\])?/) {
            my ($name, $deps) = ($1, $2);
            push @{ $plan{changes} }, $name;
            my @d = defined $deps ? grep { length } split /\s+/, $deps : ();
            $plan{deps}{$name} = \@d;
            for my $d (@d) {
                next if $d =~ /\A!/;                       # a conflict, not a need
                $req{$1} = 1 if $d =~ /\A([^:@]+):/;        # project:change
            }
            next;
        }
    }
    close $fh;
    Carp::croak("Punk::Sqitch: $file names no %project")
        unless defined $plan{project} && length $plan{project};
    $plan{requires} = [ sort grep { $_ ne $plan{project} } keys %req ];
    return \%plan;
}

sub registry_for {
    my ($class, $db, $target, $conf) = @_;
    my $engine = $target->{engine};
    my $reg = $class->conf_get($conf, 'registry', $engine) // 'sqitch';
    if ($engine eq 'sqlite') {
        my ($path) = $target->{uri} =~ /\Adb:sqlite:(.*)\z/s;
        my $file;
        if (File::Spec->file_name_is_absolute($reg)) { $file = $reg }
        else {
            my ($vol, $dir, $bn) = File::Spec->splitpath($path);
            my $new;
            if ($reg =~ /[.]/ || $bn !~ /[.]/) { $new = $reg }
            else { my (undef, $ext) = split /[.]/, $bn, 2; $new = "$reg.$ext" }
            $file = File::Spec->catpath($vol, $dir, $new);
        }
        return { engine => $engine, name => $reg, kind => 'file', path => $file,
                 connect => [ "dbi:SQLite:dbname=$file", undef, undef ] };
    }
    my %where = (pg => 'schema', cockroach => 'schema', yugabyte => 'schema',
                 oracle => 'schema', vertica => 'schema', snowflake => 'schema',
                 exasol => 'schema', mysql => 'database', clickhouse => 'database');
    return { engine => $engine, name => $reg, kind => $where{$engine} // 'unknown',
             connect => [ $db->{dsn}, $db->{user}, $db->{password} ] };
}

sub pending {
    my ($class, %o) = @_;
    my $root = $o{root} or Carp::croak('Punk::Sqitch: pending needs root');
    my $db   = $o{database} or Carp::croak('Punk::Sqitch: pending needs the database options');
    my $target = $o{target} || $class->target_for($db);
    my $conf = $o{conf} || $class->read_conf(File::Spec->catfile($root, 'sqitch.conf'));
    my $plan_file = $o{plan_file} || $class->plan_file_for($root, $conf, $target->{engine});
    Carp::croak("Punk::Sqitch: no plan at $plan_file - run `punk sqitch init` "
              . 'first, or point plan_file at it') unless -f $plan_file;
    my $plan = $class->read_plan($plan_file);
    my $reg  = $class->registry_for($db, $target, $o{registry_conf} || $conf);
    my %r = (project => $plan->{project}, plan_file => $plan_file,
             registry => $reg, deployed => 0, pending => [ @{ $plan->{changes} } ],
             drift => undef, error => undef);

    my @rows;
    if ($reg->{kind} eq 'file' && !-e $reg->{path}) {
        return \%r;                           # nothing deployed yet
    }
    if ($reg->{kind} eq 'unknown') {
        $r{error} = "the check does not know where the '$target->{engine}' engine "
                  . 'keeps its registry; run `punk sqitch status` instead';
        return \%r;
    }
    require DBI;
    my $dbh = DBI->connect(@{ $reg->{connect} },
                           { RaiseError => 1, PrintError => 0, AutoCommit => 1 });
    unless ($dbh) {
        $r{error} = 'cannot reach the registry: ' . (DBI->errstr // 'connect failed');
        return \%r;
    }
    my $table = $reg->{kind} eq 'file' ? 'changes' : "$reg->{name}.changes";
    my $rows = eval {
        $dbh->selectcol_arrayref(
            "SELECT change FROM $table WHERE project = ? ORDER BY committed_at",
            undef, $plan->{project});
    };
    my $err = $@;
    $dbh->disconnect;
    if ($err) {
        # no registry yet is an answer; anything else is the database's problem
        my $absent = $err =~ /no such table|does not exist|doesn\x27t exist|Unknown database/i;
        unless ($absent) {
            $err =~ s/ at \S+ line \d+\.?\s*\z//;
            $err =~ s/\s+\z//;
            $r{error} = "cannot read the registry: $err";
        }
        return \%r;
    }
    @rows = @$rows;
    my $n = @rows;
    my @changes = @{ $plan->{changes} };
    $r{deployed} = $n;
    if ($n > @changes) {
        $r{drift} = "the registry holds $n changes for project '$plan->{project}' "
                  . 'but the plan lists ' . scalar(@changes);
        $r{pending} = [];
        return \%r;
    }
    if ($n && $rows[-1] ne $changes[$n - 1]) {
        $r{drift} = "the last deployed change is '$rows[-1]' but the plan\x27s "
                  . "entry $n is '$changes[$n - 1]'";
        $r{pending} = [];
        return \%r;
    }
    $r{pending} = [ @changes[ $n .. $#changes ] ];
    return \%r;
}

sub project_name_for {
    my ($class, $app_class) = @_;
    (my $n = lc $app_class) =~ s/::/_/g;
    $n =~ s/[^\w-]/_/g;
    $n = "app_$n" unless $n =~ /\A[A-Za-z]/;
    return $n;
}

sub skeleton {
    my ($class, %o) = @_;
    my $meta   = $o{meta}   or Carp::croak('Punk::Sqitch: skeleton needs the model meta');
    my $engine = $o{engine} or Carp::croak('Punk::Sqitch: skeleton needs an engine');
    my $t = $TYPES{$engine}
        or Carp::croak("Punk::Sqitch: no skeleton types for the '$engine' engine - "
                     . "Punk::Sqitch->register_types('$engine' => {...}) adds them "
                     . '(have: ' . join(', ', sort keys %TYPES) . ')');
    my $table   = $meta->{table} or Carp::croak('Punk::Sqitch: the model declares no table');
    my @fields  = @{ $meta->{fields} || [] };
    Carp::croak("Punk::Sqitch: the model for $table declares no fields") unless @fields;
    my $primary = $meta->{primary};
    my $project = $o{project} // 'project';
    my $change  = $o{change}  // $table;
    my $from    = $o{model}   // 'the model';

    my @cols;
    for my $name (@fields) {
        my $spec = $meta->{field}{$name} || {};
        my $type = $spec->{type} // 'string';
        my $sql;
        if (defined $primary && $name eq $primary) {
            $sql = $type eq 'integer' ? $t->{primary_integer}
                 : ($t->{$type} // $t->{string}) . ' PRIMARY KEY';
        }
        else {
            $sql = $t->{$type};
            $sql = "$t->{string}  -- type '$type' has no mapping; pick one"
                unless defined $sql;
            $sql .= ' NOT NULL' if $spec->{required} && $sql !~ /--/;
        }
        push @cols, "    $name $sql";
    }
    my $header = sub {
        my ($what) = @_;
        return "-- $what $project:$change " . ($what eq 'Deploy' ? 'to' : 'from')
             . " $engine\n"
             . "-- Generated from $from by `punk sqitch add --model`: a starting\n"
             . "-- point. Indexes, defaults, foreign keys and the database's real\n"
             . "-- types are yours; the model is not read again.\n\n";
    };
    my $wrap = sub {
        my ($body) = @_;
        return $t->{txn} ? "BEGIN;\n\n$body\nCOMMIT;\n" : "$body";
    };
    my $deploy = $header->('Deploy')
               . $wrap->("CREATE TABLE $table (\n" . join(",\n", @cols) . "\n);\n");
    my $revert = $header->('Revert') . $wrap->("DROP TABLE $table;\n");
    my $verify = $header->('Verify')
               . $wrap->("SELECT " . join(', ', @fields) . "\n  FROM $table\n WHERE $t->{false};\n");
    return { deploy => $deploy, revert => $revert, verify => $verify };
}

sub client_for {
    my ($class, $engine, $conf) = @_;
    my $c = $CLIENT{$engine}
        or return { ok => 0, why => "no client known for the '$engine' engine - "
                                 . "Punk::Sqitch->register_client('$engine' => {...}) adds one" };
    my $named = $conf && $class->conf_get($conf, 'client', $engine);
    my @try = $named ? ($named) : ($c->{name}, @{ $c->{alternatives} || [] });
    my ($name, $path);
    for my $n (@try) {
        $name = $n;
        if (File::Spec->file_name_is_absolute($n) || $n =~ m{/}) { $path = $n }
        else {
            ($path) = grep { -x $_ } map { File::Spec->catfile($_, $n) }
                      grep { length } split /\Q$Config::Config{path_sep}\E/, $ENV{PATH} // '';
        }
        last if defined $path && -x $path;
        undef $path;
    }
    return { name => $try[0], ok => 0, why => join(' / ', @try) . ' is not on PATH' }
        unless defined $path && -x $path;
    my $out = do {
        local $ENV{LC_ALL} = 'C';
        my $pid = open my $fh, '-|';
        if (!defined $pid) { '' }
        elsif ($pid == 0) { open STDERR, '>&', \*STDOUT; exec $path, @{ $c->{args} }; exit 127 }
        else { local $/; my $o = <$fh>; close $fh; $o // '' }
    };
    my ($version) = $out =~ /(\d+\.\d+(?:\.\d+)*)/;
    my %r = (name => $name, path => $path, version => $version, ok => 1);
    if (defined $c->{min} && defined $version) {
        my @have = split /\./, $version;
        my @want = split /\./, $c->{min};
        for my $i (0 .. $#want) {
            last if ($have[$i] // 0) > $want[$i];
            if (($have[$i] // 0) < $want[$i]) {
                @r{qw(ok why)} = (0, "$name $version is older than $c->{min}, which Sqitch needs");
                last;
            }
        }
    }
    return \%r;
}

# ---- running Sqitch --------------------------------------------------------------

sub takes_target { $TAKES_TARGET{ $_[1] } ? 1 : 0 }

sub _open_handles {
    my %seen;
    return \%seen unless $INC{'DBI.pm'};
    require Scalar::Util;
    eval {
        DBI->visit_handles(sub {
            my ($h) = @_;
            $seen{ Scalar::Util::refaddr($h) } = 1 if ($h->{Type} // '') eq 'db';
            return 1;
        });
        1;
    };
    return \%seen;
}

sub _close_handles {
    my ($before) = @_;
    return unless $INC{'DBI.pm'};
    require Scalar::Util;
    eval {
        DBI->visit_handles(sub {
            my ($h) = @_;
            return 1 unless ($h->{Type} // '') eq 'db';
            return 1 if $before->{ Scalar::Util::refaddr($h) };
            eval { $h->disconnect } if $h->{Active};
            return 1;
        });
        1;
    };
    return;
}

sub run {
    my ($class, %o) = @_;
    my $verb = $o{verb} or Carp::croak('Punk::Sqitch: run needs a verb');
    my @args = @{ $o{args} || [] };
    my $target = $o{target};

    require App::Sqitch;
    require App::Sqitch::Config;
    require App::Sqitch::Command;
    require App::Sqitch::X;

    if ($target && $class->takes_target($verb)) {
        # the caller's own --target wins, as it would on the sqitch command line
        unshift @args, '--target', $target->{uri}
            unless grep { /\A(?:--target|-t)(?:=|\z)/ } @args;
    }
    local $ENV{SQITCH_PASSWORD} = $target->{password}
        if $target && defined $target->{password};

    no warnings 'redefine';
    local *App::Sqitch::Command::_pod2usage = sub {
        my ($self, %params) = @_;
        my $msg = delete $params{'-message'};
        require Pod::Find;
        require Pod::Usage;
        my $command = $self->command;
        my $find = sub { Pod::Find::pod_where({ '-inc' => 1, '-script' => 1 }, shift) };
        $params{'-input'} ||= $find->("sqitch-$command")
                          ||  $find->('sqitch')
                          ||  $find->(ref $self || $self)
                          ||  $find->('App::Sqitch::Command');
        # `help` comes through here too, asking for exit 0: that is a page
        # on STDOUT and a clean return, not an error
        my $is_help = defined $params{'-exitval'} && $params{'-exitval'} eq '0';
        delete $params{'-exitval'};
        print STDERR "punk sqitch: $msg\n" if defined $msg && length $msg;
        Pod::Usage::pod2usage(
            '-verbose'  => 99,
            '-sections' => '(?i:(Usage|Synopsis|Options))',
            '-output'   => $is_help ? \*STDOUT : \*STDERR,
            %params,
            '-exitval'  => 'NOEXIT',
            '-noperldoc' => 1,   # render here, into the handle above - no perldoc, no pager
        );
        App::Sqitch::X::hurl($is_help ? 'help' : 'usage',
                             defined $msg ? $msg : ($is_help ? 'help' : 'usage'));
    };

    my $cwd;
    if (defined $o{cwd}) {
        $cwd = Cwd::getcwd();
        chdir $o{cwd} or Carp::croak("Punk::Sqitch: cannot chdir to $o{cwd}: $!");
    }
    my $before = _open_handles();
    my $config = App::Sqitch::Config->new;
    my $sqitch = App::Sqitch->new(config => $config,
                                  options => { verbosity => $o{verbosity} // 1 });
    my $code = eval {
        my $cmd = App::Sqitch::Command->load({
            sqitch => $sqitch, config => $config, command => $verb, args => \@args,
        });
        $cmd->execute(@args) ? 0 : 2;
    };
    my $err = $@;
    _close_handles($before);
    chdir $cwd if defined $cwd;
    return $code unless $err;
    if (ref $err && eval { $err->isa('App::Sqitch::X') }) {
        my $code = $err->exitval;
        return 0 if $err->ident eq 'help';
        if ($code == 1 && $err->ident ne 'usage') {
            # Sqitch's "non-fatal": the message is information, not an error
            $sqitch->info($err->message);
        }
        else {
            $sqitch->vent($err->message) if length $err->message && $err->ident ne 'usage';
        }
        return $err->ident eq 'usage' ? 2 : ($code || 1);
    }
    my $msg = "$err";
    $msg =~ s/\s+\z//;
    print STDERR "punk sqitch: $msg\n" if length $msg;
    return 2;
}

1;

__END__

=head1 NAME

Punk::Sqitch - schema change management for Punk applications, on Sqitch

=head1 SYNOPSIS

    # the database punk.yml configures is the target, every time
    punk sqitch deploy
    punk sqitch deploy --env production
    punk sqitch status --database analytics
    punk sqitch add users -n 'users table'

    # the pieces, from Perl
    my $t = Punk::Sqitch->target_for({ dsn => 'dbi:Pg:host=db;dbname=shop',
                                       user => 'shop', password => $pw });
    # $t->{uri}      db:pg://shop@db/shop
    # $t->{engine}   pg
    # $t->{password} $pw   - handed to Sqitch through $SQITCH_PASSWORD, never the URI

=head1 DESCRIPTION

L<Sqitch|App::Sqitch> manages database schema as a plan of changes with
deploy, revert and verify scripts, recorded in a registry in the database
itself. Punk::Sqitch makes it the path of least resistance in a Punk
application: C<punk sqitch> runs any Sqitch command against the database
the application is configured for, so there is one description of that
database - the C<database> keyword, or the C<database> block of
F<config/punk.yml> with its secret behind C<$env> - and Sqitch is told the
target on every run rather than keeping its own copy in F<sqitch.conf>.

The install needs one thing the Perl side cannot supply: Sqitch runs
scripts through the database's own client, C<sqlite3> (3.3.9 or later),
C<psql> or C<mysql>, so the host that deploys needs that binary on its
C<PATH>. The application's workers never do.

=head2 Installing App::Sqitch

As of App::Sqitch v1.6.1 its own F<t/engine.t> dies on a recent
L<Test::MockModule> (the test reads C<$@> after an C<unmock> that clears
it), so C<cpanm App::Sqitch> reports a failure with no failed assertion
and does not install. C<cpanm --notest App::Sqitch> does.

=head1 THE TARGET

=head2 target_for(\%database)

Maps a C<database> options hash - C<dsn>, and optionally C<user> and
C<password> - to a Sqitch target:

    dbi:SQLite:dbname=var/app.db                     db:sqlite:var/app.db
    dbi:Pg:dbname=shop                               db:pg:shop
    dbi:Pg:host=h;port=5433;dbname=shop   + user     db:pg://user@h:5433/shop
    dbi:Pg:dbname=shop;sslmode=require               db:pg:shop?sslmode=require
    dbi:mysql:database=shop;host=h        + user     db:mysql://user@h/shop
    dbi:MariaDB:database=shop                        db:mysql:shop

Returns C<< { uri, engine, password } >>. The URI B<never carries the
password>: Sqitch reads one from C<$SQITCH_PASSWORD>, and a password that
is not in the URI is not in C<sqitch -v>'s output, a process listing or a
log. C<run> localises the variable around each command.

DSN keys other than the host, port and database name become query
parameters (C<sslmode>, C<application_name>, ...), which is how
L<URI::db> spells them and what Sqitch's engines hand to DBI. A driver
other than SQLite, Pg, mysql and MariaDB croaks naming it: declare the
target in F<sqitch.conf> for those.

=head2 Other engines

Mapped from the DBI driver out of the box: SQLite, Pg, mysql and
MariaDB, Oracle (C<sid> or C<service_name> as the database), Firebird
and ClickHouse. Two escape hatches cover the rest, both as keys on the
C<database> options - the keyword's or the F<punk.yml> block's:

    database dsn => 'dbi:Pg:dbname=shop;host=h', sqitch_engine => 'cockroach';
    database dsn => 'dbi:ODBC:DSN=warehouse',
             sqitch_target => 'db:vertica://etl@warehouse.internal/shop',
             user => 'etl', password => $pw;

C<sqitch_engine> keeps the mapping and replaces the engine name, for the
engines that ride on another's driver - CockroachDB and Yugabyte on
C<DBD::Pg>. C<sqitch_target> is the application's own URI, used as it is
whatever the DSN says (the password still travels separately). A driver
with neither croaks naming both ways out, and a third:

=head2 engine_for($driver => \%spec)

    Punk::Sqitch->engine_for(Vertica => { engine => 'vertica', name => 'database' });

Register, or replace, the mapping for a DBI driver: C<engine> is Sqitch's
engine name, C<name> the DSN key holding the database name, C<aliases>
other keys that also name it, and C<< path => 1 >> for a file-backed
engine whose name is a path and whose URI has no authority, the SQLite
shape. C<engines> lists the engine names currently mapped.

The check (C<pending>) knows where Pg, CockroachDB, Yugabyte, Oracle,
Vertica, Snowflake and Exasol keep their registry (a schema) and where
MySQL and ClickHouse do (a database beside the target); for an engine it
does not know - Firebird keeps a separate database file behind the
server - it reports an error rather than a guess, and C<punk sqitch
status> still works. The model skeleton has types for SQLite, Pg,
CockroachDB, Yugabyte, MySQL, Oracle and Firebird (C<register_types>
adds an engine), and the client probe knows every client Sqitch 1.6
looks for (C<register_client> adds one).

=head1 THE APPLICATION

=head2 The sqitch directory

Everything Sqitch owns lives together under F<sqitch/> in the application
root - the plan, the conf and the three script directories:

    myapp/
      app.psgi
      config/punk.yml
      lib/MyApp.pm
      sqitch/
        sqitch.conf
        sqitch.plan
        deploy/  revert/  verify/

C<punk sqitch init> creates it and every command runs from it, so the
application root stays the application's. A project with those files
loose in the root - the layout before this, or one made by C<sqitch init>
by hand - is used where it is; nothing has to move.

Because each project runs from its own directory, a relative SQLite path
is resolved against the B<application root>, in F<punk.yml> and in a
C<--target> of your own alike, and the directory it names is created on
C<deploy> if it is missing.

=head2 project_dir($root)

The directory holding the application's Sqitch project: F<sqitch/> under
the root when it holds a plan or a conf, the root itself when that does,
and F<sqitch/> for a project that does not exist yet.

=head2 ensure_target_dir($target, $root)

The directory a SQLite target lives in, created when missing (relative
paths against C<$root>); nothing for any other engine. Returns what it
made, or undef.

=head2 find_root($dir?)

The directory holding F<app.psgi>, walking up from C<$dir> (default the
current directory) - the rule every C<punk> command uses.

=head2 databases_for(root => $dir, env => $name, registrar => $app?)

The configured databases as C<< { name => \%options } >>, with C<default>
for the unnamed one. From the application's registrar when it can answer
(C<< $app->databases >>, Punk 0.31), else from F<config/punk.yml> resolved
for the environment through L<Punk::Config> - secrets included, because
Sqitch needs the real password.

=head2 database_for(\%databases, $name?)

One database's options, or a croak listing the names there are.

=head1 THE CHECK

    my $r = Punk::Sqitch->pending(root => $root, database => \%db);
    # { project, plan_file, registry, deployed => N, pending => [...],
    #   drift => undef|"...", error => undef|"..." }

Is the schema behind the code? The plan against the registry, computed
here and used twice: by C<punk sqitch pending> as a deploy gate and by
L<Punk::Plugin::Sqitch> at boot. Sqitch's own C<status> prints the answer
and exits 0 either way, and its C<check> reports something else - a
deployed script edited since, by hash - so this is the other half.

=head2 pending(root => $dir, database => \%db, %opts)

C<pending> is the plan's changes beyond the number the registry holds for
the project. B<Counts, not names>: a reworked change is in the plan twice
under one name and in the registry twice with two ids, so the first N
plan entries are what N deployed rows stand for. The Nth deployed name is
checked against the Nth plan entry, and a mismatch - or more rows than the
plan has entries - is C<drift>: something deployed here that the plan does
not describe, which no C<deploy> will fix. A registry that does not exist
yet is "nothing deployed", everything pending, and not an error; one that
cannot be reached or read is C<error>, and the caller decides - the boot
check warns and starts.

Options: C<target> (from C<target_for>, computed otherwise), C<conf> (from
C<read_conf>, read from F<sqitch.conf> in the root otherwise), C<plan_file>
(from C<plan_file_for> otherwise). A missing plan croaks naming the path
and C<punk sqitch init>.

One C<SELECT> through DBI, with no L<App::Sqitch> loaded: the boot check
runs in a web worker's parent, where loading a Moo application to answer
a yes/no question would be the wrong cost.

=head2 read_conf($file)

F<sqitch.conf> as a flat hash, C<section.key> and C<section.sub.key>
(C<[engine "sqlite"]> gives C<engine.sqlite.*>), comments and quotes
handled. Only the project's own file: a registry renamed in
F<~/.sqitch/sqitch.conf> is not seen.

=head2 conf_get(\%conf, $key, $engine?, $target?)

One key by Sqitch's precedence: C<target.$target.$key>, then
C<engine.$engine.$key>, then C<core.$key>.

=head2 plan_file_for($root, \%conf, $engine?)

C<plan_file> from the conf (relative to the root), else C<top_dir> (or the
root) joined with F<sqitch.plan>.

=head2 read_plan($file)

C<< { project, uri, changes => [names], tags => [names], deps => { change
=> [deps] }, requires => [projects] } >>: the C<%project> and C<%uri>
pragmas, every change's name in order (a reworked one twice), the tags,
each change's dependencies, and the other projects those dependencies
name (C<project:change>). A plan without C<%project> croaks.

=head2 pending_all(root => $dir, database => \%db, projects => \@projects?)

C<pending> for every project in the list (C<projects> when none is
given), in the list's order: a plugin project's plan from its own
directory, the registry the target's.

=head2 projects(root => $dir, app_only => 0|1)

The projects a target verb runs over: the plugins' in deploy order -
found by loading the application class (C<load_app>) so its plugins
register them - then the application's own. Each is
C<< { name, dir, plan_file, conf, plan, plugin => 0|1 } >>. With
C<app_only> the application's alone, and nothing is loaded.

=head2 app_project(root => $dir, conf => \%conf?, plan_file => $file?)

The application's own project entry.

=head2 project_list(\%app_project, \@plugin_projects)

The plugins' projects then the application's, checking the one policy
the arrangement needs: with plugin projects the registry keeps its
default name (L<Punk::Plugin::Sqitch/"The registry keeps its default name">).

=head2 app_class_for($root)

The application class named in F<app.psgi>, without running it.

=head2 load_app($root)

Load that class - F<lib/> under the root on C<@INC> - with the boot check
held off, so its plugins register their projects. Croaks naming the class
when it will not load.

=head2 target_abs($target, $root)

A SQLite target made absolute against the root, for a run whose working
directory is a plugin's project; other engines' targets already are.

=head2 registry_for(\%db, $target, \%conf)

Where Sqitch keeps the registry for a target, as its engines decide it:
for SQLite a B<file> - the registry name (C<sqitch> unless the conf says
otherwise) in place of the target's basename, keeping its extension, so
F<app.db> gives F<sqitch.db> beside it, an absolute registry as is; for
PostgreSQL a B<schema> in the target database; for MySQL a B<database> on
the same server. C<< { engine, name, kind, path?, connect => [@dbi_args] } >>.

=head1 SCAFFOLDING

=head2 project_name_for($app_class)

A Sqitch project name for an application class: lowercased, C<::> to
C<_>, always inside Sqitch's C<[A-Za-z][\w-]*>.

=head2 skeleton(meta => \%meta, engine => $engine, %opts)

The C<deploy>, C<revert> and C<verify> scripts for a L<Punk::Model>'s
table, from its metadata (C<table>, C<fields>, C<field>, C<primary>), for
C<sqlite>, C<pg> or C<mysql>. Types map C<integer>, C<string>, C<number>
and C<boolean>; the primary key becomes the engine's autoincrement when it
is an integer; C<required> is C<NOT NULL>; a type with no mapping is
C<text> with a comment asking for one. Options C<project>, C<change> and
C<model> fill the header. Returns C<< { deploy, revert, verify } >>.

=head2 register_types($engine => \%types)

    Punk::Sqitch->register_types(vertica => {
        integer => 'BIGINT', string => 'VARCHAR(4000)', number => 'FLOAT',
        boolean => 'BOOLEAN', primary_integer => 'IDENTITY PRIMARY KEY',
        txn => 0, false => 'FALSE' });

The skeleton's types for an engine: C<integer>, C<string>, C<number> and
C<boolean> for L<Punk::Model>'s field types, C<primary_integer> for the
integer primary key's whole declaration, C<txn> whether the scripts wrap
in C<BEGIN>/C<COMMIT>, C<false> the WHERE-nothing predicate. Replaces a
built-in engine's as readily as it adds one.

=head2 register_client($engine => \%client)

    Punk::Sqitch->register_client(mydb => { name => 'mydb-cli', args => ['--version'],
                                            min => '2.0', alternatives => ['mydb'] });

The client an engine deploys through: C<name> on C<PATH>, C<alternatives>
the other names to try, C<args> what prints its version, C<min> the oldest
Sqitch accepts.

=head2 client_for($engine, \%conf)

The client binary the engine deploys through - Sqitch's default name, or
C<[engine "x"] client> from the conf - found on C<PATH> and asked its
version: C<< { name, path, version, ok, why } >>. A C<sqlite3> older than
3.3.9, which Sqitch refuses, is not C<ok>.

=head1 RUNNING SQITCH

=head2 run(verb => $verb, args => \@args, target => $target?, cwd => $dir?, verbosity => $n?)

One Sqitch command, in-process, through L<App::Sqitch::Command>. For a
verb that takes a target (C<deploy>, C<revert>, C<verify>, C<status>,
C<log>, C<check>, C<checkout>, C<rebase>, C<upgrade>, C<bundle>) the
target's URI is passed as C<--target> unless the arguments already carry
one, and its password as C<$SQITCH_PASSWORD> for the duration. With C<cwd> the
command runs from that directory and the previous one is restored
afterwards, whatever happens. Returns the exit code by Sqitch's own
rules: 0, the exception's code for one of Sqitch's (a failed deploy is 2),
2 for a usage error, with the message on C<STDERR> as C<punk sqitch: ...>.

In-process rather than C<exec sqitch> because L<Punk::Command>'s C<main>
localises C<STDOUT> and C<STDERR> and returns an exit code, so a test of
C<punk sqitch status> reads both without spawning. The C<sqitch> binary
is not required on C<PATH>; the engine's client is.

=head2 takes_target($verb)

Whether a verb accepts C<--target>.

=head1 SEE ALSO

L<Punk::Command::Sqitch>, L<App::Sqitch>, L<sqitch|https://sqitch.org>,
L<Punk>.

=head1 AUTHOR

LNATION <email@lnation.org>

=head1 LICENSE AND COPYRIGHT

This software is Copyright (c) 2026 by LNATION <email@lnation.org>.

This is free software, licensed under:

  The Artistic License 2.0 (GPL Compatible)

=cut
