develooper Front page | perl.perl6.users | Postings from January 2009

Scripting competition: password solution

Thread Next
From:
Richard Hainsworth
Date:
January 8, 2009 07:04
Subject:
Scripting competition: password solution
Message ID:
496615D0.5010000@rusrating.ru
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';
}



Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About