source: trunk/UDriveScan.pas

unit UDriveScan;

{$mode delphi}

interface

uses
  Classes, SysUtils, Syncobjs, UBlockMap, Forms, DOM, UConfig, UPhysDrive,
  UXMLUtils, Contnrs, ExtCtrls, DateUtils;

type
  TDriveScan = class;

  TRunMode = (rmRead, rmWrite, rmNone, rmSpeed);
  TExceptionEvent = procedure (Sender: TObject; E: Exception) of object;

  { TScanThread }

  TScanThread = class(TThread)
  private
    FOnException: TExceptionEvent;
  public
    Scan: TDriveScan;
    ExceptionText: string;
    procedure Execute; override;
    property OnException: TExceptionEvent read FOnException write FOnException;
  end;

  { TDriveScanProfile }

  TDriveScanProfile = class
    SectorCount: Integer;
    SectorStart: Integer;
    SectorEnd: Integer;
    Mode: TRunMode;
    WritePattern: Byte;
    WritePatternRandom: Boolean;
    procedure LoadFromDriveInfo(DriveInfo: TDriveInfo);
  end;

  { TTestStream }

  TTestStream = class(TStream)
  public
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
  end;

  { TSpeedValue }

  TSpeedValue = record
  public
    Null: Boolean;
    Max: Int64;
    Average: Int64;
    Values: array of Int64;
    Min: Int64;
    procedure Reset;
    procedure UpdateValue(Value: Int64);
  end;

  { TDriveScan }

  TDriveScan = class
  private
    FDriveName: string;
    FOnChange: TNotifyEvent;
    FOnTerminate: TNotifyEvent;
    FSectorCurrent: Integer;
    ScanThread: TScanThread;
    LastExceptionMessage: string;
    SpeedTimer: TTimer;
    SpeedTimeLast: TDateTime;
    SectorLast: Integer;
    procedure DoOnExceptionSync;
    procedure DoOnException(Sender: TObject; E: Exception);
    procedure DoChange;
    procedure DoTerminate;
    function GetSectorCount: Integer;
    procedure Run;
    procedure SetDriveName(AValue: string);
    procedure SetSectorCount(AValue: Integer);
    procedure SpeedTimerExecute(Sender: TObject);
  public
    Lock: TCriticalSection;
    BlockMap: TBlockMap;
    TimeStart: TDateTime;
    TimeEnd: TDateTime;
    Terminated: Boolean;
    DamagedBlockCount: Integer;
    Mode: TRunMode;
    WritePattern: Byte;
    WritePatternRandom: Boolean;
    SectorSize: Integer;
    SectorStart: Integer;
    SectorEnd: Integer;
    SpeedSteps: array of TSpeedValue;
    SpeedStepsCount: Integer;
    function GetName: string;
    function GetElapsedTime: TDateTime;
    procedure Reset;
    procedure Start;
    procedure Stop;
    procedure LoadProfile(Profile: TDriveScanProfile);
    constructor Create;
    destructor Destroy; override;
    procedure SaveToNode(Node: TDOMNode);
    procedure LoadFromNode(Node: TDOMNode);
    property SectorCurrent: Integer read FSectorCurrent;
    property DriveName: string read FDriveName write SetDriveName;
    property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property SectorCount: Integer read GetSectorCount write SetSectorCount;
  end;

  { TDriveScanList }

  TDriveScanList = class(TObjectList)
    procedure SaveToNode(Node: TDOMNode);
    procedure LoadFromNode(Node: TDOMNode);
  end;


implementation

resourcestring
  SUnknownRunMode = 'Unknown run mode';

{ TSpeedValue }

procedure TSpeedValue.Reset;
begin
  Null := True;
end;

procedure TSpeedValue.UpdateValue(Value: Int64);
var
  Sum: Double;
  I: Integer;
begin
  if Null then begin
    Min := High(Int64);
    Max := Low(Int64);
    SetLength(Values, 0);
  end;
  Null := False;
  if Value > Max then Max := Value;
  // TODO: Computer average
  SetLength(Values, Length(Values) + 1);
  Values[Length(Values) - 1] := Value;
  Sum := 0;
  for I := 0 to Length(Values) - 1 do
    Sum := Sum + Values[I];
  Average := Trunc(Sum / Length(Values));
  if Value < Min then Min := Value;
