# DES もどきライブラリ〜
# Copyright (c) Vid Forn , 2001 ( vid@geocities.co.jp )

# このファイルの著作権は放棄しませんが、
# 再配布／改編しての配布などは、金銭の授受が伴わない場合に
# 限って自由にどうぞ。金銭の授受を伴うものは認めません。
# 金を取るつもりなら、この程度のものは自分で作って下さい。

# 使用に際しては、個人／法人も商業／非商業も問いません。

# このファイルの関数に何らかの問題があったとしても
# 著作権者は一切の責任を取りません。
# 組み込んでの使用に際しては、十分にテストを
# 重ねて、問題が無い事を確認してから使用してください。

# 鍵を忘れた場合、復号はできません。
# 絶対に忘れないようにしましょう。

# 使用法
# require 'des.pl';
#
# $key = "key string";
# $data = "data string";
# $encode = &des::encrypt( $key , $data );
# $data = &des::decrypt( $key , $encode );

# 数値ではなく文字列から勝手に鍵を作ります。
# それなりに適当な鍵を作るようにはしてありますので、
# 長さは特に問いません。最低一文字以上であれば多分
# それなりの暗号になると思います……あくまでも多分。

# $encode はバイナリですので、
# ファイルに落す時などは長さ情報含めてきっちりと
# 落す必要があります。
# encline / decline を通せばそれなりに ASCII 化するように
# してあります。使用法は enc.pl / dec.pl を参考にしてください。

# md5.pl ( http://raiden.goice.co.jp/member/mo/release/ )
# があると、鍵を作成する時に md5 を使うようになります。
# そうでない場合は、このファイルの最後にくっつけた
# crc32 をベースに作ります。crc32 の部分だけ切り放して使っても
# かまいません。ただ、全然手を加えてないので、重たいです。
# ただし注意ですが、md5.pl と crc32 とでは鍵が変りますので、
# 必ず同じ関数を使用するように注意してください。

# 一つ言っておきます。
# DES はそれほど強い暗号ではありませんから、その使用は
# 十分に気をつけてください。
# しかもこの関数群は DES の「挙動を真似て」作ったものですから、
# 暗号の強度には更に問題が残ります。
# まぁ、クラックする為には自分でソフトを作成する必要があるため、
# そこらのアングラツールユーザーでは解けないとは思いますが。

# この関数群ですが『非常に重たい』ので、
# 大きなデータを暗号化するのには向きません。
# ちょっとしたデータに使用する程度です。

# ver 0.00.10b 2001/06/28 公開
#          20b      07/03 デコード時にうまくデコードされない
#                         IP のかけかた
#                         指定する KEY の間違い
#                         などのデバグ

package des;

&init unless defined $version;

sub init{
    $version = "0.00.20b.2001.07.03"; 
    &maketable();
    if( !$md5::version ){
	&crc32::init;
	$crc32::version;
    }
}

sub maketable{
    @cbitmask = (1, 2, 4, 8, 16, 32, 64, 128);

#    @iprt = ( 62,54,46,38,30,22,14, 6,
#	      60,52,44,36,28,20,12, 4,
#	      58,50,42,34,26,18,10, 2,
#	      56,48,40,32,24,16, 8, 0,
#	      63,55,47,39,31,23,15, 7,
#	      61,53,45,37,29,21,13, 5,
#	      59,51,43,35,27,19,11, 3,
#	      57,49,41,33,25,17, 9, 1 );
#    @iplt = ( 31,63,23,55,15,47, 7,39,
#	      30,62,22,54,14,46, 6,38,
#	      29,61,21,53,13,45, 5,37,
#	      28,60,20,52,12,44, 4,36,
#	      27,59,19,51,11,43, 3,35,
#	      26,58,18,50,10,42, 2,34,
#	      25,57,17,49, 9,41, 1,33,
#	      24,56,16,48, 8,40, 0,32 );

    @iprt = ( 55,48,62,38,63,35,44,23,
	      10,19,36,53,11,54, 4,33,
	       7, 2,58,50,43, 3,32,56,
	      47,13,29,17,61, 0,24,52,
	      45, 8,49,40,39,12,18,59,
	       9,42,16, 1,51,46,60, 6,
	      21, 5,28,25,37,41,30,22,
	      27,26,31,57,34,20,14,15 );

    @iplt = ( 29,43,17,21,14,49,47,16,
	      33,40, 8,12,37,25,62,63,
	      42,27,38, 9,61,48,55, 7,
	      30,51,57,56,50,26,54,58,
	      22,15,60, 5,10,52, 3,36,
	      35,53,41,20, 6,32,45,24,
	       1,34,19,44,31,11,13, 0,
	      23,59,18,39,46,28, 2, 4 );

    @keytable = ( 22,18,13,38, 5,34,62, 2,
		  10,50,53,60,61,11,31, 9,
		  45,59,58,12,43,35,14,55,
		  51,46,57,33,37,20,27,42,
		  25,32,26,17,36, 1,47, 6,
		  23,29,15,41,16,56,63,49,
		   3,39,54, 7,24,30, 0,52,
		   8, 4,21,48,28,44,40,19 );

    @bmap = @keytable;
}

