view release on metacpan or  search on metacpan

lib/DBD/D1.pm  view on Meta::CPAN

# Pass Cloudflare API token as $password.
sub connect {
    my ($drh, $dsn, $user, $auth, $attr) = @_;

    my %dsnargs;
    for my $pair (split /;/, $dsn) {
        my ($k, $v) = split /=/, $pair, 2;
        $dsnargs{$k} = $v if defined $k && defined $v;
    }

    # Use DBI->set_err on the drh with the caller's err/errstr so that
    # PrintError/RaiseError on the caller handle control output, not the drh.
    my $account_id = $dsnargs{account_id}
        or return $drh->set_err(1,
            "DBD::D1 connect: 'account_id' missing from DSN", undef, 'connect');

    my $database_id = $dsnargs{database_id}
        or return $drh->set_err(1,
            "DBD::D1 connect: 'database_id' missing from DSN", undef, 'connect');

    my $api_token = $auth || $dsnargs{api_token}
        or return $drh->set_err(1,
            "DBD::D1 connect: Cloudflare API token required (pass as password)", undef, 'connect');

    my ($outer, $dbh) = DBI::_new_dbh($drh, { Name => $dsn });

    $dbh->{Active}          = 1;
    $dbh->{d1_account_id}   = $account_id;
    $dbh->{d1_database_id}  = $database_id;
    $dbh->{d1_api_token}    = $api_token;

    return $outer;
}

sub data_sources { () }
sub disconnect_all { }

# ---------------------------------------------------------------
# DBD::D1::db  – database handle
# ---------------------------------------------------------------
package DBD::D1::db;

use strict;
use warnings;

$DBD::D1::db::imp_data_size = 0;

sub prepare {
    my ($dbh, $statement, @attribs) = @_;

    my ($outer, $sth) = DBI::_new_sth($dbh, { Statement => $statement });

    # Count ? placeholders outside quoted strings
    (my $copy = $statement) =~ s/'[^']*'|"[^"]*"//g;
    my $num_params = () = $copy =~ /\?/g;

    $sth->{NUM_OF_PARAMS}    = $num_params;
    $sth->{d1_params}        = [];
    $sth->{d1_rows_affected} = undef;
    $sth->{d1_result_data}   = undef;
    $sth->{d1_cursor}        = 0;

    return $outer;
}

sub commit {
    my ($dbh) = @_;
    warn "DBD::D1: commit() has no effect – D1 is AutoCommit only\n"
        if $dbh->{Warn};
    return 1;
}

sub rollback {
    my ($dbh) = @_;
    warn "DBD::D1: rollback() has no effect – D1 is AutoCommit only\n"
        if $dbh->{Warn};
    return 0;
}

sub disconnect {
    my ($dbh) = @_;
    $dbh->{Active} = 0;
    return 1;
}

sub ping {
    my ($dbh) = @_;
    my $prev_raise = $dbh->{RaiseError};
    my $prev_print = $dbh->{PrintError};
    $dbh->{RaiseError} = 0;
    $dbh->{PrintError} = 0;

    my $ok = 0;
    eval {
        my $sth = $dbh->prepare('SELECT 1');
        $ok = 1 if $sth && $sth->execute();
    };

    $dbh->{RaiseError} = $prev_raise;
    $dbh->{PrintError} = $prev_print;
    return $ok;
}

sub FETCH {
    my ($dbh, $attr) = @_;
    return 1          if $attr eq 'AutoCommit';
    return $dbh->{$attr} if $attr =~ /^d1_/;
    return $dbh->SUPER::FETCH($attr);
}

sub STORE {
    my ($dbh, $attr, $val) = @_;
    if ($attr eq 'AutoCommit') {
        die "DBD::D1: AutoCommit cannot be disabled\n" unless $val;
        return 1;
    }
    if ($attr =~ /^d1_/) { $dbh->{$attr} = $val; return 1 }
    return $dbh->SUPER::STORE($attr, $val);
}

