fmain.pas

Unit fMain;

{$mode objfpc}{$H+}

Interface

Uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls,
  Buttons, ComCtrls, ValEdit, MQTT, IniFiles, Grids,
  fpjson, jsonparser, ECXMLParser;

Type

  { TfrmMain }

  TfrmMain = Class(TForm)
    btnHalt: TButton;
    chlSubPause: TCheckBox;
    chkRetain: TCheckBox;
    chkLogPing: TCheckBox;
    chkDup: TCheckBox;
    edAddr: TEdit;
    edUser: TEdit;
    edClientID: TEdit;
    edSubscribe: TEdit;
    edPort: TEdit;
    edPublish: TEdit;
    edPwd: TEdit;
    ILJSON: TImageList;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    lbSendCnt: TLabel;
    lbRecCnt: TLabel;
    lbPort: TLabel;
    lbName: TLabel;
    memSubDat: TMemo;
    memPub: TMemo;
    memSub: TMemo;
    Panel2: TPanel;
    pgSubscr: TPageControl;
    panConnect: TPanel;
    Panel1: TPanel;
    panPublish: TPanel;
    panSubscribe: TPanel;
    rbPTxt: TRadioButton;
    rbPJson: TRadioButton;
    rbPXml: TRadioButton;
    rbSQoS0: TRadioButton;
    rbSQoS1: TRadioButton;
    rbSQoS2: TRadioButton;
    rbPQoS0: TRadioButton;
    rbPQoS1: TRadioButton;
    rbPQoS2: TRadioButton;
    spConnect: TSpeedButton;
    spDisconnect: TSpeedButton;
    Splitter2: TSplitter;
    spSubClr: TSpeedButton;
    spSubscribe: TSpeedButton;
    spPublish: TSpeedButton;
    spUnsubscribe: TSpeedButton;
    Splitter1: TSplitter;
    tabLog: TTabSheet;
    tabTable: TTabSheet;
    tvP: TTreeView;
    veSub: TValueListEditor;
    Procedure btnHaltClick(Sender: TObject);
    Procedure FormClose(Sender: TObject; Var CloseAction: TCloseAction);
    Procedure FormCreate(Sender: TObject);
    Procedure FormShow(Sender: TObject);
    Procedure rbPTxtChange(Sender: TObject);
    Procedure spConnectClick(Sender: TObject);
    Procedure spDisconnectClick(Sender: TObject);
    Procedure spPublishClick(Sender: TObject);
    Procedure spSubClrClick(Sender: TObject);
    Procedure spSubscribeClick(Sender: TObject);
    Procedure spUnsubscribeClick(Sender: TObject);
    Procedure veSubDblClick(Sender: TObject);
    Procedure veSubSelectCell(Sender: TObject; aCol, aRow: Integer;
      Var CanSelect: Boolean);
  private
    ParIni: String;
    ParWillTopic: String;
    ParWillMsg: String;
    ParWillQoS: Integer;
    ParWillRetain: Boolean;
    Procedure OnConnAck(Sender: TObject; ReturnCode: Integer);
    Procedure OnDisConn(Sender: TObject);
    Procedure OnPingResp(Sender: TObject);
    Procedure OnPingReq(Sender: TObject);
    Procedure OnSubAck(Sender: TObject; MessageID, QoS: Integer);
    Procedure OnUnSubAck(Sender: TObject; MessageID: Integer);
    Procedure OnPublish(Sender: TObject; topic, payload: Utf8string; MessageID, QoS: Integer; Retain, Dup: Boolean);
    Procedure OnPubAck(Sender: TObject; MessageID: Integer);
    Procedure OnPubRec(Sender: TObject; MessageID: Integer);
    Procedure OnPubRel(Sender: TObject; MessageID: Integer);
    Procedure OnPubComp(Sender: TObject; MessageID: Integer);
    procedure ShowJSONData(tv: TTreeView; AParent : TTreeNode; Data : TJSONData; iEbene: Integer);
    procedure ShowXMLData(tv: TTreeView; AParent : TTreeNode; Data : TXMLItem; iEbene: Integer);
  public
    MQTTClient: TMQTT;
  End;

Var
  frmMain: TfrmMain;

Implementation

{$R *.lfm}

{ TfrmMain }

