Compare commits

..

No commits in common. "master" and "0.5" have entirely different histories.
master ... 0.5

33 changed files with 756 additions and 1434 deletions

View file

@ -1,51 +1,3 @@
1.4 - 2026-01-10
- FU::Pg: rename q() and Q() to sql() and SQL() (old names still work)
- FU: Improve handling of EPIPE when writing FastCGI response
- FU: Log unclean worker process shutdown
- FU: Fix warning when parsing empty cookie values
- Misc doc fixes
1.3 - 2025-09-04
- FU::Validate: Scalar validations now reject control characters by default
- FU::Validate: Add `allow_control` option to override above behavior
- FU::Util: JSON and URI parsing now always permit control characters
- FU::Util: More strict UTF-8 validation on path & URI decoding
- FU::Util: Deprecate `decode_utf8()`
- FU::Util: Deprecate `allow_control` option in `json_parse()`
1.2 - 2025-07-06
- FU::Pg: Throw error on non-boolean-looking Perl values for boolean bind
parameters
- FU: Improve setting process status during startup
1.1 - 2025-06-07
- FU::SQL: Add IDENT function and `quote_identifier` option
- FU::Pg: Set appropriate `quote_identifier` for `$conn->Q()`
- FU: Improve `--monitor` file change detection
- FU::XMLWriter: Disallow stringification of bare Perl references
- FU::Util::json_parse(): Disallow control characters in strings, add
`allow_control` option to revert to old behavior.
- Some doc fixes
1.0 - 2025-05-11
- FU::Util: Fix parsing of empty sections in query_decode()
- FU::Util: Fix buffer overflow in json_format() float formatting
- FU::Util: Reject `0x1f` in utf8_decode()
- FU::Pg: Add perl<->text and bin<->text type conversion methods
- FU::Validate: Improved error messages
- FU::MultipartFormData: Various parser fixes
- FU: Include request body in verbose error logs
- FU: Add fu->log_verbose()
- FU: Extend debug_info pages with request body, response body, 'fu'
object dump, expandable query parameters and interpolated SQL queries
- FU: Improve styling of debug_info pages
- FU: Preserve headers on fu->redirect
- FU: Ignore HTTP_CONTENT_LENGTH and HTTP_CONTENT_TYPE FastCGI parameters
- FU: Suppress warning about missing files in FU::monitor_path
- FU: Reject hash character and newlines in request path
- Fix creating read-only undef/true/false in json_parse() and FU::Pg
- Benchmark updates
0.5 - 2025-04-24 0.5 - 2025-04-24
- FU::Util: Set O_CLOEXEC on fds received through `fdpass_recv()` - FU::Util: Set O_CLOEXEC on fds received through `fdpass_recv()`
- FU::Util: Fix interpretation of false options in `json_format()` and - FU::Util: Fix interpretation of false options in `json_format()` and

135
FU.pm
View file

