summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Build.PL2
-rw-r--r--ChangeLog28
-rw-r--r--lib/TUWF.pm39
-rw-r--r--lib/TUWF.pod21
-rw-r--r--lib/TUWF/DB.pm17
-rw-r--r--lib/TUWF/DB.pod2
-rw-r--r--lib/TUWF/Misc.pm5
-rw-r--r--lib/TUWF/Request.pm44
-rw-r--r--lib/TUWF/Response.pm58
-rw-r--r--lib/TUWF/Response.pod19
-rw-r--r--lib/TUWF/Validate.pm64
-rw-r--r--lib/TUWF/Validate.pod67
-rw-r--r--lib/TUWF/Validate/Interop.pm14
-rw-r--r--lib/TUWF/XML.pm22
-rw-r--r--lib/TUWF/XML.pod20
-rw-r--r--t/interop.t22
-rw-r--r--t/kv_validate.t4
-rw-r--r--t/validate.t62
-rw-r--r--t/xml.t2
19 files changed, 340 insertions, 172 deletions
diff --git a/Build.PL b/Build.PL
index 30193be..09b58c9 100644
--- a/Build.PL
+++ b/Build.PL
@@ -4,7 +4,7 @@ use Module::Build;
Module::Build->new(
dist_name => 'TUWF',
- dist_version => '1.4',
+ dist_version => '1.5',
dist_author => 'Yoran Heling <projects@yorhel.nl>',
dist_abstract => 'The Ultimate Website Framework',
license => 'mit',
diff --git a/ChangeLog b/ChangeLog
index 2e7dd7c..3f089cc 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,31 @@
+1.5 - 2023-01-18
+ - Add tuwf->req() method for storing request-local data
+ - Add tuwf->captures() as alternative to handler arguments
+ - Add support for Max-Age and SameSite properties in resCookie()
+ - Add support for JSON::PP and Cpanel::JSON::PP
+ - Add support for calling dbPage() in scalar context
+ - Add "onerror" and "undefbool" built-in validations
+ - Add support for subroutine arguments to 'default' validation option
+ - Add TUWF::Validate::Interop::elm_decoder() (undocumented)
+ - Add support for undef and concat attributes in TUWF::XML
+ - Add TUWF::XML::xml_string() function
+ - Add summary tag to TUWF::XML
+ - Add "db_connect" hook
+ - Add "fastcgi_max_requests" setting
+ - Add support for graceful process shutdown in FastCGI mode
+ - Add support for output compression for resJSON, resFile and resBinary
+ - Fix handling recursion from the log_format subroutine
+ - Fix encoding of HTTP response headers
+ - Fix calling error_404_handler before the "after" hooks.
+ - Fix handling of SIGCHLD when using the builtin HTTP server
+ - Fix logging during startup
+ - Fix input modification on TUWF::Validate with unknown=>"reject" hashes
+ - Fix handling of HTTP DELETE requests
+ - Fix handling for HTTP 204 responses
+ - Remove error on resFile() path traversal, just return a 404 instead
+ - Disallow IP address hosts as part of email validation
+ - Use Perl built-in utf8 functions instead of Encode module
+
1.4 - 2019-07-06
- Version bump because CPAN doesn't like patch versions
diff --git a/lib/TUWF.pm b/lib/TUWF.pm
index f460306..0a4886c 100644
--- a/lib/TUWF.pm
+++ b/lib/TUWF.pm
@@ -7,7 +7,7 @@ use strict;
use warnings;
use Carp 'croak';
-our $VERSION = '1.4';
+our $VERSION = '1.5';
# Store the object in a global variable for some functions that don't get it
@@ -22,6 +22,7 @@ our $OBJ = bless {
hooks => {
before => [],
after => [],
+ db_connect => [],
},
# defaults
import_modules => 1,
@@ -45,6 +46,7 @@ our $OBJ = bless {
aac audio/aac
atom application/atom+xml
avi video/x-msvideo
+ avif image/avif
bin application/octet-stream
bmp image/bmp
bz application/x-bzip2
@@ -58,6 +60,8 @@ our $OBJ = bless {
jpg image/jpeg
js application/javascript
json application/json
+ jxl image/jxl
+ mjs application/javascript
mp3 audio/mpeg
mp4 video/mp4
mp4v video/mp4
@@ -77,6 +81,7 @@ our $OBJ = bless {
tiff image/tiff
ttf font/ttf
txt text/plain
+ webp image/webp
webm video/webm
xhtml text/html
xml application/xml
@@ -105,24 +110,26 @@ sub import {
sub set {
return $OBJ->{_TUWF}{$_[0]} if @_ == 1;
$OBJ->{_TUWF} = { %{$OBJ->{_TUWF}}, @_ };
+ # Make sure to load TUWF::DB as soon as we have database settings.
+ $OBJ->_load_module('TUWF::DB', 1) if $OBJ->{_TUWF}{db_login};
}
sub run {
- # load the database module if requested
- $OBJ->_load_module('TUWF::DB', 1) if $OBJ->{_TUWF}{db_login};
-
# install a warning handler to write to the log file
$SIG{__WARN__} = sub { $TUWF::OBJ->log($_) for @_; };
# load optional modules
require Time::HiRes if $OBJ->debug || $OBJ->{_TUWF}{log_slow_pages};
- # initialize DB connection
- $OBJ->dbInit if $OBJ->{_TUWF}{db_login};
+ # roll back any transaction that is currently active, so we start with a
+ # clean slate for the next incoming request. Code running SQL queries during
+ # initialization is responsible for doing an explicit dbCommit() if changes
+ # should be kept.
+ $OBJ->dbRollBack if $OBJ->{_TUWF}{db_login};
# In a FastCGI environment, STDIN will be a listen socket; getpeername() will
- # return a ENOTCONN on those, giving us a reliably way to differentiate
+ # return a ENOTCONN on those, giving us a reliable way to differentiate
# between CGI (env vars), FastCGI (STDIN socket), and others.
my(undef) = (getpeername \*STDIN);
my $isfastcgi = $!{ENOTCONN};
@@ -137,9 +144,11 @@ sub run {
import FCGI;
my $r = FCGI::Request();
$OBJ->{_TUWF}{fcgi_req} = $r;
+ local $SIG{TERM} = local $SIG{INT} = sub { $r->LastCall() };
while($r->Accept() >= 0) {
$OBJ->_handle_request;
$r->Finish();
+ last if $OBJ->{_TUWF}{fastcgi_max_requests} && !--$OBJ->{_TUWF}{fastcgi_max_requests};
}
# otherwise, run our own HTTP server
@@ -188,7 +197,7 @@ sub patch ($&) { any ['patch' ], @_ }
sub hook ($&) {
my($hook, $sub) = @_;
- croak "Unknown hook: $hook" if $hook ne 'before' && $hook ne 'after';
+ croak "Unknown hook: $hook" if $hook ne 'before' && $hook ne 'after' && $hook ne 'db_connect';
croak 'Hooks expect a subroutine as second argument' if ref $sub ne 'CODE';
push @{$OBJ->{_TUWF}{hooks}{$hook}}, $sub;
}
@@ -515,14 +524,22 @@ sub capture {
}
+sub captures {
+ my $self = shift;
+ map $self->capture($_), @_;
+}
+
+
# writes a message to the log file. date, time and URL are automatically added
+our $_recursive_log = 0;
sub log {
my($self, $msg) = @_;
# temporarily disable the warnings-to-log, to avoid infinite recursion if
# this function throws a warning.
- my $recursive = !defined $SIG{__WARN__};
+ my $recursive = $_recursive_log;
local $SIG{__WARN__} = undef;
+ local $_recursive_log = 1;
my $uri = $self->{_TUWF}{Req} ? $self->reqURI : '[init]';
chomp $msg;
@@ -537,8 +554,8 @@ sub log {
flock $F, 4;
close $F;
}
- # Also always dump stuff to STDERR if we're running a standalone HTTP server.
- warn $msg if $self->{_TUWF}{http};
+ # Also always dump stuff to STDERR during init or if we're running a standalone HTTP server.
+ warn $msg if $self->{_TUWF}{http} || !$self->{_TUWF}{Req};
}
diff --git a/lib/TUWF.pod b/lib/TUWF.pod
index c1c5029..1339c34 100644
--- a/lib/TUWF.pod
+++ b/lib/TUWF.pod
@@ -297,6 +297,11 @@ an exception).
This replaces the L<post_request_handler|/post_request_handler> setting.
+=item db_connect
+
+Called after (re)connecting to the database. Can be used to load the correct
+session variables into the database connection.
+
=back
=head2 TUWF::load(@modules)
@@ -490,6 +495,13 @@ not be in a usable state. This handler may also be called before any of the
hooks have been run. It's best to keep this handler as simple as possible, and
only have it generate a friendly response.
+=item fastcgi_max_requests
+
+Maximum number of requests to handle when running in FastCGI mode. The process
+will gracefully exit when this number of requests has been processed. This
+option is useful when running under L<spawn-fcgi(1)> in combination with
+L<multiwatch(1)> or another supervisor that automatically respawns processes.
+
=item http_server_port
Port to listen on when running the standalone HTTP server. This defaults to the
@@ -669,6 +681,15 @@ named captures can be used, for example:
Note that C<captures(0)> is not available; This would be equivalent to
C<< tuwf->reqPath >>, save for the leading slash.
+=head2 captures(@keys)
+
+Multiple-argument version of C<capture()>, returns the a list of values
+associated with the given keys. Example:
+
+ TUWF::get qr{/user/([0-9]+)/file/(.+)} => sub {
+ my($user_id, $file) = tuwf->captures(1,2);
+ };
+
=head2 debug()
Returns the value of the I<debug> setting.
diff --git a/lib/TUWF/DB.pm b/lib/TUWF/DB.pm
index a583609..b3c9bcc 100644
--- a/lib/TUWF/DB.pm
+++ b/lib/TUWF/DB.pm
@@ -7,7 +7,7 @@ use Carp 'croak';
use Exporter 'import';
use Time::HiRes 'time';
-our $VERSION = '1.4';
+our $VERSION = '1.5';
our @EXPORT = qw|
dbInit dbh dbCheck dbDisconnect dbCommit dbRollBack
dbExec dbVal dbRow dbAll dbPage
@@ -40,24 +40,29 @@ sub dbInit {
sql => $sql,
queries => [],
};
+
+ $_->() for @{$self->{_TUWF}{hooks}{db_connect}};
}
sub dbh {
- return shift->{_TUWF}{DB}{sql};
+ my($self) = @_;
+ $self->dbInit if !$self->{_TUWF}{DB}{sql};
+ $self->{_TUWF}{DB}{sql};
}
sub dbCheck {
my $self = shift;
my $info = $self->{_TUWF}{DB};
+ return $self->dbInit if !$info || !$info->{sql};
my $start = time;
$info->{queries} = [];
if(!$info->{sql}->ping) {
- warn "Ping failed, reconnecting";
$self->dbInit;
+ warn "Ping failed, reconnected to database";
}
$self->dbRollBack;
push(@{$info->{queries}}, [ 'ping/rollback', {}, time-$start ]);
@@ -65,21 +70,21 @@ sub dbCheck {
sub dbDisconnect {
- shift->{_TUWF}{DB}{sql}->disconnect();
+ (shift->{_TUWF}{DB}{sql} // return)->disconnect();
}
sub dbCommit {
my $self = shift;
my $start = [Time::HiRes::gettimeofday()] if $self->debug || $self->{_TUWF}{log_slow_pages};
- $self->{_TUWF}{DB}{sql}->commit();
+ ($self->{_TUWF}{DB}{sql} // return)->commit();
push(@{$self->{_TUWF}{DB}{queries}}, [ 'commit', {}, Time::HiRes::tv_interval($start) ])
if $self->debug || $self->{_TUWF}{log_slow_pages};
}
sub dbRollBack {
- shift->{_TUWF}{DB}{sql}->rollback();
+ (shift->{_TUWF}{DB}{sql} // return)->rollback();
}
diff --git a/lib/TUWF/DB.pod b/lib/TUWF/DB.pod
index 6f11a97..75647e3 100644
--- a/lib/TUWF/DB.pod
+++ b/lib/TUWF/DB.pod
@@ -72,7 +72,7 @@ Returns the DBI connection handle.
Commits the current transaction. You normally don't have to call this method
since TUWF does this automatically after each request.
-=head2 dbRollback()
+=head2 dbRollBack()
Rolls back the current transaction. You normally don't have to call this method
since TUWF does this automatically if something goes wrong.
diff --git a/lib/TUWF/Misc.pm b/lib/TUWF/Misc.pm
index e887409..6d76698 100644
--- a/lib/TUWF/Misc.pm
+++ b/lib/TUWF/Misc.pm
@@ -7,17 +7,16 @@ use strict;
use warnings;
use Carp 'croak';
use Exporter 'import';
-use Encode 'encode_utf8';
use Scalar::Util 'looks_like_number';
use TUWF::Validate;
-our $VERSION = '1.4';
+our $VERSION = '1.5';
our @EXPORT_OK = ('uri_escape', 'kv_validate');
sub uri_escape {
- local $_ = encode_utf8 shift;
+ utf8::encode(local $_ = shift);
s/([^A-Za-z0-9._~-])/sprintf '%%%02X', ord $1/eg;
return $_;
}
diff --git a/lib/TUWF/Request.pm b/lib/TUWF/Request.pm
index 0cec70e..e9a54e5 100644
--- a/lib/TUWF/Request.pm
+++ b/lib/TUWF/Request.pm
@@ -3,11 +3,10 @@ package TUWF::Request;
use strict;
use warnings;
-use Encode 'decode_utf8', 'encode_utf8';
use Exporter 'import';
use Carp 'croak';
-our $VERSION = '1.4';
+our $VERSION = '1.5';
our @EXPORT = qw|
reqInit reqGets reqGet reqPosts reqPost reqParams reqParam reqJSON
reqUploadMIMEs reqUploadMIME reqUploadRaws reqUploadRaw reqSaveUpload
@@ -31,12 +30,10 @@ sub reqInit {
$self->reqPath(); # let it croak when the path isn't valid UTF-8
1;
};
- die TUWF::Exception->new('utf8') if !$ok && $@ && $@ =~ /does not map to Unicode/; # <- UGLY!
- # re-throw if it wasn't a UTF-8 problem. I don't expect this to happen
die $@ if !$ok;
my $meth = $self->reqMethod;
- die TUWF::Exception->new('method') if $meth !~ /^(GET|POST|HEAD|DEL|OPTIONS|PUT|PATCH)$/;
+ die TUWF::Exception->new('method') if $meth !~ /^(GET|POST|HEAD|DELETE|OPTIONS|PUT|PATCH)$/;
if($meth =~ /^(POST|PUT|PATCH)$/ && $ENV{CONTENT_LENGTH}) {
die TUWF::Exception->new('maxpost') if $self->{_TUWF}{max_post_body} && $ENV{CONTENT_LENGTH} > $self->{_TUWF}{max_post_body};
@@ -44,7 +41,7 @@ sub reqInit {
my $data;
die "Couldn't read all request data.\n" if $ENV{CONTENT_LENGTH} > read STDIN, $data, $ENV{CONTENT_LENGTH}, 0;
- $ok = eval {
+ eval {
if(($ENV{'CONTENT_TYPE'}||'') =~ m{^application/json(?:;.*)?$}) {
$self->{_TUWF}{Req}{JSON} = _parse_json($data);
die TUWF::Exception->new('json') if !$self->{_TUWF}{Req}{JSON};
@@ -54,9 +51,7 @@ sub reqInit {
$self->{_TUWF}{Req}{POST} = _parse_urlencoded($data);
}
1;
- };
- die TUWF::Exception->new('utf8') if !$ok && $@ && $@ =~ /does not map to Unicode/;
- die $@ if !$ok;
+ } || die $@;;
}
}
@@ -68,6 +63,12 @@ sub _check_control {
}
+sub _decode_utf8 {
+ utf8::decode(my $v = $_[0]) || die TUWF::Exception->new('utf8');
+ $v;
+}
+
+
sub _store {
return push @{$_[0]}, $_[1] if ref $_[0];
$_[0] = defined $_[0] ? [$_[0], $_[1]] : $_[1];
@@ -77,15 +78,16 @@ sub _store {
sub _parse_urlencoded {
my %dat;
my $d = shift;
- for (split /[;&]/, decode_utf8 $d, 1) {
+ for (split /[;&]/, _decode_utf8 $d) {
my($key, $val) = split /=/, $_, 2;
next if !defined $key or !defined $val;
for ($key, $val) {
s/\+/ /gs;
# assume %XX sequences represent UTF-8 bytes and properly decode it.
s#((?:%[0-9a-fA-F]{2})+)#
- (my $s=encode_utf8 $1) =~ s/%(.{2})/chr hex($1)/eg;
- decode_utf8($s, 1);
+ utf8::downgrade(my $s = $1);
+ $s =~ s/%(.{2})/chr hex($1)/eg;
+ _decode_utf8 $s;
#eg;
s/%u([0-9a-fA-F]{4})/chr hex($1)/eg;
_check_control($_);
@@ -139,7 +141,7 @@ sub _parse_multipart {
}
}
- $name = _check_control decode_utf8 $name, 1;
+ $name = _check_control _decode_utf8 $name;
# In the case of a file upload, use the filename as value instead of the
# data. This is to ensure that reqPOST() always returns decoded data.
@@ -149,11 +151,11 @@ sub _parse_multipart {
# regular form element. The standards do not require the filename to be
# present, but I am not aware of any browser that does not send it.
if($filename) {
- _store $nfo->{POST}{$name}, _check_control decode_utf8 $filename, 1;
- _store $nfo->{MIMES}{$name}, _check_control decode_utf8 $mime, 1;
+ _store $nfo->{POST}{$name}, _check_control _decode_utf8 $filename;
+ _store $nfo->{MIMES}{$name}, _check_control _decode_utf8 $mime;
_store $nfo->{FILES}{$name}, $value; # not decoded, can be binary
} else {
- _store $nfo->{POST}{$name}, _check_control decode_utf8 $value, 1;
+ _store $nfo->{POST}{$name}, _check_control _decode_utf8 $value;
}
}
}
@@ -168,7 +170,7 @@ sub _parse_cookies {
# implementations all differ in how they interpret the data. This (rather)
# lazy implementation assumes the cookie values are not escaped and don't
# contain any characters that are used within the header format.
- for (split /[;,]/, decode_utf8 $str, 1) {
+ for (split /[;,]/, _decode_utf8 $str) {
s/^ +//;
s/ +$//;
next if !$_ || !m{^([^\(\)<>@,;:\\"/\[\]\?=\{\}\t\s]+)=("?)(.*)\2$};
@@ -273,13 +275,13 @@ sub reqHeader {
if(@_ == 2) {
(my $v = uc $_[1]) =~ tr/-/_/;
$v = $ENV{"HTTP_$v"}||'';
- return _check_control decode_utf8 $v, 1;
+ return _check_control _decode_utf8 $v;
} else {
return (map {
if(/^HTTP_/) {
(my $h = lc $_) =~ s/_([a-z])/-\U$1/g;
$h =~ s/^http-//;
- _check_control decode_utf8 $h, 1;
+ _check_control _decode_utf8 $h;
} else { () }
} sort keys %ENV);
}
@@ -289,7 +291,7 @@ sub reqHeader {
# returns the path part of the current URI, including the leading slash
sub reqPath {
(my $u = ($ENV{REQUEST_URI}||'')) =~ s{\?.*$}{};
- return _check_control decode_utf8 $u, 1;
+ return _check_control _decode_utf8 $u;
}
@@ -307,7 +309,7 @@ sub reqBaseURI {
sub reqQuery {
my $u = $ENV{QUERY_STRING} ? '?'.$ENV{QUERY_STRING} : '';
- return _check_control decode_utf8 $u, 1;
+ return _check_control _decode_utf8 $u;
}
diff --git a/lib/TUWF/Response.pm b/lib/TUWF/Response.pm
index 628eb4d..a6763d1 100644
--- a/lib/TUWF/Response.pm
+++ b/lib/TUWF/Response.pm
@@ -6,10 +6,10 @@ use strict;
use warnings;
use Exporter 'import';
use POSIX 'strftime';
-use Carp 'croak';
+use Carp 'croak', 'carp';
-our $VERSION = '1.4';
+our $VERSION = '1.5';
our @EXPORT = qw|
resInit resHeader resCookie resBuffer resFd resStatus resRedirect
resNotFound resJSON resBinary resFile resFinish
@@ -113,8 +113,7 @@ sub resCookie {
# 'auto' Clears and autodetects output compression from request header
# Enabling compression if PerlIO::gzip isn't installed will result in an error
sub resBuffer {
- my $self = shift;
- my $act = shift;
+ my($self, $act, $noutf8) = @_;
my $i = $self->{_TUWF}{Res};
my $h = $self->resHeader('Content-Encoding');
@@ -143,7 +142,7 @@ sub resBuffer {
# set output compression
binmode $i->{fd}, $new eq 'gzip' ? ':gzip' : ':gzip(none)' if $new ne 'none';
- binmode $i->{fd}, ':utf8';
+ binmode $i->{fd}, ':utf8' if !($noutf8 && $noutf8 eq 'noutf8');
$self->resHeader('Content-Encoding', $new eq 'none' ? undef : $new);
}
@@ -190,21 +189,23 @@ sub resNotFound {
my $_json_codec;
sub resJSON {
my($self, $obj) = @_;
- $_json_codec ||= TUWF::Misc::_JSON()->new->utf8;
+ $_json_codec ||= TUWF::Misc::_JSON()->new->convert_blessed->utf8;
$self->resHeader('Content-Type' => 'application/json; charset=UTF-8');
- $self->resBuffer('clear');
- $self->resBinary($_json_codec->encode($obj));
+ $self->resBinary($_json_codec->encode($obj), 'clear');
}
sub resBinary {
- my($self, $data) = @_;
- $self->resBuffer('none');
+ my($self, $data, $buffer) = @_;
+ my $enc = $self->resBuffer($buffer//'none', 'noutf8');
- # Write to the buffer directly, bypassing the fd. This avoids extra copying
- # and bypasses the ':utf8' filter.
- $self->{_TUWF}{Res}{content} = $data;
+ if($enc eq 'none') {
+ # Write to the buffer directly if we're not compressing, avoids extra copying.
+ $self->{_TUWF}{Res}{content} = $data;
+ } else {
+ print { $self->{_TUWF}{Res}{fd} } $data;
+ }
}
@@ -214,18 +215,23 @@ sub resFile {
# This also catches files with '..' somewhere in the middle of the name.
# Let's just disallow that too to simplify this check, I'd err on the side of
# caution.
- croak "Possible path traversal attempt" if $fn =~ /\.\./;
+ if($fn =~ /\.\./) {
+ $self->resNotFound;
+ $self->done;
+ }
+
+ my $ext = $fn =~ m{\.([^/\.]+)$} ? lc $1 : '';
+ my $ctype = $self->{_TUWF}{mime_types}{$ext} || $self->{_TUWF}{mime_default};
+ my $compress = $ctype =~ /^text/;
my $file = "$path/$fn";
return 0 if !-f $file;
open my $F, '<', $file or croak "Unable to open '$file': $!";
{
local $/=undef;
- $self->resBinary(scalar <$F>);
+ $self->resBinary(scalar <$F>, $compress ? 'auto' : 'none');
}
- my $ext = $fn =~ m{\.([^/\.]+)$} ? lc $1 : '';
- my $ctype = $self->{_TUWF}{mime_types}{$ext} || $self->{_TUWF}{mime_default};
$self->resHeader('Content-Type' => "$ctype; charset=UTF-8"); # Adding a charset to binary formats should be safe, too.
return 1;
}
@@ -237,18 +243,24 @@ sub resFinish {
my $i = $self->{_TUWF}{Res};
close $i->{fd};
- $self->resHeader('Content-Length' => length($i->{content}));
+ if($i->{status} == 204) {
+ $self->resHeader('Content-Type' => undef);
+ $self->resHeader('Content-Encoding' => undef);
+ } else {
+ $self->resHeader('Content-Length' => length($i->{content}));
+ }
if($self->{_TUWF}{http}) {
printf "HTTP/1.0 %d Hi, I am a HTTP response.\r\n", $i->{status};
} else {
printf "Status: %d\r\n", $i->{status};
}
- printf "%s: %s\r\n", $i->{headers}[$_*2], $i->{headers}[$_*2+1]
- for (0..$#{$i->{headers}}/2);
- printf "Set-Cookie: %s\r\n", $i->{cookies}{$_} for (keys %{$i->{cookies}});
- print "\r\n";
- print $i->{content} if $self->reqMethod() ne 'HEAD';
+ my $hdr = join "\r\n",
+ (map "$i->{headers}[$_*2]: $i->{headers}[$_*2+1]", @{$i->{headers}} ? 0..$#{$i->{headers}}/2 : ()),
+ (map "Set-Cookie: $i->{cookies}{$_}", keys %{$i->{cookies}});
+ utf8::encode $hdr;
+ print "$hdr\r\n\r\n";
+ print $i->{content} if $self->reqMethod() ne 'HEAD' && $i->{status} != 204;
# free the memory used for the reponse data
$self->resInit;
diff --git a/lib/TUWF/Response.pod b/lib/TUWF/Response.pod
index 3ceb34f..a15471b 100644
--- a/lib/TUWF/Response.pod
+++ b/lib/TUWF/Response.pod
@@ -192,12 +192,15 @@ you had to set these B<after> calling C<resRedirect()>. In TUWF versions after
Sets the content type to C<application/json> and sends the encoded JSON object
to the client.
-=head2 resBinary(data)
+=head2 resBinary(data, buffer_action)
-Send binary data to the client. This method throws away any data currently
-written to the buffer. This method also disables output compression to prevent
-additional copies of the data. Make sure to set the right content type as well,
-for example:
+Send raw/binary data to the client. This method throws away any data currently
+written to the buffer. The optional I<buffer_action> argument is passed to
+C<resBuffer()> and can be used to control output compression. C<'none'> is
+assumed when absent. This method can prevent additional copies of the data when
+output compression is disabled.
+
+Make sure to set the right content type as well, for example:
tuwf->resHeader('Content-Type' => 'image/jpeg');
tuwf->resBinary($image_data);
@@ -232,9 +235,9 @@ change much:
tuwf->resHeader('Cache-Control' => 'max-age=31536000');
-C<resFile()> uses C<resBinary()> internally, so output compression will be
-disabled for these files. Furthermore, this method is not really suitable for
-sending large files, as the entire files contents will be copied into RAM.
+C<resFile()> uses C<resBinary()> internally, output compression is only enabled
+if the file's mime type starts with C<text>. This method is not really suitable
+for sending large files, as the entire files contents will be copied into RAM.
Range requests, I<If-Modified-Since>, I<ETag> and such are also not supported.
If any of this is a concern, it's recommended to configure your webserver to
serve static files directly - without involvement of TUWF.
diff --git a/lib/TUWF/Validate.pm b/lib/TUWF/Validate.pm
index fbdfd5c..9743321 100644
--- a/lib/TUWF/Validate.pm
+++ b/lib/TUWF/Validate.pm
@@ -7,20 +7,23 @@ use Exporter 'import';
use Scalar::Util 'blessed';
our @EXPORT_OK = qw/compile validate/;
-our $VERSION = '1.4';
+our $VERSION = '1.5';
# Unavailable as custom validation names
my %builtin = map +($_,1), qw/
type
- required default
+ default
onerror
rmwhitespace
values scalar sort unique
- keys unknown
+ keys unknown missing
func
/;
+my %type_vals = map +($_,1), qw/scalar hash array any/;
+my %unknown_vals = map +($_,1), qw/remove reject pass/;
+my %missing_vals = map +($_,1), qw/create reject ignore/;
sub _length {
my($exp, $min, $max) = @_;
@@ -37,9 +40,9 @@ sub _reg {
}
-our $re_num = qr/^-?(?:0|[1-9]\d*)(?:\.\d+)?(?:[eE][+-]?\d+)?$/;
-my $re_int = qr/^-?(?:0|[1-9]\d*)$/;
-our $re_uint = qr/^(?:0|[1-9]\d*)$/;
+our $re_num = qr/^-?(?:0|[1-9][0-9]*)(?:\.[0-9]+)?(?:[eE][+-]?[0-9]+)?$/;
+my $re_int = qr/^-?(?:0|[1-9][0-9]*)$/;
+our $re_uint = qr/^(?:0|[1-9][0-9]*)$/;
my $re_fqdn = qr/(?:[a-zA-Z0-9][\w-]*\.)+[a-zA-Z][a-zA-Z0-9-]{1,25}\.?/;
my $re_ip4_digit = qr/(?:0|[1-9]|[1-9][0-9]|1[0-9]{2}|2[0-4][0-9]|25[0-5])/;
my $re_ip4 = qr/($re_ip4_digit\.){3}$re_ip4_digit/;
@@ -49,7 +52,7 @@ my $re_ip6 = qr/(?:[0-9a-fA-F]{1,4}:){7,7}[0-9a-fA-F]{1,4}|(?:[0-9a-fA-F]
my $re_ip = qr/(?:$re_ip4|$re_ip6)/;
my $re_domain = qr/(?:$re_fqdn|$re_ip4|\[$re_ip6\])/;
# Also used by the TUWF::Misc::kv_validate()
-our $re_email = qr/^[-\+\.#\$=\w]+\@$re_domain$/;
+our $re_email = qr/^[-\+\.#\$=\w]+\@$re_fqdn$/;
our $re_weburl = qr/^https?:\/\/$re_domain(?::[1-9][0-9]{0,5})?(?:\/[^\s<>"]*)$/;
@@ -71,7 +74,8 @@ our %default_validations = (
maxlength => sub { _length $_[0], undef, $_[0] },
length => sub { _length($_[0], ref $_[0] eq 'ARRAY' ? @{$_[0]} : ($_[0], $_[0])) },
- anybool => { type => 'any', required => 0, default => 0, func => sub { $_[0] = $_[0] ? 1 : 0; 1 } },
+ anybool => { type => 'any', default => 0, func => sub { $_[0] = $_[0] ? 1 : 0; 1 } },
+ undefbool => { type => 'any', default => undef, func => sub { $_[0] = $_[0] ? 1 : 0; 1 } },
jsonbool => { type => 'any', func => sub {
my $r = $_[0];
blessed $r && (
@@ -143,7 +147,7 @@ sub _compile {
croak "Incompatible types, '$t->[0]' requires '$t->{schema}{type}', but another validation requires '$top{type}'";
}
exists $t->{schema}{$_} and !exists $top{$_} and $top{$_} = delete $t->{schema}{$_}
- for qw/required default onerror rmwhitespace type scalar unknown sort unique/;
+ for qw/default onerror rmwhitespace type scalar unknown missing sort unique/;
push @keys, keys %{ delete $t->{known_keys} };
push @keys, keys %{ $t->{schema}{keys} } if $t->{schema}{keys};
@@ -178,9 +182,20 @@ sub compile {
my $c = _compile $validations, $schema, 64;
$c->{schema}{type} //= 'scalar';
- $c->{schema}{required} //= 1;
- $c->{schema}{rmwhitespace} //= 1;
+ croak "Invalid value for 'type': $c->{schema}{type}" if !$type_vals{$c->{schema}{type}};
+
+ $c->{schema}{rmwhitespace} //= 1 if $c->{schema}{type} eq 'scalar';
+
$c->{schema}{unknown} //= 'remove';
+ $c->{schema}{missing} //= 'create';
+ croak "Invalid value for 'unknown': $c->{schema}{unknown}" if !$unknown_vals{$c->{schema}{unknown}};
+ croak "Invalid value for 'missing': $c->{schema}{missing}" if !$missing_vals{$c->{schema}{missing}};
+
+ delete $c->{schema}{default} if ref $c->{schema}{default} eq 'SCALAR' && ${$c->{schema}{default}} eq 'required';
+ delete $c->{schema}{keys} if $c->{schema}{type} ne 'hash';
+ delete $c->{schema}{values} if $c->{schema}{type} ne 'array';
+ delete $c->{schema}{sort} if $c->{schema}{type} ne 'array';
+ delete $c->{schema}{unique} if $c->{schema}{type} ne 'array';
if(exists $c->{schema}{sort}) {
my $s = $c->{schema}{sort};
@@ -203,12 +218,13 @@ sub _validate_rec {
if($c->{schema}{keys}) {
my @err;
for my $k (keys %{$c->{schema}{keys}}) {
- # We need to overload the '!exists && !required && !default'
- # scenario a bit, because in that case we should not create the key
- # in the output. All other cases will be handled just fine by
- # passing an implicit 'undef'.
my $s = $c->{schema}{keys}{$k};
- next if !exists $input->{$k} && !$s->{schema}{required} && !exists $s->{schema}{default};
+ if(!exists $input->{$k}) {
+ next if $s->{schema}{missing} eq 'ignore';
+ return [$input, { validation => 'missing', key => $k }] if $s->{schema}{missing} eq 'reject';
+ $input->{$k} = ref $s->{schema}{default} eq 'CODE' ? $s->{schema}{default}->() : $s->{schema}{default} // undef;
+ next if exists $s->{schema}{default};
+ }
my $r = _validate($s, $input->{$k});
$input->{$k} = $r->[0];
@@ -289,17 +305,16 @@ sub _validate_array {
sub _validate_input {
my($c, $input) = @_;
- # rmwhitespace (needs to be done before the 'required' test)
+ # rmwhitespace (needs to be done before the 'default' test)
if(defined $input && !ref $input && $c->{schema}{type} eq 'scalar' && $c->{schema}{rmwhitespace}) {
$input =~ s/\r//g;
$input =~ s/^\s*//;
$input =~ s/\s*$//;
}
- # required & default
+ # default
if(!defined $input || (!ref $input && $input eq '')) {
- # XXX: This will return undef if !required and no default is set, even for hash and array types. Should those get an empty hash or array?
- return [exists $c->{schema}{default} ? $c->{schema}{default} : $input] if !$c->{schema}{required};
+ return [ref $c->{schema}{default} eq 'CODE' ? $c->{schema}{default}->($input) : $c->{schema}{default}] if exists $c->{schema}{default};
return [$input, { validation => 'required' }];
}
@@ -310,15 +325,16 @@ sub _validate_input {
return [$input, { validation => 'type', expected => 'hash', got => lc ref $input || 'scalar' }] if ref $input ne 'HASH';
# unknown
+ # Each branch below makes a shallow copy of the hash, so that further
+ # validations can perform in-place modifications without affecting the
+ # input.
if($c->{schema}{unknown} eq 'remove') {
$input = { map +($_, $input->{$_}), grep $c->{known_keys}{$_}, keys %$input };
} elsif($c->{schema}{unknown} eq 'reject') {
my @err = grep !$c->{known_keys}{$_}, keys %$input;
return [$input, { validation => 'unknown', keys => \@err, expected => [ sort keys %{$c->{known_keys}} ] }] if @err;
+ $input = { %$input };
} else {
- # Make a shallow copy of the hash, so that further validations can
- # perform in-place modifications without affecting the input.
- # (The other two if clauses above also ensure this)
$input = { %$input };
}
@@ -345,7 +361,7 @@ sub _validate_input {
sub _validate {
my($c, $input) = @_;
my $r = _validate_input($c, $input);
- $r->[1] && exists $c->{schema}{onerror} ? [$c->{schema}{onerror}] : $r
+ $r->[1] && exists $c->{schema}{onerror} ? [ref $c->{schema}{onerror} eq 'CODE' ? $c->{schema}{onerror}->(bless $r, 'TUWF::Validate::Result') : $c->{schema}{onerror}] : $r
}
diff --git a/lib/TUWF/Validate.pod b/lib/TUWF/Validate.pod
index 234c60f..a4a1952 100644
--- a/lib/TUWF/Validate.pod
+++ b/lib/TUWF/Validate.pod
@@ -134,7 +134,8 @@ is actually equivalent to:
{ type => 'scalar',
rmwhitespace => 1,
- required => 1
+ default => \'required',
+ missing => 'create',
}
=head2 Built-in options
@@ -143,9 +144,9 @@ is actually equivalent to:
=item type => $type
-Specify the required type of the input, this can be I<scalar>, I<array>,
-I<hash> or I<any>. If no type is specified or implied by other validations, the
-default type is I<scalar>.
+Specify the type of the input, this can be I<scalar>, I<array>, I<hash> or
+I<any>. If no type is specified or implied by other validations, the default
+type is I<scalar>.
Upon failure, the error object will look something like:
@@ -154,25 +155,24 @@ Upon failure, the error object will look something like:
got => 'scalar'
}
-=item required => 0/1
-
-Whether this input is required to have a value. Specifically, this means
-C<exists($x) && defined($x) && $x ne ''>. If the input is empty and this option
-is disabled, the I<default> option is returned when it is set, otherwise the
-input is simply returned as-is.
-
-As a corollary: Other validations will never get to validate undef or an empty
-string, these values are either rejected or substituted with a default.
-
-Note that this option is checked after I<rmwhitespace> and before any other
-validation. So a string containing only whitespace is considered an empty
-string, and will fail the I<required> test.
+=item default => $val
-Default: true.
+If not set, or set to C<\'required'> (note: scalarref), then a value is required
+for this field. Specifically, this means that a value must exist and must not
+be C<undef> or an empty string, i.e. C<exists($x) && defined($x) && $x ne ''>.
-=item default => $val
+If set to any other value, then the input is considered optional and the given
+C<$val> will be returned instead. If C<$val> is a CODE reference, the
+subroutine will be called with the original value (which is either no argument,
+undef or an empty string) and the return value of the subroutine will be used
+as value instead.
-The value to return if I<required> is false and the input is empty or undef.
+The empty check is performed after I<rmwhitespace> and before any other
+validations. So a string containing only whitespace is considered an empty
+string and will be treated according to this I<default> option. As an
+additional side effect, other validations will never get to validate undef or
+an empty string, as these values are either rejected or substituted with a
+default.
=item onerror => $val
@@ -180,6 +180,10 @@ Instead of reporting an error, return C<$val> if this input fails validation
for whatever reason. Setting this option in the top-level schema ensures that
the validation will always succeed regardless of the input.
+If C<$val> is a CODE reference, the subroutine will be called with the result
+object for this validation as its first argument. The return value of the
+subroutine will be returned for this validation.
+
=item rmwhitespace => 0/1
By default, any whitespace around scalar-type input is removed before testing
@@ -237,6 +241,23 @@ In the case of I<reject>, the error object will look like:
expected => ['known1', .. ]
}
+=item missing => $option
+
+For C<< type => 'hash' >>, this option specifies what to do with keys that have
+been defined in the I<keys> option, but which are not present in the input
+data. Possible values are I<create> to insert the key with a default value (if
+the I<default> option is set, otherwise undef), I<reject> to return an error if
+the option is missing or I<ignore> to leave the key out of the returned data.
+
+The default is I<create>, but if no I<default> option is set for this key then
+that is effectively the same as I<reject>.
+
+In the case of I<reject>, the error object will look like:
+
+ { validation => 'missing',
+ key => 'field'
+ }
+
=item values => $schema
For C<< type => 'array' >>, this defines the schema that applies to all items
@@ -404,6 +425,12 @@ C<[$minlength,$maxlength]>.
Accept any value of any type as input, and normalize it to either a C<0> or a
C<1> according to Perl's idea of truth.
+=item undefbool => 1
+
+Like C<anybool>, but missing or empty values are normalized to C<undef>. All
+other values are normalized to either C<0> or C<1> according to Perl's idea of
+truth.
+
=item jsonbool => 1
Require the input to be a boolean type returned by a JSON parser. Supported
diff --git a/lib/TUWF/Validate/Interop.pm b/lib/TUWF/Validate/Interop.pm
index cc2d1c0..4d00034 100644
--- a/lib/TUWF/Validate/Interop.pm
+++ b/lib/TUWF/Validate/Interop.pm
@@ -7,7 +7,7 @@ use Exporter 'import';
use Carp 'croak';
our @EXPORT_OK = ('analyze');
-our $VERSION = '1.4';
+our $VERSION = '1.5';
# Analyzed ("flattened") object:
@@ -22,7 +22,7 @@ sub _merge_type {
return if $o->{type} eq 'int' || $o->{type} eq 'bool';
$o->{type} = 'int' if $n eq 'int' || $n eq 'uint';
- $o->{type} = 'bool' if $n eq 'anybool' || $n eq 'jsonbool';
+ $o->{type} = 'bool' if $n eq 'anybool' || $n eq 'undefbool' || $n eq 'jsonbool';
$o->{type} = 'num' if $n eq 'num';
}
@@ -53,7 +53,7 @@ sub _merge {
sub _merge_toplevel {
my($c, $o) = @_;
- $o->{required} ||= $c->{schema}{required};
+ $o->{required} ||= !exists $c->{schema}{default};
$o->{unknown} ||= $c->{schema}{unknown};
$o->{default} = $c->{schema}{default} if exists $c->{schema}{default};
$o->{type} = $c->{schema}{type} if !$o->{type} || $o->{type} eq 'any';
@@ -150,7 +150,7 @@ sub html5_validation {
sub elm_type {
my($o, %opt) = @_;
my $par = delete $opt{_need_parens} ? sub { "($_[0])" } : sub { $_[0] };
- return $par->('Maybe ' . $o->elm_type(%opt, required => 1, _need_parens => 1)) if !$o->{required} && !defined $o->{default} && !$opt{required};
+ return $par->('Maybe ' . $o->elm_type(%opt, required => 1, _need_parens => 1)) if (ref $o->{default} eq 'CODE' || (!$o->{required} && !defined $o->{default})) && !$opt{required};
delete $opt{required};
return 'String' if $o->{type} eq 'scalar';
return 'Bool' if $o->{type} eq 'bool';
@@ -188,7 +188,7 @@ sub elm_encoder {
return sprintf '(Maybe.withDefault %snull << Maybe.map %s)',
$opt{json_encode}, $opt{values} || $o->elm_encoder(%opt, required => 1)
- if !$o->{required} && !defined $o->{default} && !$opt{required};
+ if (ref $o->{default} eq 'CODE' || (!$o->{required} && !defined $o->{default})) && !$opt{required};
delete $opt{required};
return "$opt{json_encode}string" if $o->{type} eq 'scalar';
@@ -264,8 +264,8 @@ sub elm_decoder {
' 'x($len-(length $_)),
$opt{keys}{$_} || $o->{keys}{$_}->elm_decoder(%opt, var_prefix => $var, level => $opt{level}+1);
}
- $r = sprintf "(%smap%d\n(\\%s -> { %s })\n%s)",
- $opt{json_decode}, $num, join(' ', @fnarg), join(', ', @assign), join("\n", @fetch);
+ $r = sprintf "(%smap%s\n(\\%s -> { %s })\n%s)",
+ $opt{json_decode}, $num == 1 ? '' : $num, join(' ', @fnarg), join(', ', @assign), join("\n", @fetch);
# For larger hashes we go through Json.Decode.dict and a little custom decoding logic.
# Json.Decode only allows failing with an error string, so the error messages aren't as good.
diff --git a/lib/TUWF/XML.pm b/lib/TUWF/XML.pm
index 108e1f1..d0f2efa 100644
--- a/lib/TUWF/XML.pm
+++ b/lib/TUWF/XML.pm
@@ -10,7 +10,7 @@ use Exporter 'import';
use Carp 'carp', 'croak';
-our $VERSION = '1.4';
+our $VERSION = '1.5';
our(@EXPORT_OK, %EXPORT_TAGS, $OBJ);
# List::Util provides a uniq() since 1.45, but for some reason my Perl comes
@@ -31,10 +31,10 @@ BEGIN {
button canvas caption cite code col colgroup command datagrid datalist dd
del details dfn dialog div dl dt em embed fieldset figure footer form h1 h2
h3 h4 h5 h6 head header hr i iframe img input ins kbd label legend li Link
- main Map mark meta meter nav noscript object ol optgroup option output p
+ main Map mark menu meta meter nav noscript object ol optgroup option output p
param pre progress Q rp rt ruby samp script section Select small source
- span strong style Sub sup table tbody td textarea tfoot th thead Time title
- Tr ul var video
+ span strong style Sub summary sup table tbody td textarea tfoot th thead
+ Time title Tr ul var video
|;
my @Htmltags = map ucfirst, @htmltags;
my @Html5tags = map ucfirst, @html5tags;
@@ -172,6 +172,8 @@ sub txt {
# 'tagname', id => "main" <tagname id="main">
# 'tagname', '<bar>' <tagname>&lt;bar&gt;</tagname>
# 'tagname', sub { .. } <tagname>..</tagname>
+# 'tagname', class => undef <tagname>
+# 'tagname', '+a' => 1, '+a' => 2 <tagname a="1 2">
# 'tagname', id => 'main', '<bar>' <tagname id="main">&lt;bar&gt;</tagname>
# 'tagname', id => 'main', sub { .. } <tagname id="main">..</tagname>
# 'tagname', id => 'main', undef <tagname id="main" />
@@ -183,11 +185,19 @@ sub tag {
my $indent = $s->{pretty} ? "\n".(' 'x($s->{nesting}*$s->{pretty})) : '';
my $t = $indent.'<'.$name;
+ my %concat;
while(@_ > 1) {
my $attr = shift;
- croak "Invalid XML attribute name" if !$attr || $attr =~ /^[^a-z]/i || $attr =~ / /;
- $t .= qq{ $attr="}.xml_escape(shift).'"';
+ my $val = shift;
+ next if !defined $val;
+ croak "Invalid XML attribute name" if $attr =~ /[\s'"&<>=]/; # Not comprehensive, just enough to prevent XSS-by-fucking-up-XML-structure
+ if($attr =~ /^\+(.+)/) {
+ $concat{$1} .= (length $concat{$1} ? ' ' : '') . $val;
+ } else {
+ $t .= qq{ $attr="}.xml_escape($val).'"';
+ }
}
+ $t .= qq{ $_="}.xml_escape($concat{$_}).'"' for sort keys %concat;
if(!@_) {
$s->lit($t.'>');
diff --git a/lib/TUWF/XML.pod b/lib/TUWF/XML.pod
index 1d1fafb..1f3d5b3 100644
--- a/lib/TUWF/XML.pod
+++ b/lib/TUWF/XML.pod
@@ -141,6 +141,10 @@ This is convenient when the classes are dependant on other variables, e.g.:
# $is_hidden && $is_warning: <div class="hidden warning">Text</div>
Note that the order in which classes are returned may be somewhat random.
+The above example can also be written as follows:
+
+ tag 'div', '+class' => $is_hidden ? 'hidden' : undef,
+ '+class' => $is_warning ? 'warning' : undef, 'Text';
=head2 xml_escape(string)
@@ -217,8 +221,11 @@ reference, the subroutine will be called in between the start tag and the
closing tag.
The tag name and attribute names are outputted as-is, after some very basic
-validation. The attribute values and contents are passed through
-C<xml_escape()>.
+validation. If the attribute value is C<undef>, the attribute is ignored. If
+the attribute name starts with a C<+> sign, then multiple attributes with the
+same name are concatenated together with a space.
+
+The attribute values and tag contents are passed through C<xml_escape()>.
Some example function calls and their output:
@@ -248,6 +255,9 @@ Some example function calls and their output:
};
# <div><a href="/">Home</a></div>
+ tag 'span', '+class', 'strikethrough', '+class', undef, '+class', 'bold', 'text';
+ # <span class="strikethrough bold">text</span>
+
=head2 end(name)
Closes the last tag opened by C<tag()> or C<html()>. The I<name> argument is
@@ -346,10 +356,10 @@ functions:
button canvas caption cite code col colgroup command datagrid datalist dd
del details dfn dialog div dl dt em embed fieldset figure footer form h1 h2
h3 h4 h5 h6 head header hr i iframe img input ins kbd label legend li Link
- main Map mark meta meter nav noscript object ol optgroup option output p
+ main Map mark menu meta meter nav noscript object ol optgroup option output p
param pre progress Q rp rt ruby samp script section Select small source
- span strong style Sub sup table tbody td textarea tfoot th thead Time title
- Tr ul var video
+ span strong style Sub summary sup table tbody td textarea tfoot th thead Time
+ title Tr ul var video
=item B<:Html> and B<:Html5>
diff --git a/t/interop.t b/t/interop.t
index bd7c7c9..20ea7ba 100644
--- a/t/interop.t
+++ b/t/interop.t
@@ -18,7 +18,9 @@ sub h {
}
h {}, required => 'required';
-h { required => 0 };
+h { default => 1 };
+h { default => undef };
+h { default => sub{} };
h { minlength => 1 }, required => 'required', minlength => 1;
h { maxlength => 1 }, required => 'required', maxlength => 1;
h { length => 1 }, required => 'required', minlength => 1, maxlength => 1;
@@ -26,7 +28,7 @@ h { length => [1,2] }, required => 'required', minlength => 1, maxlength => 2
h { uint => 1 }, required => 'required', pattern => TUWF::Validate::Interop::_re_compat($TUWF::Validate::re_uint);
h { email => 1 }, required => 'required', maxlength => 254, pattern => TUWF::Validate::Interop::_re_compat($TUWF::Validate::re_email);
-h { uint => 1, regex => qr/^.{3}$/ }, required => 'required', pattern => '(?=(?:^(?:0|[1-9]\d*)$))(?:^.{3}$)';
+h { uint => 1, regex => qr/^.{3}$/ }, required => 'required', pattern => '(?=(?:^(?:0|[1-9][0-9]*)$))(?:^.{3}$)';
h { min => 1 }, required => 'required', pattern => TUWF::Validate::Interop::_re_compat($TUWF::Validate::re_num), min => 1;
h { max => 1 }, required => 'required', pattern => TUWF::Validate::Interop::_re_compat($TUWF::Validate::re_num), max => 1;
@@ -54,18 +56,18 @@ my @serialized = (
[ { type => 'hash' }, {a=>1,b=>'2'}, '{"a":1,"b":"2"}' ],
[ { type => 'hash', keys => {b=>{}} }, {}, '{}' ],
[ { type => 'hash', keys => {a=>{anybool=>1},b=>{int=>1}} }, {a=>1,b=>'10'}, '{"a":true,"b":10}' ],
- [ { required => 0 }, undef, 'null' ],
- [ { required => 0, jsonbool => 1 }, undef, 'null' ],
- [ { required => 0, num => 1 }, undef, 'null' ],
- [ { required => 0, int => 1 }, undef, 'null' ],
- [ { required => 0, type => 'hash' }, undef, 'null' ],
- [ { required => 0, type => 'array' }, undef, 'null' ],
+ [ { default => undef }, undef, 'null' ],
+ [ { default => undef, jsonbool => 1 }, undef, 'null' ],
+ [ { default => undef, num => 1 }, undef, 'null' ],
+ [ { default => undef, int => 1 }, undef, 'null' ],
+ [ { default => undef, type => 'hash' }, undef, 'null' ],
+ [ { default => undef, type => 'array' }, undef, 'null' ],
);
subtest 'JSON::XS coercion', sub {
eval { require JSON::XS; 1 } or plan skip_all => 'JSON::XS not installed';
my @extra = (
- [ { type => 'num' }, '10', '10' ],
+ [ { num => 1 }, '10', '10' ],
[ { type => 'hash', keys => {a=>{anybool=>1},b=>{int=>1}} }, {a=>1,b=>'10',c=>[]}, '{"a":true,"b":10}' ],
[ { type => 'hash', unknown => 'pass', keys => {a=>{anybool=>1},b=>{int=>1}} }, {a=>1,b=>'10',c=>[]}, '{"a":true,"b":10,"c":[]}' ],
);
@@ -83,7 +85,7 @@ subtest 'JSON::XS coercion', sub {
subtest 'Cpanel::JSON::XS coercion', sub {
eval { require Cpanel::JSON::XS; require Cpanel::JSON::XS::Type; 1 } or return plan skip_all => 'Cpanel::JSON::XS not installed or too old';
my @extra = (
- [ { type => 'num' }, '10', '10.0' ],
+ [ { num => 1 }, '10', '10.0' ],
);
for (@serialized, @extra) {
my($schema, $in, $out) = @$_;
diff --git a/t/kv_validate.t b/t/kv_validate.t
index d04c73f..e4fef37 100644
--- a/t/kv_validate.t
+++ b/t/kv_validate.t
@@ -291,10 +291,10 @@ BEGIN{@tests=(
[ 0, 'a"@a.com' ],
[ 0, 'a@[:]' ],
[ 0, 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx@xxxxxxxxxxxxxxxxxxxx.xxxxxxxxxxxxxxxxxxxxxxxx.xxxxx' ],
+ [ 0, 'a@127.0.0.1' ],
+ [ 0, 'a@[::1]' ],
[ 1, 'a@a.com' ],
[ 1, 'a@a.com.' ],
- [ 1, 'a@127.0.0.1' ],
- [ 1, 'a@[::1]' ],
[ 1, 'é@yörhel.nl' ],
[ 1, 'a+_0-c@yorhel.nl' ],
[ 1, 'é@x-y_z.example' ],
diff --git a/t/validate.t b/t/validate.t
index f3315cc..eed3dd8 100644
--- a/t/validate.t
+++ b/t/validate.t
@@ -14,17 +14,22 @@ BEGIN { use_ok 'TUWF::Validate', qw/compile validate/ };
my %validations = (
hex => { regex => qr/^[0-9a-f]*$/i },
prefix => sub { my $p = shift; { func => sub { $_[0] =~ /^$p/ } } },
- bool => { required => 0, default => 0, func => sub { $_[0] = $_[0]?1:0; 1 } },
+ bool => { default => 0, func => sub { $_[0] = $_[0]?1:0; 1 } },
+ setundef => { func => sub { $_[0] = undef; 1 } },
+ defaultsub1 => { default => sub { 2 } },
+ defaultsub2 => { default => sub { defined $_[0] } },
+ onerrorsub => { onerror => sub { ref $_[0] } },
collapsews => { rmwhitespace => 0, func => sub { $_[0] =~ s/\s+/ /g; 1 } },
neverfails => { onerror => 'err' },
revnum => { type => 'array', sort => sub { $_[1] <=> $_[0] } },
uniquelength => { type => 'array', values => { type => 'array' }, unique => sub { scalar @{$_[0]} } },
person => {
type => 'hash',
- unknown => 'accept',
+ unknown => 'pass',
keys => {
name => {},
- age => { required => 0 }
+ age => { missing => 'ignore' },
+ sex => { missing => 'reject', default => 1 }
}
},
);
@@ -55,13 +60,16 @@ sub t {
}
-# required / default
+# default
t {}, 0, 0, undef;
t {}, '', '', { validation => 'required' };
t {}, undef, undef, { validation => 'required' };
-t { required => 0 }, undef, undef, undef;
-t { required => 0 }, '', '', undef;
-t { required => 0, default => '' }, undef, '', undef;
+t { default => undef }, undef, undef, undef;
+t { default => undef }, '', undef, undef;
+t { defaultsub1 => 1 }, undef, 2, undef;
+t { defaultsub2 => 1 }, undef, '', undef;
+t { defaultsub2 => 1 }, '', 1, undef;
+t { onerrorsub => 1 }, undef, 'TUWF::Validate::Result', undef;
# rmwhitespace
t {}, " Va\rl id \n ", 'Val id', undef;
@@ -86,18 +94,25 @@ t { type => 'array', unique => 1 }, [qw/3 1 2/], [qw/3 1 2/], undef;
t { type => 'array', unique => 1 }, [qw/3 1 3/], [qw/3 1 3/], { validation => 'unique', index_a => 0, value_a => 3, index_b => 2, value_b => 3, key => 3 };
t { uniquelength => 1 }, [[],[1],[1,2]], [[],[1],[1,2]], undef;
t { uniquelength => 1 }, [[],[1],[2]], [[],[1],[2]], { validation => 'unique', index_a => 1, value_a => [1], index_b => 2, value_b => [2], key => 1 };
+t { type => 'array', setundef => 1 }, [], undef, undef;
+t { type => 'array', values => { type => 'any', setundef => 1 } }, [[]], [undef], undef;
# hashes
t { type => 'hash' }, [], [], { validation => 'type', expected => 'hash', got => 'array' };
t { type => 'hash' }, 'a', 'a', { validation => 'type', expected => 'hash', got => 'scalar' };
t { type => 'hash' }, {a=>[],b=>undef,c=>{}}, {}, undef;
t { type => 'hash', keys => { a=>{} } }, {}, {a=>undef}, { validation => 'keys', errors => [{ key => 'a', validation => 'required' }] }; # XXX: the key doesn't necessarily have to be created
-t { type => 'hash', keys => { a=>{required=>0} } }, {}, {}, undef;
-t { type => 'hash', keys => { a=>{required=>0,default=>undef} } }, {}, {a=>undef}, undef;
+t { type => 'hash', keys => { a=>{missing=>'ignore'} } }, {}, {}, undef;
+t { type => 'hash', keys => { a=>{default=>undef} } }, {}, {a=>undef}, undef;
+t { type => 'hash', keys => { a=>{missing=>'create',default=>undef} } }, {}, {a=>undef}, undef;
+t { type => 'hash', keys => { a=>{missing=>'reject'} } }, {}, {}, {key => 'a', validation => 'missing'};
+
t { type => 'hash', keys => { a=>{} } }, {a=>' a '}, {a=>'a'}, undef; # Test against in-place modification
t { type => 'hash', keys => { a=>{} }, unknown => 'remove' }, { a=>1,b=>1 }, { a=>1 }, undef;
t { type => 'hash', keys => { a=>{} }, unknown => 'reject' }, { a=>1,b=>1 }, { a=>1,b=>1 }, { validation => 'unknown', keys => ['b'], expected => ['a'] };
-t { type => 'hash', keys => { a=>{} }, unknown => 'accept' }, { a=>1,b=>1 }, { a=>1,b=>1 }, undef;
+t { type => 'hash', keys => { a=>{} }, unknown => 'pass' }, { a=>1,b=>1 }, { a=>1,b=>1 }, undef;
+t { type => 'hash', setundef => 1 }, {}, undef, undef;
+t { type => 'hash', unknown => 'reject', keys => { a=>{ type => 'any', setundef => 1}} }, {a=>[]}, {a=>undef}, undef;
# default validations
t { minlength => 3 }, 'ab', 'ab', { validation => 'minlength', expected => 3, got => 2 };
@@ -113,8 +128,8 @@ t { length => [1,3] }, 'abcd', 'abcd', { validation => 'length', expected => [1,
t { type => 'array', length => 0 }, [], [], undef;
t { type => 'array', length => 1 }, [1,2], [1,2], { validation => 'length', expected => 1, got => 2 };
t { type => 'hash', length => 0 }, {}, {}, undef;
-t { type => 'hash', length => 1, unknown => 'accept' }, {qw/1 a 2 b/}, {qw/1 a 2 b/}, { validation => 'length', expected => 1, got => 2 };
-t { type => 'hash', length => 1, keys => {a => {required=>0}, b => {required=>0}} }, {a=>1}, {a=>1}, undef;
+t { type => 'hash', length => 1, unknown => 'pass' }, {qw/1 a 2 b/}, {qw/1 a 2 b/}, { validation => 'length', expected => 1, got => 2 };
+t { type => 'hash', length => 1, keys => {a => {missing=>'ignore'}, b => {missing=>'ignore'}} }, {a=>1}, {a=>1}, undef;
t { regex => '^a' }, 'abc', 'abc', undef; # XXX: Can't use qr// here because t() does dclone(). The 'hex' test covers that case anyway.
t { regex => '^a' }, 'cba', 'cba', { validation => 'regex', regex => '^a', got => 'cba' };
t { enum => [1,2] }, 1, 1, undef;
@@ -147,19 +162,18 @@ t { prefix => 'a' }, 'cba', 'cba', { validation => 'prefix', error => { validati
t { bool => 1 }, 'abc', 1, undef;
t { bool => 1 }, undef, 0, undef;
t { bool => 1 }, '', 0, undef;
-t { bool => 1, required => 1 }, undef, undef, { validation => 'required' };
-t { bool => 1, required => 1 }, 0, 0, undef;
-t { collapsews => 1, required => 0 }, " \t\n ", ' ', undef;
+t { collapsews => 1 }, " \t\n ", ' ', undef;
t { collapsews => 1 }, ' x ', ' x ', undef;
t { collapsews => 1, rmwhitespace => 1 }, ' x ', 'x', undef;
t { person => 1 }, 1, 1, { validation => 'type', expected => 'hash', got => 'scalar' };
-t { person => 1 }, {}, { name => undef }, { validation => 'person', error => { validation => 'keys', errors => [{ key => 'name', validation => 'required' }] } };
-t { person => 1 }, {name => 'x'}, { name => 'x' }, undef;
-t { person => 1, keys => {age => { required => 1 }} }, {name => 'x'}, { name => 'x', age => undef }, { validation => 'keys', errors => [{ key => 'age', validation => 'required' }] };
-t { person => 1, keys => {extra => {}} }, {name => 'x', extra => 1}, { name => 'x', extra => 1 }, undef;
-t { person => 1, keys => {extra => {}} }, {name => 'x', extra => ''}, { name => 'x', extra => '' }, { validation => 'keys', errors => [{ key => 'extra', validation => 'required' }] };
-t { person => 1 }, {name => 'x', extra => 1}, {name => 'x', extra => 1}, undef;
-t { person => 1, unknown => 'remove' }, {name => 'x', extra => 1}, {name => 'x'}, undef;
+t { person => 1, default => 1 }, undef, 1, undef;
+t { person => 1 }, { sex => 1 }, { sex => 1, name => undef }, { validation => 'person', error => { validation => 'keys', errors => [{ key => 'name', validation => 'required' }] } };
+t { person => 1 }, { sex => undef, name => 'y' }, { sex => 1, name => 'y' }, undef;
+t { person => 1, keys => {age => {default => \'required'}} }, {name => 'x', sex => 'y'}, { name => 'x', sex => 'y', age => undef }, { validation => 'keys', errors => [{ key => 'age', validation => 'required' }] };
+t { person => 1, keys => {extra => {}} }, {name => 'x', sex => 'y', extra => 1}, { name => 'x', sex => 'y', extra => 1 }, undef;
+t { person => 1, keys => {extra => {}} }, {name => 'x', sex => 'y', extra => ''}, { name => 'x', sex => 'y', extra => '' }, { validation => 'keys', errors => [{ key => 'extra', validation => 'required' }] };
+t { person => 1 }, {name => 'x', sex => 'y', extra => 1}, {name => 'x', sex => 'y', extra => 1}, undef;
+t { person => 1, unknown => 'remove' }, {name => 'x', sex => 'y', extra => 1}, {name => 'x', sex => 'y'}, undef;
t { neverfails => 1, int => 1 }, undef, 'err', undef;
t { neverfails => 1, int => 1 }, 'x', 'err', undef;
t { neverfails => 1, int => 1, onerror => undef }, 'x', undef, undef; # XXX: no way to 'unset' an inherited onerror clause, hmm.
@@ -204,10 +218,10 @@ t { email => 1 }, $_->[1], $_->[1], $_->[0] ? undef : { validation => 'email', g
[ 0, 'a @a.com' ],
[ 0, 'a"@a.com' ],
[ 0, 'a@[:]' ],
+ [ 0, 'a@127.0.0.1' ],
+ [ 0, 'a@[::1]' ],
[ 1, 'a@a.com' ],
[ 1, 'a@a.com.' ],
- [ 1, 'a@127.0.0.1' ],
- [ 1, 'a@[::1]' ],
[ 1, 'é@yörhel.nl' ],
[ 1, 'a+_0-c@yorhel.nl' ],
[ 1, 'é@x-y_z.example' ],
diff --git a/t/xml.t b/t/xml.t
index 0490a80..ed99cc6 100644
--- a/t/xml.t
+++ b/t/xml.t
@@ -12,6 +12,7 @@ is xml_string(pretty => 1, sub {
p;
b '<html &text>';
end;
+ strong a => 1, '+class' => 'abc', b => undef, '+class' => undef, c => '', '+class' => 'def', d => 2, 'txt';
};
}), '
<body t="&lt;/a&amp;>">
@@ -19,4 +20,5 @@ is xml_string(pretty => 1, sub {
<p>
<b>&lt;html &amp;text></b>
</p>
+ <strong a="1" c="" d="2" class="abc def">txt</strong>
</body>';
generated by cgit v1.2.3 (git 2.25.1) at 2024-04-20 08:35:13 +0000