sub encrypt{
    my ( $key , $val ) = @_;
    my ( $out , $r , $len );
    $len = pack( "C4" , unpack( "C4" , pack( "N" , length( $val ) ) ) );
    $val = $len . $val;
    $out = '';
    while( $val =~ /(.{1,16})/gs ){
	$r = $1;
	$out .= ( $r = crypt_block( 'e' , $r , $key ) );
    }

    return $out;
}
sub decrypt{
    my ( $key , $val ) = @_;
    my ( $out , $r , $len , @out );

    $out = '';
    while( $val =~ /(.{1,16})/gs ){
	$r = $1;
	$out .= ( $r = crypt_block( 'd' , $r , $key ) );
    }
    @out = unpack( "C*" , $out );
    $len = ( $out[0] << 24 ) + ( $out[1] << 16 )
	+ ( $out[2] << 8 ) + $out[3] + 3;
    @out = @out[4..$len];
    $out = pack( "C*" , @out );
    return $out;
}

sub crypt_block{
    my ( $f , $str , $key ) = @_;
    my ( @str1 , @str2 , @str3 , $i , @arr );

    @keylst = &keygene( $key );

    # 8 , 8 に分ける
    @str3 = unpack( "C*" , $str );
    @str1 = @str3[0..7];
    @str2 = @str3[8..15];

    # 両方に IP をかける
    &IPR( @str1 );
    &IPR( @str2 );

    if( $f eq 'e' ){
	@arr = ( 0..15 );
    } else {
	@arr = ( 15,14,13,12,11,10,9,8,7,6,5,4,3,2,1,0 );
    }

    # 計算 F
    @str3 = unpack( "C*" , $keylst[$arr[0]] );
    for( $str = 0 ; $str < 8 ; $str++ ){
	$str2[$str] ^= $str3[$str];
    }

    foreach $i ( @arr[1..15] ){
	# 左右を入れ替えて
	@str3 = @str1;
	@str1 = @str2;
	@str2 = @str3;
	# 計算 F
	@str3 = unpack( "C*" , $keylst[$i] );
	for( $str = 0 ; $str < 8 ; $str++ ){
	    $str2[$str] ^= $str3[$str];
	}

    }

    # 両方に IP をかける
    &IPL( @str1 );
    &IPL( @str2 );

    $str = pack( "C*" , @str1 , @str2 );
}

sub keygene{
    my ( $key ) = shift;
    my ( $bit , @b );
    my ( @out , @t1 , @t2 );

    if( $md5::version ){
	$bit = &md5::convert( $key );
	@b = unpack( "NNNN" , $bit );
    } else {
	$b[0] = $bit = &crc32::calc( 0xffff , $key );
	$b[1] = $bit = &crc32::calc( $bit , $key );
	$b[2] = $bit = &crc32::calc( $bit , $key );
	$b[3] = $bit = &crc32::calc( $bit , $key );
    }

    $out[0] = pack( "NN" , @b[0..1] );
    $out[1] = pack( "NN" , @b[2..3] );
    @bmap = @keytable;
    for( $i = 2 ; $i < 16 ; $i++ ){
	@t1 = unpack( "C*" , $out[$i-2] );
	@t2 = &IP( @t1 );
	$out[$i] = pack( "C*" , @t2 );
    }

    return @out;
}

sub IPR{
    my ( @dec ) = @_;
    @bmap = @iprt;
    return &IP( @dec );
}
sub IPL{
    my ( @dec ) = @_;
    @bmap = @iplt;
    return &IP( @dec );
}

sub IP{
    my ( @dec ) = @_;
    my ( @enc , $s1 , $s2 , $b , $c);

    @enc = ( 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 );
    $c = 0;
    for( my $i = 0 ; $i < 8 ; $i++ ){
	for( my $j = 0 ; $j < 8 ; $j++ ){
	    $s1 = ( $s2 = $bmap[$c] ) >> 3;
	    $s2 &= 7;
	    if( $dec[$s1] & $cbitmask[$s2] ){
		$enc[$i] |= ( 1 << $j );
	    }
	    $c++;
	}
    }

    return @enc;
}