sub table_info {

lib/DBD/D1.pm  view on Meta::CPAN

# ---------------------------------------------------------------
# DBD::D1::st  – statement handle
# ---------------------------------------------------------------
package DBD::D1::st;

use strict;
use warnings;

$DBD::D1::st::imp_data_size = 0;

sub bind_param {
    my ($sth, $pNum, $val, $attr) = @_;
    $sth->{d1_params}[$pNum - 1] = $val;
    return 1;
}

sub execute {
    my ($sth, @bind_values) = @_;

    my @params = @bind_values ? @bind_values : @{ $sth->{d1_params} // [] };

    my $dbh         = $sth->{Database};
    my $account_id  = $dbh->{d1_account_id};
    my $database_id = $dbh->{d1_database_id};
    my $api_token   = $dbh->{d1_api_token};
    my $sql         = $sth->{Statement};

    my ($result, $err) = DBD::D1::_http::query(
        $account_id, $database_id, $api_token, $sql, \@params,
    );

    if (defined $err) {
        return $sth->set_err(1, $err);
    }

    # D1 REST returns an array of result objects (one per statement).
    my $res  = ref($result) eq 'ARRAY' ? $result->[0] : $result;
    my $rows = $res->{results} // [];   # array of hashrefs
    my $meta = $res->{meta}    // {};

    if (@$rows) {
        my @col_names = sort keys %{ $rows->[0] };

        # Must use direct hash assignment – STORE() rejects DBI read-only attrs
        $sth->{NAME}          = \@col_names;
        $sth->{NAME_lc}       = [ map { lc $_ } @col_names ];
        $sth->{NAME_uc}       = [ map { uc $_ } @col_names ];
        $sth->{NUM_OF_FIELDS} = scalar @col_names;

        $sth->{d1_result_data} = [
            map { my $r = $_; [ @{$r}{@col_names} ] } @$rows
        ];
    } else {
        $sth->{NAME}           = [];
        $sth->{NAME_lc}        = [];
        $sth->{NAME_uc}        = [];
        $sth->{NUM_OF_FIELDS}  = 0;
        $sth->{d1_result_data} = [];
    }

    $sth->{d1_cursor}        = 0;
    $sth->{d1_rows_affected} = $meta->{changes} // $meta->{rows_affected} // 0;
    $sth->{Active}           = 1;

    return $sth->{d1_rows_affected} || '0E0';
}

sub fetchrow_arrayref {
    my ($sth) = @_;
    my $data   = $sth->{d1_result_data} or return undef;
    my $cursor = $sth->{d1_cursor};

    if ($cursor >= scalar @$data) {
        $sth->{Active} = 0;
        return undef;
    }

    $sth->{d1_cursor}++;
    return $data->[$cursor];
}

*fetch = \&fetchrow_arrayref;

sub fetchall_arrayref {
    my ($sth, $slice, $max_rows) = @_;
    my $data = $sth->{d1_result_data} // [];
    my @result;

    for my $row (@$data) {
        last if defined $max_rows && @result >= $max_rows;
        if (!defined $slice) {
            push @result, [@$row];
        } elsif (ref $slice eq 'HASH') {
            my $names = $sth->{NAME} // [];
            my %h; @h{@$names} = @$row;
            my @keys = keys %$slice ? keys %$slice : keys %h;
            push @result, { map { $_ => $h{$_} } @keys };
        } elsif (ref $slice eq 'ARRAY') {
            push @result, [ @{$row}[@$slice] ];
        }
    }

    $sth->{Active} = 0;
    return \@result;
}

sub rows   { $_[0]->{d1_rows_affected} // -1 }

sub finish {
    my ($sth) = @_;
    $sth->{Active}          = 0;
    $sth->{d1_result_data}  = undef;
    $sth->{d1_cursor}       = 0;
    return 1;
}

sub FETCH {
    my ($sth, $attr) = @_;
    return $sth->{$attr} if $attr =~ /^d1_/;
    return $sth->SUPER::FETCH($attr);
}

sub STORE {
    my ($sth, $attr, $val) = @_;
    if ($attr =~ /^d1_/) { $sth->{$attr} = $val; return 1 }
    return $sth->SUPER::STORE($attr, $val);
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

DBD::D1 - DBI driver for Cloudflare D1 (serverless SQLite)

=head1 VERSION

0.02

=head1 SYNOPSIS

    use DBI;

    my $dbh = DBI->connect(
        'dbi:D1:account_id=<ACCOUNT_ID>;database_id=<DATABASE_ID>',
        undef,
        $ENV{CF_API_TOKEN},
        { RaiseError => 1, PrintError => 0 },
    ) or die $DBI::errstr;

    my $sth = $dbh->prepare('SELECT * FROM users WHERE active = ?');
    $sth->execute(1);

    while (my $row = $sth->fetchrow_hashref) {
        printf "%s <%s>\n", $row->{name}, $row->{email};
    }

    $dbh->disconnect;

=head1 DESCRIPTION

B<DBD::D1> is a L<DBI> driver for L<Cloudflare D1|https://developers.cloudflare.com/d1/>,
Cloudflare's serverless SQLite-compatible relational database.

It communicates via the D1 REST API using L<HTTP::Tiny> and L<JSON::PP>
(both ship with Perl 5.14+), so no compiled extensions are required.

=head1 DSN FORMAT