end;

{ TDriveScanProfile }

procedure TDriveScanProfile.LoadFromDriveInfo(DriveInfo: TDriveInfo);
begin
  SectorCount := DriveInfo.SectorCount;
  SectorStart := 0;
  SectorEnd := DriveInfo.SectorCount - 1;
end;

{ TTestStream }

function TTestStream.Read(var Buffer; Count: Longint): Longint;
begin
//  if Random < 0.00001 then Result := 0
//   else
     Result := Count;
end;

function TTestStream.Write(const Buffer; Count: Longint): Longint;
begin
  Result := 0;
end;

function TTestStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
  Result := 0;
end;

{ TDriveScanList }

procedure TDriveScanList.SaveToNode(Node: TDOMNode);
var
  I: Integer;
  NewNode2: TDOMNode;
begin
  for I := 0 to Count - 1 do
  with TDriveScan(Items[I]) do begin
    NewNode2 := Node.OwnerDocument.CreateElement('Scan');
    Node.AppendChild(NewNode2);
    SaveToNode(NewNode2);
  end;
end;

procedure TDriveScanList.LoadFromNode(Node: TDOMNode);
var
  Node2: TDOMNode;
  NewScan: TDriveScan;
begin
  Count := 0;
  Node2 := Node.FirstChild;
  while Assigned(Node2) and (Node2.NodeName = 'Scan') do begin
    NewScan := TDriveScan.Create;
    NewScan.LoadFromNode(Node2);
    Add(NewScan);
    Node2 := Node2.NextSibling;
  end;
end;


{ TScanThread }

procedure TScanThread.Execute;
begin
  ExceptionText := '';
  try
    Scan.Run;
  except
    on E: Exception do
      if Assigned(FOnException) then FOnException(Self, E);
  end;
end;

{ TDriveScan }

procedure TDriveScan.DoOnExceptionSync;
begin
  raise Exception.Create(LastExceptionMessage);
end;

procedure TDriveScan.DoOnException(Sender: TObject; E: Exception);
begin
  LastExceptionMessage := E.Message;
  TThread(Sender).Synchronize(TThread(Sender), DoOnExceptionSync);
end;

procedure TDriveScan.DoChange;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TDriveScan.DoTerminate;
begin

  if Assigned(FOnTerminate) then FOnTerminate(Self);
end;

function TDriveScan.GetSectorCount: Integer;
begin
  Result := BlockMap.SectorCount;
end;

function TDriveScan.GetElapsedTime: TDateTime;
begin
  if TimeEnd <> 0 then Result := TimeEnd - TimeStart
    else Result := Now - TimeStart;
end;

procedure TDriveScan.Reset;
var
  I: Integer;
begin
  TimeStart := Now;
  DamagedBlockCount := 0;
  BlockMap.Clear;
  FSectorCurrent := SectorStart;
  SetLength(SpeedSteps, SpeedStepsCount);
  for I := 0 to Length(SpeedSteps) - 1 do
    SpeedSteps[I].Reset;
end;

procedure TDriveScan.Start;
begin
  if Terminated then begin
    Terminated := False;
    ScanThread := TScanThread.Create(True);
    ScanThread.OnException := DoOnException;
    ScanThread.Scan := Self;
    ScanThread.Start;
    SpeedTimeLast := Now;
    SectorLast := SectorCurrent;
    SpeedTimer.Enabled := True;
  end;
end;

procedure TDriveScan.Run;
var
  F: TStream;
  RealSize: Integer;
  Buffer: Pointer;
  BufferAligned: Pointer;
  I: Integer;
  Alignment: Integer;
