static rotors

4 files changed, 243 insertions, 0 deletions

diff --git a/lib/DAKKAR/p.pm b/lib/DAKKAR/p.pm
new file mode 100644
index 0000000..ced4be8
--- /dev/null
+++ b/lib/DAKKAR/p.pm
@@ -0,0 +1,102 @@
+package DAKKAR::p;
+use 5.012;
+use strict;
+use warnings;
+use utf8 ();
+use feature ();
+use true ();
+use TryCatch ();
+use Carp ();
+use Sub::Import ();
+use namespace::autoclean;
+use B::Hooks::EndOfScope;
+use Hook::AfterRuntime;
+use autobox ();
+use Moose::Autobox ();
+
+sub import {
+    my ($class,@opts) = @_;
+    my $caller = caller;
+
+    strict->import();
+    warnings->import('FATAL'=>'all');
+    feature->import( ':5.12' );
+    utf8->import($caller);
+    true->import();
+    TryCatch->import({into=>$caller});
+    Sub::Import->import('Carp',{into=>$caller});
+    Moose::Autobox->import();
+
+    for (@opts) {
+        when ('class') {
+            require Moose;
+            require MooseX::Params::Validate;
+            Moose->import({into=>$caller});
+            MooseX::Params::Validate->import({into=>$caller});
+            after_runtime {
+                $caller->meta->make_immutable;
+            }
+        };
+        when ('role') {
+            require Moose::Role;
+            require MooseX::Params::Validate;
+            Moose::Role->import({into=>$caller});
+            MooseX::Params::Validate->import({into=>$caller});
+        };
+        when ('exporter') {
+            on_scope_end {
+                __PACKAGE__->mark_as_method('import',$caller);
+            }
+        };
+        when ('test') {
+            require lib;
+            lib->import('t/lib');
+            # yes, this is ugly, but I couldn't find a better way;
+            eval <<"MAGIC" or die "Couldn't set up testing policy: $@";
+package $caller;
+use Test::Most '-Test::Deep';
+use Test::Deep '!blessed';
+use Data::Printer;
+1;
+MAGIC
+        }
+    }
+
+    # this must come after the on_scope_end call above, otherwise the
+    # clean happens before the mark_as_method, and 'import' is cleaned
+    # even though we don't want it to be
+    namespace::autoclean->import(
+        -cleanee => $caller,
+    );
+}
+
+sub mark_as_method {
+    my ($self,$method_name,$class)=@_;
+
+    $class //= caller;
+
+    my $meta=Class::MOP::Class->initialize($class);
+    return if $meta->has_method($method_name);
+    my $code = $meta->get_package_symbol({
+        name  => $method_name,
+        sigil => '&',
+        type  => 'CODE',
+    });
+
+    do { warn "$method_name not found as a CODE symbol!"; return }
+        unless defined $code;
+
+    $meta->add_method(
+        $method_name => (
+            $meta->wrap_method_body(
+                associated_metaclass => $meta,
+                name => $method_name,
+                body => $code,
+            ),
+        )
+    );
+
+    return;
+}
+
+1;
diff --git a/lib/Enigmatic/Rotor.pm b/lib/Enigmatic/Rotor.pm
new file mode 100644
index 0000000..a600b43
--- /dev/null
+++ b/lib/Enigmatic/Rotor.pm
@@ -0,0 +1,50 @@
+package Enigmatic::Rotor;
+use DAKKAR::p 'class';
+use Enigmatic::Types qw(WiringMap Letter RotorPos);
+
+has wiring => (
+    is => 'ro',
+    isa => WiringMap,
+    coerce => 1,
+);
+
+has ring_setting => (
+    is => 'rw',
+    isa => RotorPos,
+    default => 0,
+);
+
+around BUILDARGS => sub {
+    my $orig  = shift;
+    my $class = shift;
+
+    if ( @_ == 1 && !ref $_[0] ) {
+        return $class->$orig( wiring => $_[0] );
+    }
+    else {
+        return $class->$orig(@_);
+    }
+};
+
+sub map {
+    my $self = shift;
+    my ($letter) = pos_validated_list(
+        \@_,
+        { isa => Letter },
+    );
+
+    return $self->wiring->at($self->_apply_ring_setting($letter));
+}
+
+sub _apply_ring_setting {
+    my $self = shift;
+    my ($letter) = pos_validated_list(
+        \@_,
+        { isa => Letter },
+    );
+
+    return chr(
+        (ord($letter) - ord('A') + $self->ring_setting)
+            % 26
+                +ord('A') );
+}
diff --git a/lib/Enigmatic/Types.pm b/lib/Enigmatic/Types.pm
new file mode 100644
index 0000000..12cb414
--- /dev/null
+++ b/lib/Enigmatic/Types.pm
@@ -0,0 +1,32 @@
+package Enigmatic::Types;
+use DAKKAR::p;
+use MooseX::Types -declare => [qw(Letter WiringMap RotorPos)];
+use MooseX::Types::Moose qw(Str Int);
+use MooseX::Types::Structured qw(Map);
+
+subtype Letter,
+    as Str,
+    where { /[A-Z]/ };
+
+subtype WiringMap,
+    as Map[Letter,Letter],
+    where {
+        my $in = $_->keys->sort->join;
+        my $out = $_->values->sort->join;
+        $in eq $out and $in eq ['A'..'Z']->join;
+    };
+
+coerce WiringMap,
+    from Str,
+    via {
+        my @out = $_->uc->split(qr//)->flatten;
+        croak "invalid wiring string <$_>"
+            unless @out == 26;
+        my %ret;
+        @ret{'A'..'Z'}=@out;
+        \%ret;
+    };
+
+subtype RotorPos,
+    as Int,
+    where { $_ >=0 and $_ <= 26 };
diff --git a/t/rotors.t b/t/rotors.t
new file mode 100644
index 0000000..509d88d
--- /dev/null
+++ b/t/rotors.t
@@ -0,0 +1,59 @@
+#!perl
+use DAKKAR::p 'test';
+use List::Util 'shuffle';
+
+use Enigmatic::Rotor;
+
+sub test_the_rotor {
+    my ($r,$out,$name) = @_;
+
+    my @in = 'A'..'Z';
+    my %map;@map{@in}=@$out;
+
+    for my $c ('A' .. 'Z') {
+        is($r->map($c),
+           $map{$c},
+           "$name on $c");
+    }
+}
+
+subtest 'identity rotor' => sub {
+    my @in = 'A'..'Z';
+    my $r = Enigmatic::Rotor->new(@in->join);
+    test_the_rotor($r,\@in,'identity');
+};
+
+
+subtest 'scramble rotor' => sub {
+    my @out = shuffle 'A'..'Z';
+
+    my $r = Enigmatic::Rotor->new(@out->join);
+    test_the_rotor($r,\@out,'shuffle');
+};
+
+subtest 'identity rotor, non-default ring setting' => sub {
+    my @out = (('B'..'Z'),'A');
+
+    my $r = Enigmatic::Rotor->new(
+        wiring => ['A'..'Z']->join,
+        ring_setting => 1,
+    );
+    test_the_rotor($r,\@out,'ring=1');
+};
+
+subtest 'constraints' => sub {
+    my @bad_params = (
+        'ABCD',
+        'ABCDEFGHIJKLMNOPQRSTUVWXYZABCD',
+        'AACDEFGHIJKLMNOPQRSTUVWXYZ',
+        '12CDEFGHIJKLMNOPQRSTUVWXYZABCD',
+    );
+
+    for my $bad_param (@bad_params) {
+        dies_ok {
+            Enigmatic::Rotor->new($bad_param);
+        } "bad parameter $bad_param";
+    }
+};
+
+done_testing();