Answer:
Drop this on a form, then repeatedly call Update(nextbyte) until your input stream is complete, then access the CRC property for a CRC of the input bytes.
unit CCRC;
interface
uses
Classes, SysUtils, DsgnIntf;
type
TCRCScheme = (crcX25, crcXMODEM, crcARC, crcCRC32, crcPKZIP, crcCustom);
TLongHex = LongWord;
ECRCException = class(Exception);
ECRCBadScheme = class(ECRCException);
TLongHexEditor = class(TIntegerProperty)
procedure Edit; override;
function GetAttributes: TPropertyAttributes; override;
function GetValue: string; override;
procedure SetValue(const sValue: string); override;
end; //class TLongHexEditor
TCRC = class(TComponent)
private
//Private declarations
FScheme : TCRCScheme;
FWidth : Integer;
FReflectInput,
FReflectCRC : Boolean;
FCRC,
FInitialValue,
FPolynomial,
FXorToCRC : TLongHex;
protected
//Protected declarations
procedure SetScheme(crcNewScheme: TCRCScheme);
procedure SetCRCParameters(iNewWidth : Integer;
lNewPolynomial,
lNewInitialValue: TLongHex;
bNewReflectInput,
bNewReflectCRC : Boolean;
lNewXorToCRC : TLongHex);
procedure SetWidth(iNewWidth: Integer);
procedure SetPolynomial(lNewPolynomial: TLongHex);
procedure SetInitialValue(lNewInitialValue: TLongHex);
procedure SetReflectInput(bNewReflectInput: Boolean);
procedure SetReflectCRC(bNewReflectCRC: Boolean);
procedure SetXorToCRC(lNewXorToCRC: TLongHex);
function Reflect(lValue : TLongHex;
iBottomBitsToReflect: Integer): TLongHex;
function Bitmask(iBits: Integer): TLongHex;
function MaskOfWidth: TLongHex;
function GetCRC: TLongHex;
public
//Public declarations
constructor Create(AOwner: TComponent); override;
procedure Initialize;
procedure Update(byNewCharacter: Byte);
property CRC : TLongHex read GetCRC;
published
//Published declarations
property Scheme : TCRCScheme read FScheme write SetScheme default crcCRC32;
property Width : Integer read FWidth write SetWidth default 32;
property Polynomial : TLongHex read FPolynomial write SetPolynomial default $04C11DB7;
property InitialValue: TLongHex read FInitialValue write SetInitialValue default $FFFFFFFF;
property ReflectInput: Boolean read FReflectInput write SetReflectInput default True;
property ReflectCRC : Boolean read FReflectCRC write SetReflectCRC default True;
property XorToCRC : TLongHex read FXorToCRC write SetXorToCRC default $FFFFFFFF;
end; //class TCRC
procedure Register;
procedure CustomRegister(const sFolderName: string);
implementation
{$IFDEF VER100}
resourcestring
{$ELSE}
const
{$ENDIF}
rsCRCBadScheme = 'Invalid CRC scheme type specified.';
const
BITSINABYTE = 8;
var
sCustomFolderName: string = 'InterVocative Software';
//------------------------------------------------------------------------------
procedure TLongHexEditor.Edit;
var
ThisComponent: TPersistent;
begin //procedure TLongHexEditor.Edit
ThisComponent := GetComponent(Pred(PropCount));
if ThisComponent is TCRC then
begin //if..then
//do it here
end; //if..then
end; //procedure TLongHexEditor.Edit
//------------------------------------------------------------------------------
function TLongHexEditor.GetAttributes: TPropertyAttributes;
begin //function TLongHexEditor.GetAttributes
Result := inherited GetAttributes + [paRevertable];
end; //function TLongHexEditor.GetAttributes
//------------------------------------------------------------------------------
function TLongHexEditor.GetValue: string;
begin //function TLongHexEditor.GetValue
Result := inherited GetValue;
end; //function TLongHexEditor.GetValue
//------------------------------------------------------------------------------
procedure TLongHexEditor.SetValue(const sValue: string);
begin //procedure TLongHexEditor.SetValue
inherited SetValue(sValue);
end; //procedure TLongHexEditor.SetValue
//------------------------------------------------------------------------------
constructor TCRC.Create(AOwner: TComponent);
begin //constructor TCRC.Create
inherited Create(AOwner);
Scheme := crcCRC32;
Initialize;
end; //constructor TCRC.Create
//------------------------------------------------------------------------------
procedure TCRC.SetScheme(crcNewScheme: TCRCScheme);
begin //procedure TCRC.SetScheme
if crcNewScheme <> Scheme then
begin //if..then
case crcNewScheme of
crcX25 : SetCRCParameters(16, $1021, $FFFF, False, False, $0000);
crcXMODEM: SetCRCParameters(16, $8408, $0000, True, True, $0000);
crcARC : SetCRCParameters(16, $8005, $0000, True, True, $0000);
crcCRC32 : SetCRCParameters(32, $04C11DB7, $FFFFFFFF, True, True, $FFFFFFFF);
crcPKZIP : SetCRCParameters(32, $EDB88320, $FFFFFFFF, True, True, $FFFFFFFF);
crcCustom: ; //deliberate non-statement
else
raise ECRCBadScheme.Create(rsCRCBadScheme);
end; //case
FScheme := crcNewScheme;
end; //if..then
end; //procedure TCRC.SetScheme
//------------------------------------------------------------------------------
procedure TCRC.SetCRCParameters(iNewWidth : Integer;
lNewPolynomial,
lNewInitialValue: TLongHex;
bNewReflectInput,
bNewReflectCRC : Boolean;
lNewXorToCRC : TLongHex);
begin //procedure TCRC.SetCRCParameters
Width := iNewWidth;
Polynomial := lNewPolynomial;
InitialValue := lNewInitialValue;
ReflectInput := bNewReflectInput;
ReflectCRC := bNewReflectCRC;
XorToCRC := lNewXorToCRC;
end; //procedure TCRC.SetCRCParameters
//------------------------------------------------------------------------------
procedure TCRC.SetWidth(iNewWidth: Integer);
begin //procedure TCRC.SetWidth
if iNewWidth <> Width then
begin //if..then
FWidth := iNewWidth;
Scheme := crcCustom;
end; //if..then
end; //procedure TCRC.SetWidth
//------------------------------------------------------------------------------
procedure TCRC.SetPolynomial(lNewPolynomial: TLongHex);
begin //procedure TCRC.SetPolynomial
if lNewPolynomial <> Polynomial then
begin //if..then
FPolynomial := lNewPolynomial;
Scheme := crcCustom;
end; //if..then
end; //procedure TCRC.SetPolynomial
//------------------------------------------------------------------------------
procedure TCRC.SetInitialValue(lNewInitialValue: TLongHex);
begin //procedure TCRC.SetInitialValue
if lNewInitialValue <> InitialValue then
begin //if..then
FInitialValue := lNewInitialValue;
Scheme := crcCustom;
end; //if..then
end; //procedure TCRC.SetInitialValue
//------------------------------------------------------------------------------
procedure TCRC.SetReflectInput(bNewReflectInput: Boolean);
begin //procedure TCRC.SetReflectInput}
if bNewReflectInput <> ReflectInput then
begin //if..then
FReflectInput := bNewReflectInput;
Scheme := crcCustom;
end; //if..then
end; //procedure TCRC.SetReflectInput
//------------------------------------------------------------------------------
procedure TCRC.SetReflectCRC(bNewReflectCRC: Boolean);
begin //procedure TCRC.SetReflectCRC
if bNewReflectCRC <> ReflectCRC then
begin //if..then
FReflectCRC := bNewReflectCRC;
Scheme := crcCustom;
end; //if..then
end; //procedure TCRC.SetReflectCRC
//------------------------------------------------------------------------------
procedure TCRC.SetXorToCRC(lNewXorToCRC: TLongHex);
begin //procedure TCRC.SetXorToCRC
if lNewXorToCRC <> XorToCRC then
begin //if..then
FXorToCRC := lNewXorToCRC;
Scheme := crcCustom;
end; //if..then
end; //procedure TCRC.SetXorToCRC
//------------------------------------------------------------------------------
function TCRC.Reflect(lValue : TLongHex;
iBottomBitsToReflect: Integer): TLongHex;
var
iLoop : Integer;
lTempValue,
lOrValue: TLongHex;
begin //function TCRC.Reflect
lTempValue := lValue;
for iLoop := 0 to Pred(iBottomBitsToReflect) do
begin //for
lOrValue := Bitmask(Pred(iBottomBitsToReflect) - iLoop);
if lTempValue and 1 <> 0 then
lValue := lValue or lOrValue
else
lValue := lValue and not lOrValue;
lTempValue := lTempValue shr 1;
end; //for
Result := lValue;
end; //function TCRC.Reflect
//------------------------------------------------------------------------------
function TCRC.Bitmask(iBits: Integer): TLongHex;
begin //function TCRC.Bitmask
Result := 1 shl iBits;
end; //function TCRC.Bitmask
//------------------------------------------------------------------------------
function TCRC.MaskOfWidth: TLongHex;
var
lhResult: TLongHex;
begin //function TCRC.MaskOfWidth
lhResult := 1 shl Pred(Width);
Result := (Pred(lhResult) shl 1) or 1;
end; //function TCRC.MaskOfWidth
//------------------------------------------------------------------------------
function TCRC.GetCRC: TLongHex;
begin //function TCRC.GetCRC
if ReflectCRC then
Result := XorToCRC xor Reflect(FCRC, Width)
else
Result := XorToCRC xor FCRC;
end; //function TCRC.GetCRC
//------------------------------------------------------------------------------
procedure TCRC.Initialize;
begin //procedure TCRC.Initialize
FCRC := InitialValue;
end; //procedure TCRC.Initialize
//------------------------------------------------------------------------------
procedure TCRC.Update(byNewCharacter: Byte);
var
iLoop : Integer;
lNewLong,
lTopBit : TLongHex;
begin //procedure TCRC.Update
lNewLong := byNewCharacter;
lTopBit := Bitmask(Pred(Width));
if ReflectInput then
lNewLong := Reflect(lNewLong, BITSINABYTE);
FCRC := FCRC xor (lNewLong shl (Width - BITSINABYTE));
for iLoop := 1 to BITSINABYTE do
begin //for
if FCRC and lTopBit <> 0 then
FCRC := (FCRC shl 1) xor Polynomial
else
FCRC := FCRC shl 1;
FCRC := FCRC and MaskOfWidth;
end; //for
end; //procedure TCRC.Update
//------------------------------------------------------------------------------
procedure Register;
begin //procedure Register
RegisterPropertyEditor(TypeInfo(TLongHex), nil, '', TLongHexEditor);
RegisterComponents(sCustomFolderName, [TCRC]);
end; //procedure Register
//------------------------------------------------------------------------------
procedure CustomRegister(const sFolderName: string);
begin //procedure CustomRegister
if Trim(sFolderName) > '' then
sCustomFolderName := sFolderName;
Register;
end; //procedure CustomRegister
//------------------------------------------------------------------------------
end. //unit CCRC
|
Sign Up