Procedure TfrmMain.spConnectClick(Sender: TObject);
Begin
  Screen.Cursor := crHourGlass;
  Try
    If Not Assigned(MQTTClient) Then
    Begin
      MQTTClient := TMQTT.Create(edAddr.Text, StrToIntDef(edPort.Text, 1883));
      MQTTClient.AsyncQueue := True;
      MQTTClient.ClientID := edClientID.Text;
      MQTTClient.Username := edUser.Text;
      MQTTClient.Password := edPwd.Text;
      MQTTClient.OnConnAck := @OnConnAck;
      MQTTClient.OnDisconnect := @OnDisConn;
      MQTTClient.OnPingResp := @OnPingResp;
      MQTTClient.OnPingReq := @OnPingReq;
      MQTTClient.OnPublish := @OnPublish;
      MQTTClient.OnSubAck := @OnSubAck;
      MQTTClient.OnUnSubAck := @OnUnSubAck;
      MQTTClient.OnPubAck := @OnPubAck;
      MQTTClient.OnPubRec := @OnPubRec;
      MQTTClient.OnPubRel := @OnPubRel;
      MQTTClient.OnPubComp := @OnPubComp;
      MQTTClient.WillTopic := ParWillTopic;
      MQTTClient.WillMsg := ParWillMsg;
      MQTTClient.WillQoS := ParWillQoS;
      MQTTClient.WillRetain := ParWillRetain;
    End;
    If Not MQTTClient.Connect() Then
    Begin
      FreeAndNil(MQTTClient);
      If Not chlSubPause.Checked Then
        memSub.Lines.Add('Connection failed.');
    End Else Begin
      If Not chlSubPause.Checked Then
        If (ParWillTopic <> '') And (ParWillMsg <> '') Then
          memSub.Lines.Add('LastWill: ' + ParWillTopic + '=' + ParWillMsg);
    End;
  Finally
    Screen.Cursor := crDefault;
  End;
End;

Procedure TfrmMain.spDisconnectClick(Sender: TObject);
Begin
  If Not Assigned(MQTTClient) Then Exit;
  MQTTClient.Unsubscribe(MQTTClient.Subscribed);
  MQTTClient.Disconnect;
  FreeAndNil(MQTTClient);
End;

Procedure TfrmMain.spPublishClick(Sender: TObject);
Var
  i: Integer;
Begin
  If Not Assigned(MQTTClient) Then Exit;
  If rbSQoS1.Checked Then
    i := 1
  Else If rbSQoS2.Checked Then
    i := 2
  Else i := 0;
  MQTTClient.Publish(edPublish.Text, memPub.Text, i, chkRetain.Checked, chkDup.Checked);
End;

Procedure TfrmMain.spSubClrClick(Sender: TObject);
Begin
  memSub.Clear;
  memSubDat.Clear;
  veSub.RowCount := 1;
  tvP.Items.Clear;
end;

Procedure TfrmMain.spSubscribeClick(Sender: TObject);
Var
  i: Integer;
Begin
  If Not Assigned(MQTTClient) Then Exit;
  i := 0;
  If rbSQoS1.Checked Then
    i := 1;
  If rbSQoS2.Checked Then
    i := 2;
  MQTTClient.Subscribe(edSubscribe.Text, i);
  If Not chlSubPause.Checked Then
    memSub.Lines.Add('+ ' + edSubscribe.Text + ' [' + i.ToString + ']');
End;

Procedure TfrmMain.spUnsubscribeClick(Sender: TObject);
Begin
  If Not Assigned(MQTTClient) Then Exit;
  MQTTClient.Unsubscribe(edSubscribe.Text);
  If Not chlSubPause.Checked Then
    memSub.Lines.Add('- ' + edSubscribe.Text);
End;

Procedure TfrmMain.veSubDblClick(Sender: TObject);
Begin
  If veSub.Row > 0 Then
  Begin
    edPublish.Text := veSub.Cells[0, veSub.Row];
    memPub.Text := veSub.Cells[1, veSub.Row];
  End;
end;

Procedure TfrmMain.veSubSelectCell(Sender: TObject; aCol, aRow: Integer;
  Var CanSelect: Boolean);
Begin
  CanSelect := aRow > 0;
  If CanSelect Then
    memSubDat.Lines.Text := veSub.Cells[1, aRow]
  Else memSubDat.Lines.Clear;
  rbPTxtChange(Nil);
