Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Основная";
Текущий архив: 2004.08.29;
Скачать: [xml.tar.bz2];

Вниз

Помогите, пожалуйста, перевести кусок код с Си на Pascal.   Найти похожие ветки 

 
Андрей007   (2004-08-14 10:23) [0]

Это программа вычисления контрольной суммы файла.
Расчёт контрольной суммы по алгоритму CRC32.
Расчёт контрольной суммы по алгоритму cyclic redundancy code (CRC32), описанному в стандарте ISO 3309 осуществляется с помощью регистра сдвига с обратной связью в операционной системе Windows 9x, NT, 2000, XP, 2003.
Пример использования CRC32.EXE:
команда для ОС Windows: CRC32.EXE RSM.XML >RSM.CRC
что означает: сформировать файл RSM.CRC, содержащий контрольную
сумму файла RSM.XML
формирует файл RSM.CRC вида:
CRC32 - Cyclic Redundancy Checker Version 1.0,dmc 1/25/91
Command line entered:
RSM.XML
C:\ RSM.XML
40260 Bytes Processed
40260 9-14-95 9:36:50p 16-bit CRC = B9E2 32-bit CRC = 3890C5B6

где контрольная сумма, расчитанная по алгоритму CRC32 = 3890C5B6
Исходный код программы, на языке программирования C (Си), пригодный для компилирования в среде Microsoft Visual Studio:

#include "stdafx.h"
#include <windows.h>
#include <winbase.h>
static const long CRC32Table[256] =
{
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
};
unsigned long InitCRC32 ()
{
return -1L;
}
unsigned long UpdateCRC32 ( char val, unsigned long crc )
{
return CRC32Table[(unsigned char)crc^val & 0xff] ^ (crc>>8);
}
//
// Подсчёт CRC32
//
int crc32 (char * fname, char * fout)
{
char a[8];
FILE *file = fopen( fname, "rb" );
if( !file ) return -1;
unsigned long crc = InitCRC32();
int c;
while( (c = fgetc( file )) != EOF )
crc = UpdateCRC32( unsigned(c), crc );
crc = ~crc;
fclose (file);
FILE *fileout= fopen( fout,"w" );
if( !fileout ) return -1;
sprintf(a,"%08lX",crc);
fputs((char *) a,fileout);
fclose (fileout);
return 0;
}
// Главная процедура
int main(int argc, char* argv[])
{
int a=-1;
if (argc=3)
{
printf("In: %s\n",argv[1]);
printf("Out: %s\n",argv[2]);
a=crc32(argv[1],argv[2]);
};
return a;
}


 
Sun bittern ©   (2004-08-14 10:25) [1]

На сайте TDelphi вроде на паскале есть пример


 
Андрей007   (2004-08-14 10:30) [2]

Вы имеете в виду сайт www.tdelphi.ru? Он не работает. На www.tdelphi.com написано что-то по-тайваньски и не работает ни одна ссылка на страницы внутри сайта - работают только ссылки на внешние сайты.


 
Frozzen   (2004-08-14 10:49) [3]

unit CRC32;
interface
function GetCRC32(data : String): LongWord;

implementation