begin
  try
    Lock.Acquire;
    Terminated := False;
    if ConfigTest then F := TTestStream.Create
    else begin
      //if Mode = rmRead then F := TFileStreamEx.Create(DriveName, fmOpenRead, [ffDirect])
      //  else if Mode = rmWrite then F := TFileStreamEx.Create(DriveName, fmOpenReadWrite, [ffDirect]);
      if Mode = rmRead then F := TFileStream.Create(DriveName, fmOpenRead)
        else if Mode = rmWrite then F := TFileStream.Create(DriveName, fmOpenReadWrite);
    end;
    try
      Alignment := SectorSize;
      Buffer := GetMem(SectorSize + Alignment);
      BufferAligned := Pointer(Int64(Buffer) - (Int64(Buffer) and (Alignment - 1)) + Alignment);
      if Mode = rmWrite then begin
        if not WritePatternRandom then
          FillChar(BufferAligned^, SectorSize, WritePattern)
          else for I := 0 to SectorSize - 1 do
            PByte(Int64(BufferAligned) + I)^ := Random(256);
      end;
      while FSectorCurrent < SectorEnd do begin
        try
          Lock.Release;
          DoChange;
          F.Position := FSectorCurrent * SectorSize;
          if Mode = rmRead then RealSize := F.Read(BufferAligned^, SectorSize)
            else if Mode = rmWrite then RealSize := F.Write(BufferAligned^, SectorSize)
            else raise Exception.Create(SUnknownRunMode);
        finally
          Lock.Acquire;
        end;
        if RealSize <> SectorSize then begin
          BlockMap.Sectors[FSectorCurrent] := bsDamaged;
          Inc(DamagedBlockCount);
        end else begin
          if Mode = rmRead then BlockMap.Sectors[FSectorCurrent] := bsRead
            else if Mode = rmWrite then BlockMap.Sectors[FSectorCurrent] := bsWrite;
        end;
        Inc(FSectorCurrent);
        if Terminated then Break;
      end;
      FreeMem(Buffer);
    finally
      F.Free;
    end;
  finally
    Lock.Release;
  end;
  TimeEnd := Now;
  DoChange;
  Terminated := True;
  ScanThread.Synchronize(DoTerminate);
end;

procedure TDriveScan.SetDriveName(AValue: string);
begin
  if FDriveName = AValue then Exit;
  FDriveName := AValue;
end;

procedure TDriveScan.SetSectorCount(AValue: Integer);
begin
  if BlockMap.SectorCount = AValue then Exit;
  BlockMap.SectorCount := AValue;
end;

procedure TDriveScan.SpeedTimerExecute(Sender: TObject);
var
  SpeedTimeCurrent: TDateTime;
  Index: Integer;
  Value: Int64;
begin
  SpeedTimeCurrent := Now;
  Index := Trunc(SectorCurrent / SectorCount * SpeedStepsCount);
  if Index >= Length(SpeedSteps) then Index := Length(SpeedSteps) - 1;
  Value := Trunc((SectorCurrent - SectorLast) * SectorSize / ((SpeedTimeCurrent - SpeedTimeLast) / OneSecond));
  if Value < 0 then Value := 0;
  SpeedSteps[Index].UpdateValue(Value);
  SpeedTimeLast := SpeedTimeCurrent;
  SectorLast := SectorCurrent;
end;

function TDriveScan.GetName: string;
begin
  if Mode = rmNone then Result := 'None'
  else if Mode = rmRead then Result := 'Read'
  else if Mode = rmWrite then begin
    if WritePatternRandom then Result := 'Write pattern random'
      else Result := 'Write pattern $' + IntToHex(WritePattern, 2);
  end else Result := '';
end;

procedure TDriveScan.Stop;
begin
  if not Terminated then begin
    SpeedTimer.Enabled := False;
    Terminated := True;
    ScanThread.Terminate;
    ScanThread.WaitFor;
    FreeAndNil(ScanThread);
  end;
end;

procedure TDriveScan.LoadProfile(Profile: TDriveScanProfile);
begin
  SectorStart := Profile.SectorStart;
  SectorEnd := Profile.SectorEnd;
  Mode := Profile.Mode;
  WritePattern := Profile.WritePattern;
  WritePatternRandom := Profile.WritePatternRandom;
end;

constructor TDriveScan.Create;
begin
  Lock := TCriticalSection.Create;
  BlockMap := TBlockMap.Create;
  SpeedTimer := TTimer.Create(nil);
  SpeedTimer.Interval := 500;
  SpeedTimer.Enabled := False;
  SpeedTimer.OnTimer := SpeedTimerExecute;
  SpeedStepsCount := 500;
  SectorSize := 4096;
  Terminated := True;
  Reset;
  Mode := rmNone;
end;

destructor TDriveScan.Destroy;
begin
  Stop;
  FreeAndNil(SpeedTimer);
  FreeAndNil(BlockMap);
  FreeAndNil(Lock);
  inherited Destroy;
end;

