File Coverage

blib/lib/CTK/Crypt/TCD04.pm
Criterion Covered Total %
statement 40 40 100.0
branch 11 16 68.7
condition 3 3 100.0
subroutine 8 8 100.0
pod 5 5 100.0
total 67 72 93.0


line stmt bran cond sub pod time code
1             package CTK::Crypt::TCD04;
2 2     2   59598 use strict;
  2         9  
  2         120  
3 2     2   498 use utf8;
  2         30  
  2         11  
4              
5             =encoding utf-8
6              
7             =head1 NAME
8              
9             CTK::Crypt::TCD04 - TCD04 Crypt backend
10              
11             =head1 VERSION
12              
13             Version 1.02
14              
15             =head1 SYNOPSIS
16              
17             use CTK::Crypt::TCD04;
18              
19             my $tcd04 = CTK::Crypt::TCD04->new;
20              
21             my $code = $tcd04->tcd04c('u'); # 1 char
22             my $decode = $tcd04->tcd04d($code); # 1 word
23              
24             print $tcd04->decrypt( $tcd04->encrypt( 'Hello, World!' ) );
25              
26             =head1 DESCRIPTION
27              
28             TCD04 Crypt backend. Simple cryptografy's algorythm of D&D Corporation
29              
30             =head1 METHODS
31              
32             =over 8
33              
34             =item B
35              
36             my $tcd04 = CTK::Crypt::TCD04->new;
37              
38             =item B
39              
40             $tcd04->decrypt( $tcd04->encrypt( 'Hello, World!' ) );
41              
42             =item B
43              
44             my $words = $tcd04->encrypt( 'Hello, World!' );
45              
46             =item B
47              
48             my $code = $tcd04->tcd04c('u'); # 1 char
49              
50             =item B
51              
52             my $decode = $tcd04->tcd04d($code); # 1 word
53              
54             =back
55              
56             =head1 HISTORY
57              
58             =over 8
59              
60             =item B<1.00 / 1.00.0001 08.01.2007>
61              
62             Init version on base mod_main 1.00.0002
63              
64             =item B<1.01 Fri 26 Apr 12:05:51 MSK 2019>
65              
66             Was moved from MPMinus project
67              
68             =back
69              
70             See C file
71              
72             =head1 TO DO
73              
74             See C file
75              
76             =head1 BUGS
77              
78             * none noted
79              
80             =head1 SEE ALSO
81              
82             L, L
83              
84             =head1 AUTHOR
85              
86             Serż Minus (Sergey Lepenkov) L Eabalama@cpan.orgE
87              
88             =head1 COPYRIGHT
89              
90             Copyright (C) 1998-2022 D&D Corporation. All Rights Reserved
91              
92             =head1 LICENSE
93              
94             This program is free software; you can redistribute it and/or
95             modify it under the same terms as Perl itself.
96              
97             See C file and L
98              
99             =cut
100              
101 2     2   76 use vars qw/ $VERSION /;
  2         3  
  2         821  
102             $VERSION = 1.02;
103              
104             sub new {
105 1     1 1 132 my $class = shift;
106 1         2 my $self = bless {}, $class;
107 1         2 return $self
108             }
109             sub encrypt {
110 1     1 1 650 my $self = shift;
111 1         3 my $string = shift;
112 1 50       3 return '' if length $string == 0;
113 1         5 return join "",map {$_=$self->tcd04c($_)} split //,$string;
  13         21  
114             }
115             sub decrypt {
116 1     1 1 2 my $self = shift;
117 1         2 my $string = shift;
118 1 50       3 return '' if length $string == 0;
119 1         2 my $ch2 ='';
120 1         2 my $outstr = '';
121 1         14 foreach (split //,$string) {
122 26         31 $ch2.=$_;
123 26 100       33 if (length($ch2) == 2) {
124 13         21 $outstr.=$self->tcd04d($ch2);
125 13         18 $ch2='';
126             }
127             }
128 1         5 return $outstr;
129             }
130             sub tcd04c {
131 14     14 1 721 my $self = shift;
132 14         13 my $ch = shift;
133 14 50       23 return '' if length $ch != 1;
134 14         16 my $kod1 = ord($ch)>>4;
135 14         15 my $kod2 = (ord($ch)&(2**4-1));
136 14 50       78 return chr($kod1>0?int(rand 16)*15 + $kod1:0).chr($kod2>0?int(rand 16)*15 + $kod2:0);
    100          
137             }
138             sub tcd04d {
139 14     14 1 19 my $self = shift;
140 14         15 my $ch2 = shift;
141 14 50       20 return '' if length $ch2 != 2;
142 14 100 100     20 my ($kod1,$kod2) = map {(((ord($_)%15)==0)&&ord($_)>0)?15:ord($_)%15} split //,$ch2;
  28         67  
143 14         30 return chr($kod1<<4|$kod2); #return sprintf "%X", $kod1<<4|$kod2;
144             }
145              
146             1;
147              
148             __END__