wrong pod commands
s/=pod/=begin/
s/=cut/=end/

Richard Hainsworth wrote:
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';
}

Reply via email to