Overwriting A File: A Threaded Component

unit sdobj;

// file overwrite or secure deletion component written by Glenn9999 at 
// tek-tips.com
interface
   uses sysutils, windows, classes, forms, messages;

const
  SIZELIMIT = 65536;           // limit in bytes allocated for the buffer
  WM_SDPROGRESS = WM_APP + $20;
  WM_SDFINISHED = WM_APP + $21;

type
  int64 = comp;
  QWord = packed record
    low: DWord;
    high: DWord;
  end;
  array3 = array[1..3] of byte;
  // base object implementation of secure delete.  Toolset for deleting a file.
  TSDBaseObject = class(TThread)
  private
    FilePath: String;          // file path of the file to erase
    WHandle: THandle;          // window handle to send progress messages to.
    FileHandle: THandle;       // file handle for the file to erase
    bufferptr: Pointer;        // allocated buffer pointer
    SizeOfFile: Int64;         // the size of the file.
    SFClusters: Longint;       // the number of clusters in the file.
    SFClusterBuffer: Longint;  // number of clusters that fit in SIZELIMIT bytes
    SFBufferSize: Longint;     // the buffer size allocated in bufferptr
    ByteClusterSize: Longint;  // size in bytes of one cluster of the drive.
    AmountWritten: Int64;      // amount written in percent
    PassCount: Longint;        // total amount of passes completed
    TotalPasses: Longint;      // total number of passes to run.

    procedure OpenEraseFile;
    procedure CloseEraseFile;
    procedure FillCharByte(thebyte: byte);
    procedure FillCharPattern(Count: Integer; Pattern: array3);
    procedure FillRandomBuffer(bufsize: Longint);
    procedure WriteSinglePass;
    procedure WriteRandomPass;
    procedure SDProgressMsg;
  protected
    procedure Execute; override;
    function EraseFile: boolean; virtual; abstract;
  end;
  // zero erase object.
  TSDZeroErase = class(TSDBaseObject)
  public
    function EraseFile: Boolean; override;
  end;
  // DOD erase object
  TSDDodErase = class(TSDBaseObject)
  public
    function EraseFile: Boolean; override;
  end;
  // Gutmann erase object
  TSDGutmannErase = class(TSDBaseObject)
  public
    function EraseFile: Boolean; override;
  end;

  TSDMethod = (sdmZero, sdmDoD, sdmGutmann);
  TSDProgressEvent = procedure (Sender: TObject; PassCount: Byte;
                     PercentWritten: Byte) of object;
  // component for interaction with the VCL
  TSecureDelete = class(TComponent)
  private
    FHandle: THandle;
    FMethod: TSDMethod;

    FZeroErase: TSDZeroErase;
    FDoDErase: TSDDoDErase;
    FGutmannErase: TSDGutmannErase;

    FOnProgress: TSDProgressEvent;
    FOnCompleted: TNotifyEvent;
  public
    Constructor Create(AOwner: TComponent); override;
    Destructor Destroy; override;
    procedure EraseFile(filepath: string);
  protected
    procedure Window_Handler(var msg: TMessage); virtual;
  published
    property Method: TSDMethod read FMethod write FMethod;
    property OnProgress: TSDProgressEvent read FOnProgress write FOnProgress;
    property OnCompleted: TNotifyEvent read FOnCompleted write FOnCompleted;
  end;

  procedure register;

implementation

procedure TSecureDelete.EraseFile(filepath: string);
  begin
    case FMethod of
      sdmZero:
        begin
          FZeroErase := TSDZeroErase.Create(true);
          FZeroErase.FilePath := FilePath;
          FZeroErase.WHandle := FHandle;
          FZeroErase.Resume;
        end;
      sdmDoD:
        begin
          FDoDErase := TSDDoDErase.Create(true);
          FDoDErase.FilePath := FilePath;
          FDoDErase.WHandle := FHandle;
          FDoDErase.Resume;
        end;
      sdmGutmann:
        begin
          FGutmannErase := TSDGutmannErase.Create(true);
          FGutmannErase.FilePath := FilePath;
          FGutmannErase.WHandle := FHandle;
          FGutmannErase.Resume;
        end;
     end;
  end;

