Pastebin launched a little side project called VERYVIRAL.com, check it out ;-) Want more features on Pastebin? Sign Up, it's FREE!
Guest

Code that forces multiple threads to simultaneously write

By: a guest on Mar 19th, 2011  |  syntax: Delphi  |  size: 1.11 KB  |  views: 55  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. procedure TConcurentWriterThread.Execute;
  2. var F: TFileStream;
  3.     StopTime: TDateTime;
  4.     s: string;
  5.     Buff: array[0..1024] of Byte;
  6.     i: Integer;
  7. begin
  8.   try
  9.     StopTime := Now + EncodeTime(0, 0, 30, 0);
  10.     F := TFileStream.Create('C:\Temp\Proba.bin', fmOpenWrite or fmShareDenyNone);
  11.     try
  12.       while Now < StopTime do
  13.       begin
  14.         F.Position := Random(1000);
  15.         for i:=0 to High(Buff) do
  16.           Buff[i] := Random($ff);
  17.         if F.Write(Buff, SizeOf(Buff)) <> SizeOf(Buff) then
  18.           RaiseLastOSError;
  19.       end;
  20.     finally F.Free;
  21.     end;
  22.  
  23.     Synchronize(
  24.       procedure
  25.       begin
  26.         ShowMessage('Thread Done.');
  27.       end
  28.     );
  29.  
  30.   except on E:Exception do
  31.     begin
  32.       s := E.ClassName + ' / ' + E.Message;
  33.       Synchronize(
  34.         procedure
  35.         begin
  36.           ShowMessage(s);
  37.         end
  38.       );
  39.     end;
  40.   end;
  41. end;
  42.  
  43. procedure TForm25.Button1Click(Sender: TObject);
  44. var n:Integer;
  45. begin
  46.   for n:=1 to 4 do
  47.     with TConcurentWriterThread.Create(True) do
  48.     begin
  49.       FreeOnTerminate := True;
  50.       Start;
  51.     end;
  52. end;
clone this paste RAW Paste Data