sub encline{
    my ( $in ) = shift;
    my ( $out , $len );
    $len = sprintf("%x:" , length( $in )>>4 );
    while( $in =~ /(.{1,3})/gs ){
	$out .= &encblock( $1 );
    }
    return $len . $out;
}
sub encblock{
    my ( $in ) = shift;
    my( $out );
    $out = substr( $d = pack( "u" , $in ) , 1 );
    chop( $out );
    chop( $d );
    $out =~ tr|` -_|AA-Za-z0-9+/|; #`
    return $out;
}
sub decline{
    my ( $in ) = shift;
    my ( $out , $len , @out );
    chomp( $in );
    $in =~ /^([a-fA-F0-9]+):(.*)/;
    $in = $2;
    $len = hex( "0x" . $1 ) << 4;
    while( $in =~ /(.{1,4})/gs ){
	$out .=  &decblock( $1 );
    }
    @out = unpack( "C*" , $out );
    $len--;
    @out = @out[0..$len];
    $out = pack( "C*" , @out );
    return $out;
}
sub decblock{
    my ( $in ) = shift;
    my ( $out );
    $in =~ tr|A-Za-z0-9+/| -_|;
    $in = chr( $l = length( $in ) + 0x1F ) . $in;
    return unpack( "u" , $in  );
}

sub arrdump{
    foreach ( @_ ){
	printf("%02x " , $_ );
    }
    print "\n";
}

# ====================================================================
# CRC32

sub crc32::init{
    @crc32::crc32table = ( 0x00000000,0x77073096,0xee0e612c,0x990951ba,
		    0x076dc419,0x706af48f,0xe963a535,0x9e6495a3,
		    0x0edb8832,0x79dcb8a4,0xe0d5e91e,0x97d2d988,
		    0x09b64c2b,0x7eb17cbd,0xe7b82d07,0x90bf1d91,
		    0x1db71064,0x6ab020f2,0xf3b97148,0x84be41de,
		    0x1adad47d,0x6ddde4eb,0xf4d4b551,0x83d385c7,
		    0x136c9856,0x646ba8c0,0xfd62f97a,0x8a65c9ec,
		    0x14015c4f,0x63066cd9,0xfa0f3d63,0x8d080df5,
		    0x3b6e20c8,0x4c69105e,0xd56041e4,0xa2677172,
		    0x3c03e4d1,0x4b04d447,0xd20d85fd,0xa50ab56b,
		    0x35b5a8fa,0x42b2986c,0xdbbbc9d6,0xacbcf940,
		    0x32d86ce3,0x45df5c75,0xdcd60dcf,0xabd13d59,
		    0x26d930ac,0x51de003a,0xc8d75180,0xbfd06116,
		    0x21b4f4b5,0x56b3c423,0xcfba9599,0xb8bda50f,
		    0x2802b89e,0x5f058808,0xc60cd9b2,0xb10be924,
		    0x2f6f7c87,0x58684c11,0xc1611dab,0xb6662d3d,
		    0x76dc4190,0x01db7106,0x98d220bc,0xefd5102a,
		    0x71b18589,0x06b6b51f,0x9fbfe4a5,0xe8b8d433,
		    0x7807c9a2,0x0f00f934,0x9609a88e,0xe10e9818,
		    0x7f6a0dbb,0x086d3d2d,0x91646c97,0xe6635c01,
		    0x6b6b51f4,0x1c6c6162,0x856530d8,0xf262004e,
		    0x6c0695ed,0x1b01a57b,0x8208f4c1,0xf50fc457,
		    0x65b0d9c6,0x12b7e950,0x8bbeb8ea,0xfcb9887c,
		    0x62dd1ddf,0x15da2d49,0x8cd37cf3,0xfbd44c65,
		    0x4db26158,0x3ab551ce,0xa3bc0074,0xd4bb30e2,
		    0x4adfa541,0x3dd895d7,0xa4d1c46d,0xd3d6f4fb,
		    0x4369e96a,0x346ed9fc,0xad678846,0xda60b8d0,
		    0x44042d73,0x33031de5,0xaa0a4c5f,0xdd0d7cc9,
		    0x5005713c,0x270241aa,0xbe0b1010,0xc90c2086,
		    0x5768b525,0x206f85b3,0xb966d409,0xce61e49f,
		    0x5edef90e,0x29d9c998,0xb0d09822,0xc7d7a8b4,
		    0x59b33d17,0x2eb40d81,0xb7bd5c3b,0xc0ba6cad,
		    0xedb88320,0x9abfb3b6,0x03b6e20c,0x74b1d29a,
		    0xead54739,0x9dd277af,0x04db2615,0x73dc1683,
		    0xe3630b12,0x94643b84,0x0d6d6a3e,0x7a6a5aa8,
		    0xe40ecf0b,0x9309ff9d,0x0a00ae27,0x7d079eb1,
		    0xf00f9344,0x8708a3d2,0x1e01f268,0x6906c2fe,
		    0xf762575d,0x806567cb,0x196c3671,0x6e6b06e7,
		    0xfed41b76,0x89d32be0,0x10da7a5a,0x67dd4acc,
		    0xf9b9df6f,0x8ebeeff9,0x17b7be43,0x60b08ed5,
		    0xd6d6a3e8,0xa1d1937e,0x38d8c2c4,0x4fdff252,
		    0xd1bb67f1,0xa6bc5767,0x3fb506dd,0x48b2364b,
		    0xd80d2bda,0xaf0a1b4c,0x36034af6,0x41047a60,
		    0xdf60efc3,0xa867df55,0x316e8eef,0x4669be79,
		    0xcb61b38c,0xbc66831a,0x256fd2a0,0x5268e236,
		    0xcc0c7795,0xbb0b4703,0x220216b9,0x5505262f,
		    0xc5ba3bbe,0xb2bd0b28,0x2bb45a92,0x5cb36a04,
		    0xc2d7ffa7,0xb5d0cf31,0x2cd99e8b,0x5bdeae1d,
		    0x9b64c2b0,0xec63f226,0x756aa39c,0x026d930a,
		    0x9c0906a9,0xeb0e363f,0x72076785,0x05005713,
		    0x95bf4a82,0xe2b87a14,0x7bb12bae,0x0cb61b38,
		    0x92d28e9b,0xe5d5be0d,0x7cdcefb7,0x0bdbdf21,
		    0x86d3d2d4,0xf1d4e242,0x68ddb3f8,0x1fda836e,
		    0x81be16cd,0xf6b9265b,0x6fb077e1,0x18b74777,
		    0x88085ae6,0xff0f6a70,0x66063bca,0x11010b5c,
		    0x8f659eff,0xf862ae69,0x616bffd3,0x166ccf45,
		    0xa00ae278,0xd70dd2ee,0x4e048354,0x3903b3c2,
		    0xa7672661,0xd06016f7,0x4969474d,0x3e6e77db,
		    0xaed16a4a,0xd9d65adc,0x40df0b66,0x37d83bf0,
		    0xa9bcae53,0xdebb9ec5,0x47b2cf7f,0x30b5ffe9,
		    0xbdbdf21c,0xcabac28a,0x53b39330,0x24b4a3a6,
		    0xbad03605,0xcdd70693,0x54de5729,0x23d967bf,
		    0xb3667a2e,0xc4614ab8,0x5d681b02,0x2a6f2b94,
		    0xb40bbe37,0xc30c8ea1,0x5a05df1b,0x2d02ef8d );

    $crc32::version = "0.00.10b.2001.06.28";
}

