Как передать звук с микрофона по сети?

#c_sharp #c #delphi #cpp

                    
Нужно передать звук с микрофона по сети на другой комп и воспроизвести там. Я знаю,
что мне нужна 2 программы. Сервер и Клиент. А еще я знаю, что я дожна использовать
RTP. Я справилась с задачей c помощью FTP.  Думала, что и с этой справлюсь, но что-то
не получается. Прошу помощь. Спасибо всем заранее.    

Ответы

Ответ 1

По хорошему суть такова: берем поток с микрофона, режем на кусочки по 0.1-0.5 сек
(смотря насколько вам нужен реалтайм, чем выше частота, тем больше нагрузка). Кодируем
сей кусочек в mp3 и шлем по уже созданному сокет-соединению. Там, соотв-но, дешифруем
и воспроизводим.
Собственно, если вас не сильно заботит траффик, можно решать в лоб(без перекодировки,
в PCM MONO). В который раз тут пиарю либу, уж простите) 
Чего делаем: инициализируемся, определяем девайс микрофона. Выставляем потоку глубину/частоту,
чтобы ваше соединение вытянуло (ширина потока будет = (глубинаbps / 8) * 1 канал(моно)
* частотадискретизации байт/сек).
Далее: открываем соединение с клиентом и раз в 0.1-0.5 сек берем с потока байты и
шлем в сокет. С такой же частотой на клиенте считываем данные с сервера и напрямую
воспроизводим. 
Отправку/прием лучше реализовать в отдельном потоке. 
В архиве для дельфей (скорее всего не только, но не проверял) куча примеров, которые
можно расковырять. В т.ч. был пример с инет-радио. В том же архиве хелп по всем функциям,
наложить их на алгоритм выше не должно быть проблемой.

IP адрес в Delphi

#delphi #ip_address

                    
Как программно узнать свой IP адрес?    

Ответы

Ответ 1

Можно, например, так:
function GetIP:string;
var
  WSAData: TWSAData;
  p: PHostEnt;
  name: array [0..255] of AnsiChar;
begin
  WSAStartup($0101, WSAData);
  gethostname(name, 256);
  p := gethostbyname(name);
  result := inet_ntoa(PInAddr(P.H_ADDR_LIST^)^);
  WSACleanup;
end;


Ответ 2

function TForm2.LocalIP: string;
type
 TaPInAddr=array [0..10] of PInAddr;
 PaPInAddr=^TaPInAddr;
var
 phe:PHostEnt;
 pptr:PaPInAddr;
 Buffer:array [0..63] of char;
 i:Integer;
 GInitData:TWSADATA;
begin
 WSAStartup($101, GInitData);
 Result:='';
 GetHostName(Buffer, SizeOf(Buffer));
 phe:=GetHostByName(buffer);
 if phe=nil then Exit;
 pptr:=PaPInAddr(Phe^.h_addr_list);
 i:=0;
 while pptr^[i]<>nil do
  begin
   result:=StrPas(inet_ntoa(pptr^[i]^));
   Inc(i);
  end;
 WSACleanup;
end;


Ответ 3

uses
  WinSock;

function GetLocalIP: String;
const WSVer = $101;
var
  wsaData: TWSAData;
  P: PHostEnt;
  Buf: array [0..127] of Char;
begin
  Result := '';
  if WSAStartup(WSVer, wsaData) = 0 then begin
    if GetHostName(@Buf, 128) = 0 then begin
      P := GetHostByName(@Buf);
      if P <> nil then Result := iNet_ntoa(PInAddr(p^.h_addr_list^)^);
    end;
    WSACleanup;
  end;
end;

Использование generics в Delphi: неизвестный тип данных TList

#delphi #generics #delphi_xe2

                    
Пробую использовать generics:

var List: TList;    


но RAD Studio мне подчеркивает неизвестный тип данных TList, хотя в коде var List:
TList; - никаких проблем нет. В чем тут может быть проблема? Юнит Classes, естественно,
подключен.
    

Ответы

Ответ 1

Ответ найден: нужно подключить еще и юнит System.Generics.Collections

Совместимы ли методы из библиотеки Delphi с P/Invoke?

#c_sharp #delphi #net

                    
Совместимы ли методы из библиотеки, написанной на Delphi с P/Invoke?
И если нет - есть ли какая либо возможность сделать их совместимыми? 

Есть доступ к исходникам .dll.
    

Ответы

Ответ 1

Для начала - стоит посмотреть в исходниках, с каким соглашением о вызовах функции
из библиотеки экспортируются.

Если там stdcall или cdecl - то такая функция без проблем может быть вызвана через
P/Invoke. Если же там соглашение не указано - то так просто не получится.

В таком случае, если исходники библиотеки менять нельзя - самым простым решением
будет прослойка из еще одной библиотеки на Delphi:

procedure Foo(...); external 'MyLib.dll';

// ...

procedure Foo_Std(...); stdcall;
begin
  Foo(...);
end;

// ...

exports
  Foo_Std name 'Foo';

Как избежать подвисания программы во время ожидания выполнения другой через CreateProcess?

#delphi #winapi

Запускаю программу Delphi, открывается форма, нажимаю на кнопку, происходит выполнение
команды через cmd.exe. Мне нужно дождаться завершения ее выполнения. И пока команда
не выполниться - у меня сама форма (программа) Delphi находится в замороженном состоянии.
Мне нужно, чтобы сама форма (программа) Delphi - не была в замороженном состоянии.
То есть её можно было передвигать. Как сделать, чтобы окно программы Delphi в процессе
выполнения CMD.exe не застывало? То есть обработка в отдельном потоке.

var
  LCmd: string;
  LInfo: TStartupInfo;
  LPI: TProcessInformation;
begin
  // Заполняем структуры
  LCmd := 'cmd.exe ' + SPar;
  FillChar(LInfo, SizeOf(LInfo), 0);
  LInfo.cb := SizeOf(LInfo);
  LInfo.dwFlags := STARTF_USESHOWWINDOW;
  LInfo.wShowWindow := SW_HIDE;
  // Запускаем программу
  Win32Check(CreateProcess(
    'cmd.exe',        // lpApplicationName,
    PChar(LCmd),      // lpCommandLine,
    nil,              // lpProcessAttributes,
    nil,              // lpThreadAttributes,
    False,            // bInheritHandles,
    CREATE_NO_WINDOW, // dwCreationFlags,
    nil,              // lpEnvironment,
    nil,              // lpCurrentDirectory,
    LInfo,            // lpStartupInfo,
    LPI               // lpProcessInformation
  ));
  try
    // Закрываем хендл главного потока (он нам не нужен)
    CloseHandle(LPI.hThread);
    // Ждем завершения процесса
    Win32Check(WaitForSingleObject(LPI.hProcess, INFINITE) <> WAIT_FAILED);
  finally
    // Закрываем хендл процесса
    CloseHandle(LPI.hProcess);
  end;
  ShowMessage('Программа завершена');
end;

    

Ответы

Ответ 1

Чтобы дождаться завершения программы не замораживая интерфейс, нужно делать ожидание
в отдельном потоке. А потом уведомить основной поток о завершении операции

type
  TWaitThread = class(TThread)
  private
    FWaitHandle: THandle;
  protected
    procedure Execute; override;
  public
    constructor Create(ACreateSuspended: Boolean; AWaitHandle: THandle);
    destructor Destroy; override;
  end;

constructor TWaitThread.Create(ACreateSuspended: Boolean; AWaitHandle: THandle);
begin
  inherited Create(ACreateSuspended);
  FWaitHandle := AWaitHandle;
end;

destructor TWaitThread.Destroy; 
begin
  CloseHandle(FWaitHandle);
  inherited Destroy;
end;

procedure TWaitThread.Execute; 
begin
  // Ждем завершения процессса
  Win32Check(WaitForSingleObject(FWaitHandle, INFINITE) <> WAIT_FAILED);
end;

// И использование
var
  ..........
  LPI: TProcessInformation;
  LThread: TThread;
begin
  ..........
  Win32Check(CreateProcess(......, LPI));
  CloseHandle(LPI.hThread);
  // Создаем ждущий поток
  LThread := TWaitThread.Create(True, LPI.hProcess);
  // Поток удалится при завершении
  LThread.FreeOnTerminate := True;
  // После завершения вызвать процедуру EndWait
  LThread.OnTerminate := EndWait;
  // Запускаем поток
  LThread.Start;
end;

procedure TForm1.EndWait(Sender: TObject);
begin
  ShowMessage('Программа завершена');
end;

Подменить функцию Send() своей

#delphi

