File Coverage

blib/lib/Story/Interact/State.pm
Criterion Covered Total %
statement 41 74 55.4
branch 1 12 8.3
condition 2 3 66.6
subroutine 18 22 81.8
pod 0 6 0.0
total 62 117 52.9


line stmt bran cond sub pod time code
1 5     5   85 use 5.010001;
  5         28  
2 5     5   31 use strict;
  5         10  
  5         174  
3 5     5   25 use warnings;
  5         16  
  5         371  
4              
5             package Story::Interact::State;
6              
7             warn "LOADED DEV VERSION!";
8              
9             our $AUTHORITY = 'cpan:TOBYINK';
10             our $VERSION = '0.001013';
11              
12 5     5   2117 use Story::Interact::Character ();
  5         18  
  5         176  
13              
14 5     5   40 use Moo;
  5         82  
  5         39  
15 5     5   1711 use Module::Runtime qw( use_package_optimistically );
  5         23  
  5         43  
16 5     5   404 use Types::Common -types;
  5         21  
  5         43  
17 5     5   68410 use namespace::clean;
  5         10  
  5         47  
18              
19             has 'world' => (
20             is => 'ro',
21             isa => HashRef,
22 9     9   359 builder => sub { {} },
23             );
24              
25             has 'character' => (
26             is => 'ro',
27             isa => HashRef->of( Object ),
28 9     9   16203 builder => sub { {} },
29             );
30              
31             has 'location' => (
32             is => 'ro',
33             isa => HashRef->of( HashRef ),
34 9     9   344 builder => sub { {} },
35             );
36              
37             has 'visited' => (
38             is => 'ro',
39             isa => HashRef->of( PositiveOrZeroInt ),
40 9     9   357 builder => sub { {} },
41             );
42              
43             has 'character_class' => (
44             is => 'ro',
45             isa => Str,
46 9     9   394 builder => sub { 'Story::Interact::Character' },
47             );
48              
49             has 'params' => (
50             is => 'rw',
51             isa => HashRef,
52 9     9   334 builder => sub { {} },
53             );
54              
55             sub BUILD {
56 9     9 0 212 my ( $self, $arg ) = @_;
57 9         112 $self->define_npc( player => ( name => 'Anon' ) );
58             }
59              
60             sub player {
61 55     55 0 93 my ( $self ) = @_;
62 55         1278 return $self->character->{player};
63             }
64              
65             sub define_npc {
66 10     10 0 39 my ( $self, $code, %attrs ) = @_;
67 10 50       128 return if defined $self->character->{$code};
68            
69 10   66     83 my $character_class = delete( $attrs{class} ) // $self->character_class;
70 10         48 $self->character->{$code} = use_package_optimistically( $character_class )->new( %attrs );
71             }
72              
73             sub update_from_page {
74 45     45 0 91 my ( $self, $page ) = @_;
75 45         201 ++$self->visited->{ $page->id };
76 45         108 $self->player->_set_location( $page->location );
77 45         1286 return $self;
78             }
79              
80             sub _maybe_encrypt {
81 0     0     my ( $self, $data ) = @_;
82 0 0         my $key = $ENV{PERL_STORY_INTERACT_KEY} or return $data;
83            
84 0           require Crypt::Mode::OFB;
85 0           require Bytes::Random::Secure;
86 0           my $iv = Bytes::Random::Secure::random_string_from( 'abcdefghijklmnopqrstuvwxyz0123456789', 8 );
87 0           my $m = Crypt::Mode::OFB->new( 'CAST5' );
88 0           return sprintf( 'CRYPTX:%s:%s', $iv, $m->encrypt( $data, $key, $iv ) );
89             }
90              
91             sub _maybe_decrypt {
92 0     0     my ( $class, $data ) = @_;
93            
94 0 0         if ( substr( $data, 0, 7 ) eq 'CRYPTX:' ) {
95 0 0         my $key = $ENV{PERL_STORY_INTERACT_KEY} or die 'PERL_STORY_INTERACT_KEY not found!';
96 0           require Crypt::Mode::OFB;
97 0           my $m = Crypt::Mode::OFB->new( 'CAST5' );
98 0           my $iv = substr( $data, 7, 8 );
99 0           my $ciphertext = substr( $data, 16 );
100 0           return $m->decrypt( $ciphertext, $key, $iv );
101             }
102            
103 0 0         die 'Failed to load non-encrypted state!!!' if $ENV{PERL_STORY_INTERACT_FORCE_ENCRYPTED};
104 0           return $data;
105             }
106              
107             sub dump {
108 0     0 0   my ( $self ) = @_;
109 0           require Storable;
110 0           require MIME::Base64;
111 0           require Compress::Bzip2;
112 0           my $frozen = Compress::Bzip2::memBzip( Storable::nfreeze( $self ) );
113 0           my $encrypted = $self->_maybe_encrypt( $frozen );
114 0           return MIME::Base64::encode_base64( $encrypted );
115             }
116              
117             sub load {
118 0     0 0   my ( $class, $data ) = @_;
119 0           require Storable;
120 0           require MIME::Base64;
121 0           require Compress::Bzip2;
122 0           my $frozen = MIME::Base64::decode_base64( $data );
123 0           my $decrypted = $class->_maybe_decrypt( $frozen );
124 0 0         if ( my $unzipped = Compress::Bzip2::memBunzip( $decrypted ) ) {
125 0           return Storable::thaw( $unzipped );
126             }
127 0           return Storable::thaw( $decrypted );
128             }
129              
130             1;