sub crc32::crc32{
    my( @data ) = @_;
    my( @out , $crc , $str );
    foreach $str ( @data ){
	$crc = 0xffffffff;
	$crc = &calc( $crc , $str );
	$crc ^= 0xffffffff;
	@out = ( @out , $crc );
    }
    return @out;
}

sub crc32::calc{
    my ( $c32 , @data ) = @_;
    my ( $str , $c );

    foreach $str ( @data ){
	foreach $c ( unpack( "C*" , $str ) ){
	    $c32 = ( ( $c32 >> 8 ) & 0xffffff )
		^ ( $crc32::crc32table[ ( $c32 & 0xff ) ^ $c ] );
	}
    }
    return $c32;
}

# おまけ。
# 暗号の置換表を作るスクリプト

##!/usr/local/bin/perl
#
#for( $i = 0 ; $i < 64 ; $i++ ){
#    $t[$i] = $i;
#}
#@array = @t;
#srand;
#for (my $i = @array; --$i; ) {
#    my $j = int rand ($i + 1);
#    next if $i == $j;
#    @array[$i, $j] = @array[$j, $i];
#}
#
#@t = @array;
#
#for( $i = 0 ; $i < 64 ; $i++ ){
#    $b[$t[$i]] = $i;
#}
#$c = 0;
#
#print "\@iprt = ( ";
#foreach ( @t ){
#    printf("%2d,",$_);
#    $c++;
#    if( $c ==8 ){$c = 0;print "\n";}
#}
#print ");\n\@iplt = ( ";
#foreach ( @b ){
#    printf("%2d,",$_);
#    $c++;
#    if( $c ==8 ){$c = 0;print "\n";}
#}
#print ");\n";

# これで置換表を置き換えたら、あなただけの
# 暗号になる……かも(^^;;。
# 乱数部分参考:perl メモ／配列をランダムに並び替える
# http://www.din.or.jp/~ohzaki/perl.htm#ArrayRandom

1;