view release on metacpan or  search on metacpan

lib/App/Test/Generator.pm  view on Meta::CPAN

		next unless ref($aref) eq 'ARRAY';

		# Render each array element via perl_quote so strings are
		# properly quoted and numbers are left unquoted
		my $vals = join(', ', map { perl_quote($_) } @{$aref});

		# Use "\t" rather than a literal tab for clarity
		push @entries, "\t" . perl_quote($k) . " => [ $vals ]";
	}

	return join(",\n", @entries);
}

# --------------------------------------------------
# _has_positions
#
# Purpose:    Determine whether any field in an input
#             spec hashref declares a positional argument
#             via the 'position' key.
#
# Entry:      $input_spec - the input section of a parsed
#             schema, expected to be a hashref whose values
#             are themselves hashrefs containing field specs.
#             May be undef or a non-hash ref.
#
# Exit:       Returns 1 if any field has a defined
#             'position' key, 0 otherwise.
#
# Side effects: None.
#
# Notes:      Returns 0 immediately for undef or non-hash
#             input rather than throwing — callers use the
#             return value as a boolean and do not expect
#             exceptions from this function.
# --------------------------------------------------
sub _has_positions {
	my $input_spec = $_[0];

	# Guard against undef or non-hash input — keys %$undef would throw
	return 0 unless defined($input_spec) && ref($input_spec) eq 'HASH';

	for my $field (keys %{$input_spec}) {
		# Only examine fields whose spec is a hashref — scalar specs
		# (e.g. input: { type: string }) cannot have positions
		next unless ref($input_spec->{$field}) eq 'HASH';

		# Return immediately on first match — no need to scan further
		return 1 if defined $input_spec->{$field}{position};
	}

	# No positional arguments found in any field
	return 0;
}

# --------------------------------------------------
# q_wrap
#
# Purpose:    Wrap a string in the most readable
#             q{} form that does not require escaping,
#             falling back to single-quoted form with
#             escaped apostrophes if no delimiter is
#             available.
#
# Entry:      $s - the string to wrap. May be undef.
# Exit:       Returns a Perl source-code fragment that
#             evaluates to the original string value,
#             or the string 'undef' if $s is undef.
#
# Side effects: None.
#
# Notes:      index() returns -1 when not found and
#             any value >= 0 when found, including 0
#             for a delimiter at the start of the
#             string. We compare against $INDEX_NOT_FOUND
#             to make this boundary explicit and to
#             prevent off-by-one mutation survivors.
#             See GitHub issue #1.
# --------------------------------------------------
sub q_wrap {
	my $s = $_[0];

	croak('q_wrap: argument must be a plain string, not a reference') if ref($s);

	# Return empty string for undef — this function is a low-level
	# string quoter only. Callers that need the Perl literal 'undef'
	# for undefined values should use perl_quote() instead, which
	# handles the undef -> 'undef' semantic conversion correctly.
	# Returning '' here preserves the original behaviour and avoids
	# injecting the bare word 'undef' into contexts that expect a
	# quoted string value.
	return "''" unless defined $s;

	# Try bracket-form q{} delimiters first — most readable
	for my $p (@Q_BRACKET_PAIRS) {
		my ($l, $r) = @{$p};

		# Only use this bracket pair if neither bracket
		# appears in the string — both must be checked
		return "q$l$s$r" unless $s =~ /\Q$l\E|\Q$r\E/;
	}

	# Try single-character delimiters in preference order
	for my $d (@Q_SINGLE_DELIMITERS) {
		# index() returns $INDEX_NOT_FOUND (-1) when not found.
		# Must use != $INDEX_NOT_FOUND rather than > 0 since
		# the delimiter may legitimately appear at position 0
		return "q$d$s$d" if index($s, $d) == $INDEX_NOT_FOUND;
	}

	# Last resort — single-quoted string with escaped apostrophes
	(my $esc = $s) =~ s/'/\\'/g;
	return "'$esc'";
}

# --------------------------------------------------
# perl_sq
#
# Purpose:    Escape a string for safe inclusion
#             inside a single-quoted Perl string
#             literal in generated test code.
#
# Entry:      $s - the string to escape.
# Exit:       Returns the escaped string, or an
#             empty string if $s is undef.
#
# Side effects: None.
#
# Notes:      NUL byte replacement produces the
#             two-character sequence \0 which is
#             only correct when the result is used
#             inside a double-quoted string context
#             in the generated test.
#
#             The \b substitution (backspace) is
#             intentionally omitted — in Perl regex
#             context \b means word boundary, not
#             backspace, so substituting it here
#             would corrupt strings containing word
#             boundaries.
# --------------------------------------------------
sub perl_sq {
	my $s = $_[0];

	croak('perl_sq: argument must be a plain string, not a reference') if ref($s);

	# Return empty string for undef — callers that need
	# 'undef' literal should use perl_quote instead
	return '' unless defined $s;

	# Escape backslashes first so later substitutions
	# don't double-escape already-escaped sequences
	$s =~ s/\\/\\\\/g;

	# Escape apostrophes so they don't terminate the
	# surrounding single-quoted string literal
	$s =~ s/'/\\'/g;

	# Escape common control characters to their
	# printable two-character escape sequences
	$s =~ s/\n/\\n/g;
	$s =~ s/\r/\\r/g;
	$s =~ s/\t/\\t/g;
	$s =~ s/\f/\\f/g;

	# Replace NUL bytes with \0 — valid only in
	# double-quoted string context in generated code
	$s =~ s/\0/\\0/g;

	return $s;
}

=head2 perl_quote

Convert any Perl value into a source-code fragment that reproduces that value
when evaluated in a generated test file.

=head3 Arguments

=over 4

=item * C<$v>

Any Perl value. May be undef, a scalar, an arrayref, a Regexp, or a blessed
object. All types are handled — undef becomes C<'undef'>, numbers are
unquoted, strings are single-quoted, arrayrefs recurse, Regexps become
C<qr{...}>, and anything else falls through to C<render_fallback>.

=back

=head3 API specification

=head4 input

    { v => { type => 'any', optional => 1 } }

=head4 output

    { type => 'string' }

=cut

sub perl_quote {
	my ($v) = @_;
	return _perl_quote($v, 0);
}

sub _perl_quote {
	my ($v, $depth) = @_;
	croak('perl_quote: structure too deeply nested (circular reference?)') if $depth > 100;

	# Undef produces the Perl literal 'undef'
	return 'undef' unless defined $v;

	# Convert YAML boolean string literals to Perl
	# boolean constants so they survive round-tripping
	return '!!1' if $v eq 'true';
	return '!!0' if $v eq 'false';

	if(ref($v)) {