mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-12 05:42:35 +02:00
145 lines
4.0 KiB
ObjectPascal
145 lines
4.0 KiB
ObjectPascal
{
|
|
***************************************************************************
|
|
* *
|
|
* This source is free software; you can redistribute it and/or modify *
|
|
* it under the terms of the GNU General Public License as published by *
|
|
* the Free Software Foundation; either version 2 of the License, or *
|
|
* (at your option) any later version. *
|
|
* *
|
|
* This code is distributed in the hope that it will be useful, but *
|
|
* WITHOUT ANY WARRANTY; without even the implied warranty of *
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
|
|
* General Public License for more details. *
|
|
* *
|
|
* A copy of the GNU General Public License is available on the World *
|
|
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
|
|
* obtain it by writing to the Free Software Foundation, *
|
|
* Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
|
|
* *
|
|
***************************************************************************
|
|
|
|
Abstract:
|
|
Demo to show, how to process a big file with the main thread.
|
|
Important: In most (all?) Unix like systems, the cthread unit must be added
|
|
to the uses section of the .lpr file. Further, cmem is likely to
|
|
be significently faster so add it as well. Due to how the units
|
|
work a sensible order is cmem, cthreads and then perhaps cwstrings.
|
|
But note that heaptrc does not work with cmem so comment it out
|
|
while testing/debugging.
|
|
}
|
|
unit ProcessMessagesUnit1;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, Forms, Dialogs, ComCtrls, StdCtrls, LazUTF8;
|
|
|
|
type
|
|
|
|
{ TForm1 }
|
|
|
|
TForm1 = class(TForm)
|
|
ProgressBar1: TProgressBar;
|
|
StartStopButton: TButton;
|
|
procedure FormCreate(Sender: TObject);
|
|
procedure StartStopButtonClick(Sender: TObject);
|
|
private
|
|
procedure Run;
|
|
procedure UpdateButton;
|
|
public
|
|
Running: boolean;
|
|
Aborting: boolean;
|
|
Filename: String;
|
|
end;
|
|
|
|
var
|
|
Form1: TForm1;
|
|
|
|
implementation
|
|
|
|
{$R *.lfm}
|
|
|
|
{ TForm1 }
|
|
|
|
procedure TForm1.FormCreate(Sender: TObject);
|
|
begin
|
|
Filename:='processmessagesunit1.pas';
|
|
end;
|
|
|
|
procedure TForm1.StartStopButtonClick(Sender: TObject);
|
|
begin
|
|
if not Running then
|
|
Run
|
|
else
|
|
Aborting:=true;
|
|
end;
|
|
|
|
procedure TForm1.Run;
|
|
var
|
|
fs: TFileStream;
|
|
Buffer: string;
|
|
Count: LongInt;
|
|
i: Integer;
|
|
Last: TDateTime;
|
|
begin
|
|
if Running then exit;
|
|
Running:=true;
|
|
UpdateButton;
|
|
try
|
|
// open a file
|
|
fs:=TFileStream.Create(UTF8ToSys(Filename),fmOpenRead);
|
|
try
|
|
SetLength(Buffer,10);
|
|
while true do
|
|
begin
|
|
|
|
// process all user events, like clicking on the button
|
|
Application.ProcessMessages;
|
|
if Aborting or Application.Terminated then break;
|
|
|
|
// read some bytes
|
|
Count:=fs.Read(Buffer[1],length(Buffer));
|
|
if Count=0 then break;
|
|
|
|
// process ...
|
|
for i:=1 to Count do
|
|
begin
|
|
Last:=Now;
|
|
repeat
|
|
until Now-Last>(double(1)/fs.Size)/10000;
|
|
end;
|
|
|
|
// show progress
|
|
ProgressBar1.Position:=ProgressBar1.Min
|
|
+((ProgressBar1.Max-ProgressBar1.Min+1)*fs.Position) div fs.Size;
|
|
end;
|
|
finally
|
|
fs.Free;
|
|
end;
|
|
except
|
|
on E: Exception do begin
|
|
MessageDlg('Error',E.Message,mtError,[mbCancel],0);
|
|
end;
|
|
end;
|
|
Aborting:=false;
|
|
Running:=false;
|
|
UpdateButton;
|
|
end;
|
|
|
|
procedure TForm1.UpdateButton;
|
|
begin
|
|
if Running then begin
|
|
if Aborting then
|
|
StartStopButton.Caption:='Aborting ...'
|
|
else
|
|
StartStopButton.Caption:='Running ...';
|
|
end else begin
|
|
StartStopButton.Caption:='Start';
|
|
end;
|
|
end;
|
|
|
|
end.
|
|
|