INT 21h

Hi, I am Vladimir Smagin, SysAdmin and Kaptain. Telegram Email / GIT / RSS / GPG

Lazarus: клиент NTP и часовые пояса (NTP client and time zones)

№ 5710 В разделе Programming от November 27th, 2013,
В подшивках: ,

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

Качаем нашу самую любимую библиотеку для работы со всем сетевым Synapse и распаковываем lib в директорию своей программы (ну можно и переименовать, если не хотите кучу барахла всякого в одной директории). Подключаете директорию к проекту (делается в настройках проекта) и теперь можно писать код!

function get_ntp(): TDateTime;
var
  NTPClient: TSNTPSend;
  NTPResult, Belt: TDateTime;
begin
  with form1 do
  begin
    NTPClient := TSNTPSend.Create;
    NTPClient.TargetHost := Edit2.Text;
    NTPClient.GetNTP;
    NTPResult := NTPClient.NTPTime;
    if StrToInt(Edit3.Text) >= 0 then
    begin
      Belt := EncodeTime(StrToInt(Edit3.Text), 0, 0, 0);
      NTPResult := NTPResult + Belt;
    end
    else
    begin
      Belt := EncodeTime(abs(StrToInt(Edit3.Text)), 0, 0, 0);
      NTPResult := NTPResult - Belt;
    end;
  end;
  Result:=NTPResult;
end;

Этой функции ничего кормить не надо. Однако, это неправильно 🙂 Вы можете переписать ее, чтобы передавать ей 2 параметра: сервер (у меня Edit2.Text) и временной сдвиг (часовой пояс, Edit3.Text). После этого и with form1 do убрать можно будет 😉

Ну а потом эти значения можно использовать, например, так:

procedure TForm1.Button4Click(Sender: TObject);
begin
  ShowMessage(DateTimeToStr(get_ntp()));
end;

Или так:

var mydatetime: TDateTime;
...
 mydatetime:=get_ntp();
 ShowMessage(FormatDateTime('dd', mydatetime))+'.'+
    FormatDateTime('mm', mydatetime))+'.20'+
    FormatDateTime('yy', mydatetime)));

Рабочий код можно посмотреть в репозитории, который я вынес из 2 других схожих проектов https://git.blindage.org/21h/bluetooth-clock-sync.

ClockSync

Нет комментариев »

Lazarus: многопоточность в Linux и Windows

№ 4467 В разделе Programming от August 19th, 2012,
В подшивках: ,

Наверняка вы делаете не бесполезные программы и частенько они выполняют долгие операции. На столько долгие, что интерфейс замирает пока программу не “отпустит”. На помощь приходит многопоточность! Смысл в том, чтобы отделить долгоиграющую подпрограмму от основной программы и иногда синхронизировать потоки для обновления переменных или интерфейса. Именно это мне и пришлось сделать при доработке программы отправки команд на контроллер освещения через Bluetooth.

Демонстрация незамирающего окна:

Update (19.08.2012): В конце этой статьи есть дополнение о создании очередей и ожидании конца выполнения смежной задачи, а также видео для демонстрации.

У Windows и Linux разные способы работы с потоками, поэтому сначала придется наложить небольшой патч на файл проекта (например, myproject.lpr). По умолчанию uses выглядит так:

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Interfaces, // this includes the LCL widgetset

Нужно его изменить на такой вариант:

