1package Crypt::CAST5_PP;
2
3require 5.004;
4use strict;
5use AutoLoader qw( AUTOLOAD );
6use Carp;
7use integer;
8use vars qw( @s1 @s2 @s3 @s4 @s5 @s6 @s7 @s8 $VERSION );
9
10$VERSION = "1.04";
11
12sub new {
13  my ($class, $key) = @_;
14  my $cast5 = { };
15  bless $cast5 => $class;
16  $cast5->init($key) if defined $key;
17  return $cast5;
18} # new
19
20sub blocksize { return 8  }
21sub keysize   { return 16 }
22
231 # end module
24__END__
25
26=head1 NAME
27
28Crypt::CAST5_PP - CAST5 block cipher in pure Perl
29
30=head1 SYNOPSIS
31
32    use Crypt::CBC;
33
34    my $crypt = Crypt::CBC->new({
35        key    => "secret key",
36        cipher => "CAST5_PP",
37    });
38
39    my $message = "All mimsy were the borogoves";
40    my $ciphertext = $crypt->encrypt($message);
41    print unpack("H*", $ciphertext), "\n";
42
43    my $plaintext = $crypt->decrypt($ciphertext);
44    print $plaintext, "\n";
45
46=head1 DESCRIPTION
47
48This module provides a pure Perl implementation of the CAST5 block cipher.
49CAST5 is also known as CAST-128. It is a product of the CAST design
50procedure developed by C. Adams and S. Tavares.
51
52The CAST5 cipher is available royalty-free.
53
54=head1 FUNCTIONS
55
56=head2 blocksize
57
58Returns the CAST5 block size, which is 8 bytes. This function exists
59so that Crypt::CAST5_PP can work with Crypt::CBC.
60
61=head2 keysize
62
63Returns the maximum CAST5 key size, 16 bytes.
64
65=head2 new
66
67    $cast5 = Crypt::CAST5_PP->new($key);
68
69Create a new encryption object. If the optional key parameter is given,
70it will be passed to the init() function.
71
72=head2 init
73
74    $cast5->init($key);
75
76Set or change the encryption key to be used. The key must be from 40 bits
77(5 bytes) to 128 bits (16 bytes) in length. Note that if the key used is
7880 bits or less, encryption and decryption will be somewhat faster.
79
80It is best for the key to be random binary data, not something printable
81like a password. A message digest function may be useful for converting
82a password to an encryption key; see L<Digest::SHA1> or L<Digest::MD5>.
83Note that Crypt::CBC runs the given "key" through MD5 to get the actual
84encryption key.
85
86=head2 encrypt
87
88    $ciphertext = $cast5->encrypt($plaintext);
89
90Encrypt a block of plaintext using the current encryption key, and return
91the corresponding ciphertext. The input must be 8 bytes long, and the output
92has the same length. Note that the encryption is in ECB mode, which means
93that it encrypts each block independently. That can leave you vulnerable
94to dictionary attacks, so it is generally best to use some form of chaining
95between blocks; see L<Crypt::CBC>.
96
97=head2 decrypt
98
99    $plaintext = $cast5->decrypt($ciphertext);
100
101Decrypt the ciphertext and return the corresponding plaintext.
102
103=head1 LIMITATIONS
104
105Always produces untainted output, even if the input is tainted, because
106that's what perl's pack() function does.
107
108=head1 SEE ALSO
109
110RFC 2144, "The CAST-128 Encryption Algorithm", C. Adams, May 1997
111
112L<Crypt::CBC>
113
114=head1 AUTHOR
115
116Bob Mathews, <bobmathews@alumni.calpoly.edu>
117
118=head1 COPYRIGHT
119
120Copyright (c) 2006 Bob Mathews. All rights reserved.
121This program is free software; you can redistribute it and/or
122modify it under the same terms as Perl itself.
123
124=cut
125
126sub init {
127  use strict;
128  use integer;
129  my ($cast5, $key) = @_;
130  croak "Key length must be 40 to 128 bits"
131      if length($key) < 5 || length($key) > 16;
132  require Crypt::CAST5_PP::Tables;
133
134  # untaint the key. this keeps the evals from blowing up later.
135  # arguably, a tainted key should result in tainted output. oh well.
136  $key =~ /^(.*)$/s and $key = $1;
137
138  # null-pad the key to 16 bytes, and then split it into 32-bit chunks
139  my ($s, $t, $u, $v) = unpack "N4", pack "a16", $key;
140
141  # compute the key schedule
142  # don't try to read this -- it's generated by mkschedule
143  my ($w, $x, $y, $z, @k);
144  for (1..2) {
145    $w=$s^$s5[$v>>16&255]^$s6[$v&255]^$s7[$v>>24&255]^$s8[$v>>8&255]^$s7[$u>>24&255];
146    $x=$u^$s5[$w>>24&255]^$s6[$w>>8&255]^$s7[$w>>16&255]^$s8[$w&255]^$s8[$u>>8&255];
147    $y=$v^$s5[$x&255]^$s6[$x>>8&255]^$s7[$x>>16&255]^$s8[$x>>24&255]^$s5[$u>>16&255];
148    $z=$t^$s5[$y>>8&255]^$s6[$y>>16&255]^$s7[$y&255]^$s8[$y>>24&255]^$s6[$u&255];
149    push@k,$s5[$y>>24&255]^$s6[$y>>16&255]^$s7[$x&255]^$s8[$x>>8&255]^$s5[$w>>8&255];
150    push@k,$s5[$y>>8&255]^$s6[$y&255]^$s7[$x>>16&255]^$s8[$x>>24&255]^$s6[$x>>8&255];
151    push@k,$s5[$z>>24&255]^$s6[$z>>16&255]^$s7[$w&255]^$s8[$w>>8&255]^$s7[$y>>16&255];
152    push@k,$s5[$z>>8&255]^$s6[$z&255]^$s7[$w>>16&255]^$s8[$w>>24&255]^$s8[$z>>24&255];
153    $s=$y^$s5[$x>>16&255]^$s6[$x&255]^$s7[$x>>24&255]^$s8[$x>>8&255]^$s7[$w>>24&255];
154    $t=$w^$s5[$s>>24&255]^$s6[$s>>8&255]^$s7[$s>>16&255]^$s8[$s&255]^$s8[$w>>8&255];
155    $u=$x^$s5[$t&255]^$s6[$t>>8&255]^$s7[$t>>16&255]^$s8[$t>>24&255]^$s5[$w>>16&255];
156    $v=$z^$s5[$u>>8&255]^$s6[$u>>16&255]^$s7[$u&255]^$s8[$u>>24&255]^$s6[$w&255];
157    push@k,$s5[$s&255]^$s6[$s>>8&255]^$s7[$v>>24&255]^$s8[$v>>16&255]^$s5[$u>>24&255];
158    push@k,$s5[$s>>16&255]^$s6[$s>>24&255]^$s7[$v>>8&255]^$s8[$v&255]^$s6[$v>>16&255];
159    push@k,$s5[$t&255]^$s6[$t>>8&255]^$s7[$u>>24&255]^$s8[$u>>16&255]^$s7[$s&255];
160    push@k,$s5[$t>>16&255]^$s6[$t>>24&255]^$s7[$u>>8&255]^$s8[$u&255]^$s8[$t&255];
161    $w=$s^$s5[$v>>16&255]^$s6[$v&255]^$s7[$v>>24&255]^$s8[$v>>8&255]^$s7[$u>>24&255];
162    $x=$u^$s5[$w>>24&255]^$s6[$w>>8&255]^$s7[$w>>16&255]^$s8[$w&255]^$s8[$u>>8&255];
163    $y=$v^$s5[$x&255]^$s6[$x>>8&255]^$s7[$x>>16&255]^$s8[$x>>24&255]^$s5[$u>>16&255];
164    $z=$t^$s5[$y>>8&255]^$s6[$y>>16&255]^$s7[$y&255]^$s8[$y>>24&255]^$s6[$u&255];
165    push@k,$s5[$w&255]^$s6[$w>>8&255]^$s7[$z>>24&255]^$s8[$z>>16&255]^$s5[$y>>16&255];
166    push@k,$s5[$w>>16&255]^$s6[$w>>24&255]^$s7[$z>>8&255]^$s8[$z&255]^$s6[$z>>24&255];
167    push@k,$s5[$x&255]^$s6[$x>>8&255]^$s7[$y>>24&255]^$s8[$y>>16&255]^$s7[$w>>8&255];
168    push@k,$s5[$x>>16&255]^$s6[$x>>24&255]^$s7[$y>>8&255]^$s8[$y&255]^$s8[$x>>8&255];
169    $s=$y^$s5[$x>>16&255]^$s6[$x&255]^$s7[$x>>24&255]^$s8[$x>>8&255]^$s7[$w>>24&255];
170    $t=$w^$s5[$s>>24&255]^$s6[$s>>8&255]^$s7[$s>>16&255]^$s8[$s&255]^$s8[$w>>8&255];
171    $u=$x^$s5[$t&255]^$s6[$t>>8&255]^$s7[$t>>16&255]^$s8[$t>>24&255]^$s5[$w>>16&255];
172    $v=$z^$s5[$u>>8&255]^$s6[$u>>16&255]^$s7[$u&255]^$s8[$u>>24&255]^$s6[$w&255];
173    push@k,$s5[$u>>24&255]^$s6[$u>>16&255]^$s7[$t&255]^$s8[$t>>8&255]^$s5[$s&255];
174    push@k,$s5[$u>>8&255]^$s6[$u&255]^$s7[$t>>16&255]^$s8[$t>>24&255]^$s6[$t&255];
175    push@k,$s5[$v>>24&255]^$s6[$v>>16&255]^$s7[$s&255]^$s8[$s>>8&255]^$s7[$u>>24&255];
176    push@k,$s5[$v>>8&255]^$s6[$v&255]^$s7[$s>>16&255]^$s8[$s>>24&255]^$s8[$v>>16&255];
177  }
178
179  for (16..31) { $k[$_] &= 31 }
180  delete $cast5->{encrypt};
181  delete $cast5->{decrypt};
182  $cast5->{rounds} = length($key) <= 10 ? 12 : 16;
183  $cast5->{key} = \@k;
184  return $cast5;
185} # init
186
187sub encrypt {
188  use strict;
189  use integer;
190  my ($cast5, $block) = @_;
191  croak "Block size must be 8" if length($block) != 8;
192
193  my $encrypt = $cast5->{encrypt};
194  unless ($encrypt) {
195    my $key = $cast5->{key} or croak "Call init() first";
196    my $f = 'sub{my($l,$r,$i)=unpack"N2",$_[0];';
197
198    my ($l, $r) = qw( $l $r );
199    my ($op1, $op2, $op3) = qw( + ^ - );
200    foreach my $round (0 .. $cast5->{rounds}-1) {
201      my $km = $key->[$round];
202      my $kr = $key->[$round+16];
203
204      my $rot = "";
205      if ($kr) {
206        my $mask = ~(~0<<$kr) & 0xffffffff;
207        my $kr2 = 32-$kr;
208        $rot = "\$i=\$i<<$kr|\$i>>$kr2&$mask;"
209      }
210
211      $f .= "\$i=$km$op1$r;$rot$l^=((\$s1[\$i>>24&255]$op2\$s2[\$i>>16&255])$op3\$s3[\$i>>8&255])$op1\$s4[\$i&255];";
212      ($l, $r) = ($r, $l);
213      ($op1, $op2, $op3) = ($op2, $op3, $op1);
214    }
215
216    $f .= 'pack"N2",$r&0xffffffff,$l&0xffffffff}';
217    $cast5->{encrypt} = $encrypt = eval $f;
218  }
219
220  return $encrypt->($block);
221} # encrypt
222
223sub decrypt {
224  use strict;
225  use integer;
226  my ($cast5, $block) = @_;
227  croak "Block size must be 8" if length($block) != 8;
228
229  my $decrypt = $cast5->{decrypt};
230  unless ($decrypt) {
231    my $key = $cast5->{key} or croak "Call init() first";
232    my $rounds = $cast5->{rounds};
233    my $f = 'sub{my($r,$l,$i)=unpack"N2",$_[0];';
234
235    my ($l, $r) = qw( $r $l );
236    my ($op1, $op2, $op3) = qw( - + ^ );
237    foreach (1 .. $rounds%3) { ($op1, $op2, $op3) = ($op2, $op3, $op1) }
238    foreach my $round (1 .. $rounds) {
239      my $km = $key->[$rounds-$round];
240      my $kr = $key->[$rounds-$round+16];
241
242      my $rot = "";
243      if ($kr) {
244        my $mask = ~(~0<<$kr) & 0xffffffff;
245        my $kr2 = 32-$kr;
246        $rot = "\$i=\$i<<$kr|\$i>>$kr2&$mask;"
247      }
248
249      $f .= "\$i=$km$op1$r;$rot$l^=((\$s1[\$i>>24&255]$op2\$s2[\$i>>16&255])$op3\$s3[\$i>>8&255])$op1\$s4[\$i&255];";
250      ($l, $r) = ($r, $l);
251      ($op1, $op2, $op3) = ($op3, $op1, $op2);
252    }
253
254    $f .= 'pack"N2",$l&0xffffffff,$r&0xffffffff}';
255    $cast5->{decrypt} = $decrypt = eval $f;
256  }
257
258  return $decrypt->($block);
259} # decrypt
260
261# end CAST5_PP.pm
262