diff options
| -rwxr-xr-x | challenge-099/jo-37/perl/ch-1.pl | 118 | ||||
| -rwxr-xr-x | challenge-099/jo-37/perl/ch-2.pl | 107 |
2 files changed, 225 insertions, 0 deletions
diff --git a/challenge-099/jo-37/perl/ch-1.pl b/challenge-099/jo-37/perl/ch-1.pl new file mode 100755 index 0000000000..5125ed3951 --- /dev/null +++ b/challenge-099/jo-37/perl/ch-1.pl @@ -0,0 +1,118 @@ +#!/usr/bin/perl -s + +use v5.20; +use Test2::V0; +use experimental 'signatures'; + +our ($tests, $examples, $verbose); + +run_tests() if $tests || $examples; # does not return + +die <<EOS unless @ARGV == 2; +usage: $0 [-examples] [-tests] [-verbose] [string pattern] + +-examples + run the examples from the challenge + +-tests + run some tests + +-verbose + print generated regex + +string + string to be matched against pattern + +pattern + shell-like pattern + +Use '?' inside pattern to match one arbitrary character, '*' to match +any number of characters and '\\' to interpret the following single +character literally. + +EOS + + +### Input and Output + +say patmatch($ARGV[0], $ARGV[1]) + 0; + + +### Implementation + +# Convert pattern part to regex: +# * -> .* +# ? -> . +# \x -> x +# other: quote if necessary +# +# Processes $_. +sub convmeta { + return '.*?' if /^\*$/; + return '.' if /^\?$/; + return quotemeta $1 if /^\\(.)$/; + # else: + quotemeta; +} + +# Match string against pattern. Pattern meta characters are: +# ? : match one character +# * : match any number of characters +# \ : use next character literally +# The special treatment of quoted characters is beyond the specification +# of this task but it seems to be useful and needful. +sub patmatch ($str, $pat) { + + # Convert pattern to regex. + my $re = sub {qr/^ @_ $/x}->( + map convmeta, + $pat =~ m{ + \G # start at previous end-of-match position and + ( # capture + [^*?\\]+ # a group of non-meta chars + | # or + [*?] # a meta-char + | # or + \\. # a quoted char + ) + }gx); + # Reject incomplete patterns. + die "invalid pattern: '$'' in '$pat'" if $'; + + say "pattern: '$pat'\nregex: $re" if $verbose; + + $str =~ $re; +} + + +### Examples and tests + +sub run_tests { + SKIP: { + skip "examples" unless $examples; + ok patmatch('abcde', 'a*e'), 'example 1'; + ok !patmatch('abcde', 'a*d'), 'example 2'; + ok !patmatch('abcde', '?b*d'), 'example 3'; + ok patmatch('abcde', 'a*c?e'), 'example 4'; + } + + SKIP: { + skip "tests" unless $tests; + ok patmatch('ch-1.pl', '*.pl'), 'literal dot matches'; + ok !patmatch('ch-1-pl', '*.pl'), 'literal dot only matches dot'; + ok patmatch('abc.*', '*.\*'), 'literal asterisk matches'; + ok !patmatch('abc.pl', '*.\*'), 'literal asterisk required'; + ok patmatch('ch-[12].pl', '*-[12].pl'), 'literal charclass matches'; + ok !patmatch('ch-1.pl', '*-[12].pl'), 'literal charclass required'; + ok patmatch('ch-1.pl', '*.\p\l'), 'escaped characters'; + ok patmatch('ab\\cd', '??\\\\??'), 'escaped backslash'; + ok patmatch('abbccdde', 'a?*?*?e'), 'matching consecutive meta chars'; + ok !patmatch('abde', 'a?*?*?e'), 'non-matching consecuteive meta chars'; + ok patmatch('äöü', 'ä?ü'), 'handle multi-byte characters'; + like dies {patmatch('ab', 'ab\\')}, qr/invalid pattern/, + 'incomplete quoting sequence'; + } + + done_testing; + exit; +} diff --git a/challenge-099/jo-37/perl/ch-2.pl b/challenge-099/jo-37/perl/ch-2.pl new file mode 100755 index 0000000000..9f7e22f188 --- /dev/null +++ b/challenge-099/jo-37/perl/ch-2.pl @@ -0,0 +1,107 @@ +#!/usr/bin/perl -s + +use v5.16; +use Test2::V0; +use experimental 'signatures'; +use charnames ':full'; + +our ($tests, $examples, $verbose); + +run_tests() if $tests || $examples; # does not return + +die <<EOS unless @ARGV == 2; +usage: $0 [-examples] [-tests] [-verbose] [string sequence] + +-examples + run the examples from the challenge + +-tests + run some tests + +-verbose + show subsequence in string + +string + string to examine + +sequence + sequence of chars to search for in <string> + +EOS + + +### Input and Output + +say matchseq($ARGV[0], $ARGV[1]); + + +### Implementation + +# Count occurences of a character sequence within a string. +sub matchseq ($str, $seq) { + + # Create a regex that matches the character sequence and captures + # all of its characters individually. + # Example transformation chain: + # 'x*' -> ('x', '*') -> ('x', '\\*') -> (?:(x).*?(\*)) + my $seqmatch = sub { + local $" = ').*?('; + qr{(@_)}; + }->(map quotemeta, split //, $seq); + + # Find all sequence matches and collect the character match offsets. + my @match; + $str =~ m{ $seqmatch (?{push @match, [@-]}) (*FAIL) }x; + + explainseq($str, $seq, $seqmatch, \@match) if $verbose; + + # Return the number of matches. + scalar @match; +} + +# Show the locations of the character sequence within the string. +sub explainseq ($str, $seq, $re, $matches) { + + say "sequence: '$seq'"; + say "matcher: $re"; + say $str; + + for my $match (@$matches) { + + # Discard match offset, keeping submatches only. (See @-) + shift @$match; + + # Prepare a string having the same length as $str. + my $seqloc = "\N{MIDDLE DOT}" x length $str; + + # Overwrite the string at match offsets with chars from the + # sequence. + while (my ($idx, $offs) = each @$match) { + substr($seqloc, $offs, 1) = substr($seq, $idx, 1); + } + say $seqloc; + } +} + +### Examples and tests + +sub run_tests { +SKIP: { + skip "examples" unless $examples; + is matchseq('littleit', 'lit'), 5, 'example 1'; + is matchseq('london', 'lon'), 3, 'example 2'; +} + +SKIP: { + skip "tests" unless $tests; + is matchseq('xxaxxbxxcxx', 'abc'), 1, 'unique sequence'; + is matchseq('aaaaa', 'a'), 5, 'repetition'; + is matchseq('ihgfedcba', 'def'), 0, 'not found'; + is matchseq('a.b*c[d0e-f9g]h', '.*[0-9]'), 1, 'meta characters'; + is matchseq('aa1', '.*[0-9]'), 0, 'not matching "regex"'; + is matchseq('a.b.c', '.'), 2, 'matching literal dot' + } + + done_testing; + exit; +} |