File Coverage

blib/lib/Mock/Data/Charset.pm

Criterion	Covered	Total	%
statement	312	374	83.4
branch	190	258	73.6
condition	78	139	56.1
subroutine	40	46	86.9
pod	16	16	100.0
total	636	833	76.3

package Mock::Data::Charset;
use strict;
use warnings;
use Mock::Data::Util qw( _parse_context _escape_str );
require Carp;
our @CARP_NOT= ('Mock::Data::Util');
require Mock::Data::Generator;
our @ISA= ( 'Mock::Data::Generator' );

# ABSTRACT: Generator of strings from a set of characters
our $VERSION = '0.02'; # VERSION


our @generator_attrs= qw( str_len min_codepoint max_codepoint );

sub new {
	my $class= shift;
	my (%self, %parse);
	# make the common case fast
	if (@_ == 1 && !ref $_[0]) {
		qr/[$_[0]]/;
		%self= ( notation => $_[0] );
		if (ref $class) {
			$self{generator_opts} ||= { %{ $class->{generator_opts} } };
			$self{max_codepoint}  //= $class->{max_codepoint};
			$class= ref $class;
		}
		return bless \%self, $class;
	}

	%self= @_ != 1? @_ : %{$_[0]};

	# Look for fields from the parser
	$parse{classes}= delete $self{classes} if defined $self{classes};
	$parse{codepoints}= delete $self{codepoints} if defined $self{codepoints};
	$parse{codepoint_ranges}= delete $self{codepoint_ranges} if defined $self{codepoint_ranges};
	$parse{negate}= delete $self{negate} if defined $self{negate};
	if (defined $self{chars}) {
		push @{$parse{codepoints}}, map ord, @{$self{chars}};
		delete $self{chars};
	}
	if (defined $self{ranges}) {
		push @{$parse{codepoint_ranges}},
			map +( ref $_? ( ord $_->[0], ord $_->[1] ) : ord ),
				@{$self{ranges}};
		delete $self{ranges};
	}

	# If called on an object, carry over some settings
	if (ref $class) {
		if (!keys %parse && !defined $self{notation} && !$self{members} && !$self{member_invlist}) {
			@self{'_parse','notation','members','member_invlist'}=
				@{$class}{'_parse','notation','members','member_invlist'};
		}
		$self{$_} //= $class->{$_} for @generator_attrs;
		$class= ref $class;
	}

	if (defined $self{notation} && !keys %parse) {
		# want to trigger the syntax error exception now, not lazily later on
		qr/[$self{notation}]/;
	}
	elsif (keys %parse) {
		$self{_parse}= \%parse;
		Carp::croak("Charset-building options (classes, chars, codepoints, ranges, codepoint_ranges, negate)"
			." cannot be combined with members, member_invlist or notation attributes")
			if $self{members} or $self{member_invlist}; # allow notation to preserve original text
	}
	else {
		# At least one of members, member_invlist, notation, or _parse must be specified
		Carp::croak("Require at least one of members, member_invlist, notation, or charset-building options")
			unless $self{members} or $self{member_invlist};
	}

	return bless \%self, $class;
}

sub _parse {
	# If the '_parse' wasn't initialized, it can be derived from members or member_invlist or notation
	$_[0]{_parse} || do {
		my $self= shift;
		if (defined $self->{notation}) {
			$self->{_parse}= $self->parse($self->{notation});
		}
		elsif ($self->{members}) {
			$self->{_parse}{codepoints}= [ map ord, @{$self->{members}} ];
		}
		elsif (my $inv= $self->{member_invlist}) {
			my $i;
			for ($i= 0; $i < $#$inv; $i+= 2) {
				if ($inv->[$i] + 1 == $inv->[$i+1]) { push @{$self->{_parse}{codepoints}}, $inv->[$i] }
				else { push @{$self->{_parse}{codepoint_ranges}}, $inv->[$i], $inv->[$i+1] - 1; }
			}
			if ($i == $#$inv) {
				push @{$self->{_parse}{codepoint_ranges}}, $inv->[$i], ($self->max_codepoint || 0x10FFFF);
			}
		}
		else { die "Unhandled lazy-build scenario" }
		$self->{_parse};
	};
}