@ -1,9 +1,9 @@
package FU 1.4; package FU 0.5;
use v5.36; use v5.36;
use Carp 'confess', 'croak'; use Carp 'confess', 'croak';
use IO::Socket; use IO::Socket;
use POSIX (); use POSIX ();
use Time::HiRes 'time', 'clock_gettime', 'CLOCK_MONOTONIC'; use Time::HiRes 'clock_gettime', 'CLOCK_MONOTONIC';
use FU::Log 'log_write'; use FU::Log 'log_write';
use FU::Util; use FU::Util;
use FU::Validate; use FU::Validate;
@ -121,24 +121,11 @@ sub query_trace($st,@) {
$REQ->{trace_nsqldirect}++ if !defined $st->prepare_time; $REQ->{trace_nsqldirect}++ if !defined $st->prepare_time;
$REQ->{trace_sqlexec} += $st->exec_time; $REQ->{trace_sqlexec} += $st->exec_time;
$REQ->{trace_sqlprep} += $st->prepare_time if $st->prepare_time; $REQ->{trace_sqlprep} += $st->prepare_time if $st->prepare_time;
if (FU::debug) { push $REQ->{trace_sql}->@*, {
my $t = $st->param_types; query => $st->query, nrows => $st->nrows,
my $v = $st->param_values; param_types => $st->param_types, param_values => $st->param_values,
my $txt = $st->get_text_params; exec_time => $st->exec_time, prepare_time => $st->prepare_time,
push $REQ->{trace_sql}->@*, { } if FU::debug;
query => $st->query, nrows => $st->nrows,
exec_time => $st->exec_time, prepare_time => $st->prepare_time,
# Store the binary value when we're in binary params mode, that way
# we don't have to keep a reference to the original perl value and
# we can defer & batch the conversion to text.
params => [ map +{
type => $t->[$_],
!defined $v->[$_] ? (text => undef) :
$txt ? (text => "$v->[$_]")
: (bin => $DB->perl2bin($t->[$_], $v->[$_]))
}, 0..$#$v ],
};
}
} }
sub _connect_db { sub _connect_db {
$DB = ref $INIT_DB eq 'CODE' ? $INIT_DB->() : FU::Pg->connect($INIT_DB); $DB = ref $INIT_DB eq 'CODE' ? $INIT_DB->() : FU::Pg->connect($INIT_DB);
@ -217,14 +204,19 @@ sub monitor_path { push @monitor_paths, @_ }
sub monitor_check :prototype(&) { $monitor_check = $_[0] } sub monitor_check :prototype(&) { $monitor_check = $_[0] }
sub _monitor { sub _monitor {
state %data;
return 1 if $monitor_check && $monitor_check->(); return 1 if $monitor_check && $monitor_check->();
require File::Find; require File::Find;
eval { eval {
File::Find::find({ File::Find::find({
wanted => sub { die if (-M) < 0 }, wanted => sub {
my $m = (stat)[9];
$data{$_} //= $m;
die if $m > $data{$_};
},
no_chdir => 1 no_chdir => 1
}, grep -e, $scriptpath, values %INC, @monitor_paths); }, $scriptpath, values %INC, @monitor_paths);
0 0
} // 1; } // 1;
} }
@ -292,8 +284,7 @@ sub _read_req($c) {
: $r == -2 ? "I/O error while reading from FastCGI socket\n" : $r == -2 ? "I/O error while reading from FastCGI socket\n"
: $r == -3 ? "FastCGI protocol error\n" : $r == -3 ? "FastCGI protocol error\n"
: $r == -4 ? "Too long FastCGI parameter\n" : $r == -4 ? "Too long FastCGI parameter\n"
: $r == -5 ? "Too long request body\n" : $r == -5 ? "Too long request body\n" : undef if $r != -7;
: $r == -8 ? "I/O error while writing to FastCGI socket\n" : undef if $r != -7;
delete $c->{fcgi_obj}; delete $c->{fcgi_obj};
fu->error(-1); fu->error(-1);
} }
@ -309,12 +300,10 @@ sub _read_req($c) {
# Decode these into Unicode strings and check for special characters. # Decode these into Unicode strings and check for special characters.
eval { FU::Util::utf8_decode($_); 1} || fu->error(400, $@) eval { FU::Util::utf8_decode($_); 1} || fu->error(400, $@)
for ($REQ->{path}, $REQ->{qs}, values $REQ->{hdr}->%*); for ($REQ->{path}, $REQ->{qs}, values $REQ->{hdr}->%*);
fu->error(400, 'Invalid character in path') if $REQ->{path} =~ /#/; # Some bots don't correctly split off the fragment
($REQ->{path}, my $qs) = split /\?/, $REQ->{path}//'', 2; ($REQ->{path}, my $qs) = split /\?/, $REQ->{path}//'', 2;
$REQ->{qs} //= $qs; $REQ->{qs} //= $qs;
eval { $REQ->{path} = FU::Util::uri_unescape($REQ->{path}); FU::Util::check_control($REQ->{path}); 1; } || fu->error(400, $@); $REQ->{path} = FU::Util::uri_unescape($REQ->{path});
fu->error(400, 'Invalid character in path') if $REQ->{path} =~ /[\r\n\t]/; # There are plenty other questionable characters, but newlines and tabs are definitely out
} }
@ -324,16 +313,21 @@ sub _log_err($e) {
return if !$e; return if !$e;
my $crit = $e isa 'FU::err' ? $e->[0] == 500 : !($e isa 'FU::Validate::err'); my $crit = $e isa 'FU::err' ? $e->[0] == 500 : !($e isa 'FU::Validate::err');
return if !debug && !$crit; return if !debug && !$crit;
return fu->log_verbose($e) if $crit; if ($crit && !$REQ->{full_err}++) {
log_write $e; $e =~ s/^\s+//;
$e =~ s/\s+$//;
log_write join "\n",
'IP: '.($REQ->{ip}||'-'),
'Headers:', (map " $_: $REQ->{hdr}{$_}", sort keys $REQ->{hdr}->%*),
'ERROR:'.($e =~ s/(^|\n)/\n /rg);
# TODO: decoded body, if we have that.
} else {
log_write $e;
}
} }
sub _do_req($c) { sub _do_req($c) {
local $REQ = { local $REQ = { hdr => {}, trace_start => clock_gettime(CLOCK_MONOTONIC), trace_id => sprintf('%010x%08x%04x', int time, $$, int rand 1<<16) };
hdr => {},
trace_start => clock_gettime(CLOCK_MONOTONIC),
trace_id => sprintf('%012x%06x%04x', int(time*10000) % (1<<(12*4)), $$ % (1<<(6*4)), int rand 1<<16)
};
local $fu = bless {}, 'FU::obj'; local $fu = bless {}, 'FU::obj';
$REQ->{ip} = $c->{client_sock} isa 'IO::Socket::INET' ? $c->{client_sock}->peerhost : '127.0.0.1'; $REQ->{ip} = $c->{client_sock} isa 'IO::Socket::INET' ? $c->{client_sock}->peerhost : '127.0.0.1';
@ -401,13 +395,7 @@ sub _do_req($c) {
} }
$REQ->{trace_end} = clock_gettime(CLOCK_MONOTONIC); $REQ->{trace_end} = clock_gettime(CLOCK_MONOTONIC);
eval { fu->_flush($c->{fcgi_obj} || $c->{client_sock});
fu->_flush($c->{fcgi_obj} || $c->{client_sock});
1;
} || do {
log_write "Error writing response: $@\n";
$c->{client_sock} = $c->{fcgi_obj} = undef;
};
if (debug && $REQ->{trace_id} && $debug_info->{history} && $debug_info->{storage}) { if (debug && $REQ->{trace_id} && $debug_info->{history} && $debug_info->{storage}) {
require FU::DebugImpl; require FU::DebugImpl;
@ -498,8 +486,6 @@ sub _supervisor($c) {
if (!$err && (!$childs{$pid} || $childs{$pid} != 2)) { if (!$err && (!$childs{$pid} || $childs{$pid} != 2)) {
$err = 1; $err = 1;
log_write "Script exited before calling FU::run()\n"; log_write "Script exited before calling FU::run()\n";
} elsif ($?) {
log_write "Unclean shutdown of worker PID $pid status $?\n";
} }
delete $childs{$pid}; delete $childs{$pid};
} }
@ -512,7 +498,6 @@ sub _supervisor($c) {
die $! if !defined $pid; die $! if !defined $pid;
if (!$pid) { # child if (!$pid) { # child
$SIG{CHLD} = $SIG{HUP} = $SIG{INT} = $SIG{TERM} = undef; $SIG{CHLD} = $SIG{HUP} = $SIG{INT} = $SIG{TERM} = undef;
$0 = sprintf '%s: starting', $procname if $procname;
# In error state, wait with loading the script until we've received a request. # In error state, wait with loading the script until we've received a request.
# Otherwise we'll end up in an infinite spawning loop if the script doesn't start properly. # Otherwise we'll end up in an infinite spawning loop if the script doesn't start properly.
$client = $c->{listen_sock}->accept() or die $! if !$client && $err; $client = $c->{listen_sock}->accept() or die $! if !$client && $err;
@ -655,29 +640,8 @@ sub db {
}; };
} }
sub sql { shift->db->sql(@_) } sub sql { shift->db->q(@_) }
sub SQL { shift->db->SQL(@_) } sub SQL { shift->db->Q(@_) }
sub _fmt_section($s) { $s =~ s/^\s*/ /r =~ s/\s+$//r =~ s/\n/\n /rg }
sub log_verbose($,$msg) {
my $r = $FU::REQ;
return FU::Log::log_write($msg) if $r->{log_verbose}++;
FU::Log::log_write(join "\n",
'IP: '.($r->{ip}||'-'),
'Headers:', (map " $_: $r->{hdr}{$_}", sort keys $r->{hdr}->%*),
$r->{multipart} ? ('Body (multipart):', _fmt_section join "\n", map $_->describe, $r->{multipart}->@*) :
$r->{json} ? ('Body (JSON):', _fmt_section FU::Util::json_format($r->{json}, pretty => 1, canonical => 1)) :
$r->{formdata} ? ('Body (formdata):', _fmt_section FU::Util::json_format($r->{formdata}, pretty => 1, canonical => 1)) :
length $r->{body} ? do {
my $b = substr $r->{body}, 0, 4096;
my $trunc = length $r->{body} > 4096 ? ', truncated' : '';
utf8::decode($b) ? ("Body (utf8$trunc):", _fmt_section($b =~ s/\r//rg =~ s/\n{4,}/\n[..]\n/rg))
: ("Body (hex$trunc):", _fmt_section(unpack('H*', $b) =~ s/(.{128})/$1\n/rg))
} : (),
'Message:', _fmt_section $msg
);
}
@ -714,8 +678,7 @@ sub cookie {
my %c; my %c;
for my $c (split /; /, fu->header('cookie')||'') { for my $c (split /; /, fu->header('cookie')||'') {
my($n, $v) = split /=/, $c, 2; my($n, $v) = split /=/, $c, 2;
if (!defined $v) {} if (!exists $c{$n}) { $c{$n} = $v }
elsif (!exists $c{$n}) { $c{$n} = $v }
elsif (ref $c{$n}) { push $c{$n}->@*, $v } elsif (ref $c{$n}) { push $c{$n}->@*, $v }
else { $c{$n} = [ $c{$n}, $v ] } else { $c{$n} = [ $c{$n}, $v ] }
} }
@ -870,6 +833,7 @@ sub send_file($, $root, $path) {
sub redirect($, $code, $location) { sub redirect($, $code, $location) {
state $alias = {qw/ perm 301 temp 302 tempget 303 tempsame 307 permsame 308 /}; state $alias = {qw/ perm 301 temp 302 tempget 303 tempsame 307 permsame 308 /};
fu->reset;
fu->status($alias->{$code} // $code); fu->status($alias->{$code} // $code);
fu->set_header(location => "$location"); fu->set_header(location => "$location");
fu->set_header('content-type', 'text/plain'); fu->set_header('content-type', 'text/plain');
@ -922,12 +886,10 @@ sub _finalize {
) { ) {
push @vary, 'accept-encoding'; push @vary, 'accept-encoding';
if ($hasbrotli && ($r->{hdr}{'accept-encoding'}||'') =~ /\bbr\b/) { if ($hasbrotli && ($r->{hdr}{'accept-encoding'}||'') =~ /\bbr\b/) {
$r->{resbody_orig} = $r->{resbody};
$r->{resbody} = FU::Util::brotli_compress(6, $r->{resbody}); $r->{resbody} = FU::Util::brotli_compress(6, $r->{resbody});
$r->{reshdr}{'content-encoding'} = 'br'; $r->{reshdr}{'content-encoding'} = 'br';
} elsif ($hasgzip && ($r->{hdr}{'accept-encoding'}||'') =~ /\bgzip\b/) { } elsif ($hasgzip && ($r->{hdr}{'accept-encoding'}||'') =~ /\bgzip\b/) {
$r->{resbody_orig} = $r->{resbody};
$r->{resbody} = FU::Util::gzip_compress(6, $r->{resbody}); $r->{resbody} = FU::Util::gzip_compress(6, $r->{resbody});
$r->{reshdr}{'content-encoding'} = 'gzip'; $r->{reshdr}{'content-encoding'} = 'gzip';
} }
@ -984,6 +946,14 @@ __END__
FU - A Lean and Efficient Zero-Dependency Web Framework. FU - A Lean and Efficient Zero-Dependency Web Framework.
=head1 EXPERIMENTAL
This module is still in development: it's missing important functionality and
there will likely be a few breaking API changes. This framework currently
powers manned.org as a test. I'll do a stable 1.0 release once FU is used in
production for vndb.org, which will take a few months in the best case
scenario.
=head1 SYNOPSIS =head1 SYNOPSIS
use v5.36; use v5.36;
@ -1000,7 +970,7 @@ FU - A Lean and Efficient Zero-Dependency Web Framework.
} }
FU::get qr{/hello/(.+)}, sub($who) { FU::get qr{/hello/(.+)}, sub($who) {
myhtml_ "Website title", sub { my_html_ "Website title", sub {
h1_ "Hello, $who!"; h1_ "Hello, $who!";
}; };
}; };
@ -1009,11 +979,6 @@ FU - A Lean and Efficient Zero-Dependency Web Framework.
=head1 DESCRIPTION =head1 DESCRIPTION
FU is the backend web framework developed for L<VNDB.org|https://vndb.org/> and
L<Manned.org|https://manned.org/>, but is also perfectly suitable for other
projects. Besides a web framework, this distrubion also includes a bunch of
handy utility functions and modules.
=head2 Distribution Overview =head2 Distribution Overview
This top-level C<FU> module is a web development framework. The C<FU> This top-level C<FU> module is a web development framework. The C<FU>
@ -1103,7 +1068,7 @@ returning strings deal with perl Unicode strings, not raw bytes.
=item use FU -procname => $name =item use FU -procname => $name
When the C<-procname> import option is set, FU automatically updates the When the C<-procname> import option is set, FU automatically updates the
process name (as displayed in L<top(1)> and L<ps(1)>, see C<$0>) with process name (as displayed in L<top(1)> and L<ps(1)>, see `$0`) with
information about the current process, prefixed with the given C<$name>. information about the current process, prefixed with the given C<$name>.
=item FU::init_db($info) =item FU::init_db($info)
@ -1277,7 +1242,7 @@ handler being run. Any other exception is passed to the C<500> error handler.
While the C<FU::> namespace is used for global configuration and utility While the C<FU::> namespace is used for global configuration and utility
functions, the C<fu> object is intended for methods that deal with request functions, the C<fu> object is intended for methods that deal with request
processing (although some are useful outside of request handlers as well). processing (although some are useful used outside of request handlers as well).
The C<fu> object itself can be used to store request-local data. For example, The C<fu> object itself can be used to store request-local data. For example,
the following is a valid approach to handle user authentication: the following is a valid approach to handle user authentication:
@ -1315,19 +1280,11 @@ has successfully been processed, or rolled back if there was an error.
=item fu->sql($query, @params) =item fu->sql($query, @params)
Convenient short-hand for C<< fu->db->sql($query, @params) >>. Convenient short-hand for C<< fu->db->q($query, @params) >>.
=item fu->SQL(@args) =item fu->SQL(@args)
Convenient short-hand for C<< fu->db->SQL(@args) >>. Convenient short-hand for C<< fu->db->Q(@args) >>.
=item fu->log_verbose($message)
Write a verbose multi-line message to the log, including a full dump of
information about the request: IP, headers and (potentially reformatted and/or
truncated) body. This extra info is only written once per request, further
calls to C<log_verbose()> just go directly to L<FU::Log>'s C<log_write()>
instead.
=back =back

48
FU.xs
View file

@ -3,7 +3,7 @@
#include <time.h> /* struct timespec & clock_gettime() */ #include <time.h> /* struct timespec & clock_gettime() */
#include <string.h> /* strerror() */ #include <string.h> /* strerror() */
#include <arpa/inet.h> /* inet_ntop(), inet_ntoa() */ #include <arpa/inet.h> /* inet_ntop(), inet_ntoa() */
#include <sys/socket.h> /* send(), fd passing */ #include <sys/socket.h> /* fd passing */
#include <sys/un.h> /* fd passing */ #include <sys/un.h> /* fd passing */
#include <dlfcn.h> /* dlopen() etc */ #include <dlfcn.h> /* dlopen() etc */
@ -20,12 +20,6 @@
#ifndef BOOL_INTERNALS_sv_isbool_true #ifndef BOOL_INTERNALS_sv_isbool_true
#define BOOL_INTERNALS_sv_isbool_true(x) SvTRUEx(x) #define BOOL_INTERNALS_sv_isbool_true(x) SvTRUEx(x)
#endif #endif
#ifndef newSV_true
#define newSV_true() newSVsv(&PL_sv_yes)
#endif
#ifndef newSV_false
#define newSV_false() newSVsv(&PL_sv_no)
#endif
/* Disable key/value struct packing in khashl, so we can safely take a pointer /* Disable key/value struct packing in khashl, so we can safely take a pointer
* to values inside the hash table. */ * to values inside the hash table. */
@ -170,11 +164,11 @@ void print(fufcgi *ctx, SV *sv)
CODE: CODE:
STRLEN len; STRLEN len;
const char *buf = SvPVbyte(sv, len); const char *buf = SvPVbyte(sv, len);
fufcgi_print(aTHX_ ctx, buf, len); fufcgi_print(ctx, buf, len);
void flush(fufcgi *ctx) void flush(fufcgi *ctx)
CODE: CODE:
fufcgi_done(aTHX_ ctx); fufcgi_done(ctx);
void DESTROY(fufcgi *ctx) void DESTROY(fufcgi *ctx)
CODE: CODE:
@ -217,12 +211,6 @@ void query_trace(fupg_conn *c, SV *cb)
SvGETMAGIC(cb); SvGETMAGIC(cb);
c->trace = SvOK(cb) ? SvREFCNT_inc(cb) : NULL; c->trace = SvOK(cb) ? SvREFCNT_inc(cb) : NULL;
void conn(fupg_conn *c)
CODE:
ST(0) = sv_newmortal();
sv_setrv_inc(ST(0), c->self);
sv_bless(ST(0), gv_stashpv("FU::Pg::conn", 0));
void status(fupg_conn *c) void status(fupg_conn *c)
CODE: CODE:
ST(0) = sv_2mortal(newSVpv(fupg_conn_status(c), 0)); ST(0) = sv_2mortal(newSVpv(fupg_conn_status(c), 0));
@ -277,10 +265,10 @@ void exec(fupg_conn *c, SV *sv)
FUPG_CONN_COOKIE; FUPG_CONN_COOKIE;
ST(0) = fupg_exec(aTHX_ c, SvPVutf8_nolen(sv)); ST(0) = fupg_exec(aTHX_ c, SvPVutf8_nolen(sv));
void sql(fupg_conn *c, SV *sv, ...) void q(fupg_conn *c, SV *sv, ...)
CODE: CODE:
FUPG_CONN_COOKIE; FUPG_CONN_COOKIE;
ST(0) = fupg_sql(aTHX_ c, c->stflags, SvPVutf8_nolen(sv), ax, items); ST(0) = fupg_q(aTHX_ c, c->stflags, SvPVutf8_nolen(sv), ax, items);
void copy(fupg_conn *c, SV *sv) void copy(fupg_conn *c, SV *sv)
CODE: CODE:
@ -292,22 +280,6 @@ void _set_type(fupg_conn *c, SV *name, SV *sendsv, SV *recvsv)
fupg_set_type(aTHX_ c, name, sendsv, recvsv); fupg_set_type(aTHX_ c, name, sendsv, recvsv);
XSRETURN(1); XSRETURN(1);
void perl2bin(fupg_conn *c, int oid, SV *sv)
CODE:
ST(0) = fupg_perl2bin(aTHX_ c, oid, sv);
void bin2perl(fupg_conn *c, int oid, SV *sv)
CODE:
ST(0) = fupg_bin2perl(aTHX_ c, oid, sv);
void bin2text(fupg_conn *c, ...)
CODE:
XSRETURN(fupg_bintext(aTHX_ c, 0, ax, items));
void text2bin(fupg_conn *c, ...)
CODE:
XSRETURN(fupg_bintext(aTHX_ c, 1, ax, items));
MODULE = FU PACKAGE = FU::Pg::txn MODULE = FU PACKAGE = FU::Pg::txn
@ -323,12 +295,6 @@ void cache(fupg_txn *x, ...)
CODE: CODE:
FUPG_STFLAGS; FUPG_STFLAGS;
void conn(fupg_txn *t)
CODE:
ST(0) = sv_newmortal();
sv_setrv_inc(ST(0), t->conn->self);
sv_bless(ST(0), gv_stashpv("FU::Pg::conn", 0));
void status(fupg_txn *t) void status(fupg_txn *t)
CODE: CODE:
ST(0) = sv_2mortal(newSVpv(fupg_txn_status(t), 0)); ST(0) = sv_2mortal(newSVpv(fupg_txn_status(t), 0));
@ -353,10 +319,10 @@ void exec(fupg_txn *t, SV *sv)
FUPG_TXN_COOKIE; FUPG_TXN_COOKIE;
ST(0) = fupg_exec(aTHX_ t->conn, SvPVutf8_nolen(sv)); ST(0) = fupg_exec(aTHX_ t->conn, SvPVutf8_nolen(sv));
void sql(fupg_txn *t, SV *sv, ...) void q(fupg_txn *t, SV *sv, ...)
CODE: CODE:
FUPG_TXN_COOKIE; FUPG_TXN_COOKIE;
ST(0) = fupg_sql(aTHX_ t->conn, t->stflags, SvPVutf8_nolen(sv), ax, items); ST(0) = fupg_q(aTHX_ t->conn, t->stflags, SvPVutf8_nolen(sv), ax, items);
# XXX: The copy object should probably keep a ref on the transaction # XXX: The copy object should probably keep a ref on the transaction
void copy(fupg_txn *t, SV *sv) void copy(fupg_txn *t, SV *sv)

View file

@ -26,25 +26,21 @@ The following module versions were used:
=over =over
=item L<Cpanel::JSON::XS> 4.40 =item L<Cpanel::JSON::XS> 4.38
=item L<DBD::Pg> 3.18.0 =item L<FU> 0.1
=item L<FU> 1.4
=item L<HTML::Tiny> 1.08 =item L<HTML::Tiny> 1.08
=item L<JSON::PP> 4.16 =item L<JSON::PP> 4.16
=item L<JSON::SIMD> 1.07 =item L<JSON::SIMD> 1.06
=item L<JSON::Tiny> 0.58 =item L<JSON::Tiny> 0.58
=item L<JSON::XS> 4.04 =item L<JSON::XS> 4.03
=item L<Pg::PQ> 0.15 =item L<TUWF::XML> 1.5
=item L<TUWF::XML> 1.6
=item L<XML::Writer> 0.900 =item L<XML::Writer> 0.900
@ -60,294 +56,266 @@ These benchmarks run on large-ish arrays with repeated values. JSON encoding is
sufficiently fast that Perl function calling overhead tends to dominate for sufficiently fast that Perl function calling overhead tends to dominate for
smaller inputs, but I don't find that overhead very interesting. smaller inputs, but I don't find that overhead very interesting.
Also worth noting that L<JSON::SIMD> formatting code is forked from Also worth noting that JSON::SIMD formatting code is forked from JSON::XS, the
L<JSON::XS>, the SIMD parts are only used for parsing. SIMD parts are only used for parsing.
API object from L<JSON::XS> documentation. API object from L<JSON::XS> documentation.
Encode Canonical Decode Encode Canonical Decode
JSON::PP 5136/s 4943/s 1240/s JSON::PP 5312/s 5119/s 1290/s
JSON::Tiny 7617/s - 3474/s JSON::Tiny 7757/s - 3426/s
Cpanel::JSON::XS 108128/s 98734/s 105811/s Cpanel::JSON::XS 108187/s 101867/s 103575/s
JSON::SIMD 125105/s 114822/s 118410/s JSON::SIMD 130137/s 118948/s 115123/s
JSON::XS 128749/s 117518/s 120190/s JSON::XS 128421/s 120243/s 117940/s
FU::Util 126909/s 109166/s 113983/s FU::Util 133182/s 113275/s 118213/s
Object (small) Object (small)
Encode Canonical Decode Encode Canonical Decode
JSON::PP 896/s 826/s 194/s JSON::PP 907/s 829/s 202/s
JSON::Tiny 1216/s - 519/s JSON::Tiny 1224/s - 499/s
Cpanel::JSON::XS 44184/s 28190/s 19449/s Cpanel::JSON::XS 43168/s 28114/s 19229/s
JSON::SIMD 52633/s 31157/s 23587/s JSON::SIMD 49019/s 30699/s 23267/s
JSON::XS 50314/s 34276/s 25294/s JSON::XS 49814/s 31326/s 25336/s
FU::Util 42121/s 25618/s 19203/s FU::Util 44110/s 26134/s 21144/s
Object (large) Object (large)
Encode Canonical Decode Encode Canonical Decode
JSON::PP 910/s 734/s 98/s JSON::PP 927/s 747/s 104/s
JSON::Tiny 1068/s - 404/s JSON::Tiny 1108/s - 392/s
Cpanel::JSON::XS 27626/s 12484/s 15333/s Cpanel::JSON::XS 29672/s 12637/s 16609/s
JSON::SIMD 34106/s 12808/s 23674/s JSON::SIMD 24418/s 12388/s 22895/s
JSON::XS 35738/s 13099/s 22637/s JSON::XS 23192/s 13174/s 23553/s
FU::Util 37663/s 13366/s 16292/s FU::Util 39477/s 13567/s 17178/s
Object (large, mixed unicode) Object (large, mixed unicode)
Encode Canonical Decode Encode Canonical Decode
JSON::PP 835/s 664/s 82/s JSON::PP 817/s 679/s 86/s
JSON::Tiny 1028/s - 427/s JSON::Tiny 1036/s - 402/s
Cpanel::JSON::XS 24123/s 1352/s 8694/s Cpanel::JSON::XS 20437/s 1345/s 7408/s
JSON::SIMD 26008/s 1413/s 19707/s JSON::SIMD 25031/s 1331/s 15997/s
JSON::XS 25444/s 1391/s 10442/s JSON::XS 23580/s 1375/s 8526/s
FU::Util 33132/s 12006/s 11861/s FU::Util 34435/s 11916/s 9419/s
Small integers Small integers
Encode Decode Encode Decode
JSON::PP 116/s 30/s JSON::PP 113/s 29/s
JSON::Tiny 158/s 86/s JSON::Tiny 160/s 86/s
Cpanel::JSON::XS 7426/s 5774/s Cpanel::JSON::XS 7137/s 6083/s
JSON::SIMD 8294/s 4375/s JSON::SIMD 7963/s 4361/s
JSON::XS 8526/s 6179/s JSON::XS 7915/s 6058/s
FU::Util 7996/s 5962/s FU::Util 8565/s 5639/s
Large integers Large integers
Encode Decode Encode Decode
JSON::PP 2213/s 341/s JSON::PP 2176/s 329/s
JSON::Tiny 2910/s 1661/s JSON::Tiny 2999/s 1638/s
Cpanel::JSON::XS 32616/s 53053/s Cpanel::JSON::XS 31302/s 48892/s
JSON::SIMD 37749/s 53032/s JSON::SIMD 37201/s 51719/s
JSON::XS 38644/s 55004/s JSON::XS 36722/s 50110/s
FU::Util 109930/s 63358/s FU::Util 116188/s 62110/s
ASCII strings ASCII strings
Encode Decode Encode Decode
JSON::PP 2811/s 312/s JSON::PP 2934/s 336/s
JSON::Tiny 3924/s 1506/s JSON::Tiny 4126/s 1439/s
Cpanel::JSON::XS 129468/s 51536/s Cpanel::JSON::XS 116744/s 43489/s
JSON::SIMD 140393/s 64499/s JSON::SIMD 134711/s 50429/s
JSON::XS 141149/s 56913/s JSON::XS 135419/s 43976/s
FU::Util 165938/s 55034/s FU::Util 182026/s 44312/s
Unicode strings Unicode strings
Encode Decode Encode Decode
JSON::PP 5138/s 248/s JSON::PP 5113/s 253/s
JSON::Tiny 6501/s 2677/s JSON::Tiny 6603/s 2585/s
Cpanel::JSON::XS 91004/s 64101/s Cpanel::JSON::XS 91704/s 64489/s
JSON::SIMD 101185/s 80941/s JSON::SIMD 106928/s 102440/s
JSON::XS 106312/s 61104/s JSON::XS 105473/s 60558/s
FU::Util 205716/s 52041/s FU::Util 217135/s 58972/s
String escaping (few) String escaping (few)
Encode Decode Encode Decode
JSON::PP 4269/s 329/s JSON::PP 4251/s 352/s
JSON::Tiny 4878/s 2101/s JSON::Tiny 4704/s 1869/s
Cpanel::JSON::XS 152958/s 105597/s Cpanel::JSON::XS 131789/s 106306/s
JSON::SIMD 165340/s 130074/s JSON::SIMD 158171/s 153692/s
JSON::XS 165863/s 87872/s JSON::XS 157261/s 97676/s
FU::Util 228511/s 81599/s FU::Util 191699/s 91177/s
String escaping (many) String escaping (many)
Encode Decode Encode Decode
JSON::PP 4052/s 573/s JSON::PP 2224/s 366/s
JSON::Tiny 4575/s 2274/s JSON::Tiny 2884/s 984/s
Cpanel::JSON::XS 201958/s 102800/s Cpanel::JSON::XS 136583/s 100789/s
JSON::SIMD 242806/s 146341/s JSON::SIMD 152951/s 113242/s
JSON::XS 209689/s 98420/s JSON::XS 153471/s 106269/s
FU::Util 210713/s 100255/s FU::Util 142604/s 97984/s
=head2 XML Writing =head2 XML Writing
L<FU::XMLWriter> is the only XS-based XML DSL that I'm aware of, so all direct
competition is inherently slower by virtue of being pure perl. I'm sure some
templating modules will perform better, though.
HTML fragment HTML fragment
TUWF::XML 787/s TUWF::XML 795/s
XML::Writer 832/s XML::Writer 833/s
HTML::Tiny 403/s HTML::Tiny 423/s
FU::XMLWriter 5192/s FU::XMLWriter 5285/s
=head2 PostgreSQL client
Fetching query results is highly unlikely to be a bottleneck in your code, this
benchmark is mainly here to verify that L<FU::Pg> is not introducing a
bottleneck where there shouldn't be one.
Fetch and bitwise-or 20k integers
Smallint Bigint
DBD::Pg 346/s 33/s
Pg::PQ 270/s 24/s
FU::Pg (bin) 476/s 46/s
FU::Pg (text) 273/s 23/s
=cut =cut
# Cached data used by bench.PL. Same as the formatted tables above but easier to parse. # Cached data used by bench.PL. Same as the formatted tables above but easier to parse.
json/api Canonical Cpanel::JSON::XS 98734 json/api Canonical Cpanel::JSON::XS 101867
json/api Canonical FU::Util 109166 json/api Canonical FU::Util 113275
json/api Canonical JSON::PP 4943 json/api Canonical JSON::PP 5119
json/api Canonical JSON::SIMD 114822 json/api Canonical JSON::SIMD 118948
json/api Canonical JSON::XS 117518 json/api Canonical JSON::XS 120243
json/api Decode Cpanel::JSON::XS 105811 json/api Decode Cpanel::JSON::XS 103575
json/api Decode FU::Util 113983 json/api Decode FU::Util 118213
json/api Decode JSON::PP 1240 json/api Decode JSON::PP 1290
json/api Decode JSON::SIMD 118410 json/api Decode JSON::SIMD 115123
json/api Decode JSON::Tiny 3474 json/api Decode JSON::Tiny 3426
json/api Decode JSON::XS 120190 json/api Decode JSON::XS 117940
json/api Encode Cpanel::JSON::XS 108128 json/api Encode Cpanel::JSON::XS 108187
json/api Encode FU::Util 126909 json/api Encode FU::Util 133182
json/api Encode JSON::PP 5136 json/api Encode JSON::PP 5312
json/api Encode JSON::SIMD 125105 json/api Encode JSON::SIMD 130137
json/api Encode JSON::Tiny 7617 json/api Encode JSON::Tiny 7757
json/api Encode JSON::XS 128749 json/api Encode JSON::XS 128421
json/intl Decode Cpanel::JSON::XS 53053 json/intl Decode Cpanel::JSON::XS 48892
json/intl Decode FU::Util 63358 json/intl Decode FU::Util 62110
json/intl Decode JSON::PP 341 json/intl Decode JSON::PP 329
json/intl Decode JSON::SIMD 53032 json/intl Decode JSON::SIMD 51719
json/intl Decode JSON::Tiny 1661 json/intl Decode JSON::Tiny 1638
json/intl Decode JSON::XS 55004 json/intl Decode JSON::XS 50110
json/intl Encode Cpanel::JSON::XS 32616 json/intl Encode Cpanel::JSON::XS 31302
json/intl Encode FU::Util 109930 json/intl Encode FU::Util 116188
json/intl Encode JSON::PP 2213 json/intl Encode JSON::PP 2176
json/intl Encode JSON::SIMD 37749 json/intl Encode JSON::SIMD 37201
json/intl Encode JSON::Tiny 2910 json/intl Encode JSON::Tiny 2999
json/intl Encode JSON::XS 38644 json/intl Encode JSON::XS 36722
json/ints Decode Cpanel::JSON::XS 5774 json/ints Decode Cpanel::JSON::XS 6083
json/ints Decode FU::Util 5962 json/ints Decode FU::Util 5639
json/ints Decode JSON::PP 30 json/ints Decode JSON::PP 29
json/ints Decode JSON::SIMD 4375 json/ints Decode JSON::SIMD 4361
json/ints Decode JSON::Tiny 86 json/ints Decode JSON::Tiny 86
json/ints Decode JSON::XS 6179 json/ints Decode JSON::XS 6058
json/ints Encode Cpanel::JSON::XS 7426 json/ints Encode Cpanel::JSON::XS 7137
json/ints Encode FU::Util 7996 json/ints Encode FU::Util 8565
json/ints Encode JSON::PP 116 json/ints Encode JSON::PP 113
json/ints Encode JSON::SIMD 8294 json/ints Encode JSON::SIMD 7963
json/ints Encode JSON::Tiny 158 json/ints Encode JSON::Tiny 160
json/ints Encode JSON::XS 8526 json/ints Encode JSON::XS 7915
json/objl Canonical Cpanel::JSON::XS 12484 json/objl Canonical Cpanel::JSON::XS 12637
json/objl Canonical FU::Util 13366 json/objl Canonical FU::Util 13567
json/objl Canonical JSON::PP 734 json/objl Canonical JSON::PP 747
json/objl Canonical JSON::SIMD 12808 json/objl Canonical JSON::SIMD 12388
json/objl Canonical JSON::XS 13099 json/objl Canonical JSON::XS 13174
json/objl Decode Cpanel::JSON::XS 15333 json/objl Decode Cpanel::JSON::XS 16609
json/objl Decode FU::Util 16292 json/objl Decode FU::Util 17178
json/objl Decode JSON::PP 98 json/objl Decode JSON::PP 104
json/objl Decode JSON::SIMD 23674 json/objl Decode JSON::SIMD 22895
json/objl Decode JSON::Tiny 404 json/objl Decode JSON::Tiny 392
json/objl Decode JSON::XS 22637 json/objl Decode JSON::XS 23553
json/objl Encode Cpanel::JSON::XS 27626 json/objl Encode Cpanel::JSON::XS 29672
json/objl Encode FU::Util 37663 json/objl Encode FU::Util 39477
json/objl Encode JSON::PP 910 json/objl Encode JSON::PP 927
json/objl Encode JSON::SIMD 34106 json/objl Encode JSON::SIMD 24418
json/objl Encode JSON::Tiny 1068 json/objl Encode JSON::Tiny 1108
json/objl Encode JSON::XS 35738 json/objl Encode JSON::XS 23192
json/objs Canonical Cpanel::JSON::XS 28190 json/objs Canonical Cpanel::JSON::XS 28114
json/objs Canonical FU::Util 25618 json/objs Canonical FU::Util 26134
json/objs Canonical JSON::PP 826 json/objs Canonical JSON::PP 829
json/objs Canonical JSON::SIMD 31157 json/objs Canonical JSON::SIMD 30699
json/objs Canonical JSON::XS 34276 json/objs Canonical JSON::XS 31326
json/objs Decode Cpanel::JSON::XS 19449 json/objs Decode Cpanel::JSON::XS 19229
json/objs Decode FU::Util 19203 json/objs Decode FU::Util 21144
json/objs Decode JSON::PP 194 json/objs Decode JSON::PP 202
json/objs Decode JSON::SIMD 23587 json/objs Decode JSON::SIMD 23267
json/objs Decode JSON::Tiny 519 json/objs Decode JSON::Tiny 499
json/objs Decode JSON::XS 25294 json/objs Decode JSON::XS 25336
json/objs Encode Cpanel::JSON::XS 44184 json/objs Encode Cpanel::JSON::XS 43168
json/objs Encode FU::Util 42121 json/objs Encode FU::Util 44110
json/objs Encode JSON::PP 896 json/objs Encode JSON::PP 907
json/objs Encode JSON::SIMD 52633 json/objs Encode JSON::SIMD 49019
json/objs Encode JSON::Tiny 1216 json/objs Encode JSON::Tiny 1224
json/objs Encode JSON::XS 50314 json/objs Encode JSON::XS 49814
json/obju Canonical Cpanel::JSON::XS 1352 json/obju Canonical Cpanel::JSON::XS 1345
json/obju Canonical FU::Util 12006 json/obju Canonical FU::Util 11916
json/obju Canonical JSON::PP 664 json/obju Canonical JSON::PP 679
json/obju Canonical JSON::SIMD 1413 json/obju Canonical JSON::SIMD 1331
json/obju Canonical JSON::XS 1391 json/obju Canonical JSON::XS 1375
json/obju Decode Cpanel::JSON::XS 8694 json/obju Decode Cpanel::JSON::XS 7408
json/obju Decode FU::Util 11861 json/obju Decode FU::Util 9419
json/obju Decode JSON::PP 82 json/obju Decode JSON::PP 86
json/obju Decode JSON::SIMD 19707 json/obju Decode JSON::SIMD 15997
json/obju Decode JSON::Tiny 427 json/obju Decode JSON::Tiny 402
json/obju Decode JSON::XS 10442 json/obju Decode JSON::XS 8526
json/obju Encode Cpanel::JSON::XS 24123 json/obju Encode Cpanel::JSON::XS 20437
json/obju Encode FU::Util 33132 json/obju Encode FU::Util 34435
json/obju Encode JSON::PP 835 json/obju Encode JSON::PP 817
json/obju Encode JSON::SIMD 26008 json/obju Encode JSON::SIMD 25031
json/obju Encode JSON::Tiny 1028 json/obju Encode JSON::Tiny 1036
json/obju Encode JSON::XS 25444 json/obju Encode JSON::XS 23580
json/strel Decode Cpanel::JSON::XS 102800 json/strel Decode Cpanel::JSON::XS 100789
json/strel Decode FU::Util 100255 json/strel Decode FU::Util 97984
json/strel Decode JSON::PP 573 json/strel Decode JSON::PP 366
json/strel Decode JSON::SIMD 146341 json/strel Decode JSON::SIMD 113242
json/strel Decode JSON::Tiny 2274 json/strel Decode JSON::Tiny 984
json/strel Decode JSON::XS 98420 json/strel Decode JSON::XS 106269
json/strel Encode Cpanel::JSON::XS 201958 json/strel Encode Cpanel::JSON::XS 136583
json/strel Encode FU::Util 210713 json/strel Encode FU::Util 142604
json/strel Encode JSON::PP 4052 json/strel Encode JSON::PP 2224
json/strel Encode JSON::SIMD 242806 json/strel Encode JSON::SIMD 152951
json/strel Encode JSON::Tiny 4575 json/strel Encode JSON::Tiny 2884
json/strel Encode JSON::XS 209689 json/strel Encode JSON::XS 153471
json/stres Decode Cpanel::JSON::XS 105597 json/stres Decode Cpanel::JSON::XS 106306
json/stres Decode FU::Util 81599 json/stres Decode FU::Util 91177
json/stres Decode JSON::PP 329 json/stres Decode JSON::PP 352
json/stres Decode JSON::SIMD 130074 json/stres Decode JSON::SIMD 153692
json/stres Decode JSON::Tiny 2101 json/stres Decode JSON::Tiny 1869
json/stres Decode JSON::XS 87872 json/stres Decode JSON::XS 97676
json/stres Encode Cpanel::JSON::XS 152958 json/stres Encode Cpanel::JSON::XS 131789
json/stres Encode FU::Util 228511 json/stres Encode FU::Util 191699
json/stres Encode JSON::PP 4269 json/stres Encode JSON::PP 4251
json/stres Encode JSON::SIMD 165340 json/stres Encode JSON::SIMD 158171
json/stres Encode JSON::Tiny 4878 json/stres Encode JSON::Tiny 4704
json/stres Encode JSON::XS 165863 json/stres Encode JSON::XS 157261
json/strs Decode Cpanel::JSON::XS 51536 json/strs Decode Cpanel::JSON::XS 43489
json/strs Decode FU::Util 55034 json/strs Decode FU::Util 44312
json/strs Decode JSON::PP 312 json/strs Decode JSON::PP 336
json/strs Decode JSON::SIMD 64499 json/strs Decode JSON::SIMD 50429
json/strs Decode JSON::Tiny 1506 json/strs Decode JSON::Tiny 1439
json/strs Decode JSON::XS 56913 json/strs Decode JSON::XS 43976
json/strs Encode Cpanel::JSON::XS 129468 json/strs Encode Cpanel::JSON::XS 116744
json/strs Encode FU::Util 165938 json/strs Encode FU::Util 182026
json/strs Encode JSON::PP 2811 json/strs Encode JSON::PP 2934
json/strs Encode JSON::SIMD 140393 json/strs Encode JSON::SIMD 134711
json/strs Encode JSON::Tiny 3924 json/strs Encode JSON::Tiny 4126
json/strs Encode JSON::XS 141149 json/strs Encode JSON::XS 135419
json/stru Decode Cpanel::JSON::XS 64101 json/stru Decode Cpanel::JSON::XS 64489
json/stru Decode FU::Util 52041 json/stru Decode FU::Util 58972
json/stru Decode JSON::PP 248 json/stru Decode JSON::PP 253
json/stru Decode JSON::SIMD 80941 json/stru Decode JSON::SIMD 102440
json/stru Decode JSON::Tiny 2677 json/stru Decode JSON::Tiny 2585
json/stru Decode JSON::XS 61104 json/stru Decode JSON::XS 60558
json/stru Encode Cpanel::JSON::XS 91004 json/stru Encode Cpanel::JSON::XS 91704
json/stru Encode FU::Util 205716 json/stru Encode FU::Util 217135
json/stru Encode JSON::PP 5138 json/stru Encode JSON::PP 5113
json/stru Encode JSON::SIMD 101185 json/stru Encode JSON::SIMD 106928
json/stru Encode JSON::Tiny 6501 json/stru Encode JSON::Tiny 6603
json/stru Encode JSON::XS 106312 json/stru Encode JSON::XS 105473
pg/ints Bigint DBD::Pg 33 xml/a Rate FU::XMLWriter 5285
pg/ints Bigint FU::Pg (bin) 46 xml/a Rate HTML::Tiny 423
pg/ints Bigint FU::Pg (text) 23 xml/a Rate TUWF::XML 795
pg/ints Bigint Pg::PQ 24 xml/a Rate XML::Writer 833
pg/ints Smallint DBD::Pg 346
pg/ints Smallint FU::Pg (bin) 476
pg/ints Smallint FU::Pg (text) 273
pg/ints Smallint Pg::PQ 270
xml/a Rate FU::XMLWriter 5192
xml/a Rate HTML::Tiny 403
xml/a Rate TUWF::XML 787
xml/a Rate XML::Writer 832

View file

@ -1,7 +1,6 @@
# Internal module used by FU.pm # Internal module used by FU.pm
package FU::DebugImpl 1.4; package FU::DebugImpl 0.5;
use v5.36; use v5.36;
use utf8;
use experimental 'for_list'; use experimental 'for_list';
use FU; use FU;
use FU::XMLWriter ':html5_', 'fragment', 'xml_escape'; use FU::XMLWriter ':html5_', 'fragment', 'xml_escape';
@ -17,32 +16,27 @@ sub loc_($loc) {
my $l = $loc->[$_]; my $l = $loc->[$_];
my $f = $_ == $#$loc ? '(main)' : $loc->[$_+1][3]; my $f = $_ == $#$loc ? '(main)' : $loc->[$_+1][3];
$f = "$l->[0]::$f" if $f !~ /^\Q$l->[0]/; $f = "$l->[0]::$f" if $f !~ /^\Q$l->[0]/;
txt_ $f; txt_ "$f @ $l->[1]:$l->[2]";
small_ " @ $l->[1]:$l->[2]";
} }
} }
sub fmtpre_($code) {
lit_ xml_escape($code) =~ s/^\s+//r =~ s/\s+$//r =~ s/\n/<br>/rg;
}
sub clean_re($str) { sub clean_re($str) {
# Regex formatting isn't stable, but this cleans up the crap I'm seeing a little bit. # Regex formatting isn't stable, but this cleans up the crap I'm seeing a little bit.
"$str" =~ s/^\(\?\^u:\^\(\?\^u://r =~ s/\)\$\)$//r; "$str" =~ s/^\(\?\^u:\^\(\?\^u://r =~ s/\)\$\)$//r;
} }
sub raw_data($str) { my @tabs = (
my $d = substr $str, 0, 32*1024;
my $trunc = length $str > 32*1024 ? ', truncated' : '';
return utf8::decode($d) ? ("utf8$trunc", $d)
: ("hex$trunc", unpack('H*', $d) =~ s/(.{128})/$1\n/rg =~ s/(.{16})/$1 /rg);
}
my @sections = (
req => sub { req => sub {
my $r = $FU::REQ;
table_ sub { table_ sub {
tr_ sub { td_ 'Method'; td_ fu->method }; tr_ sub { td_ 'Method'; td_ fu->method };
tr_ sub { td_ 'Path'; td_ fu->path }; tr_ sub { td_ 'Path'; td_ fu->path };
tr_ sub { td_ 'Query'; td_ fu->query }; tr_ sub { td_ 'Query'; td_ fu->query };
tr_ sub { td_ 'Client IP'; td_ fu->ip }; tr_ sub { td_ 'Client IP'; td_ fu->ip };
tr_ sub { td_ 'Received'; td_ fmtts(time - (($r->{trace_end}||clock_gettime(CLOCK_MONOTONIC)) - $r->{trace_start})) }; tr_ sub { td_ 'Received'; td_ fmtts(time - (($FU::REQ->{trace_end}||clock_gettime(CLOCK_MONOTONIC)) - $FU::REQ->{trace_start})) };
}; };
h2_ 'Headers'; h2_ 'Headers';
table_ sub { table_ sub {
@ -51,38 +45,7 @@ my @sections = (
td_ fu->headers->{$_}; td_ fu->headers->{$_};
} for sort keys fu->headers->%*; } for sort keys fu->headers->%*;
}; };
if ((fu->header('content-length')||0) > 0) { # TODO: Body? Certainly useful for JSON
h2_ 'Body';
section_ class => 'tabs', sub {
my $json = eval { fu->json({type=>'any'}) };
details_ name => 'reqbody', open => !0, sub {
summary_ 'JSON';
pre_ FU::Util::json_format($json, pretty => 1, canonical => 1);
} if $json;
my $formdata = eval { fu->formdata({type=>'hash'}) };
details_ name => 'reqbody', open => !0, sub {
summary_ 'Form data';
table_ sub {
for my $k (sort keys %$formdata) {
tr_ sub {
td_ $k;
td_ $_;
} for ref $formdata->{$k} ? $formdata->{$k}->@* : ($formdata->{$k});
}
};
} if $formdata;
my $multipart = eval { fu->multipart };
details_ name => 'reqbody', open => !0, sub {
summary_ 'Multipart';
pre_ join "\n", map $_->describe, @$multipart;
} if $multipart;
details_ name => 'reqbody', open => !0,sub {
my($lbl, $data) = raw_data $r->{body};
summary_ "Raw ($lbl)";
pre_ $data;
};
}
}
('Request') ('Request')
}, },
@ -121,103 +84,32 @@ my @sections = (
} for !defined $v ? () : ref $v ? @$v : ($v); } for !defined $v ? () : ref $v ? @$v : ($v);
} }
}; };
my $body = $r->{resbody_orig} // $r->{resbody};
if (length $body) {
h2_ 'Body';
section_ class => 'tabs', sub {
my $json = ($r->{reshdr}{'content-type'}||'') =~ /^application\/json/ && eval { FU::Util::json_parse($body, utf8 => 1) };
details_ name => 'resbody', open => !0, sub {
summary_ 'JSON';
pre_ FU::Util::json_format($json, pretty => 1, canonical => 1);
} if $json;
details_ name => 'resbody', open => !0,sub {
my($lbl, $data) = raw_data $body;
summary_ "Raw ($lbl)";
pre_ $data;
};
}
}
('Response') ('Response')
}, },
sql => sub { sql => sub {
my $queries = $FU::REQ->{trace_sql}; return () if !$FU::REQ->{trace_sql};
return () if !$queries; table_ sub {
# Convert binary params to text.
# For queries with text_params, assume the params are already valid for the text format.
my @binparams = grep $_->{type} && !exists $_->{text}, map $_->{params}->@*, @$queries;
my @arg = map +($_->{type}, $_->{bin}), @binparams;
my @text;
my $ok = !@arg || eval { @text = $FU::DB->bin2text(@arg); 1 };
$binparams[$_]{text} = $text[$_] for 0..$#text;
pre_ "Error converting binary parameters:\n$@" if !$ok;
input_ type => 'checkbox', id => "row${_}_c" for 0..$#{$queries};
table_ class => 'sqlt', sub {
thead_ sub { tr_ sub { thead_ sub { tr_ sub {
td_ class => 'num', 'Exec'; td_ class => 'num', 'Exec';
td_ class => 'num', 'Prep'; td_ class => 'num', 'Prep';
td_ class => 'num', 'Rows'; td_ class => 'num', 'Rows';
td_ 'Query'; td_ 'Query';
} }; } };
my $rows = 0;
for my($i, $st) (builtin::indexed $queries->@*) {
$rows += $st->{nrows};
tr_ sub {
td_ class => 'num', sprintf '%.1f ms', $st->{exec_time}*1000;
td_ class => 'num', !defined $st->{prepare_time} ? '-' : $st->{prepare_time} ? sprintf '%.1f ms', $st->{prepare_time}*1000 : 'cache';
td_ class => 'num', $st->{nrows};
td_ class => 'sum', sub {
label_ for => "row${i}_c", sub {
span_ class => 'closed', '▶';
span_ class => 'open', '▼';
txt_ $st->{query} =~ s/[\r\n]/ /rg =~ s/\s\s+/ /rg =~ s/^\s+//r;
};
};
};
tr_ class => 'details', id => "row$i", sub {
td_ '';
td_ colspan => 3, sub {
pre_ $st->{query};
if ($st->{params}->@*) {
strong_ 'Parameters:';
table_ sub {
tr_ sub {
td_ class => 'num', sprintf '$%d =', $_+1;
td_ class => 'code', sub {
my $p = $st->{params}[$_]{text};
!defined $p ? em_ 'null' : txt_ $p;
};
} for (0..$#{$st->{params}});
};
# XXX: Buggy when the query contains string literals with $n variables.
strong_ 'Interpolated:';
pre_ $st->{query} =~ s{\$([1-9][0-9]*)}{
my $v = $st->{params}[$1-1]{text};
defined $v ? $FU::DB->escape_literal($v) : 'NULL'
}egr;
}
};
};
}
tr_ sub { tr_ sub {
td_ class => 'num', sprintf '%.1f ms', $FU::REQ->{trace_sqlexec}*1000; td_ class => 'num', sprintf '%.1f ms', $_->{exec_time}*1000;
td_ class => 'num', !defined $FU::REQ->{trace_sqlprep} ? '-' : sprintf '%.1f ms', $FU::REQ->{trace_sqlprep}*1000; td_ class => 'num', !defined $_->{prepare_time} ? '-' : $_->{prepare_time} ? sprintf '%.1f ms', $_->{prepare_time}*1000 : 'cache';
td_ class => 'num', $rows; td_ class => 'num', $_->{nrows};
td_ class => 'sum', 'total'; td_ class => 'code', sub { fmtpre_ $_->{query} };
} if @$queries > 1; # TODO: Params, both separate and interpolated
} for $FU::REQ->{trace_sql}->@*;
}; };
('Queries', scalar @$queries) ('Queries', scalar $FU::REQ->{trace_sql}->@*)
}, },
fu => sub { fu => sub {
return () if !keys fu->%*; return () if !keys fu->%*;
# TODO: This is kinda lazy, an expandable table might be nicer. # TODO: Contents of the 'fu' object
require Data::Dumper;
pre_ sub {
lit_ Data::Dumper->new([fu])->Sortkeys(1)->Terse(1)->Dump;
};
('fu obj') ('fu obj')
}, },
@ -283,7 +175,7 @@ my @sections = (
pgst => sub { pgst => sub {
return () if !$FU::DB; return () if !$FU::DB;
my $lst = eval { $FU::DB->sql( my $lst = eval { $FU::DB->q(
'SELECT generic_plans + custom_plans, statement FROM pg_prepared_statements ORDER BY generic_plans + custom_plans DESC, statement' 'SELECT generic_plans + custom_plans, statement FROM pg_prepared_statements ORDER BY generic_plans + custom_plans DESC, statement'
)->cache(0)->alla } || do { warn "Unable to collect prepared statement list: $@"; return () }; )->cache(0)->alla } || do { warn "Unable to collect prepared statement list: $@"; return () };
return () if !@$lst; return () if !@$lst;
@ -294,20 +186,19 @@ my @sections = (
} }; } };
tr_ sub { tr_ sub {
td_ $_->[0]; td_ $_->[0];
td_ class => 'code', $_->[1]; td_ class => 'code', sub { fmtpre_ $_->[1] };
} for @$lst; } for @$lst;
}; };
('Prepared stmts', scalar @$lst) ('Prepared statements', scalar @$lst)
}, },
); );
sub collect { sub collect {
my @t; my @t;
for my ($id, $sub) (@sections) { for my ($id, $sub) (@tabs) {
my($title, $num); my($title, $num);
my $html = fragment { ($title, $num) = $sub->() }; my $html = fragment { ($title, $num) = $sub->() };
utf8::decode($html);
push @t, { id => $id, title => $title, num => $num, html => $html } if $title; push @t, { id => $id, title => $title, num => $num, html => $html } if $title;
} }
\@t \@t
@ -319,9 +210,47 @@ sub framework_($data) {
head_ sub { head_ sub {
title_ 'FU Debugging Interface'; title_ 'FU Debugging Interface';
meta_ name => 'viewport', content => 'width=device-width, initial-scale=1.0, user-scalable=yes'; meta_ name => 'viewport', content => 'width=device-width, initial-scale=1.0, user-scalable=yes';
link_ rel => 'stylesheet', type => 'text/css', media => 'all', href => '?css';
style_ type => 'text/css', <<~_; style_ type => 'text/css', <<~_;
html { box-sizing: border-box; color: #000; background: #fff }
*, *:before, *:after { box-sizing: inherit }
* { margin: 0; padding: 0; font: inherit; color: inherit }
body { display: grid; grid: 45px 400px / 220px auto; }
header { grid-column: 1 / 3; grid-row: 1 / 2 }
nav { grid-column: 1 / 2; grid-row: 2 / 3 }
main { grid-column: 2 / 3; grid-row: 2 / 3 }
header, nav { background: #eee }
main { border-top: 2px solid #009; border-left: 2px solid #009 }
nav { border-bottom: 2px solid #009 }
header { display: flex; justify-content: space-between; padding: 10px }
header h1 { font-size: 20px; font-weight: bold }
header menu { list-style-type: none; display: flex; gap: 15px }
body > input { display: none }
nav { padding-top: 20px }
nav menu { list-style-type: none }
nav label { display: block; width: 100%; padding: 2px 10px; cursor: pointer; white-space: nowrap }
nav label:hover { background-color: #fff }
nav label span { float: right; font-size: 80% }
main { padding: 10px 20px }
main h2 { margin: 30px 0 5px -10px; font-size: 20px; font-weight: bold }
main h2:first-child { margin-top: 0 }
p, pre, table { margin: 5px 0 }
pre, .code { font-family: monospace; white-space: pre }
table { border-collapse: collapse }
td { padding: 1px 10px 1px 0; font-size: 12px; vertical-align: top }
tr:hover { background-color: #eee }
thead { font-weight: bold }
.num { text-align: right; white-space: nowrap }
_ _
style_ type => 'text/css', join "\n", map +(
"#tab_$_:checked ~ nav menu li label[for=tab_$_] { background-color: #fff }",
"#tab_$_:not(:checked) ~ main #tabc_$_ { display: none }",
), map $_->{id}, @$data;
}; };
body_ sub { body_ sub {
header_ sub { header_ sub {
@ -332,21 +261,22 @@ sub framework_($data) {
li_ sub { a_ href => '?', 'Listing' }; li_ sub { a_ href => '?', 'Listing' };
}; };
}; };
input_ type => 'radio', name => 'tab', id => "tab_$_->{id}", checked => $_ eq $data->[0] ? 'checked' : undef for @$data;
nav_ sub { nav_ sub {
menu_ sub { menu_ sub {
li_ sub { li_ sub {
a_ href => "#$_->{id}", sub { label_ for => "tab_$_->{id}", sub {
txt_ $_->{title}; txt_ $_->{title};
span_ $_->{num} if defined $_->{num}; span_ $_->{num} if defined $_->{num};
}; }
} for @$data; } for @$data;
}; };
} if @$data; } if @$data;
main_ sub { main_ sub {
for (@$data) { div_ id => "tabc_$_->{id}", sub {
h1_ id => $_->{id}, $_->{title}; h2_ $_->{title};
lit_ $_->{html}; lit_ $_->{html};
} } for @$data;
}; };
}; };
}; };
@ -387,23 +317,10 @@ sub load($id) {
fu->set_body(scalar <$fn>); fu->set_body(scalar <$fn>);
} }
sub css {
# Awful CSS row hiding hack. I'm not sorry.
state $css = join '', <DATA>, map qq{
#row${_}_c:checked ~ * label[for=row${_}_c] .closed { display: none }
#row${_}_c:not(:checked) ~ * label[for=row${_}_c] .open { display: none }
#row${_}_c:not(:checked) ~ * #row${_} { display: none }
}, 0..1000;
}
sub render { sub render {
my $q = fu->query; my $q = fu->query;
if (!$q) { if (!$q) {
fu->set_body(framework_ [{id => 'lst', title => 'Recent Requests', html => fragment \&listing_ }]); fu->set_body(framework_ [{id => 'lst', title => 'Recent Requests', html => fragment \&listing_ }]);
} elsif ($q eq 'css') {
fu->set_header('content-type', 'text/css');
fu->set_header('cache-control', 'max-age=86400');
fu->set_body(css());
} elsif ($q eq 'cur') { } elsif ($q eq 'cur') {
fu->set_body(framework_ collect); fu->set_body(framework_ collect);
} elsif ($q eq 'last') { } elsif ($q eq 'last') {
@ -437,62 +354,3 @@ sub save {
} }
1; 1;
__DATA__
html { box-sizing: border-box; color: #000; background: #fff }
*, *:before, *:after { box-sizing: inherit }
* { margin: 0; padding: 0; font: inherit; color: inherit }
/* Ugh, fixed positioning */
header { position: fixed; top: 0; left: 0; width: 100%; height: 40px; z-index: 2 }
nav { position: fixed; top: 38px; left: 0; width: 200px; z-index: 2 }
main { margin: 0 0 0 200px }
header, nav { background: #eee }
header { border-bottom: 2px solid #009 }
nav { border-bottom: 2px solid #009; border-right: 2px solid #009 }
header { display: flex; justify-content: space-between; align-items: baseline; padding: 5px 10px }
header h1 { font-size: 120%; font-weight: bold }
header menu { list-style-type: none; display: flex; gap: 15px }
body > input { display: none }
nav { padding-top: 20px }
nav menu { list-style-type: none }
nav a { display: block; width: 100%; text-decoration: none; padding: 2px 10px; cursor: pointer; white-space: nowrap }
nav a:hover { background-color: #fff }
nav a span { float: right; font-size: 80% }
main { padding: 0 10px 30px 10px }
main h1 { background: #eee; padding: 5px 10px 5px 205px; margin: 40px -10px 10px -210px; scroll-margin-top: 40px; font-size: 130%; font-weight: bold }
main h2 { margin: 20px 0 5px 0; font-size: 120%; font-weight: bold }
p, table, pre { margin: 5px 0 }
pre { border-left: 2px dotted #999; padding-left: 5px; font-family: monospace; white-space: pre; overflow-x: auto; padding-bottom: 15px; /* for the scrollbar, kinda browser-specific */ }
table { border-collapse: collapse }
td { padding: 1px 10px 1px 0; font-size: 12px; vertical-align: top }
td.code { font-family: monospace }
tr:hover { background-color: #eee }
thead { font-weight: bold }
.num { text-align: right; white-space: nowrap }
section.tabs { position: relative; display: flex; flex-wrap: wrap; z-index: 1; }
section.tabs summary { cursor: pointer; order: 0; display: block; padding: 3px 5px; margin-right: 10px; background: #ddd }
section.tabs summary:hover, section.tabs details[open] summary { background: #eee }
section.tabs details { display: contents }
section.tabs details *:nth-child(2) { order: 1; width: 100% }
.sqlt { width: 100%; table-layout: fixed }
.sqlt .num { width: 50px }
.sqlt .num:first-child { width: 75px }
.sqlt .num:nth-child(2) { width: 60px }
.sqlt .sum { white-space: nowrap; font-family: monospace; overflow: hidden; text-overflow: ellipsis }
.sqlt label { cursor: pointer }
.sqlt label span { color: #555; display: inline-block; width: 15px }
.sqlt tr.details { background: #fff }
.sqlt tr.details > td { padding-bottom: 10px }
input[id^=row] { display: none }
small { color: #555; font-size: 90% }
em { font-style: italic }
strong { font-weight: bold }

View file

@ -1,4 +1,4 @@
package FU::Log 1.4; package FU::Log 0.5;
use v5.36; use v5.36;
use Exporter 'import'; use Exporter 'import';
use POSIX 'strftime'; use POSIX 'strftime';
@ -65,6 +65,11 @@ __END__
FU::Log - Extremely Basic Process-Wide Logging Infrastructure FU::Log - Extremely Basic Process-Wide Logging Infrastructure
=head1 EXPERIMENTAL
This module is still in development and there will likely be a few breaking API
changes, see the main L<FU> module for details.
=head1 SYNOPSIS =head1 SYNOPSIS
use FU::Log 'log_write'; use FU::Log 'log_write';

View file

@ -1,9 +1,9 @@
package FU::MultipartFormData 1.4; package FU::MultipartFormData 0.5;
use v5.36; use v5.36;
use Carp 'confess'; use Carp 'confess';
use FU::Util 'utf8_decode'; use FU::Util 'utf8_decode';
sub _arg($d) { $d =~ s{^"(.+)"$}{$1 =~ s/\\([\\"])/$1/rg}er } sub _arg($d) { $d =~ s/^\s+//r =~ s/\s+$//r =~ s/^"(.+)"$/$1/r }
sub parse($pkg, $header, $data) { sub parse($pkg, $header, $data) {
confess "Invalid multipart header '$header'" confess "Invalid multipart header '$header'"
@ -26,14 +26,13 @@ sub parse($pkg, $header, $data) {
start => pos $data, start => pos $data,
}, $pkg; }, $pkg;
confess "Missing content-disposition header" if $hdrs !~ /content-disposition:\s*form-data(.+)/i; confess "Missing content-disposition header" if $hdrs !~ /content-disposition:\s*form-data;(.+)/i;
my $v = $1; my $v = $1;
my $pvalue = qr/("(?:\\[\\"]|[^\\"\r\n]+)*"|[^\s;"]*)/; confess "Missing 'name' parameter" if $v !~ /[;\s]name=([^[;\s]+)/;
confess "Missing 'name' parameter" if $v !~ /;\s*name\s*=\s*$pvalue/;
$d->{name} = utf8_decode _arg $1; $d->{name} = utf8_decode _arg $1;
$d->{filename} = utf8_decode _arg $1 if $v =~ /;\s*filename\s*=\s*$pvalue/; $d->{filename} = utf8_decode _arg $1 if $v =~ /[;\s]filename=([^;\s]+)/;
if ($hdrs =~ /content-type:\s*$pvalue(?:\s*;\s*charset\s*=\s*$pvalue)?/i) { if ($hdrs =~ /content-type:\s*([^;\s]+)(?:\s*;\s*charset=([^;\s]+))?/i) {
$d->{mime} = utf8_decode _arg $1; $d->{mime} = utf8_decode _arg $1;
$d->{charset} = utf8_decode _arg $2 if $2; $d->{charset} = utf8_decode _arg $2 if $2;
} }
@ -175,7 +174,9 @@ this on large fields.
=item value =item value
Returns a copy of the field value as a Unicode string. Returns a copy of the field value as a Unicode string. Uses C<utf8_decode()>
from L<FU::Util>, so also throws an error if the value contains control
characters.
=item substr($off, $len) =item substr($off, $len)

139
FU/Pg.pm
View file

@ -1,4 +1,4 @@
package FU::Pg 1.4; package FU::Pg 0.5;
use v5.36; use v5.36;
use FU::XS; use FU::XS;
@ -7,15 +7,11 @@ _load_libpq();
package FU::Pg::conn { package FU::Pg::conn {
sub lib_version { FU::Pg::lib_version() } sub lib_version { FU::Pg::lib_version() }
sub SQL { sub Q {
require FU::SQL; require FU::SQL;
my $s = shift; my $s = shift;
my($sql, $params) = FU::SQL::SQL(@_)->compile( my($sql, $params) = FU::SQL::SQL(@_)->compile(placeholder_style => 'pg', in_style => 'pg');
placeholder_style => 'pg', $s->q($sql, @$params);
in_style => 'pg',
quote_identifier => sub { $s->conn->escape_identifier(@_) },
);
$s->sql($sql, @$params);
} }
sub set_type($s, $n, @arg) { sub set_type($s, $n, @arg) {
@ -26,13 +22,7 @@ package FU::Pg::conn {
} }
}; };
*FU::Pg::txn::SQL = \*FU::Pg::conn::SQL; *FU::Pg::txn::Q = \*FU::Pg::conn::Q;
# Compat
*FU::Pg::conn::q = \*FU::Pg::conn::sql;
*FU::Pg::txn::q = \*FU::Pg::txn::sql;
*FU::Pg::conn::Q = \*FU::Pg::conn::SQL;
*FU::Pg::txn::Q = \*FU::Pg::txn::SQL;
package FU::Pg::error { package FU::Pg::error {
use overload '""' => sub($e, @) { $e->{full_message} }; use overload '""' => sub($e, @) { $e->{full_message} };
@ -45,6 +35,11 @@ __END__
FU::Pg - The Ultimate (synchronous) Interface to PostgreSQL FU::Pg - The Ultimate (synchronous) Interface to PostgreSQL
=head1 EXPERIMENTAL
This module is still in development and there will likely be a few breaking API
changes, see the main L<FU> module for details.
=head1 SYNOPSYS =head1 SYNOPSYS
use FU::Pg; use FU::Pg;
@ -53,10 +48,10 @@ FU::Pg - The Ultimate (synchronous) Interface to PostgreSQL
$conn->exec('CREATE TABLE books (id SERIAL, title text, read bool)'); $conn->exec('CREATE TABLE books (id SERIAL, title text, read bool)');
$conn->sql('INSERT INTO books (title) VALUES ($1)', 'Revelation Space')->exec; $conn->q('INSERT INTO books (title) VALUES ($1)', 'Revelation Space')->exec;
$conn->sql('INSERT INTO books (title) VALUES ($1)', 'The Invincible')->exec; $conn->q('INSERT INTO books (title) VALUES ($1)', 'The Invincible')->exec;
for my ($id, $title) ($conn->sql('SELECT * FROM books')->flat->@*) { for my ($id, $title) ($conn->q('SELECT * FROM books')->flat->@*) {
print "$id: $title\n"; print "$id: $title\n";
} }
@ -77,7 +72,7 @@ C<$string> can either be in key=value format or a URI, refer to L<the
PostgreSQL PostgreSQL
documentation|https://www.postgresql.org/docs/current/libpq-connect.html#LIBPQ-CONNSTRING> documentation|https://www.postgresql.org/docs/current/libpq-connect.html#LIBPQ-CONNSTRING>
for the full list of supported formats and options. You may also pass an empty for the full list of supported formats and options. You may also pass an empty
string and leave the configuration up to L<environment string and leave the configuration up L<environment
variables|https://www.postgresql.org/docs/current/libpq-envars.html>. variables|https://www.postgresql.org/docs/current/libpq-envars.html>.
=item $conn->server_version =item $conn->server_version
@ -147,7 +142,7 @@ a table, column, function, etc) in an SQL statement.
=item $conn->text($enable) =item $conn->text($enable)
Set the default settings for new statements created with B<< $conn->sql() >>. Set the default settings for new statements created with B<< $conn->q() >>.
=item $conn->cache_size($num) =item $conn->cache_size($num)
@ -175,7 +170,7 @@ Also worth noting that the subroutine is called from the context of the code
executing the query, but I<before> the query results have been returned. executing the query, but I<before> the query results have been returned.
The subroutine is (currently) only called for queries executed through C<< The subroutine is (currently) only called for queries executed through C<<
$conn->exec >>, C<< $conn->sql >>, C<< $conn->SQL >> and their C<$txn> variants; $conn->exec >>, C<< $conn->q >>, C<< $conn->Q >> and their C<$txn> variants;
C<< $conn->copy >> statements and internal queries performed by this module C<< $conn->copy >> statements and internal queries performed by this module
(such as for transaction management, querying type information, etc) do not (such as for transaction management, querying type information, etc) do not
trigger the callback. Statements that result in an error being thrown during or trigger the callback. Statements that result in an error being thrown during or
@ -199,7 +194,7 @@ Execute one or more SQL commands, separated by a semicolon. Returns the number
of rows affected by the last statement or I<undef> if that information is not of rows affected by the last statement or I<undef> if that information is not
available for the given command (like with C<CREATE TABLE>). available for the given command (like with C<CREATE TABLE>).
=item $conn->sql($sql, @params) =item $conn->q($sql, @params)
Create a new SQL statement with the given C<$sql> string and an optional list Create a new SQL statement with the given C<$sql> string and an optional list
of bind parameters. C<$sql> can only hold a single statement. of bind parameters. C<$sql> can only hold a single statement.
@ -215,15 +210,14 @@ Note that this method just creates a statement object, the query is not
prepared or executed until the appropriate statement methods (see below) are prepared or executed until the appropriate statement methods (see below) are
used. used.
=item $conn->SQL(@args) =item $conn->Q(@args)
Same as C<< $conn->sql() >> but uses L<FU::SQL> to construct the query and bind Same as C<< $conn->q() >> but uses L<FU::SQL> to construct the query and bind
parameters. Uses the 'pg' C<in_style> and C<< $conn->escape_identifier() >> for parameters.
identifier quoting.
=back =back
Statement objects returned by C<< $conn->sql() >> support the following Statement objects returned by C<< $conn->q() >> support the following
configuration parameters, which can be set before the statement is executed: configuration parameters, which can be set before the statement is executed:
=over =over
@ -258,7 +252,7 @@ depending on how you'd like to obtain the results:
Execute the query and return the number of rows affected. Similar to C<< Execute the query and return the number of rows affected. Similar to C<<
$conn->exec >>. $conn->exec >>.
my $v = $conn->sql('UPDATE books SET read = true WHERE id = 1')->exec; my $v = $conn->q('UPDATE books SET read = true WHERE id = 1')->exec;
# $v = 1 # $v = 1
=item $st->val =item $st->val
@ -267,7 +261,7 @@ Return the first column of the first row. Throws an error if the query does not
return exactly one column, or if multiple rows are returned. Returns I<undef> return exactly one column, or if multiple rows are returned. Returns I<undef>
if no rows are returned or if its value is I<NULL>. if no rows are returned or if its value is I<NULL>.
my $v = $conn->sql('SELECT COUNT(*) FROM books')->val; my $v = $conn->q('SELECT COUNT(*) FROM books')->val;
# $v = 2 # $v = 2
=item $st->rowl =item $st->rowl
@ -275,7 +269,7 @@ if no rows are returned or if its value is I<NULL>.
Return the first row as a list, or an empty list if no rows are returned. Return the first row as a list, or an empty list if no rows are returned.
Throws an error if the query returned more than one row. Throws an error if the query returned more than one row.
my($id, $title) = $conn->sql('SELECT id, title FROM books LIMIT 1')->rowl; my($id, $title) = $conn->q('SELECT id, title FROM books LIMIT 1')->rowl;
# ($id, $title) = (1, 'Revelation Space'); # ($id, $title) = (1, 'Revelation Space');
=item $st->rowa =item $st->rowa
@ -284,7 +278,7 @@ Return the first row as an arrayref, equivalent to C<< [$st->rowl] >> but might
be slightly more efficient. Returns C<undef> if the query did not generate any be slightly more efficient. Returns C<undef> if the query did not generate any
rows. rows.
my $row = $conn->sql('SELECT id, title FROM books LIMIT 1')->rowa; my $row = $conn->q('SELECT id, title FROM books LIMIT 1')->rowa;
# $row = [1, 'Revelation Space']; # $row = [1, 'Revelation Space'];
=item $st->rowh =item $st->rowh
@ -293,14 +287,14 @@ Return the first row as a hashref. Returns C<undef> if the query did not
generate any rows. Throws an error if the query returns multiple columns with generate any rows. Throws an error if the query returns multiple columns with
the same name. the same name.
my $row = $conn->sql('SELECT id, title FROM books LIMIT 1')->rowh; my $row = $conn->q('SELECT id, title FROM books LIMIT 1')->rowh;
# $row = { id => 1, title => 'Revelation Space' }; # $row = { id => 1, title => 'Revelation Space' };
=item $st->alla =item $st->alla
Return all rows as an arrayref of arrayrefs. Return all rows as an arrayref of arrayrefs.
my $data = $conn->sql('SELECT id, title FROM books')->alla; my $data = $conn->q('SELECT id, title FROM books')->alla;
# $data = [ # $data = [
# [ 1, 'Revelation Space' ], # [ 1, 'Revelation Space' ],
# [ 2, 'The Invincible' ], # [ 2, 'The Invincible' ],
@ -311,7 +305,7 @@ Return all rows as an arrayref of arrayrefs.
Return all rows as an arrayref of hashrefs. Throws an error if the query Return all rows as an arrayref of hashrefs. Throws an error if the query
returns multiple columns with the same name. returns multiple columns with the same name.
my $data = $conn->sql('SELECT id, title FROM books')->allh; my $data = $conn->q('SELECT id, title FROM books')->allh;
# $data = [ # $data = [
# { id => 1, title => 'Revelation Space' }, # { id => 1, title => 'Revelation Space' },
# { id => 2, title => 'The Invincible' }, # { id => 2, title => 'The Invincible' },
@ -321,7 +315,7 @@ returns multiple columns with the same name.
Return an arrayref with all rows flattened. Return an arrayref with all rows flattened.
my $data = $conn->sql('SELECT id, title FROM books')->flat; my $data = $conn->q('SELECT id, title FROM books')->flat;
# $data = [ # $data = [
# 1, 'Revelation Space', # 1, 'Revelation Space',
# 2, 'The Invincible', # 2, 'The Invincible',
@ -333,7 +327,7 @@ Return a hashref where the first result column is used as key and the second
column as value. If the query only returns a single column, C<true> is used as column as value. If the query only returns a single column, C<true> is used as
value instead. An error is thrown if the query returns 3 or more columns. value instead. An error is thrown if the query returns 3 or more columns.
my $data = $conn->sql('SELECT id, title FROM books')->kvv; my $data = $conn->q('SELECT id, title FROM books')->kvv;
# $data = { # $data = {
# 1 => 'Revelation Space', # 1 => 'Revelation Space',
# 2 => 'The Invincible', # 2 => 'The Invincible',
@ -344,7 +338,7 @@ value instead. An error is thrown if the query returns 3 or more columns.
Return a hashref where the first result column is used as key and the remaining Return a hashref where the first result column is used as key and the remaining
columns are stored as arrayref. columns are stored as arrayref.
my $data = $conn->sql('SELECT id, title, read FROM books')->kva; my $data = $conn->q('SELECT id, title, read FROM books')->kva;
# $data = { # $data = {
# 1 => [ 'Revelation Space', true ], # 1 => [ 'Revelation Space', true ],
# 2 => [ 'The Invincible', false ], # 2 => [ 'The Invincible', false ],
@ -355,7 +349,7 @@ columns are stored as arrayref.
Return a hashref where the first result column is used as key and the remaining Return a hashref where the first result column is used as key and the remaining
columns are stored as hashref. columns are stored as hashref.
my $data = $conn->sql('SELECT id, title, read FROM books')->kvh; my $data = $conn->q('SELECT id, title, read FROM books')->kvh;
# $data = { # $data = {
# 1 => { title => 'Revelation Space', read => true }, # 1 => { title => 'Revelation Space', read => true },
# 2 => { title => 'The Invincible', read => false }, # 2 => { title => 'The Invincible', read => false },
@ -367,7 +361,7 @@ The only time you actually need to assign a statement object to a variable is
when you want to inspect the statement using one of the methods below, in all when you want to inspect the statement using one of the methods below, in all
other cases you can chain the methods for more concise code. For example: other cases you can chain the methods for more concise code. For example:
my $data = $conn->sql('SELECT a, b FROM table')->cache(0)->text->alla; my $data = $conn->q('SELECT a, b FROM table')->cache(0)->text->alla;
Statement objects can be inspected with the following methods (many of which Statement objects can be inspected with the following methods (many of which
only make sense after the query has been executed): only make sense after the query has been executed):
@ -387,10 +381,10 @@ Returns the provided bind parameters as an arrayref.
Returns an arrayref of integers indicating the type (as I<oid>) of each Returns an arrayref of integers indicating the type (as I<oid>) of each
parameter in the given C<$sql> string. Example: parameter in the given C<$sql> string. Example:
my $oids = $conn->sql('SELECT id FROM books WHERE id = $1 AND title = $2')->param_types; my $oids = $conn->q('SELECT id FROM books WHERE id = $1 AND title = $2')->param_types;
# $oids = [23,25] # $oids = [23,25]
my $oids = $conn->sql('SELECT id FROM books')->params; my $oids = $conn->q('SELECT id FROM books')->params;
# $oids = [] # $oids = []
This method can be called before the query has been executed, but will then This method can be called before the query has been executed, but will then
@ -403,7 +397,7 @@ prepared statement caching is disabled and C<text_params> is enabled.
Returns an arrayref of hashrefs describing each column that the statement Returns an arrayref of hashrefs describing each column that the statement
returns. returns.
my $cols = $conn->sql('SELECT id, title FROM books')->columns; my $cols = $conn->q('SELECT id, title FROM books')->columns;
# $cols = [ # $cols = [
# { name => 'id', oid => 23 }, # { name => 'id', oid => 23 },
# { name => 'title', oid => 25 }, # { name => 'title', oid => 25 },
@ -452,7 +446,7 @@ fail while a transaction object is alive.
my $txn = $conn->txn; my $txn = $conn->txn;
# run queries # run queries
$txn->sql('DELETE FROM books WHERE id = $1', 1)->exec; $txn->q('DELETE FROM books WHERE id = $1', 1)->exec;
# run commands in a subtransaction # run commands in a subtransaction
{ {
@ -473,9 +467,9 @@ Transaction methods:
=item $txn->exec(..) =item $txn->exec(..)
=item $txn->sql(..) =item $txn->q(..)
=item $txn->SQL(..) =item $txn->Q(..)
Run a query inside the transaction. These work the same as the respective Run a query inside the transaction. These work the same as the respective
methods on the parent C<$conn> object. methods on the parent C<$conn> object.
@ -498,7 +492,7 @@ when the object goes out of scope.
=item $txn->text($enable) =item $txn->text($enable)
Set the default settings for new statements created with B<< $txn->sql() >>. Set the default settings for new statements created with B<< $txn->q() >>.
These settings are inherited from the main connection when the transaction is These settings are inherited from the main connection when the transaction is
created. Subtransactions inherit these settings from their parent transaction. created. Subtransactions inherit these settings from their parent transaction.
@ -637,12 +631,10 @@ Some built-in types deserve a few additional notes:
=item bool =item bool
Boolean values are converted to C<builtin::true> and C<builtin::false>. Boolean values are converted to C<builtin::true> and C<builtin::false>. As bind
parameters, Perl's idea of truthiness is used: C<0>, C<false> and C<""> are
As bind parameters, values recognized by C<to_bool()> in L<FU::Util> are false, everything else is true. Objects that overload I<bool> are also
accepted, in addition to C<0>, C<"f"> and C<""> for false and C<1>, and C<"t"> supported. C<undef> always converts to SQL C<NULL>.
for true. C<undef> always converts to SQL C<NULL>. Everything else throws an
error.
=item bytea =item bytea
@ -708,7 +700,7 @@ While C<null> is a valid JSON value, there's currently no way to distinguish
that from SQL C<NULL>. When sending C<undef> as bind parameter, it is sent as that from SQL C<NULL>. When sending C<undef> as bind parameter, it is sent as
SQL C<NULL>. SQL C<NULL>.
If you prefer to work with JSON as raw text values instead, use: If you prefer to work with JSON are raw text values instead, use:
$conn->set_type(json => 'text'); $conn->set_type(json => 'text');
@ -766,46 +758,7 @@ C<set_type()> to configure appropriate conversions for these types.
=back =back
Utility functions: I<TODO:> Methods to convert between the various formats.
=over
=item $conn->perl2bin($oid, $val)
=item $conn->bin2perl($oid, $bin)
Convert the value for a specific type between the Perl representation and the
PostgreSQL binary format, using the current type configuration of the
connection. This is the same conversion used internally by this module to send
bind parameters and receive query results, and map to the C<send> and C<recv>
functions of C<< $conn->set_type() >>.
These methods throw an error if C<$oid> is not a known type or if the given
data is not valid for the type. However, these methods should not be used for
strict validation: the conversion routines are usually written under the
assumption that the data has been received directly from Postgres or is about
to be sent to (and further validated by) Postgres. For some types,
C<perl2bin()> may return invalid data on invalid input and C<bin2perl()> may
accept invalid binary data.
=item $conn->bin2text($oid, $bin, ...)
=item $conn->text2bin($oid, $text, ...)
Convert between the binary format and the PostgreSQL text format. This
conversion requires a round-trip to the server and throws an error if the
connection state is not I<idle> or I<txn_idle>. Since it is Postgres doing the
conversion, the input is properly validated and, in the case of C<bin2text()>,
the result is guaranteed to be suitable for use as a textual bind parameter or
for inclusion in an SQL query (but don't forget to use C<escape_literal()> in
that case).
Calling these methods many times can be pretty slow. If you have several values
to convert, you can do that in a single call to speed things up:
my($text1, $text2, ..) = $conn->bin2text($oid1, $bin1, $oid2, $bin2, ..);
=back
I<TODO:> Methods to query type info. I<TODO:> Methods to query type info.

View file

@ -1,11 +1,11 @@
package FU::SQL 1.4; package FU::SQL 0.5;
use v5.36; use v5.36;
use Exporter 'import'; use Exporter 'import';
use Carp 'confess'; use Carp 'confess';
use experimental 'builtin', 'for_list'; use experimental 'builtin', 'for_list';
our @EXPORT = qw/ our @EXPORT = qw/
P RAW IDENT SQL P RAW SQL
PARENS INTERSPERSE COMMA PARENS INTERSPERSE COMMA
AND OR WHERE AND OR WHERE
SET VALUES IN SET VALUES IN
@ -16,7 +16,6 @@ sub _obj { bless [@_], 'FU::SQL::val' }
sub P :prototype($) ($p) { bless \(my $x = $p), 'FU::SQL::p' } sub P :prototype($) ($p) { bless \(my $x = $p), 'FU::SQL::p' }
sub RAW :prototype($) ($s) { _obj "$s" } sub RAW :prototype($) ($s) { _obj "$s" }
sub IDENT :prototype($) ($s) { bless \(my $x = "$s"), 'FU::SQL::i' }
# These operate on $_ and must be called with &func syntax. # These operate on $_ and must be called with &func syntax.
# The readonly check can be finicky. # The readonly check can be finicky.
@ -30,7 +29,7 @@ sub COMMA { INTERSPERSE ',', @_ }
sub _conditions { sub _conditions {
@_ == 1 && ref $_[0] eq 'HASH' @_ == 1 && ref $_[0] eq 'HASH'
? map PARENS(IDENT $_, ? map PARENS(RAW $_,
!defined $_[0]{$_} ? ('IS NULL') : !defined $_[0]{$_} ? ('IS NULL') :
ref($_[0]{$_}) eq 'FU::SQL::in' ? ($_[0]{$_}) ref($_[0]{$_}) eq 'FU::SQL::in' ? ($_[0]{$_})
: ('=', $_[0]{$_}) : ('=', $_[0]{$_})
@ -42,11 +41,11 @@ sub AND { !@_ || (@_ == 1 && ref $_[0] eq 'HASH' && keys $_[0]->%* == 0) ? RAW '
sub OR { !@_ || (@_ == 1 && ref $_[0] eq 'HASH' && keys $_[0]->%* == 0) ? RAW '1=0' : INTERSPERSE 'OR', _conditions @_ } sub OR { !@_ || (@_ == 1 && ref $_[0] eq 'HASH' && keys $_[0]->%* == 0) ? RAW '1=0' : INTERSPERSE 'OR', _conditions @_ }
sub WHERE { SQL 'WHERE', AND @_ } sub WHERE { SQL 'WHERE', AND @_ }
sub SET($h) { SQL 'SET', COMMA map SQL(IDENT $_, '=', $h->{$_}), sort keys %$h } sub SET($h) { SQL 'SET', COMMA map SQL(RAW $_, '=', $h->{$_}), sort keys %$h }
sub VALUES { sub VALUES {
@_ == 1 && ref $_[0] eq 'HASH' @_ == 1 && ref $_[0] eq 'HASH'
? SQL '(', COMMA(map IDENT $_, sort keys $_[0]->%*), ') VALUES (', COMMA(map $_[0]{$_}, sort keys $_[0]->%*), ')' ? SQL '(', COMMA(map RAW $_, sort keys $_[0]->%*), ') VALUES (', COMMA(map $_[0]{$_}, sort keys $_[0]->%*), ')'
: @_ == 1 && ref $_[0] eq 'ARRAY' : @_ == 1 && ref $_[0] eq 'ARRAY'
? SQL 'VALUES (', COMMA($_[0]->@*), ')' ? SQL 'VALUES (', COMMA($_[0]->@*), ')'
: SQL 'VALUES (', COMMA(@_), ')'; : SQL 'VALUES (', COMMA(@_), ')';
@ -72,10 +71,6 @@ sub FU::SQL::p::_compile($self, $opt, $sql, $params) {
$$sql .= $opt->{placeholder_style} eq 'pg' ? '$'.@$params : '?'; $$sql .= $opt->{placeholder_style} eq 'pg' ? '$'.@$params : '?';
} }
sub FU::SQL::i::_compile($self, $opt, $sql, $params) {
$$sql .= $opt->{quote_identifier} ? $opt->{quote_identifier}->($$self) : $$self;
}
sub FU::SQL::in::_compile($self, $opt, $sql, $params) { sub FU::SQL::in::_compile($self, $opt, $sql, $params) {
if ($opt->{in_style} eq 'pg') { if ($opt->{in_style} eq 'pg') {
$$sql .= '= ANY('; $$sql .= '= ANY(';
@ -92,7 +87,6 @@ sub FU::SQL::in::_compile($self, $opt, $sql, $params) {
} }
sub FU::SQL::val::compile($self, %opt) { sub FU::SQL::val::compile($self, %opt) {
!/^(placeholder_style|in_style|quote_identifier)$/ && confess "Unknown flag: $_" for keys %opt;
$opt{placeholder_style} ||= 'dbi'; $opt{placeholder_style} ||= 'dbi';
$opt{in_style} ||= 'dbi'; $opt{in_style} ||= 'dbi';
my($sql, @params) = (''); my($sql, @params) = ('');
@ -100,7 +94,7 @@ sub FU::SQL::val::compile($self, %opt) {
($sql, \@params) ($sql, \@params)
} }
*FU::SQL::p::compile = *FU::SQL::i::compile = *FU::SQL::in::compile = \*FU::SQL::val::compile; *FU::SQL::p::compile = *FU::SQL::in::compile = \*FU::SQL::val::compile;
1; 1;
__END__ __END__
@ -109,6 +103,11 @@ __END__
FU::SQL - Small and Safe SQL Query Builder FU::SQL - Small and Safe SQL Query Builder
=head1 EXPERIMENTAL
This module is still in development and there will likely be a few breaking API
changes, see the main L<FU> module for details.
=head1 SYNOPSIS =head1 SYNOPSIS
use FU::SQL; use FU::SQL;
@ -121,7 +120,7 @@ FU::SQL - Small and Safe SQL Query Builder
my $sel = SQL 'SELECT id, name FROM table', WHERE { id => IN([1,2,3]) }; my $sel = SQL 'SELECT id, name FROM table', WHERE { id => IN([1,2,3]) };
my($sql, $params) = $sel->compile; my($sql, @params) = $sel->compile;
=head1 DESCRIPTION =head1 DESCRIPTION
@ -162,16 +161,6 @@ C<'pg'> when your SQL is going to L<FU::Pg> or L<Pg::PQ>.
Set the style to use for C<IN> expressions, refer to the C<IN()> function below Set the style to use for C<IN> expressions, refer to the C<IN()> function below
for details. for details.
=item quote_identifier => $func
Set a function to perform quoting of SQL identifiers. When using DBI, you can
do:
my($sql) = $obj->compile(quote_identifier => sub { $dbh->quote_identifier(@_) });
If this option is not set, identifiers are included into the raw SQL string
without any escaping.
=back =back
=back =back
@ -192,7 +181,7 @@ types of supported arguments:
=item 1. =item 1.
I<String literals> are interpreted as raw SQL fragments. B<String literals> are interpreted as raw SQL fragments.
=item 2. =item 2.
@ -200,7 +189,7 @@ Objects returned by other functions listed below are included as SQL fragments.
=item 3. =item 3.
I<Everything else> is considered a bind parameter. B<Everything else> is considered a bind parameter.
=back =back
@ -260,18 +249,6 @@ Force the given C<$sql> string to be included as SQL. For example:
Never use this function with untrusted input. Never use this function with untrusted input.
=item IDENT($string)
Mark the given string as an SQL identifier. This function is only useful if you
use potentially untrusted input to determine which column to select or which
table to select from, for example:
SQL 'SELECT id,', IDENT $ENV{column}, 'FROM table';
B<WARNING:> By default this function is equivalent to C<RAW()> and hence
provides no safety whatsoever. Be sure to set the C<quote_identifier> option on
C<compile()> to get more useful behavior.
=item PARENS(@args) =item PARENS(@args)
Like C<SQL()> but surrounds the expression by parens: Like C<SQL()> but surrounds the expression by parens:
@ -307,8 +284,8 @@ C<'1=1'> (i.e. true) if C<@conditions> is an empty list.
=item AND($hashref) =item AND($hashref)
A special form of C<AND()> that tests the given columns for equality instead. A special form of C<AND()> that tests the given columns for equality instead.
The keys of the hashref are interpreted as per C<IDENT()> and the values as The keys of the hashref are interpreted as raw SQL and the values as bind
bind parameters. parameters.
AND { id => 1, number => RAW 'random()', x => undef } AND { id => 1, number => RAW 'random()', x => undef }
# '( id = ? ) AND ( number = random() ) AND ( x IS NULL )' # '( id = ? ) AND ( number = random() ) AND ( x IS NULL )'

View file

@ -1,36 +1,26 @@
package FU::Util 1.4; package FU::Util 0.5;
use v5.36; use v5.36;
use FU::XS; use FU::XS;
use Carp 'confess'; use Carp 'confess';
use Exporter 'import'; use Exporter 'import';
use Encode ();
use POSIX (); use POSIX ();
use experimental 'builtin'; use experimental 'builtin';
our @EXPORT_OK = qw/ our @EXPORT_OK = qw/
to_bool to_bool
json_format json_parse json_format json_parse
has_control check_control utf8_decode utf8_decode uri_escape uri_unescape
uri_escape uri_unescape
query_decode query_encode query_decode query_encode
httpdate_format httpdate_parse httpdate_format httpdate_parse
gzip_lib gzip_compress brotli_compress gzip_lib gzip_compress brotli_compress
fdpass_send fdpass_recv fdpass_send fdpass_recv
/; /;
# Internal utility function
sub has_control :prototype($) ($s) { defined $s && $s =~ /[\x00-\x08\x0b\x0c\x0e-\x1f\x7f]/ }
sub check_control :prototype($) ($s) { confess 'Invalid control character' if has_control $s; }
# Deprecated, call Encode::decode() directly.
sub utf8_decode :prototype($) { sub utf8_decode :prototype($) {
return if !defined $_[0]; return if !defined $_[0];
eval { confess 'Invalid UTF-8' if !utf8::decode($_[0]);
$_[0] = Encode::decode('UTF-8', $_[0], Encode::FB_CROAK); confess 'Invalid control character' if $_[0] =~ /[\x00-\x08\x0b\x0c\x0e-\x1f]/;
1
} || confess($@ =~ s/ at .+\n$//r);
$_[0] $_[0]
} }
@ -51,7 +41,6 @@ sub uri_unescape :prototype($) ($s) {
sub query_decode :prototype($) ($s) { sub query_decode :prototype($) ($s) {
my %o; my %o;
for (split /&/, $s//'') { for (split /&/, $s//'') {
next if !length;
my($k,$v) = map uri_unescape($_), split /=/, $_, 2; my($k,$v) = map uri_unescape($_), split /=/, $_, 2;
$v //= builtin::true; $v //= builtin::true;
if (ref $o{$k}) { push $o{$k}->@*, $v } if (ref $o{$k}) { push $o{$k}->@*, $v }
@ -108,6 +97,11 @@ __END__
FU::Util - Miscellaneous Utility Functions FU::Util - Miscellaneous Utility Functions
=head1 EXPERIMENTAL
This module is still in development and there will likely be a few breaking API
changes, see the main L<FU> module for details.
=head1 SYNOPSIS =head1 SYNOPSIS
use FU::Util qw/json_format/; use FU::Util qw/json_format/;
@ -147,7 +141,7 @@ value for C<$val>, due to C<\0> and C<\1> being considered booleans.
=head1 JSON Parsing & Formatting =head1 JSON Parsing & Formatting
This module comes with a custom C-based JSON parser and formatter. These This module comes with a custom C-based JSON parser and formatter. These
functions conform to L<RFC-8259|https://tools.ietf.org/html/rfc8259>, functions conform strictly to L<RFC-8259|https://tools.ietf.org/html/rfc8259>,
non-standard extensions are not supported and never will be. It also happens to non-standard extensions are not supported and never will be. It also happens to
be pretty fast, refer to L<FU::Benchmarks> for some numbers. be pretty fast, refer to L<FU::Benchmarks> for some numbers.
@ -261,9 +255,10 @@ value. There is no way to do that without violating JSON specs, so you should
use entity escaping instead. use entity escaping instead.
Some JSON modules escape the forward slash (C</>) character instead, but that Some JSON modules escape the forward slash (C</>) character instead, but that
is I<only> sufficient for embedding inside a C<< <script> >> tag. In any other is, at best, B<only> sufficient for embedding inside a C<< <script> >> tag (I'm
context, you'll need the more thourough escaping provided by this C<html_safe> not sure how C<< <!-- >> and C<< <![CDATA[ >> are treated in that context). In
option. any other context, you'll need the more thourough escaping provided by this
C<html_safe> option.
=item max_size =item max_size
@ -295,6 +290,18 @@ inputs, at the cost of flexibility.
=over =over
=item utf8_decode($bytes)
Convert a (perl-UTF-8 encoded) byte string into a sanitized perl Unicode
string. The conversion is performed in-place, so the C<$bytes> argument is
turned into a Unicode string. Returns the same string for convenience.
This function throws an error if the input is not valid UTF-8 or if it contains
ASCII control characters - that is, any character between C<0x00> and C<0x1f>
except for tab, newline and carriage return.
(This is a tiny wrapper around C<utf8::decode()> with some extra checks)
=item uri_escape($string) =item uri_escape($string)
Takes an Unicode string and returns a percent-encoded ASCII string, suitable Takes an Unicode string and returns a percent-encoded ASCII string, suitable
@ -303,7 +310,8 @@ for use in a query parameter.
=item uri_unescape($string) =item uri_unescape($string)
Takes an Unicode string potentially containing percent-encoding and returns a Takes an Unicode string potentially containing percent-encoding and returns a
decoded Unicode string. decoded Unicode string. Also checks for ASCII control characters as per
C<utf8_decode()>.
=item query_decode($string) =item query_decode($string)
@ -320,7 +328,8 @@ have a value are decoded as C<builtin::true>. Example:
# } # }
The input C<$string> is assumed to be a perl Unicode string. An error is thrown The input C<$string> is assumed to be a perl Unicode string. An error is thrown
if the resulting data decodes into invalid UTF-8. if the resulting data decodes into invalid UTF-8 or contains control
characters, as per C<utf8_decode>.
=item query_encode($hashref) =item query_encode($hashref)

View file

@ -1,10 +1,10 @@
package FU::Validate 1.4; package FU::Validate 0.5;
use v5.36; use v5.36;
use experimental 'builtin', 'for_list'; use experimental 'builtin', 'for_list';
use builtin qw/true false blessed trim/; use builtin qw/true false blessed trim/;
use Carp 'confess'; use Carp 'confess';
use FU::Util 'to_bool', 'has_control'; use FU::Util 'to_bool';
# Unavailable as custom validation names # Unavailable as custom validation names
@ -12,7 +12,7 @@ my %builtin = map +($_,1), qw/
type type
default default
onerror onerror
trim allow_control trim
elems sort unique elems sort unique
accept_scalar accept_array accept_scalar accept_array
keys values unknown missing keys values unknown missing
@ -296,13 +296,8 @@ sub _validate_input {
$_[1] = $_[1]->@* == 0 ? undef : $c->{accept_array} eq 'first' ? $_[1][0] : $_[1][ $#{$_[1]} ] $_[1] = $_[1]->@* == 0 ? undef : $c->{accept_array} eq 'first' ? $_[1][0] : $_[1][ $#{$_[1]} ]
if $c->{accept_array} && ref $_[1] eq 'ARRAY'; if $c->{accept_array} && ref $_[1] eq 'ARRAY';
# early scalar checks # trim (needs to be done before the 'default' test)
if (defined $_[1] && !ref $_[1] && $type eq 'scalar') { $_[1] = trim $_[1] =~ s/\r//rg if defined $_[1] && !ref $_[1] && $type eq 'scalar' && (!exists $c->{trim} || $c->{trim});
# trim needs to be done before the 'default' test
$_[1] = trim $_[1] =~ s/\r//rg if !exists $c->{trim} || $c->{trim};
return { validation => 'allow_control' } if !$c->{allow_control} && has_control $_[1];
}
# default # default
if (!defined $_[1] || (!ref $_[1] && $_[1] eq '')) { if (!defined $_[1] || (!ref $_[1] && $_[1] eq '')) {
@ -400,48 +395,32 @@ sub empty($c) {
sub _fmtkey($k) { $k =~ /^[a-zA-Z0-9_-]+$/ ? $k : FU::Util::json_format($k); }
sub _fmtval($v) { eval { $v = FU::Util::json_format($v) }; "$v" }
sub _inval($t,$v) { sprintf 'invalid %s: %s', $t, _fmtval $v }
# validation name => formatting sub
# TODO: document.
our %error_format = (
required => sub { 'required value missing' },
allow_control => sub { 'invalid control character' },
type => sub($e) { "invalid type, expected '$e->{expected}' but got '$e->{got}'" },
unknown => sub($e) { sprintf 'unknown key%s: %s', $e->{keys}->@* == 1 ? '' : 's', join ', ', map _fmtkey($_), $e->{keys}->@* },
minlength => sub($e) { sprintf "input too short, expected minimum of %d but got %d", $e->{expected}, $e->{got} },
maxlength => sub($e) { sprintf "input too long, expected maximum of %d but got %d", $e->{expected}, $e->{got} },
length => sub($e) {
!ref $e->{expected}
? sprintf 'invalid input length, expected %d but got %d', $e->{expected}, $e->{got}
: sprintf 'invalid input length, expected between %d and %d but got %d', $e->{expected}->@*, $e->{got}
},
num => sub($e) { _inval 'number', $e->{got} },
min => sub($e) { $e->{error} ? _inval 'number', $e->{error}{got} : sprintf 'expected minimum %s but got %s', $e->{expected}, $e->{got} },
max => sub($e) { $e->{error} ? _inval 'number', $e->{error}{got} : sprintf 'expected maximum %s but got %s', $e->{expected}, $e->{got} },
range => sub($e) { FU::Validate::err::errors($e->{error}) },
);
package FU::Validate::err; package FU::Validate::err;
use v5.36; use v5.36;
use FU::Util;
use overload '""' => sub { $_[0]{longmess} || join "\n", $_[0]->errors }; use overload '""' => sub { $_[0]{longmess} || join "\n", $_[0]->errors };
# TODO: document. sub _fmtkey($k) {
$k =~ /^[a-zA-Z0-9_-]+$/ ? $k : FU::Util::json_format($k);
}
sub _fmtval($v) {
eval { $v = FU::Util::json_format($v) }; "$v"
}
sub errors($e, $prefix='') { sub errors($e, $prefix='') {
my $val = $e->{validation}; my $val = $e->{validation};
my $p = $prefix ? "$prefix: " : ''; my $p = $prefix ? "$prefix: " : '';
$FU::Validate::error_format{$val} ? map "$p$_", $FU::Validate::error_format{$val}->($e) : $val eq 'keys' ? map errors($_, $prefix.'.'._fmtkey($_->{key})), $e->{errors}->@* :
$val eq 'keys' ? map errors($_, $prefix.'.'.FU::Validate::_fmtkey($_->{key})), $e->{errors}->@* : $val eq 'values' ? map errors($_, $prefix.'.'._fmtkey($_->{key})), $e->{errors}->@* :
$val eq 'values' ? map errors($_, $prefix.'.'.FU::Validate::_fmtkey($_->{key})), $e->{errors}->@* : $val eq 'missing' ? $prefix.'.'._fmtkey($e->{key}).': required key missing' :
$val eq 'missing' ? $prefix.'.'.FU::Validate::_fmtkey($e->{key}).': required key missing' :
$val eq 'elems' ? map errors($_, $prefix."[$_->{index}]"), $e->{errors}->@* : $val eq 'elems' ? map errors($_, $prefix."[$_->{index}]"), $e->{errors}->@* :
$val eq 'unique' ? $prefix."[$e->{index_b}] value '".FU::Validate::_fmtval($e->{value_a})."' duplicated" : $val eq 'unique' ? $prefix."[$e->{index_b}] value '"._fmtval($e->{value_a})."' duplicated" :
$val eq 'required' ? "${p}required value missing" :
$val eq 'type' ? "${p}invalid type, expected '$e->{expected}' but got '$e->{got}'" :
$val eq 'unknown' ? ($e->{keys}->@* > 1 ? "${p}unknown keys: ".join(', ', _fmtkey($e->{keys})) : "${p}unknown key '"._fmtkey($e->{keys}[0])."'") :
$e->{error} ? errors($e->{error}, "${p}validation '$val'") : $e->{error} ? errors($e->{error}, "${p}validation '$val'") :
$e->{message} ? "${p}validation '$val': $e->{message}" :
"${p}failed validation '$val'"; "${p}failed validation '$val'";
} }
@ -453,6 +432,11 @@ __END__
FU::Validate - Data and form validation and normalization FU::Validate - Data and form validation and normalization
=head1 EXPERIMENTAL
This module is still in development and there will likely be a few breaking API
changes, see the main L<FU> module for details.
=head1 DESCRIPTION =head1 DESCRIPTION
This module provides an easy and simple interface for data validation. It can This module provides an easy and simple interface for data validation. It can
@ -596,9 +580,6 @@ Upon failure, the error object will look something like:
got => 'scalar' got => 'scalar'
} }
Beware: setting the type to I<any> causes the I<trim> and I<allow_control>
validations to be skipped.
=item default => $val =item default => $val
If not set, or set to C<\'required'> (note: scalarref), then a value is required If not set, or set to C<\'required'> (note: scalarref), then a value is required
@ -632,12 +613,6 @@ By default, any whitespace around scalar-type input is removed before testing
any other validations. Setting I<trim> to a false value will disable this any other validations. Setting I<trim> to a false value will disable this
behavior. behavior.
=item allow_control => 0/1
By default, ASCII control characters in the input are not permitted for scalar
values and trigger a validation error. Set this to a positive value to disable
the check.
=item keys => $hashref =item keys => $hashref
Implies C<< type => 'hash' >>, this option specifies which keys are permitted, Implies C<< type => 'hash' >>, this option specifies which keys are permitted,

View file

@ -1,4 +1,4 @@
package FU::XMLWriter 1.4; package FU::XMLWriter 0.5;
use v5.36; use v5.36;
use Carp 'confess'; use Carp 'confess';
use Exporter 'import'; use Exporter 'import';
@ -83,6 +83,11 @@ __END__
FU::XMLWriter - Convenient and efficient XML and HTML generator. FU::XMLWriter - Convenient and efficient XML and HTML generator.
=head1 EXPERIMENTAL
This module is still in development and there will likely be a few breaking API
changes, see the main L<FU> module for details.
=head1 SYNOPSIS =head1 SYNOPSIS
use FU::XMLWriter ':html5_'; use FU::XMLWriter ':html5_';
@ -263,7 +268,7 @@ and C<"> are replaced with their XML entity.
All of the functions mentioned in this document can be imported individually. All of the functions mentioned in this document can be imported individually.
There are also two import groups: There are also two import groups:
use FU::XMLWriter ':html5_'; use FU::XMLWriter ':html_';
Exports C<tag_()>, C<html_()>, C<lit_()>, C<txt_()> and all of the C<< Exports C<tag_()>, C<html_()>, C<lit_()>, C<txt_()> and all of the C<<
<html-tag>_ >> functions mentioned above. <html-tag>_ >> functions mentioned above.

View file

@ -1,5 +1,5 @@
# This module is for internal use by other FU modules. # This module is for internal use by other FU modules.
package FU::XS 1.4; package FU::XS 0.5;
use Carp; # may be called by XS. use Carp; # may be called by XS.
use XSLoader; use XSLoader;
XSLoader::load('FU'); XSLoader::load('FU');

View file

@ -7,6 +7,10 @@ collection of handy utility modules.
*Contributing:* Refer to my [contribution guidelines](https://dev.yorhel.nl/contributing). *Contributing:* Refer to my [contribution guidelines](https://dev.yorhel.nl/contributing).
## Project Status
**EXPERIMENTAL**; expect breaking changes.
## Build & Install ## Build & Install
```sh ```sh

198
bench.PL
View file

@ -1,9 +1,8 @@
#!/usr/bin/perl #!/usr/bin/perl
# Can be invoked as: # Can be invoked as:
# ./bench.PL # generates FU/Benchmarks.pod, running new benchmarks as necessary # ./bench.PL # generates FU/Benchmarks.pod, running new benchmarks as necessary
# ./bench.PL id x y # invalidate cache for the (regex-)matching benchmark IDs, x and y and re-run them # ./bench.PL id x y # invalidate cache for the (regex-)matching benchmark IDs, x and y and re-run them
# ./bench.PL exec id x y # Run just the given benchmark and exit
# #
# This script obviously has more dependencies than the FU distribution itself. # This script obviously has more dependencies than the FU distribution itself.
# It's supposed to be used by maintainers, not users. # It's supposed to be used by maintainers, not users.
@ -26,74 +25,32 @@ my %modules = map +($_, eval "require $_; \$${_}::VERSION"), qw/
TUWF::XML TUWF::XML
HTML::Tiny HTML::Tiny
XML::Writer XML::Writer
DBD::Pg
Pg::PQ
/; /;
use FU::Pg;
my @exec = $ARGV[0] && $ARGV[0] eq 'exec' ? @ARGV[1..3] : ();
my @run = !@exec && @ARGV && (qr/$ARGV[0]/i, $ARGV[1] ? qr/$ARGV[1]/i : qr/.*/, $ARGV[2] ? qr/$ARGV[2]/i : qr/.*/);
my %data; # "id x y" => { id x y rate exists } my %data; # "id x y" => { id x y rate exists }
my @bench; # [ id, text, [ x_1, .. ], [ [ y_1, mod_1, sub_1, .. ], .. ] ]
my %oldmodules; my %oldmodules;
if (!@exec) { { if (open my $F, '<', 'FU/Benchmarks.pod') {
if (open my $F, '<', 'FU/Benchmarks.pod') { my $indata;
my $indata; while (<$F>) {
while (<$F>) { chomp;
chomp; $oldmodules{$1} = $2 if /^=item L<([a-zA-Z0-9:]+)> ([0-9.]+)/;
$oldmodules{$1} = $2 if /^=item L<([a-zA-Z0-9:]+)> ([0-9.]+)/; $indata = 1 if /^# Cached data used by bench\.PL/;
$indata = 1 if /^# Cached data used by bench\.PL/; next if !$indata || !$_ || /^#/;
next if !$indata || !$_ || /^#/; my %d;
my %d; @d{qw/id x y rate/} = split /\t/;
@d{qw/id x y rate/} = split /\t/; $data{"$d{id} $d{x} $d{y}"} = \%d;
$data{"$d{id} $d{x} $d{y}"} = \%d;
}
} }
} }
if (@ARGV) {
my $idre = qr/$ARGV[0]/i;
my $xre = $ARGV[1] ? qr/$ARGV[1]/i : qr/.*/;
my $yre = $ARGV[2] ? qr/$ARGV[2]/i : qr/.*/;
delete $_->{rate} for grep $_->{id} =~ /$idre/ && $_->{x} =~ /$xre/ && $_->{y} =~ /$yre/, values %data;
} }
sub fmtbench($id, $text, $xs, $ys) { my @bench; # [ id, text, [ x_1, .. ], [ [ y_1, mod_1, sub_1, .. ], .. ] ]
my $r = "$text\n\n";
if (@$xs > 1) {
$r .= sprintf '%18s', '';
$r .= sprintf '%12s', $_ for @$xs;
$r .= "\n";
}
for my ($n, $yr) (builtin::indexed @$ys) {
my $x = $xs->[$n];
my ($y, $m, @ys) = @$yr;
$m ||= $y;
$r .= sprintf '%18s', $y;
for my $i (0..$#$xs) {
my $d = $data{"$id $xs->[$i] $y"};
$r .= $d && $d->{rate} ? sprintf '%10d/s', $d->{rate} : sprintf '%12s', '-';
}
$r .= "\n";
}
"$r\n"
}
$SIG{INT} = $SIG{HUP} = sub { exit };
END {
exit if @exec;
open my $F, '>FU/Benchmarks.pod' or die $!;
select $F;
while (<DATA>) {
s/^%/=/;
s#^:modules#join '', map sprintf("=item L<%s> %s\n\n", $_, $modules{$_}), sort keys %modules#e;
s#^:benches (.+)#join '', map fmtbench(@$_), grep $_->[0] =~ /$1/, @bench#e;
print;
}
for (sort keys %data) {
my $b = $data{$_};
print join("\t", map $_//'', @{$b}{qw/ id x y rate /})."\n";
}
}
sub def($id, $text, $xs, @ys) { sub def($id, $text, $xs, @ys) {
for my ($ya) (@ys) { for my ($ya) (@ys) {
my($y, $m, @sub) = @$ya; my($y, $m, @sub) = @$ya;
@ -104,6 +61,12 @@ sub def($id, $text, $xs, @ys) {
$data{$d} ||= { id => $id, x => $x, y => $y }; $data{$d} ||= { id => $id, x => $x, y => $y };
$d = $data{$d}; $d = $data{$d};
$d->{exists} = 1; $d->{exists} = 1;
delete $d->{rate} if !$oldmodules{$m} || $modules{$m} ne $oldmodules{$m};
if (!exists $d->{rate}) {
my $o = timethis -5, $sub[$i], 0, 'none';
$d->{rate} = sprintf '%.0f', $o->iters/$o->real;
printf "%-20s%-12s%-20s%10d/s\n", $id, $x, $y, $d->{rate};
}
} }
} }
push @bench, [ $id, $text, $xs, \@ys ]; push @bench, [ $id, $text, $xs, \@ys ];
@ -149,7 +112,7 @@ defjson stru => 0, 'Unicode strings', do { use utf8;
[ map +('グリザイアの果実 -LE FRUIT DE LA GRISAIA-', '💩', 'Я люблю нічого не робити'), 1..50 ]; [ map +('グリザイアの果実 -LE FRUIT DE LA GRISAIA-', '💩', 'Я люблю нічого не робити'), 1..50 ];
}; };
defjson stres => 0, 'String escaping (few)', [ map 'This string needs to "be escaped" a little bit', 1..100 ]; defjson stres => 0, 'String escaping (few)', [ map 'This string needs to "be escaped" a little bit', 1..100 ];
defjson strel => 0, 'String escaping (many)', [ map "This \" \\ needs \n\x41\x42\x43\x44 more", 1..100 ]; defjson strel => 0, 'String escaping (many)', [ map "This \" \\ needs \b\x01\x02\x03\x04 more", 1..100 ];
@ -233,76 +196,43 @@ def 'xml/a', 'HTML fragment', [ 'Rate' ],
{
die "FU_TEST_DB not set.\n" if @exec && !$ENV{FU_TEST_DB};
my $pq = @exec && Pg::PQ::Conn->new($ENV{FU_TEST_DB});
my $fu = @exec && FU::Pg->connect($ENV{FU_TEST_DB});
# XXX: Doesn't support all connection params this way
my $dbi = @exec && DBI->connect("dbi:Pg:dbname=".$pq->db, $pq->user, $pq->pass, {RaiseError => 1, PrintError => 0});
my $small = 'SELECT x, x+1, x+2, x+3, x+4, x+5, x+6, x+7, x+8, x+9 FROM generate_series(-10000::smallint, 9999, 10) x(x)';
my $big = 'SELECT x<<5, x<<10, x<<15, x<<20, x<<25, x<<30, x<<35, x<<40, x<<45, x<<50 FROM generate_series(1::bigint, 20000, 1) x(x)';
my sub dbi { my $sum = 0; my $st = $dbi->prepare_cached($_[0]); for my $row ($dbi->selectall_arrayref($st)->@*) { $sum ^= $_ for @$row; } }
my sub pq { my $sum = 0; $pq->prepare('' => $_[0]); for my $row ($pq->execQueryPrepared('')->rows) { $sum ^= $_ for @$row; } }
my sub fub { my $sum = 0; for my $row ($fu->sql($_[0])->alla->@*) { $sum ^= $_ for @$row; } }
my sub fut { my $sum = 0; for my $row ($fu->sql($_[0])->text->alla->@*) { $sum ^= $_ for @$row; } }
def 'pg/ints', 'Fetch and bitwise-or 20k integers', [ 'Smallint', 'Bigint' ],
[ 'DBD::Pg', undef, sub { dbi($small) }, sub { dbi($big) } ],
[ 'Pg::PQ', undef, sub { pq($small) }, sub { pq($big) } ],
[ 'FU::Pg (bin)', 'FU', sub { fub($small) }, sub { fub($big) } ],
[ 'FU::Pg (text)', 'FU', sub { fut($small) }, sub { fut($big) } ];
}
delete @data{ grep !$data{$_}{exists}, keys %data }; delete @data{ grep !$data{$_}{exists}, keys %data };
sub fmtbench($id, $text, $xs, $ys) {
sub runbench($sub) { my $r = "$text\n\n";
my $o = timethis -1, $sub, 0, 'none'; if (@$xs > 1) {
printf "%.2f\n", $o->iters/$o->real; $r .= sprintf '%18s', '';
exit; $r .= sprintf '%12s', $_ for @$xs;
} $r .= "\n";
sub execbench($d) {
my $sum = 0;
my $num = 1;
local $| = 1;
printf "%-20s%-12s%-20s", $d->{id}, $d->{x}, $d->{y};
for (1..$num) {
open my $P, '-|', $^X, (map "-I$_", @INC), $0, 'exec', $d->{id}, $d->{x}, $d->{y};
chomp(my $rate = <$P>);
printf "%10d", $rate;
$sum += $rate;
} }
printf " ->%10d\n", $sum/$num; for my ($n, $yr) (builtin::indexed @$ys) {
$d->{rate} = sprintf '%.0f', $sum/$num; my $x = $xs->[$n];
} my ($y, $m, @ys) = @$yr;
for my $b (@bench) {
my ($id, $text, $xs, $ys) = @$b;
for my ($ya) (@$ys) {
my($y, $m, @sub) = @$ya;
$m ||= $y; $m ||= $y;
for my($i, $x) (builtin::indexed @$xs) { $r .= sprintf '%18s', $y;
next if !$sub[$i]; for my $i (0..$#$xs) {
if (@exec) { my $d = $data{"$id $xs->[$i] $y"};
runbench $sub[$i] if $exec[0] eq $id && $exec[1] eq $x && $exec[2] eq $y; $r .= $d ? sprintf '%10d/s', $d->{rate} : sprintf '%12s', '-';
} else {
my $d = $data{"$id $x $y"};
execbench $d if !$oldmodules{$m} || $modules{$m} ne $oldmodules{$m}
|| (@run && $id =~ /$run[0]/ && $x =~ /$run[1]/ && $y =~ /$run[2]/);
}
} }
$r .= "\n";
} }
"$r\n"
} }
die if @exec; {
open my $F, '>FU/Benchmarks.pod' or die $!;
select $F;
while (<DATA>) {
s/^%/=/;
s#^:modules#join '', map sprintf("=item L<%s> %s\n\n", $_, $modules{$_}), sort keys %modules#e;
s#^:benches (.+)#join '', map fmtbench(@$_), grep $_->[0] =~ /$1/, @bench#e;
print;
}
for (sort keys %data) {
my $b = $data{$_};
print join("\t", @{$b}{qw/ id x y rate /})."\n";
}
}
# s/^=/%/ to prevent tools from interpreting the below as POD # s/^=/%/ to prevent tools from interpreting the below as POD
__DATA__ __DATA__
@ -346,27 +276,15 @@ These benchmarks run on large-ish arrays with repeated values. JSON encoding is
sufficiently fast that Perl function calling overhead tends to dominate for sufficiently fast that Perl function calling overhead tends to dominate for
smaller inputs, but I don't find that overhead very interesting. smaller inputs, but I don't find that overhead very interesting.
Also worth noting that L<JSON::SIMD> formatting code is forked from Also worth noting that JSON::SIMD formatting code is forked from JSON::XS, the
L<JSON::XS>, the SIMD parts are only used for parsing. SIMD parts are only used for parsing.
:benches ^json :benches ^json
%head2 XML Writing %head2 XML Writing
L<FU::XMLWriter> is the only XS-based XML DSL that I'm aware of, so all direct
competition is inherently slower by virtue of being pure perl. I'm sure some
templating modules will perform better, though.
:benches ^xml :benches ^xml
%head2 PostgreSQL client
Fetching query results is highly unlikely to be a bottleneck in your code, this
benchmark is mainly here to verify that L<FU::Pg> is not introducing a
bottleneck where there shouldn't be one.
:benches ^pg
%cut %cut
# Cached data used by bench.PL. Same as the formatted tables above but easier to parse. # Cached data used by bench.PL. Same as the formatted tables above but easier to parse.

View file

@ -18,7 +18,6 @@
#define FUFE_CLEN -5 #define FUFE_CLEN -5
#define FUFE_ABORT -6 /* explicit abort or client-level EOF */ #define FUFE_ABORT -6 /* explicit abort or client-level EOF */
#define FUFE_NOREQ -7 /* protocol-level EOF before we received anything */ #define FUFE_NOREQ -7 /* protocol-level EOF before we received anything */
#define FUFE_SEND -8 /* error in send() */
#define FUFCGI_MAX_DATA 65535 #define FUFCGI_MAX_DATA 65535
@ -178,8 +177,8 @@ static int fufcgi_write_record(fufcgi *ctx, fufcgi_rec *hdr, char *buf) {
buf[7] = 0; buf[7] = 0;
int len = hdr->len + 8; int len = hdr->len + 8;
while (len > 0) { while (len > 0) {
int r = send(ctx->fd, buf, len, MSG_NOSIGNAL); int r = write(ctx->fd, buf, len);
if (r <= 0) return FUFE_SEND; if (r <= 0) return r == 0 ? FUFE_EOF : FUFE_IO;
buf += r; buf += r;
len -= r; len -= r;
} }
@ -320,11 +319,8 @@ static int fufcgi_read_params(pTHX_ fufcgi *ctx, fufcgi_rec *rec) {
p.name += 5; p.name += 5;
for (r=0; r<p.namelen; r++) for (r=0; r<p.namelen; r++)
p.name[r] = p.name[r] == '_' ? '-' : p.name[r] >= 'A' && p.name[r] <= 'Z' ? p.name[r] | 0x20 : p.name[r]; p.name[r] = p.name[r] == '_' ? '-' : p.name[r] >= 'A' && p.name[r] <= 'Z' ? p.name[r] | 0x20 : p.name[r];
if (!(p.namelen == 14 && memcmp(p.name, "content-length", 14) == 0) valsv = newSV(p.vallen+1);
&& !(p.namelen == 12 && memcmp(p.name, "content-type", 12) == 0)) { hv_store(ctx->headers, p.name, p.namelen, valsv, 0);
valsv = newSV(p.vallen+1);
hv_store(ctx->headers, p.name, p.namelen, valsv, 0);
}
} else if (p.namelen == 14 && memcmp(p.name, "CONTENT_LENGTH", 14) == 0) { } else if (p.namelen == 14 && memcmp(p.name, "CONTENT_LENGTH", 14) == 0) {
valsv = newSV(p.vallen+1); valsv = newSV(p.vallen+1);
@ -410,19 +406,18 @@ static int fufcgi_read_req(pTHX_ fufcgi *ctx, SV *headers, SV *params) {
} }
} }
static void fufcgi_flush(pTHX_ fufcgi *ctx) { static void fufcgi_flush(fufcgi *ctx) {
fufcgi_rec hdr; fufcgi_rec hdr;
if (ctx->len > 0) { if (ctx->len > 0) {
hdr.len = ctx->len; hdr.len = ctx->len;
hdr.type = FCGI_STDOUT; hdr.type = FCGI_STDOUT;
hdr.id = ctx->reqid; hdr.id = ctx->reqid;
if (fufcgi_write_record(ctx, &hdr, ctx->buf) != FUFE_OK) fufcgi_write_record(ctx, &hdr, ctx->buf);
croak("%s\n", strerror(errno));
ctx->len = 0; ctx->len = 0;
} }
} }
static void fufcgi_print(pTHX_ fufcgi *ctx, const char *buf, int len) { static void fufcgi_print(fufcgi *ctx, const char *buf, int len) {
int r; int r;
while (len > 0) { while (len > 0) {
r = len > FUFCGI_MAX_DATA - ctx->len ? FUFCGI_MAX_DATA - ctx->len : len; r = len > FUFCGI_MAX_DATA - ctx->len ? FUFCGI_MAX_DATA - ctx->len : len;
@ -430,25 +425,23 @@ static void fufcgi_print(pTHX_ fufcgi *ctx, const char *buf, int len) {
ctx->len += r; ctx->len += r;
len -= r; len -= r;
buf += r; buf += r;
if (ctx->len >= FUFCGI_MAX_DATA) fufcgi_flush(aTHX_ ctx); if (ctx->len >= FUFCGI_MAX_DATA) fufcgi_flush(ctx);
} }
} }
static void fufcgi_done(pTHX_ fufcgi *ctx) { static void fufcgi_done(fufcgi *ctx) {
fufcgi_rec hdr; fufcgi_rec hdr;
fufcgi_flush(aTHX_ ctx); fufcgi_flush(ctx);
hdr.len = 0; hdr.len = 0;
hdr.type = FCGI_STDOUT; hdr.type = FCGI_STDOUT;
hdr.id = ctx->reqid; hdr.id = ctx->reqid;
if (fufcgi_write_record(ctx, &hdr, ctx->buf) != FUFE_OK) fufcgi_write_record(ctx, &hdr, ctx->buf);
croak("%s\n", strerror(errno));
memcpy(ctx->buf+8, "\0\0\0\0\0\0\0\0", 8); /* FCGI_REQUEST_COMPLETE */ memcpy(ctx->buf+8, "\0\0\0\0\0\0\0\0", 8); /* FCGI_REQUEST_COMPLETE */
hdr.type = FCGI_END_REQUEST; hdr.type = FCGI_END_REQUEST;
hdr.len = 8; hdr.len = 8;
if (fufcgi_write_record(ctx, &hdr, ctx->buf) != FUFE_OK) fufcgi_write_record(ctx, &hdr, ctx->buf);
croak("%s\n", strerror(errno));
ctx->reqid = ctx->len = ctx->off = 0; ctx->reqid = ctx->len = ctx->off = 0;
} }

View file

@ -244,7 +244,7 @@ static void fujson_fmt(pTHX_ fujson_fmt_ctx *ctx, SV *val) {
if (isinfnan(nv)) croak("unable to format floating point NaN or Inf as JSON"); if (isinfnan(nv)) croak("unable to format floating point NaN or Inf as JSON");
/* XXX: Cpanel::JSON::XS appears to always append a ".0" for round numbers, other modules do not. */ /* XXX: Cpanel::JSON::XS appears to always append a ".0" for round numbers, other modules do not. */
/* XXX#2: This doesn't support quadmath. Makefile.PL checks for that */ /* XXX#2: This doesn't support quadmath. Makefile.PL checks for that */
fustr_reserve(ctx->out, NV_DIG+32); fustr_reserve(ctx->out, NV_DIG+1);
Gconvert(nv, NV_DIG, 0, ctx->out->cur); Gconvert(nv, NV_DIG, 0, ctx->out->cur);
ctx->out->cur += strlen(ctx->out->cur); ctx->out->cur += strlen(ctx->out->cur);
} else if (SvIOKp(val)) { } else if (SvIOKp(val)) {

View file

@ -236,12 +236,12 @@ static SV *fujson_parse(pTHX_ fujson_parse_ctx *ctx) {
if (ctx->end - ctx->buf < 4) return NULL; if (ctx->end - ctx->buf < 4) return NULL;
if (memcmp(ctx->buf, "true", 4) != 0) return NULL; if (memcmp(ctx->buf, "true", 4) != 0) return NULL;
ctx->buf += 4; ctx->buf += 4;
return newSV_true(); return &PL_sv_yes;
case 'f': case 'f':
if (ctx->end - ctx->buf < 5) return NULL; if (ctx->end - ctx->buf < 5) return NULL;
if (memcmp(ctx->buf, "false", 5) != 0) return NULL; if (memcmp(ctx->buf, "false", 5) != 0) return NULL;
ctx->buf += 5; ctx->buf += 5;
return newSV_false(); return &PL_sv_no;
case 'n': case 'n':
if (ctx->end - ctx->buf < 4) return NULL; if (ctx->end - ctx->buf < 4) return NULL;
if (memcmp(ctx->buf, "null", 4) != 0) return NULL; if (memcmp(ctx->buf, "null", 4) != 0) return NULL;
@ -275,7 +275,6 @@ static SV *fujson_parse_xs(pTHX_ I32 ax, I32 argc, SV *val) {
if (strcmp(arg, "utf8") == 0) decutf8 = SvTRUEx(r); if (strcmp(arg, "utf8") == 0) decutf8 = SvTRUEx(r);
else if (strcmp(arg, "max_size") == 0) maxlen = SvUV(r); else if (strcmp(arg, "max_size") == 0) maxlen = SvUV(r);
else if (strcmp(arg, "max_depth") == 0) ctx.depth = SvUV(r); else if (strcmp(arg, "max_depth") == 0) ctx.depth = SvUV(r);
else if (strcmp(arg, "allow_control") == 0) {}
else if (strcmp(arg, "offset") == 0) offset = r; else if (strcmp(arg, "offset") == 0) offset = r;
else croak("Unknown flag: '%s'", arg); else croak("Unknown flag: '%s'", arg);
} }

View file

@ -626,80 +626,3 @@ static void fupg_tio_free(fupg_tio *tio) {
safefree(tio->record.tio); safefree(tio->record.tio);
} }
} }
static SV *fupg_perl2bin(pTHX_ fupg_conn *conn, Oid oid, SV *sv) {
int refresh_done = 0;
fupg_tio tio;
fustr buf;
memset(&tio, 0, sizeof(tio));
fupg_tio_setup(aTHX_ conn, &tio, FUPGT_SEND, oid, &refresh_done);
fustr_init(&buf, sv_newmortal(), SIZE_MAX);
tio.send(aTHX_ &tio, sv, &buf); /* XXX: Leaks 'tio' on error */
fupg_tio_free(&tio);
return fustr_done(&buf);
}
static SV *fupg_bin2perl(pTHX_ fupg_conn *conn, Oid oid, SV *sv) {
int refresh_done = 0;
fupg_tio tio;
STRLEN len;
const char *buf = SvPVbyte(sv, len);
memset(&tio, 0, sizeof(tio));
fupg_tio_setup(aTHX_ conn, &tio, FUPGT_RECV, oid, &refresh_done);
SV *r = tio.recv(aTHX_ &tio, buf, len); /* XXX: Leaks 'tio' on error */
fupg_tio_free(&tio);
return r;
}
static I32 fupg_bintext(pTHX_ fupg_conn *conn, int format, I32 ax, I32 argc) {
int vals = argc/2;
if (argc == 1 || argc % 2 == 0) croak("Usage: $conn->%s(oid, data, ...)", format ? "text2bin" : "bin2text");
if (vals > 1 && GIMME_V != G_LIST) {
ST(0) = sv_2mortal(newSViv(vals));
return 1;
}
Oid *paramtypes = safemalloc(vals * sizeof(*paramtypes));
const char **paramvalues = safemalloc(vals * sizeof(*paramvalues));
int *paramlengths = safemalloc(vals * sizeof(*paramlengths));
int *paramformats = safemalloc(vals * sizeof(*paramformats));
fustr sql;
fustr_init(&sql, NULL, SIZE_MAX);
fustr_write(&sql, "SELECT ", 7);
STRLEN len;
int i;
for (i=0; i<vals; i++) {
paramtypes[i] = SvIV(ST(i*2+1));
paramvalues[i] = format ? SvPVutf8(ST(i*2+2), len) : SvPVbyte(ST(i*2+2), len);
paramlengths[i] = len;
paramformats[i] = format ? 0 : 1;
if (i) fustr_write_ch(&sql, ',');
sql.cur -= 8 - sprintf(fustr_write_buf(&sql, 8), "$%d", i+1);
}
fustr_write_ch(&sql, 0);
PGresult *r = PQexecParams(conn->conn, fustr_start(&sql), vals,
paramtypes, paramvalues, paramlengths, paramformats, format);
safefree(paramtypes);
safefree(paramvalues);
safefree(paramlengths);
safefree(paramformats);
SvREFCNT_dec(sql.sv);
if (!r) fupg_conn_croak(conn, "exec");
if (PQresultStatus(r) != PGRES_TUPLES_OK) fupg_result_croak(r, "exec", sql.sv ? "SELECT $1, ..." : sql.sbuf);
/* The stack is guaranteed to be large enough, since we received 1+2*vals arguments */
for (i=0; i<vals; i++)
ST(i) = newSVpvn_flags(PQgetvalue(r, 0, i), PQgetlength(r, 0, i), SVs_TEMP | (format ? 0 : SVf_UTF8));
PQclear(r);
return vals;
}

View file

@ -76,7 +76,7 @@ static SV *fupg_exec(pTHX_ fupg_conn *c, const char *sql) {
return ret; return ret;
} }
static SV *fupg_sql(pTHX_ fupg_conn *c, int stflags, const char *query, I32 ax, I32 argc) { static SV *fupg_q(pTHX_ fupg_conn *c, int stflags, const char *query, I32 ax, I32 argc) {
fupg_st *st = safecalloc(1, sizeof(fupg_st)); fupg_st *st = safecalloc(1, sizeof(fupg_st));
st->conn = c; st->conn = c;
st->cookie = c->cookie; st->cookie = c->cookie;
@ -463,7 +463,7 @@ static SV *fupg_st_kvv(pTHX_ fupg_st *st) {
SAVETMPS; SAVETMPS;
SV *key = sv_2mortal(fupg_st_getval(aTHX_ st, i, 0)); SV *key = sv_2mortal(fupg_st_getval(aTHX_ st, i, 0));
if (hv_exists_ent(hv, key, 0)) fu_confess("Key '%s' is duplicated in $st->kvv() query results", SvPV_nolen(key)); if (hv_exists_ent(hv, key, 0)) fu_confess("Key '%s' is duplicated in $st->kvv() query results", SvPV_nolen(key));
hv_store_ent(hv, key, st->nfields == 1 ? newSV_true() : fupg_st_getval(aTHX_ st, i, 1), 0); hv_store_ent(hv, key, st->nfields == 1 ? &PL_sv_yes : fupg_st_getval(aTHX_ st, i, 1), 0);
FREETMPS; FREETMPS;
} }
return sv; return sv;

View file

@ -78,25 +78,18 @@ SENDFN(domain) { (void)out; SERR("domain type should not be handled by this func
RECVFN(bool) { RECVFN(bool) {
RLEN(1); RLEN(1);
return *buf ? newSV_true() : newSV_false(); return *buf ? &PL_sv_yes : &PL_sv_no;
} }
SENDFN(bool) { SENDFN(bool) {
int r = fu_2bool(aTHX_ val); int r = fu_2bool(aTHX_ val); /* So that we also recognize \0 and \1 */
if (r < 0) { fustr_write_ch(out, r < 0 ? SvTRUE(val) : r);
STRLEN l;
const char *x = SvPV(val, l);
if (l == 0 || (l == 1 && (*x == '0' || *x == 'f'))) r = 0;
else if (l == 1 && (*x == '1' || *x == 't')) r = 1;
else SERR("invalid boolean value: %s", x);
}
fustr_write_ch(out, r);
} }
RECVFN(void) { RECVFN(void) {
RLEN(0); RLEN(0);
(void)buf; (void)buf;
return newSV(0); return &PL_sv_undef;
} }
SENDFN(void) { SENDFN(void) {
@ -276,7 +269,7 @@ SENDFN(jsonpath) {
#define ARRAY_MAXDIM 100 #define ARRAY_MAXDIM 100
static SV *fupg_recv_array_elem(pTHX_ const fupg_tio *elem, const char *header, U32 dim, U32 ndim, const char **buf, const char *end) { static SV *fupg_recv_array_elem(pTHX_ const fupg_tio *elem, const char *header, U32 dim, U32 ndim, const char **buf, const char *end) {
SV *r; SV *r = &PL_sv_undef;
if (dim == ndim) { if (dim == ndim) {
if (end - *buf < 4) fu_confess("Invalid array format"); if (end - *buf < 4) fu_confess("Invalid array format");
I32 len = fu_frombeI(32, *buf); I32 len = fu_frombeI(32, *buf);
@ -286,8 +279,6 @@ static SV *fupg_recv_array_elem(pTHX_ const fupg_tio *elem, const char *header,
if (len >= 0) { if (len >= 0) {
r = elem->recv(aTHX_ elem, *buf, len); r = elem->recv(aTHX_ elem, *buf, len);
*buf += len; *buf += len;
} else {
r = newSV(0);
} }
} else { } else {
@ -412,14 +403,12 @@ RECVFN(record) {
if (oid != ctx->record.info->attrs[i].oid) if (oid != ctx->record.info->attrs[i].oid)
RERR("expected field %d to be of type %u but got %u", i, ctx->record.info->attrs[i].oid, oid); RERR("expected field %d to be of type %u but got %u", i, ctx->record.info->attrs[i].oid, oid);
I32 vlen = fu_frombeI(32, buf+4); I32 vlen = fu_frombeI(32, buf+4);
SV *r; SV *r = &PL_sv_undef;
buf += 8; len -= 8; buf += 8; len -= 8;
if (vlen > len) RERR("input data too short"); if (vlen > len) RERR("input data too short");
if (vlen >= 0) { if (vlen >= 0) {
r = ctx->record.tio[i].recv(aTHX_ ctx->record.tio+i, buf, vlen); r = ctx->record.tio[i].recv(aTHX_ ctx->record.tio+i, buf, vlen);
buf += vlen; len -= vlen; buf += vlen; len -= vlen;
} else {
r = newSV(0);
} }
hv_store(hv, ctx->record.info->attrs[i].name.n, -strlen(ctx->record.info->attrs[i].name.n), r, 0); hv_store(hv, ctx->record.info->attrs[i].name.n, -strlen(ctx->record.info->attrs[i].name.n), r, 0);
} }

View file

@ -27,8 +27,6 @@ static void fuxmlwr_destroy(pTHX_ fuxmlwr *wr) {
static void fuxmlwr_escape(pTHX_ fuxmlwr *wr, SV *sv) { static void fuxmlwr_escape(pTHX_ fuxmlwr *wr, SV *sv) {
if (SvROK(sv) && !SvAMAGIC(sv)) fu_confess("Invalid attempt to output bare reference");
STRLEN len; STRLEN len;
const unsigned char *str = (unsigned char *)SvPV_const(sv, len); const unsigned char *str = (unsigned char *)SvPV_const(sv, len);
const unsigned char *tmp, *end = str + len; const unsigned char *tmp, *end = str + len;
@ -98,7 +96,7 @@ static void fuxmlwr_tag(pTHX_ fuxmlwr *wr, I32 ax, I32 offset, I32 argc, int sel
val = ST(offset); val = ST(offset);
offset++; offset++;
// Don't even try to stringify attribute names; non-string keys are always a bug. // Don't even try to stringify other arguments; non-string keys are always a bug.
if (!SvPOK(key)) fu_confess("Non-string attribute"); if (!SvPOK(key)) fu_confess("Non-string attribute");
keys = SvPVX(key); keys = SvPVX(key);

View file

@ -54,11 +54,6 @@ start;
begin 1, 2; begin 1, 2;
record 1, 4, ""; record 1, 4, "";
start;
begin 3, 2, 1;
$remote->close;
iserr -8;
start; start;
begin 3, 2, 1; begin 3, 2, 1;
begin 1, 1, 1; begin 1, 1, 1;
@ -172,15 +167,6 @@ record 1, 4, "\x0c\x05CONTENT_TYPEsomet";
record 1, 2, ""; record 1, 2, "";
isrec {'content-type','somet'}, {body => ''}, -6; isrec {'content-type','somet'}, {body => ''}, -6;
start;
begin;
record 1, 4, "\x13\x01HTTP_CONTENT_LENGTH3\x0e\x01CONTENT_LENGTH0\x13\x01HTTP_CONTENT_LENGTH5";
record 1, 4, "";
record 1, 5, "";
isrec {'content-length','0'}, {body => ''};
$remote->close;
ok !eval { $f->flush; 1 };
start; start;
begin; begin;
record 1, 4, "\x0e\x05CONTENT_LENGTH65536"; record 1, 4, "\x0e\x05CONTENT_LENGTH65536";

View file

@ -2,7 +2,7 @@ use v5.36;
use Test::More; use Test::More;
use FU::Util 'json_parse'; use FU::Util 'json_parse';
no warnings 'experimental::builtin'; no warnings 'experimental::builtin';
use builtin 'is_bool', 'created_as_number', 'true', 'false'; use builtin 'is_bool', 'created_as_number';
use Config; use Config;
my @error = ( my @error = (
@ -82,10 +82,9 @@ sub str($in, $exp) {
} }
str '""', ''; str '""', '';
str '"hello, world"', 'hello, world'; str '"hello, world"', 'hello, world';
str '"\u0000\b"', "\x00\b"; str '"\u0000\u0099\u0234\u1234"', "\x{00}\x{99}\x{234}\x{1234}";
str '"\u0099\u0234\u1234"', "\x{99}\x{234}\x{1234}"; str "\"\x{7f}\x{99}\x{234}\x{1234}\x{12345}\"", "\x{7f}\x{99}\x{234}\x{1234}\x{12345}";
str "\"\x{99}\x{234}\x{1234}\x{12345}\"", "\x{99}\x{234}\x{1234}\x{12345}"; str '"\/\"\\\\\b\t\n\f\r"', "/\"\\\x{08}\x{09}\x{0a}\x{0c}\x{0d}";
str '"\/\"\\\\\t\n\r"', "/\"\\\x{09}\x{0a}\x{0d}";
str '"\uD83D\uDE03"', "\x{1F603}"; str '"\uD83D\uDE03"', "\x{1F603}";
sub num($in, $exp=$in) { sub num($in, $exp=$in) {
@ -187,7 +186,6 @@ for (2000..2100, 4000..4200, 8100..8200, 12200..12300, 16300..16400) {
ok !eval { json_parse '[[[[]]]]', max_depth => 4; 1 }; ok !eval { json_parse '[[[[]]]]', max_depth => 4; 1 };
ok !eval { json_parse '{"":{"":{"":{"":1}}}}', max_depth => 4; 1 }; ok !eval { json_parse '{"":{"":{"":{"":1}}}}', max_depth => 4; 1 };
is json_parse('"\u0000\b\f\u007f"', allow_control => 1), "\x00\x08\x0c\x7f";
# 500 depth # 500 depth
{ {
@ -238,10 +236,4 @@ is json_parse('"\u0000\b\f\u007f"', allow_control => 1), "\x00\x08\x0c\x7f";
ok !eval { json_parse '"string"', max_size => 7 }; ok !eval { json_parse '"string"', max_size => 7 };
} }
# Mutable hashes/arrays
my $d = json_parse('[true,false,null,{"a":true,"b":false,"c":null}]');
is_deeply $d, [true,false,undef,{a => true, b => false, c => undef}];
$_ = 1 for @{$d}[0,1,2], values $d->[3]->%*;
is_deeply $d, [1,1,1,{a => 1, b => 1, c => 1}];
done_testing; done_testing;

View file

@ -14,17 +14,12 @@ Content-Type: text
Content-Disposition: form-data; filename="example.txt"; name=field2 Content-Disposition: form-data; filename="example.txt"; name=field2
value2 value2
--delimiter12345
Content-Type: something; charset = " a b \\ c "
Content-Disposition: form-data; name = "field \" name" ;filename= "月姫.jpg"
--delimiter12345-- --delimiter12345--
_ _
my $l = FU::MultipartFormData->parse('multipart/form-data;boundary="delimiter12345"', $t); my $l = FU::MultipartFormData->parse('multipart/form-data;boundary="delimiter12345"', $t);
is scalar @$l, 3; is scalar @$l, 2;
my $v = $l->[0]; my $v = $l->[0];
is $v->name, 'field1'; is $v->name, 'field1';
@ -49,12 +44,4 @@ is $v->charset, undef;
is $v->length, 6; is $v->length, 6;
is $v->data, 'value2'; is $v->data, 'value2';
$v = $l->[2];
is $v->name, 'field " name';
is $v->filename, "\x{6708}\x{59eb}.jpg";
is $v->mime, 'something';
is $v->charset, ' a b \ c ';
is $v->length, 0;
is $v->data, '';
done_testing; done_testing;

View file

@ -37,7 +37,7 @@ subtest '$conn->exec', sub {
ok !defined $conn->exec(''); ok !defined $conn->exec('');
is $conn->exec('SELECT 1'), 1; is $conn->exec('SELECT 1'), 1;
ok !eval { $conn->sql('SELEXT')->param_types; }; ok !eval { $conn->q('SELEXT')->param_types; };
okerr ERROR => prepare => qr/syntax error/; okerr ERROR => prepare => qr/syntax error/;
is $conn->exec('SET client_encoding=utf8'), undef; is $conn->exec('SET client_encoding=utf8'), undef;
@ -46,7 +46,7 @@ subtest '$conn->exec', sub {
subtest '$st prepare & exec', sub { subtest '$st prepare & exec', sub {
{ {
my $st = $conn->sql('SELECT 1'); my $st = $conn->q('SELECT 1');
is_deeply $st->param_types, []; is_deeply $st->param_types, [];
is_deeply $st->columns, [{ name => '?column?', oid => 23 }]; is_deeply $st->columns, [{ name => '?column?', oid => 23 }];
@ -63,7 +63,7 @@ subtest '$st prepare & exec', sub {
} }
{ {
my $st = $conn->sql("SELECT \$1::int AS a, \$2::char(5) AS \"\x{1F603}\"", 1, 2); my $st = $conn->q("SELECT \$1::int AS a, \$2::char(5) AS \"\x{1F603}\"", 1, 2);
is_deeply $st->param_types, [ 23, 1042 ]; is_deeply $st->param_types, [ 23, 1042 ];
is_deeply $st->columns, [ is_deeply $st->columns, [
{ oid => 23, name => 'a' }, { oid => 23, name => 'a' },
@ -74,28 +74,28 @@ subtest '$st prepare & exec', sub {
is $conn->exec('SELECT 1 FROM pg_prepared_statements'), 0; is $conn->exec('SELECT 1 FROM pg_prepared_statements'), 0;
ok !eval { $conn->sql('SELECT 1', 1)->exec; 1 }; ok !eval { $conn->q('SELECT 1', 1)->exec; 1 };
like $@, qr/bind message supplies 1 parameters, but prepared statement/; like $@, qr/bind message supplies 1 parameters, but prepared statement/;
ok !eval { $conn->sql('SELECT $1')->exec; 1 }; ok !eval { $conn->q('SELECT $1')->exec; 1 };
like $@, qr/bind message supplies 0 parameters, but prepared statement/; like $@, qr/bind message supplies 0 parameters, but prepared statement/;
# prepare + describe won't let us detect empty queries, hmm... # prepare + describe won't let us detect empty queries, hmm...
is_deeply $conn->sql('')->param_types, []; is_deeply $conn->q('')->param_types, [];
is_deeply $conn->sql('')->columns, []; is_deeply $conn->q('')->columns, [];
ok !eval { $conn->sql('')->exec; 1 }; ok !eval { $conn->q('')->exec; 1 };
okerr FATAL => exec => qr/unexpected status code/; okerr FATAL => exec => qr/unexpected status code/;
is $conn->sql('SET client_encoding=utf8')->exec, undef; is $conn->q('SET client_encoding=utf8')->exec, undef;
ok !eval { $conn->sql('select 1; select 2')->exec; 1 }; ok !eval { $conn->q('select 1; select 2')->exec; 1 };
okerr ERROR => exec => qr/cannot insert multiple commands into a prepared statement/; okerr ERROR => exec => qr/cannot insert multiple commands into a prepared statement/;
# Interleaved # Interleaved
{ {
my $x = $conn->sql('SELECT 1 as a'); my $x = $conn->q('SELECT 1 as a');
my $y = $conn->sql('SELECT 2 as b'); my $y = $conn->q('SELECT 2 as b');
is_deeply $x->columns, [ { oid => 23, name => 'a' } ]; is_deeply $x->columns, [ { oid => 23, name => 'a' } ];
is_deeply $y->columns, [ { oid => 23, name => 'b' } ]; is_deeply $y->columns, [ { oid => 23, name => 'b' } ];
is $x->val, 1; is $x->val, 1;
@ -104,137 +104,136 @@ subtest '$st prepare & exec', sub {
}; };
subtest '$st->val', sub { subtest '$st->val', sub {
ok !eval { $conn->sql('SELECT')->val; 1 }; ok !eval { $conn->q('SELECT')->val; 1 };
like $@, qr/on query returning no data/; like $@, qr/on query returning no data/;
ok !eval { $conn->sql('SELECT 1, 2')->val; 1 }; ok !eval { $conn->q('SELECT 1, 2')->val; 1 };
like $@, qr/on query returning more than one column/; like $@, qr/on query returning more than one column/;
ok !eval { $conn->sql('SELECT 1 UNION SELECT 2')->val; 1 }; ok !eval { $conn->q('SELECT 1 UNION SELECT 2')->val; 1 };
like $@, qr/on query returning more than one row/; like $@, qr/on query returning more than one row/;
ok !defined $conn->sql('SELECT 1 WHERE false')->val; ok !defined $conn->q('SELECT 1 WHERE false')->val;
ok !defined $conn->sql('SELECT null')->val; ok !defined $conn->q('SELECT null')->val;
is $conn->sql('SELECT $1::text', "\x{1F603}")->val, "\x{1F603}"; is $conn->q('SELECT $1::text', "\x{1F603}")->val, "\x{1F603}";
}; };
subtest '$st->rowl', sub { subtest '$st->rowl', sub {
ok !eval { $conn->sql('SELECT 1 UNION SELECT 2')->rowl; 1 }; ok !eval { $conn->q('SELECT 1 UNION SELECT 2')->rowl; 1 };
like $@, qr/on query returning more than one row/; like $@, qr/on query returning more than one row/;
ok !eval { $conn->sql('SELEXT')->rowl; 1; }; ok !eval { $conn->q('SELEXT')->rowl; 1; };
is scalar $conn->sql('SELECT')->rowl, 0; is scalar $conn->q('SELECT')->rowl, 0;
is scalar $conn->sql('SELECT 1, 2')->rowl, 2; is scalar $conn->q('SELECT 1, 2')->rowl, 2;
is_deeply [$conn->sql('SELECT')->rowl], []; is_deeply [$conn->q('SELECT')->rowl], [];
is_deeply [$conn->sql('SELECT 1, null')->rowl], [1, undef]; is_deeply [$conn->q('SELECT 1, null')->rowl], [1, undef];
is_deeply [$conn->sql('SELECT 1, $1', undef)->rowl], [1, undef]; is_deeply [$conn->q('SELECT 1, $1', undef)->rowl], [1, undef];
is_deeply [$conn->sql('SELECT 1, $1::int', undef)->text_params(0)->rowl], [1, undef]; is_deeply [$conn->q('SELECT 1, $1::int', undef)->text_params(0)->rowl], [1, undef];
is_deeply [$conn->sql('SELECT 1 WHERE false')->rowl], []; is_deeply [$conn->q('SELECT 1 WHERE false')->rowl], [];
}; };
subtest '$st->rowa', sub { subtest '$st->rowa', sub {
ok !eval { $conn->sql('SELECT 1 UNION SELECT 2')->rowa; 1 }; ok !eval { $conn->q('SELECT 1 UNION SELECT 2')->rowa; 1 };
like $@, qr/on query returning more than one row/; like $@, qr/on query returning more than one row/;
ok !eval { $conn->sql('SELEXT')->rowa; 1; }; ok !eval { $conn->q('SELEXT')->rowa; 1; };
is $conn->sql('SELECT 1 WHERE false')->rowa, undef; is $conn->q('SELECT 1 WHERE false')->rowa, undef;
is_deeply $conn->sql('SELECT')->rowa, []; is_deeply $conn->q('SELECT')->rowa, [];
is_deeply $conn->sql('SELECT 1, 2')->rowa, [1, 2]; is_deeply $conn->q('SELECT 1, 2')->rowa, [1, 2];
is_deeply $conn->sql('SELECT 1, null')->rowa, [1, undef]; is_deeply $conn->q('SELECT 1, null')->rowa, [1, undef];
is_deeply $conn->sql('SELECT 1, $1', undef)->rowa, [1, undef]; is_deeply $conn->q('SELECT 1, $1', undef)->rowa, [1, undef];
is_deeply $conn->sql('SELECT 1, $1::int', undef)->text_params(0)->rowa, [1, undef]; is_deeply $conn->q('SELECT 1, $1::int', undef)->text_params(0)->rowa, [1, undef];
}; };
subtest '$st->rowh', sub { subtest '$st->rowh', sub {
ok !eval { $conn->sql('SELECT 1 UNION SELECT 2')->rowh; 1 }; ok !eval { $conn->q('SELECT 1 UNION SELECT 2')->rowh; 1 };
like $@, qr/on query returning more than one row/; like $@, qr/on query returning more than one row/;
ok !eval { $conn->sql('SELECT 1 as a, 2 as a')->rowh; 1 }; ok !eval { $conn->q('SELECT 1 as a, 2 as a')->rowh; 1 };
like $@, qr/Query returns multiple columns with the same name/; like $@, qr/Query returns multiple columns with the same name/;
is $conn->sql('SELECT 1 WHERE false')->rowh, undef; is $conn->q('SELECT 1 WHERE false')->rowh, undef;
is_deeply $conn->sql('SELECT')->rowh, {}; is_deeply $conn->q('SELECT')->rowh, {};
is_deeply $conn->sql('SELECT 1 as a, 2 as b')->rowh, {a => 1, b => 2}; is_deeply $conn->q('SELECT 1 as a, 2 as b')->rowh, {a => 1, b => 2};
is_deeply $conn->sql('SELECT 1 as a, null as b')->rowh, {a => 1, b => undef}; is_deeply $conn->q('SELECT 1 as a, null as b')->rowh, {a => 1, b => undef};
is_deeply $conn->sql('SELECT 1 as a, $1::int as b', undef)->rowh, {a => 1, b => undef}; is_deeply $conn->q('SELECT 1 as a, $1::int as b', undef)->rowh, {a => 1, b => undef};
}; };
subtest '$st->alla', sub { subtest '$st->alla', sub {
is_deeply $conn->sql('SELECT 1 WHERE false')->alla, []; is_deeply $conn->q('SELECT 1 WHERE false')->alla, [];
is_deeply $conn->sql('SELECT')->alla, [[]]; is_deeply $conn->q('SELECT')->alla, [[]];
is_deeply $conn->sql('SELECT 1')->alla, [[1]]; is_deeply $conn->q('SELECT 1')->alla, [[1]];
is_deeply $conn->sql('SELECT 1, null UNION ALL SELECT NULL, 2')->alla, [[1,undef],[undef,2]]; is_deeply $conn->q('SELECT 1, null UNION ALL SELECT NULL, 2')->alla, [[1,undef],[undef,2]];
}; };
subtest '$st->allh', sub { subtest '$st->allh', sub {
ok !eval { $conn->sql('SELECT 1 as a, 2 as a')->allh; 1 }; ok !eval { $conn->q('SELECT 1 as a, 2 as a')->allh; 1 };
like $@, qr/Query returns multiple columns with the same name/; like $@, qr/Query returns multiple columns with the same name/;
is_deeply $conn->sql('SELECT 1 WHERE false')->allh, []; is_deeply $conn->q('SELECT 1 WHERE false')->allh, [];
is_deeply $conn->sql('SELECT')->allh, [{}]; is_deeply $conn->q('SELECT')->allh, [{}];
is_deeply $conn->sql('SELECT 1 a')->allh, [{a=>1}]; is_deeply $conn->q('SELECT 1 a')->allh, [{a=>1}];
is_deeply $conn->sql('SELECT 1 a, null b UNION ALL SELECT NULL, 2')->allh, [{a=>1,b=>undef},{a=>undef,b=>2}]; is_deeply $conn->q('SELECT 1 a, null b UNION ALL SELECT NULL, 2')->allh, [{a=>1,b=>undef},{a=>undef,b=>2}];
}; };
subtest '$st->flat', sub { subtest '$st->flat', sub {
is_deeply $conn->sql('SELECT 1 WHERE false')->flat, []; is_deeply $conn->q('SELECT 1 WHERE false')->flat, [];
is_deeply $conn->sql('SELECT')->flat, []; is_deeply $conn->q('SELECT')->flat, [];
is_deeply $conn->sql('SELECT 1')->flat, [1]; is_deeply $conn->q('SELECT 1')->flat, [1];
is_deeply $conn->sql('SELECT 1, null UNION ALL SELECT NULL, 2')->flat, [1,undef,undef,2]; is_deeply $conn->q('SELECT 1, null UNION ALL SELECT NULL, 2')->flat, [1,undef,undef,2];
}; };
subtest '$st->kvv', sub { subtest '$st->kvv', sub {
ok !eval { $conn->sql('SELECT')->kvv; 1; }; ok !eval { $conn->q('SELECT')->kvv; 1; };
like $@, qr/returning no data/; like $@, qr/returning no data/;
ok !eval { $conn->sql('SELECT 1, 2, 3')->kvv; 1; }; ok !eval { $conn->q('SELECT 1, 2, 3')->kvv; 1; };
like $@, qr/returning more than two columns/; like $@, qr/returning more than two columns/;
ok !eval { $conn->sql('SELECT 1 UNION ALL SELECT 1')->kvv; 1; }; ok !eval { $conn->q('SELECT 1 UNION ALL SELECT 1')->kvv; 1; };
like $@, qr/is duplicated/; like $@, qr/is duplicated/;
is_deeply $conn->sql('SELECT 1 WHERE false')->kvv, {}; is_deeply $conn->q('SELECT 1 WHERE false')->kvv, {};
is_deeply $conn->sql('SELECT 1')->kvv, {1=>1}; is_deeply $conn->q('SELECT 1')->kvv, {1=>1};
is_deeply $conn->sql('SELECT 1, null UNION ALL SELECT 3, 2')->kvv, {1=>undef,3=>2}; is_deeply $conn->q('SELECT 1, null UNION ALL SELECT 3, 2')->kvv, {1=>undef,3=>2};
$conn->sql('SELECT 1')->kvv->{1} = 0;
}; };
subtest '$st->kva', sub { subtest '$st->kva', sub {
ok !eval { $conn->sql('SELECT')->kva; 1; }; ok !eval { $conn->q('SELECT')->kva; 1; };
like $@, qr/returning no data/; like $@, qr/returning no data/;
ok !eval { $conn->sql('SELECT 1 UNION ALL SELECT 1')->kva; 1; }; ok !eval { $conn->q('SELECT 1 UNION ALL SELECT 1')->kva; 1; };
like $@, qr/is duplicated/; like $@, qr/is duplicated/;
is_deeply $conn->sql('SELECT 1 WHERE false')->kva, {}; is_deeply $conn->q('SELECT 1 WHERE false')->kva, {};
is_deeply $conn->sql('SELECT 1')->kva, {1=>[]}; is_deeply $conn->q('SELECT 1')->kva, {1=>[]};
is_deeply $conn->sql("SELECT 1, null, 'hi' UNION ALL SELECT 3, 2, 'ok'")->kva, is_deeply $conn->q("SELECT 1, null, 'hi' UNION ALL SELECT 3, 2, 'ok'")->kva,
{1=>[undef,'hi'], 3=>[2, 'ok']}; {1=>[undef,'hi'], 3=>[2, 'ok']};
}; };
subtest '$st->kvh', sub { subtest '$st->kvh', sub {
ok !eval { $conn->sql('SELECT')->kvh; 1; }; ok !eval { $conn->q('SELECT')->kvh; 1; };
like $@, qr/returning no data/; like $@, qr/returning no data/;
ok !eval { $conn->sql('SELECT 1 UNION ALL SELECT 1')->kvh; 1; }; ok !eval { $conn->q('SELECT 1 UNION ALL SELECT 1')->kvh; 1; };
like $@, qr/is duplicated/; like $@, qr/is duplicated/;
ok !eval { $conn->sql('SELECT 1, 2, 3')->kvh; 1; }; ok !eval { $conn->q('SELECT 1, 2, 3')->kvh; 1; };
like $@, qr/Query returns multiple columns with the same name/; like $@, qr/Query returns multiple columns with the same name/;
is_deeply $conn->sql('SELECT 1 WHERE false')->kvh, {}; is_deeply $conn->q('SELECT 1 WHERE false')->kvh, {};
is_deeply $conn->sql('SELECT 1')->kvh, {1=>{}}; is_deeply $conn->q('SELECT 1')->kvh, {1=>{}};
is_deeply $conn->sql("SELECT 1 as a , null as a, 'hi' as b UNION ALL SELECT 3, 2, 'ok'")->kvh, is_deeply $conn->q("SELECT 1 as a , null as a, 'hi' as b UNION ALL SELECT 3, 2, 'ok'")->kvh,
{1=>{a=>undef,b=>'hi'}, 3=>{a=>2,b=>'ok'}}; {1=>{a=>undef,b=>'hi'}, 3=>{a=>2,b=>'ok'}};
}; };
subtest 'txn', sub { subtest 'txn', sub {
$conn->exec('CREATE TEMPORARY TABLE fupg_tst (id int)'); $conn->exec('CREATE TEMPORARY TABLE fupg_tst (id int)');
$conn->txn->exec('INSERT INTO fupg_tst VALUES (1)'); # rolled back $conn->txn->exec('INSERT INTO fupg_tst VALUES (1)'); # rolled back
is $conn->sql('SELECT COUNT(*) FROM fupg_tst')->val, 0; is $conn->q('SELECT COUNT(*) FROM fupg_tst')->val, 0;
my $st = $conn->sql('SELECT COUNT(*) FROM fupg_tst'); my $st = $conn->q('SELECT COUNT(*) FROM fupg_tst');
my $sst; my $sst;
{ {
my $txn = $conn->txn; my $txn = $conn->txn;
@ -246,13 +245,13 @@ subtest 'txn', sub {
ok !eval { $conn->exec('SELECT 1'); 1 }; ok !eval { $conn->exec('SELECT 1'); 1 };
like $@, qr/Invalid operation on the top-level connection/; like $@, qr/Invalid operation on the top-level connection/;
ok !eval { $conn->sql('SELECT 1'); 1 }; ok !eval { $conn->q('SELECT 1'); 1 };
like $@, qr/Invalid operation on the top-level connection/; like $@, qr/Invalid operation on the top-level connection/;
ok !eval { $conn->txn; 1 }; ok !eval { $conn->txn; 1 };
like $@, qr/Invalid operation on the top-level connection/; like $@, qr/Invalid operation on the top-level connection/;
$txn->exec('INSERT INTO fupg_tst VALUES (1)'); $txn->exec('INSERT INTO fupg_tst VALUES (1)');
$sst = $txn->sql('SELECT 1'); $sst = $txn->q('SELECT 1');
is $conn->status, 'txn_idle'; is $conn->status, 'txn_idle';
is $txn->status, 'idle'; is $txn->status, 'idle';
@ -268,7 +267,7 @@ subtest 'txn', sub {
like $@, qr/Invalid operation on a transaction that has already been marked as done/; like $@, qr/Invalid operation on a transaction that has already been marked as done/;
ok !eval { $txn->exec('select 1'); 1 }; ok !eval { $txn->exec('select 1'); 1 };
like $@, qr/Invalid operation on a transaction that has already been marked as done/; like $@, qr/Invalid operation on a transaction that has already been marked as done/;
ok !eval { $txn->sql('select 1'); 1 }; ok !eval { $txn->q('select 1'); 1 };
like $@, qr/Invalid operation on a transaction that has already been marked as done/; like $@, qr/Invalid operation on a transaction that has already been marked as done/;
ok !eval { $conn->exec('SELECT 1'); 1 }; ok !eval { $conn->exec('SELECT 1'); 1 };
@ -295,7 +294,7 @@ subtest 'txn', sub {
{ {
my $txn = $conn->txn; my $txn = $conn->txn;
my $st = $txn->sql('SELECT count(*) FROM fupg_tst WHERE id = 2'); my $st = $txn->q('SELECT count(*) FROM fupg_tst WHERE id = 2');
{ {
my $sub = $txn->txn; my $sub = $txn->txn;
is $conn->status, 'txn_idle'; is $conn->status, 'txn_idle';
@ -316,7 +315,7 @@ subtest 'txn', sub {
is $txn->status, 'idle'; is $txn->status, 'idle';
is $st->val, 0; is $st->val, 0;
$st = $txn->sql('SELECT count(*) FROM fupg_tst WHERE id = 2'); $st = $txn->q('SELECT count(*) FROM fupg_tst WHERE id = 2');
{ {
my $sub = $txn->txn; my $sub = $txn->txn;
$sub->exec('INSERT INTO fupg_tst VALUES (2)'); $sub->exec('INSERT INTO fupg_tst VALUES (2)');
@ -339,19 +338,19 @@ subtest 'txn', sub {
$sub->commit; $sub->commit;
} }
# We didn't commit $txn, so $sub got aborted as well # We didn't commit $txn, so $sub got aborted as well
is $conn->sql('SELECT count(*) FROM fupg_tst WHERE id = 3')->val, 0; is $conn->q('SELECT count(*) FROM fupg_tst WHERE id = 3')->val, 0;
}; };
{ {
local $_ = 'x'; local $_ = 'x';
my $st = $conn->sql('SELECT $1', $_); my $st = $conn->q('SELECT $1', $_);
$_ = 'y'; $_ = 'y';
is $st->val, 'x', 'shallow copy'; is $st->val, 'x', 'shallow copy';
} }
{ {
my $x = [1,2]; my $x = [1,2];
my $st = $conn->sql('SELECT $1::int[]', $x)->text(0); my $st = $conn->q('SELECT $1::int[]', $x)->text(0);
$x->[1] = 3; $x->[1] = 3;
is_deeply $st->val, [1,3], 'not deep copy'; is_deeply $st->val, [1,3], 'not deep copy';
} }
@ -360,7 +359,7 @@ subtest 'txn', sub {
{ {
# Exact format returned by escape_literal() can differ between Postgres versions and configurations. # Exact format returned by escape_literal() can differ between Postgres versions and configurations.
my $x = q{"' \" \\}; my $x = q{"' \" \\};
is $conn->sql('SELECT '.$conn->escape_literal($x))->val, $x; is $conn->q('SELECT '.$conn->escape_literal($x))->val, $x;
# Format can also change, but unsure how to test this otherwise. # Format can also change, but unsure how to test this otherwise.
is $conn->escape_identifier('hel\l"o'), '"hel\l""o"'; is $conn->escape_identifier('hel\l"o'), '"hel\l""o"';
@ -370,44 +369,44 @@ subtest 'Prepared statement cache', sub {
$conn->cache_size(2); $conn->cache_size(2);
my $txn = $conn->txn; my $txn = $conn->txn;
$txn->cache; $txn->cache;
my $numexec = sub($sql) { my sub numexec($sql) {
$txn->sql('SELECT generic_plans + custom_plans FROM pg_prepared_statements WHERE statement = $1', $sql)->cache(0)->val $txn->q('SELECT generic_plans + custom_plans FROM pg_prepared_statements WHERE statement = $1', $sql)->cache(0)->val
}; }
is $txn->sql('SELECT 1')->val, 1; is $txn->q('SELECT 1')->val, 1;
is $numexec->('SELECT 1'), 1; is numexec('SELECT 1'), 1;
my $sql = 'SELECT $1::int as a, $2::text as b'; my $sql = 'SELECT $1::int as a, $2::text as b';
ok !defined $numexec->($sql); ok !defined numexec($sql);
my $params = $txn->sql($sql)->param_types; my $params = $txn->q($sql)->param_types;
is_deeply $params, [23, 25]; is_deeply $params, [23, 25];
is $numexec->($sql), 0; is numexec($sql), 0;
my $cparams = $txn->sql($sql)->param_types; my $cparams = $txn->q($sql)->param_types;
is_deeply $cparams, $params; is_deeply $cparams, $params;
my $cols = $txn->sql($sql)->columns; my $cols = $txn->q($sql)->columns;
is_deeply $cols, [{ name => 'a', oid => 23 }, { name => 'b', oid => 25 }]; is_deeply $cols, [{ name => 'a', oid => 23 }, { name => 'b', oid => 25 }];
my $ccols = $txn->sql($sql)->columns; my $ccols = $txn->q($sql)->columns;
is_deeply $ccols, $cols; is_deeply $ccols, $cols;
$txn->sql($sql, 0, '')->exec; $txn->q($sql, 0, '')->exec;
is $numexec->($sql), 1; is numexec($sql), 1;
$txn->sql($sql, 0, '')->exec; $txn->q($sql, 0, '')->exec;
is $numexec->($sql), 2; is numexec($sql), 2;
is $numexec->('SELECT 1'), 1; is numexec('SELECT 1'), 1;
$txn->sql('SELECT 2')->exec; $txn->q('SELECT 2')->exec;
ok !defined $numexec->('SELECT 1'); ok !defined numexec('SELECT 1');
is $numexec->('SELECT 2'), 1; is numexec('SELECT 2'), 1;
$conn->cache_size(1); $conn->cache_size(1);
ok !defined $numexec->('SELECT 1'); ok !defined numexec('SELECT 1');
ok !defined $numexec->($sql); ok !defined numexec($sql);
is $numexec->('SELECT 2'), 1; is numexec('SELECT 2'), 1;
$conn->cache_size(0); $conn->cache_size(0);
ok !defined $numexec->($sql); ok !defined numexec($sql);
ok !defined $numexec->('SELECT 2'); ok !defined numexec('SELECT 2');
}; };
@ -415,7 +414,7 @@ subtest 'Tracing', sub {
my @log; my @log;
$conn->query_trace(sub($st) { push @log, $st }); $conn->query_trace(sub($st) { push @log, $st });
is_deeply $conn->sql('SELECT 1 AS a, $1 AS b', 123)->text_params(0)->rowa, [ 1, 123 ]; is_deeply $conn->q('SELECT 1 AS a, $1 AS b', 123)->text_params(0)->rowa, [ 1, 123 ];
is scalar @log, 1; is scalar @log, 1;
my $st = shift @log; my $st = shift @log;
is ref $st, 'FU::Pg::st'; is ref $st, 'FU::Pg::st';
@ -451,7 +450,7 @@ subtest 'Tracing', sub {
}; };
{ {
my $st = $conn->sql("SELECT 1"); my $st = $conn->q("SELECT 1");
undef $conn; # statement keeps the connection alive undef $conn; # statement keeps the connection alive
is $st->val, 1; is $st->val, 1;
} }

View file

@ -82,9 +82,9 @@ is $conn->status, 'idle';
$c->write($bin); $c->write($bin);
$c->close; $c->close;
is $txn->sql('SELECT sum(v) FROM fupg_copy_test')->val, 1+1+2+2+3+3; is $txn->q('SELECT sum(v) FROM fupg_copy_test')->val, 1+1+2+2+3+3;
$txn->rollback; $txn->rollback;
} }
is $conn->sql('SELECT sum(v) FROM fupg_copy_test')->val, 1+2+3; is $conn->q('SELECT sum(v) FROM fupg_copy_test')->val, 1+2+3;
done_testing; done_testing;

View file

@ -10,31 +10,31 @@ my $conn = FU::Pg->connect($ENV{FU_TEST_DB});
$conn->_debug_trace(0); $conn->_debug_trace(0);
is_deeply $conn->SQL('SELECT', 1, '::int')->param_types, [23]; is_deeply $conn->Q('SELECT', 1, '::int')->param_types, [23];
is_deeply $conn->SQL('SELECT 1', IN([1,2,3]))->param_types, [1007]; is_deeply $conn->Q('SELECT 1', IN([1,2,3]))->param_types, [1007];
is $conn->SQL('SELECT 1', IN([1,2,3]))->val, 1; is $conn->Q('SELECT 1', IN([1,2,3]))->val, 1;
ok !eval { $conn->sql('SELECT $1::aclitem', '')->exec; 1 }; ok !eval { $conn->q('SELECT $1::aclitem', '')->exec; 1 };
like $@, qr/Unable to send type/; like $@, qr/Unable to send type/;
subtest 'type overrides', sub { subtest 'type overrides', sub {
$conn->set_type(int4 => recv => 'bytea'); $conn->set_type(int4 => recv => 'bytea');
is $conn->sql('SELECT 5::int4')->val, "\0\0\0\5"; is $conn->q('SELECT 5::int4')->val, "\0\0\0\5";
is_deeply $conn->sql('SELECT ARRAY[5::int4]')->val, ["\0\0\0\5"]; is_deeply $conn->q('SELECT ARRAY[5::int4]')->val, ["\0\0\0\5"];
$conn->set_type(int4 => send => 'bytea'); $conn->set_type(int4 => send => 'bytea');
is $conn->sql('SELECT $1::int4', "\0\0\0\5")->val, 5; is $conn->q('SELECT $1::int4', "\0\0\0\5")->val, 5;
is_deeply $conn->sql('SELECT $1::int4[]', ["\0\0\0\5"])->val, [5]; is_deeply $conn->q('SELECT $1::int4[]', ["\0\0\0\5"])->val, [5];
$conn->set_type(int4 => 'int2'); $conn->set_type(int4 => 'int2');
ok !eval { $conn->sql('SELECT 5::int4')->val }; ok !eval { $conn->q('SELECT 5::int4')->val };
like $@, qr/Error parsing value/; like $@, qr/Error parsing value/;
ok !eval { $conn->sql('SELECT $1::int4', 5)->val }; ok !eval { $conn->q('SELECT $1::int4', 5)->val };
like $@, qr/insufficient data left in message/; like $@, qr/insufficient data left in message/;
$conn->set_type(int4 => undef); $conn->set_type(int4 => undef);
is $conn->sql('SELECT 5::int4')->val, 5; is $conn->q('SELECT 5::int4')->val, 5;
ok !eval { $conn->set_type(int4 => 1007); }; ok !eval { $conn->set_type(int4 => 1007); };
like $@, qr/Cannot set a type to array/; like $@, qr/Cannot set a type to array/;
@ -46,23 +46,23 @@ subtest 'type overrides', sub {
subtest 'type override callback', sub { subtest 'type override callback', sub {
$conn->set_type(text => recv => sub { length $_[0] }); $conn->set_type(text => recv => sub { length $_[0] });
is $conn->sql('SELECT $1', 'a')->val, 1; is $conn->q('SELECT $1', 'a')->val, 1;
is $conn->sql('SELECT $1', 'ab')->val, 2; is $conn->q('SELECT $1', 'ab')->val, 2;
is $conn->sql('SELECT $1', 'abc')->val, 3; is $conn->q('SELECT $1', 'abc')->val, 3;
is $conn->sql('SELECT $1', 'abcd')->val, 4; is $conn->q('SELECT $1', 'abcd')->val, 4;
$conn->set_type(text => send => sub { 'l'.length $_[0] }); $conn->set_type(text => send => sub { 'l'.length $_[0] });
is $conn->sql('SELECT $1', 'a')->val, 'l1'; is $conn->q('SELECT $1', 'a')->val, 'l1';
is $conn->sql('SELECT $1', 'ab')->val, 'l2'; is $conn->q('SELECT $1', 'ab')->val, 'l2';
is $conn->sql('SELECT $1', 'abc')->val, 'l3'; is $conn->q('SELECT $1', 'abc')->val, 'l3';
is $conn->sql('SELECT $1', 'abcd')->val, 'l4'; is $conn->q('SELECT $1', 'abcd')->val, 'l4';
}; };
subtest 'custom types', sub { subtest 'custom types', sub {
my $txn = $conn->txn; my $txn = $conn->txn;
is $txn->SQL('SELECT 1', IN([1,2,3]))->val, 1; is $txn->Q('SELECT 1', IN([1,2,3]))->val, 1;
$txn->exec(<<~_); $txn->exec(<<~_);
CREATE TYPE fupg_test_enum AS ENUM('aa', 'bb', 'ccccccccccccccccccc'); CREATE TYPE fupg_test_enum AS ENUM('aa', 'bb', 'ccccccccccccccccccc');
@ -73,21 +73,21 @@ subtest 'custom types', sub {
domain fupg_test_domain domain fupg_test_domain
); );
_ _
is $txn->sql("SELECT 'aa'::fupg_test_enum")->val, 'aa'; is $txn->q("SELECT 'aa'::fupg_test_enum")->val, 'aa';
is $txn->sql('SELECT $1::fupg_test_enum', 'ccccccccccccccccccc')->val, 'ccccccccccccccccccc'; is $txn->q('SELECT $1::fupg_test_enum', 'ccccccccccccccccccc')->val, 'ccccccccccccccccccc';
is_deeply $txn->sql("SELECT '{aa,bb,null}'::fupg_test_enum[]")->val, ['aa','bb',undef]; is_deeply $txn->q("SELECT '{aa,bb,null}'::fupg_test_enum[]")->val, ['aa','bb',undef];
is $txn->sql('SELECT $1::fupg_test_enum[]', ['aa','bb',undef])->text_results->val, '{aa,bb,NULL}'; is $txn->q('SELECT $1::fupg_test_enum[]', ['aa','bb',undef])->text_results->val, '{aa,bb,NULL}';
is $txn->sql("SELECT 'aa'::fupg_test_domain")->val, 'aa'; is $txn->q("SELECT 'aa'::fupg_test_domain")->val, 'aa';
is $txn->sql('SELECT $1::fupg_test_domain', 'bb')->val, 'bb'; is $txn->q('SELECT $1::fupg_test_domain', 'bb')->val, 'bb';
is_deeply $txn->sql("SELECT '{aa,bb,null}'::fupg_test_domain[]")->val, ['aa','bb',undef]; is_deeply $txn->q("SELECT '{aa,bb,null}'::fupg_test_domain[]")->val, ['aa','bb',undef];
is $txn->sql('SELECT $1::fupg_test_domain[]', ['aa','bb',undef])->text_results->val, '{aa,bb,NULL}'; is $txn->q('SELECT $1::fupg_test_domain[]', ['aa','bb',undef])->text_results->val, '{aa,bb,NULL}';
my $val = { a => undef, aenum => ['aa','bb'], domain => 'aa' }; my $val = { a => undef, aenum => ['aa','bb'], domain => 'aa' };
is_deeply $txn->sql("SELECT '(,\"{aa,bb}\",aa)'::fupg_test_record")->val, $val; is_deeply $txn->q("SELECT '(,\"{aa,bb}\",aa)'::fupg_test_record")->val, $val;
is $txn->sql('SELECT $1::fupg_test_record', $val)->text_results->val, '(,"{aa,bb}",aa)'; is $txn->q('SELECT $1::fupg_test_record', $val)->text_results->val, '(,"{aa,bb}",aa)';
$txn->exec(<<~_); $txn->exec(<<~_);
CREATE TEMPORARY TABLE fupg_test_table ( CREATE TEMPORARY TABLE fupg_test_table (
@ -96,17 +96,12 @@ subtest 'custom types', sub {
); );
_ _
$val = $txn->sql(q{SELECT '{"(\"(2,{},bb)\",)","(\"(,,)\",bb)"}'::fupg_test_table[]})->val; is_deeply $txn->q(q{SELECT '{"(\"(2,{},bb)\",)","(\"(,,)\",bb)"}'::fupg_test_table[]})->val, [
is_deeply $val, [
{ rec => { a => 2, aenum => [], domain => 'bb' }, dom => undef }, { rec => { a => 2, aenum => [], domain => 'bb' }, dom => undef },
{ rec => { a => undef, aenum => undef, domain => undef }, dom => 'bb' }, { rec => { a => undef, aenum => undef, domain => undef }, dom => 'bb' },
]; ];
$val->[0] = 0;
$val->[1]{rec}{a} = 0;
$val->[1]{rec} = 0;
$val->[1]{dom} = 0;
is $txn->sql('SELECT $1::fupg_test_table[]', [ is $txn->q('SELECT $1::fupg_test_table[]', [
{ rec => { a => 2, aenum => [], domain => 'bb' }, dom => undef }, { rec => { a => 2, aenum => [], domain => 'bb' }, dom => undef },
{ rec => {}, dom => 'bb', extra => 1 }, { rec => {}, dom => 'bb', extra => 1 },
])->text_results->val, '{"(\"(2,{},bb)\",)","(\"(,,)\",bb)"}'; ])->text_results->val, '{"(\"(2,{},bb)\",)","(\"(,,)\",bb)"}';
@ -114,46 +109,38 @@ subtest 'custom types', sub {
# Wonky Postgres behavior: selecting a domain directly actually returns the # Wonky Postgres behavior: selecting a domain directly actually returns the
# underlying type, but going through an array does work. # underlying type, but going through an array does work.
$conn->set_type(fupg_test_domain => 21); $conn->set_type(fupg_test_domain => 21);
is_deeply $txn->sql("SELECT ARRAY['aa'::fupg_test_domain]")->val, [0x6161]; is_deeply $txn->q("SELECT ARRAY['aa'::fupg_test_domain]")->val, [0x6161];
# Bind param type doesn't match column type, argh. # Bind param type doesn't match column type, argh.
is $txn->sql('SELECT $1::fupg_test_domain', 0x6161)->val, 'aa'; is $txn->q('SELECT $1::fupg_test_domain', 0x6161)->val, 'aa';
# Same for selecting from a table :( # Same for selecting from a table :(
$txn->exec("INSERT INTO fupg_test_table VALUES (NULL, 'bb')"); $txn->exec("INSERT INTO fupg_test_table VALUES (NULL, 'bb')");
is $txn->sql("SELECT dom FROM fupg_test_table")->val, 'bb'; is $txn->q("SELECT dom FROM fupg_test_table")->val, 'bb';
$conn->set_type(fupg_test_enum => 21); $conn->set_type(fupg_test_enum => 21);
is $txn->sql("SELECT dom FROM fupg_test_table")->val, 0x6262; is $txn->q("SELECT dom FROM fupg_test_table")->val, 0x6262;
};
subtest 'identifier quoting', sub {
my $txn = $conn->txn;
$txn->exec('CREATE TEMPORARY TABLE fupg_test_tbl ("desc" int, ok int, "hello world" int)');
ok $txn->SQL('INSERT INTO fupg_test_tbl', VALUES {desc => 5, ok => 10, 'hello world', 15})->exec;
is $txn->SQL('SELECT', IDENT 'hello world', 'FROM fupg_test_tbl')->val, 15;
}; };
subtest 'vndbid', sub { subtest 'vndbid', sub {
plan skip_all => 'type not loaded in the database' if !$conn->sql("SELECT 1 FROM pg_type WHERE typname = 'vndbtag'")->val; plan skip_all => 'type not loaded in the database' if !$conn->q("SELECT 1 FROM pg_type WHERE typname = 'vndbtag'")->val;
for my $t (qw/a zz xxx/) { for my $t (qw/a zz xxx/) {
is $conn->sql('SELECT $1::vndbtag', $t)->val, $t; is $conn->q('SELECT $1::vndbtag', $t)->val, $t;
is $conn->sql('SELECT $1::vndbtag', $t)->text_params->val, $t; is $conn->q('SELECT $1::vndbtag', $t)->text_params->val, $t;
is $conn->sql('SELECT $1::vndbtag', $t)->text_results->val, $t; is $conn->q('SELECT $1::vndbtag', $t)->text_results->val, $t;
} }
ok !eval { $conn->sql('SELECT $1::vndbtag', '')->val }; ok !eval { $conn->q('SELECT $1::vndbtag', '')->val };
ok !eval { $conn->sql('SELECT $1::vndbtag', 'abcd')->val }; ok !eval { $conn->q('SELECT $1::vndbtag', 'abcd')->val };
for my $t (qw/a123 zz992883231 xxx18388123/) { for my $t (qw/a123 zz992883231 xxx18388123/) {
is $conn->sql('SELECT $1::vndbid', $t)->val, $t; is $conn->q('SELECT $1::vndbid', $t)->val, $t;
is $conn->sql('SELECT $1::vndbid', $t)->text_params->val, $t; is $conn->q('SELECT $1::vndbid', $t)->text_params->val, $t;
is $conn->sql('SELECT $1::vndbid', $t)->text_results->val, $t; is $conn->q('SELECT $1::vndbid', $t)->text_results->val, $t;
} }
ok !eval { $conn->sql('SELECT $1::vndbid', '')->val }; ok !eval { $conn->q('SELECT $1::vndbid', '')->val };
ok !eval { $conn->sql('SELECT $1::vndbid', 'ab')->val }; ok !eval { $conn->q('SELECT $1::vndbid', 'ab')->val };
ok !eval { $conn->sql('SELECT $1::vndbid', 'ab1219229999999999')->val }; ok !eval { $conn->q('SELECT $1::vndbid', 'ab1219229999999999')->val };
}; };
done_testing; done_testing;

View file

@ -19,59 +19,32 @@ sub v($type, $p_in, @args) {
my $s_out = @args > 2 && defined $args[2] ? $args[2] : $s_in; my $s_out = @args > 2 && defined $args[2] ? $args[2] : $s_in;
my $test = "$type $s_in" =~ s/\n/\\n/rg; my $test = "$type $s_in" =~ s/\n/\\n/rg;
my $oid;
utf8::encode($test); utf8::encode($test);
{ {
my $st = $conn->sql("SELECT \$1::$type", $s_in)->text_params; my $res = $conn->q("SELECT \$1::$type", $s_in)->text_params->val;
$oid = $st->param_types->[0];
my $array = $st->flat;
my $res = $array->[0];
ok is_bool($res), "$test is bool" if $type eq 'bool'; ok is_bool($res), "$test is bool" if $type eq 'bool';
ok created_as_number($res), "$test is number" if $type =~ /^(int|float)\d/; ok created_as_number($res), "$test is number" if $type =~ /^(int|float)\d/;
is_deeply $res, $p_out, "$test text->bin"; is_deeply $res, $p_out, "$test text->bin";
$array->[0] = 0; # Must be writable
} }
{ {
my $res = $conn->sql("SELECT \$1::$type", $p_in)->text_results->val; my $res = $conn->q("SELECT \$1::$type", $p_in)->text_results->val;
is $res, $s_out, "$test bin->text"; is $res, $s_out, "$test bin->text";
} }
{ {
my $res = $conn->sql("SELECT \$1::$type", $p_in)->val; my $res = $conn->q("SELECT \$1::$type", $p_in)->val;
is_deeply $res, $p_out, "$test bin->bin"; is_deeply $res, $p_out, "$test bin->bin";
} }
{
my $bin = $conn->perl2bin($oid, $p_in);
ok defined $bin;
if ($type !~ /\(/) {
is_deeply $conn->bin2perl($oid, $bin), $p_out;
is $conn->bin2text($oid, $bin), $s_out;
is $conn->text2bin($oid, $s_out), $bin if $type ne 'jsonb'; # jsonb pretty-prints for some reason
}
}
} }
sub f($type, $p_in) { sub f($type, $p_in) {
my $test = "$type $p_in" =~ s/\n/\\n/rg; my $test = "$type $p_in" =~ s/\n/\\n/rg;
utf8::encode($test); utf8::encode($test);
ok !eval { $conn->sql("SELECT \$1::$type", $p_in)->val; 1 }, "$test fail"; ok !eval { $conn->q("SELECT \$1::$type", $p_in)->val; 1 }, "$test fail";
} }
{ # void ok !defined $conn->q('SELECT pg_sleep(0)')->val; # void
my $array = $conn->sql('SELECT pg_sleep(0)')->flat;
ok !defined $array->[0];
$array->[0] = 0;
}
v bool => true, true, 1, 't'; v bool => true, undef, 1, 't';
v bool => \1, true, 1, 't'; v bool => false, undef, 0, 'f';
v bool => 1, true, 1, 't';
v bool => 't', true, 1, 't';
v bool => false, false, 0, 'f';
v bool => \0, false, 0, 'f';
v bool => 0, false, 0, 'f';
v bool => '', false, 0, 'f';
v bool => 'f', false, 0, 'f';
f bool => 2;
f bool => [];
v int2 => $_ for (1, -1, -32768, 32767, '12345', -12345, 123.0); v int2 => $_ for (1, -1, -32768, 32767, '12345', -12345, 123.0);
f int2 => $_ for (-32769, 32768, [], '', 'a', 1.5); f int2 => $_ for (-32769, 32768, [], '', 'a', 1.5);
@ -187,29 +160,10 @@ f 'oidvector', [undef];
# Example from https://www.postgresql.org/docs/17/arrays.html#ARRAYS-IO # Example from https://www.postgresql.org/docs/17/arrays.html#ARRAYS-IO
# Lower bounds are discarded. # Lower bounds are discarded.
is_deeply $conn->sql("SELECT '[1:1][-2:-1][3:5]={{{1,2,3},{4,5,6}}}'::int[]")->val, [[[1,2,3],[4,5,6]]]; is_deeply $conn->q("SELECT '[1:1][-2:-1][3:5]={{{1,2,3},{4,5,6}}}'::int[]")->val, [[[1,2,3],[4,5,6]]];
is $conn->sql('SELECT ($1::int2[])[2]', [1,2,3,4])->val, 2; is $conn->q('SELECT ($1::int2[])[2]', [1,2,3,4])->val, 2;
is $conn->sql('SELECT ($1::int2vector)[1]', [1,2,3,4])->val, 2; is $conn->q('SELECT ($1::int2vector)[1]', [1,2,3,4])->val, 2;
is $conn->sql('SELECT ($1::oidvector)[1]', [1,2,3,4])->val, 2; is $conn->q('SELECT ($1::oidvector)[1]', [1,2,3,4])->val, 2;
is_deeply [$conn->bin2text(
16, $conn->perl2bin(16, 1),
25, 'Hello',
1007, $conn->perl2bin(1007, [-3,1,undef])
)], ['t', 'Hello', '{-3,1,NULL}'];
{
my($b,$s,$a) = $conn->text2bin(16, 't', 25, 'Hello', 1007, '{-3,1,NULL}');
is $conn->bin2perl(16, $b), 1;
is $conn->bin2perl(25, $s), 'Hello';
is_deeply $conn->bin2perl(1007, $a), [-3,1,undef];
}
{
my $v = $conn->sql("SELECT '{t,f,NULL}'::bool[]")->val;
is_deeply $v, [true, false, undef];
$_ = 0 for @$v;
}
done_testing; done_testing;

View file

@ -7,10 +7,8 @@ is_deeply
query_decode('a&a&%c3%be=%26%3d%c3%be&a=3'), query_decode('a&a&%c3%be=%26%3d%c3%be&a=3'),
{ a => [ builtin::true, builtin::true, 3 ], "\xfe" => "&=\xfe" }; { a => [ builtin::true, builtin::true, 3 ], "\xfe" => "&=\xfe" };
ok !eval { query_decode('a=%fe%83%bf%bf%bf%bf%bf%0a'); 1 }; ok !eval { query_decode('%10'); 1 };
like $@, qr/does not map to Unicode/; like $@, qr/Invalid control character/;
is_deeply query_decode('&&&a=b'), { a => 'b' };
is query_encode is query_encode
{ a => builtin::true, b => undef, c => builtin::false, d => 'string', e => "&=\xfe" }, { a => builtin::true, b => undef, c => builtin::false, d => 'string', e => "&=\xfe" },

10
t/sql.t
View file

@ -9,15 +9,11 @@ sub t($obj, $sql, $params, @opt) {
is_deeply $gotparams, $params; is_deeply $gotparams, $params;
} }
my @q_ident = (quote_identifier => sub($x) { $x =~ s/"/_/rg });
my $x; my $x;
t P '', '?', ['']; t P '', '?', [''];
t P '', '$1', [''], placeholder_style => 'pg'; t P '', '$1', [''], placeholder_style => 'pg';
t P undef, '?', [undef]; t P undef, '?', [undef];
t RAW '', '', []; t RAW '', '', [];
t IDENT '"hello"', '"hello"', [];
t IDENT '"hello"', '_hello_', [], @q_ident;
t SQL('select', '1'), 'select 1', []; t SQL('select', '1'), 'select 1', [];
t SQL('select', P '1'), 'select ?', [1]; t SQL('select', P '1'), 'select ?', [1];
t SQL('select', $x = '1'), 'select ?', [1]; t SQL('select', $x = '1'), 'select ?', [1];
@ -45,7 +41,6 @@ t WHERE($x, '1 = 2', SQL('x = ', $x)),
t WHERE({ col1 => RAW 'NOW()', col2 => 'a'}), t WHERE({ col1 => RAW 'NOW()', col2 => 'a'}),
'WHERE ( col1 = NOW() ) AND ( col2 = ? )', ['a']; 'WHERE ( col1 = NOW() ) AND ( col2 = ? )', ['a'];
t WHERE(), 'WHERE 1=1', []; t WHERE(), 'WHERE 1=1', [];
t WHERE({ '"x' => 1 }), 'WHERE ( _x = ? )', [1], @q_ident;
t WHERE(AND('true', $x), OR($y, 'y'), AND, OR), t WHERE(AND('true', $x), OR($y, 'y'), AND, OR),
'WHERE ( ( true ) AND ( ? ) ) AND ( ( ? ) OR ( y ) ) AND ( 1=1 ) AND ( 1=0 )', [$x, $y]; 'WHERE ( ( true ) AND ( ? ) ) AND ( ( ? ) OR ( y ) ) AND ( 1=1 ) AND ( 1=0 )', [$x, $y];
@ -57,11 +52,9 @@ t SQL(SELECT => COMMA(qw/a b c/), FROM => 'table', WHERE { x => 1, a => undef })
t SET({ a => 1, c => RAW 'NOW()', d => undef }), t SET({ a => 1, c => RAW 'NOW()', d => undef }),
'SET a = ? , c = NOW() , d = ?', [1, undef]; 'SET a = ? , c = NOW() , d = ?', [1, undef];
t SET({ '"x' => 1 }), 'SET _x = ?', [1], @q_ident;
t VALUES({ a => 1, c => RAW 'NOW()', d => undef }), t VALUES({ a => 1, c => RAW 'NOW()', d => undef }),
'( a , c , d ) VALUES ( ? , NOW() , ? )', [1, undef]; '( a , c , d ) VALUES ( ? , NOW() , ? )', [1, undef];
t VALUES({ '"x' => 1 }), '( _x ) VALUES ( ? )', [1], @q_ident;
t VALUES(1, $x, 'NOW()', RAW 'NOW()'), 'VALUES ( ? , ? , NOW() , NOW() )', [1, $x]; t VALUES(1, $x, 'NOW()', RAW 'NOW()'), 'VALUES ( ? , ? , NOW() , NOW() )', [1, $x];
t VALUES([1, $x, 'NOW()', RAW 'NOW()']), 'VALUES ( ? , ? , ? , NOW() )', [1, $x, 'NOW()']; t VALUES([1, $x, 'NOW()', RAW 'NOW()']), 'VALUES ( ? , ? , ? , NOW() )', [1, $x, 'NOW()'];
@ -93,7 +86,4 @@ Hash::Util::lock_keys(%hash);
Hash::Util::lock_value(%hash, 'v'); Hash::Util::lock_value(%hash, 'v');
t SQL($hash{v}), 'value', []; t SQL($hash{v}), 'value', [];
ok !eval { SQL('')->compile(oops => 1); 1 };
like $@, qr/Unknown flag: oops/;
done_testing; done_testing;

View file

@ -79,10 +79,6 @@ t { trim => 0 }, " Va\rl id \n ", " Va\rl id \n ";
f {}, ' ', { validation => 'required' }, 'required value missing'; f {}, ' ', { validation => 'required' }, 'required value missing';
t { trim => 0 }, ' ', ' '; t { trim => 0 }, ' ', ' ';
# allow_control
f {}, "\b", { validation => 'allow_control' }, 'invalid control character';
t { allow_control => 1 }, "\b", "\b";
# accept_array # accept_array
t { default => undef, accept_array => 'first' }, [], undef; t { default => undef, accept_array => 'first' }, [], undef;
t { default => undef, accept_array => 'first' }, [' x '], 'x'; t { default => undef, accept_array => 'first' }, [' x '], 'x';
@ -123,7 +119,7 @@ f { type => 'hash', keys => { a=>{missing=>'reject'} } }, {}, {key => 'a', valid
t { type => 'hash', keys => { a=>{} } }, {a=>' a '}, {a=>'a'}; # Test against in-place modification t { type => 'hash', keys => { a=>{} } }, {a=>' a '}, {a=>'a'}; # Test against in-place modification
t { type => 'hash', keys => { a=>{} }, unknown => 'remove' }, { a=>1,b=>1 }, { a=>1 }; t { type => 'hash', keys => { a=>{} }, unknown => 'remove' }, { a=>1,b=>1 }, { a=>1 };
f { type => 'hash', keys => { a=>{} }, unknown => 'reject' }, { a=>1,b=>1 }, { validation => 'unknown', keys => ['b'], expected => ['a'] }, "unknown key: b"; f { type => 'hash', keys => { a=>{} }, unknown => 'reject' }, { a=>1,b=>1 }, { validation => 'unknown', keys => ['b'], expected => ['a'] }, "unknown key 'b'";
t { type => 'hash', keys => { a=>{} }, unknown => 'pass' }, { a=>1,b=>1 }, { a=>1,b=>1 }; t { type => 'hash', keys => { a=>{} }, unknown => 'pass' }, { a=>1,b=>1 }, { a=>1,b=>1 };
t { type => 'hash', setundef => 1 }, {}, undef; t { type => 'hash', setundef => 1 }, {}, undef;
t { type => 'hash', unknown => 'reject', keys => { a=>{ type => 'any', setundef => 1}} }, {a=>[]}, {a=>undef}; t { type => 'hash', unknown => 'reject', keys => { a=>{ type => 'any', setundef => 1}} }, {a=>[]}, {a=>undef};
@ -136,20 +132,20 @@ t { values => { int => 1 } }, { a => -1, b => 1 }, { a => -1, b => 1 };
f { values => { int => 1 } }, { a => undef }, { validation => 'values', errors => [{ key => 'a', validation => 'required' }] }, '.a: required value missing'; f { values => { int => 1 } }, { a => undef }, { validation => 'values', errors => [{ key => 'a', validation => 'required' }] }, '.a: required value missing';
# default validations # default validations
f { minlength => 3 }, 'ab', { validation => 'minlength', expected => 3, got => 2 }, "input too short, expected minimum of 3 but got 2"; f { minlength => 3 }, 'ab', { validation => 'minlength', expected => 3, got => 2 }, "failed validation 'minlength'";
t { minlength => 3 }, 'abc', 'abc'; t { minlength => 3 }, 'abc', 'abc';
f { maxlength => 3 }, 'abcd', { validation => 'maxlength', expected => 3, got => 4 }, "input too long, expected maximum of 3 but got 4"; f { maxlength => 3 }, 'abcd', { validation => 'maxlength', expected => 3, got => 4 }, "failed validation 'maxlength'";
t { maxlength => 3 }, 'abc', 'abc'; t { maxlength => 3 }, 'abc', 'abc';
t { minlength => 3, maxlength => 3 }, 'abc', 'abc'; t { minlength => 3, maxlength => 3 }, 'abc', 'abc';
f { length => 3 }, 'ab', { validation => 'length', expected => 3, got => 2 }, 'invalid input length, expected 3 but got 2'; f { length => 3 }, 'ab', { validation => 'length', expected => 3, got => 2 }, "failed validation 'length'";
f { length => 3 }, 'abcd', { validation => 'length', expected => 3, got => 4 }, 'invalid input length, expected 3 but got 4'; f { length => 3 }, 'abcd', { validation => 'length', expected => 3, got => 4 }, "failed validation 'length'";
t { length => 3 }, 'abc', 'abc'; t { length => 3 }, 'abc', 'abc';
t { length => [1,3] }, 'abc', 'abc'; t { length => [1,3] }, 'abc', 'abc';
f { length => [1,3] }, 'abcd', { validation => 'length', expected => [1,3], got => 4 }, "invalid input length, expected between 1 and 3 but got 4"; f { length => [1,3] }, 'abcd', { validation => 'length', expected => [1,3], got => 4 }, "failed validation 'length'";
t { type => 'array', length => 0 }, [], []; t { type => 'array', length => 0 }, [], [];
f { type => 'array', length => 1 }, [1,2], { validation => 'length', expected => 1, got => 2 }, "invalid input length, expected 1 but got 2"; f { type => 'array', length => 1 }, [1,2], { validation => 'length', expected => 1, got => 2 }, "failed validation 'length'";
t { type => 'hash', length => 0 }, {}, {}; t { type => 'hash', length => 0 }, {}, {};
f { type => 'hash', length => 1, unknown => 'pass' }, {qw/1 a 2 b/}, { validation => 'length', expected => 1, got => 2 }, "invalid input length, expected 1 but got 2"; f { type => 'hash', length => 1, unknown => 'pass' }, {qw/1 a 2 b/}, { validation => 'length', expected => 1, got => 2 }, "failed validation 'length'";
t { type => 'hash', length => 1, keys => {a => {missing=>'ignore'}, b => {missing=>'ignore'}} }, {a=>1}, {a=>1}; t { type => 'hash', length => 1, keys => {a => {missing=>'ignore'}, b => {missing=>'ignore'}} }, {a=>1}, {a=>1};
t { regex => '^a' }, 'abc', 'abc'; # XXX: Can't use qr// here because t() does dclone(). The 'hex' test covers that case anyway. t { regex => '^a' }, 'abc', 'abc'; # XXX: Can't use qr// here because t() does dclone(). The 'hex' test covers that case anyway.
f { regex => '^a' }, 'cba', { validation => 'regex', regex => '^a', got => 'cba' }, "failed validation 'regex'"; f { regex => '^a' }, 'cba', { validation => 'regex', regex => '^a', got => 'cba' }, "failed validation 'regex'";
@ -205,7 +201,7 @@ t { doublefunc => 1 }, 0, 2;
f { doublefunc => 1 }, 1, { validation => 'doublefunc', error => { validation => 'func', result => '' } }, "validation 'doublefunc': failed validation 'func'"; f { doublefunc => 1 }, 1, { validation => 'doublefunc', error => { validation => 'func', result => '' } }, "validation 'doublefunc': failed validation 'func'";
# numbers # numbers
sub nerr { ({ validation => 'num', got => $_[0] }, "invalid number: \"$_[0]\"") } sub nerr { ({ validation => 'num', got => $_[0] }, "failed validation 'num'") }
t { num => 1 }, 0, 0; t { num => 1 }, 0, 0;
f { num => 1 }, '-', nerr '-'; f { num => 1 }, '-', nerr '-';
f { num => 1 }, '00', nerr '00'; f { num => 1 }, '00', nerr '00';
@ -223,16 +219,16 @@ t { uint => 1 }, 0, 0;
t { uint => 1 }, 123, 123; t { uint => 1 }, 123, 123;
f { uint => 1 }, -123, { validation => 'uint', got => -123 }, "failed validation 'uint'"; f { uint => 1 }, -123, { validation => 'uint', got => -123 }, "failed validation 'uint'";
t { min => 1 }, 1, 1; t { min => 1 }, 1, 1;
f { min => 1 }, 0.9, { validation => 'min', expected => 1, got => 0.9 }, "expected minimum 1 but got 0.9"; f { min => 1 }, 0.9, { validation => 'min', expected => 1, got => 0.9 }, "failed validation 'min'";
f { min => 1 }, 'a', { validation => 'min', error => (nerr 'a')[0] }, 'invalid number: "a"'; f { min => 1 }, 'a', { validation => 'min', error => (nerr 'a')[0] }, "validation 'min': failed validation 'num'";
t { max => 1 }, 1, 1; t { max => 1 }, 1, 1;
f { max => 1 }, 1.1, { validation => 'max', expected => 1, got => 1.1 }, "expected maximum 1 but got 1.1"; f { max => 1 }, 1.1, { validation => 'max', expected => 1, got => 1.1 }, "failed validation 'max'";
f { max => 1 }, 'a', { validation => 'max', error => (nerr 'a')[0] }, 'invalid number: "a"'; f { max => 1 }, 'a', { validation => 'max', error => (nerr 'a')[0] }, "validation 'max': failed validation 'num'";
t { range => [1,2] }, 1, 1; t { range => [1,2] }, 1, 1;
t { range => [1,2] }, 2, 2; t { range => [1,2] }, 2, 2;
f { range => [1,2] }, 0.9, { validation => 'range', error => { validation => 'min', expected => 1, got => 0.9 } }, 'expected minimum 1 but got 0.9'; f { range => [1,2] }, 0.9, { validation => 'range', error => { validation => 'min', expected => 1, got => 0.9 } }, "validation 'range': failed validation 'min'";
f { range => [1,2] }, 2.1, { validation => 'range', error => { validation => 'max', expected => 2, got => 2.1 } }, 'expected maximum 2 but got 2.1'; f { range => [1,2] }, 2.1, { validation => 'range', error => { validation => 'max', expected => 2, got => 2.1 } }, "validation 'range': failed validation 'max'";
f { range => [1,2] }, 'a', { validation => 'range', error => { validation => 'min', error => (nerr 'a')[0] } }, 'invalid number: "a"'; f { range => [1,2] }, 'a', { validation => 'range', error => { validation => 'min', error => (nerr 'a')[0] } }, "validation 'range': validation 'min': failed validation 'num'";
# email template # email template
use utf8; use utf8;
@ -257,7 +253,7 @@ t { email => 1 }, $_, $_ for (
'abc@x-y_z.example', 'abc@x-y_z.example',
); );
my $long = 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx@xxxxxxxxxxxxxxxxxxxx.xxxxxxxxxxxxxxxxxxxxxxxx.xxxxx'; my $long = 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx@xxxxxxxxxxxxxxxxxxxx.xxxxxxxxxxxxxxxxxxxxxxxx.xxxxx';
f { email => 1 }, $long, { validation => 'email', error => { validation => 'maxlength', got => 255, expected => 254 } }, "validation 'email': input too long, expected maximum of 254 but got 255"; f { email => 1 }, $long, { validation => 'email', error => { validation => 'maxlength', got => 255, expected => 254 } }, "validation 'email': failed validation 'maxlength'";
# weburl template # weburl template
f { weburl => 1 }, $_, { validation => 'weburl', got => $_ }, "failed validation 'weburl'" for ( f { weburl => 1 }, $_, { validation => 'weburl', got => $_ }, "failed validation 'weburl'" for (

View file

@ -65,21 +65,4 @@ sub t {
is fragment { t 'arg' }, '<div attr1="arg"><span>ab&quot; &lt; c &amp;&lt; d</span><span><ok🥳ay></span>🥳</div>'; is fragment { t 'arg' }, '<div attr1="arg"><span>ab&quot; &lt; c &amp;&lt; d</span><span><ok🥳ay></span>🥳</div>';
ok !eval { fragment { tag_ 'hi', \1 } };
like $@, qr/Invalid attempt to output bare reference/;
ok !eval { fragment { tag_ 'hi', {} } };
like $@, qr/Invalid attempt to output bare reference/;
is fragment { tag_ 'hi', bless {}, 'XTEST1' }, '<hi>string</hi>';
like fragment { tag_ 'hi', bless {}, 'XTEST2' }, qr{<hi>HASH\(.*\)</hi>}; # Yeah, whatever.
like fragment { tag_ 'hi', ''.{} }, qr{<hi>HASH\(.*\)</hi>};
done_testing; done_testing;
package XTEST1;
use overload '""' => sub { 'string' };
package XTEST2;
use overload '""' => sub { {} };