end;

Procedure TfrmMain.FormCreate(Sender: TObject);
Var ini: TIniFile;
  i: Integer;
Begin
  MQTTClient := nil;
  spConnect.Enabled := True;
  spDisconnect.Enabled := False;
  memSub.Lines.Clear;
  pgSubscr.ActivePage := tabLog;
  ParIni := ChangeFileExt(Application.ExeName, '.ini');
  ini := TIniFile.Create(ParIni);
  Try
    edClientID.Text := ini.ReadString('Connection', 'ClientID', edClientID.Text);
    edAddr.Text := ini.ReadString('Connection', 'Host', edAddr.Text);
    edPort.Text := ini.ReadString('Connection', 'Port', edPort.Text);
    edUser.Text := ini.ReadString('Connection', 'User', edUser.Text);
    edPwd.Text := ini.ReadString('Connection', 'Password', edPwd.Text);
    edPublish.Text := ini.ReadString('Publish', 'Text', edPublish.Text);
    i := ini.ReadInteger('Publish', 'QoS', 0);
    Case i Of
    0: rbPQoS0.Checked := True;
    1: rbPQoS1.Checked := True;
    2: rbPQoS2.Checked := True;
    End;
    chkRetain.Checked := ini.ReadInteger('Publish', 'Retain', 0) <> 0;
    chkDup.Checked := ini.ReadInteger('Publish', 'Dup', 0) <> 0;
    edSubscribe.Text := ini.ReadString('Subscribe', 'Text', edSubscribe.Text);
    i := ini.ReadInteger('Subscribe', 'QoS', 0);
    Case i Of
    0: rbSQoS0.Checked := True;
    1: rbSQoS1.Checked := True;
    2: rbSQoS2.Checked := True;
    End;
    If Not ini.SectionExists('LastWill') Then
    Begin
      ini.WriteString('LastWill', 'Topic', '');
      ini.WriteString('LastWill', 'Msg', '');
      ini.WriteInteger('LastWill', 'Flag', 0);
      ini.WriteInteger('LastWill', 'QoS', 0);
      ini.WriteInteger('LastWill', 'Retain', 0);
    End Else Begin
      ParWillTopic := ini.ReadString('LastWill', 'Topic', '');
      ParWillMsg := ini.ReadString('LastWill', 'Msg', '');
      ParWillQoS := ini.ReadInteger('LastWill', 'QoS', 0);
      If (ParWillQoS < 0) Or (ParWillQoS > 2) Then
        ParWillQoS := 0;
      ParWillRetain := ini.ReadInteger('LastWill', 'Retain', 0) <> 0;
    End;
  Finally
    FreeAndNil(ini);
  End;
End;

Procedure TfrmMain.FormShow(Sender: TObject);
Begin
  panConnect.Height := edUser.Top + edUser.Height + 8;
end;

Procedure TfrmMain.rbPTxtChange(Sender: TObject);
Var xml: TECXMLParser;
  J: TJsonData;
  st: TMemoryStream;
  s: AnsiString;
Begin
  memSubDat.Visible := rbPTxt.Checked;
  tvP.Visible := Not memSubDat.Visible;
  If tvP.Visible Then
  Begin
    tvP.Items.Clear;
    st := TMemoryStream.Create;
    Try
      s := Trim(memSubDat.Lines.Text);
      st.WriteBuffer(PAnsiChar(s)^, Length(s));
      st.Position := 0;
      If rbPXml.Checked Then
      Begin
        xml := TECXMLParser.Create(Self);
        Try
          xml.LoadFromStream(st);
          ShowXMLData(tvP, Nil, xml.Root, 0); // Daten in TTreeView übernehmen
        Finally
          FreeAndNil(xml);
        End;
      End;
      If rbPJson.Checked Then
      Begin
        J := GetJSON(st);
        ShowJSONData(tvP, Nil, J, 0); // Daten in TreeView zeigen
      End;
      If tvP.Items.Count > 0 Then
        tvP.FullExpand;
    Finally
      FreeAndNil(st);
    End;
  End;
end;

Procedure TfrmMain.FormClose(Sender: TObject; Var CloseAction: TCloseAction);
Var ini: TIniFile;
  i: Integer;
