Add Peter Pentchev's Perl solutions to 313

challenge-313/ppentchev/perl/.gitignore

@@ -0,0 +1,4 @@
+# SPDX-FileCopyrightText: Peter Pentchev <[email protected]>
+# SPDX-License-Identifier: BSD-2-Clause
+
+.tidyall.d/

challenge-313/ppentchev/perl/.perlcriticrc

@@ -13,3 +13,9 @@ theme = core
 
 [Documentation::PodSpelling]
 spell_command = aspell --lang=en_US list
+
+# We do need to match exactly the letters A-Z
+[-RegularExpressions::ProhibitEnumeratedClasses]
+
+# We do run perltidy...
+[-CodeLayout::RequireTidyCode]

challenge-313/ppentchev/perl/ch-1.t

@@ -0,0 +1,98 @@
+#!/usr/bin/perl5
+# SPDX-FileCopyrightText: Peter Pentchev <[email protected]>
+# SPDX-License-Identifier: BSD-2-Clause
+
+use strict;
+use warnings;
+use v5.16;    ## no critic qw(ValuesAndExpressions::ProhibitVersionStrings)
+
+use List::Util qw(min reduce);
+use Readonly;
+
+use Test::More;
+
+plan tests => 2;
+
+sub re_escape_char($) {
+	my ($chr) = @_;
+
+	if ( $chr eq q{[} || $chr eq q{]} || $chr eq q{^} ) {
+		return "\\$chr";
+	}
+
+	return "[$chr]";
+}
+
+sub broken_keys($ $) {
+	my ( $name, $typed ) = @_;
+	my $pattern =
+		q{^} . join( q{}, map { re_escape_char($_) . q{+} } split //ms, $name ) . q{$};
+	if ( $typed =~ qr{$pattern}xms ) {
+		return 1;
+	}
+	else {
+		return 0;
+	}
+}
+
+Readonly my $TEST_ESCAPE_CHARS =>
+	' ~!@#%^&*()_+`1234567890-=abcdefghijklmnopqrstuvwxyz[];m,./{}:"<>$' . q{'};    ## no critic qw(ValuesAndExpressions::RequireInterpolationOfMetachars)
+
+Readonly my @TEST_BROKEN_KEYS => (
+	[ 'perl',         'perrrl',          1 ],
+	[ 'raku',         'rrakuuuu',        1 ],
+	[ 'python',       'perl',            0 ],
+	[ 'coffeescript', 'cofffeescccript', 1 ],
+);
+
+subtest check_re_escape => sub {
+	plan tests => length $TEST_ESCAPE_CHARS;
+
+	for my $chr ( split //ms, $TEST_ESCAPE_CHARS ) {
+		subtest check_single_char => sub {
+			plan tests => length $TEST_ESCAPE_CHARS;
+
+			my $pattern = q{^} . re_escape_char($chr) . q{$};
+			my $re      = qr{$pattern}xms;
+
+			for my $other ( split //ms, $TEST_ESCAPE_CHARS ) {
+				subtest check_chars => sub {
+					plan tests => 5;
+					if ( $chr eq $other ) {
+						ok $other =~ $re,
+							"'$other' matches '$pattern'";
+					}
+					else {
+						ok $other !~ $re,
+							"'$other' does not match '$pattern'";
+					}
+
+					ok q{} !~ $re, "'' does not match '$pattern'";
+
+					ok "$chr$chr" !~ $re,
+						"'$chr$chr' does not match '$pattern'";
+
+					ok "$chr$other" !~ $re,
+						"'$chr$other' does not match '$pattern'";
+
+					ok "$other$other" !~ $re,
+						"'$other$other' does not match '$pattern'";
+				}
+			}
+		};
+	}
+};
+
+subtest check_broken_keys => sub {
+	plan tests => scalar @TEST_BROKEN_KEYS;
+
+	for my $tcase (@TEST_BROKEN_KEYS) {
+		my ( $name, $typed, $expected ) = @{$tcase};
+		if ($expected) {
+			ok broken_keys( $name, $typed ), "'$typed' could be '$name'";
+		}
+		else {
+			ok !broken_keys( $name, $typed ), "'$typed' could not be '$name'";
+		}
+	}
+};

challenge-313/ppentchev/perl/ch-2.t

@@ -0,0 +1,133 @@
+#!/usr/bin/perl5
+# SPDX-FileCopyrightText: Peter Pentchev <[email protected]>
+# SPDX-License-Identifier: BSD-2-Clause
+
+use strict;
+use warnings;
+use v5.16;    ## no critic qw(ValuesAndExpressions::ProhibitVersionStrings)
+
+use Carp    qw(croak);
+use English qw(--no_match_vars);
+use Data::Dumper;
+use List::Util qw(min reduce);
+use Readonly;
+
+use Test::More;
+
+plan tests => 3;
+
+Readonly my $RE_STARTING_NON_LETTERS => qr{
+    ^
+        (?P<weird> [^A-Za-z]+ )
+        (?P<rest> .* )
+    $
+}xms;
+
+Readonly my $RE_LETTERS => qr{
+    ^
+        (?P<letters> [A-Za-z]+ )
+        (?P<others> [^A-Za-z]* )
+        (?P<rest> .* )
+    $
+}xms;
+
+sub parse_letters($) {
+	my ($str) = @_;
+
+	my @res;
+
+	if ( $str =~ $RE_STARTING_NON_LETTERS ) {
+		push @res, [ q{}, $LAST_PAREN_MATCH{weird} ];
+		$str = $LAST_PAREN_MATCH{rest};
+	}
+
+	# Check for a non-letter at the very start
+	while ( $str ne q{} ) {
+		if ( $str !~ $RE_LETTERS ) {
+			croak 'Could not parse ' . Dumper($str);
+		}
+		push @res, [ $LAST_PAREN_MATCH{letters}, $LAST_PAREN_MATCH{others} ];
+		$str = $LAST_PAREN_MATCH{rest};
+	}
+
+	return map { [ [ split //ms, $_->[0] ], $_->[1] ] } @res;
+}
+
+sub reverse_parsed($) {
+	my ($parsed) = @_;
+	my @letters = reverse map { @{ $_->[0] } } @{$parsed};
+
+	my $res = q{};
+	for my $group ( @{$parsed} ) {
+		my $count = scalar @{ $group->[0] };
+		$res .= join q{}, @letters[ 0 .. ( $count - 1 ) ];
+		@letters = @letters[ $count .. $#letters ];
+
+		$res .= $group->[1];
+	}
+	return $res;
+}
+
+sub reverse_letters($) {
+	my ($str) = @_;
+	my @parsed = parse_letters $str;
+	return reverse_parsed \@parsed;
+}
+
+Readonly my @TEST_REVERSE_LETTERS => (
+	[
+		'p-er?l', 'l-re?p',
+		[ [ [q{p}], q{-} ], [ [ q{e}, q{r} ], q{?} ], [ [q{l}], q{} ] ],
+	],
+	[
+		'wee-k!L-y',
+		'yLk-e!e-w',
+		[
+			[ [ q{w}, q{e}, q{e} ], q{-} ],
+			[ [q{k}],               q{!} ],
+			[ [q{L}],               q{-} ],
+			[ [q{y}],               q{} ],
+		],
+	],
+	[
+		'_c-!h_all-en!g_e',
+		'_e-!g_nel-la!h_c',
+		[
+			[ [],                   q{_} ],
+			[ [q{c}],               q{-!} ],
+			[ [q{h}],               q{_} ],
+			[ [ q{a}, q{l}, q{l} ], q{-} ],
+			[ [ q{e}, q{n} ],       q{!} ],
+			[ [q{g}],               q{_} ],
+			[ [q{e}],               q{} ],
+		],
+	],
+);
+
+subtest test_parse => sub {
+	plan tests => scalar @TEST_REVERSE_LETTERS;
+	for my $tcase (@TEST_REVERSE_LETTERS) {
+		my ( $str, undef, $exp_parsed ) = @{$tcase};
+		my @parsed = parse_letters $str;
+		is_deeply \@parsed, $exp_parsed,
+			'parse the string into letters and other characters';
+	}
+};
+
+subtest test_reverse_parsed => sub {
+	plan tests => scalar @TEST_REVERSE_LETTERS;
+	for my $tcase (@TEST_REVERSE_LETTERS) {
+		my ( undef, $expected, $exp_parsed ) = @{$tcase};
+		my $res = reverse_parsed $exp_parsed;
+		is $res, $expected, 'build a string back out of the parsed groups';
+	}
+};
+
+subtest test_full => sub {
+	plan tests => scalar @TEST_REVERSE_LETTERS;
+	for my $tcase (@TEST_REVERSE_LETTERS) {
+		my ( $str, $expected, undef ) = @{$tcase};
+		my $res = reverse_letters $str;
+		is $res, $expected, 'go all the way';
+	}
+};

challenge-313/ppentchev/perl/format.sh

@@ -0,0 +1,104 @@
+#!/bin/sh
+# SPDX-FileCopyrightText: Peter Pentchev <[email protected]>
+# SPDX-License-Identifier: BSD-2-Clause
+
+set -e
+
+usage()
+{
+	cat <<'EOUSAGE'
+Usage:  format.sh check
+	format.sh reformat
+	format.sh -h | -V | --help | --version
+EOUSAGE
+}
+
+version()
+{
+	echo 'format.sh 0.1.0'
+}
+
+show_config()
+{
+	test -f .perltidyrc
+	test -f .tidyallrc
+	perltidy -dpro
+}
+
+cmd_check()
+{
+	set -x
+	show_config
+	tidyall -a --check-only
+}
+
+cmd_reformat()
+{
+	set -x
+	show_config
+	tidyall -a --no-backups
+}
+
+unset show_help show_version
+while getopts 'hV-:' o; do
+	case "$o" in
+		h)
+			show_help=1
+			;;
+
+		V)
+			show_version=1
+			;;
+
+		-)
+			case "$OPTARG" in
+				help)
+					show_help=1
+					;;
+
+				version)
+					show_version=1
+					;;
+
+				*)
+					echo "Unrecognized long option '--$OPTARG'" 1>&2
+					usage 1>&2
+					exit 1
+					;;
+			esac
+			;;
+
+		*)
+			usage 1>&2
+			exit 1
+			;;
+	esac
+done
+shift "$((OPTIND - 1))"
+
+[ -z "$show_version" ] || version
+[ -z "$show_help" ] || usage
+[ -z "$show_version$show_help" ] || exit 0
+
+if [ "$#" -lt 1 ]; then
+	echo 'No subcommand specified' 1>&2
+	usage 1>&2
+	exit 1
+fi
+cmd="$1"
+shift
+case "$cmd" in
+	check)
+		cmd_check "$@"
+		;;
+
+	reformat)
+		cmd_reformat "$#"
+		;;
+
+	*)
+		echo "Unrecognized subcommand '$cmd' specified" 1>&2
+		usage 1>&2
+		exit 1
+		;;
+esac

challenge-313/ppentchev/perl/run-tests.sh

@@ -0,0 +1,14 @@
+#!/bin/sh
+# SPDX-FileCopyrightText: Peter Pentchev <[email protected]>
+# SPDX-License-Identifier: BSD-2-Clause
+
+set -e
+
+echo '=== shellcheck'
+shellcheck format.sh run-tests.sh
+
+echo '=== format check'
+./format.sh check
+
+echo '=== prove'
+prove ch-*.t