const crc32tab : array [0..255] of LongWord = ($00000000, $77073096, $ee0e612c, $990951ba , $076dc419 ,
 $706af48f , $e963a535 , $9e6495a3 , $0edb8832 , $79dcb8a4 ,
 $e0d5e91e , $97d2d988 , $09b64c2b , $7eb17cbd , $e7b82d07 ,
 $90bf1d91 , $1db71064 , $6ab020f2 , $f3b97148 , $84be41de ,
 $1adad47d , $6ddde4eb , $f4d4b551 , $83d385c7 , $136c9856 ,
 $646ba8c0 , $fd62f97a , $8a65c9ec , $14015c4f , $63066cd9 ,
 $fa0f3d63 , $8d080df5 , $3b6e20c8 , $4c69105e , $d56041e4 ,
 $a2677172 , $3c03e4d1 , $4b04d447 , $d20d85fd , $a50ab56b ,
 $35b5a8fa , $42b2986c , $dbbbc9d6 , $acbcf940 , $32d86ce3 ,
 $45df5c75 , $dcd60dcf , $abd13d59 , $26d930ac , $51de003a ,
 $c8d75180 , $bfd06116 , $21b4f4b5 , $56b3c423 , $cfba9599 ,
 $b8bda50f , $2802b89e , $5f058808 , $c60cd9b2 , $b10be924 ,
 $2f6f7c87 , $58684c11 , $c1611dab , $b6662d3d , $76dc4190 ,
 $01db7106 , $98d220bc , $efd5102a , $71b18589 , $06b6b51f ,
 $9fbfe4a5 , $e8b8d433 , $7807c9a2 , $0f00f934 , $9609a88e ,
 $e10e9818 , $7f6a0dbb , $086d3d2d , $91646c97 , $e6635c01 ,
 $6b6b51f4 , $1c6c6162 , $856530d8 , $f262004e , $6c0695ed ,
 $1b01a57b , $8208f4c1 , $f50fc457 , $65b0d9c6 , $12b7e950 ,
 $8bbeb8ea , $fcb9887c , $62dd1ddf , $15da2d49 , $8cd37cf3 ,
 $fbd44c65 , $4db26158 , $3ab551ce , $a3bc0074 , $d4bb30e2 ,
 $4adfa541 , $3dd895d7 , $a4d1c46d , $d3d6f4fb , $4369e96a ,
 $346ed9fc , $ad678846 , $da60b8d0 , $44042d73 , $33031de5 ,
 $aa0a4c5f , $dd0d7cc9 , $5005713c , $270241aa , $be0b1010 ,
 $c90c2086 , $5768b525 , $206f85b3 , $b966d409 , $ce61e49f ,
 $5edef90e , $29d9c998 , $b0d09822 , $c7d7a8b4 , $59b33d17 ,
 $2eb40d81 , $b7bd5c3b , $c0ba6cad , $edb88320 , $9abfb3b6 ,
 $03b6e20c , $74b1d29a , $ead54739 , $9dd277af , $04db2615 ,
 $73dc1683 , $e3630b12 , $94643b84 , $0d6d6a3e , $7a6a5aa8 ,
 $e40ecf0b , $9309ff9d , $0a00ae27 , $7d079eb1 , $f00f9344 ,
 $8708a3d2 , $1e01f268 , $6906c2fe , $f762575d , $806567cb ,
 $196c3671 , $6e6b06e7 , $fed41b76 , $89d32be0 , $10da7a5a ,
 $67dd4acc , $f9b9df6f , $8ebeeff9 , $17b7be43 , $60b08ed5 ,
 $d6d6a3e8 , $a1d1937e , $38d8c2c4 , $4fdff252 , $d1bb67f1 ,
 $a6bc5767 , $3fb506dd , $48b2364b , $d80d2bda , $af0a1b4c ,
 $36034af6 , $41047a60 , $df60efc3 , $a867df55 , $316e8eef ,
 $4669be79 , $cb61b38c , $bc66831a , $256fd2a0 , $5268e236 ,
 $cc0c7795 , $bb0b4703 , $220216b9 , $5505262f , $c5ba3bbe ,
 $b2bd0b28 , $2bb45a92 , $5cb36a04 , $c2d7ffa7 , $b5d0cf31 ,
 $2cd99e8b , $5bdeae1d , $9b64c2b0 , $ec63f226 , $756aa39c ,
 $026d930a , $9c0906a9 , $eb0e363f , $72076785 , $05005713 ,
 $95bf4a82 , $e2b87a14 , $7bb12bae , $0cb61b38 , $92d28e9b ,
 $e5d5be0d , $7cdcefb7 , $0bdbdf21 , $86d3d2d4 , $f1d4e242 ,
 $68ddb3f8 , $1fda836e , $81be16cd , $f6b9265b , $6fb077e1 ,
 $18b74777 , $88085ae6 , $ff0f6a70 , $66063bca , $11010b5c ,
 $8f659eff , $f862ae69 , $616bffd3 , $166ccf45 , $a00ae278 ,
 $d70dd2ee , $4e048354 , $3903b3c2 , $a7672661 , $d06016f7 ,
 $4969474d , $3e6e77db , $aed16a4a , $d9d65adc , $40df0b66 ,
 $37d83bf0 , $a9bcae53 , $debb9ec5 , $47b2cf7f , $30b5ffe9 ,
 $bdbdf21c , $cabac28a , $53b39330 , $24b4a3a6 , $bad03605 ,
 $cdd70693 , $54de5729 , $23d967bf , $b3667a2e , $c4614ab8 ,
 $5d681b02 , $2a6f2b94 , $b40bbe37 , $c30c8ea1 , $5a05df1b ,
 $2d02ef8d );