Begin
  spDisconnectClick(nil);
  ini := TIniFile.Create(ParIni);
  Try
    ini.WriteString('Connection', 'ClientID', edClientID.Text);
    ini.WriteString('Connection', 'Host', edAddr.Text);
    ini.WriteString('Connection', 'Port', edPort.Text);
    ini.WriteString('Connection', 'User', edUser.Text);
    ini.WriteString('Connection', 'Password', edPwd.Text);
    ini.WriteString('Publish', 'Text', edPublish.Text);
    If rbPQoS1.Checked Then
      i := 1
    Else If rbPQoS2.Checked Then
      i := 2
    Else i := 0;
    ini.WriteInteger('Publish', 'QoS', i);
    If chkRetain.Checked Then
      ini.WriteInteger('Publish', 'Retain', 1)
    Else ini.WriteInteger('Publish', 'Retain', 0);
    If chkDup.Checked Then
      ini.WriteInteger('Publish', 'Dup', 1)
    Else ini.WriteInteger('Publish', 'Dup', 0);
    ini.WriteString('Subscribe', 'Text', edSubscribe.Text);
    If rbSQoS1.Checked Then
      i := 1
    Else If rbSQoS2.Checked Then
      i := 2
    Else i := 0;
    ini.WriteInteger('Subscribe', 'QoS', i);
  Finally
    FreeAndNil(ini);
  End;
End;

Procedure TfrmMain.btnHaltClick(Sender: TObject);
Begin
  Halt;
end;

Procedure TfrmMain.OnConnAck(Sender: TObject; ReturnCode: Integer);
Begin
  If Not chlSubPause.Checked Then
    memSub.Lines.Add('Rx: OnConnAck()');
  spConnect.Enabled := False;
  spDisconnect.Enabled := True;
  panPublish.Enabled := True;
  panSubscribe.Enabled := True;
End;

Procedure TfrmMain.OnDisConn(Sender: TObject);
Begin
  If Not chlSubPause.Checked Then
    memSub.Lines.Add('Rx: OnDisconnect()');
  spConnect.Enabled := True;
  spDisconnect.Enabled := False;
  panPublish.Enabled := False;
  panSubscribe.Enabled := False;
  lbRecCnt.Caption := MQTTClient.RecvCounter.ToString;
  lbSendCnt.Caption := MQTTClient.SendCounter.ToString;
End;

Procedure TfrmMain.OnPingResp(Sender: TObject);
Begin
  If Not chlSubPause.Checked Then
    If chkLogPing.Checked Then
    Begin
      memSub.Lines.Add('Rx: OnPingResp()');
      While memSub.Lines.Count > 500 Do
        memSub.Lines.Delete(0);
    End;
  lbRecCnt.Caption := MQTTClient.RecvCounter.ToString;
  lbSendCnt.Caption := MQTTClient.SendCounter.ToString;
End;

Procedure TfrmMain.OnPingReq(Sender: TObject);
Begin
  If Not chlSubPause.Checked Then
    If chkLogPing.Checked Then
    Begin
      memSub.Lines.Add('Rx: OnPingReq()');
      While memSub.Lines.Count > 500 Do
        memSub.Lines.Delete(0);
    End;
End;

Procedure TfrmMain.OnSubAck(Sender: TObject; MessageID, QoS: Integer);
Begin
  If Not chlSubPause.Checked Then
    memSub.Lines.Add('Rx: OnSubAck(' + MessageID.ToString + ',' + QoS.ToString + ')');
End;

Procedure TfrmMain.OnUnSubAck(Sender: TObject; MessageID: Integer);
Begin
  If Not chlSubPause.Checked Then
    memSub.Lines.Add('Rx: OnUnSubAck(' + MessageID.ToString + ')');
End;

Procedure TfrmMain.OnPublish(Sender: TObject; topic, payload: Utf8string; MessageID: Integer; QoS: Integer; Retain, Dup: Boolean);
Var s: String;
Begin
  If Not chlSubPause.Checked Then
  Begin
    If Length(payload) > 255 Then
      s := Copy(payload, 1, 255) + '...'
    Else s := PayLoad;
    memSub.Lines.Add('Rx: ' + Topic + '=' + s);
    veSub.Strings.Values[topic] := payload;
    veSub.Strings.Sort;
    While memSub.Lines.Count > 500 Do
      memSub.Lines.Delete(0);
  End;
