extlib/Digest/Perl/MD5.pm

   1 #! /usr/bin/false
   2 #
   3 # $Id: MD5.pm,v 1.23 2004/08/27 20:28:25 lackas Exp $
   4 #
   5
   6 package Digest::Perl::MD5;
   7 use strict;
   8 use integer;
   9 use Exporter;
  10 use vars qw($VERSION @ISA @EXPORTER @EXPORT_OK);
  11
  12 @EXPORT_OK = qw(md5 md5_hex md5_base64);
  13
  14 @ISA = 'Exporter';
  15 $VERSION = '1.8';
  16
  17 # I-Vektor
  18 sub A() { 0x67_45_23_01 }
  19 sub B() { 0xef_cd_ab_89 }
  20 sub C() { 0x98_ba_dc_fe }
  21 sub D() { 0x10_32_54_76 }
  22
  23 # for internal use
  24 sub MAX() { 0xFFFFFFFF }
  25
  26 # padd a message to a multiple of 64
  27 sub padding {
  28     my $l = length (my $msg = shift() . chr(128));
  29     $msg .= "\0" x (($l%64<=56?56:120)-$l%64);
  30     $l = ($l-1)*8;
  31     $msg .= pack 'VV', $l & MAX , ($l >> 16 >> 16);
  32 }
  33
  34
  35 sub rotate_left($$) {
  36         #$_[0] << $_[1] | $_[0] >> (32 - $_[1]);
  37         #my $right = $_[0] >> (32 - $_[1]);
  38         #my $rmask = (1 << $_[1]) - 1;
  39         ($_[0] << $_[1]) | (( $_[0] >> (32 - $_[1])  )  & ((1 << $_[1]) - 1));
  40         #$_[0] << $_[1] | (($_[0]>> (32 - $_[1])) & (1 << (32 - $_[1])) - 1);
  41 }
  42
  43 sub gen_code {
  44   # Discard upper 32 bits on 64 bit archs.
  45   my $MSK = ((1 << 16) << 16) ? ' & ' . MAX : '';
  46 #       FF => "X0=rotate_left(((X1&X2)|(~X1&X3))+X0+X4+X6$MSK,X5)+X1$MSK;",
  47 #       GG => "X0=rotate_left(((X1&X3)|(X2&(~X3)))+X0+X4+X6$MSK,X5)+X1$MSK;",
  48   my %f = (
  49         FF => "X0=rotate_left((X3^(X1&(X2^X3)))+X0+X4+X6$MSK,X5)+X1$MSK;",
  50         GG => "X0=rotate_left((X2^(X3&(X1^X2)))+X0+X4+X6$MSK,X5)+X1$MSK;",
  51         HH => "X0=rotate_left((X1^X2^X3)+X0+X4+X6$MSK,X5)+X1$MSK;",
  52         II => "X0=rotate_left((X2^(X1|(~X3)))+X0+X4+X6$MSK,X5)+X1$MSK;",
  53   );
  54   #unless ( (1 << 16) << 16) { %f = %{$CODES{'32bit'}} }
  55   #else { %f = %{$CODES{'64bit'}} }
  56
  57   my %s = (  # shift lengths
  58         S11 => 7, S12 => 12, S13 => 17, S14 => 22, S21 => 5, S22 => 9, S23 => 14,
  59         S24 => 20, S31 => 4, S32 => 11, S33 => 16, S34 => 23, S41 => 6, S42 => 10,
  60         S43 => 15, S44 => 21
  61   );
  62
  63   my $insert = "\n";
  64   while(<DATA>) {
  65         chomp;
  66         next unless /^[FGHI]/;
  67         my ($func,@x) = split /,/;
  68         my $c = $f{$func};
  69         $c =~ s/X(\d)/$x[$1]/g;
  70         $c =~ s/(S\d{2})/$s{$1}/;
  71         $c =~ s/^(.*)=rotate_left\((.*),(.*)\)\+(.*)$//;
  72
  73         my $su = 32 - $3;
  74         my $sh = (1 << $3) - 1;
  75
  76         $c = "$1=(((\$r=$2)<<$3)|((\$r>>$su)&$sh))+$4";
  77
  78         #my $rotate = "(($2 << $3) || (($2 >> (32 - $3)) & (1 << $2) - 1)))";
  79         # $c = "\$r = $2;
  80         # $1 = ((\$r << $3) | ((\$r >> (32 - $3))  & ((1 << $3) - 1))) + $4";
  81         $insert .= "\t$c\n";
  82   }
  83   close DATA;
  84
  85   my $dump = '
  86   sub round {
  87         my ($a,$b,$c,$d) = @_[0 .. 3];
  88         my $r;' . $insert . '
  89         $_[0]+$a' . $MSK . ', $_[1]+$b ' . $MSK .
  90         ', $_[2]+$c' . $MSK . ', $_[3]+$d' . $MSK . ';
  91   }';
  92   eval $dump;
  93   # print "$dump\n";
  94   # exit 0;
  95 }
  96
  97 gen_code();
  98
  99 #########################################
 100 # Private output converter functions:
 101 sub _encode_hex { unpack 'H*', $_[0] }
 102 sub _encode_base64 {
 103         my $res;
 104         while ($_[0] =~ /(.{1,45})/gs) {
 105                 $res .= substr pack('u', $1), 1;
 106                 chop $res;
 107         }
 108         $res =~ tr|` -_|AA-Za-z0-9+/|;#`
 109         chop $res; chop $res;
 110         $res
 111 }
 112
 113 #########################################
 114 # OOP interface:
 115 sub new {
 116         my $proto = shift;
 117         my $class = ref $proto || $proto;
 118         my $self = {};
 119         bless $self, $class;
 120         $self->reset();
 121         $self
 122 }
 123
 124 sub reset {
 125         my $self = shift;
 126         delete $self->{_data};
 127         $self->{_state} = [A,B,C,D];
 128         $self->{_length} = 0;
 129         $self
 130 }
 131
 132 sub add {
 133         my $self = shift;
 134         $self->{_data} .= join '', @_ if @_;
 135         my ($i,$c);
 136         for $i (0 .. (length $self->{_data})/64-1) {
 137                 my @X = unpack 'V16', substr $self->{_data}, $i*64, 64;
 138                 @{$self->{_state}} = round(@{$self->{_state}},@X);
 139                 ++$c;
 140         }
 141         if ($c) {
 142                 substr ($self->{_data}, 0, $c*64) = '';
 143                 $self->{_length} += $c*64;
 144         }
 145         $self
 146 }
 147
 148 sub finalize {
 149         my $self = shift;
 150         $self->{_data} .= chr(128);
 151     my $l = $self->{_length} + length $self->{_data};
 152     $self->{_data} .= "\0" x (($l%64<=56?56:120)-$l%64);
 153     $l = ($l-1)*8;
 154     $self->{_data} .= pack 'VV', $l & MAX , ($l >> 16 >> 16);
 155         $self->add();
 156         $self
 157 }
 158
 159 sub addfile {
 160         my ($self,$fh) = @_;
 161         if (!ref($fh) && ref(\$fh) ne "GLOB") {
 162             require Symbol;
 163             $fh = Symbol::qualify($fh, scalar caller);
 164         }
 165         # $self->{_data} .= do{local$/;<$fh>};
 166         my $read = 0;
 167         my $buffer = '';
 168         $self->add($buffer) while $read = read $fh, $buffer, 8192;
 169         die __PACKAGE__, " read failed: $!" unless defined $read;
 170         $self
 171 }
 172
 173 sub add_bits {
 174         my $self = shift;
 175         return $self->add( pack 'B*', shift ) if @_ == 1;
 176         my ($b,$n) = @_;
 177         die __PACKAGE__, " Invalid number of bits\n" if $n%8;
 178         $self->add( substr $b, 0, $n/8 )
 179 }
 180
 181 sub digest {
 182         my $self = shift;
 183         $self->finalize();
 184         my $res = pack 'V4', @{$self->{_state}};
 185         $self->reset();
 186         $res
 187 }
 188
 189 sub hexdigest {
 190         _encode_hex($_[0]->digest)
 191 }
 192
 193 sub b64digest {
 194         _encode_base64($_[0]->digest)
 195 }
 196
 197 sub clone {
 198         my $self = shift;
 199         my $clone = {
 200                 _state => [@{$self->{_state}}],
 201                 _length => $self->{_length},
 202                 _data => $self->{_data}
 203         };
 204         bless $clone, ref $self || $self;
 205 }
 206
 207 #########################################
 208 # Procedural interface:
 209 sub md5 {
 210         my $message = padding(join'',@_);
 211         my ($a,$b,$c,$d) = (A,B,C,D);
 212         my $i;
 213         for $i (0 .. (length $message)/64-1) {
 214                 my @X = unpack 'V16', substr $message,$i*64,64;
 215                 ($a,$b,$c,$d) = round($a,$b,$c,$d,@X);
 216         }
 217         pack 'V4',$a,$b,$c,$d;
 218 }
 219 sub md5_hex { _encode_hex &md5 }
 220 sub md5_base64 { _encode_base64 &md5 }
 221
 222
 223 1;
 224
 225 =head1 NAME
 226
 227 Digest::MD5::Perl - Perl implementation of Ron Rivests MD5 Algorithm
 228
 229 =head1 DISCLAIMER
 230
 231 This is B<not> an interface (like C<Digest::MD5>) but a Perl implementation of MD5.
 232 It is written in perl only and because of this it is slow but it works without C-Code.
 233 You should use C<Digest::MD5> instead of this module if it is available.
 234 This module is only usefull for
 235
 236 =over 4
 237
 238 =item
 239
 240 computers where you cannot install C<Digest::MD5> (e.g. lack of a C-Compiler)
 241
 242 =item
 243
 244 encrypting only small amounts of data (less than one million bytes). I use it to
 245 hash passwords.
 246
 247 =item
 248
 249 educational purposes
 250
 251 =back
 252
 253 =head1 SYNOPSIS
 254
 255  # Functional style
 256  use Digest::MD5  qw(md5 md5_hex md5_base64);
 257
 258  $hash = md5 $data;
 259  $hash = md5_hex $data;
 260  $hash = md5_base64 $data;
 261
 262
 263  # OO style
 264  use Digest::MD5;
 265
 266  $ctx = Digest::MD5->new;
 267
 268  $ctx->add($data);
 269  $ctx->addfile(*FILE);
 270
 271  $digest = $ctx->digest;
 272  $digest = $ctx->hexdigest;
 273  $digest = $ctx->b64digest;
 274
 275 =head1 DESCRIPTION
 276
 277 This modules has the same interface as the much faster C<Digest::MD5>. So you can
 278 easily exchange them, e.g.
 279
 280         BEGIN {
 281           eval {
 282             require Digest::MD5;
 283             import Digest::MD5 'md5_hex'
 284           };
 285           if ($@) { # ups, no Digest::MD5
 286             require Digest::Perl::MD5;
 287             import Digest::Perl::MD5 'md5_hex'
 288           }
 289         }
 290
 291 If the C<Digest::MD5> module is available it is used and if not you take
 292 C<Digest::Perl::MD5>.
 293
 294 You can also install the Perl part of Digest::MD5 together with Digest::Perl::MD5
 295 and use Digest::MD5 as normal, it falls back to Digest::Perl::MD5 if it
 296 cannot load its object files.
 297
 298 For a detailed Documentation see the C<Digest::MD5> module.
 299
 300 =head1 EXAMPLES
 301
 302 The simplest way to use this library is to import the md5_hex()
 303 function (or one of its cousins):
 304
 305     use Digest::Perl::MD5 'md5_hex';
 306     print 'Digest is ', md5_hex('foobarbaz'), "\n";
 307
 308 The above example would print out the message
 309
 310     Digest is 6df23dc03f9b54cc38a0fc1483df6e21
 311
 312 provided that the implementation is working correctly.  The same
 313 checksum can also be calculated in OO style:
 314
 315     use Digest::MD5;
 316
 317     $md5 = Digest::MD5->new;
 318     $md5->add('foo', 'bar');
 319     $md5->add('baz');
 320     $digest = $md5->hexdigest;
 321
 322     print "Digest is $digest\n";
 323
 324 The digest methods are destructive. That means you can only call them
 325 once and the $md5 objects is reset after use. You can make a copy with clone:
 326
 327         $md5->clone->hexdigest
 328
 329 =head1 LIMITATIONS
 330
 331 This implementation of the MD5 algorithm has some limitations:
 332
 333 =over 4
 334
 335 =item
 336
 337 It's slow, very slow. I've done my very best but Digest::MD5 is still about 100 times faster.
 338 You can only encrypt Data up to one million bytes in an acceptable time. But it's very usefull
 339 for encrypting small amounts of data like passwords.
 340
 341 =item
 342
 343 You can only encrypt up to 2^32 bits = 512 MB on 32bit archs. But You should
 344 use C<Digest::MD5> for those amounts of data anyway.
 345
 346 =back
 347
 348 =head1 SEE ALSO
 349
 350 L<Digest::MD5>
 351
 352 L<md5(1)>
 353
 354 RFC 1321
 355
 356 tools/md5: a small BSD compatible md5 tool written in pure perl.
 357
 358 =head1 COPYRIGHT
 359
 360 This library is free software; you can redistribute it and/or
 361 modify it under the same terms as Perl itself.
 362
 363  Copyright 2000 Christian Lackas, Imperia Software Solutions
 364  Copyright 1998-1999 Gisle Aas.
 365  Copyright 1995-1996 Neil Winton.
 366  Copyright 1991-1992 RSA Data Security, Inc.
 367
 368 The MD5 algorithm is defined in RFC 1321. The basic C code
 369 implementing the algorithm is derived from that in the RFC and is
 370 covered by the following copyright:
 371
 372 =over 4
 373
 374 =item
 375
 376 Copyright (C) 1991-1992, RSA Data Security, Inc. Created 1991. All
 377 rights reserved.
 378
 379 License to copy and use this software is granted provided that it
 380 is identified as the "RSA Data Security, Inc. MD5 Message-Digest
 381 Algorithm" in all material mentioning or referencing this software
 382 or this function.
 383
 384 License is also granted to make and use derivative works provided
 385 that such works are identified as "derived from the RSA Data
 386 Security, Inc. MD5 Message-Digest Algorithm" in all material
 387 mentioning or referencing the derived work.
 388
 389 RSA Data Security, Inc. makes no representations concerning either
 390 the merchantability of this software or the suitability of this
 391 software for any particular purpose. It is provided "as is"
 392 without express or implied warranty of any kind.
 393
 394 These notices must be retained in any copies of any part of this
 395 documentation and/or software.
 396
 397 =back
 398
 399 This copyright does not prohibit distribution of any version of Perl
 400 containing this extension under the terms of the GNU or Artistic
 401 licenses.
 402
 403 =head1 AUTHORS
 404
 405 The original MD5 interface was written by Neil Winton
 406 (<N.Winton (at) axion.bt.co.uk>).
 407
 408 C<Digest::MD5> was made by Gisle Aas <gisle (at) aas.no> (I took his Interface
 409 and part of the documentation).
 410
 411 Thanks to Guido Flohr for his 'use integer'-hint.
 412
 413 This release was made by Christian Lackas <delta (at) lackas.net>.
 414
 415 =cut
 416
 417 __DATA__
 418 FF,$a,$b,$c,$d,$_[4],7,0xd76aa478,/* 1 */
 419 FF,$d,$a,$b,$c,$_[5],12,0xe8c7b756,/* 2 */
 420 FF,$c,$d,$a,$b,$_[6],17,0x242070db,/* 3 */
 421 FF,$b,$c,$d,$a,$_[7],22,0xc1bdceee,/* 4 */
 422 FF,$a,$b,$c,$d,$_[8],7,0xf57c0faf,/* 5 */
 423 FF,$d,$a,$b,$c,$_[9],12,0x4787c62a,/* 6 */
 424 FF,$c,$d,$a,$b,$_[10],17,0xa8304613,/* 7 */
 425 FF,$b,$c,$d,$a,$_[11],22,0xfd469501,/* 8 */
 426 FF,$a,$b,$c,$d,$_[12],7,0x698098d8,/* 9 */
 427 FF,$d,$a,$b,$c,$_[13],12,0x8b44f7af,/* 10 */
 428 FF,$c,$d,$a,$b,$_[14],17,0xffff5bb1,/* 11 */
 429 FF,$b,$c,$d,$a,$_[15],22,0x895cd7be,/* 12 */
 430 FF,$a,$b,$c,$d,$_[16],7,0x6b901122,/* 13 */
 431 FF,$d,$a,$b,$c,$_[17],12,0xfd987193,/* 14 */
 432 FF,$c,$d,$a,$b,$_[18],17,0xa679438e,/* 15 */
 433 FF,$b,$c,$d,$a,$_[19],22,0x49b40821,/* 16 */
 434 GG,$a,$b,$c,$d,$_[5],5,0xf61e2562,/* 17 */
 435 GG,$d,$a,$b,$c,$_[10],9,0xc040b340,/* 18 */
 436 GG,$c,$d,$a,$b,$_[15],14,0x265e5a51,/* 19 */
 437 GG,$b,$c,$d,$a,$_[4],20,0xe9b6c7aa,/* 20 */
 438 GG,$a,$b,$c,$d,$_[9],5,0xd62f105d,/* 21 */
 439 GG,$d,$a,$b,$c,$_[14],9,0x2441453,/* 22 */
 440 GG,$c,$d,$a,$b,$_[19],14,0xd8a1e681,/* 23 */
 441 GG,$b,$c,$d,$a,$_[8],20,0xe7d3fbc8,/* 24 */
 442 GG,$a,$b,$c,$d,$_[13],5,0x21e1cde6,/* 25 */
 443 GG,$d,$a,$b,$c,$_[18],9,0xc33707d6,/* 26 */
 444 GG,$c,$d,$a,$b,$_[7],14,0xf4d50d87,/* 27 */
 445 GG,$b,$c,$d,$a,$_[12],20,0x455a14ed,/* 28 */
 446 GG,$a,$b,$c,$d,$_[17],5,0xa9e3e905,/* 29 */
 447 GG,$d,$a,$b,$c,$_[6],9,0xfcefa3f8,/* 30 */
 448 GG,$c,$d,$a,$b,$_[11],14,0x676f02d9,/* 31 */
 449 GG,$b,$c,$d,$a,$_[16],20,0x8d2a4c8a,/* 32 */
 450 HH,$a,$b,$c,$d,$_[9],4,0xfffa3942,/* 33 */
 451 HH,$d,$a,$b,$c,$_[12],11,0x8771f681,/* 34 */
 452 HH,$c,$d,$a,$b,$_[15],16,0x6d9d6122,/* 35 */
 453 HH,$b,$c,$d,$a,$_[18],23,0xfde5380c,/* 36 */
 454 HH,$a,$b,$c,$d,$_[5],4,0xa4beea44,/* 37 */
 455 HH,$d,$a,$b,$c,$_[8],11,0x4bdecfa9,/* 38 */
 456 HH,$c,$d,$a,$b,$_[11],16,0xf6bb4b60,/* 39 */
 457 HH,$b,$c,$d,$a,$_[14],23,0xbebfbc70,/* 40 */
 458 HH,$a,$b,$c,$d,$_[17],4,0x289b7ec6,/* 41 */
 459 HH,$d,$a,$b,$c,$_[4],11,0xeaa127fa,/* 42 */
 460 HH,$c,$d,$a,$b,$_[7],16,0xd4ef3085,/* 43 */
 461 HH,$b,$c,$d,$a,$_[10],23,0x4881d05,/* 44 */
 462 HH,$a,$b,$c,$d,$_[13],4,0xd9d4d039,/* 45 */
 463 HH,$d,$a,$b,$c,$_[16],11,0xe6db99e5,/* 46 */
 464 HH,$c,$d,$a,$b,$_[19],16,0x1fa27cf8,/* 47 */
 465 HH,$b,$c,$d,$a,$_[6],23,0xc4ac5665,/* 48 */
 466 II,$a,$b,$c,$d,$_[4],6,0xf4292244,/* 49 */
 467 II,$d,$a,$b,$c,$_[11],10,0x432aff97,/* 50 */
 468 II,$c,$d,$a,$b,$_[18],15,0xab9423a7,/* 51 */
 469 II,$b,$c,$d,$a,$_[9],21,0xfc93a039,/* 52 */
 470 II,$a,$b,$c,$d,$_[16],6,0x655b59c3,/* 53 */
 471 II,$d,$a,$b,$c,$_[7],10,0x8f0ccc92,/* 54 */
 472 II,$c,$d,$a,$b,$_[14],15,0xffeff47d,/* 55 */
 473 II,$b,$c,$d,$a,$_[5],21,0x85845dd1,/* 56 */
 474 II,$a,$b,$c,$d,$_[12],6,0x6fa87e4f,/* 57 */
 475 II,$d,$a,$b,$c,$_[19],10,0xfe2ce6e0,/* 58 */
 476 II,$c,$d,$a,$b,$_[10],15,0xa3014314,/* 59 */
 477 II,$b,$c,$d,$a,$_[17],21,0x4e0811a1,/* 60 */
 478 II,$a,$b,$c,$d,$_[8],6,0xf7537e82,/* 61 */
 479 II,$d,$a,$b,$c,$_[15],10,0xbd3af235,/* 62 */
 480 II,$c,$d,$a,$b,$_[6],15,0x2ad7d2bb,/* 63 */
 481 II,$b,$c,$d,$a,$_[13],21,0xeb86d391,/* 64 */