sub notation {
	$_[0]{notation} //= _deparse_charset($_[0]->_parse);
}


sub min_codepoint {
	$_[0]{min_codepoint}= $_[1] if @_ > 1;
	$_[0]{min_codepoint}
}
sub max_codepoint {
	$_[0]{max_codepoint}
}


sub str_len {
	$_[0]{str_len}= $_[1] if @_ > 1;
	$_[0]{str_len};
}


sub count {
	$_[0]{members}? scalar @{$_[0]{members}}
		: $_[0]->_invlist_index->[-1];
}


sub members {
	$_[0]{members} ||= $_[0]->_build_members;
}

sub _build_members {
	my $self= shift;
	my $invlist= $self->member_invlist;
	my @members;
	if (@$invlist > 1) {
		push @members, map chr, $invlist->[$_*2] .. ($invlist->[$_*2+1]-1)
			for 0 .. (($#$invlist-1)>>1);
	}
	# an odd number of elements means the list ends with an "include-all"
	push @members, map chr, $invlist->[-1] .. 0x10FFFF
		if 1 & @$invlist;
	return \@members;
}

sub Mock::Data::Charset::Util::expand_invlist {
	my $invlist= shift;
	my @members;
	if (@$invlist > 1) {
		push @members, $invlist->[$_*2] .. ($invlist->[$_*2+1]-1)
			for 0 .. (($#$invlist-1)>>1);
	}
	# an odd number of elements means the list ends with an "include-all"
	push @members, $invlist->[-1] .. 0x10FFFF
		if 1 & @$invlist;
	return \@members;
}

# The index is private because there's not a good way to explain it to the user
sub _invlist_index {
	my $self= shift;
	$self->{_invlist_index} ||= Mock::Data::Charset::Util::create_invlist_index($self->member_invlist);
}

sub Mock::Data::Charset::Util::create_invlist_index {
	my $invlist= shift;
	my $n_spans= (@$invlist + 1) >> 1;
	my @index;
	$#index= $n_spans-1;
	my $total= 0;
	$index[$_]= $total += $invlist->[$_*2+1] - $invlist->[$_*2]
		for 0 .. (@$invlist >> 1)-1;
	if (@$invlist & 1) { # In the case that the final range is infinite
		$index[$n_spans-1]= $total + 0x110000 - $invlist->[-1];
	}
	\@index;
}


sub member_invlist {
	if (@_ > 1) {
		$_[0]{member_invlist}= $_[1];
		delete $_[0]{_invlist_index};
		delete $_[0]{members};
		delete $_[0]{notation};
	}
	$_[0]{member_invlist} //= _build_member_invlist(@_);
}

sub _build_member_invlist {
	my $self= shift;
	my $max_codepoint= $self->max_codepoint;
	# If the search space is small, and there is already a regex notation, it is probably faster
	# to iterate and let perl do the work than to parse the charset.
	my $invlist;
	if (!defined $max_codepoint || $max_codepoint > 1000 || !defined $self->{notation}) {
		$max_codepoint ||= 0x10FFFF;
		$invlist= eval {
			_parsed_charset_to_invlist($self->_parse, $max_codepoint);
		}# or main::diag $@
	}
	$invlist ||= _charset_invlist_brute_force($self->notation, $max_codepoint);
	# If a user writes to the invlist, it will become out of sync with the Index,
	# leading to confusing bugs.
	if (Internals->can('SvREADONLY')) {
		Internals::SvREADONLY($_,1) for @$invlist;
		Internals::SvREADONLY(@$invlist,1);
	}
	return $invlist;
}

# Lazy-built string of all basic-multilingual-plane characters
our $_ascii_chars;
our $_unicode_chars;
sub _build_unicode_chars {
	unless (defined $_unicode_chars) {
		# Construct ranges of valid characters separated by NUL.
		# Older perls die when the regex engine encounters an invalid character
		# but newer perls just treat the invalid character as "not a member",
		# unless the set is a negation in which case non-characters *are* a member.
		# This makes the assumption that if a non-char isn't a member then \0 won't
		# be either.
		$_unicode_chars= '';
		$_unicode_chars .= chr($_) for 0 .. 0xD7FF;
		$_unicode_chars .= "\0";
		$_unicode_chars .= chr($_) for 0xFDF0 .. 0xFFFD;
		for (1..16) {
			$_unicode_chars .= "\0";
			$_unicode_chars .= chr($_) for ($_<<16) .. (($_<<16)|0xFFFD);
		}
	}
	\$_unicode_chars;
}

sub _charset_invlist_brute_force {
	my ($set, $max_codepoint)= @_;
	my $inv= (ord $set == ord '^')? substr($set,1) : '^'.$set;
	my @invlist;

	# optimize common case
	if ($max_codepoint < 256) {
		# Find first character of every match and first character of every non-match
		# and convert to codepoints.
		@invlist= map +(defined $_? ord($_) : ()),
			($_ascii_chars //= join('', map chr($_), 0..255))
				=~ / ( [$set] ) (?> [$set]* ) (?: \z | ( [$inv] ) (?> [$inv]* ) )/gx;
	}
	else {
		_build_unicode_chars() unless defined $_unicode_chars;
		# This got complicated while trying to support perls that can't match against non-characters.
		# The non-characters have been replaced by NULs, so need to capture the char before and after
		# each transition in case one of them is a NUL.
		my @endpoints=
			($max_codepoint < 0x10FFFF? substr($_unicode_chars,0,$max_codepoint+1) : $_unicode_chars)
				=~ /( [$set] ) ( [$set] )* ( \z | [$inv] ) ( [$inv] )* /gx;
		if (@endpoints) {
			# List is a multiple of 4 elements: (first-member,last-member,first-non-member,last-non-member)
			# We're not interested in the span of non-members at the end, so just remove those.
			pop @endpoints; pop @endpoints;
			# Iterate every transition of member/nonmember, and use the second character if present
			# and isn't a NUL, else use the first character and add 1.
			push @invlist, ord $endpoints[0];
			for (my $i= 1; $i < @endpoints; $i+= 2) {
				if (defined $endpoints[$i+1] && ord $endpoints[$i+1]) {
					push @invlist, ord $endpoints[$i+1];
				} elsif (defined $endpoints[$i]) {
					push @invlist, 1 + ord $endpoints[$i];
				} else {
					push @invlist, 1 + $invlist[-1];
				}
			}
			# substr is an estimate, because string skips characters, so remove any spurrous
			# codepoints beyond the max
			pop @invlist while @invlist && $invlist[-1] > $max_codepoint;
		}
	}
	# If an "infinite" range would be returned, but the user set a maximum codepoint,
	# list the max codepoint as the end of the invlist.
	if ($max_codepoint < 0x10FFFF and 1 & @invlist) {
		push @invlist, $max_codepoint+1;
	}
	return \@invlist;
}

sub _parsed_charset_to_invlist {
	my ($parse, $max_codepoint)= @_;
	my @invlists;
	# convert the character list into an inversion list
	if (defined (my $cp= $parse->{codepoints})) {
		my @chars= sort { $a <=> $b } @$cp;
		my @invlist= (shift @chars);
		push @invlist, $invlist[0] + 1;
		for (my $i= 0; $i <= $#chars; $i++) {
			# If the next char is adjacent, extend the span
			if ($invlist[-1] == $chars[$i]) {
				++$invlist[-1];
			} else {
				push @invlist, $chars[$i], $chars[$i]+1;
			}
		}
		push @invlists, \@invlist;
	}
	# Each range is an inversion list already
	if (my $r= $parse->{codepoint_ranges}) {
		for (my $i= 0; $i < (@$r >> 1); $i++) {
			my ($start, $limit)= ($r->[$i*2], $r->[$i*2+1]+1);
			# Try to combine the range with the most recent inversion list, if possible,
			if (@invlists && $invlists[-1][-1] < $start) {
				push @{ $invlists[-1] }, $start, $limit;
			} elsif (@invlists && $invlists[-1][0] > $limit) {
				unshift @{ $invlists[-1] }, $start, $limit;
			} else {
				# else just start a new inversion list
				push @invlists, [ $start, $limit ]
			}
		}
	}
	# Convert each character class to an inversion list.
	if ($parse->{classes}) {
		push @invlists, _class_invlist($_)
			for @{ $parse->{classes} };
	}
	my $invlist= Mock::Data::Charset::Util::merge_invlists(\@invlists, $max_codepoint);
	# Perform negation of inversion list by either starting at char 0 or removing char 0
	if ($parse->{negate}) {
		if ($invlist->[0]) { unshift @$invlist, 0 }
		else { shift @$invlist; }
	}
	return $invlist;
}


our $_compile;
sub compile {
	local $_compile= 1;
	shift->generate(@_);
}
sub generate {
	my ($self, $mock)= (shift, shift);
	my ($len, $cp_min, $cp_max, $member_count)
		= ($self->str_len, $self->min_codepoint, $self->max_codepoint, $self->count);
	if (@_) {
		my %opts= ref $_[0] eq 'HASH'? %{ shift() } : ();
		$len= @_? shift : $opts{str_len} // $opts{len} // $opts{size}; # allow some aliases for length
		$cp_min= $opts{min_codepoint} // $cp_min;
		$cp_max= $opts{max_codepoint} // $cp_max;
	}
	my ($memb_min, $memb_span)= !defined $cp_min && !defined $cp_max? (0,$member_count)
		: $self->_codepoint_minmax_to_member_range($cp_min, $cp_max);

	# If compiling, $len will be a function, else it will be an integer
	$len= !defined $len? ($_compile? sub { 1 } : 1 )
		: !ref $len? ($_compile? sub { $len } : $len)
		: ref $len eq 'ARRAY'? (
			$_compile? sub { $len->[0] + int rand ($len->[1] - $len->[0]) }
			: $len->[0] + int rand ($len->[1] - $len->[0])
		)
		: ref $len eq 'CODE'? ($_compile? $len : $len->($mock))
		: Carp::croak("Unknown str_len specification '$len'");

	# If member list is small-ish, use faster direct array access
	if ($self->{members} || $member_count < 500) {
		my $members= $self->members;
		return sub {
			my $buf= '';
			$buf .= $members->[$memb_min + int rand $memb_span]
				for 1..$len->($_[0]);
			return $buf;
		} if $_compile;
		my $buf= '';
		$buf .= $members->[$memb_min + int rand $memb_span]
			for 1..$len;
		return $buf;
	}
	else {
		my $invlist= $self->member_invlist;
		my $index= $self->_invlist_index;
		return sub {
			my $ret= '';
			$ret .= chr _get_invlist_element($memb_min + int rand($memb_span), $invlist, $index)
				for 1..$len->($_[0]);
		} if $_compile;
		my $buf= '';
		$buf .= chr _get_invlist_element($memb_min + int rand($memb_span), $invlist, $index)
			for 1..$len;
		return $buf;
	}
}

sub _codepoint_minmax_to_member_range {
	my $self= shift;
	my ($cp_min, $cp_max)= @_;
	my $memb_min= !defined $cp_min? 0
		: do {
			my ($at, $ins)= _find_invlist_element($cp_min, $self->member_invlist, $self->_invlist_index);
			$at // $ins
		};
	my $memb_lim= !defined $cp_max? $self->count
		: do {
			my ($at, $ins)= _find_invlist_element($cp_max, $self->member_invlist, $self->_invlist_index);
			defined $at? $at + 1 : $ins;
		};
	return ($memb_min, $memb_lim-$memb_min);
}


sub parse {
	my ($self, $notation)= @_;
	return { codepoints => [] } unless length $notation;
	return { classes => ['All'] } if $notation eq '^';
	$notation .= ']';
	# parse function needs $_ to be the input string
	pos($notation)= 0;
	return _parse_charset() for $notation;
}

our $have_prop_invlist;
our %_parse_charset_backslash= (
	a => ord "\a",
	b => ord "\b",
	c => sub { die "Unimplemented: \\c" },
	d => sub { push @{$_[0]{classes}}, 'digit'; undef; },
	D => sub { push @{$_[0]{classes}}, '^digit'; undef; },
	e => ord "\e",
	f => ord "\f",
	h => sub { push @{$_[0]{classes}}, 'horizspace'; undef; },
	H => sub { push @{$_[0]{classes}}, '^horizspace'; undef; },
	n => ord "\n",
	N => \&_parse_charset_namedchar,
	o => \&_parse_charset_oct,
	p => \&_parse_charset_classname,
	P => sub { _parse_charset_classname(shift, 1) },
	r => ord "\r",
	s => sub { push @{$_[0]{classes}}, 'space'; undef; },
	S => sub { push @{$_[0]{classes}}, '^space'; undef; },
	t => ord "\t",
	v => sub { push @{$_[0]{classes}}, 'vertspace'; undef; },
	V => sub { push @{$_[0]{classes}}, '^vertspace'; undef; },
	w => sub { push @{$_[0]{classes}}, 'word'; undef; },
	W => sub { push @{$_[0]{classes}}, '^word'; undef; },
	x => \&_parse_charset_hex,
	0 => \&_parse_charset_oct,
	1 => \&_parse_charset_oct,
	2 => \&_parse_charset_oct,
	3 => \&_parse_charset_oct,
	4 => \&_parse_charset_oct,
	5 => \&_parse_charset_oct,
	6 => \&_parse_charset_oct,
	7 => \&_parse_charset_oct,
	8 => \&_parse_charset_oct,
	9 => \&_parse_charset_oct,
);
our %_class_invlist_cache= (
	'Any' => [ 0 ],
	'\\N' => [ 0, ord("\n"), 1+ord("\n") ],
);
sub _class_invlist {
	my $class= shift;
	if (ord $class == ord '^') {
		return Mock::Data::Charset::Util::negate_invlist(
			_class_invlist(substr($class,1))
		);
	}
	return $_class_invlist_cache{$class} ||= do {
		$have_prop_invlist= do { require Unicode::UCD; !!Unicode::UCD->can('prop_invlist') }
			unless defined $have_prop_invlist;
		$have_prop_invlist? [ Unicode::UCD::prop_invlist($class) ]
			: _charset_invlist_brute_force("\\p{$class}", 0x10FFFF);
	};
}
sub _parse_charset_hex {
	/\G( [0-9A-Fa-f]{2} | \{ ([0-9A-Fa-f]+) \} )/gcx
		or die "Invalid hex escape at "._parse_context;
	return hex(defined $2? $2 : $1);
}
sub _parse_charset_oct {
	--pos; # The caller ate one of the characters we need to parse
	/\G( [0-7]{3} | 0 | o\{ ([0-7]+) \} ) /gcx
		or die "Invalid octal escape at "._parse_context;
	return oct(defined $2? $2 : $1);
}
sub _parse_charset_namedchar {
	require charnames;
	/\G \{ ([^}]+) \} /gcx
#		or die "Invalid named char following \\N at '".substr($_,pos,10)."'";
		and return charnames::vianame($1);
	# Plain "\N" means every character except \n
	push @{ $_[0]{classes} }, '\\N';
	return;
}
sub _parse_charset_classname {
	my ($result, $negate)= @_;
	/\G \{ ([^}]+) \} /gcx
		or die "Invalid class name following \\p at "._parse_context;
	push @{$result->{classes}}, lc($negate? "^$1" : $1);
	undef
}
sub _parse_charset {
	my $flags= shift;
	# argument is in $_, starting from pos($_)
	my %parse;
	my @range;
	$parse{codepoints}= \my @chars;
	$parse{negate}= 1 if /\G \^ /gcx;
	if (/\G]/gc) { push @chars, ord ']' }
	while (1) {
		my $cp; # literal codepoint to be added
		# Check for special cases
		if (/\G ( \\ | - | \[: | \] ) /gcx) {
			if ($1 eq '\\') {
				/\G(.)/gc or die "Unexpected end of input";
				$cp= $_parse_charset_backslash{$1} || ord $1;
				$cp= $cp->(\%parse)
					if ref $cp;
			}
			elsif ($1 eq '-') {
				if (@range == 1) {
					push @range, ord '-';
					next;
				}
				else {
					$cp= ord '-';
				}
			}
			elsif ($1 eq '[:') {
				/\G ( [^:]+ ) :] /gcx
					or die "Invalid character class at "._parse_context;
				push @{$parse{classes}}, $1;
			}
			else {
				last; # $1 eq ']';
			}
		}
		elsif ($flags && ($flags->{x}||0) >= 2 && /\G[ \t]/gc) {
			next; # ignore space and tab under /xx
		}
		else {
			/\G(.)/gc or die "Unexpected end of input";
			$cp= ord $1;
		}
		# If no single character was found, any range-in-progress needs converted to
		# charcters
		if (!defined $cp) {
			push @chars, @range;
			@range= ();
		}
		# At this point, $cp will contain the next ordinal of the character to include,
		# but it might also be starting or finishing a range.
		elsif (@range == 1) {
			push @chars, $range[0];
			$range[0]= $cp;
		}
		elsif (@range == 2) {
			push @{$parse{codepoint_ranges}}, $range[0], $cp;
			@range= ();
		}
		else {
			push @range, $cp;
		}
		#printf "# pos %d  cp %d  range %s %s  include %s\n", pos $_, $cp, $range[0] // '(null)', $range[1] // '(null)', join(',', @include);
	}
	push @chars, @range;
	if (@chars) {
		@chars= sort { $a <=> $b } @chars;
	} else {
		delete $parse{codepoints};
	}
	return \%parse;
}

sub _ord_to_safe_regex_char {
	return chr($_[0]) =~ /[\w]/? chr $_[0]
		: $_[0] <= 0xFF? sprintf('\x%02X',$_[0])
		: sprintf('\x{%X}',$_[0])
}

sub _deparse_charset {
	my $parse= shift;
	my $str= '';
	if (my $cp= $parse->{codepoints}) {
		$str .= _ord_to_safe_regex_char($_)
			for @$cp;
	}
	if (my $r= $parse->{codepoint_ranges}) {
		for (my $i= 0; $i < (@$r << 1); $i++) {
			$str .= _ord_to_safe_regex_char($r->[$i*2]) . '-' . _ord_to_safe_regex_char($r->[$i*2+1]);
		}
	}
	if (my $cl= $parse->{classes}) {
		# TODO: reverse conversions to \h \v etc.
		for (@$cl) {
			$str .= $_ eq '\N'? '\0-\x09\x0B-\x{10FFFF}'
				: ord == ord '^'? '\P{'.substr($_,1).'}'
				: '\p{'.$_.'}';
		}
	}
	return $str;
}


sub get_member {
	$_[0]{members}? $_[0]{members}[$_[1]]
		: chr _get_invlist_element($_[1], $_[0]->member_invlist, $_[0]->_invlist_index);
}

sub get_member_codepoint {
	$_[0]{members}? ord $_[0]{members}[$_[1]]
		: _get_invlist_element($_[1], $_[0]->member_invlist, $_[0]->_invlist_index);
}

sub _get_invlist_element {
	my ($ofs, $invlist, $invlist_index)= @_;
	$ofs += @$invlist_index if $ofs < 0;
	return undef if $ofs >= $invlist_index->[-1] || $ofs < 0;
	# Binary Search to find the range that contains this numbered element
	my ($min, $max, $mid)= (0, $#$invlist_index);
	while (1) {
		$mid= ($min+$max) >> 1;
		if ($ofs >= $invlist_index->[$mid]) {
			$min= $mid+1
		}
		elsif ($mid > 0 && $ofs < $invlist_index->[$mid-1]) {
			$max= $mid-1
		}
		else {
			$ofs -= $invlist_index->[$mid-1] if $mid > 0;
			return $invlist->[$mid*2] + $ofs;
		}
	}
}


sub find_member {
	my ($self, $char)= @_;
	return _find_invlist_element(ord $char, $self->member_invlist, $self->_invlist_index);
}

sub _find_invlist_element {
	my ($codepoint, $invlist, $index)= @_;
	# Binary Search to find the range that contains this numbered element
	my ($min, $max, $mid)= (0, $#$invlist);
	while (1) {
		$mid= ($min+$max) >> 1;
		if ($mid > 0 && $codepoint < $invlist->[$mid]) {
			$max= $mid-1
		}
		elsif ($mid < $#$invlist && $codepoint >= $invlist->[$mid+1]) {
			$min= $mid+1;
		}
		else {
			return (undef, 0) unless $codepoint >= $invlist->[$mid];
			return $codepoint - $invlist->[$mid] unless $mid > 0;
			return $codepoint - $invlist->[$mid] + $index->[($mid >> 1) - 1] unless $mid & 1;
			# if $mid is an odd number, the range is excluded, and there is no match
			return undef unless wantarray;
			return (undef, $index->[($mid-1)>>1]) # return insertion point as second val
		}
	}
}


sub negate {
	my $self= shift;
	my $neg= Mock::Data::Charset::Util::negate_invlist($self->member_invlist, $self->max_codepoint);
	return $self->new(member_invlist => $neg);
}
sub Mock::Data::Charset::Util::negate_invlist {
	my ($invlist, $max_codepoint)= @_;
	# Toggle first char of 0
	$invlist= $invlist->[0]? [ 0, @$invlist ] : [ @{$invlist}[1..$#$invlist] ];
	# If max_codepoint is defined, and was the final char, remove the range starting at max_codepoint+1
	if (@$invlist & 1 and defined $max_codepoint and $invlist->[-1] == $max_codepoint+1) {
		pop @$invlist;
	}
	return $invlist;
}


sub union {
	my $self= $_[0];
	my @invlists= @_;
	ref eq 'ARRAY' || ($_= $_->member_invlist)
		for @invlists;
	my $combined= Mock::Data::Charset::Util::merge_invlists(\@invlists, $self->max_codepoint);
	return $self->new(member_invlist => $combined);
}

#=head2 merge_invlists
#
#  my $combined_invlist= $charset->merge_invlist( \@list2, \@list3, ... );
#  my $combined_invlist= merge_invlist( \@list1, \@list2, ... );
#
#Merge one or more inversion lists into a superset of all of them.
#If called as a method, the L is used as the first list.
#
#The return value is an inversion list, which can be wrapped in a Charset object by passing it
#as the C attribute.
#
#The current L applies to the result.  If called as a plain function, the
#C is assumed to be the Unicode maximum of C<0x10FFFF>.
#
#=cut

sub Mock::Data::Charset::Util::merge_invlists {
	my @invlists= @{shift()};
	my $max_codepoint= shift // 0x10FFFF;

	return [] unless @invlists;
	return [@{$invlists[0]}] unless @invlists > 1;
	my @combined= ();
	# Repeatedly select the minimum range among the input lists and add it to the result
	my @pos= (0)x@invlists;
	while (@invlists) {
		my ($min_ch, $min_i)= ($invlists[0][$pos[0]], 0);
		# Find which inversion list contains the lowest range
		for (my $i= 1; $i < @invlists; $i++) {
			if ($invlists[$i][$pos[$i]] < $min_ch) {
				$min_ch= $invlists[$i][$pos[$i]];
				$min_i= $i;
			}
		}
		last if $min_ch > $max_codepoint;
		# Check for overlap of this new inclusion range with the previous
		if (@combined && $combined[-1] >= $min_ch) {
			# they overlap, so just replace the end-codepoint of the range
			# if the new endpoint is larger
			my $new_end= $invlists[$min_i][$pos[$min_i]+1];
			$combined[-1]= $new_end if !defined $new_end || $combined[-1] < $new_end;
		}
		else {
			# else, simply append the range
			push @combined, @{$invlists[$min_i]}[$pos[$min_i] .. $pos[$min_i]+1];
		}
		# If the list is empty now, remove it from consideration
		if (($pos[$min_i] += 2) >= @{$invlists[$min_i]}) {
			splice @invlists, $min_i, 1;
			splice @pos, $min_i, 1;
			# If the invlist ends with an infinite range now, we are done
			if (!defined $combined[-1]) {
				pop @combined;
				last;
			}
		}
		# If this is the only list remaining, append the rest and done
		elsif (@invlists == 1) {
			push @combined, @{$invlists[0]}[$pos[0] .. $#{$invlists[0]}];
			last;
		}
	}
	while ($combined[-1] > $max_codepoint) {
		pop @combined;
	}
	# If the list ends with inclusion, and the max_codepoint is less than unicode max,
	# end the list with it.
	if (1 & @combined and $max_codepoint < 0x10FFFF) {
		push @combined, $max_codepoint+1;
	}
	return \@combined;
}

1;

__END__