Требуется вести лог исходящих от программы-клиента пакетов.
Внедряю свою dll в процесс программы-клиента. Адрес оригинальной функции Send в памяти
нахожу (GetModuleHandle->GetProcAddress).
Как можно поставить хук на стандартную функцию Send из Winsock/подменить на свою,
с последующим вызовом оригинальной?
Очень хотелось бы примеры(
Гуглил много и упорно, ничего подходящего не нашёл.
Предпочтительнее всего в моём случае сплайсинг.
Библиотеку advApiHook от MS-REM не предлагать, она сильно устарела и полна глюков.    

Ответы

Ответ 1

Тут описано подробно.


   Здравствуй читатель. Сегодня я расскажу довольно таки эффективную методику перехвата
API функций. Не следует думать, что если мы хотим перехватить API функции, то мы пишем
либо троян, вирус и ещё какую-нибудь заразу, с помощью перехвата API функций осуществляются
многие защитные механизмы, перехват API функций это довольно-таки нужная и полезная
вещь. Для прочтения данной статьи с максимальной пользой обязательны, нужны, как минимум,
начальные знания низкоуровневого программирования и хотя бы какие-нибудь знания архитектуры
работы Windows. Итак, начнём.

   В этой статье я расскажу наиболее действенную методику перехвата API функций —
это сплайсинг. Сплайсинг это подмена кода функции. Конечно, есть другой метод перехвата
это редактирование таблицы импорта приложения, редактирование таблицы экспорта. Рассказывать
буду по порядку.
   Когда вы пишете в своём приложении так 
Function Func1(param:type):restype;stdcall;external ‘libname.dll’;
Вы импортируете функцию статически. Адрес функции прописывается в таблице импорта
вашего приложения (допустим, что адрес нашей функции $7BC56010). 
адрес      значение
……
$00405F56  7BC56010
……

А при вызове функции происходит так
Push …
push …
call dword ptr [$00405F56]

Следовательно, для перехвата функции нам надо только подменить значение по адресу
$00405F56 на своё, а для вызова оригинальной функции получать адрес функции через GetProcAddress.
Но приложение может также получить адрес функции через GetProcAddress и вызывать перехватываемую
функцию минуя, перехватчик. Данный метод бесперспективен. 
   Идём дальше. Что такое сплайсинг? Наша функция находится по адресу $7C80B529 и
допустим, что там такой код
7C80B529      8BFF             mov     edi, edi                     
7C80B52B      55               push    ebp
7C80B52C      8BEC             mov     ebp, esp
7C80B52E      837D 08 00       cmp     dword ptr ss:[ebp+8], 0

Для перехвата функции от нас требуется только переписать начальный код функции, так
чтобы он передавал управление нашему обработчику. Для передачи управления нашему обработчику
достаточно всего лишь одной инструкции jmp на абсолютный  адрес, на адрес нашего обработчика
. Эта инструкция займёт всего лишь 5 байт – сам опкод этой инструкции ($E9) и значение
для прыжка. Это значение вычисляется так
 v=0-(s-d)
s - Смещение следующей команды
d - Требуемый адрес для jmp, т.е. адрес обработчика

Если немного переделать эту формулу, то она будет выглядеть так
v=d-FunctionAddress-5

Теперь при каждом вызове целевой функции, всегда будет передаваться управление нашему
обработчику. А как теперь вызвать оригинальную функцию? При установке перехвата нам
надо сохранять первые 5 байт функции. Для вызова оригинала надо восстанавливать начало
функции и вызывать ее, потом снова устанавливать перехват. Объявим структуру в которой
будем сохранять первые 5 байт функции:
PFunctionRestoreData = ^ TFunctionRestoreData;
TFunctionRestoreData = packed record
  Address:Pointer;
  val1:Byte;
  val2:DWORD;
 end;

Поле Address фактически в этой структуре не нужен (он просто не к чему), поле нужно
только для того чтобы было удобнее снимать перехват. Назовём эту структуру «мост» к
старой функции.
   Теперь напишем функцию, которая будет устанавливать перехват:
function SetCodeHook(ProcAddress, NewProcAddress: pointer; RestoreDATA:PFunctionRestoreData):boolean;
var
  OldProtect, JMPValue:DWORD;
begin
  Result:=False;
  if not VirtualProtect(ProcAddress,5,PAGE_EXECUTE_READWRITE,OldProtect) then exit;
  JMPValue := DWORD (NewProcAddress) - DWORD (ProcAddress) - 5;
  RestoreDATA^.val1:= Byte(ProcAddress^);
  RestoreDATA^.val2:= DWORD(Pointer(DWORD(ProcAddress)+1)^);
  RestoreDATA^.Address:=ProcAddress;
  byte(ProcAddress^):=$E9;
  DWORD(Pointer(DWORD(ProcAddress)+1)^):=JMPValue;
  Result:=VirtualProtect(ProcAddress,5,OldProtect,OldProtect);
end;

Мы сначала устанавливает атрибуты доступа к коду функции, так чтобы можно было его
переписывать. Потом вычисляем значение для прыжка. Сначала сохраняем начало функции
в запись, потом переписываем начало функции. В конце устанавливаем старые атрибуты доступа.
   Теперь напишем функцию, которая будет снимать перехват:
function UnHookCodeHook(RestoreDATA:PFunctionRestoreData):Boolean;
var
  ProcAddress:Pointer;
  OldProtect,JMPValue:DWORD;
begin
  Result:=False;
  ProcAddress:=RestoreDATA^.Address;
  if not VirtualProtect(ProcAddress,5,PAGE_EXECUTE_READWRITE,OldProtect) then exit;
  Byte(ProcAddress^):=RestoreDATA^.val1;
  DWORD(Pointer(DWORD(ProcAddress)+1)^):=RestoreDATA^.val2;
  Result:=VirtualProtect(ProcAddress,5,OldProtect,OldProtect);
end;

Я думаю, что здесь всё понятно — просто восстанавливаем начало перехватываемой функции.
Адрес перехватываемой функции берём из структуры указатель, на которую передаётся функции
в качестве единственного параметра.
   Теперь напишем функцию, которая будет устанавливать перехват по имени функции. 
function SetProcedureHook(ModuleHandle: HMODULE; ProcedureName : PChar; NewProcedureAddress
:Pointer;   RestoreDATA : PFunctionRestoreData) :Boolean;
var
  ProcAddress:Pointer;
begin
  ProcAddress:=GetProcAddress(ModuleHandle,ProcedureName);
  Result:=SetCodeHook(ProcAddress,NewProcedureAddress,RestoreDATA);
end;

   Едем далее. Описанные выше функции могут перехватывать функции только в текущем
процессе. А как нам перехватывать функции в других процессах? Наиболее простой метод
это засунуть перехватчик функции в DLL и в коде библиотечной функции устанавливать
перехват, если DLL загружается в процесс и снимать перехват, если она выгружается.
Тут ещё одна проблема: как заставить другой процесс загрузить нашу DLL. Наиболее простое
решение это создание удалённых потоков. Теперь всё по порядку.
   Удалённый поток создаётся функцией CreateRemoteThread.
HANDLE CreateRemoteThread(
    HANDLE hProcess,    // хендл процесса в котором создаётся поток  
    LPSECURITY_ATTRIBUTES lpThreadAttributes,//атрибуты безопасности
    DWORD dwStackSize,  //размер стека
    LPTHREAD_START_ROUTINE lpStartAddress,//адрес функции потока 
    LPVOID lpParameter, // параметр для функции  
    DWORD dwCreationFlags,  // флаги создания 
    LPDWORD lpThreadId  // указатель на переменную, в которой будет сохранён ID потока
   );

Функция потока должна иметь следующие атрибуты
DWORD WINAPI ThreadFunc(PVOID pvPararn)

У функции только один параметр –это обычный  указатель. Теперь проанализируем ситуацию…
Думаем…Шевелим мозгами…Функция LoadLibraryA имеет такие же атрибуты. Она принимает
указатель на первый символ имени файла DLL (строка должна кончаться символом #0). Следовательно,
функция LoadLibraryA полностью подходит для того, что бы она могла выступать в качестве
функции потока. Так как она принимает указатель на строку в своём процессе, нам надо
будет записать в память чужого процесса нашу строку и именем файла DLL. Это делается
функцией WriteProcessMemory. Вот её описание
BOOL WriteProcessMemory(
    HANDLE hProcess, // хендл процесса   
    LPVOID lpBaseAddress,// адрес по которому надо писать  
    LPVOID lpBuffer,    // указатель на буфер
    DWORD nSize,    // количество байт для записи
    LPDWORD lpNumberOfBytesWritten //количество реально записанных байт 
   );

Адрес функции LoadLibraryA мы получаем с помощью функции GetProcAddress   так библиотеки
kernel32.dll и ntdll.dll грузятся во все процессы всегда по одним и тем же адресам,
следовательно, адрес, полученный в адресном пространстве нашего процесса, будет действителен
и адресном пространстве любого другого процесса. Теперь напишем функцию, которая загружает
вашу DLL в адресное пространство чужого процесса. 
function LoadLibrary_Ex(ProcessID:DWORD;LibName:PChar):boolean;
var
  pLL,pDLLPath:Pointer;
  hProcess,hThr:THandle;
  LibPathLen,_WR,ThrID:DWORD;
begin
  Result:=False;
  LibPathLen:=Length(string(LibName));
  hProcess:=OpenProcess(PROCESS_ALL_ACCESS,false,ProcessID);
  if hProcess=0 then exit;
  pDLLPath:=VirtualAllocEx(hProcess,0,LibPathLen+1,MEM_COMMIT,PAGE_READWRITE);
  if DWORD(pDLLPath)=0 then exit;
  pLL:=GetProcAddress(GetModuleHandle(kernel32),'LoadLibraryA');
  WriteProcessMemory(hProcess,pDLLPath,LibName,LibPathLen+1,_WR);
  hThr:=CreateRemoteThread(hProcess,0,0,pLL,pDLLPath,0,ThrID);
  if hThr=0 then exit;
  Result:=CloseHandle(hProcess);
end;

Таким образом, мы загрузили свою DLL в чужой процесс. Вообще, внедрение своего кода
в чужие процессы это совсем другая история и требует написания отдельной статьи. Вышеприведённый
пример это самый простой способ внедриться в чужой процесс. Обычному процессу не разрешается
изменение памяти системных процессов, таких как winlogon.exe, lsass.exe, smss.exe,
csrss.exe и др. для этого нужна привилегия SeDebugPrivilege. В приложенных к статье
исходниках есть функция EnableDebugPrivilege, которая включает эту привилегию для текущего
процесса.
   Идём дальше. Теперь у нас мы научились загружать свою DLL в чужой процесс. Но
для должного эффекта нам надо перехватывать DLL во всех процессах системы. Но как это
сделать. Можно просто перечислять процессы через ToolHelp32 и загружать свою DLL в
каждый найденный процесс. Но не приемлемо, так как во вновь созданных процессах функции
не будут перехвачены. Но можно каждую секунду перечислять процессы, короче это тоже
неприемлемо и очень долгая история. Самый простой метод это воспользоваться тем что
предоставляет нам механизм хуков. Когда мы ставим какой-либо глобальный хук с помощью
функции SetWindowsHookEx то DLL, в которой находится функция обработчик хука, загружается
во все процессы, которые получают сообщения от системы через функции GetMessage и PeekMessage.
Каркас DLL с перехватом функций будет выглядеть так примерно так 
library HideDLL;

uses
  Windows,
  ExtendedAPIFunctions,
  apihooktools;

{$R *.res}
const
  MutexName='__API_HOOK';


function MsgProc(code:DWORD;wParam,lparam:DWORD):DWORD;stdcall;
begin
  Result:=CallNextHookEx(SH,code,wParam,lparam);
end;

procedure SetWindowsHook(e:Boolean); stdcall;
var
  M:THandle;
begin
  if e then
   begin
    M:=CreateMutex(0,false,MutexName);
    if GetLastErrorERROR_ALREADY_EXISTS then
     begin
     SH:=SetWindowsHookEx(WH_GETMESSAGE,@MsgProc,HInstance,0);
     MutexHandle:=M;
    end                                   else
    CloseHandle(M);
   end
       else
   begin
    UnhookWindowsHookEx(SH);
    CloseHandle(MutexHandle);
   end;
end;

procedure DLLEntryPoint(dwReason:DWord);
begin
  case dwReason of
    DLL_PROCESS_ATTACH:
     begin
     // StopProcess(GetCurrentProcessId);
      SetWindowsHook(true);
      SetProcedureHook(GetModuleHandle('ntdll.dll'),'ZwQuerySystemInformation',@NewSystemFunction,@SystemFunctionBridge);
     // ResumeProcess(GetCurrentProcessId);
     end;
    DLL_PROCESS_DETACH:
     begin
     // StopProcess(GetCurrentProcessId);
      UnHookCodeHook(@SystemFunctionBridge);
      SetWindowsHook(false);
      //ResumeProcess(GetCurrentProcessId);
     end;
   end;
end;

begin
   DllProc:= @DLLEntryPoint; 
   DLLEntryPoint(DLL_PROCESS_ATTACH);
end.

Чтобы установить перехват на API функции во всех процессах (во всех GUI процессах)
достаточно просто загрузить нашу DLL. Достаточно написать вот такой код: 
LoadLibrary(pchar(ExtractFileDir(Application.ExeName)+'\'+'DLL.dll'));

   Также следует помнить одну меру предосторожности при установке и снятии перехвата
на функции: надо остановить все остальные потоки текущего процесса, так как во время
установки перехвата другой поток может вызывать искомую функцию и это приведёт к непредсказуемым
последствиям.
   В архиве с исходниками есть заголовочный файл для Delphi (apihooktools.pas), в
котором описаны все функции, которые я сегодня использовал и описывал.
   Вот, пожалуй, и  всё на сегодня. В архиве так же есть пример скрытия процесса
lsass.exe.
Скачать исходник

Самоудаление через реестр

#delphi

Здравствуйте! 
Вот с сайта откопал, какой путь к реестру нужно, что самоудалить прогу:
"HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce"
Записи в этом разделе указывают на имена файлов, которые должны выполниться один
раз во время загрузки системы. Для удаления программы, нужно всего лишь добавить запись
с именем файла, который удалит ее или командой del "имя файла"."
Но не могу понять, что делать в Delphi. Вот то, что сам написал:
reg:=TRegistry.Create;

reg.RootKey:=HKEY_LOCAL_MACHINE;

try
reg.OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce',true);
reg.WriteString('del','del "C:\...\Project2.exe"');
reg.CloseKey;
reg.Free;
except
end;
    

Ответы

Ответ 1

Попробуйте слеши продублируйте: вместо \ пишите \\,  например так
reg.WriteString('del','del ' + StringReplace('"C:\...\Project2.exe"', '\', '\\',
[rfReplaceAll]);


Уберите try except end и посмотрите какую ошибку выдает - может у вас нет прав на
запись в эту ветку.


Что записалось в реестр посмотрите.


Попробуйте запись в реестр команду вручную и проверьте срабатывает ли он при перезагрузке
- этот ключ может быть проигнорирован, если это указано в политике безопасности.


Попробуйте писать в реестр такую команду
cmd /C del /F /Q "C:\RHDSetup.log"


Ответ 2

Для самоудаления лучше всего использовать bat-файл.
:1
del /F /Q "C:\prog.exe" || goto :1
del /F /Q "C:\delete_prog.bat"

Генерить и запускать его можно прям из программы. 2-я строка будет пытаться удалить
prog.exe пока запущенный процесс программы не отпустит его. После успешного удаления
программы 3-я строка удалит сам bat-файл.
UPD: Чтобы процесс удаления работал в фоне без окна консоли в панели задач запускать
его нужно через ShellExecute(0, 'Open', 'C:\delete_prog.bat', nil, nil, SW_HIDE)

Создание ПО с плагинами

#c_sharp #delphi #plugin #desktop #рефлексия

По долгу службы требуется реализация довольно сложного десктопного ПО. Как одно из
требований — плагины (подключаемые модули), которые могут быть очень разнообразными:
от определения новых типов данных до работы с интерфейсом (добавление форм, кнопок
и т.п.). Разумеется, также требуются аналитика, обработка данных, сохранение в разные
БД и т.д.

Платформы для выбора — C# или Delphi (т.к. есть прототип, реализующий 90% потребного
функционала, но в режиме «спагетти»).

Если с Delphi всё понятно — средство загрузки/выгрузки плагинов делать руками, то
вот с C# не всё так прозрачно.

Пока что быстрый поиск показал следующие варианты:


MEF: довольно просто в реализации, но нельзя изолировать плагины в отдельных AppDomain
(что довольно-таки важно, это существенное архитектурное преимущество .NET вообще и
шарпа в частности);
MAF: переусложнено, замудрённо, и, с виду, уже не поддерживается. С другой стороны —
мощная изоляция;
самостоятельная реализация на reflection (например, так), с возможностью загрузки
в AppDomain и прочим. Но придётся много велосипедить, чего в общем-то не хочется.


Есть ещё варианты? Может, что-то не было учтено?

UPD: добавил ссылки.
    

Ответы

Ответ 1

Для C# есть встроенное готовое решение от Microsoft: System.Addin. Позволяет конфигурировать
плагины так, чтобы использовать их в том же AppDomain'е, или в выделенном другом, или
каждый в своём, или вообще в отдельном процессе.

Не понимаю, почему везде советуют MEF. Это решение именно для расширяемости: код,
который вы загружаете, считается доверенным и очень мало отличается от основного кода
приложения, поэтому возможности выгрузки и управление правами напрочь отсутствуют.

Самостоятельный велосипед на reflection написать можно, но придётся довольно серьёзно
разбираться в тонкостях наподобие Fusion и Load context, так что я бы не советовал
тратить время.



Обновление: Ага, System.Addin — это то, что вы называете MAF.


Ответ 2

Зависит от специфических требований к вашей системе. Так ли нужна изоляция в отдельный
домен? Если код ваших плагинов не предполагает взаимодействия с Native библиотеками,
то и исключения, выбрасываемые из плагина, не поломают вашу программу целиком. Вы вполне
можете их перехватить, по стеку установить плагин-виновник и предложить пользователю
в следующий раз не загружать его. Ну да, не так круто, как в динамике выгрузить домен,
но зато насколько меньше возни. Вот Студия же работает именно так.
Ну а если ваши плагины способны нарушить работу процесса на уровне ОС, то ляжет весь
процесс приложения вместе с CLR и доменами.

Поэтому с MAF я бы не связывался. Что до остального, могу посоветовать Mono.Addins.
По возможностям превосходит MEF. Документация есть, но не исчерпывающая. Примеров маловато.
Также есть система ICSharpCode.Core, используемая в SharpDevelop, она тоже мощная,
есть исходники (сам шарпдевелоп). Но документации почти нет, и она сильно устарела.

Что значат операторы @ и ^ в Делфи?

#delphi #указатели

Что значат операторы @ и ^ ?? Так же хочется узнать, что будет в Pkts если Psh[4, 1] = ?

Blocks = 4; 
RTParts = 2; 
BlNum, ROTO: integer
mkts = array [0..3, 1..6, 1..16] of SmallInt;
msh = array[1..392] of SmallInt;
TPmkts = ^mkts;
TPmsh = ^msh;
Pkts: array[1..Blocks, 1..RTParts] of TPmkts = ( (nil, nil), (nil, nil), (nil, nil),
(nil, nil) );
Psh: array[1..Blocks, 1..RTParts] of TPmsh = ( (nil, nil), (nil, nil), (nil, nil),
(nil, nil) );

Pkts[Num, ROTO]:= @Psh[Num, ROTO]^[9];

    

Ответы

Ответ 1

Оператор @ обозначает взятие адреса переменной (получение указателя на переменную)

Оператор ^ в коде обозначает разыменование указателя и получение значения переменной.

Оператор ^ при объявлении типа обозначает использование указателя. Например PPoint
= ^TPoint обозначает, что объект типа PPoint будет указателем на объект типа TPoint.

Эти операторы дополняют друг друга.

var
  a: integer;
  b: pointer;
begin
  a := 123;

  // теперь b указывает на a
  b := @a; 

  // приводим указатель к конкретному типу и записываем в адрес,
  // на который указывает b - новое значение 120
  // теперь a будет 120
  PInteger(b)^ := 120; 
end;





  что будет в Pkts если Psh[4, 1] = 230 ?

Pkts[4, 1]:= @Psh[4, 1]^[9];



В Pkts[4,1] будет элемент со смещением 9 от Psh[4,1].

Давайте разберем по шагам, мы получаем адрес переменной Psh[4,1], тут же его разыменовываем
обратно в переменную, и от этой переменной берем [9] элемент (то есть похоже что это
строка или другой массив).

Обратите внимание, что подобный код не скомпилируется в Делфи, т.к. не указан разыменуемый
тип @Psh[4, 1].

Почему при дробных значениях алгоритм не работает?

#delphi #алгоритм #pascal #delphi_7

Задача следующая:


  Ввести целое число a и вывести сумму квадратов всех чисел от 1 до a с шагом 0.1.
(1^2+1.1^2+1.2^2+...+a^2)


Алгоритм решения такой:

result := 0
while (a >= 1) do begin
    result := result + a * a;
    a := a - 0.1;
end;


В конце работы программы результат должен быть:

При a = 1.1 result = 2.21
При a = 3 result = 91.7


Переменная a, в любом случае, при завершении программы должна быть равна 0.9.

Проблема в следующем. При a = 1.1 все верно, но начиная с 1.2 и далее программа выдает
в результате на 1 меньше, чем нужно: a = 3; result = 90.7, при этом, в конце выполнения
программы, a = 0.9(9).

Если модифицировать алгоритм: переменную a после ввода умножать на 10, а затем в
цикле в квадрат возводить не ее, а выражение a / 10, то все начинает работать правильно
(второй строкой в цикле здесь будет: a := a - 1).

В чем может быть проблема?
    

Ответы

Ответ 1

Проблема в том, что числа представлены в двоичном виде. Десятичное значение 0,1 не
может быть представлено в двоичном виде конечной дробью, оно равно 0,0001100110011...2
или 0,0(0011)2 в стандартной записи рациональных дробей.

У чисел с плавающей точкой с двойной точностью хранится 53 двоичных знака после запятой,
бесконечная часть дроби отбрасывается. В результате вместо точного значения 0,1 мы
имеем число 0,1000000000000000055511151231257827021181583404541015625. Если вы выведете
его на печать с не очень большой точностью, вы получите 0,1, но это только результат
округления. При округлении до 17-го знака получается 0,100000000000000001, и последний
знак участвует в вычислениях. Поэтому, два раза вычитая из 1,2 значение 0,1, вы получаете
число меньшее 1.

Простого решения подобных проблем на все случаи жизни не существует. Простейшим в
вашем случае будет эмуляция чисел с фиксированной запятой, например так, как вы и сделали.

Можно упростить вычисления, посчитав суммы квадратов целых чисел, и разделив результат
на 100:

a2 + (a + 0.1)2 + (a + 0.2)2 + ... =

(10a)2/100 + (10a + 1)2/100 + (10a + 2)2/100 + ...

Можно использовать библиотеки, которые обеспечивают работу с рациональными числами,
с числами в десятичной системе счисления (как тип decimal в C#), или с числами большой
точности.

Есть ли встроенные процедуры сортировок в Delphi?

#delphi #delphi_7

Нужно сделать прогу, которая бы сортировала список по определённому полю. Но писать
самому сортировку лень. Есть ли встроенные процедуры в Delphi?
    

Ответы

Ответ 1

В Delphi есть TList который может хранить произвольные типы данных и позволяет их
сортировать. Метод TList.Sort(), в качестве аргумента принимает вашу функцию сортировки.
Сортировка списка проводится внутри TList (используется QuickSort), но каждая пара
элементов сравнивается, вызывая функцию, которую вы указали для этого метода.

Минимальный пример, который показывает как можно отсортировать список по тому или
иному полю, просто подставив нужную функцию сортировки:

uses
  Classes,
  SysUtils;

type
  TListItem = record
    F1: string;
    F2: Integer;
  end;
  PListItem = ^TListItem;

function CompareByF1(Item1, Item2: Pointer): Integer;
begin
   Result := CompareText(PListItem(Item1).F1, PListItem(Item2).F1);
end;

function CompareByF2(Item1, Item2: Pointer): Integer;
begin
   Result := PListItem(Item1).F2 - PListItem(Item2).F2;
end;

procedure Test;
var
  I: Integer;
  VList: TList;
  VTestItem: PListItem;
begin
  VList := TList.Create;
  try
    try
      // заполнение списка данными
      for I := 9 downto 0 do begin
        New(VTestItem); // динамическое выделение памяти для элемента списка
        VTestItem.F1 := 'TestStr#' + IntToStr(I);
        VTestItem.F2 := I;
        VList.Add(VTestItem);
      end;

      // тестовая перчать списка ДО сортировки
      for I := 0 to VList.Count - 1 do begin
        Writeln(PListItem(VList.Items[I]).F1);
      end;
      Writeln;

      VList.Sort(CompareByF2); // сортировка по нужному нам полю

      // тестовая перчать списка ПОСЛЕ сортировки
      for I := 0 to VList.Count - 1 do begin
        Writeln(PListItem(VList.Items[I]).F1);
      end;
    finally
      for I := 0 to VList.Count - 1 do begin
        Dispose(VList.Items[I]); // освобождение ранее выделенной памяти
      end;
    end;
  finally
    VList.Free;
  end;
end;


А вот тут: How do I sort a generic list using a custom comparer? есть пример, как
сортировать список, в версиях Delphi с поддержкой дженериков.

Утечка памяти в TObjectList

#delphi

Не могу найти решение для устранении утечки.



type
  TMyObj = class
  Caption: string;
  Description: string;
  Params:string;
  ParamsLst: TStringList;

public
  constructor Create(const aPath: string; const aParams: TStrings); overload;
  destructor Destroy(); override;
end;

TDataList = class(TObjectList)
public
  constructor Create;
  // function LoadFromINI(IniFile: TMemIniFile): boolean;
  function Remove(Obj: TMyObj): Integer;
end;

var
  TObjData: TDataList;

implementation

constructor TMyObj.Create(const aPath: string; const aParams: TStrings);
begin
  Caption := aParams.Values['Caption'];
  Description := aParams.Values['Description'];
  Params := aParams.Values['Params'];
  if aParams.Values['Params'] <> '' then
  begin
    ParamsLst := TStringList.Create;
    try
      ExtractStrings([';', ','], [' '], PChar(Params), ParamsLst);
    except
      ParamsLst := nil;
    end;
  end;
end;

destructor TMyObj.Destroy;
begin
  ParamsLst.Free;
  inherited;
end;

constructor TDataList.Create;
begin
  inherited Create;
  OwnsObjects := True;
end;

function TDataList.Remove(Obj: TMyObj): Integer;
begin
  Result := inherited Remove(Obj);
end;

initialization
TObjData := TDataList.Create;

finalization
TObjData.Free;


заполнение TObjData, так

    TObjData.Add(TMyObj.Create(sVal, SecParams));

    

Ответы

Ответ 1

Что касается исключения - точное место создания объекта, который не уничтожился 
может показать FastMM или EurekaLog. Приведенный код рабочий и в большинстве случаев
все правильно освобождается. (Нюансы описал ниже.) Скорее всего вы создается TreeList
и его не уничтожаете (либо ждете что его уничтожит родительский объект, а он не назначен).

Остальные нюансы:

Может я что то упустил, но я не вижу откуда берутся данные для заполнения SecParams.


Если вы до момента добавления создали SecParams - его нужно уничтожить. Иначе будет
утечка. 

TObjData.Add(TMyObj.Create(sVal, SecParams));

Второй участок try..except. При возникновении исключения - объект все же не уничтожится. 

ParamsLst := TStringList.Create;
try
  ExtractStrings([';', ','], [' '], PChar(Params), ParamsLst);
except
  ParamsLst := nil; // 
end;



Хотя тоже не ясно, ну не обработались параметры, значит они в неправильном формате
- объект создастся, но с пустым параметром ParamsLst. И если к нему обратится без проверки
- будет Access Violation.


TObjData - есть общие правила когда с буквы T начинаются описания типов. F - для
внутренних полей класса.

var
  TObjData: TDataList;

Для полей класса TMyObj нужно явно указать идентификатор видимости (private, public),
а еще лучше перенести их в секцию private и дать доступ к полям с помощью свойств.
Например:

type
  TMyObj = class
    FCaption: string;
  public
    ...
    property Caption: string read FCaption;
  end;

TMyObj  - название класса должно описывать объект. (Например: TPerson)


Ответ 2

В коде нет ни одного момента заполнения переменной со странным именем TObjData. Но
могу предположить, что OwnsObjects не правильно срабатывает.
В финализации перед разрушением объекта TObjData лучше сделать цикл проверки вложенных
в него объектов и выяснения по какой причине они не освобождаются до финализации.


Ответ 3

Код с учетом замечаний и предложений......

type
  TData = class
  private
    FCaption: string;
    FDescription: string;
    FParams: string;
    FParamsLst: TStringList;
    //....
  public
    constructor Create(const aPath: string; const aParams: TStrings);
    destructor Destroy(); override;
    property Caption: string read FCaption;
    property Description: string read FDescription;
    property Params: string read FParams;
    property ParamsLst: TStringList read FParamsLst;
    //...
  end;

  TDataList = class(TObjectList)
  private
   //...
  public
    constructor Create;
    destructor Destroy(); override;
  property
    //...
  end;

var
  DataList: TDataList;

implementation

{ TData }
constructor TData.Create(const sPath: string; const sData: TStrings);
begin
  Caption := aParams.Values['..'];
  Description := aParams.Values['..'];
  Params := aParams.Values['..'];
  if aParams.Values['..'] <> '' then
  begin
    ParamsLst := TStringList.Create;
    try
      ExtractStrings([','], [' '], PChar(Params), ParamsLst);
    except
      on E: Exception do
        ShowMessage(E.ClassName + ': ' + E.Message);
    end;
  end;
end;

destructor TData.Destroy;
begin
  inherited;
end; { end TData }

{ DataList }
constructor TDataList.Create;
begin
  inherited Create;
  OwnsObjects := True;
end;

destructor TDataList.Destroy;
begin
  inherited;
end; { end DataList }


Решение, проблемы
    ......

procedure TMain.FormDestroy(Sender: TObject);
var
  I: Integer;
begin
  // Удаление списков в объекте
  for i := 0 to DataList.Count - 1 do
  begin
    with DataList.Items[i] do
    begin
      ParamsLst.Free;
    end;
  end;
// При удалении списка оставшиеся в нём объекты будут удалены.
  FreeAndNil(DataList);
end;

Как узнать, применяется ли схемы оформления (Vcl.Styles)?

#delphi #vcl

D 10.1 starter. Стандартное приложение. В опциях включены схемы оформления.
Вопрос: Как программно узнать, применяется ли сейчас какая-то схема оформления или
стиль оформления стандартный?

если схема применяется, то в файле проекта видим (например):

...
TStyleManager.TrySetStyle('Amethyst Kamri'); *
...


если в опциях проекта схемы выбраны, но дефолтное оформление выбрано "Windows", то
в проекте ничего (*) такого нет 

Нужна функция примерно такая

Function IsAppThemed:boolean;
begin
 Result := <..?..>
end;

    

Ответы

Ответ 1

Нашел:

function IsAppThemed: Boolean;
begin
  Result := TStyleManager.Enabled and TStyleManager.IsCustomStyleActive;
end;

Можно ли в Delphi, вызвать функцию по имени, которое хранится в строке?

#delphi

Есть строка, которая может принимать разные значения, 

можно ли вызвать функцию, имя которой, равно значению строки,

а если, допустим, такой функции нет, то ничего не произойдет

Что бы не использовать много раз if str = 'myfunc' then myfunc(a);
    

Ответы

Ответ 1

как следует из комментариев, от того, что у вас используется классовая функция, ничего
особо не меняется (при использовании RTTI для решения задачи)

type
  TTest = class(TObject)
    public
      class function myFunc(x : integer): integer;
  end;


class function TTest.myFunc(x: integer): integer;
begin
    result := x*100;
end;


метод TRttiMethod.invoke() имеет несколько перегруженных вараинтов, и может принимать
как экземпляр класса так и мета-класс (class of ..).

function invokeClassFunction(cls: TClass; funcName: string; args: array of TValue):
TValue;
var
    ctx: TRttiContext;
    t: TRttiType;
    m: TRttiMethod;
begin
    ctx := TRttiContext.Create();
    try
        t := ctx.GetType(cls);
        m := t.GetMethod(funcName);
        if (m = nil) then
            raise Exception.Create('Method not found');

        result := m.Invoke(cls, args);
    finally
        ctx.Free();
    end;
end;


Поэтому при вызове вы просто указываете нужный класс:

var r : TValue;

try
    r := invokeClassFunction(TTest, 'myFunc', [1]);
    writeln('result: ', r.AsInteger);
except
    on e: Exception do
        writeln('ничего не проиозошло');
end;

Вызов диалога “Обзор папок”

#delphi #delphi_7

Как вызвать точно такое же окно выбора папки?

Использовал эту функцию:

var
  chosenDirectory: string;

SelectDirectory('Выберите папку', '', chosenDirectory);


Как сюда добавить кнопку создания папки?


    

Ответы

Ответ 1

Для Delphi 7 находится вот такое (не очень красивое) решение:

uses ShlObj, ActiveX;

//global variables
var
  lg_StartFolder: String;


//functions
//no need to declare these anywhere at the top of the unit
function BrowseForFolderCallBack(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM):
Integer stdcall;
begin
  if uMsg = BFFM_INITIALIZED then
     SendMessage(Wnd,BFFM_SETSELECTION, 1, Integer(@lg_StartFolder[1]));
  result := 0;
end;

function BrowseForFolder(const browseTitle: String; const initialFolder: String =''):
String;
var
  browse_info: TBrowseInfo;
  folder: array[0..MAX_PATH] of char;
  find_context: PItemIDList;
begin
  FillChar(browse_info, SizeOf(browse_info), #0);
  lg_StartFolder := initialFolder;
  browse_info.pszDisplayName := @folder[0];
  browse_info.lpszTitle := PChar(browseTitle);
  browse_info.ulFlags := BIF_RETURNONLYFSDIRS or BIF_EDITBOX or $40;
  browse_info.hwndOwner := Application.Handle;

  if initialFolder <> '' then
     browse_info.lpfn := BrowseForFolderCallBack;
  find_context := SHBrowseForFolder(browse_info);
  if Assigned(find_context) then
  begin
    if SHGetPathFromIDList(find_context,folder) then
      result := folder
    else
      result := '';
    GlobalFreePtr(find_context);
  end
  else
    result := '';
end;


Пример использования:

procedure TForm4.Button3Click(Sender: TObject);
begin
   BrowseForFolder('Select Dir', 'C:\');
end;


Ответ 2

не уверен на счет Delphi-7, но в более поздних версиях можно было использовать класс
StdActns.TBrowseForFolder:

procedure TForm1.ChooseDirButtonClick(Sender: TObject);
var bff : TBrowseForFolder;
begin
    bff := TBrowseForFolder.create(nil);
    try
        bff.Caption := 'Выберите папку';
        bff.BrowseOptions :=  [bifNewDialogStyle];

        if bff.Execute() then begin
            if bff.Folder <> '' then
                showMessage(bff.Folder);
        end;
    finally
        bff.Free();
    end;
end;


Ответ 3

Как минимум, начиная с Delphi 2007 (про Delphi 7 не уверен), в юните FileCtrl есть
функция SelectDirectory, которая имеет вот такое описание:

function SelectDirectory(
  const Caption: string; 
  const Root: WideString;
  var Directory: string; 
  Options: TSelectDirExtOpts = [sdNewUI]; 
  Parent: TWinControl = nil
): Boolean; overload;


Соответственно, передав опцию sdNewFolder в параметре Options можно добиться того,
что вам нужно:

uses
  FileCtrl;
...

if SelectDirectory('Выберите папку', '', chosenDirectory, [sdNewFolder, sdNewUI,
sdShowEdit, sdShowShares]) then begin
  ...
end;

Синхронизация между объектами Workflow

#delphi #классы #связи #workflow #биоинформатика

Создаю универсальный workflow для обработки наших геномных данных. Для этого пишется
более или менее стандартный в нашей среде workflow, что-то вроде такого:



Каждая панель на рисунке - отдельный экземпляр определенного класса (наследника TShape,
но не думаю, что это важно) со своими методами, графические и математические проблемы
вроде более-менее решены.
У каждого класса есть хотя бы один метод ввода или вывода (бывает, и по нескольку),
формат данных на входе и на выходе у разных классов - разные. Одному, условно говоря,
нужен массив строк, другому - просто строка, третий выдает самостоятельные массивы
строк и массивы целых и  т.п.   

Поэтому первый вопрос - как проверять соответствие типов данных? Вот хочу я сделать
связь между двумя экземплярами на рисунке, а вдруг нельзя! Либо совсем нельзя, либо
нужен еще посредник (конвертор или обработчик). Ничего иного не придумал, кроме как
ввести единый энумератор, в котором прописать все возможные варианты типов данных и
запрашивать у экземпляров, которые хочу связать, совпадают ли у них типы ввод-вывод
по энумератору или нет. Или можно проще придумать способ?

Второй момент. Если использовать TMemoryStream для обмена данными, то как я должен
обрабатывать такие ситуации:


вывод в Stream экземпляром-донором начат. Нужно сообщить экземпляру-акцептору, что
можно начинать обрабатывать данные. Как? Создать поток акцептора уснувшим, а затем
Resume?  
Экземпляр-акцептор обрабатывает данные быстрее, чем их записывает в Stream экземпляр-донор.
Через что разумнее обработать эту ситуацию? Через CriticalSection?

    

Ответы

Ответ 1

По первому вопросу: нормальное решение.

По второму вопросу: Для синхронизации работы потоков придумано много разных объектов
синхронизации, в том числе и события (TEvent) и критические секции (TCriticalSection).
Делать потоку Resume - это не по феншую. Чтобы передавать данные через TMemoryStream
между потоками и одновременно читать и писать, его нужно сделать потокобезопасным (добавить
в него критическую секцию). Возможно, для этой задачи лучше подойдет использование
каналов (pipe), но мне пока не доводилось с ними работать и я про них мало чего знаю. 

Итак, наш наследник от TMemoryStream:

  TMyCustomMemoryStream = class(TMemoryStream)
  private
    FLock: TCriticalSection;
    FCanReadUpTo: Int64;
    FAllDataWritten: Boolean;
  protected
    function GetSize: Int64; override;
    procedure SetSize(const NewSize: Int64); override;
  public
    constructor Create;
    destructor Destroy; override;

    property Lock: TCriticalSection read FLock;
    property CanReadUpTo: Int64 read FCanReadUpTo write FCanReadUpTo;
    property AllDataWritten: Boolean read FAllDataWritten write FAllDataWritten;
  end;

{ TMyCustomMemoryStream }

constructor TMyCustomMemoryStream.Create;
begin
  inherited Create;

  FLock := TCriticalSection.Create;
end;

destructor TMyCustomMemoryStream.Destroy;
begin
  FLock.Free;

  inherited Destroy;
end;

function TMyCustomMemoryStream.GetSize: Int64;
begin
  FLock.Acquire;
  try
    Result := inherited GetSize;
  finally
    FLock.Release;
  end;
end;

procedure TMyCustomMemoryStream.SetSize(const NewSize: Int64);
begin
  FLock.Acquire;
  try
    inherited SetSize(NewSize);
  finally
    FLock.Release;
  end;
end;


Lock - критическая секция для доступа к данным. Как-то так:

var
DataStream: TMyCustomMemoryStream;

DataStream.Lock.Acquire;
try
  DataStream.Position := 0;
  DataStream.Write(...);
  DataStream.AllDataWritten := True;
finally
  DataStream.Lock.Release;
end;


Чтобы другой поток мог читать данные, нужно периодически отпускать критическую секцию,
а не писать все за один заход.

Не забываем, что Position, после Lock.Release может быть совсем не таким, как мы
ожидаем, так что его нужно будет запоминать в контексте каждого потока и устанавливать
каждый раз в нужное место при записи или чтении.

Теперь поток. который читает данные:

  TCustomThread= class(TThread)
  private
    FTerminatedEvent: TEvent;
    FCanReadData: TEvent;
    FData: TMyCustomMemoryStream;
    procedure DoReadData;
    function CheckAndWaitNewData(BytesReaded: Int64): Boolean;
    procedure ClearData;
  protected
    procedure Execute; override;
    procedure TerminatedSet; override;
  public
    constructor Create;
    destructor Destroy; override;
    procedure ReadData(Data: TMyCustomMemoryStream);
  end;

{ TCustomThread }

constructor TCustomThread.Create;
begin
  inherited Create(False);

  FTerminatedEvent := TEvent.Create(nil, True, False, '');
  FCanReadData := TEvent.Create(nil, True, False, '');
end;

destructor TCustomThread.Destroy;
begin
  Terminate;
  if not Suspended then
    WaitFor;

  ClearData;

  FTerminatedEvent.Free;
  FCanReadData.Free;

  inherited Destroy;
end;

procedure TCustomThread.ClearData;
begin
  FCanReadData.ResetEvent;
  FreeAndNil(FData);
end;

procedure TCustomThread.DoReadData;
var
  DataPosition: Int64;
  CountToRead: Int64;
begin
  DataPosition := 0;

  while CheckAndWaitNewData(DataPosition) do
  begin
    // read new data
    FData.Lock.Acquire;
    try
      CountToRead := FData.Size - DataPosition;
      FData.Position := DataPosition;
      DataPosition := DataPosition + FData.Read(Buffer, CountToRead);
    finally
      FData.Lock.Release;
    end;

    // process new data
    // ...
  end;

  // all data readed
  ClearData;
end;

function TCustomThread.CheckAndWaitNewData(BytesReaded: Int64): Boolean;
begin
  // returns True on data available or False on AllDataWritten
  Result := FData.Size > BytesReaded;
  while not Result and not FData.AllDataWritten do
  begin
    // wait for 100 ms to check data available again
    if FTerminatedEvent.WaitFor(100) <> wrTimeout then
      Abort;

    Result := FData.Size > BytesReaded;
  end;
end;

procedure TCustomThread.Execute;
var
  WOHA: TWOHandleArray;
begin
  WOHA[0] := FCanReadData.Handle;
  WOHA[1] := FTerminatedEvent.Handle;

  try
    while not Terminated do
    begin
      if WaitForMultipleObjects(2, @WOHA, False, INFINITE) = WAIT_OBJECT_0 then
        DoReadData
      else
        Exit;
    end;
  except
    on EAbort do
      Exit;
  end;
end;

procedure TCustomThread.ReadData(Data: TMyCustomMemoryStream);
begin
  if Assigned(FData) then
    raise Exception.Create('Thread is busy!');

  FData := Data;
  FCanReadData.SetEvent;
end;

procedure TCustomThread.TerminatedSet;
begin
  inherited TerminatedSet;

  FTerminatedEvent.SetEvent;
end;


Предполагается, что поток, читающий данные, ответственен за уничтожение потока данных
(возможно не лучшее решение). Поток создается и ожидает события для начала чтения FCanReadData
или события, сигнализирующего о необходимости завершения работы потока FTerminatedEvent.
Метод Execute можно модифицировать, если нужно делать еще какую-то работу, тогда ожидание
должно быть не бесконечным либо вообще нулевым. Чтение данных запускается вызовом метода
ReadData. Чтение данных продолжается до тех пор, пока не закончатся данные, после чего,
если в потоке данных не установлен признак AllDataWritten начинается ожидание поступления
новых данных с проверкой наличия новых данных каждые 100 мс. Если данные закончились
и установлен признак AllDataWritten, чтение данных прекращается и поток данных уничтожается.


Ответ 2

Да, пожалуй. У нас в пакетах, где используются workflow, у всех таких экземпляров
есть компонент-хозяин (потомок от TScrollBox с добавленным свойством Canvas), в обязанности
которого входят отрисовка всяких стрелочек, создание очереди, автораспределение по
поверхности и т.п., и в том числе хранение энумератора с типами данных, а также автосоздание
цепочки, если это возможно (Скажем, на входе SAM, а процессу нужны FASTA, тогда пользователю
автоматически предлагается создать экземпляр посредника).
Мы от потоков отказались, для нас это неудобно, используем собственные классы-контейнеры
для массивов. Поскольку не все алгоритмы могут работать с частичными данными, то каждый
экземпляр-акцептор имеет свойство в том же энумераторе, нужны ли ему данные полностью
или он может брать частично, и если второе - начиная с какого количества уже созданных
данных ему можно отсемафорить о начале работы. Поскольку акцепторы никогда не подходят
близко к адресам вновь создаваемых данных, критические секции не используются, акцепторы
предупреждаются через TEvent.
Но если нужен именно TMemoryStream, то @kot-da-vinci , на мой взгляд, очень хорошо
ответил.

Авторизация в Steam на Delphi

#delphi #rsa #steam #cryptoapi

Добрый день, есть желание из своей программы, написанной на Delphi, авторизоваться
в Steam.
Посмотрев исходники программы Steam Desktop Authenticator, пришел к выводу, что нам
нужно сделать 2 POST-запроса к серверу Steam, первый вернет нам модуль и экспоненту
открытого ключа RSA, которым мы должны зашифровать свой пароль и отправить его во втором
запросе. Решил попробовать реализовать это с помощью функций Microsoft CryptoAPI: Next
Generation.
Набросал функцию, которая на входе получает 3 строки: пароль от Стима, открытые модуль
и экспоненту в виде строк, состоящих из шестнадцатеричных символов (их нам присылает
сервер). На выходе должны получить пароль, зашифрованный открытым ключом по алгоритму
RSA и закодированный в BASE64.




    unit uRSA;

    interface
    uses WinAPI.Windows, System.SysUtils, VCL.Dialogs, System.NetEncoding;

    //БЛОБ открытого ключа RSA, описание структуры есть на MSDN
    type TPublicKeyBLOB = packed record
    Magic: ULONG;
    BitLength: ULONG;
    cbPublicExp: ULONG;
    cbModulus: ULONG;
    cbPrime1: ULONG;
    cbPrime2: ULONG;
    exponent: array[0..2] of byte;
    modulus: array[0..255] of byte;
    end;
    pPublicKeyBLOB = ^TPublicKeyBLOB;

    //прототипы функций из библиотеки BCRYPT.DLL
    TBCryptOpenAlgorithmProvider = function (phAlgorithm: pHandle; pszAlgId: LPCWSTR;
    pszImplementation: LPCWSTR; dwFlags: DWORD): ULONG; stdcall;
    //--
    TBCryptImportKeyPair = function (hAlgorithm: THandle; hImportKey: THandle; pszBlobType:
LPCWSTR;
    phKey: pHandle; pbInput: pPublicKeyBLOB; cbInput: ULONG; dwFlags: ULONG): ULONG;
stdcall;
    //--
    TBCryptEncrypt = function (hKey: THandle; pbInput: PUCHAR; cbInput: ULONG; pPaddingInfo:
POINTER;
    pbIV: PUCHAR; cbIV: ULONG; pbOutput: PUCHAR; cbOutput: ULONG; pcbResult: PULONG;
dwFlags: ULONG): ULONG; stdcall;
    //--
    TBCryptCloseAlgorithmProvider = function (hAlgorithm: THandle; dwFlags: ULONG):
ULONG; stdcall;

    //сама функция шифрования
    type TRSA = class
    public
    function RSA_Encrypt(DataStr: string; modulusStr: string; exponentStr:   string):
string;
    end;

    const
    BCRYPT_RSAPUBLIC_MAGIC = $31415352;  // RSA1
    BCRYPT_PAD_PKCS1 = $00000002;

    implementation

    function HexToByte(Str: string): Byte;
    begin
    result :=  Byte(StrToInt('$' + (Str)));
    end;

    function TRsa.RSA_Encrypt(DataStr: string; modulusStr: string; exponentStr: string):
string;
    var
    PublicKeyBLOB: TPublicKeyBlob;
    i: word;
    status: ULONG;
    hLib: THandle;
    hAlg: THandle;
    hKey: tHandle;
    Password: TBytes;
    EncryptedPassword: TBytes;
    EncryptedSize: ULONG;
    BCryptOpenAlgorithmProvider: TBCryptOpenAlgorithmProvider;
    BCryptImportKeyPair: TBCryptImportKeyPair;
    BCryptEncrypt: TBCryptEncrypt;
    BCryptCloseAlgorithmProvider: TBCryptCloseAlgorithmProvider;
    begin
    //преобразовываем входные данные в массив байтов;
    Password := TEncoding.ASCII.GetBytes(DataStr);
    hLib := LoadLibrary('BCRYPT.DLL');
    //загрузка функций из библиотеки
    //функция инициализации провайдера
    @BCryptOpenAlgorithmProvider := GetProcAddress(hLib, 'BCryptOpenAlgorithmProvider');
    //функция импорта ключа
    @BCryptImportKeyPair := GetProcAddress(hLib, 'BCryptImportKeyPair');
    //функция шифрования
    @BCryptEncrypt := GetProcAddress(hLib, 'BCryptEncrypt');
    //функция освобождения провайдера
    @BCryptCloseAlgorithmProvider := GetProcAddress(hLib, 'BCryptCloseAlgorithmProvider');
    //собираем ключ
    with PublicKeyBLOB do
    begin
    Magic := BCRYPT_RSAPUBLIC_MAGIC;  // RSA1;
    BitLength := SizeOf(Modulus)*8;//размер модуля в битах
    cbPublicExp := SizeOf(Exponent);//размер экспоненты в байтах
    cbModulus := SizeOf(Modulus);//размер модуля в байтах
    //(необязательно) проверим, что в переданных параметрах - четное количество символов
    if (length(exponentstr) mod 2)  0 then
    exponentstr := '0' + exponentstr;
    if (length(modulusstr) mod 2)  0 then
    modulusstr := '0' + modulusstr;
    for i := Low(exponent) to High(exponent) do
    exponent[i] := HexToByte(copy(exponentstr,i*2+1,2));
    for i := Low(modulus) to High(modulus) do
    modulus[i] := HexToByte(copy(modulusstr,i*2+1,2));
    end;
    //инициализация провайдера
    status := BCryptOpenAlgorithmProvider(@halg,'RSA',nil,0);
    //импорт ключа
    status := BCryptImportKeyPair(hAlg,0,'RSAPUBLICBLOB', @hKey, @PublicKeyBLOB,
    SizeOf(PublicKeyBLOB),0);
    //шифрование сообщения. Первый проход - получаем размер выходного буфера, второй
- шифруем текст
    status := BCryptEncrypt(hKey, @Password[0], Length(Password), nil, nil, 0, nil,
0, @EncryptedSize, BCRYPT_PAD_PKCS1);
    SetLength(EncryptedPassword,EncryptedSize);
    status := BCryptEncrypt(hKey, @Password[0], Length(Password), nil, nil, 0, @EncryptedPassword[0],
Length(EncryptedPassword), @EncryptedSize, BCRYPT_PAD_PKCS1);
    //кодируем зашифрованное сообщение в Base64
    Result := TNetEncoding.Base64.EncodeBytesToString(EncryptedPassword);
    //освобождаем память
    status := BCryptCloseAlgorithmProvider(hAlg,0);
    FreeLibrary(hLib);
    end;

    end.




Вроде бы все успешно отрабатывает, но, когда делаю POST-запрос с зашифрованным паролем
к серверу STEAM - получаю в ответ:
    {"success":false,"requires_twofactor":false,
   "message":"The account name or password that you have entered is incorrect.",
   "clear_password_field":true,"captcha_needed":false,"captcha_gid":-1}

На вход функции подаются строки в виде

   "publickey_mod":"c152954756c74aee68ca1e6ac77bc71af6a93660bd56f1517e8141436b8fda4e32cc123ced02c0421a6a8d505dd25d07c4df9a25cf682799ea87ceb0eeaef7c7e71a8a30ec6c60d4dcfa8006a193f0b99958655894147b13d4f15285f9d7dc75baaa61b1b12265a303324c6b5e648bb272d87e0003295ca124e6e7a8a5ec45b9d2f1399e3ffbd0d9aec012afe1fbe65bfc9bd4c2087e7b7a73d2f9286e311e77341113f4cbde9a2a94141252e395e36bc2bf135ef38be90458090d6cd2c419e293a5dcf93bff3df2ca641edfb38ff85f6c9f8864f2905015cf34bd35d74e324f4a6a156c2462cfdd1c1fafb15567047a59b188c9f2a4f78157f2ec120ce09b5d",
   "publickey_exp":"010001"


Буду очень признателен, если кто-нибудь укажет на ошибку или даст совет: как в Delphi
можно зашифровать сообщение, имея экспоненту и модуль открытого ключа RSA.
    

Ответы

Ответ 1

Проблема была в некорректной работе     

//кодируем зашифрованное сообщение в Base64
Result := TNetEncoding.Base64.EncodeBytesToString(EncryptedPassword);


Эта функция не убирает переносы строки, так что придется получившийся результат обработать
дополнительно:

//кодируем зашифрованное сообщение в Base64
Result := TNetEncoding.Base64.EncodeBytesToString(EncryptedPassword);
//удалим переносы строки
Result := StringReplace(Result, #13#10, '',[rfReplaceAll]);


Либо же можно использовать аналогичную функцию из пакета Indy, которая работает верно:

uses IdCoderMIME, idcoder, idglobal;
...
function MyFunc(): string;
var
Temp: TIdBytes;
begin
...
Result := TIdEncoderMIME.EncodeBytes(Temp);
end;




Рабочий код :

unit uRSA;

interface
uses WinAPI.Windows, System.SysUtils, VCL.Dialogs, System.NetEncoding;

//БЛОБ открытого ключа RSA, описание структуры есть на MSDN
type TPublicKeyBLOB = packed record
Magic: ULONG;
BitLength: ULONG;
cbPublicExp: ULONG;
cbModulus: ULONG;
cbPrime1: ULONG;
cbPrime2: ULONG;
exponent: array[0..2] of byte;
modulus: array[0..255] of byte;
end;
pPublicKeyBLOB = ^TPublicKeyBLOB;

//прототипы функций из библиотеки BCRYPT.DLL
TBCryptOpenAlgorithmProvider = function (phAlgorithm: pHandle; pszAlgId: LPCWSTR;
pszImplementation: LPCWSTR; dwFlags: DWORD): ULONG; stdcall;
//--
TBCryptImportKeyPair = function (hAlgorithm: THandle; hImportKey: THandle; pszBlobType:
LPCWSTR;
phKey: pHandle; pbInput: pPublicKeyBLOB; cbInput: ULONG; dwFlags: ULONG): ULONG; stdcall;
//--
TBCryptEncrypt = function (hKey: THandle; pbInput: PUCHAR; cbInput: ULONG; pPaddingInfo:
POINTER;
pbIV: PUCHAR; cbIV: ULONG; pbOutput: PUCHAR; cbOutput: ULONG; pcbResult: PULONG;
dwFlags: ULONG): ULONG; stdcall;
//--
TBCryptCloseAlgorithmProvider = function (hAlgorithm: THandle; dwFlags: ULONG): ULONG;
stdcall;

//сама функция шифрования
type TRSA = class
public
function Encrypt(DataStr: string; modulusStr: string; exponentStr:   string): string;
end;

const
BCRYPT_RSAPUBLIC_MAGIC = $31415352;  // RSA1
BCRYPT_PAD_PKCS1 = $00000002;
BCRYPT_RSA_ALGORITHM = 'RSA';
BCRYPT_RSAPUBLIC_BLOB = 'RSAPUBLICBLOB';

implementation

function HexToByte(Str: string): Byte;
begin
result :=  Byte(StrToInt('$' + (Str)));
end;

function TRsa.Encrypt(DataStr: string; modulusStr: string; exponentStr: string): string;
var
PublicKeyBLOB: TPublicKeyBlob;
i: word;
status: ULONG;
hLib: THandle;
hAlg: THandle;
hKey: tHandle;
Password: TBytes;
EncryptedPassword: TBytes;
EncryptedSize: ULONG;
BCryptOpenAlgorithmProvider: TBCryptOpenAlgorithmProvider;
BCryptImportKeyPair: TBCryptImportKeyPair;
BCryptEncrypt: TBCryptEncrypt;
BCryptCloseAlgorithmProvider: TBCryptCloseAlgorithmProvider;
begin
//преобразовываем входные данные в массив байтов;
Password := TEncoding.ASCII.GetBytes(DataStr);
hLib := LoadLibrary('BCRYPT.DLL');
if hLib < 32 then
begin
 ShowMessage('Error while loading BCRYPT.DLL!');
 exit;
end;
//загрузка функций из библиотеки
//функция инициализации провайдера
@BCryptOpenAlgorithmProvider := GetProcAddress(hLib, 'BCryptOpenAlgorithmProvider');
//функция импорта ключа
@BCryptImportKeyPair := GetProcAddress(hLib, 'BCryptImportKeyPair');
//функция шифрования
@BCryptEncrypt := GetProcAddress(hLib, 'BCryptEncrypt');
//функция освобождения провайдера
@BCryptCloseAlgorithmProvider := GetProcAddress(hLib, 'BCryptCloseAlgorithmProvider');
//собираем ключ
with PublicKeyBLOB do
begin
Magic := BCRYPT_RSAPUBLIC_MAGIC;  // RSA1;
BitLength := SizeOf(Modulus)*8;//размер модуля в битах
cbPublicExp := SizeOf(Exponent);//размер экспоненты в байтах
cbModulus := SizeOf(Modulus);//размер модуля в байтах
//(необязательно) проверим, что в переданных параметрах - четное количество символов
if (length(exponentstr) mod 2) <> 0 then
exponentstr := '0' + exponentstr;
if (length(modulusstr) mod 2) <> 0 then
modulusstr := '0' + modulusstr;
for i := Low(exponent) to High(exponent) do
exponent[i] := HexToByte(copy(exponentstr,i*2+1,2));
for i := Low(modulus) to High(modulus) do
modulus[i] := HexToByte(copy(modulusstr,i*2+1,2));
end;
//инициализация провайдера
status := BCryptOpenAlgorithmProvider(@halg,BCRYPT_RSA_ALGORITHM,nil,0);
if status <> 0 then
begin
ShowMessage('BCryptOpenAlgorithmProvider error, status: ' + IntToStr(status)  + ',
' + SysErrorMessage(GetLastError()));
exit;
end;
//импорт ключа
status := BCryptImportKeyPair(hAlg,0,BCRYPT_RSAPUBLIC_BLOB, @hKey, @PublicKeyBLOB,
SizeOf(PublicKeyBLOB),0);
if status <> 0 then
begin
ShowMessage('BCryptImportKeyPair error, status: ' + IntToStr(status) + ', ' + SysErrorMessage(GetLastError()));
exit;
end;
//шифрование сообщения. Первый проход - получаем размер выходного буфера, второй
- шифруем текст
status := BCryptEncrypt(hKey, @Password[0], Length(Password), nil, nil, 0, nil, 0,
@EncryptedSize, BCRYPT_PAD_PKCS1);
if status <> 0 then
begin
ShowMessage('BCryptEncrypt error 1, status: ' + IntToStr(status) + ', ' + SysErrorMessage(GetLastError()));
exit;
end;
SetLength(EncryptedPassword,EncryptedSize);
status := BCryptEncrypt(hKey, @Password[0], Length(Password), nil, nil, 0, @EncryptedPassword[0],
Length(EncryptedPassword), @EncryptedSize, BCRYPT_PAD_PKCS1);
if status <> 0 then
begin
ShowMessage('BCryptEncrypt error 2, status: ' + IntToStr(status) + ', ' + SysErrorMessage(GetLastError()));
exit;
end;
//освобождаем занятые ресурсы
status := BCryptCloseAlgorithmProvider(hAlg,0);
if status <> 0 then
begin
ShowMessage('BCryptCloseAlgorithmProvider error, status: ' + IntToStr(status) + SysErrorMessage(GetLastError()));
exit;
end;
//кодируем зашифрованное сообщение в Base64
Result := TNetEncoding.Base64.EncodeBytesToString(EncryptedPassword);
//удалим переносы строки
Result := StringReplace(Result, #13#10, '',[rfReplaceAll]);
//выгружаем библиотеку
FreeLibrary(hLib);
end;

end.


На вход функции подаются строки в виде:


  "publickey_mod":"c152954756c74aee68ca1e6ac77bc71af6a93660bd56f1517e8141436b8fda4e32cc123ced02c0421a6a8d505dd25d07c4df9a25cf682799ea87ceb0eeaef7c7e71a8a30ec6c60d4dcfa8006a193f0b99958655894147b13d4f15285f9d7dc75baaa61b1b12265a303324c6b5e648bb272d87e0003295ca124e6e7a8a5ec45b9d2f1399e3ffbd0d9aec012afe1fbe65bfc9bd4c2087e7b7a73d2f9286e311e77341113f4cbde9a2a94141252e395e36bc2bf135ef38be90458090d6cd2c419e293a5dcf93bff3df2ca641edfb38ff85f6c9f8864f2905015cf34bd35d74e324f4a6a156c2462cfdd1c1fafb15567047a59b188c9f2a4f78157f2ec120ce09b5d",
  "publickey_exp":"010001"

Как правильно задать тип chart-а c помощью delphi

#delphi #excel #vba #chart #диаграммы

Есть часть кода на Delphi:  

chart:=sheet.chartobjects.add(270,205,397,220);
chart.chart.charttype:=4;
chart.Chart.SetSourceData(Sheet.Range['A3:B34']);


который выводит в Excel график (диаграмму):



Мне нужен другой тип графика, через макрос (excel-vba) он выглядит так:  

ActiveSheet.Shapes.AddChart2(332, xlLineMarkersStacked).Select


Вопрос: какой код на Delphi должен выполняться вместо этой строчки, чтоб он вывел
мне вот такой тип графика:

 
    

Ответы

Ответ 1

Вам достаточно заменить 

chart.chart.charttype:=4;


на

chart.chart.charttype:=66; // xlLineMarkersStacked = 66


чтобы сменить тип диаграммы на нужный.

Если часто приходится использовать построение диаграмм в Excel внутри Delphi-программ,
стоит завести модуль, где будут перечислены основные константы. Вот все константы энумерации
для диаграмм Excel, скопируйте их в новый юнит, оформите как const и вам проще будет
транслировать макросы Excel в код Delphi.

Как размеры минимального и максимального стека влияют на скорость обработки данных?

#delphi

У меня по большей части - обработка текстовой информации, чтение, запись.

По умолчанию, в настройках проекта стоят такие размеры:

Maximum Stack Size - 1048576
Minimum Stack Size - 16384


Если изменения влияют на скорость то какие параметры - должны быть (в большую или
меньшую сторону). И что от чего зависит ? 
    

Ответы

Ответ 1

Эти размеры практически никак не влияют на скорость работы.

Максимальный размер стека ограничивает место под локальные переменные.
Нужда в расширении этого места бывает редко, большие локальные статические массивы
данных обычно не используют.

От размера стека также зависит глубина рекурсии, которая может случиться. Однако,
если стек переполняется из-за рекурсии, нужно исправлять логическую ошибку, приводящую
к большой (скорее всего - неограниченной) глубине рекурсивных вызовов.

Лицензирование программы с привязкой к железу

#delphi #лицензирование

Есть моя программа, которую я хочу отдавать пользователям.
Программа читает зашифрованные мной файлы и выводит в нормальном виде пользователю.
Нужно сделать привязку к железу.
Мне интересен ход действий при лицензировании. Поделитесь опытом.
    

Ответы

Ответ 1

Информацию о железе можно получить через классы WMI.
Если делать привязку, то можно пользоваться серийным номером HDD и его моделью.
Полученные данные можно зашифровать, сохранить в файл, попросить пользователя отправить
 вложением по почте.
На основе этих данных можно сгенерировать ключ, прислать его пользователю. При регистрации
прописать в файл или в реестр.
При запуске программы проверять его наличие.
Если ключа нет, то программа не запускается, если ключ есть, то декодировать его,
узнать железо и сравнить с установленным.