Skip to content

Commit eae4f42

Browse files
manwarmanwar
authoredMar 22, 2025
Merge pull request #11753 from ppentchev/pp-313-perl
Add Peter Pentchev's Perl solutions to 313
·
wk-314
2 parents ea34316 + 1a66afc commit eae4f42

File tree

6 files changed

+359
-0
lines changed

6 files changed

+359
-0
lines changed
 

‎challenge-313/ppentchev/perl/.gitignore

+4
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
# SPDX-FileCopyrightText: Peter Pentchev <roam@ringlet.net>
2+
# SPDX-License-Identifier: BSD-2-Clause
3+
4+
.tidyall.d/

‎challenge-313/ppentchev/perl/.perlcriticrc

+6
Original file line numberDiff line numberDiff line change
@@ -13,3 +13,9 @@ theme = core
1313

1414
[Documentation::PodSpelling]
1515
spell_command = aspell --lang=en_US list
16+
17+
# We do need to match exactly the letters A-Z
18+
[-RegularExpressions::ProhibitEnumeratedClasses]
19+
20+
# We do run perltidy...
21+
[-CodeLayout::RequireTidyCode]

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

+98
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,98 @@
1+
#!/usr/bin/perl5
2+
# SPDX-FileCopyrightText: Peter Pentchev <roam@ringlet.net>
3+
# SPDX-License-Identifier: BSD-2-Clause
4+
5+
use strict;
6+
use warnings;
7+
use v5.16; ## no critic qw(ValuesAndExpressions::ProhibitVersionStrings)
8+
9+
use List::Util qw(min reduce);
10+
use Readonly;
11+
12+
use Test::More;
13+
14+
plan tests => 2;
15+
16+
sub re_escape_char($) {
17+
my ($chr) = @_;
18+
19+
if ( $chr eq q{[} || $chr eq q{]} || $chr eq q{^} ) {
20+
return "\\$chr";
21+
}
22+
23+
return "[$chr]";
24+
}
25+
26+
sub broken_keys($ $) {
27+
my ( $name, $typed ) = @_;
28+
my $pattern =
29+
q{^} . join( q{}, map { re_escape_char($_) . q{+} } split //ms, $name ) . q{$};
30+
if ( $typed =~ qr{$pattern}xms ) {
31+
return 1;
32+
}
33+
else {
34+
return 0;
35+
}
36+
}
37+
38+
Readonly my $TEST_ESCAPE_CHARS =>
39+
' ~!@#%^&*()_+`1234567890-=abcdefghijklmnopqrstuvwxyz[];m,./{}:"<>$' . q{'}; ## no critic qw(ValuesAndExpressions::RequireInterpolationOfMetachars)
40+
41+
Readonly my @TEST_BROKEN_KEYS => (
42+
[ 'perl', 'perrrl', 1 ],
43+
[ 'raku', 'rrakuuuu', 1 ],
44+
[ 'python', 'perl', 0 ],
45+
[ 'coffeescript', 'cofffeescccript', 1 ],
46+
);
47+
48+
subtest check_re_escape => sub {
49+
plan tests => length $TEST_ESCAPE_CHARS;
50+
51+
for my $chr ( split //ms, $TEST_ESCAPE_CHARS ) {
52+
subtest check_single_char => sub {
53+
plan tests => length $TEST_ESCAPE_CHARS;
54+
55+
my $pattern = q{^} . re_escape_char($chr) . q{$};
56+
my $re = qr{$pattern}xms;
57+
58+
for my $other ( split //ms, $TEST_ESCAPE_CHARS ) {
59+
subtest check_chars => sub {
60+
plan tests => 5;
61+
if ( $chr eq $other ) {
62+
ok $other =~ $re,
63+
"'$other' matches '$pattern'";
64+
}
65+
else {
66+
ok $other !~ $re,
67+
"'$other' does not match '$pattern'";
68+
}
69+
70+
ok q{} !~ $re, "'' does not match '$pattern'";
71+
72+
ok "$chr$chr" !~ $re,
73+
"'$chr$chr' does not match '$pattern'";
74+
75+
ok "$chr$other" !~ $re,
76+
"'$chr$other' does not match '$pattern'";
77+
78+
ok "$other$other" !~ $re,
79+
"'$other$other' does not match '$pattern'";
80+
}
81+
}
82+
};
83+
}
84+
};
85+
86+
subtest check_broken_keys => sub {
87+
plan tests => scalar @TEST_BROKEN_KEYS;
88+
89+
for my $tcase (@TEST_BROKEN_KEYS) {
90+
my ( $name, $typed, $expected ) = @{$tcase};
91+
if ($expected) {
92+
ok broken_keys( $name, $typed ), "'$typed' could be '$name'";
93+
}
94+
else {
95+
ok !broken_keys( $name, $typed ), "'$typed' could not be '$name'";
96+
}
97+
}
98+
};

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

+133
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,133 @@
1+
#!/usr/bin/perl5
2+
# SPDX-FileCopyrightText: Peter Pentchev <roam@ringlet.net>
3+
# SPDX-License-Identifier: BSD-2-Clause
4+
5+
use strict;
6+
use warnings;
7+
use v5.16; ## no critic qw(ValuesAndExpressions::ProhibitVersionStrings)
8+
9+
use Carp qw(croak);
10+
use English qw(--no_match_vars);
11+
use Data::Dumper;
12+
use List::Util qw(min reduce);
13+
use Readonly;
14+
15+
use Test::More;
16+
17+
plan tests => 3;
18+
19+
Readonly my $RE_STARTING_NON_LETTERS => qr{
20+
^
21+
(?P<weird> [^A-Za-z]+ )
22+
(?P<rest> .* )
23+
$
24+
}xms;
25+
26+
Readonly my $RE_LETTERS => qr{
27+
^
28+
(?P<letters> [A-Za-z]+ )
29+
(?P<others> [^A-Za-z]* )
30+
(?P<rest> .* )
31+
$
32+
}xms;
33+
34+
sub parse_letters($) {
35+
my ($str) = @_;
36+
37+
my @res;
38+
39+
if ( $str =~ $RE_STARTING_NON_LETTERS ) {
40+
push @res, [ q{}, $LAST_PAREN_MATCH{weird} ];
41+
$str = $LAST_PAREN_MATCH{rest};
42+
}
43+
44+
# Check for a non-letter at the very start
45+
while ( $str ne q{} ) {
46+
if ( $str !~ $RE_LETTERS ) {
47+
croak 'Could not parse ' . Dumper($str);
48+
}
49+
push @res, [ $LAST_PAREN_MATCH{letters}, $LAST_PAREN_MATCH{others} ];
50+
$str = $LAST_PAREN_MATCH{rest};
51+
}
52+
53+
return map { [ [ split //ms, $_->[0] ], $_->[1] ] } @res;
54+
}
55+
56+
sub reverse_parsed($) {
57+
my ($parsed) = @_;
58+
my @letters = reverse map { @{ $_->[0] } } @{$parsed};
59+
60+
my $res = q{};
61+
for my $group ( @{$parsed} ) {
62+
my $count = scalar @{ $group->[0] };
63+
$res .= join q{}, @letters[ 0 .. ( $count - 1 ) ];
64+
@letters = @letters[ $count .. $#letters ];
65+
66+
$res .= $group->[1];
67+
}
68+
return $res;
69+
}
70+
71+
sub reverse_letters($) {
72+
my ($str) = @_;
73+
my @parsed = parse_letters $str;
74+
return reverse_parsed \@parsed;
75+
}
76+
77+
Readonly my @TEST_REVERSE_LETTERS => (
78+
[
79+
'p-er?l', 'l-re?p',
80+
[ [ [q{p}], q{-} ], [ [ q{e}, q{r} ], q{?} ], [ [q{l}], q{} ] ],
81+
],
82+
[
83+
'wee-k!L-y',
84+
'yLk-e!e-w',
85+
[
86+
[ [ q{w}, q{e}, q{e} ], q{-} ],
87+
[ [q{k}], q{!} ],
88+
[ [q{L}], q{-} ],
89+
[ [q{y}], q{} ],
90+
],
91+
],
92+
[
93+
'_c-!h_all-en!g_e',
94+
'_e-!g_nel-la!h_c',
95+
[
96+
[ [], q{_} ],
97+
[ [q{c}], q{-!} ],
98+
[ [q{h}], q{_} ],
99+
[ [ q{a}, q{l}, q{l} ], q{-} ],
100+
[ [ q{e}, q{n} ], q{!} ],
101+
[ [q{g}], q{_} ],
102+
[ [q{e}], q{} ],
103+
],
104+
],
105+
);
106+
107+
subtest test_parse => sub {
108+
plan tests => scalar @TEST_REVERSE_LETTERS;
109+
for my $tcase (@TEST_REVERSE_LETTERS) {
110+
my ( $str, undef, $exp_parsed ) = @{$tcase};
111+
my @parsed = parse_letters $str;
112+
is_deeply \@parsed, $exp_parsed,
113+
'parse the string into letters and other characters';
114+
}
115+
};
116+
117+
subtest test_reverse_parsed => sub {
118+
plan tests => scalar @TEST_REVERSE_LETTERS;
119+
for my $tcase (@TEST_REVERSE_LETTERS) {
120+
my ( undef, $expected, $exp_parsed ) = @{$tcase};
121+
my $res = reverse_parsed $exp_parsed;
122+
is $res, $expected, 'build a string back out of the parsed groups';
123+
}
124+
};
125+
126+
subtest test_full => sub {
127+
plan tests => scalar @TEST_REVERSE_LETTERS;
128+
for my $tcase (@TEST_REVERSE_LETTERS) {
129+
my ( $str, $expected, undef ) = @{$tcase};
130+
my $res = reverse_letters $str;
131+
is $res, $expected, 'go all the way';
132+
}
133+
};

‎challenge-313/ppentchev/perl/format.sh

+104
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,104 @@
1+
#!/bin/sh
2+
# SPDX-FileCopyrightText: Peter Pentchev <roam@ringlet.net>
3+
# SPDX-License-Identifier: BSD-2-Clause
4+
5+
set -e
6+
7+
usage()
8+
{
9+
cat <<'EOUSAGE'
10+
Usage: format.sh check
11+
format.sh reformat
12+
format.sh -h | -V | --help | --version
13+
EOUSAGE
14+
}
15+
16+
version()
17+
{
18+
echo 'format.sh 0.1.0'
19+
}
20+
21+
show_config()
22+
{
23+
test -f .perltidyrc
24+
test -f .tidyallrc
25+
perltidy -dpro
26+
}
27+
28+
cmd_check()
29+
{
30+
set -x
31+
show_config
32+
tidyall -a --check-only
33+
}
34+
35+
cmd_reformat()
36+
{
37+
set -x
38+
show_config
39+
tidyall -a --no-backups
40+
}
41+
42+
unset show_help show_version
43+
while getopts 'hV-:' o; do
44+
case "$o" in
45+
h)
46+
show_help=1
47+
;;
48+
49+
V)
50+
show_version=1
51+
;;
52+
53+
-)
54+
case "$OPTARG" in
55+
help)
56+
show_help=1
57+
;;
58+
59+
version)
60+
show_version=1
61+
;;
62+
63+
*)
64+
echo "Unrecognized long option '--$OPTARG'" 1>&2
65+
usage 1>&2
66+
exit 1
67+
;;
68+
esac
69+
;;
70+
71+
*)
72+
usage 1>&2
73+
exit 1
74+
;;
75+
esac
76+
done
77+
shift "$((OPTIND - 1))"
78+
79+
[ -z "$show_version" ] || version
80+
[ -z "$show_help" ] || usage
81+
[ -z "$show_version$show_help" ] || exit 0
82+
83+
if [ "$#" -lt 1 ]; then
84+
echo 'No subcommand specified' 1>&2
85+
usage 1>&2
86+
exit 1
87+
fi
88+
cmd="$1"
89+
shift
90+
case "$cmd" in
91+
check)
92+
cmd_check "$@"
93+
;;
94+
95+
reformat)
96+
cmd_reformat "$#"
97+
;;
98+
99+
*)
100+
echo "Unrecognized subcommand '$cmd' specified" 1>&2
101+
usage 1>&2
102+
exit 1
103+
;;
104+
esac

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

+14
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,14 @@
1+
#!/bin/sh
2+
# SPDX-FileCopyrightText: Peter Pentchev <roam@ringlet.net>
3+
# SPDX-License-Identifier: BSD-2-Clause
4+
5+
set -e
6+
7+
echo '=== shellcheck'
8+
shellcheck format.sh run-tests.sh
9+
10+
echo '=== format check'
11+
./format.sh check
12+
13+
echo '=== prove'
14+
prove ch-*.t

0 commit comments

Comments
 (0)
Please sign in to comment.