procedure TDriveScan.SaveToNode(Node: TDOMNode);
var
  NewNode: TDOMNode;
  NewNode2: TDOMNode;
  NewNode3: TDOMNode;
  I: Integer;
begin
  with Node do begin
    WriteInteger(Node, 'DamagedBlockCount', DamagedBlockCount);
    WriteInteger(Node, 'RunMode', Integer(Mode));
    WriteInteger(Node, 'WritePattern', WritePattern);
    WriteBoolean(Node, 'WritePatternRandom', WritePatternRandom);
    WriteString(Node, 'DriveName', DriveName);
    WriteDateTime(Node, 'TimeStart', TimeStart);
    WriteDateTime(Node, 'TimeEnd', TimeEnd);
    WriteInteger(Node, 'SectorSize', SectorSize);
    WriteInteger(Node, 'SectorCount', SectorCount);
    WriteInteger(Node, 'SectorStart', SectorStart);
    WriteInteger(Node, 'SectorEnd', SectorEnd);
    WriteInteger(Node, 'SectorCurrent', FSectorCurrent);

    NewNode := OwnerDocument.CreateElement('SectorMap');
    AppendChild(NewNode);
    BlockMap.SaveToNode(NewNode);

    NewNode := OwnerDocument.CreateElement('Speed');
    AppendChild(NewNode);
    WriteInt64(NewNode, 'Count', Length(SpeedSteps));
    NewNode2 := OwnerDocument.CreateElement('Steps');
    NewNode.AppendChild(NewNode2);
    for I := 0 to Length(SpeedSteps) - 1 do
    if not SpeedSteps[I].Null then begin
      NewNode3 := OwnerDocument.CreateElement('Step');
      NewNode2.AppendChild(NewNode3);
      WriteInteger(NewNode3, 'Index', I);
      WriteInt64(NewNode3, 'Avg', SpeedSteps[I].Average);
      WriteInt64(NewNode3, 'Min', SpeedSteps[I].Min);
      WriteInt64(NewNode3, 'Max', SpeedSteps[I].Max);
    end;
  end;
end;

procedure TDriveScan.LoadFromNode(Node: TDOMNode);
var
  NewNode: TDOMNode;
  NewNode2: TDOMNode;
  NewNode3: TDOMNode;
  I: Integer;
begin
  with Node do begin
    DamagedBlockCount := ReadInteger(Node, 'DamagedBlockCount', 0);
    Mode := TRunMode(ReadInteger(Node, 'RunMode', 0));
    WritePattern := ReadInteger(Node, 'WritePattern', 0);
    WritePatternRandom := ReadBoolean(Node, 'WritePatternRandom', False);
    DriveName := ReadString(Node, 'DriveName', '');
    TimeStart := ReadDateTime(Node, 'TimeStart', 0);
    TimeEnd := ReadDateTime(Node, 'TimeEnd', 0);
    SectorSize := ReadInteger(Node, 'SectorSize', 512);
    SectorCount := ReadInteger(Node, 'SectorCount', 0);
    SectorStart := ReadInteger(Node, 'SectorStart', 0);
    SectorEnd := ReadInteger(Node, 'SectorEnd', SectorCount - 1);
    FSectorCurrent := ReadInteger(Node, 'SectorCurrent', 0);

    NewNode := FindNode('SectorMap');
    if Assigned(NewNode) then
      BlockMap.LoadFromNode(NewNode);

    NewNode := FindNode('Speed');
    if Assigned(NewNode) then begin
      SpeedStepsCount := ReadInt64(NewNode, 'Count', 0);
      SetLength(SpeedSteps, SpeedStepsCount);
      NewNode2 := NewNode.FindNode('Steps');
      if Assigned(NewNode2) then begin
        NewNode3 := NewNode2.FirstChild;
        while Assigned(NewNode3) and (NewNode3.NodeName = 'Step') do begin
          I := ReadInteger(NewNode3, 'Index', 0);
          SpeedSteps[I].Average := ReadInt64(NewNode3, 'Avg', 0);
          SpeedSteps[I].Min := ReadInt64(NewNode3, 'Min', 0);
          SpeedSteps[I].Max := ReadInt64(NewNode3, 'Max', 0);
          SpeedSteps[I].Null := False;
          NewNode3 := NewNode3.NextSibling;
        end;
      end;
    end;
end;
end;

end.