Changeset 3


Ignore:
Timestamp:
Mar 26, 2016, 11:40:31 PM (8 years ago)
Author:
chronos
Message:
  • Modified: TDriveScan and TBlockMap moved to separate units.
  • Added: Show total drive size.
Location:
trunk
Files:
2 added
4 edited

Legend:

Unmodified
Added
Removed

  • trunk/CoolDisk.lpi

    r1 r3  
    7272      </Item2>
    7373    </RequiredPackages>
    74     <Units Count="6">
     74    <Units Count="8">
    7575      <Unit0>
    7676        <Filename Value="CoolDisk.lpr"/>
    … …  
    105105        <IsPartOfProject Value="True"/>
    106106      </Unit5>
     107      <Unit6>
     108        <Filename Value="UBlockMap.pas"/>
     109        <IsPartOfProject Value="True"/>
     110      </Unit6>
     111      <Unit7>
     112        <Filename Value="UDriveScan.pas"/>
     113        <IsPartOfProject Value="True"/>
     114      </Unit7>
    107115    </Units>
    108116  </ProjectOptions>
    … …  
    139147      </Options>
    140148    </Linking>
     149    <Other>
     150      <CompilerMessages>
     151        <IgnoredMessages idx5024="True"/>
     152      </CompilerMessages>
     153    </Other>
    141154  </CompilerOptions>
    142155  <Debugging>

  • trunk/CoolDisk.lpr

    r1 r3  
    99  Interfaces, // this includes the LCL widgetset
    1010  Forms, tachartlazaruspkg, UFormMain, UFormBenchmark, UFormProject, UProject,
    11   UConfig
     11  UConfig, UBlockMap, UDriveScan
    1212  { you can add units after this };
    1313

  • trunk/UFormMain.lfm

    r2 r3  
    11object FormMain: TFormMain
    2   Left = 355
     2  Left = 215
    33  Height = 941
    4   Top = 211
     4  Top = 79
    55  Width = 1703
    66  Caption = 'CoolDisk'
    … …  
    1212  OnDestroy = FormDestroy
    1313  OnShow = FormShow
    14   LCLVersion = '1.6.0.4'
     14  LCLVersion = '1.7'
    1515  object ListView1: TListView
    1616    Left = 16
    … …  
    4444  object Label1: TLabel
    4545    Left = 15
    46     Height = 24
     46    Height = 22
    4747    Top = 675
    48     Width = 101
     48    Width = 91
    4949    Caption = 'Sector size:'
    5050    ParentColor = False
    … …  
    5252  object LabelBlockSize: TLabel
    5353    Left = 256
    54     Height = 24
     54    Height = 22
    5555    Top = 675
    5656    Width = 10
    … …  
    6060  object LabelBlockCount: TLabel
    6161    Left = 256
    62     Height = 24
     62    Height = 22
    6363    Top = 704
    6464    Width = 10
    … …  
    6868  object Label2: TLabel
    6969    Left = 16
    70     Height = 24
     70    Height = 22
    7171    Top = 704
    72     Width = 119
     72    Width = 105
    7373    Caption = 'Sector count:'
    7474    ParentColor = False
    … …  
    7676  object LabelBlockCurrent: TLabel
    7777    Left = 256
    78     Height = 24
     78    Height = 22
    7979    Top = 736
    8080    Width = 10
    … …  
    8484  object Label3: TLabel
    8585    Left = 16
    86     Height = 24
     86    Height = 22
    8787    Top = 736
    88     Width = 136
     88    Width = 122
    8989    Caption = 'Current sector:'
    9090    ParentColor = False
    … …  
    9292  object Label4: TLabel
    9393    Left = 17
    94     Height = 24
     94    Height = 22
    9595    Top = 768
    96     Width = 162
     96    Width = 147
    9797    Caption = 'Damaged sectors:'
    9898    ParentColor = False
    … …  
    100100  object LabelBlockDamaged: TLabel
    101101    Left = 256
    102     Height = 24
     102    Height = 22
    103103    Top = 764
    104104    Width = 10
    … …  
    108108  object Label5: TLabel
    109109    Left = 16
    110     Height = 24
     110    Height = 22
    111111    Top = 796
    112     Width = 122
     112    Width = 112
    113113    Caption = 'Elapsed time:'
    114114    ParentColor = False
    … …  
    116116  object LabelElapsedTime: TLabel
    117117    Left = 256
    118     Height = 24
     118    Height = 22
    119119    Top = 792
    120120    Width = 10
    … …  
    124124  object Label6: TLabel
    125125    Left = 17
    126     Height = 24
     126    Height = 22
    127127    Top = 824
    128     Width = 142
     128    Width = 129
    129129    Caption = 'Estimated time:'
    130130    ParentColor = False
    … …  
    132132  object LabelEstimatedTime: TLabel
    133133    Left = 257
    134     Height = 24
     134    Height = 22
    135135    Top = 820
    136136    Width = 10
    … …  
    140140  object Label7: TLabel
    141141    Left = 17
    142     Height = 24
     142    Height = 22
    143143    Top = 644
    144     Width = 160
     144    Width = 144
    145145    Caption = 'Sectors per Block:'
    146146    ParentColor = False
    … …  
    148148  object LabelSectorPerBlock: TLabel
    149149    Left = 256
    150     Height = 24
     150    Height = 22
    151151    Top = 640
    152152    Width = 10
    … …  
    156156  object LabelIOSpeed: TLabel
    157157    Left = 256
    158     Height = 24
     158    Height = 22
    159159    Top = 848
    160160    Width = 10
    … …  
    164164  object Label8: TLabel
    165165    Left = 16
    166     Height = 24
     166    Height = 22
    167167    Top = 852
    168     Width = 94
     168    Width = 86
    169169    Caption = 'I/O speed:'
    170170    ParentColor = False
    … …  
    196196  object EditDrive: TEdit
    197197    Left = 16
    198     Height = 34
     198    Height = 32
    199199    Top = 8
    200200    Width = 448
    … …  
    203203  object ComboBoxRunMode: TComboBox
    204204    Left = 17
    205     Height = 38
     205    Height = 32
    206206    Top = 88
    207207    Width = 247
    … …  
    218218  object Label9: TLabel
    219219    Left = 286
    220     Height = 24
     220    Height = 22
    221221    Top = 95
    222     Width = 121
     222    Width = 108
    223223    Caption = 'Data pattern:'
    224224    ParentColor = False
    … …  
    226226  object EditPattern: TEdit
    227227    Left = 440
    228     Height = 34
     228    Height = 32
    229229    Top = 88
    230230    Width = 80
    231231    TabOrder = 7
    232232    Text = '0xff'
     233  end
     234  object Label10: TLabel
     235    Left = 16
     236    Height = 22
     237    Top = 612
     238    Width = 36
     239    Caption = 'Size:'
     240    ParentColor = False
     241  end
     242  object LabelSize: TLabel
     243    Left = 256
     244    Height = 22
     245    Top = 608
     246    Width = 10
     247    Caption = '  '
     248    ParentColor = False
    233249  end
    234250  object MainMenu1: TMainMenu

  • trunk/UFormMain.pas

    r2 r3  
    77uses
    88  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
    9   Menus, ComCtrls, ExtCtrls, ActnList, Math, dateutils, syncobjs, UProject,
    10   UConfig;
     9  Menus, ComCtrls, ExtCtrls, ActnList, dateutils, syncobjs, UProject,
     10  UDriveScan;
    1111
    1212type
    13 
    14   TSectorState = (bsNone, bsOk, bsDamaged);
    15 
    16   { TBlockMap }
    17 
    18   TBlockMap = class
    19   private
    20     FBlockSize: TPoint;
    21     FDrawSize: TPoint;
    22     FSectorPerBlock: Integer;
    23     FSectors: array of TSectorState;
    24     FBlocks: array of TSectorState;
    25     function GetBlockCount: Integer;
    26     function GetSector(Index: Integer): TSectorState;
    27     function GetSectorCount: Integer;
    28     procedure SetBlockCount(AValue: Integer);
    29     procedure SetBlockSize(AValue: TPoint);
    30     procedure SetDrawSize(AValue: TPoint);
    31     procedure SetSector(Index: Integer; AValue: TSectorState);
    32     procedure SetSectorCount(AValue: Integer);
    33     procedure SetSectorPerBlock(AValue: Integer);
    34     procedure UpdateBlockSize;
    35     procedure UpdateBlocks;
    36   public
    37     ItemsCount: TPoint;
    38     function CombineSectors(From, Count: Integer): TSectorState;
    39     procedure Draw(Canvas: TCanvas);
    40     procedure Clear;
    41     constructor Create;
    42     property BlockSize: TPoint read FBlockSize write SetBlockSize;
    43     property DrawSize: TPoint read FDrawSize write SetDrawSize;
    44     property SectorPerBlock: Integer read FSectorPerBlock write SetSectorPerBlock;
    45     property SectorCount: Integer read GetSectorCount write SetSectorCount;
    46     property BlockCount: Integer read GetBlockCount;
    47     property Sectors[Index: Integer]: TSectorState read GetSector write SetSector;
    48   end;
    49 
    50   TRunMode = (rmRead, rmWrite);
    51 
    52   { TDriveScan }
    53 
    54   TDriveScan = class
    55   private
    56     FOnChange: TNotifyEvent;
    57     FOnTerminate: TNotifyEvent;
    58     procedure DoChange;
    59     procedure DoTerminate;
    60   public
    61     Lock: TCriticalSection;
    62     BlockMap: TBlockMap;
    63     SectorSize: Integer;
    64     SectorCurrent: Integer;
    65     TimeStart: TDateTime;
    66     TimeEnd: TDateTime;
    67     Terminated: Boolean;
    68     DamagedBlockCount: Integer;
    69     Drive: string;
    70     Mode: TRunMode;
    71     WritePattern: Byte;
    72     function GetElapsedTime: TDateTime;
    73     procedure Run;
    74     constructor Create;
    75     destructor Destroy; override;
    76     property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;
    77     property OnChange: TNotifyEvent read FOnChange write FOnChange;
    78   end;
    79 
    80   { TScanThread }
    81 
    82   TScanThread = class(TThread)
    83     Form: TForm;
    84     procedure Execute; override;
    85   end;
    86 
    8713  { TFormMain }
    8814
    … …  
    10228    Image1: TImage;
    10329    Label1: TLabel;
     30    Label10: TLabel;
    10431    Label2: TLabel;
    10532    Label3: TLabel;
    … …  
    11744    LabelEstimatedTime: TLabel;
    11845    LabelIOSpeed: TLabel;
     46    LabelSize: TLabel;
    11947    LabelSectorPerBlock: TLabel;
    12048    ListView1: TListView;
    … …  
    13462  private
    13563    LastBlockPos: Integer;
    136     DriveScan: TDriveScan;
    13764    ScanThread: TScanThread;
    13865    RedrawPending: Boolean;
    … …  
    14370    procedure UpdateInterface;
    14471  public
     72    DriveScan: TDriveScan;
    14573    Project: TProject;
    14674    procedure Detect;
    … …  
    15785uses
    15886  UFormProject;
    159 
    160 { TScanThread }
    161 
    162 procedure TScanThread.Execute;
    163 begin
    164   TFormMain(Form).DriveScan.Run;
    165 end;
    166 
    167 { TBlockMap }
    168 
    169 function TBlockMap.GetSectorCount: Integer;
    170 begin
    171   Result := Length(FSectors);
    172 end;
    173 
    174 procedure TBlockMap.SetBlockCount(AValue: Integer);
    175 begin
    176   SetLength(FBlocks, AValue);
    177 end;
    178 
    179 procedure TBlockMap.SetBlockSize(AValue: TPoint);
    180 begin
    181   if (FBlockSize.X = AValue.X) and (FBlockSize.Y = AValue.Y) then Exit;
    182   if (AValue.X = 0) or (AValue.Y = 0) then
    183     raise Exception.Create('BlockSize can''t be set to 0');
    184   FBlockSize := AValue;
    185 end;
    186 
    187 procedure TBlockMap.SetDrawSize(AValue: TPoint);
    188 begin
    189   if (FDrawSize.X = AValue.X) and (FDrawSize.Y = AValue.Y) then Exit;
    190   FDrawSize := AValue;
    191   UpdateBlockSize;
    192 end;
    193 
    194 function TBlockMap.GetSector(Index: Integer): TSectorState;
    195 begin
    196   Result := FSectors[Index];
    197 end;
    198 
    199 function TBlockMap.GetBlockCount: Integer;
    200 begin
    201   Result := Length(FBlocks);
    202 end;
    203 
    204 procedure TBlockMap.SetSector(Index: Integer; AValue: TSectorState);
    205 var
    206   BlockIndex: Integer;
    207 begin
    208   FSectors[Index] := AValue;
    209 
    210   // Update block
    211   BlockIndex := Index div FSectorPerBlock;
    212   if (AValue = bsDamaged) then FBlocks[BlockIndex] := bsDamaged
    213   else if (AValue = bsOk) and (FBlocks[BlockIndex] = bsNone) then
    214     FBlocks[BlockIndex] := bsOk;
    215 end;
    216 
    217 procedure TBlockMap.SetSectorCount(AValue: Integer);
    218 begin
    219   if Length(FSectors) = AValue then Exit;
    220   SetLength(FSectors, AValue);
    221   UpdateBlockSize;
    222 end;
    223 
    224 procedure TBlockMap.SetSectorPerBlock(AValue: Integer);
    225 begin
    226   if FSectorPerBlock = AValue then Exit;
    227   FSectorPerBlock := AValue;
    228   UpdateBlockSize;
    229 end;
    230 
    231 procedure TBlockMap.UpdateBlockSize;
    232 begin
    233   ItemsCount := Point(Trunc(FDrawSize.X / BlockSize.X), Trunc(FDrawSize.Y / BlockSize.Y));
    234   FSectorPerBlock := Ceil(SectorCount / (ItemsCount.X * ItemsCount.Y));
    235   SetBlockCount(Ceil(SectorCount / FSectorPerBlock));
    236   UpdateBlocks;
    237 end;
    238 
    239 procedure TBlockMap.UpdateBlocks;
    240 var
    241   I: Integer;
    242 begin
    243   for I := 0 to BlockCount - 1 do
    244     FBlocks[I] := CombineSectors(I * FSectorPerBlock, FSectorPerBlock);
    245 end;
    246 
    247 function TBlockMap.CombineSectors(From, Count: Integer): TSectorState;
    248 var
    249   I: Integer;
    250   UpTo: Integer;
    251 begin
    252   Result := bsNone;
    253   UpTo := From + Count - 1;
    254   if UpTo >= SectorCount then Upto := SectorCount - 1;
    255   for I := From to UpTo do begin
    256 
    257     if (Result = bsNone) and (Sectors[I] = bsOk) then Result := bsOk
    258     else if (Result = bsOk) and (Sectors[I] = bsDamaged) then Result := bsDamaged;
    259   end;
    260 end;
    261 
    262 procedure TBlockMap.Draw(Canvas: TCanvas);
    263 var
    264   I: Integer;
    265   Rect: TRect;
    266   BlockState: TSectorState;
    267 begin
    268   Canvas.Pen.Style := psSolid;
    269   Canvas.Pen.Color := clBlack;
    270   // Clean background
    271   Canvas.Brush.Style := bsSolid;
    272   Canvas.Brush.Color := clBlack;
    273   Canvas.FillRect(0, 0, Canvas.Width, Canvas.Height);
    274 
    275   DrawSize := Point(Canvas.Width, Canvas.Height);
    276   if SectorPerBlock >= 1 then begin
    277     for I := 0 to BlockCount - 1 do begin
    278       Rect := Bounds((I mod ItemsCount.X) * BlockSize.X,
    279         (I div ItemsCount.X) * BlockSize.Y, BlockSize.X - 1, BlockSize.Y - 1);
    280       BlockState := FBlocks[I];
    281       if BlockState = bsOk then Canvas.Brush.Color := clGreen
    282         else if BlockState = bsDamaged then Canvas.Brush.Color := clRed
    283         else Canvas.Brush.Color := clSilver;
    284       Canvas.FillRect(Rect);
    285       //Canvas.TextOut(Rect.Left, Rect.Top, IntToStr(I));
    286     end;
    287   end;
    288 end;
    289 
    290 procedure TBlockMap.Clear;
    291 var
    292   I: Integer;
    293 begin
    294   for I := 0 to SectorCount - 1 do
    295     FSectors[I] := bsNone;
    296 end;
    297 
    298 constructor TBlockMap.Create;
    299 begin
    300   FBlockSize := Point(12, 12);
    301   SectorPerBlock := 1;
    302 end;
    303 
    304 { TDriveScan }
    305 
    306 procedure TDriveScan.DoChange;
    307 begin
    308   if Assigned(FOnChange) then FOnChange(Self);
    309 end;
    310 
    311 procedure TDriveScan.DoTerminate;
    312 begin
    313   if Assigned(FOnTerminate) then FOnTerminate(Self);
    314 end;
    315 
    316 function TDriveScan.GetElapsedTime: TDateTime;
    317 begin
    318   if TimeEnd <> 0 then Result := TimeEnd - TimeStart
    319     else Result := Now - TimeStart;
    320 end;
    321 
    322 procedure TDriveScan.Run;
    323 var
    324   F: TFileStream;
    325   RealSize: Integer;
    326   Buffer: array of Byte;
    327   I: Integer;
    328 begin
    329   try
    330   Lock.Acquire;
    331   TimeStart := Now;
    332   Terminated := False;
    333   DamagedBlockCount := 0;
    334   if Mode = rmRead then F := TFileStream.Create(Drive, fmOpenRead)
    335     else if Mode = rmWrite then F := TFileStream.Create(Drive, fmOpenReadWrite);
    336   BlockMap.SectorCount := F.Size div SectorSize;
    337   BlockMap.Clear;
    338   SetLength(Buffer, SectorSize);
    339   if Mode = rmWrite then
    340     FillChar(Buffer[0], Length(Buffer), WritePattern);
    341   for I := 0 to BlockMap.SectorCount - 1 do begin
    342     SectorCurrent := I;
    343     try
    344       Lock.Release;
    345       DoChange;
    346 
    347       if ConfigTest then begin
    348         if Random < 0.000001 then RealSize := 0
    349           else RealSize := SectorSize;
    350         //Sleep(1);
    351       end else begin
    352         F.Position := I * SectorSize;
    353         if Mode = rmRead then RealSize := F.Read(Buffer[0], SectorSize)
    354           else if Mode = rmWrite then RealSize := F.Write(Buffer[0], SectorSize)
    355           else raise Exception.Create('Unknwon run mode');
    356       end;
    357     finally
    358       Lock.Acquire;
    359     end;
    360     if RealSize <> SectorSize then begin
    361       BlockMap.Sectors[I] := bsDamaged;
    362       Inc(DamagedBlockCount);
    363     end else BlockMap.Sectors[I] := bsOk;
    364     if Terminated then Break;
    365   end;
    366   F.Free;
    367 
    368   finally
    369     Lock.Release;
    370   end;
    371   TimeEnd := Now;
    372   DoChange;
    373   Terminated := True;
    374   DoTerminate;
    375 end;
    376 
    377 constructor TDriveScan.Create;
    378 begin
    379   Lock := TCriticalSection.Create;
    380   BlockMap := TBlockMap.Create;
    381   SectorSize := 4096;
    382   Terminated := True;
    383 end;
    384 
    385 destructor TDriveScan.Destroy;
    386 begin
    387   FreeAndNil(BlockMap);
    388   FreeAndNil(Lock);
    389   inherited Destroy;
    390 end;
    39187
    39288{ TFormMain }
    … …  
    411107  ScanThread.Form := Self;
    412108  Project := TProject.Create;
    413   EditDrive.Text := '/dev/sdb';
     109  EditDrive.Text := '/dev/sda';
    414110end;
    415111
    … …  
    482178        Picture.Bitmap.EndUpdate;
    483179      end;
     180      LabelSize.Caption := IntToStr(DriveScan.BlockMap.SectorCount * DriveScan.SectorSize) + ' bytes';
    484181      LabelSectorPerBlock.Caption := IntToStr(DriveScan.BlockMap.SectorPerBlock);
    485182      LabelBlockSize.Caption := IntToStr(DriveScan.SectorSize) + ' bytes';
Note: See TracChangeset for help on using the changeset viewer.