view release on metacpan or  search on metacpan

lib/Data/Validate/CSV/Column.pm  view on Meta::CPAN

			$coerce_dt = delete $dt{format};
		}
		else {
			my $fmt = delete $dt{format};
			$facets{pattern} = qr/^$fmt$/;
		}
	}
	
	my $parameterized = $xsd_type->of(%facets);
	if ($dt{'dc:title'}) {
		$parameterized = $parameterized->create_child_type(
			name => delete $dt{'dc:title'},
		);
	}
	
	delete $dt{$_} for grep /:/, keys %dt;
	die "unrecognized keys: ".join(', ', sort keys %dt)
		if keys %dt;
	
	if (defined $coerce_boolean) {
		my ($t,$f) = split /\|/, $coerce_boolean;
		$parameterized = $parameterized->plus_coercions(
			Enum[$t,$f], sprintf('0+!!($_ eq %s)', B::perlstring($t)),
		);
	}

	if (defined $coerce_numeric) {
		my %fmt = ref($coerce_numeric) ? %$coerce_numeric : (pattern => $coerce_numeric);
		$parameterized = $parameterized->plus_coercions(
			~Ref, sprintf(
				'%s->_coerce_numeric($_, %s, %s, %s)',
				map defined($_) ? B::perlstring($_) : 'undef',
					ref($self),
					@fmt{qw(pattern decimalChar groupChar)},
			),
		);
	}

	if (defined $coerce_dt) {
		$parameterized = $parameterized->plus_coercions(
			~Ref, sprintf(
				'%s->_coerce_dt($_, %s, %s)',
				map defined($_) ? B::perlstring($_) : 'undef',
					ref($self),
					$coerce_dt,
					lc($base),
			),
		);
	}
	
	return $parameterized;
}

sub _coerce_numeric {
	shift;
	my ($value, $pattern, $decimal_char, $group_char) = @_;
	$decimal_char //= '.';
	$group_char   //= ',';
	$pattern =~ s/;+$//;
	
	return  'NaN' if lc($value) eq  'nan';
	return  'INF' if lc($value) eq  'inf';
	return '-INF' if lc($value) eq '-inf';
	
	my $regexp;
	if (defined $pattern) {
		my %numeric_pattern_char = (
			'0'   => '[0-9]+',
			'#'   => '[0-9]+',
			'-'   => quotemeta('-'),
			'E'   => '[Ee]',
			'e'   => '[Ee]',
			'%'   => quotemeta('%'),
			'‰'   => quotemeta('‰'),
			$decimal_char  => quotemeta($decimal_char),
			$group_char    => quotemeta($group_char),
		);
		my @regexp;
		for my $part (split /;/, $pattern) {
			push @regexp, '';
			while (length $part) {
				my $next = substr($part, 0, 1, '');
				$regexp[-1] .= ($numeric_pattern_char{$next}
					or die "unrecognized numeric pattern char: $next");
			}
		}
		if (@regexp == 1) {
			$regexp[0] = '-?' . $regexp[0];
		}
		$regexp = join '|', map "(?:$_)", @regexp;
		$regexp = qr/^($regexp)$/;
	}
	
	if (!defined $pattern or $value =~ $regexp) {
		my $dummy = quotemeta($group_char);
		$value =~ s/$dummy//g;
		unless ($decimal_char eq '.') {
			my $dec   = quotemeta($decimal_char);
			$value =~ s/$dec/\./g;
		}
		if ($value =~ /^(.+)\%$/) {
			$value = $1 / 100;
		}
		elsif ($value =~ /^(.+)‰$/) {
			$value = $1 / 1000;
		}
	}
	
	return $value;
}

my %target_patterns = (
	datetime          => '%FT%T',
	datetimestamp     => '%FT%T%z',
	time              => '%T',
	date              => '%F',
	gyearmonth        => '%Y-%m',
	gyear             => '%Y',
	gmonthday         => '--%m-%d',
	gday              => '---%d',
	gmonth            => '--%m',