Here's a solution to the scripting competition test. Patrick suggested
publishing solutions somewhere, including this list.
#!/usr/local/bin/perl6
=pod
Patrick Michaud suggested
(http://use.perl.org/~pmichaud/journal/38134?from=rss) writing
solutions to
scripting game definitions as a way of experimenting with perl6.
This program is a suggested solution to event 5, strong passwords, in
the scripting games. The scenario is described at
http://www.microsoft.com/technet/scriptcenter/funzone/games/games08/aevent5.mspx
So here is my first attempt. I have kept to the definition in the
competition, even though this means hard coding the top score (13) and
evaluation points (11,7).
Although I suppose part of the competition is to get funcky ways of
solving the problem, I just used a straightforward implimentation of
the tests.
They are so easy in perl6! The only real problem is to associate a
test with the string to be printed when a test fails.
=cut
use v6;
my $pw = @*ARGS[0];
my @msg;
# Here we have an array of rules that if matched yield a test failure
as per the game, and the error string to go with it.
my @rules = (
[{!(10 < .chars < 20)},'Length is under 10 or over 20 characters'],
# Note the .chars! This will be called as the argument of a when
clause and so $_ will contain the value of $pw.
[ / ^ <-digit>+ $ / , 'Does not contain a digit'],
=pod
I think this is so neat! It took a while and an email from Patrick to
find.
<digit> is supplied by PGE (perl6 grammar engine). So by definition,
<-digit> is not a digit.
A string that does not contain a digit will consist entirely of
non-digits. Hence by "stretching" the
match pattern from the start ^ of the string to the end of the string
$ with a pattern containing
as many chars as necessary +, we match a string without a single digit.
=cut
[ / ^ <-upper>+ $ / , 'Does not contain an upper case letter'],
[ / ^ <-lower>+ $ / , 'Does not contain an lower case letter'],
[ / ^ <alnum>+ $ / , 'Does not contain a symbol character'],
[ / <lower> **4 / , 'Four or more lower case characters in
succession'],
[ / <upper> **4 / , 'Four or more upper case characters in
succession'],
[ / (.) [.+] $0 / , 'A duplicate character with same case is used']
);
=pod
Developing and testing a pattern that yielded a duplicate character
ignoring case was so easy it took two minutes to
work out and test.
In order to see how a pattern would work out, I compiled perl6 to an
executable and put a link to it in /usr/local/bin
then perl6 on the command line in a console and something like
>my $x='abcedeA';$x~~m/<upper>/??say 'M' !! say 'NM'
M
The > is the prompt from perl6. The M is the response.
What's nice is that a simple cursor-up brings back the previous line
for experimenting.
see below for why the next section is commented out
=cut
#my @rules4list = (
# ['', m/ (:i $pw) /,'Matches a real word'],
# ['s/^ . (.*) $ / $0 /', / (:i $pw) /, 'Matches a real word
without the first character'],
# ['s/^ (.*) . $/ $0 /', / (:i $pw) /,'Matches a real word without
the last character'],
# ['tr/O/0/', / (:i $pw) /, 'Matches a real word with digit 0 in
place of letter O'],
# ['tr/l/1/', / (:i $pw) /, 'Matches a real word with digit 1 in
place of letter l']
#);
#my $orig;
if $pw { # trap zero-length passwords
=pod
This commented out section does not work because three things do not
appear to have been implimented:
a) m/$pw/ matching a scalar. According to S05 the should be passed raw
to the matching engine and treated as a string if it does not contain
a rule
b) s///
c) tr///
It might not work even so due to some error I've missed.
=cut
# my $words = open('wordlist.txt', :r) or die $!;
# for =$words {
# for @rules4list -> @r {
# $orig = $_;
# eval(@r[0]);
# when @r[1] { push @msg, @r[2] }
# };
# };
given $pw {
for @rules -> @r {
when @r[0] { push @msg, @r[1] }
}
};
=pod
Isnt perl6 compact? Five lines to run all the tests against $pw and
capture any error messages
'given' moves the password automatically to $_
'for' takes each of the array and puts it into @r, in this case
another array because @rules is an array of arrays
'when' applies the test statement to $_, and if a boolean true is the
result, the next block pushes the message onto the array
Note that one of the tests was a bare block, which is treated as code,
while the others were bare regexen. when does the rest
Since an error message is pushed onto the array for each failure
condition, the size of the array gives the score.
=cut
say 'A password score of '
~ 13 - @msg.elems
~ ' indicates a '
~ (given 13 - @msg.elems {
when $_ > 10 { 'strong'}
when $_ > 7 { 'moderately strong'}
default { 'weak' }
})
~ ' password';
=pod
Here I used the fact that the value of a 'given' block is the value of
the last block. Since a 'when' block 'breaks' out of the block when
'called', it is easy
to create three (in this case) strings depending on the three
condtions and interpolate them directly into the say string.
=cut
for @msg {.say};
=pod
This is all I need to print out on separate lines an entire array!
=cut
} else {
say 'No password given';
}
