From 556f1e542cdeadb7dc2f549ec7915fe28f5bb112 Mon Sep 17 00:00:00 2001 From: dakkar Date: Mon, 29 Aug 2011 13:06:32 +0100 Subject: static rotors --- lib/DAKKAR/p.pm | 102 +++++++++++++++++++++++++++++++++++++++++++++++++ lib/Enigmatic/Rotor.pm | 50 ++++++++++++++++++++++++ lib/Enigmatic/Types.pm | 32 ++++++++++++++++ t/rotors.t | 59 ++++++++++++++++++++++++++++ 4 files changed, 243 insertions(+) create mode 100644 lib/DAKKAR/p.pm create mode 100644 lib/Enigmatic/Rotor.pm create mode 100644 lib/Enigmatic/Types.pm create mode 100644 t/rotors.t 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(); -- cgit v1.2.3