uses
  {$IFNDEF WIN32}
  {$DEFINE UseCThreads}
  {$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Interfaces, // this includes the LCL widgetset

Теперь можно создать класс нужного нам потока. В вашем любимом модуле сразу после uses добавьте описание нового класса:

Type
  TSerialThread = class(TThread)
  private
    fStatusText, fDataOut, fDataIn, fPortName, fStatus : String;
    fErrorCode : Integer;
    fStatusGet : Boolean;
    procedure Draw;
    procedure UpdateStatus;
  protected
    procedure Execute; override;
  public
    Constructor Create(CreateSuspended : boolean);
  end;

Чуть ниже идет определение глобальных переменных var. Добавьте в него SerThread : TSerialThread;.

Теперь нужно описать как работает новый класс. Согласно документации при создании класса можно определить некоторые параметры. Поскольку определять особо и нечего, то сделаем самый простой конструктор:

constructor TSerialThread.Create(CreateSuspended : boolean);
  begin
    FreeOnTerminate := True;
    inherited Create(CreateSuspended);
  end;

Одного конструктора мало. Должны быть функции обновления интерфейса программы:

procedure TSerialThread.Draw;
// Показать состояние устройства на форме
var
  state: integer;
begin
  //нарисовать ответ устройства на форме
  state := Hex2Dec(fStatus);
  if (odd(state shr 0)) then Form1.ToggleBox16.Checked := true else 
     Form1.ToggleBox16.Checked := false;
  if (odd(state shr 1)) then Form1.ToggleBox15.Checked := true else
     Form1.ToggleBox15.Checked := false;
  ...
  if (odd(state shr 14)) then Form1.ToggleBox2.Checked := true else 
     Form1.ToggleBox2.Checked := false;
  if (odd(state shr 15)) then Form1.ToggleBox1.Checked := true else 
     Form1.ToggleBox1.Checked := false;
  Form1.Timer1.Enabled:=True; //разрешить автоматическое получение 
     //состояния устройства каждые 10 секунд
  Form1.Button3.Enabled:=True; 
end; 

procedure TSerialThread.UpdateStatus;
//обновить статус в StatusBar
begin
  Form1.StatusBar1.SimpleText:=fStatusText;
end;

И, наконец, основная программа запускаемого потока:

procedure TSerialThread.Execute;
var
  ser: TBlockSerial;
  answer: String;
begin
  ser:=TBlockSerial.Create;
  try
    fStatusText := 'Инициализация порта ввода\вывода...';
    Synchronize(@UpdateStatus);
    ser.connect(fPortName);
    if ser.LastError>0 then
    begin
      fStatusText := ser.LastErrorDesc;
      Synchronize(@UpdateStatus);
      Exit;
    end;
    fStatusText := 'Подключение...';
    Synchronize(@UpdateStatus);
    ser.config(9600,8,'N',0,false,false);
    if ser.LastError>0 then
    begin
      fStatusText := ser.LastErrorDesc;
      Synchronize(@UpdateStatus);
      Exit;
    end;
    fStatusText := 'Посылка команды...';
    Synchronize(@UpdateStatus);
    ser.sendstring(fDataIn);
    if ser.LastError>0 then
    begin
      fStatusText := ser.LastErrorDesc;
      Synchronize(@UpdateStatus);
      Exit;
    end;
    fStatusText := 'Ожидание ответа...';
    Synchronize(@UpdateStatus);
    answer := ser.RecvTerminated(2000,#13);
    if ser.LastError>0 then
    begin
      fStatusText := ser.LastErrorDesc;
      Synchronize(@UpdateStatus);
      Exit;
    end;
    if fStatusGet then
    begin
      fStatusText := 'Ожидание информации о состоянии...';
      Synchronize(@UpdateStatus);
      fStatus := ser.RecvTerminated(2000,#13);
      fStatus := ExtractWord(2, fStatus, StdWordDelims);
      if ser.LastError>0 then
        begin
          fStatusText := ser.LastErrorDesc;
          Synchronize(@UpdateStatus);
          Exit;
        end;
      if fStatus = '' then fStatus:='0000';
      Synchronize(@Draw);
    end;
    fStatusText := 'Команда выполнена';
    Synchronize(@UpdateStatus);
  finally
    ser.free;
  end;
end;

На этом создание нового класса завершено. Теперь в основной программе нужно создать поток и запустить его выполнение.

  SerThread := TSerialThread.Create(True);
  SerThread.fPortName:=Form1.Edit1.Text;
  SerThread.fDataIn:=chr(5)+chr(0)+chr(0)+chr(0);
  SerThread.fStatusGet:=True;
  SerThread.Resume;

Переменная fStatusGet заставит вызываться не только функцию обновления StatusBar, но и вторую функцию обновления интерфейса.

Обновление от 18.08.2012: Очереди и блокировки

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

    fBusy: boolean;
    procedure Busy;
    procedure CheckBusy;
    procedure ThreadTerminate;

Переменная fBusy это внутренний флаг статуса занятости порта, копирующий состояние флага занятости в основной программе. Он изменяется прямо в потоке, а процедурой Busy переностися в глобальную переменную SerialBusy: boolean;. Процедура CheckBusy выполняет перенос глобального флага занятости порта в переменную fBusy.

Для визуальных эффектов на форму добавлен обычный TShape, показывающий занятость порта, а также дополнительный TStatusBar (я знаю что в TStatusBar есть встроеные панельки; меня просто ломает все переписывать) в котором показывается количество заданий.

procedure TSerialThread.Busy;
begin
  if fBusy = True then
  begin
    Form1.Shape1.Brush.Color:=clRed;
    SerialBusy := True;
  end else
  begin
    Form1.Shape1.Brush.Color:=clGreen;
    SerialBusy :=False;
  end;
end;

procedure TSerialThread.CheckBusy;
begin
  if SerialBusy = True then
  begin
    Form1.Shape1.Brush.Color:=clRed;
    fBusy := True;
  end else
  begin
    Form1.Shape1.Brush.Color:=clGreen;
    fBusy :=False;
  end;
end;

Чтобы количество заданий работало, необходимо завести глобальную переменную в теле оснофной программы SerialQueued: Integer;. Именно ей нужно делать инкремент или декремент при создании или завершении потока. Я добавил эти действия в конструктор Create и процедуру ThreadTerminate.

constructor TSerialThread.Create(CreateSuspended: boolean);
begin
  FreeOnTerminate := True;
  inherited Create(CreateSuspended);
  Form1.Shape1.Brush.Color:=clRed;
  inc(SerialQueued);
  Form1.StatusBar2.SimpleText:=IntToStr(SerialQueued);
end;

procedure TSerialThread.ThreadTerminate;
begin
  Dec(SerialQueued);
  Form1.StatusBar2.SimpleText:=IntToStr(SerialQueued);
  if SerialQueued > 0 then Form1.Shape1.Brush.Color:=clRed;
end;

Теперь необходимо сделать проверку флагов прямо в процедуре Execute и ждать освобождения порта. Обратите внимание на условие (not Terminated) в цикле. Оно обязательно для всех циклов внутри потоков!

procedure TSerialThread.Execute;
var
  ser: TBlockSerial;
  answer: string;
begin
  Synchronize(@CheckBusy);
  while (not Terminated) and (fBusy) do
  begin
    //fStatusText := 'Ожидание очереди...';
    //Synchronize(@UpdateStatus);
    sleep(1500);
    Synchronize(@CheckBusy);
  end;
  fBusy := True;
  Synchronize(@Busy);
  ser := TBlockSerial.Create;
  try
    fStatusText := 'Инициализация порта ввода\вывода...';
    Synchronize(@UpdateStatus);
    ser.connect(fPortName);
    if ser.LastError > 0 then
    begin
      fStatusText := ser.LastErrorDesc;
      Synchronize(@UpdateStatus);
      fBusy := False;
      Synchronize(@Busy);
      Synchronize(@ThreadTerminate);
      Terminate;
      Exit;
    end;
    fStatusText := 'Подключение...';
    Synchronize(@UpdateStatus);
    ser.config(9600, 8, 'N', 0, False, False);
    if ser.LastError > 0 then
    begin
      fStatusText := ser.LastErrorDesc;
      Synchronize(@UpdateStatus);
      fBusy := False;
      ser.Free;
      Synchronize(@Busy);
      Synchronize(@ThreadTerminate);
      Terminate;
      Exit;
    end;
    fStatusText := 'Посылка команды...';
    Synchronize(@UpdateStatus);
    ser.sendstring(fDataIn);
    if ser.LastError > 0 then
    begin
      fStatusText := ser.LastErrorDesc;
      Synchronize(@UpdateStatus);
      fBusy := False;
      ser.Free;
      Synchronize(@Busy);
      Synchronize(@ThreadTerminate);
      Terminate;
      Exit;
    end;
    fStatusText := 'Ожидание ответа...';
    Synchronize(@UpdateStatus);
    answer := ser.RecvTerminated(2000, #13);
    if ser.LastError > 0 then
    begin
      fStatusText := ser.LastErrorDesc;
      Synchronize(@UpdateStatus);
      fBusy := False;
      ser.Free;
      Synchronize(@Busy);
      Synchronize(@ThreadTerminate);
      Terminate;
      Exit;
    end;
    if fStatusGet then
    begin
      fStatusText := 'Ожидание информации о состоянии...';
      Synchronize(@UpdateStatus);
      fStatus := ser.RecvTerminated(2000, #13);
      fStatus := ExtractWord(2, fStatus, StdWordDelims);
      if ser.LastError > 0 then
      begin
        fStatusText := ser.LastErrorDesc;
        Synchronize(@UpdateStatus);
        fBusy := False;
        ser.Free;
        Synchronize(@Busy);
        Synchronize(@ThreadTerminate);
        Terminate;
        Exit;
      end;
      if fStatus = '' then
        fStatus := '0000';
      Synchronize(@Draw);
    end;
    fStatusText := 'Команда выполнена';
    Synchronize(@UpdateStatus);
  finally

  end;
  ser.Free;
  fBusy := False;
  Synchronize(@Busy);
  Synchronize(@ThreadTerminate);
  Terminate;
end;

Заметьте, что в каждой обработке ошибки я начал уничтожать объект ser. Это связано с тем, что он не уничтожится простым Terminate. Всегда очищайте память от созданых объектов! Это позволит избежать утечек и прочих “непонятных” ошибок.

Теперь дело осталось за малым. В теле основной программы нужно запустить поочередно 2 потока с командами и ждать результата 🙂

procedure TForm1.Button5Click(Sender: TObject);
begin
  Timer1.Enabled := False;
  Button3.Enabled := False;

  SerThread := TSerialThread.Create(True);
  SerThread.fPortName := Edit1.Text;
  SerThread.fDataIn := chr(4) + chr(0) + chr(1) + chr(0);
  SerThread.Resume;

  SerThread := TSerialThread.Create(True);
  SerThread.fPortName := Form1.Edit1.Text;
  SerThread.fDataIn := chr(5) + chr(0) + chr(0) + chr(0);
  SerThread.fStatusGet := True;
  SerThread.Resume;
  Timer1.Enabled := True;
  Button3.Enabled := True;
end;

Ну и, конечно же, обещаное в начале статьи видео с демонстрацией работы:

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

Всего 1 комментарий »

Lazarus: работа с последовательным портом

№ 4453 В разделах: Electronics Programming от July 24th, 2012,
В подшивках: ,

Чтобы передать моему устройству информацию по UART и не придумывать очередной велосипед (а велосипедистов в Lazarus тьма просто), я использую уже готовую мультиплатформенную библиотеку Synaser. Ее даже устанавливать не надо. Просто распакуйте в директорию с программой и добавьте ее в Uses.

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  ComCtrls,synaser,strutils;

Кстати, чтобы программа собралась под Linux, мне пришлось наложить небольшой патч. Откройте файл synaser.pas и исправьте строку 1902 с SerialCheck(fpioctl(FHandle, TCFLSH, Pointer(TCIOFLUSH))); на SerialCheck(fpioctl(integer(FHandle), TCFLSH, Pointer(TCIOFLUSH)));. Ошибка не страшная, но запутать вопросом “какого хрена не собирается?!” может.

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

function send(port:string; data:string):string;
var
  ser: TBlockSerial;
  answer:string;
begin
  ser:=TBlockSerial.Create;
  try
    ser.connect(port);
    if ser.LastError>0 then ShowMessage(ser.LastErrorDesc);
    ser.config(9600,8,'N',0,false,false);
    if ser.LastError>0 then ShowMessage(ser.LastErrorDesc);
    ser.sendstring(data);
    if ser.LastError>0 then ShowMessage(ser.LastErrorDesc);
    answer := ser.Recvstring(2000);
    if ser.LastError>0 then ShowMessage(ser.LastErrorDesc);
    if ser.LastError>0 then Exit;
  finally
    ser.free;
  end;
  Result := answer;
end;

Программа отправит что-то микроконтроллеру и что-то должна получить в ответ. Скорость 9600 обычно стоит везде по умолчанию. Ее выбираю и я для своих устройств ser.config(9600,8,'N',0,false,false);. Чтобы обработать ошибочные ситуации в библиотеке есть переменные с ошибкой последнего действия. Я не стал делать exit из try сразу, но правильней было бы выйти сразу же при ошибке, но это вы уже сами сделаете в своих программах, а сейчас главное узнать о возможностях. LastError хранит 0, если последний вызов функций библиотеки был без ошибок, а LastErrorDesc покажет вам объяснение что именно случилось. Ну и конечно в конце полученный ответ возвращаем туда, откуда вызвали функцию send.

Обращаю ваше внимание на то, что у микроконтроллеров, работающих на некоторых частотах, возможны сбои при передачи информации! Иногда пакет с данными нужно отправлять дважды. Изучите таблицы 6-2 Determining Baud Rate на этой странице. По ним вы можете подобрать соответствующий кварц и режим работы, чтобы ошибок не было совсем.

Нет комментариев »

Динамические объекты в Lazarus (Delphi) и доступ к ним

№ 4416 В разделе Programming от July 8th, 2012,
В подшивках: , ,

Есть у меня один собственный проект IDE для микроконтроллеров AVR под мои собственные нужды. Там используется интерфейс с закладками в которых находится редактор с файлом. Выглядит оно примерно так:

(more…)

Нет комментариев »

Яндекс.Метрика

Fortune cookie: "In order to see Christianity, one must forget almost all Christians." [Henri F. Amiel]