//-----------------------------------------------------------------------------

function  Crc32Next (CRC32Current: LongWord; data: LongWord): LongWord;
Asm //EAX - CRC32Current; EDX - Data;
   XOR EDX, EAX
   AND EDX, $FF                      
   SHR EAX, 8
   XOR EAX, DWORD PTR CRC32Tab[EDX]
End;//Crc32Next
//------------------------------------------------------------------------------

function GetCRC32(data : String): LongWord;
var i : Integer;
begin
Result := $FFFFFFFF;
for i := 1 to Length(data) do
   Result := Crc32Next(Result, LongWord(data[i]));
Asm
 NOT   Result
end;
end;

end.


 
Андрей007   (2004-08-14 10:52) [4]

Большое спасибо.


 
Mim1 ©   (2004-08-14 12:14) [5]

Еще для кучи. Код не мой.

var
CRC32Table : array[0..255] of longint;

procedure makeCRC32table;
var
 crc : Int64;
 i,n : byte;
begin
 for i := 0 to 255 do
   begin
     crc := i;
     for n := 1 to 8 do
       if odd(crc)
         then crc := (crc shr 1) xor $EDB88320
         else crc := (crc shr 1);
     crc32table[i] := crc;
   end;
end;


 
OSokin ©   (2004-08-14 20:29) [6]