End;

Procedure TfrmMain.OnPubAck(Sender: TObject; MessageID: Integer);
Begin
  If Not chlSubPause.Checked Then
    memSub.Lines.Add('Rx: OnPubAck(' + MessageID.ToString + ')');
End;

Procedure TfrmMain.OnPubRec(Sender: TObject; MessageID: Integer);
Begin
  If Not chlSubPause.Checked Then
    memSub.Lines.Add('Rx: OnPubRec(' + MessageID.ToString + ')');
  MQTTClient.Pubrel(MessageID);
End;

Procedure TfrmMain.OnPubRel(Sender: TObject; MessageID: Integer);
Begin
  If Not chlSubPause.Checked Then
    memSub.Lines.Add('Rx: OnPubRel(' + MessageID.ToString + ')');
End;

Procedure TfrmMain.OnPubComp(Sender: TObject; MessageID: Integer);
Begin
  If Not chlSubPause.Checked Then
    memSub.Lines.Add('Rx: OnPubComp(' + MessageID.ToString + ')');
End;

procedure TfrmMain.ShowJSONData(tv: TTreeView; AParent : TTreeNode; Data : TJSONData; iEbene: Integer);
Var
  N,N2 : TTreeNode;
  I : Integer;
  D : TJSONData;
  sTx : String;
  S : TStringList;
Const
  ImageTypeMap : Array[TJSONtype] of Integer =
//      jtUnknown, jtNumber, jtString, jtBoolean, jtNull, jtArray, jtObject
       (-1,8,9,7,6,5,4);
begin
  N := Nil;
  if Assigned(Data) then
  begin
    Case Data.JSONType of
      jtArray,
      jtObject:
        begin
          N := AParent;
          S := TstringList.Create;
          try
            For I := 0 to Data.Count - 1 do
              If Data.JSONtype=jtArray then
                S.AddObject(IntToStr(I),Data.items[i])
              else
                S.AddObject(TJSONObject(Data).Names[i],Data.items[i]);
            For I := 0 to S.Count - 1 do
              begin
              sTx := S[i];
              N2 := tv.Items.AddChild(N, sTx);
              D := TJSONData(S.Objects[i]);
              N2.ImageIndex := ImageTypeMap[D.JSONType];
              N2.SelectedIndex := ImageTypeMap[D.JSONType];
              ShowJSONData(tv, N2,D, iEbene + 1);
              end
          finally
            FreeAndNil(S);
          end;
        end;
      jtNull: // Keine Daten
        N := tv.Items.AddChild(AParent,'null');
    else // Daten anhängen
      sTx := Data.AsString;
      N := tv.Items.AddChild(AParent,sTx);
      N := AParent;
    end;
    If Assigned(N) then
      begin
      N.ImageIndex := ImageTypeMap[Data.JSONType];
      N.SelectedIndex := ImageTypeMap[Data.JSONType];
      N.Data := Data;
    end;
  end;
end;

procedure TfrmMain.ShowXMLData(tv: TTreeView; AParent : TTreeNode; Data : TXMLItem; iEbene: Integer);
Var
  n, n2 : TTreeNode;
  i : Integer;
begin
  n := tv.Items.AddChild(AParent, Data.Name);
  If Data.SubItemCount > 0 Then
  Begin
    If Data.Text <> '' Then
      tv.Items.AddChild(n, Data.Text);
    n.ImageIndex := 4;
    n.SelectedIndex := 4;
    For i := 0 To Data.SubItemCount - 1 Do
      ShowXMLData(tv, n, Data.SubItems[i], iEbene + 1);
  end else begin
    n.ImageIndex := 4;
    n.SelectedIndex := 4;
    If Data.Text <> '' Then
    Begin
      tv.Items.AddChild(n, Data.Text);
      n.ImageIndex := 9;
      n.SelectedIndex := 9;
    End;
  end;
  For i := 0 To Data.Params.Count - 1 Do
  Begin
    n2 := tv.Items.AddChild(n, Data.Params.Names[i]);
    n2.ImageIndex := 9;
    n2.SelectedIndex := 9;
    tv.Items.AddChild(n2, Data.Params[i]);
  end;
end;

End.