| #! /usr/bin/false |
| # |
| # $Id: MD5.pm,v 1.23 2004/08/27 20:28:25 lackas Exp $ |
| # |
| |
| package Digest::Perl::MD5; |
| use strict; |
| use integer; |
| use Exporter; |
| use vars qw($VERSION @ISA @EXPORTER @EXPORT_OK); |
| |
| @EXPORT_OK = qw(md5 md5_hex md5_base64); |
| |
| @ISA = 'Exporter'; |
| $VERSION = '1.8'; |
| |
| # I-Vektor |
| sub A() { 0x67_45_23_01 } |
| sub B() { 0xef_cd_ab_89 } |
| sub C() { 0x98_ba_dc_fe } |
| sub D() { 0x10_32_54_76 } |
| |
| # for internal use |
| sub MAX() { 0xFFFFFFFF } |
| |
| # padd a message to a multiple of 64 |
| sub padding { |
| my $l = length (my $msg = shift() . chr(128)); |
| $msg .= "\0" x (($l%64<=56?56:120)-$l%64); |
| $l = ($l-1)*8; |
| $msg .= pack 'VV', $l & MAX , ($l >> 16 >> 16); |
| } |
| |
| |
| sub rotate_left($$) { |
| #$_[0] << $_[1] | $_[0] >> (32 - $_[1]); |
| #my $right = $_[0] >> (32 - $_[1]); |
| #my $rmask = (1 << $_[1]) - 1; |
| ($_[0] << $_[1]) | (( $_[0] >> (32 - $_[1]) ) & ((1 << $_[1]) - 1)); |
| #$_[0] << $_[1] | (($_[0]>> (32 - $_[1])) & (1 << (32 - $_[1])) - 1); |
| } |
| |
| sub gen_code { |
| # Discard upper 32 bits on 64 bit archs. |
| my $MSK = ((1 << 16) << 16) ? ' & ' . MAX : ''; |
| # FF => "X0=rotate_left(((X1&X2)|(~X1&X3))+X0+X4+X6$MSK,X5)+X1$MSK;", |
| # GG => "X0=rotate_left(((X1&X3)|(X2&(~X3)))+X0+X4+X6$MSK,X5)+X1$MSK;", |
| my %f = ( |
| FF => "X0=rotate_left((X3^(X1&(X2^X3)))+X0+X4+X6$MSK,X5)+X1$MSK;", |
| GG => "X0=rotate_left((X2^(X3&(X1^X2)))+X0+X4+X6$MSK,X5)+X1$MSK;", |
| HH => "X0=rotate_left((X1^X2^X3)+X0+X4+X6$MSK,X5)+X1$MSK;", |
| II => "X0=rotate_left((X2^(X1|(~X3)))+X0+X4+X6$MSK,X5)+X1$MSK;", |
| ); |
| #unless ( (1 << 16) << 16) { %f = %{$CODES{'32bit'}} } |
| #else { %f = %{$CODES{'64bit'}} } |
| |
| my %s = ( # shift lengths |
| S11 => 7, S12 => 12, S13 => 17, S14 => 22, S21 => 5, S22 => 9, S23 => 14, |
| S24 => 20, S31 => 4, S32 => 11, S33 => 16, S34 => 23, S41 => 6, S42 => 10, |
| S43 => 15, S44 => 21 |
| ); |
| |
| my $insert = "\n"; |
| while(<DATA>) { |
| chomp; |
| next unless /^[FGHI]/; |
| my ($func,@x) = split /,/; |
| my $c = $f{$func}; |
| $c =~ s/X(\d)/$x[$1]/g; |
| $c =~ s/(S\d{2})/$s{$1}/; |
| $c =~ s/^(.*)=rotate_left\((.*),(.*)\)\+(.*)$//; |
| |
| my $su = 32 - $3; |
| my $sh = (1 << $3) - 1; |
| |
| $c = "$1=(((\$r=$2)<<$3)|((\$r>>$su)&$sh))+$4"; |
| |
| #my $rotate = "(($2 << $3) || (($2 >> (32 - $3)) & (1 << $2) - 1)))"; |
| # $c = "\$r = $2; |
| # $1 = ((\$r << $3) | ((\$r >> (32 - $3)) & ((1 << $3) - 1))) + $4"; |
| $insert .= "\t$c\n"; |
| } |
| close DATA; |
| |
| my $dump = ' |
| sub round { |
| my ($a,$b,$c,$d) = @_[0 .. 3]; |
| my $r;' . $insert . ' |
| $_[0]+$a' . $MSK . ', $_[1]+$b ' . $MSK . |
| ', $_[2]+$c' . $MSK . ', $_[3]+$d' . $MSK . '; |
| }'; |
| eval $dump; |
| # print "$dump\n"; |
| # exit 0; |
| } |
| |
| gen_code(); |
| |
| ######################################### |
| # Private output converter functions: |
| sub _encode_hex { unpack 'H*', $_[0] } |
| sub _encode_base64 { |
| my $res; |
| while ($_[0] =~ /(.{1,45})/gs) { |
| $res .= substr pack('u', $1), 1; |
| chop $res; |
| } |
| $res =~ tr|` -_|AA-Za-z0-9+/|;#` |
| chop $res; chop $res; |
| $res |
| } |
| |
| ######################################### |
| # OOP interface: |
| sub new { |
| my $proto = shift; |
| my $class = ref $proto || $proto; |
| my $self = {}; |
| bless $self, $class; |
| $self->reset(); |
| $self |
| } |
| |
| sub reset { |
| my $self = shift; |
| delete $self->{_data}; |
| $self->{_state} = [A,B,C,D]; |
| $self->{_length} = 0; |
| $self |
| } |
| |
| sub add { |
| my $self = shift; |
| $self->{_data} .= join '', @_ if @_; |
| my ($i,$c); |
| for $i (0 .. (length $self->{_data})/64-1) { |
| my @X = unpack 'V16', substr $self->{_data}, $i*64, 64; |
| @{$self->{_state}} = round(@{$self->{_state}},@X); |
| ++$c; |
| } |
| if ($c) { |
| substr ($self->{_data}, 0, $c*64) = ''; |
| $self->{_length} += $c*64; |
| } |
| $self |
| } |
| |
| sub finalize { |
| my $self = shift; |
| $self->{_data} .= chr(128); |
| my $l = $self->{_length} + length $self->{_data}; |
| $self->{_data} .= "\0" x (($l%64<=56?56:120)-$l%64); |
| $l = ($l-1)*8; |
| $self->{_data} .= pack 'VV', $l & MAX , ($l >> 16 >> 16); |
| $self->add(); |
| $self |
| } |
| |
| sub addfile { |
| my ($self,$fh) = @_; |
| if (!ref($fh) && ref(\$fh) ne "GLOB") { |
| require Symbol; |
| $fh = Symbol::qualify($fh, scalar caller); |
| } |
| # $self->{_data} .= do{local$/;<$fh>}; |
| my $read = 0; |
| my $buffer = ''; |
| $self->add($buffer) while $read = read $fh, $buffer, 8192; |
| die __PACKAGE__, " read failed: $!" unless defined $read; |
| $self |
| } |
| |
| sub add_bits { |
| my $self = shift; |
| return $self->add( pack 'B*', shift ) if @_ == 1; |
| my ($b,$n) = @_; |
| die __PACKAGE__, " Invalid number of bits\n" if $n%8; |
| $self->add( substr $b, 0, $n/8 ) |
| } |
| |
| sub digest { |
| my $self = shift; |
| $self->finalize(); |
| my $res = pack 'V4', @{$self->{_state}}; |
| $self->reset(); |
| $res |
| } |
| |
| sub hexdigest { |
| _encode_hex($_[0]->digest) |
| } |
| |
| sub b64digest { |
| _encode_base64($_[0]->digest) |
| } |
| |
| sub clone { |
| my $self = shift; |
| my $clone = { |
| _state => [@{$self->{_state}}], |
| _length => $self->{_length}, |
| _data => $self->{_data} |
| }; |
| bless $clone, ref $self || $self; |
| } |
| |
| ######################################### |
| # Procedural interface: |
| sub md5 { |
| my $message = padding(join'',@_); |
| my ($a,$b,$c,$d) = (A,B,C,D); |
| my $i; |
| for $i (0 .. (length $message)/64-1) { |
| my @X = unpack 'V16', substr $message,$i*64,64; |
| ($a,$b,$c,$d) = round($a,$b,$c,$d,@X); |
| } |
| pack 'V4',$a,$b,$c,$d; |
| } |
| sub md5_hex { _encode_hex &md5 } |
| sub md5_base64 { _encode_base64 &md5 } |
| |
| |
| 1; |
| |
| =head1 NAME |
| |
| Digest::MD5::Perl - Perl implementation of Ron Rivests MD5 Algorithm |
| |
| =head1 DISCLAIMER |
| |
| This is B<not> an interface (like C<Digest::MD5>) but a Perl implementation of MD5. |
| It is written in perl only and because of this it is slow but it works without C-Code. |
| You should use C<Digest::MD5> instead of this module if it is available. |
| This module is only usefull for |
| |
| =over 4 |
| |
| =item |
| |
| computers where you cannot install C<Digest::MD5> (e.g. lack of a C-Compiler) |
| |
| =item |
| |
| encrypting only small amounts of data (less than one million bytes). I use it to |
| hash passwords. |
| |
| =item |
| |
| educational purposes |
| |
| =back |
| |
| =head1 SYNOPSIS |
| |
| # Functional style |
| use Digest::MD5 qw(md5 md5_hex md5_base64); |
| |
| $hash = md5 $data; |
| $hash = md5_hex $data; |
| $hash = md5_base64 $data; |
| |
| |
| # OO style |
| use Digest::MD5; |
| |
| $ctx = Digest::MD5->new; |
| |
| $ctx->add($data); |
| $ctx->addfile(*FILE); |
| |
| $digest = $ctx->digest; |
| $digest = $ctx->hexdigest; |
| $digest = $ctx->b64digest; |
| |
| =head1 DESCRIPTION |
| |
| This modules has the same interface as the much faster C<Digest::MD5>. So you can |
| easily exchange them, e.g. |
| |
| BEGIN { |
| eval { |
| require Digest::MD5; |
| import Digest::MD5 'md5_hex' |
| }; |
| if ($@) { # ups, no Digest::MD5 |
| require Digest::Perl::MD5; |
| import Digest::Perl::MD5 'md5_hex' |
| } |
| } |
| |
| If the C<Digest::MD5> module is available it is used and if not you take |
| C<Digest::Perl::MD5>. |
| |
| You can also install the Perl part of Digest::MD5 together with Digest::Perl::MD5 |
| and use Digest::MD5 as normal, it falls back to Digest::Perl::MD5 if it |
| cannot load its object files. |
| |
| For a detailed Documentation see the C<Digest::MD5> module. |
| |
| =head1 EXAMPLES |
| |
| The simplest way to use this library is to import the md5_hex() |
| function (or one of its cousins): |
| |
| use Digest::Perl::MD5 'md5_hex'; |
| print 'Digest is ', md5_hex('foobarbaz'), "\n"; |
| |
| The above example would print out the message |
| |
| Digest is 6df23dc03f9b54cc38a0fc1483df6e21 |
| |
| provided that the implementation is working correctly. The same |
| checksum can also be calculated in OO style: |
| |
| use Digest::MD5; |
| |
| $md5 = Digest::MD5->new; |
| $md5->add('foo', 'bar'); |
| $md5->add('baz'); |
| $digest = $md5->hexdigest; |
| |
| print "Digest is $digest\n"; |
| |
| The digest methods are destructive. That means you can only call them |
| once and the $md5 objects is reset after use. You can make a copy with clone: |
| |
| $md5->clone->hexdigest |
| |
| =head1 LIMITATIONS |
| |
| This implementation of the MD5 algorithm has some limitations: |
| |
| =over 4 |
| |
| =item |
| |
| It's slow, very slow. I've done my very best but Digest::MD5 is still about 100 times faster. |
| You can only encrypt Data up to one million bytes in an acceptable time. But it's very usefull |
| for encrypting small amounts of data like passwords. |
| |
| =item |
| |
| You can only encrypt up to 2^32 bits = 512 MB on 32bit archs. But You should |
| use C<Digest::MD5> for those amounts of data anyway. |
| |
| =back |
| |
| =head1 SEE ALSO |
| |
| L<Digest::MD5> |
| |
| L<md5(1)> |
| |
| RFC 1321 |
| |
| tools/md5: a small BSD compatible md5 tool written in pure perl. |
| |
| =head1 COPYRIGHT |
| |
| This library is free software; you can redistribute it and/or |
| modify it under the same terms as Perl itself. |
| |
| Copyright 2000 Christian Lackas, Imperia Software Solutions |
| Copyright 1998-1999 Gisle Aas. |
| Copyright 1995-1996 Neil Winton. |
| Copyright 1991-1992 RSA Data Security, Inc. |
| |
| The MD5 algorithm is defined in RFC 1321. The basic C code |
| implementing the algorithm is derived from that in the RFC and is |
| covered by the following copyright: |
| |
| =over 4 |
| |
| =item |
| |
| Copyright (C) 1991-1992, RSA Data Security, Inc. Created 1991. All |
| rights reserved. |
| |
| License to copy and use this software is granted provided that it |
| is identified as the "RSA Data Security, Inc. MD5 Message-Digest |
| Algorithm" in all material mentioning or referencing this software |
| or this function. |
| |
| License is also granted to make and use derivative works provided |
| that such works are identified as "derived from the RSA Data |
| Security, Inc. MD5 Message-Digest Algorithm" in all material |
| mentioning or referencing the derived work. |
| |
| RSA Data Security, Inc. makes no representations concerning either |
| the merchantability of this software or the suitability of this |
| software for any particular purpose. It is provided "as is" |
| without express or implied warranty of any kind. |
| |
| These notices must be retained in any copies of any part of this |
| documentation and/or software. |
| |
| =back |
| |
| This copyright does not prohibit distribution of any version of Perl |
| containing this extension under the terms of the GNU or Artistic |
| licenses. |
| |
| =head1 AUTHORS |
| |
| The original MD5 interface was written by Neil Winton |
| (<N.Winton (at) axion.bt.co.uk>). |
| |
| C<Digest::MD5> was made by Gisle Aas <gisle (at) aas.no> (I took his Interface |
| and part of the documentation). |
| |
| Thanks to Guido Flohr for his 'use integer'-hint. |
| |
| This release was made by Christian Lackas <delta (at) lackas.net>. |
| |
| =cut |
| |
| __DATA__ |
| FF,$a,$b,$c,$d,$_[4],7,0xd76aa478,/* 1 */ |
| FF,$d,$a,$b,$c,$_[5],12,0xe8c7b756,/* 2 */ |
| FF,$c,$d,$a,$b,$_[6],17,0x242070db,/* 3 */ |
| FF,$b,$c,$d,$a,$_[7],22,0xc1bdceee,/* 4 */ |
| FF,$a,$b,$c,$d,$_[8],7,0xf57c0faf,/* 5 */ |
| FF,$d,$a,$b,$c,$_[9],12,0x4787c62a,/* 6 */ |
| FF,$c,$d,$a,$b,$_[10],17,0xa8304613,/* 7 */ |
| FF,$b,$c,$d,$a,$_[11],22,0xfd469501,/* 8 */ |
| FF,$a,$b,$c,$d,$_[12],7,0x698098d8,/* 9 */ |
| FF,$d,$a,$b,$c,$_[13],12,0x8b44f7af,/* 10 */ |
| FF,$c,$d,$a,$b,$_[14],17,0xffff5bb1,/* 11 */ |
| FF,$b,$c,$d,$a,$_[15],22,0x895cd7be,/* 12 */ |
| FF,$a,$b,$c,$d,$_[16],7,0x6b901122,/* 13 */ |
| FF,$d,$a,$b,$c,$_[17],12,0xfd987193,/* 14 */ |
| FF,$c,$d,$a,$b,$_[18],17,0xa679438e,/* 15 */ |
| FF,$b,$c,$d,$a,$_[19],22,0x49b40821,/* 16 */ |
| GG,$a,$b,$c,$d,$_[5],5,0xf61e2562,/* 17 */ |
| GG,$d,$a,$b,$c,$_[10],9,0xc040b340,/* 18 */ |
| GG,$c,$d,$a,$b,$_[15],14,0x265e5a51,/* 19 */ |
| GG,$b,$c,$d,$a,$_[4],20,0xe9b6c7aa,/* 20 */ |
| GG,$a,$b,$c,$d,$_[9],5,0xd62f105d,/* 21 */ |
| GG,$d,$a,$b,$c,$_[14],9,0x2441453,/* 22 */ |
| GG,$c,$d,$a,$b,$_[19],14,0xd8a1e681,/* 23 */ |
| GG,$b,$c,$d,$a,$_[8],20,0xe7d3fbc8,/* 24 */ |
| GG,$a,$b,$c,$d,$_[13],5,0x21e1cde6,/* 25 */ |
| GG,$d,$a,$b,$c,$_[18],9,0xc33707d6,/* 26 */ |
| GG,$c,$d,$a,$b,$_[7],14,0xf4d50d87,/* 27 */ |
| GG,$b,$c,$d,$a,$_[12],20,0x455a14ed,/* 28 */ |
| GG,$a,$b,$c,$d,$_[17],5,0xa9e3e905,/* 29 */ |
| GG,$d,$a,$b,$c,$_[6],9,0xfcefa3f8,/* 30 */ |
| GG,$c,$d,$a,$b,$_[11],14,0x676f02d9,/* 31 */ |
| GG,$b,$c,$d,$a,$_[16],20,0x8d2a4c8a,/* 32 */ |
| HH,$a,$b,$c,$d,$_[9],4,0xfffa3942,/* 33 */ |
| HH,$d,$a,$b,$c,$_[12],11,0x8771f681,/* 34 */ |
| HH,$c,$d,$a,$b,$_[15],16,0x6d9d6122,/* 35 */ |
| HH,$b,$c,$d,$a,$_[18],23,0xfde5380c,/* 36 */ |
| HH,$a,$b,$c,$d,$_[5],4,0xa4beea44,/* 37 */ |
| HH,$d,$a,$b,$c,$_[8],11,0x4bdecfa9,/* 38 */ |
| HH,$c,$d,$a,$b,$_[11],16,0xf6bb4b60,/* 39 */ |
| HH,$b,$c,$d,$a,$_[14],23,0xbebfbc70,/* 40 */ |
| HH,$a,$b,$c,$d,$_[17],4,0x289b7ec6,/* 41 */ |
| HH,$d,$a,$b,$c,$_[4],11,0xeaa127fa,/* 42 */ |
| HH,$c,$d,$a,$b,$_[7],16,0xd4ef3085,/* 43 */ |
| HH,$b,$c,$d,$a,$_[10],23,0x4881d05,/* 44 */ |
| HH,$a,$b,$c,$d,$_[13],4,0xd9d4d039,/* 45 */ |
| HH,$d,$a,$b,$c,$_[16],11,0xe6db99e5,/* 46 */ |
| HH,$c,$d,$a,$b,$_[19],16,0x1fa27cf8,/* 47 */ |
| HH,$b,$c,$d,$a,$_[6],23,0xc4ac5665,/* 48 */ |
| II,$a,$b,$c,$d,$_[4],6,0xf4292244,/* 49 */ |
| II,$d,$a,$b,$c,$_[11],10,0x432aff97,/* 50 */ |
| II,$c,$d,$a,$b,$_[18],15,0xab9423a7,/* 51 */ |
| II,$b,$c,$d,$a,$_[9],21,0xfc93a039,/* 52 */ |
| II,$a,$b,$c,$d,$_[16],6,0x655b59c3,/* 53 */ |
| II,$d,$a,$b,$c,$_[7],10,0x8f0ccc92,/* 54 */ |
| II,$c,$d,$a,$b,$_[14],15,0xffeff47d,/* 55 */ |
| II,$b,$c,$d,$a,$_[5],21,0x85845dd1,/* 56 */ |
| II,$a,$b,$c,$d,$_[12],6,0x6fa87e4f,/* 57 */ |
| II,$d,$a,$b,$c,$_[19],10,0xfe2ce6e0,/* 58 */ |
| II,$c,$d,$a,$b,$_[10],15,0xa3014314,/* 59 */ |
| II,$b,$c,$d,$a,$_[17],21,0x4e0811a1,/* 60 */ |
| II,$a,$b,$c,$d,$_[8],6,0xf7537e82,/* 61 */ |
| II,$d,$a,$b,$c,$_[15],10,0xbd3af235,/* 62 */ |
| II,$c,$d,$a,$b,$_[6],15,0x2ad7d2bb,/* 63 */ |
| II,$b,$c,$d,$a,$_[13],21,0xeb86d391,/* 64 */ |