Author Archives: Stanislav_Panteleev

Delphi.RobustServer.Обработка ошибок, интерфейсный класс TResponses и измерение оперативной памяти

Posted on 17.11.2018 by Stanislav_Panteleev

Сделал обработку ошибок следующим образом В модуле CommandGet сделал единый блок try / except

procedure TCommandGet.Execute(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
var
  json: ISuperObject;
  r: IResponses;
  d, a, b: Double;
begin
  r := TResponses.Create(ARequestInfo, AResponseInfo);
  try
    if ARequestInfo.URI = '/testConnection' then
    r.OK()
    else if ARequestInfo.URI = '/testException' then
    begin
      a := 1;
      b := 0;
      d := a / b;
    end
    else
      AResponseInfo.ResponseNo := 404;
  except
    on E: Exception do
      r.Error(e.Message);
  end;
end;

procedure TCommandGet.Execute(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);

var

json: ISuperObject;

r: IResponses;

d, a, b: Double;

begin

r := TResponses.Create(ARequestInfo, AResponseInfo);

try

if ARequestInfo.URI = '/testConnection' then

r.OK()

else if ARequestInfo.URI = '/testException' then

begin

a := 1;

b := 0;

d := a / b;

end

else

AResponseInfo.ResponseNo := 404;

except

on E: Exception do

r.Error(e.Message);

end;

Теперь, если возникнет ошибка при обработке запроса, она не потеряется, а придет в понятном json формате, то есть вот так…. Кстати, здесь же можно посмотреть, … Continue reading →

Posted in Delphi | Leave a comment

Delphi. Измерение оперативной памяти

Posted on 17.11.2018 by Stanislav_Panteleev

Модуль из проекта Вот эти 2 процедуры измеряют текущую память и пиковую

class function CurrentProcessMemoryKB: Extended; static;
class function CurrentProcessMemoryPeakKB: Extended; static;

1 2	class function CurrentProcessMemoryKB: Extended; static; class function CurrentProcessMemoryPeakKB: Extended; static;

Полный модуль

unit uRPMemory;

interface

uses
  System.SysUtils, System.Classes, IdContext, IdCustomHTTPServer;

type
  TRPMemory = class(TDataModule)
  private
        { Private declarations }
    class function CurrentProcessMemoryKB: Extended; static;
    class function CurrentProcessMemoryPeakKB: Extended; static;
  public
    { Public declarations }
    class procedure GetMemory(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo); static;
  end;

implementation

uses
  Winapi.PsAPI, Winapi.Windows, Math;
{%CLASSGROUP 'Vcl.Controls.TControl'}

{$R *.dfm}

class function TRPMemory.CurrentProcessMemoryKB: Extended;
var
  MemCounters: TProcessMemoryCounters;
begin
  MemCounters.cb := SizeOf(MemCounters);
  if GetProcessMemoryInfo(GetCurrentProcess, @MemCounters, SizeOf(MemCounters)) then
    Result := trunc(MemCounters.WorkingSetSize / 1024)
  else
    RaiseLastOSError;
end;

class function TRPMemory.CurrentProcessMemoryPeakKB: Extended;
var
  MemCounters: TProcessMemoryCounters;
begin
  MemCounters.cb := SizeOf(MemCounters);
  if GetProcessMemoryInfo(GetCurrentProcess, @MemCounters, SizeOf(MemCounters)) then
    Result := trunc(MemCounters.PeakWorkingSetSize / 1024)
  else
    RaiseLastOSError;
end;

class procedure TRPMemory.GetMemory(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
var
  curr, peak: Extended;
begin
  curr := Math.RoundTo(CurrentProcessMemoryKB / 1024, -2);
  peak := Math.RoundTo(CurrentProcessMemoryPeakKB / 1024, -2);

  AResponseInfo.ResponseNo := 200;
  AResponseInfo.ContentType := 'application/json';
  AResponseInfo.CacheControl := 'no-cache';
  AResponseInfo.CustomHeaders.Add('Access-Control-Allow-Origin: *');
  AResponseInfo.ContentText := curr.ToString + ' / ' + peak.ToString + '   (MB)';
  AResponseInfo.WriteContent;
end;

end.

unit uRPMemory;

interface

uses

System.SysUtils, System.Classes, IdContext, IdCustomHTTPServer;

type

TRPMemory = class(TDataModule)

private

{ Private declarations }

class function CurrentProcessMemoryKB: Extended; static;

class function CurrentProcessMemoryPeakKB: Extended; static;

public

{ Public declarations }

class procedure GetMemory(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo); static;

end;

implementation

uses

Winapi.PsAPI, Winapi.Windows, Math;

{%CLASSGROUP 'Vcl.Controls.TControl'}

{$R *.dfm}

class function TRPMemory.CurrentProcessMemoryKB: Extended;

var

MemCounters: TProcessMemoryCounters;

begin

MemCounters.cb := SizeOf(MemCounters);

if GetProcessMemoryInfo(GetCurrentProcess, @MemCounters, SizeOf(MemCounters)) then

Result := trunc(MemCounters.WorkingSetSize / 1024)

else

RaiseLastOSError;

end;

class function TRPMemory.CurrentProcessMemoryPeakKB: Extended;

var

MemCounters: TProcessMemoryCounters;

begin

MemCounters.cb := SizeOf(MemCounters);

if GetProcessMemoryInfo(GetCurrentProcess, @MemCounters, SizeOf(MemCounters)) then

Result := trunc(MemCounters.PeakWorkingSetSize / 1024)

else

RaiseLastOSError;

end;

class procedure TRPMemory.GetMemory(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);

var

curr, peak: Extended;

begin

curr := Math.RoundTo(CurrentProcessMemoryKB / 1024, -2);

peak := Math.RoundTo(CurrentProcessMemoryPeakKB / 1024, -2);

AResponseInfo.ResponseNo := 200;

AResponseInfo.ContentType := 'application/json';

AResponseInfo.CacheControl := 'no-cache';

AResponseInfo.CustomHeaders.Add('Access-Control-Allow-Origin: *');

AResponseInfo.ContentText := curr.ToString + ' / ' + peak.ToString + ' (MB)';

AResponseInfo.WriteContent;

end;

end.

Posted in Delphi | Leave a comment

Delphi.RobustServer – первые шаги

Posted on 17.11.2018 by Stanislav_Panteleev

Github Первые несколько шагов. Текущую версию я делаю Visual Components Library App. Потом можно будет перевернуть это приложение в сервис, при желании. Архитектура следующая

Posted in Delphi | Leave a comment

Delphi. Отправка строки из одного потока в другой

Posted on 17.11.2018 by Stanislav_Panteleev

Простой пример, отправка из дополнительного потока в основной Отправка…

const WM_WORK_TIME = WM_USER + 1000;
...
TThread.CreateAnonymousThread(
    procedure
    var
      s: string;
    begin
      s := DateTimeToStr(Now());
      PostMessage(Main.Handle, WM_WORK_TIME, 0, LParam(PChar(s)));
    end).Start;
...

const WM_WORK_TIME = WM_USER + 1000;

...

TThread.CreateAnonymousThread(

procedure

var

s: string;

begin

s := DateTimeToStr(Now());

PostMessage(Main.Handle, WM_WORK_TIME, 0, LParam(PChar(s)));

end).Start;

...

Прием

const
  WM_WORK_TIME = WM_USER + 1000;
  procedure UpdateWorkTime(var aMsg: TMessage); message WM_WORK_TIME;
...
procedure TMain.UpdateWorkTime(var aMsg: TMessage);
begin
  StatusBar.Panels[1].Text := PChar(aMsg.LParam);
end;
...

const

WM_WORK_TIME = WM_USER + 1000;

procedure UpdateWorkTime(var aMsg: TMessage); message WM_WORK_TIME;

...

procedure TMain.UpdateWorkTime(var aMsg: TMessage);

begin

StatusBar.Panels[1].Text := PChar(aMsg.LParam);

end;

...

Posted in Без рубрики | Leave a comment

Delphi. RobustServer. Пишем мощный и надежный сервер на Indy

Posted on 11.11.2018 by Stanislav_Panteleev

На мой взгляд, более менее универсальная архитектура приложения выглядит так… В этом и последующем постах будем писать мощный и надежный сервер. Это будет шаблон для будущих проектов. Стэк технологий у нас будет следующий Delphi Seattle MySQL FireDAC SuperObject … Ближайшие … Continue reading →

Posted in Delphi | Leave a comment

Delphi. Потоки по книге Мартина Харви. Конспект

Posted on 11.11.2018 by Stanislav_Panteleev

Запуск потока Примеры анонимных запусков

// Если нужно настраивать какие-то параметры проекта после его запуска
 t := TThread.CreateAnonymousThread(
    procedure
    var
      i: Integer;
    begin
      for i := 0 to 10 do
        Sleep(15);
    end).Start;
  t.FreeOnTerminate := true;
 ...
  // Если нужно настраивать какие-то параметры потока до его запуска...
  with TThread.CreateAnonymousThread(
    procedure
    var
      i: Integer;
    begin
      for i := 0 to 10 do
        Sleep(15);
    end) do
  begin
    FreeOnTerminate := true;
    Start;
  end;
...
// From StackOverflow - пример анонимного запуска с параметрами запускаемой процедуры
procedure DoSomething(const aWebAddress: String);
begin
end;
 
procedure BuildThread;
var
  myThread: TThread;
  fetchURL: string;
begin
  fetchURL := 'http://stackoverflow.com';
  // Create an anonymous thread that calls a method and passes in
  // the fetchURL to that method.
  myThread := TThread.CreateAnonymousThread(
    procedure
    begin
      DoSomething(fetchURL);
    end);
  ...
end;

// Если нужно настраивать какие-то параметры проекта после его запуска

t := TThread.CreateAnonymousThread(

procedure

var

i: Integer;

begin

for i := 0 to 10 do

Sleep(15);

end).Start;

t.FreeOnTerminate := true;

...

// Если нужно настраивать какие-то параметры потока до его запуска...

with TThread.CreateAnonymousThread(

procedure

var

i: Integer;

begin

for i := 0 to 10 do

Sleep(15);

end) do

begin

FreeOnTerminate := true;

Start;

end;

...

// From StackOverflow - пример анонимного запуска с параметрами запускаемой процедуры

procedure DoSomething(const aWebAddress: String);

begin

end;

procedure BuildThread;

var

myThread: TThread;

fetchURL: string;

begin

fetchURL := 'http://stackoverflow.com';

// Create an anonymous thread that calls a method and passes in

// the fetchURL to that method.

myThread := TThread.CreateAnonymousThread(

procedure

begin

DoSomething(fetchURL);

end);

...

end;

Традиционный запуск

...
with TTestThread.Create(true) do
  begin
    FreeOnTerminate := true;
    Start;
  end;
...

...

with TTestThread.Create(true) do

begin

FreeOnTerminate := true;

Start;

end;

...

Полный модуль традиционного запуска из Main

unit uMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, //
  SyncObjs //
;

const
  WM_DATA_IN_BUF = WM_APP + 1000;

type
  TMain = class(TForm)
    bStart: TButton;
    procedure bStartClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    FBuffer: TStringList;
    FCS: TCriticalSection;
    procedure HandleBuffer(var aMessage: TMessage); message WM_DATA_IN_BUF;
    procedure SetBuffer(const Value: TStringList);
    procedure SetCS(const Value: TCriticalSection);
    { Private declarations }
  public
    { Public declarations }
    property Buffer: TStringList read FBuffer write SetBuffer;
    property CS: TCriticalSection read FCS write SetCS;
  end;

var
  Main: TMain;

implementation

{$R *.dfm}
uses
  uTestThread;

procedure TMain.bStartClick(Sender: TObject);
begin
  with TTestThread.Create(true) do
  begin
    FreeOnTerminate := true;
    Start;
  end;
end;

procedure TMain.HandleBuffer(var aMessage: TMessage);
begin
  FCS.Enter;
  Caption := FBuffer.Text;
  FCS.Leave;
end;


procedure TMain.SetBuffer(const Value: TStringList);
begin
  FBuffer := Value;
end;

procedure TMain.SetCS(const Value: TCriticalSection);
begin
  FCS := Value;
end;

procedure TMain.FormCreate(Sender: TObject);
begin
  ReportMemoryLeaksOnShutdown := true;
  FCS := TCriticalSection.Create;
  FBuffer := TStringList.Create;
end;

procedure TMain.FormDestroy(Sender: TObject);
begin
  FCS.Free();
  FBuffer.Free;
end;

end.

unit uMain;

interface

uses

Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,

Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, //

SyncObjs //

;

const

WM_DATA_IN_BUF = WM_APP + 1000;

type

TMain = class(TForm)

bStart: TButton;

procedure bStartClick(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure FormDestroy(Sender: TObject);

private

FBuffer: TStringList;

FCS: TCriticalSection;

procedure HandleBuffer(var aMessage: TMessage); message WM_DATA_IN_BUF;

procedure SetBuffer(const Value: TStringList);

procedure SetCS(const Value: TCriticalSection);

{ Private declarations }

public

{ Public declarations }

property Buffer: TStringList read FBuffer write SetBuffer;

property CS: TCriticalSection read FCS write SetCS;

end;

var

Main: TMain;

implementation

{$R *.dfm}

uses

uTestThread;

procedure TMain.bStartClick(Sender: TObject);

begin

with TTestThread.Create(true) do

begin

FreeOnTerminate := true;

Start;

end;

procedure TMain.HandleBuffer(var aMessage: TMessage);

begin

FCS.Enter;

Caption := FBuffer.Text;

FCS.Leave;

end;

procedure TMain.SetBuffer(const Value: TStringList);

begin

FBuffer := Value;

end;

procedure TMain.SetCS(const Value: TCriticalSection);

begin

FCS := Value;

end;

procedure TMain.FormCreate(Sender: TObject);

begin

ReportMemoryLeaksOnShutdown := true;

FCS := TCriticalSection.Create;

FBuffer := TStringList.Create;

end;

procedure TMain.FormDestroy(Sender: TObject);

begin

FCS.Free();

FBuffer.Free;

end;

end.

С объявлением класса потока, например так…

unit uTestThread;

interface

uses
  System.Classes, SyncObjs, SysUtils;

type
  TTestThread = class(TThread)
  private
    { Private declarations }
  protected
    procedure Execute; override;
  public
  end;

implementation

{ TTestThread }

uses
  uMain, Winapi.Windows;

procedure TTestThread.Execute;
var
  i, j: Integer;
begin
  if Assigned(Main.CS) then
  begin
    for i := 0 to 5 do
    begin
      Main.CS.Enter;
      Main.Buffer.Add(intToStr(i));
      Main.CS.Leave;
      Sleep(1000);
      PostMessage(Main.Handle, WM_DATA_IN_BUF, 0, 0);
    end;
  end;
end;

end.

unit uTestThread;

interface

uses

System.Classes, SyncObjs, SysUtils;

type

TTestThread = class(TThread)

private

{ Private declarations }

protected

procedure Execute; override;

public

end;

implementation

{ TTestThread }

uses

uMain, Winapi.Windows;

procedure TTestThread.Execute;

var

i, j: Integer;

begin

if Assigned(Main.CS) then

begin

for i := 0 to 5 do

begin

Main.CS.Enter;

Main.Buffer.Add(intToStr(i));

Main.CS.Leave;

Sleep(1000);

PostMessage(Main.Handle, WM_DATA_IN_BUF, 0, 0);

end;

end.

Флаг Terminated для потока Досрочная остановка потока В некоторых ситуациях одному потоку может потребоваться уведомить другой поток … Continue reading →

Posted in Без рубрики | Leave a comment

Delphi. Запуск анонимного потока

Posted on 11.11.2018 by Stanislav_Panteleev

Увидел в блоге следующий пример, по-моему оч. удобно для каких-то простых случаев….

TThread.CreateAnonymousThread(
          procedure   
          begin
            // do smth...
          end).Start;

TThread.CreateAnonymousThread(

procedure

begin

// do smth...

end).Start;

Немного модифицировал

 // Если нужно настраивать какие-то параметры проекта после его запуска
 t := TThread.CreateAnonymousThread(
    procedure
    var
      i: Integer;
    begin
      for i := 0 to 10 do
        Sleep(15);
    end).Start;
  t.FreeOnTerminate := true;

  // Если нужно настраивать какие-то параметры потока до его запуска...
  with TThread.CreateAnonymousThread(
    procedure
    var
      i: Integer;
    begin
      for i := 0 to 10 do
        Sleep(15);
    end) do
  begin
    FreeOnTerminate := true;
    Start;
  end;
e

// Если нужно настраивать какие-то параметры проекта после его запуска

t := TThread.CreateAnonymousThread(

procedure

var

i: Integer;

begin

for i := 0 to 10 do

Sleep(15);

end).Start;

t.FreeOnTerminate := true;

// Если нужно настраивать какие-то параметры потока до его запуска...

with TThread.CreateAnonymousThread(

procedure

var

i: Integer;

begin

for i := 0 to 10 do

Sleep(15);

end) do

begin

FreeOnTerminate := true;

Start;

end;

Со StackOverflow, в тему, запуск анонимного потока процедуры с параметрами

procedure DoSomething(const aWebAddress: String);
begin
end;

procedure BuildThread;
var
  myThread: TThread;
  fetchURL: string;
begin
  fetchURL := 'http://stackoverflow.com';
  // Create an anonymous thread that calls a method and passes in
  // the fetchURL to that method.
  myThread := TThread.CreateAnonymousThread(
    procedure
    begin
      DoSomething(fetchURL);
    end);
  ...
end;

procedure DoSomething(const aWebAddress: String);

begin

end;

procedure BuildThread;

var

myThread: TThread;

fetchURL: string;

begin

fetchURL := 'http://stackoverflow.com';

// Create an anonymous thread that calls a method and passes in

// the fetchURL to that method.

myThread := TThread.CreateAnonymousThread(

procedure

begin

DoSomething(fetchURL);

end);

...

end;

Posted in Delphi | Leave a comment

Delphi. Поиск имени свойства в объектном инспекторе

Posted on 10.11.2018 by Stanislav_Panteleev

В Seattle привык пользоваться фильтром по свойствам, но в XE4, например такого фильтра нет. Как быть? Открыл для себя “Тык на любом свойстве в объектном инспекторе” “Жмем Tab” “Начинаем печатать имя свойства, например Name” При этом, если свойство находится в … Continue reading →

Posted in Без рубрики | Leave a comment

Delphi – методы уничтожения объекта

Posted on 30.10.2018 by Stanislav_Panteleev

Небольшая заметка по книге Delphi Memory Management. Ниже перечислены методы освобождения объектов при ручном управлении памятью.

Posted in Без рубрики | Leave a comment

Delphi. “Nullable” Post by Allen Bauer

Posted on 30.10.2018 by Stanislav_Panteleev

В Delphi вроде как нет Nullable типов, но если нет, но очень хочется, то они могут появиться ))) Читал книгу Delphi Memory Management, и там наткнулся на раздел про Nullable, автор книги ссылался на MVP Allen Bauer. Идея проста… To implement … Continue reading →

Posted in Delphi | Leave a comment

Author Archives: Stanislav_Panteleev

Delphi.RobustServer.Обработка ошибок, интерфейсный класс TResponses и измерение оперативной памяти

Delphi. Измерение оперативной памяти

Delphi.RobustServer – первые шаги

Delphi. Отправка строки из одного потока в другой

Delphi. RobustServer. Пишем мощный и надежный сервер на Indy

Delphi. Потоки по книге Мартина Харви. Конспект

Delphi. Запуск анонимного потока

Delphi. Поиск имени свойства в объектном инспекторе

Delphi – методы уничтожения объекта

Delphi. “Nullable” Post by Allen Bauer

MY PROJECTS

DELPHI WORLD

C# WORLD

MySQL WORLD

JS WORLD

PHP World

IIS World

Recent Posts

Categories