{*************************************************************}
{            CRC Calculator Unit for Delphi 16/32             }
{ Version:   2.0                                              }
{ Author:    Aleksey Kuznetsov                                }
{ E-Mail:    aleksey@utilmind.com                             }
{ Home Page: http://www.utilmind.com                          }
{ Created:   March, 30, 1999 for Karol Suchanek               }
{ Modified:  April, 6, 1999                                   }
{ Legal:     Copyright (c) 1999, UtilMind Solutions           }
{            Idea: Edwin T. Floyd                             }
{*************************************************************}
{ This unit provides three speed-optimized functions to       }
{ compute (or continue computation of) a Cyclic Redundency    }
{ Check (CRC). Applicable to XModem protocol (16-bit CRC),    }
{ SEA"s "ARC" utility, PKZip (32-bit CRC) and many others     }
{ compatible software.                                        }
{ Please see TESTCRC.DPR for example.                         }
{*************************************************************}
{ Each function takes three parameters:                       }
{                                                             }
{ InitCRC - The initial CRC value.  This may be the           }
{ recommended initialization value if this is the first or    }
{ only block to be checked, or this may be a previously       }
{ computed CRC value if this is a continuation.               }
{   XModem and ARC usually starts with zero (0), 32 bit crc   }
{   starts with all bits on ($FFFFFFFF).                      }
{                                                             }
{ Buffer - An untyped parameter (Pointer^) specifying the     }
{ beginning of the memory area to be checked.                 }
{                                                             }
{ Length - A word indicating the length of the memory area to }
{ be checked. If Length is zero, the function returns the     }
{ value of InitCRC.                                           }
{                                                             }
{ The function result is the updated CRC.                     }
{*************************************************************}

unit CRC;

interface

function UpdateCRC16(InitCRC: Word; var Buffer;
                    Length: {$IFDEF Win32} LongInt {$ELSE} Word {$ENDIF}): Word;
{ I believe this is the CRC used by the XModem protocol.
 The transmitting end should initialize with zero, UpdateCRC16 for
 the block, Continue the UpdateCRC16 for two nulls, and append the
 result (hi order byte first) to the transmitted block. The receiver
 should initialize with zero and UpdateCRC16 for the received block
 including the two byte CRC. The result will be zero (why?) if there
 were no transmission errors. (I have not tested this function with
 an actual XModem implementation, though I did verify the behavior
 just described. See TESTCRC.DPR.) }

function UpdateCRCArc(InitCRC: Word; var Buffer;
                     Length: {$IFDEF Win32} LongInt {$ELSE} Word {$ENDIF}): Word;
{ This function computes the CRC used by SEA"s ARC utility.
 Initialize with zero.}

function UpdateCRC32(InitCRC: LongInt; var Buffer;
                    {$IFDEF Win32} Length: LongInt {$ELSE} Length: Word {$ENDIF}): LongInt;
{ This function computes the CRC used by PKZIP and Forsberg"s ZModem.
 Initialize with high-values ($FFFFFFFF), and finish by inverting
 allbits (Not). }

function FileCRC16(FileName: String; var CRC16: Word): Boolean; { Return True if ok }
function FileCRCArc(FileName: String; var CRCArc: Word): Boolean; { Return True if ok }
function FileCRC32(FileName: String; var CRC32: LongInt): Boolean; { Return True if ok }

implementation

const
CrcArcTab: Array[0..$FF] of Word =
   ($00000, $0C0C1, $0C181, $00140, $0C301, $003C0, $00280, $0C241,
    $0C601, $006C0, $00780, $0C741, $00500, $0C5C1, $0C481, $00440,
    $0CC01, $00CC0, $00D80, $0CD41, $00F00, $0CFC1, $0CE81, $00E40,
    $00A00, $0CAC1, $0CB81, $00B40, $0C901, $009C0, $00880, $0C841,
    $0D801, $018C0, $01980, $0D941, $01B00, $0DBC1, $0DA81, $01A40,
    $01E00, $0DEC1, $0DF81, $01F40, $0DD01, $01DC0, $01C80, $0DC41,
    $01400, $0D4C1, $0D581, $01540, $0D701, $017C0, $01680, $0D641,
    $0D201, $012C0, $01380, $0D341, $01100, $0D1C1, $0D081, $01040,
    $0F001, $030C0, $03180, $0F141, $03300, $0F3C1, $0F281, $03240,
    $03600, $0F6C1, $0F781, $03740, $0F501, $035C0, $03480, $0F441,
    $03C00, $0FCC1, $0FD81, $03D40, $0FF01, $03FC0, $03E80, $0FE41,
    $0FA01, $03AC0, $03B80, $0FB41, $03900, $0F9C1, $0F881, $03840,
    $02800, $0E8C1, $0E981, $02940, $0EB01, $02BC0, $02A80, $0EA41,
    $0EE01, $02EC0, $02F80, $0EF41, $02D00, $0EDC1, $0EC81, $02C40,
    $0E401, $024C0, $02580, $0E541, $02700, $0E7C1, $0E681, $02640,
    $02200, $0E2C1, $0E381, $02340, $0E101, $021C0, $02080, $0E041,
    $0A001, $060C0, $06180, $0A141, $06300, $0A3C1, $0A281, $06240,
    $06600, $0A6C1, $0A781, $06740, $0A501, $065C0, $06480, $0A441,
    $06C00, $0ACC1, $0AD81, $06D40, $0AF01, $06FC0, $06E80, $0AE41,
    $0AA01, $06AC0, $06B80, $0AB41, $06900, $0A9C1, $0A881, $06840,
    $07800, $0B8C1, $0B981, $07940, $0BB01, $07BC0, $07A80, $0BA41,
    $0BE01, $07EC0, $07F80, $0BF41, $07D00, $0BDC1, $0BC81, $07C40,
    $0B401, $074C0, $07580, $0B541, $07700, $0B7C1, $0B681, $07640,
    $07200, $0B2C1, $0B381, $07340, $0B101, $071C0, $07080, $0B041,
    $05000, $090C1, $09181, $05140, $09301, $053C0, $05280, $09241,
    $09601, $056C0, $05780, $09741, $05500, $095C1, $09481, $05440,
    $09C01, $05CC0, $05D80, $09D41, $05F00, $09FC1, $09E81, $05E40,
    $05A00, $09AC1, $09B81, $05B40, $09901, $059C0, $05880, $09841,
    $08801, $048C0, $04980, $08941, $04B00, $08BC1, $08A81, $04A40,
    $04E00, $08EC1, $08F81, $04F40, $08D01, $04DC0, $04C80, $08C41,
    $04400, $084C1, $08581, $04540, $08701, $047C0, $04680, $08641,
    $08201, $042C0, $04380, $08341, $04100, $081C1, $08081, $04040);


 
OSokin ©   (2004-08-14 20:31) [7]

Crc16Tab: Array[0..$FF] of Word =
   ($00000, $01021, $02042, $03063, $04084, $050a5, $060c6, $070e7,
    $08108, $09129, $0a14a, $0b16b, $0c18c, $0d1ad, $0e1ce, $0f1ef,
    $01231, $00210, $03273, $02252, $052b5, $04294, $072f7, $062d6,
    $09339, $08318, $0b37b, $0a35a, $0d3bd, $0c39c, $0f3ff, $0e3de,
    $02462, $03443, $00420, $01401, $064e6, $074c7, $044a4, $05485,
    $0a56a, $0b54b, $08528, $09509, $0e5ee, $0f5cf, $0c5ac, $0d58d,
    $03653, $02672, $01611, $00630, $076d7, $066f6, $05695, $046b4,
    $0b75b, $0a77a, $09719, $08738, $0f7df, $0e7fe, $0d79d, $0c7bc,
    $048c4, $058e5, $06886, $078a7, $00840, $01861, $02802, $03823,
    $0c9cc, $0d9ed, $0e98e, $0f9af, $08948, $09969, $0a90a, $0b92b,
    $05af5, $04ad4, $07ab7, $06a96, $01a71, $00a50, $03a33, $02a12,
    $0dbfd, $0cbdc, $0fbbf, $0eb9e, $09b79, $08b58, $0bb3b, $0ab1a,
    $06ca6, $07c87, $04ce4, $05cc5, $02c22, $03c03, $00c60, $01c41,
    $0edae, $0fd8f, $0cdec, $0ddcd, $0ad2a, $0bd0b, $08d68, $09d49,
    $07e97, $06eb6, $05ed5, $04ef4, $03e13, $02e32, $01e51, $00e70,
    $0ff9f, $0efbe, $0dfdd, $0cffc, $0bf1b, $0af3a, $09f59, $08f78,
    $09188, $081a9, $0b1ca, $0a1eb, $0d10c, $0c12d, $0f14e, $0e16f,
    $01080, $000a1, $030c2, $020e3, $05004, $04025, $07046, $06067,
    $083b9, $09398, $0a3fb, $0b3da, $0c33d, $0d31c, $0e37f, $0f35e,
    $002b1, $01290, $022f3, $032d2, $04235, $05214, $06277, $07256,
    $0b5ea, $0a5cb, $095a8, $08589, $0f56e, $0e54f, $0d52c, $0c50d,
    $034e2, $024c3, $014a0, $00481, $07466, $06447, $05424, $04405,
    $0a7db, $0b7fa, $08799, $097b8, $0e75f, $0f77e, $0c71d, $0d73c,
    $026d3, $036f2, $00691, $016b0, $06657, $07676, $04615, $05634,
    $0d94c, $0c96d, $0f90e, $0e92f, $099c8, $089e9, $0b98a, $0a9ab,
    $05844, $04865, $07806, $06827, $018c0, $008e1, $03882, $028a3,
    $0cb7d, $0db5c, $0eb3f, $0fb1e, $08bf9, $09bd8, $0abbb, $0bb9a,
    $04a75, $05a54, $06a37, $07a16, $00af1, $01ad0, $02ab3, $03a92,
    $0fd2e, $0ed0f, $0dd6c, $0cd4d, $0bdaa, $0ad8b, $09de8, $08dc9,
    $07c26, $06c07, $05c64, $04c45, $03ca2, $02c83, $01ce0, $00cc1,
    $0ef1f, $0ff3e, $0cf5d, $0df7c, $0af9b, $0bfba, $08fd9, $09ff8,
    $06e17, $07e36, $04e55, $05e74, $02e93, $03eb2, $00ed1, $01ef0);

Crc32Tab: Array[0..$FF] of LongInt =
  ($00000000, $77073096, $ee0e612c, $990951ba, $076dc419, $706af48f,
   $e963a535, $9e6495a3, $0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988,
   $09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91, $1db71064, $6ab020f2,
   $f3b97148, $84be41de, $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7,
   $136c9856, $646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9,
   $fa0f3d63, $8d080df5, $3b6e20c8, $4c69105e, $d56041e4, $a2677172,
   $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b, $35b5a8fa, $42b2986c,
   $dbbbc9d6, $acbcf940, $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59,
   $26d930ac, $51de003a, $c8d75180, $bfd06116, $21b4f4b5, $56b3c423,
   $cfba9599, $b8bda50f, $2802b89e, $5f058808, $c60cd9b2, $b10be924,
   $2f6f7c87, $58684c11, $c1611dab, $b6662d3d, $76dc4190, $01db7106,
   $98d220bc, $efd5102a, $71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433,
   $7807c9a2, $0f00f934, $9609a88e, $e10e9818, $7f6a0dbb, $086d3d2d,
   $91646c97, $e6635c01, $6b6b51f4, $1c6c6162, $856530d8, $f262004e,
   $6c0695ed, $1b01a57b, $8208f4c1, $f50fc457, $65b0d9c6, $12b7e950,
   $8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65,
   $4db26158, $3ab551ce, $a3bc0074, $d4bb30e2, $4adfa541, $3dd895d7,
   $a4d1c46d, $d3d6f4fb, $4369e96a, $346ed9fc, $ad678846, $da60b8d0,
   $44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9, $5005713c, $270241aa,
   $be0b1010, $c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f,
   $5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, $2eb40d81,
   $b7bd5c3b, $c0ba6cad, $edb88320, $9abfb3b6, $03b6e20c, $74b1d29a,
   $ead54739, $9dd277af, $04db2615, $73dc1683, $e3630b12, $94643b84,
   $0d6d6a3e, $7a6a5aa8, $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1,
   $f00f9344, $8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb,
   $196c3671, $6e6b06e7, $fed41b76, $89d32be0, $10da7a5a, $67dd4acc,
   $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5, $d6d6a3e8, $a1d1937e,
   $38d8c2c4, $4fdff252, $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b,
   $d80d2bda, $af0a1b4c, $36034af6, $41047a60, $df60efc3, $a867df55,
   $316e8eef, $4669be79, $cb61b38c, $bc66831a, $256fd2a0, $5268e236,
   $cc0c7795, $bb0b4703, $220216b9, $5505262f, $c5ba3bbe, $b2bd0b28,
   $2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d,
   $9b64c2b0, $ec63f226, $756aa39c, $026d930a, $9c0906a9, $eb0e363f,
   $72076785, $05005713, $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38,
   $92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21, $86d3d2d4, $f1d4e242,
   $68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, $18b74777,
   $88085ae6, $ff0f6a70, $66063bca, $11010b5c, $8f659eff, $f862ae69,
   $616bffd3, $166ccf45, $a00ae278, $d70dd2ee, $4e048354, $3903b3c2,
   $a7672661, $d06016f7, $4969474d, $3e6e77db, $aed16a4a, $d9d65adc,
   $40df0b66, $37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9,
   $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605, $cdd70693,
   $54de5729, $23d967bf, $b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94,
   $b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d);


 
OSokin ©   (2004-08-14 20:32) [8]

function UpdateCRC16(InitCRC: Word; var Buffer;
                    Length: {$IFDEF Win32} LongInt {$ELSE} Word {$ENDIF}): Word;
begin
 asm
 {$IFDEF Win32}
        push   esi
        push   edi
        push   eax
        push   ebx
        push   ecx
        push   edx
        lea    edi, Crc16Tab
        mov    esi, Buffer
        mov    ax, InitCrc
        mov    ecx, Length
        or     ecx, ecx
        jz     @@done
@@loop:
        xor    ebx, ebx
        mov    bl, ah
        mov    ah, al
        lodsb
        shl    bx, 1
        add    ebx, edi
        xor    ax, [ebx]
        loop   @@loop
@@done:
        mov    Result, ax
        pop    edx
        pop    ecx
        pop    ebx
        pop    eax
        pop    edi
        pop    esi
 {$ELSE}
        lea    di, Crc16Tab
        push   ds
        pop    es
        push   ds
        lds    si, Buffer
        mov    ax, InitCrc
        mov    cx, Length
        or     cx, cx
        jz     @@done
@@loop:
        xor    bx, bx
        mov    bl, ah
        mov    ah, al
        lodsb
        shl    bx, 1
        xor    ax, es:[di + bx]
        loop   @@loop
        pop    ds
@@done:
        mov    Result, ax
  {$ENDIF}
  end;
end;

function UpdateCRCArc(InitCRC: Word; var Buffer;
                     Length: {$IFDEF Win32} LongInt {$ELSE} Word {$ENDIF}): Word;
begin
 asm
 {$IFDEF Win32}
        push   esi
        push   edi
        push   eax
        push   ebx
        push   ecx
        push   edx
        lea    edi, CrcArcTab
        mov    esi, Buffer
        mov    ax, InitCrc
        mov    ecx, Length
        or     ecx, ecx
        jz     @@done
@@loop:
        xor    ebx, ebx
        mov    bl, al
        lodsb
        xor    bl, al
        shl    bx, 1
        add    ebx, edi
        mov    bx, [ebx]
        xor    bl, ah
        mov    ax, bx
        loop   @@loop
@@done:
        mov    Result, ax
        pop    edx
        pop    ecx
        pop    ebx
        pop    eax
        pop    edi
        pop    esi
 {$ELSE}
        lea    di, CrcArcTab
        push   ds
        pop    es
        push   ds
        lds    si, Buffer
        mov    ax, InitCrc
        mov    cx, Length
        or     cx, cx
        jz     @@done
@@loop:
        xor    bx, bx
        mov    bl, al
        lodsb
        xor    bl, al
        shl    bx, 1
        mov    bx, es:[di + bx]
        xor    bl, ah
        mov    ax, bx
        loop   @@loop
        pop    ds
@@done:
        mov    Result, ax
  {$ENDIF}
  end;
end;


 
OSokin ©   (2004-08-14 20:33) [9]

function UpdateCRC32(InitCRC: LongInt; var Buffer;
                    {$IFDEF Win32} Length: LongInt {$ELSE} Length: Word {$ENDIF}): LongInt;
begin
 asm
{$IFDEF Win32}
        push   esi
        push   edi
        push   eax
        push   ebx
        push   ecx
        push   edx
        lea    edi, Crc32Tab
        mov    esi, Buffer
        mov    ax, word ptr InitCRC
        mov    dx, word ptr InitCRC + 2
        mov    ecx, Length
        or     ecx, ecx
        jz     @@done
@@loop:
        xor    ebx, ebx
        mov    bl, al
        lodsb
        xor    bl, al
        mov    al, ah
        mov    ah, dl
        mov    dl, dh
        xor    dh, dh
        shl    bx, 1
        shl    bx, 1
        add    ebx, edi
        xor    ax, [ebx]
        xor    dx, [ebx + 2]
        loop   @@loop
@@done:
        mov    word ptr Result, ax
        mov    word ptr Result + 2, dx
        pop    edx
        pop    ecx
        pop    ebx
        pop    eax
        pop    edi
        pop    esi
{$ELSE}
        push   ds
        pop    es
        push   ds
        lea    di, CRC32Tab
        lds    si, Buffer
        mov    ax, word ptr InitCRC
        mov    dx, word ptr InitCRC + 2
        mov    cx, Length
        or     cx, cx
        jz     @@done
@@loop:
        xor    bh, bh
        mov    bl, al
        lodsb
        xor    bl, al
        mov    al, ah
        mov    ah, dl
        mov    dl, dh
        xor    dh, dh
        shl    bx, 1
        shl    bx, 1
        xor    ax, es:[di + bx]
        xor    dx, es:[di + bx + 2]
        loop   @@loop
@@done:
        pop    ds
        mov    word ptr Result, ax
        mov    word ptr Result + 2, dx
{$ENDIF}
 end;
end;

function FileCRC16(FileName: String; var CRC16: Word): Boolean; { Return True if ok }
var
 f: File;
 p: Pointer;
 FSize: LongInt;
 {$IFNDEF Win32}
 tmp: Word;
 {$ENDIF}
begin
 {$I+}
 try
  AssignFile(f, FileName);
  Reset(f, 1);
  FSize := FileSize(f);
  if FSize <> 0 then
   begin
    {$IFDEF Win32}
    GetMem(p, FSize);
    BlockRead(f, p^, FSize);
    CRC16 := UpdateCrc16(0, p^, FSize); {!}
    FreeMem(p, FSize);
    {$ELSE}
    CRC16 := 0;  { Usualy from zero }
    while FSize <> 0 do
     begin
      if FSize > $FFFF then tmp := $FFFF else tmp := FSize;
      dec(FSize, tmp);
      GetMem(p, tmp);
      BlockRead(f, p^, tmp);
      CRC16 := UpdateCrc16(Crc16, p^, tmp); {!}
      FreeMem(p, tmp);
     end;
    {$ENDIF}

    GetMem(p, 2);      { Finish XModem crc with two nulls }
    FillChar(p^, 2, 0);
    Crc16 := UpdateCrc16(Crc16, p^, 2);
    FreeMem(p, 2);

   end;
  Result := True;
 except
  Result := False;
 end;
 try
  CloseFile(f);
 except
 end;
 {$I-}
end;


 
OSokin ©   (2004-08-14 20:33) [10]

function FileCRCArc(FileName: String; var CRCArc: Word): Boolean; { Return True if ok }
var
 f: File;
 p: Pointer;
 FSize: LongInt;
 {$IFNDEF Win32}
 tmp: Word;
 {$ENDIF}
begin
 {$I+}
 try
  AssignFile(f, FileName);
  Reset(f, 1);
  FSize := FileSize(f);
  if FSize <> 0 then
   begin
    {$IFDEF Win32}
    GetMem(p, FSize);
    BlockRead(f, p^, FSize);
    CRCArc := UpdateCrcArc(0, p^, FSize); {!}
    FreeMem(p, FSize);
    {$ELSE}
    CRCArc := 0;  { Usualy from zero }
    while FSize <> 0 do
     begin
      if FSize > $FFFF then tmp := $FFFF else tmp := FSize;
      dec(FSize, tmp);
      GetMem(p, tmp);
      BlockRead(f, p^, tmp);
      CRCArc := UpdateCrcArc(CrcArc, p^, tmp); {!}
      FreeMem(p, tmp);
     end;
    {$ENDIF}
   end;
  Result := True;
 except
  Result := False;
 end;
 try
  CloseFile(f);
 except
 end;
 {$I-}
end;

function FileCRC32(FileName: String; var CRC32: LongInt): Boolean; { Return True if ok }
var
 f: File;
 p: Pointer;
 FSize: LongInt;
 {$IFNDEF Win32}
 tmp: Word;
 {$ENDIF}
begin
 {$I+}
 try
  AssignFile(f, FileName);
  Reset(f, 1);
  FSize := FileSize(f);
  if FSize <> 0 then
   begin
    {$IFDEF Win32}
    GetMem(p, FSize);
    BlockRead(f, p^, FSize);
    CRC32 := UpdateCrc32($FFFFFFFF, p^, FSize); {!}
    FreeMem(p, FSize);
    {$ELSE}
    CRC32 := $FFFFFFFF;  { Usualy }
    while FSize <> 0 do
     begin
      if FSize > $FFFF then tmp := $FFFF else tmp := FSize;
      dec(FSize, tmp);
      GetMem(p, tmp);
      BlockRead(f, p^, tmp);
      CRC32 := UpdateCrc32(Crc32, p^, tmp); {!}
      FreeMem(p, tmp);
     end;
    {$ENDIF}
    CRC32 := not CRC32; { Finish 32 bit crc by inverting all bits }
   end;
  Result := True;
 except
  Result := False;
 end;
 try
  CloseFile(f);
 except
 end;
 {$I-}
end;

end.


 
OSokin ©   (2004-08-14 20:36) [11]

Тут все до кучи для работы с CRC. Устанавливаешь как обычный компонент.


 
Андрей007   (2004-08-14 21:27) [12]

Спасибо.



Страницы: 1 вся ветка

Форум: "Основная";
Текущий архив: 2004.08.29;
Скачать: [xml.tar.bz2];

Наверх




Память: 0.55 MB
Время: 0.034 c
1-1092389307
Strimer
2004-08-13 13:28
2004.08.29
Пустая дата в DateTimePicker


4-1090235980
Deep8
2004-07-19 15:19
2004.08.29
RESET


3-1091784291
Самовар
2004-08-06 13:24
2004.08.29
Сортировка


14-1092191995
guest
2004-08-11 06:39
2004.08.29
Скажите мне как полиглот полиглоту


4-1089861031
Anton
2004-07-15 07:10
2004.08.29
Две независимые группы радиокнопок





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский