File Coverage

blib/lib/Mock/Data/Util.pm

Criterion	Covered	Total	%
statement	58	63	92.0
branch	43	54	79.6
condition	5	6	83.3
subroutine	11	14	78.5
pod	7	7	100.0
total	124	144	86.1

package Mock::Data::Util;
use Exporter::Extensible -exporter_setup => 1;
export(qw(
	uniform_set weighted_set inflate_template coerce_generator mock_data_subclass
	charset template _parse_context _escape_str _dump
));
require Scalar::Util;
require Carp;
our @CARP_NOT= qw( Mock::Data Mock::Data::Generator );

# ABSTRACT: Exportable functions to assist with declaring mock data
our $VERSION = '0.03'; # VERSION


sub uniform_set {
	return Mock::Data::Set->new(items => [@_]);
}

sub weighted_set {
	my $i= 0;
	return Mock::Data::Set->new_weighted(@_);
}

sub charset {
	return Mock::Data::Charset->new(@_);
}


sub template {
	Mock::Data::Template->new(@_);
}

sub inflate_template {
	my ($tpl)= @_;
	# If it does not contain '{', return as-is.  Else parse.
	return $tpl if index($tpl, '{') == -1;
	local $@;
	my $cmp= eval { Mock::Data::Template->new($tpl) };
	# If the template "compiled" to a simple scalar, return the scalar.  Else return the generator.
	return !$cmp? $tpl : ref $cmp->{_compiled}? $cmp : $cmp->{_compiled};
}


sub coerce_generator {
	my ($spec)= @_;
	!defined $spec?          Carp::croak("Can't coerce undef to a generator")
	: !ref $spec?            Mock::Data::Template->new($spec)
	: ref $spec eq 'ARRAY'?  Mock::Data::Set->new(items => [map &_maybe_coerce_set_item, @$spec])
	: ref $spec eq 'HASH'?   weighted_set(%$spec)
	: ref $spec eq 'CODE'?   Mock::Data::GeneratorSub->new($spec)
	: ref($spec)->can('generate')? $spec
	: ref $spec eq 'Regexp'? Mock::Data::Regex->new($spec)
	: Carp::croak("Don't know how to make '$spec' into a generator");
}
sub _maybe_coerce_set_item {
	!ref($_)? inflate_template($_)
	: ref($_) eq 'ARRAY'? Mock::Data::Set->new(items => [map &_maybe_coerce_set_item, @$_])
	: coerce_generator($_);
}


sub mock_data_subclass {
	my $self= shift;
	my $class= ref $self || $self;
	my @to_add= grep !$class->isa($_), @_;
	# Nothing to do if already part of this class/object
	return $self unless @to_add;
	# Determine what the new @ISA will be
	my @new_isa= defined $Mock::Data::auto_subclasses{$class}
		? @{$Mock::Data::auto_subclasses{$class}}
		: ($class);
	# Remove redundant classes
	for my $next_class (@to_add) {
		next if grep $_->isa($next_class), @new_isa;
		@new_isa= grep !$next_class->isa($_), @new_isa;
		push @new_isa, $next_class;
	}
	# If only one class remains, then this one class already defined an inheritance for all
	# the others.  Use it directly.
	my $new_class;
	if (@new_isa == 1) {
		$new_class= $new_isa[0];
	} else {
		# Now find if this combination was already composed, else create it.
		$new_class= _name_for_combined_isa(@new_isa);
		if (!$Mock::Data::auto_subclasses{$new_class}) {
			no strict 'refs';
			@{"${new_class}::ISA"}= @new_isa;
			$Mock::Data::auto_subclasses{$new_class}= \@new_isa;
		}
	}
	return ref $self? bless($self, $new_class) : $new_class;
}

# When choosing a name for a new @ISA list, the name could be something as simple as ::AUTO$n
# with an incrementing number, but that wouldn't be helpful in a stack dump.  But, a package
# name fully containing the ISA package names could get really long and also be unhelpful.
# Compromise by shortening the names by removing Mock::Data prefix and removing '::' and '_'.
# If this results in a name collision (seems unlikely), add an incrementing number on the end.
sub _name_for_combined_isa {
	my @parts= grep { $_ ne 'Mock::Data' } @_;
	my $isa_key= join "\0", @parts;
	for (@parts) {
		$_ =~ s/^Mock::Data:://;
		$_ =~ s/::|_//g;
	}
	my $class= join '_', 'Mock::Data::_AUTO', @parts;
	my $iter= 0;
	my $suffix= '';
	# While iterating, check to see if that package uses the same ISA list as this new request.
	while (defined $Mock::Data::auto_subclasses{$class . $suffix}
		&& $isa_key ne join("\0",
			grep { $_ ne 'Mock::Data' } @{$Mock::Data::auto_subclasses{$class . $suffix}}
		)
	) {
		$suffix= '_' . ++$iter;
	}
	$class . $suffix;
}

# For those cases where Data::Dumper is both overkill and insufficient...
my %_escape_common= ( "\n" => '\n', "\t" => '\t', "\0" => '\0' );
sub _escape_str {
	my $str= shift;
	$str =~ s/([^\x20-\x7E])/ $_escape_common{$1} || sprintf("\\x{%02X}",ord $1) /ge;
	return $str;
}
sub _dump;
sub _dump {
	local $_= shift if @_;
	!defined $_? 'undef'
	: !ref $_? (Scalar::Util::looks_like_number($_)? $_ : '"'._escape_str($_).'"')
	: ref $_ eq 'ARRAY'? '['.join(', ', map _dump, @$_).']'
	: ref $_ eq 'HASH'? do {
		my $hash= $_;
		'{'.join(', ', map {
			($_ =~ /^\w+\z/? $_ : '"'._escape_str($_).'"')
			.' => '._dump($hash->{$_})
		} sort keys %$hash).'}';
	}
	: "$_"
}
sub _parse_context {
	return '"' . _escape_str(substr($_, defined $_[0]? $_[0] : pos, 10)) .'"';
}

# included last, because they depend on this module.
require Mock::Data::Set;
require Mock::Data::Charset;
require Mock::Data::Regex;
require Mock::Data::Template;
require Mock::Data::GeneratorSub;

__END__