use strict;
use warnings;
use Test::More;
use Test::Exception;
use DBIx::Fast;

eval "use DBD::SQLite 1.74";
plan skip_all => "DBD::SQLite 1.74 required" if $@;

my $db = DBIx::Fast->new(
    dsn        => 'dbi:SQLite:dbname=:memory:',
    driver     => 'SQLite',
    RaiseError => 1,
    PrintError => 0,
);

$db->exec(q{
    CREATE TABLE users (
        id INTEGER PRIMARY KEY,
        name TEXT NOT NULL,
        email TEXT,
        status INTEGER DEFAULT 1
    )
});

$db->exec(q{ INSERT INTO users (name, email) VALUES ('Alice', 'alice@test.com') });
$db->exec(q{ INSERT INTO users (name, email) VALUES ('Bob', 'bob@test.com') });
$db->exec(q{ INSERT INTO users (name, email) VALUES ('Charlie', 'charlie@test.com') });

# --- _safe_id ---

subtest '_safe_id rejects injection payloads' => sub {
    my @payloads = (
        q{'; DROP TABLE users; --},
        q{table; DELETE FROM users},
        q{1 OR 1=1},
        q{users WHERE 1=1 --},
        q{`users`},
        q{"users"},
        q{users; SELECT},
        q{us ers},
        q{123start},
        q{},
        q{ },
        q{table\x00name},
        q{table--name},
        q{table/**/name},
    );

    for my $payload (@payloads) {
        throws_ok { $db->_safe_id($payload) }
            qr/Invalid identifier/,
            "_safe_id rejects: '$payload'";
    }

    throws_ok { $db->_safe_id(undef) }
        qr/Invalid identifier/,
        '_safe_id rejects undef';
};

subtest '_safe_id accepts valid identifiers' => sub {
    my @valid = (
        'users',
        'order_items',
        '_private',
        'UserProfile',
        'schema.table',
        'a',
        'A123',
        '_under_score',
        'db.schema.table',
    );

    for my $name (@valid) {
        lives_ok { $db->_safe_id($name) }
            "_safe_id accepts: '$name'";
        is($db->_safe_id($name), $name, "_safe_id returns name unchanged: '$name'");
    }
};

# --- _quote_id ---

subtest '_quote_id produces quoted identifiers' => sub {
    my $quoted = $db->_quote_id('users');
    ok(defined $quoted, '_quote_id returns a value');
    like($quoted, qr/users/, '_quote_id contains the identifier name');
    # SQLite uses double quotes
    like($quoted, qr/"users"/, '_quote_id wraps in quotes (SQLite)');

    throws_ok { $db->_quote_id("users; DROP TABLE") }
        qr/Invalid identifier/,
        '_quote_id rejects injection via _safe_id';
};

# --- _make_where ---

subtest '_make_where rejects invalid operators' => sub {
    my @bad_ops = (
        'OR 1=1 --',
        'UNION',
        '; DROP',
        'IN',
        'EXISTS',
        'HAVING',
    );

    for my $op (@bad_ops) {
        throws_ok {
            $db->count('users', { name => { $op => 'test' } });
        } qr/Invalid operator/,
            "_make_where rejects operator: '$op'";
    }
};

subtest '_make_where accepts valid operators' => sub {
    my %ops_and_values = (
        '='       => 'Alice',
        '!='      => 'Nobody',
        '<>'      => 'Nobody',
        '<'       => 'Z',
        '<='      => 'Z',
        '>'       => 'A',
        '>='      => 'A',
        'LIKE'    => '%ali%',
    );

    for my $op (sort keys %ops_and_values) {
        lives_ok {
            $db->count('users', { name => { $op => $ops_and_values{$op} } });
        } "_make_where accepts operator: '$op'";
    }
};

# --- count() injection protection ---

subtest 'count() rejects table name injection' => sub {
    # TableName now format-validates unconditionally, so the rejection fires
    # there (before _quote_id's "Invalid identifier" backstop).
    throws_ok { $db->count("users; DROP TABLE users") }
        qr/TableName not valid|Invalid identifier/,
        'count() rejects SQL in table name';

    throws_ok { $db->count("users' OR '1'='1") }
        qr/TableName not valid|Invalid identifier/,
        'count() rejects quote injection in table name';
};

subtest 'count() works correctly with valid input' => sub {
    is($db->count('users'), 3, 'count() returns correct count');
    is($db->count('users', { name => 'Alice' }), 1, 'count() with WHERE works');
    is($db->count('users', { name => 'Nonexistent' }), 0, 'count() returns 0 for no match');
};

# (query()/Result iterator coverage lives in t/result.t)

# --- Parameterized queries cannot inject ---

subtest 'bind parameters prevent injection' => sub {
    my $evil = "' OR '1'='1";

    my $count = $db->count('users', { name => $evil });
    is($count, 0, 'SQL injection via WHERE value returns 0 rows, not all');

    my $result = $db->all("SELECT * FROM users WHERE name = ?", $evil);
    is(scalar @$result, 0, 'all() with injection payload returns empty');

    my $row = $db->hash("SELECT * FROM users WHERE name = ?", $evil);
    is($row, undef, 'hash() with injection payload returns undef');
};

# --- Savepoint name validation ---

subtest 'savepoint rejects invalid names' => sub {
    $db->transaction->do(sub {
        throws_ok { $db->transaction->savepoint("sp; DROP TABLE users") }
            qr/Invalid savepoint name/,
            'Savepoint rejects semicolon injection';

        throws_ok { $db->transaction->savepoint("sp name") }
            qr/Invalid savepoint name/,
            'Savepoint rejects spaces';

        throws_ok { $db->transaction->savepoint("sp'name") }
            qr/Invalid savepoint name/,
            'Savepoint rejects quotes';

        throws_ok { $db->transaction->savepoint("123sp") }
            qr/Invalid savepoint name/,
            'Savepoint rejects leading digit';

        throws_ok { $db->transaction->savepoint("") }
            qr/Savepoint name required/,
            'Savepoint rejects empty name';
    });
};

subtest 'savepoint accepts valid names' => sub {
    $db->transaction->do(sub {
        lives_ok { $db->transaction->savepoint('sp1') }
            'Savepoint accepts simple name';
        lives_ok { $db->transaction->savepoint('my_savepoint') }
            'Savepoint accepts underscore name';
        lives_ok { $db->transaction->savepoint('_private') }
            'Savepoint accepts leading underscore';
    });
};

# --- CRUD identifier injection regression tests ---
# Pre-fix vulnerability: insert/update/delete/up did not validate column names,
# allowing payloads like { 'name = (SELECT secret FROM users), id' => 99 }
# to inject extra SET clauses and exfiltrate column values across rows.

subtest 'insert() rejects malicious column names' => sub {
    throws_ok {
        $db->insert('users', {
            q{name = (SELECT secret FROM users), id} => 99
        });
    } qr/Invalid identifier/,
        'insert() rejects identifier injection payload';

    throws_ok {
        $db->insert('users', { q{name; DROP TABLE users} => 'x' });
    } qr/Invalid identifier/,
        'insert() rejects semicolon injection';

    throws_ok {
        $db->insert('users', { q{name, status} => 'x' });
    } qr/Invalid identifier/,
        'insert() rejects comma-separated columns';
};

subtest 'update() rejects malicious column names in SET' => sub {
    throws_ok {
        $db->update('users', {
            sen   => { q{name = (SELECT email FROM users WHERE id=1), id} => 99 },
            where => { id => 1 },
        });
    } qr/Invalid identifier/,
        'update() SET clause rejects identifier injection';

    throws_ok {
        $db->update('users', {
            sen   => { q{name = email, foo} => 'x' },
            where => { id => 1 },
        });
    } qr/Invalid identifier/,
        'update() SET rejects payload without keywords';
};

subtest 'update() rejects malicious column names in WHERE' => sub {
    throws_ok {
        $db->update('users', {
            sen   => { name => 'safe' },
            where => { q{id; DROP TABLE users} => 1 },
        });
    } qr/Invalid identifier/,
        'update() WHERE clause rejects identifier injection';
};

subtest 'delete() rejects malicious column names in WHERE' => sub {
    throws_ok {
        $db->delete('users', { q{1=1) OR (1} => 1 });
    } qr/Invalid identifier/,
        'delete() WHERE clause rejects identifier injection';
};

subtest 'up() rejects malicious time_col' => sub {
    throws_ok {
        $db->up('users', { name => 'test' }, { id => 1 },
                q{updated_at, name = (SELECT email FROM users)});
    } qr/Invalid identifier/,
        'up() rejects identifier injection via time_col';
};

subtest 'extra_args rejects malicious time key' => sub {
    throws_ok {
        $db->insert('users', { name => 'test' },
                    time => q{created_at, name = email});
    } qr/Invalid identifier/,
        'extra_args() rejects identifier injection via time key';
};

# Verify the exploit-targeted payload does NOT modify data
subtest 'identifier injection cannot exfiltrate data' => sub {
    my $before = $db->all("SELECT * FROM users ORDER BY id");

    eval {
        $db->update('users', {
            sen   => { q{name = (SELECT email FROM users WHERE id=1), id} => 99 },
            where => { id => 1 },
        });
    };
    ok($@, 'update() with exploit payload threw an exception');

    my $after = $db->all("SELECT * FROM users ORDER BY id");
    is_deeply($after, $before, 'data is unchanged after blocked injection attempt');
};

# The operator whitelist must cover non-HASH WHERE specs too: SQL::Abstract
# accepts an arrayref (OR-of-conditions) and a scalarref (literal SQL), and
# earlier _safe_columns bailed out silently on anything that was not a hash.
subtest 'update/delete reject non-hash WHERE injection shapes' => sub {
    my $n = $db->count('users');

    throws_ok {
        $db->delete('users', [ { id => { '= 999 OR 1=1 OR id = ' => 999 } } ]);
    } qr/Invalid operator/, 'arrayref WHERE with injected operator is rejected';

    throws_ok {
        $db->delete('users', \'1=1');
    } qr/Literal-SQL WHERE is not allowed/, 'scalarref (literal SQL) WHERE is rejected';

    throws_ok {
        $db->update('users', { sen => { name => 'x' },
                               where => [ { id => { '= 1 OR 1=1 OR id = ' => 1 } } ] });
    } qr/Invalid operator/, 'update() arrayref WHERE injection is rejected';

    is($db->count('users'), $n, 'no rows were harmed by the blocked payloads');

    # A legitimate OR-of-conditions arrayref (clean operators) still works.
    lives_ok {
        $db->count('users');   # keep $n meaningful
        my $rows = $db->all('SELECT id FROM users LIMIT 2');
        if (@$rows >= 2) {
            $db->update('users',
                { sen => { name => 'orlist' },
                  where => [ { id => $rows->[0]{id} }, { id => $rows->[1]{id} } ] });
        }
    } 'legitimate arrayref OR-conditions WHERE is accepted';
};

# Verify normal CRUD operations still work after the fix
subtest 'normal CRUD operations work after the fix' => sub {
    lives_ok {
        $db->insert('users', { name => 'Dave', email => 'dave@test.com' });
    } 'insert() with safe columns works';

    lives_ok {
        $db->update('users',
            { sen => { name => 'Daniel' }, where => { name => 'Dave' } });
    } 'update() with safe columns works';

    is($db->val('SELECT name FROM users WHERE name = ?', 'Daniel'), 'Daniel',
       'update() actually changed the row');

    lives_ok {
        $db->delete('users', { name => 'Daniel' });
    } 'delete() with safe columns works';
};
# Verify SQL::Abstract is quoting identifiers (defense-in-depth)
subtest 'SQL::Abstract is configured with quote_char' => sub {
    $db->insert('users', { name => 'QuoteCheck' });
    like($db->last_sql, qr/"users"/,
         'generated INSERT uses double-quoted table identifier (SQLite)');
    like($db->last_sql, qr/"name"/,
         'generated INSERT uses double-quoted column identifier (SQLite)');

    $db->delete('users', { name => 'QuoteCheck' });
};

# --- Error buffer hardening ---

subtest 'errors buffer respects max_errors cap (FIFO)' => sub {
    my $small = DBIx::Fast->new(
        dsn        => 'dbi:SQLite:dbname=:memory:',
        driver     => 'SQLite',
        RaiseError => 0,
        PrintError => 0,
        max_errors => 3,
    );

    $small->set_error($_, "err-$_") for 1..10;

    is(scalar @{ $small->errors }, 3,
       'errors array is capped at max_errors=3');
    is($small->errors->[0]{error}, 'err-8',
       'oldest kept entry is err-8 (FIFO dropped 1..7)');
    is($small->errors->[-1]{error}, 'err-10',
       'newest entry is err-10');
};

subtest 'errors_redact masks quoted values in error messages' => sub {
    my $redacted = DBIx::Fast->new(
        dsn            => 'dbi:SQLite:dbname=:memory:',
        driver         => 'SQLite',
        RaiseError     => 0,
        PrintError     => 0,
        errors_redact  => 1,
    );

    $redacted->set_error(1062,
        q{Duplicate entry 'tok_4242424242424242' for key 'idx_payment'});
    my $msg = $redacted->errors->[-1]{error};
    unlike($msg, qr/4242424242424242/,
           'card-like token is redacted in error message');
    unlike($msg, qr/idx_payment/,
           'key name (sensitive table internal) is redacted');
    like($msg, qr/<redacted>/, 'redaction marker present');

    # Without errors_redact (default) values are kept (back-compat)
    my $plain = DBIx::Fast->new(
        dsn        => 'dbi:SQLite:dbname=:memory:',
        driver     => 'SQLite',
        RaiseError => 0,
        PrintError => 0,
    );
    $plain->set_error(1062,
        q{Duplicate entry 'secret_value' for key 'idx'});
    like($plain->errors->[-1]{error}, qr/secret_value/,
         'default: values are NOT redacted (back-compat)');
};

# --- Transaction isolation level ---

subtest 'txn() rejects invalid isolation level (whitelist)' => sub {
    my @bad = (
        q{READ UNCOMMITTED; DROP TABLE users},
        q{SERIALIZABLE'},
        q{NONSENSE},
        q{},
    );
    for my $bad (@bad) {
        throws_ok {
            $db->txn(sub { 1 }, { isolation => $bad });
        } qr/Invalid isolation level/,
            "Rejects malicious/invalid isolation: '$bad'";
    }
};

subtest 'txn() accepts valid isolation level (SQLite is no-op)' => sub {
    for my $level ('READ UNCOMMITTED', 'READ COMMITTED',
                   'REPEATABLE READ', 'SERIALIZABLE',
                   'read committed', '  serializable  ')
    {
        my $ok = $db->txn(sub { 1 }, { isolation => $level });
        ok($ok, "Accepts isolation '$level' (SQLite no-op)");
    }
};

# --- 0.17 audit round 3 regressions ---

subtest 'update/delete reject injected operator keys (nested WHERE)' => sub {
    for my $op ("= 1 OR 1=1 -- ", "= (SELECT email FROM users LIMIT 1) -- ",
                "> 0; DROP TABLE users; --") {
        throws_ok {
            $db->update('users', { sen   => { status => 0 },
                                   where => { id => { $op => 1 } } });
        } qr/Invalid operator/, "update rejects operator: '$op'";

        throws_ok {
            $db->delete('users', { id => { $op => 1 } });
        } qr/Invalid operator/, "delete rejects operator: '$op'";
    }

    # Legit operators (and SQL::Abstract dash-ops) still work.
    lives_ok {
        $db->update('users', { sen   => { status => 1 },
                               where => { id => { '>=' => 1 } } });
    } 'update with whitelisted operator works';
    lives_ok {
        $db->delete('users', { id => { -in => [999_999] } });
    } 'delete with SQL::Abstract dash-op works';

    is($db->count('users'), 3, 'no rows were harmed by the payloads');
};

subtest 'exception on unknown DSN scheme redacts credentials' => sub {
    eval { DBIx::Fast->new(dsn => 'redis://root:s3cr3t@dbhost/app') };
    my $err = $@ // '';
    like($err, qr/_dsn_to_dbi/, 'unknown scheme still throws');
    unlike($err, qr/s3cr3t/, 'password does not appear in the exception');
    like($err, qr/<redacted>/, 'userinfo is redacted');
};

subtest 'DB error messages echoing "deadlock" do not force a txn retry' => sub {
    my $attempts = 0;
    eval {
        $db->txn(sub {
            $attempts++;
            # A coded driver error whose MESSAGE contains 'deadlock'
            # ("no such table: deadlock_missing") - must NOT be retried.
            $db->exec(q{ SELECT * FROM deadlock_missing });
        }, { max_retries => 3, retry_delay => 0 });
    };
    is($attempts, 1, 'transaction body ran exactly once (no spurious retry)');

    # The documented convention still works: a user-thrown 'deadlock' with no
    # driver error code does trigger retries.
    $attempts = 0;
    eval {
        $db->txn(sub {
            $attempts++;
            die "deadlock: please retry\n";
        }, { max_retries => 2, retry_delay => 0 });
    };
    is($attempts, 3, 'user-thrown deadlock convention still retries');
};

subtest 'cached() keys are namespaced by connection identity' => sub {
    eval { require LRU::Cache; 1 }
        or plan skip_all => 'LRU::Cache required for the default cache backend';

    my $shared = LRU::Cache->new(100);

    my $mk = sub {
        my ($file) = @_;
        DBIx::Fast->new(
            dsn        => "dbi:SQLite:dbname=$file",
            driver     => 'SQLite',
            RaiseError => 1, PrintError => 0,
            cache      => { backend => $shared },
        );
    };

    my $db_a = $mk->(':memory:');
    # A second in-memory DB is a different database with identical SQL surface,
    # but its DSN is the same string - so give it a distinct file-backed DSN.
    my $tmp  = ($ENV{TMPDIR} // '/tmp') . "/dbixfast-ns-$$.db";
    open my $touch, '>', $tmp or die $!; close $touch;
    my $db_b = $mk->($tmp);

    for my $d ($db_a, $db_b) {
        $d->exec(q{ CREATE TABLE t (v TEXT) });
    }
    $db_a->exec(q{ INSERT INTO t (v) VALUES ('from-A') });
    $db_b->exec(q{ INSERT INTO t (v) VALUES ('from-B') });

    is($db_a->cached->val('SELECT v FROM t'), 'from-A', 'A sees its own row');
    is($db_b->cached->val('SELECT v FROM t'), 'from-B',
       'B is not served A\'s cached row despite the shared backend');

    unlink $tmp;
};

subtest 'EXPLAIN allowlist rejects DoS functions and mode-desync literals' => sub {
    require DBIx::Fast::Profile::MariaDB;
    my $p = DBIx::Fast::Profile::MariaDB->new(dbix => $db);

    ok(!$p->_validate_explainable_sql('SELECT * FROM (SELECT SLEEP(30)) x'),
       'SLEEP rejected');
    ok(!$p->_validate_explainable_sql('SELECT BENCHMARK(100000000, MD5(1))'),
       'BENCHMARK rejected');
    # NO_BACKSLASH_ESCAPES desync: under that server mode the backslash does
    # not escape the quote, so the "literal" below actually ends early and
    # LOAD_FILE is live SQL. Both parsings must be clean.
    ok(!$p->_validate_explainable_sql(
         q{SELECT '\', LOAD_FILE('/etc/passwd'), '' FROM t}),
       'literal-hidden LOAD_FILE rejected in either quoting mode');
    ok( $p->_validate_explainable_sql(q{SELECT note FROM t WHERE note = 'load_file x'}),
       'benign literal still allowed');
};

done_testing;