Constructor TSecureDelete.Create(AOwner: TComponent);
  begin
    FHandle := AllocateHWnd(Window_Handler);
    inherited create(aowner);
  end;

Destructor TSecureDelete.Destroy;
  begin
    DeallocateHWnd(FHandle);
    Inherited;
  end;

procedure TSecureDelete.Window_Handler(var msg: TMessage);
  begin
    case Msg.Msg of
      WM_SDPROGRESS:
        begin
          if Assigned(FOnProgress) then
             FOnProgress(Self, msg.WParam, Msg.LParam);
        end;
      WM_SDFINISHED:
        begin
          if Assigned(FOnCompleted) then
            FOnCompleted(Self);
        end;
    else
      DefWindowProc(FHandle, Msg.Msg, Msg.wParam, Msg.lParam);
    end;
end;

procedure TSDBaseObject.Execute;
  begin
    EraseFile;
  end;

procedure TSDBaseObject.OpenEraseFile;
// opens file with the intention of passing it into the erase procedure.
// uses parameters which are compatible with this purpose.
// also provides information regarding the drive and file to be able to erase
// it properly.
  var
    BytesPerSector, SectorsPerCluster, FreeClusters, TotalClusters: Integer;
    QuadWord: QWord;
  begin
    FilePath := ExpandFileName(FilePath);
    // create file handle, write-only, no sharing, only existing file,
    // write straight to disk, no buffers, delete on close.
    FileHandle := CreateFile(PChar(FilePath), GENERIC_WRITE, 0, nil,
                  OPEN_EXISTING, FILE_FLAG_WRITE_THROUGH or
                  FILE_FLAG_NO_BUFFERING or FILE_FLAG_DELETE_ON_CLOSE, 0);
    if FileHandle = INVALID_HANDLE_VALUE then exit;

    GetDiskFreeSpace(PChar( Copy(filepath, 1, pos('\', filepath)) ),
        SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters);
    QuadWord.Low := GetFileSize(FileHandle, @QuadWord.High);
    SizeOfFile := Int64(QuadWord);
    ByteClusterSize := BytesPerSector*SectorsPerCluster;
    SFClusters := trunc(SizeOfFile / ByteClusterSize);
    if frac(SizeOfFile / ByteClusterSize) > 0 then inc(SFClusters);
    SFClusterBuffer := SIZELIMIT div ByteClusterSize;
    SFBufferSize := SFClusterBuffer * ByteClusterSize;
    // allocate memory for the buffer.
    GetMem(bufferptr, SFBufferSize);
    PassCount := 0;
  end;

procedure TSDBaseObject.CloseEraseFile;
  begin
    CloseHandle(FileHandle);
    FreeMem(BufferPtr);
    SendMessage(WHandle, WM_SDFINISHED, 0, 0);
  end;

procedure TSDBaseObject.FillCharByte(thebyte: byte);
  begin
    FillChar(bufferptr^, SFBufferSize, thebyte);
  end;

procedure TSDBaseObject.FillCharPattern(Count: Integer; Pattern: array3);
// fill bufferptr with the byte pattern listed.
  var
    i: integer;
    procptr: Pointer;
  begin
    procptr := bufferptr;
    while count > 3 do
      begin
        Move(Pattern, procptr^, 3);
        inc(Longint(procptr), 3);
        dec(count, 3);
      end;
    for i := 1 to count do
      begin
        Byte(procptr^) := Pattern[i];
        inc(Longint(procptr));
      end;
  end;

procedure TSDBaseObject.FillRandomBuffer(bufsize: Longint);
// fills up bufferptr for bufsize bytes with pseudorandomly generated characters.
  var
    procptr: Pointer;
    i: integer;
  begin
    Randomize;
    procptr := bufferptr;
    for i := 1 to bufsize do
      begin
        Byte(procptr^) := Random(255);
        inc(Longint(procptr));
      end;
  end;

procedure TSDBaseObject.SDProgressMsg;
  var
    TotalPercent: Extended;
    TotalPercentByte: Byte;
  begin
    TotalPercent := ((AmountWritten/SizeOfFile) * (1 / TotalPasses));
    TotalPercent := TotalPercent + (PassCount / TotalPasses);
    TotalPercentByte := trunc(TotalPercent * 100);
    SendMessage(WHandle, WM_SDPROGRESS, TotalPercentByte, trunc((AmountWritten/SizeOfFile)*100));
  end;

procedure TSDBaseObject.WriteSinglePass;
  var
    i: integer;
    BytesWritten: Longint;
  begin
    AmountWritten := 0;
    SetFilePointer(FileHandle, 0, nil, FILE_BEGIN);
    i := 0;
    while (SFClusters - i) > SFClusterBuffer do
      begin
        WriteFile(FileHandle, bufferptr^, SFBufferSize, BytesWritten, nil);
        AmountWritten := AmountWritten + BytesWritten;
        SDProgressMsg;
        inc(i, SFClusterBuffer);
      end;
    WriteFile(FileHandle, BufferPtr^, (SFClusters-i)*ByteClusterSize, BytesWritten, nil);
    AmountWritten := AmountWritten + BytesWritten;
    SDProgressMsg;
    Inc(PassCount, 1);
  end;

procedure TSDBaseObject.WriteRandomPass;
  var
    j: integer;
    BytesWritten: Longint;
  begin
    AmountWritten := 0;
    SetFilePointer(FileHandle, 0, nil, FILE_BEGIN);
    j := 0;
    while (SFClusters - j) > SFClusterBuffer do
      begin
        FillRandomBuffer(SFBufferSize);
        WriteFile(FileHandle, bufferptr^, SFBufferSize, BytesWritten, nil);
        AmountWritten := AmountWritten + BytesWritten;
        SDProgressMsg;
        inc(j, SFClusterBuffer);
      end;
    FillRandomBuffer((SFClusters-j)*ByteClusterSize);
    WriteFile(FileHandle, BufferPtr^, (SFClusters-j)*ByteClusterSize, BytesWritten, nil);
    AmountWritten := AmountWritten + BytesWritten;
    SDProgressMsg;
    Inc(PassCount, 1);
  end;

function TSDZeroErase.EraseFile: Boolean;
// zero file before deleting.  1-Pass
  begin
    TotalPasses := 1;
    Result := true;
    OpenEraseFile;
    if FileHandle = INVALID_HANDLE_VALUE then
      begin
        Result := false;
        exit;
      end;
    FillCharByte(0);
    WriteSinglePass;
    CloseEraseFile;
  end;

function TSDDodErase.EraseFile: Boolean;
// secure delete a file using standard described in DoD 5220.22-M
// this implementation alternates $FF and $00 for six passes and does
// a random pass for the final pass.  (seven passes total)
// Result = true if all successful, false if not.
  const
    NumPasses = 6;
    PassChart: array[1..NumPasses] of byte = ($00, $FF, $00, $FF, $00, $FF);
  var
    j: integer;
  begin
    TotalPasses := 7;
    Result := true;
    OpenEraseFile;
    if FileHandle = INVALID_HANDLE_VALUE then
      begin
        Result := false;
        exit;
      end;
    // do alternating passes
    for j := 1 to NumPasses do
      begin
        FillCharByte(PassChart[j]);
        WriteSinglePass;
      end;
    // do final random pass
    WriteRandomPass;
    CloseEraseFile;
  end;

function TSDGutmannErase.EraseFile: Boolean;
 {
   secure delete a file using "Secure Deletion of Data from Magnetic
   and Solid-State Memory" by Peter Gutmann July 22-25, 1996   Does 35 passes.
   Result = true if all successful, false if not.
 }
  const
    GutPattern: array[1..6] of array3 = (
       ($92, $49, $24), ($49, $24, $92), ($24, $92, $49),
       ($6D, $B6, $DB), ($B6, $DB, $6D), ($DB, $6D, $B6) );
    GutChar: Array[10..25] of byte = ($00, $11, $22, $33, $44, $55, $66, $77,
        $88, $99, $AA, $BB, $CC, $DD, $EE, $FF);
  var
    j: integer;
  begin
    TotalPasses := 35;
    Result := true;
    OpenEraseFile;
    if FileHandle = INVALID_HANDLE_VALUE then
      begin
        Result := false;
        exit;
      end;
    // Pass #1-#4 - random
    for j := 1 to 4 do
      WriteRandomPass;
    // Pass #5 - Byte $55
    FillCharByte($55);
    WriteSinglePass;
    // Pass #6 - Byte $AA
    FillCharByte($AA);
    WriteSinglePass;
    // Pass #7-#9 - First three entries in GutPattern
    for j := 1 to 3 do
      begin
        FillCharPattern(SFBufferSize, GutPattern[j]);
        WriteSinglePass;
      end;
    // Pass #10-25 - Character progression, GutChar
    for j := 10 to 25 do
      begin
        FillCharByte(GutChar[j]);
        WriteSinglePass;
      end;
    // Pass #26-31 - All six entries in GutPattern
    for j := 1 to 6 do
      begin
        FillCharPattern(SFBufferSize, GutPattern[j]);
        WriteSinglePass;
      end;
    // Pass #32-35 - Random
    for j := 1 to 4 do
      WriteRandomPass;
    CloseEraseFile;
  end;

procedure Register;
begin
  RegisterComponents('Samples', [TSecureDelete]);
end;

end.

unit sdformobj;
// example use of the component posted above.
// written by Glenn9999 @ tek-tips.com
interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Gauges, sdobj, StdCtrls;

type
  TForm1 = class(TForm)
    Gauge1: TGauge;
    Gauge2: TGauge;
    Button1: TButton;
    OpenDialog1: TOpenDialog;
    SecureDelete1: TSecureDelete;  // component added to form.
    ComboBox1: TComboBox;
    procedure Button1Click(Sender: TObject);
    procedure SecureDelete1Completed(Sender: TObject);
    procedure SecureDelete1Progress(Sender: TObject; PassCount,
              PercentWritten: Byte);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  i: integer;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
// initiates process.  Overwrites/deletes files returned by OpenDialog1.
begin
  if OpenDialog1.Execute then
    begin
      if Combobox1.ItemIndex = -1 then
        begin
          ShowMessage('Select a method.');
          ComboBox1.SetFocus;
          exit;
        end;
      SecureDelete1.Method := TSDMethod(Combobox1.ItemIndex); // Zero, DoD, or Gutmann
      i := 0;
      Form1.Caption := 'Erasing file ' + IntToStr(i+1) + ' of ' +
           IntToStr(OpenDialog1.Files.Count);
      SecureDelete1.EraseFile(OpenDialog1.Files.Strings[i]);
      Button1.Enabled := false;
    end;
end;

procedure TForm1.SecureDelete1Completed(Sender: TObject);
// OnCompleted.  Signals further action after completion of process.
begin
  inc(i);
  if (i < OpenDialog1.Files.Count) then
    begin
      Form1.Caption := 'Erasing file ' + IntToStr(i+1) + ' of ' +
           IntToStr(OpenDialog1.Files.Count);
      SecureDelete1.EraseFile(OpenDialog1.Files.Strings[i]);
    end
  else
    begin
      ShowMessage('Secure Delete Completed. ' + IntToStr(OpenDialog1.Files.Count)
      + ' files deleted.');
      Button1.Enabled := true;
    end;
end;

procedure TForm1.SecureDelete1Progress(Sender: TObject; PassCount,
  PercentWritten: Byte);
// on progress.  Do this to change the progress bars.
begin
  Gauge1.Progress := PassCount;
  Gauge2.Progress := PercentWritten;
end;