Firemonkey - ungültige Zeigeroperation

[blawen]

Ich habe kürzlich von Delphi XE auf XE5 upgedatet und bin momentan ein wenig am "spielen" mit Firemonkey.
Eine der Spielereien betrifft "Video Capturing". Kurzerhand habe ich das Beispiel vom Emba DocWiki umgesetzt.
Grundsätzlich funktioniert das Programm, nach ein paar wenigen Minuten stürzt es jedoch mit der Fehlermeldung "Ungültige Zeigeroperation" ab - Bestenfalls verabschiedet es sich ohne irgendeine Meldung...

Hat mir ev. jemand einen Tipp, was ich falsch mache?

Delphi-Quellcode:

unit Unit2;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.Ani, FMX.Layouts, FMX.Gestures,
  FMX.StdCtrls, FMX.ListBox, FMX.Media, FMX.Objects;

type
  TForm2 = class(TForm)
    StyleBook1: TStyleBook;
    ToolbarHolder: TLayout;
    ToolbarPopup: TPopup;
    ToolbarPopupAnimation: TFloatAnimation;
    ToolBar1: TToolBar;
    ToolbarApplyButton: TButton;
    ToolbarCloseButton: TButton;
    ToolbarAddButton: TButton;
    Layout1: TLayout;
    StartButton: TButton;
    ComboBox1: TComboBox;
    Image1: TImage;
    procedure ToolbarCloseButtonClick(Sender: TObject);
    procedure FormGesture(Sender: TObject;
              const EventInfo: TGestureEventInfo; var Handled: Boolean);
    procedure FormKeyDown(Sender: TObject; var Key: Word; var KeyChar: Char;
                          Shift: TShiftState);
    procedure StartButtonClick(Sender: TObject);
    procedure ComboBox1Change(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    FGestureOrigin: TPointF;
    FGestureInProgress: Boolean;
    { Private-Deklarationen }
    procedure ShowToolbar(AShow: Boolean);
  public
    { Public-Deklarationen }
    VideoCamera: TVideoCaptureDevice;
    procedure SampleBufferSync;
    procedure SampleBufferReady(Sender: TObject; const ATime: TMediaTime);
  end;

var
  Form2: TForm2;

implementation

{$R *.fmx}

procedure TForm2.FormKeyDown(Sender: TObject; var Key: Word;
  var KeyChar: Char; Shift: TShiftState);
begin
  if Key = vkEscape then
    ShowToolbar(not ToolbarPopup.IsOpen);
end;

procedure TForm2.ToolbarCloseButtonClick(Sender: TObject);
begin
  Application.Terminate;
end;

procedure TForm2.ComboBox1Change(Sender: TObject);
begin
  VideoCamera := TVideoCaptureDevice(TCaptureDeviceManager.Current.GetDevicesByName(ComboBox1.Selected.Text));
  if (VideoCamera <> nil) then begin
    StartButton.Enabled := true;
  end;
end;


procedure TForm2.FormCreate(Sender: TObject);
var
   DeviceList: TCaptureDeviceList;
   i: integer;
begin
  DeviceList := TCaptureDeviceManager.Current.GetDevicesByMediaType(TMediaType.Video);
  for i := 0 to DeviceList.Count - 1 do begin
     ComboBox1.Items.Add(DeviceList[i].Name);
  end;
end;

procedure TForm2.FormGesture(Sender: TObject;
const
  EventInfo: TGestureEventInfo; var Handled: Boolean);
var
  DX, DY : Single;

begin
  if EventInfo.GestureID = igiPan then
  begin
    if (TInteractiveGestureFlag.gfBegin in EventInfo.Flags)
      and ((Sender = ToolbarPopup)
        or (EventInfo.Location.Y > (ClientHeight - 70))) then
    begin
      FGestureOrigin := EventInfo.Location;
      FGestureInProgress := True;
    end;

    if FGestureInProgress and (TInteractiveGestureFlag.gfEnd in EventInfo.Flags) then
    begin
      FGestureInProgress := False;
      DX := EventInfo.Location.X - FGestureOrigin.X;
      DY := EventInfo.Location.Y - FGestureOrigin.Y;
      if (Abs(DY) > Abs(DX)) then
        ShowToolbar(DY < 0);
    end;
  end
end;

procedure TForm2.SampleBufferReady(Sender: TObject; const ATime: TMediaTime);
begin
  TThread.Synchronize(TThread.CurrentThread, SampleBufferSync);
  //Resize the image so that the video is buffered in its original size
  Image1.Width:=Image1.Bitmap.Width;
  Image1.Height:=Image1.Bitmap.Height;
end;

procedure TForm2.SampleBufferSync;
begin
  VideoCamera.SampleBufferToBitmap(Image1.Bitmap, true);
end;

procedure TForm2.ShowToolbar(AShow: Boolean);
begin
  ToolbarPopup.Width := ClientWidth;
  ToolbarPopup.PlacementRectangle.Rect := TRectF.Create(0, ClientHeight-ToolbarPopup.Height, ClientWidth-1, ClientHeight-1);
  ToolbarPopupAnimation.StartValue := ToolbarPopup.Height;
  ToolbarPopupAnimation.StopValue := 0;

  ToolbarPopup.IsOpen := AShow;
end;

procedure TForm2.StartButtonClick(Sender: TObject);
begin
  if (VideoCamera <> nil) then
   begin
     if (VideoCamera.State = TCaptureDeviceState.Stopped) then
     begin
       VideoCamera.OnSampleBufferReady := SampleBufferReady;
       VideoCamera.StartCapture;
       StartButton.Text := 'Stop';
     end
     else
     begin
       VideoCamera.StopCapture;
       StartButton.Text := 'Start';
     end;
   end
   else
   begin
     Caption := 'Video capture devices not available.';
   end;
end;

end.

[Harry Stahl]

Ja, kann das Problem bestätigen. Habe bei Quality Central eine Meldung gemacht:

http://qc.embarcadero.com/wc/qcmain.aspx?d=122608

Falls die Behebung dieses Problem für Dich wichtig sein sollte, kannst Du ein Vote auf diese Meldung abgeben, dann beschleunigt sich die Bearbeitung des Falles evtl. ein wenig.

Falls ich eine Nachricht bezüglich eines Workarounds erhalten sollte, poste ich das hier.

[blawen]

Zitat von Harry Stahl:

Ja, kann das Problem bestätigen. Habe bei Quality Central eine Meldung gemacht:

http://qc.embarcadero.com/wc/qcmain.aspx?d=122608

Falls die Behebung dieses Problem für Dich wichtig sein sollte, kannst Du ein Vote auf diese Meldung abgeben, dann beschleunigt sich die Bearbeitung des Falles evtl. ein wenig.

Falls ich eine Nachricht bezüglich eines Workarounds erhalten sollte, poste ich das hier.

Lieben Dank für Deine Mithilfe Ich habe soeben mein Votum abgegeben.
Für eine technische Demo bei einer Berufsmesse hätte ich gerne Firemonkey als "Plattform" eingesetzt, im "worst case" werde ich zwangsweise darauf verzichten (müssen).

(Die Kamera ist ein wichtiger Bestandteil einer Modelleisenbahnanlage, welche zentral von einem Computer und von uns eigens dafür entwickelten und programmierten Steuerplatinen angegesteuert wird (ähnlich wie bei Miniatur-Wunderland - nur massiv kleiner)

So gesehen ist es nicht "Überlebenswichtig", aber es wäre doch schön gewesen.

[Harry Stahl]

Alles klar. Evtl. hat ja noch jemand Lust, der diesen Thread liest, für diesen Punkt zu Voten.

Aus meiner Sicht wäre auch wichtig, diesen Bug schnell beseitigen zu lassen:

http://qc.embarcadero.com/wc/qcmain.aspx?d=122609

Wenn man in FMX einen Style in dem Style-Designer editieren möchte (also Rechtsklick auf ein Control und dann Befehl "Benutzerdefinierten Stil bearbeiten" wählen) ist seit XE3 in der Strukturliste das entsprechende Objekt nicht ausgewählt. Das nervt schon sehr, wenn man es dann aus einer u.U. ziemlich langen Liste selber raus suchen muss. Und gerade für Anfänger in Firemonkey ist es sehr schwer zu verstehen, was man da überhaupt machen muss.

[blawen]

Zitat von Harry Stahl:

Alles klar. Evtl. hat ja noch jemand Lust, der diesen Thread liest, für diesen Punkt zu Voten.

Aus meiner Sicht wäre auch wichtig, diesen Bug schnell beseitigen zu lassen:

http://qc.embarcadero.com/wc/qcmain.aspx?d=122609

Dies ist mir auch negativ aufgefallen, darum hast Du mein Voting.

[Sir Rufo]

Also mich machen diese Zeilen ja stutzig

Delphi-Quellcode:

procedure TForm2.SampleBufferReady(Sender: TObject; const ATime: TMediaTime);
begin

  // Synchronisieren - ok, wenn man in einem anderen Thread-Kontext ist, macht das manchmal Sinn

  TThread.Synchronize(TThread.CurrentThread, SampleBufferSync);

  // äh, wenn wir in einem anderen Thread-Kontext sind, 
  // dann doch bitte keinen direkten Zugriff auf die Controls

  //Resize the image so that the video is buffered in its original size
  Image1.Width:=Image1.Bitmap.Width;
  Image1.Height:=Image1.Bitmap.Height;
end;

procedure TForm2.SampleBufferSync;
begin
  VideoCamera.SampleBufferToBitmap(Image1.Bitmap, true);
end;

Des Weiteren können wir hier lesen

Zitat:

Warnung: Rufen Sie Synchronize nicht aus dem Haupt-Thread auf. Dies kann zu einer Endlosschleife führen.

Somit kann dieser Code niemals richtig sein!

1. Die Methode wird im Haupt-Thread aufgerufen, dann ist TThread.Synchronize falsch
2. Die Methode wird nicht im Haupt-Thread aufgerufen, dann darf aber auch nicht auf Image1 zugegriffen werden

Ich würde diese Zeilen mal abändern auf

Delphi-Quellcode:

procedure TForm2.SampleBufferReady(Sender: TObject; const ATime: TMediaTime);
begin
  if MainThreadID = TThread.CurrentThread.ThreadID then
    SampleBufferSync
  else
    TThread.Synchronize(TThread.CurrentThread, SampleBufferSync);
end;

procedure TForm2.SampleBufferSync;
begin

  // Hier sollten wir uns auf jeden Fall im MainThread befinden

  VideoCamera.SampleBufferToBitmap(Image1.Bitmap, true);

  //Resize the image so that the video is buffered in its original size
  Image1.Width:=Image1.Bitmap.Width;
  Image1.Height:=Image1.Bitmap.Height;
end;

und dann sehen was passiert ...

PS: Auf meinem Mac ist die noch nicht einmal abgestürzt

[Harry Stahl]

Leider bewirkt die von Sir Rufo vorgeschlagene Änderung keine Besserung. Nach einigen Sekunden oder in 1-2 Minuten stürzt das Programm ab.

So ganz verstanden habe ich die von EMBA vorgeschlagene Lösung sowieso nicht. SampleBufferReady ist ja eine Ereignisroutine des Hauptthread.

In der Hilfe steht dazu: "Mit einer Ereignisbehandlungsroutine für OnSampleBufferReady können Sie die Aktionen angeben, die ausgeführt werden, wenn der Ausschnittspuffer bereit ist."

Warum muss ich jetzt den Zugriff über einen Thread auf den Buffer machen? Überlaufgefahr? Eigentlich doch nicht, denn ich rufe den Buffer doch ab, wenn ich ihn brauche. In der Beschreibung zu "DoSampleBufferToBitmap" bzw. "SampleBufferToBitmap" steht auch nichts davon, dass ich das threadden müsste.

Wie auch immer, hier nun einer Variante, die bei mir seit ca. einer halben Stunde ohne Probleme läuft:

Delphi-Quellcode:

procedure TForm2.SampleBufferReady(Sender: TObject; const ATime: TMediaTime);
begin
  //TThread.Synchronize(TThread.CurrentThread, SampleBufferSync);
  
   VideoCamera.SampleBufferToBitmap(Image1.Bitmap, True);

   sleep (100);

  //Resize the image so that the video is buffered in its original size  
  if (Image1.Width <> Image1.Bitmap.Width) or (Image1.Height <> Image1.Bitmap.height) then begin
    Image1.Width:=Image1.Bitmap.Width;
    Image1.Height:=Image1.Bitmap.Height;
  end;
end;

Sleep (100) wird aber benötigt, sonst kracht das Programm dann irgendwann doch mal ab.

Immerhin reduziert sich die Prozessorlast mit dieser Variante auf ca. 3-6% (vorher 12%), die Darstellung ist allerdings etwas verzögert.

[Harry Stahl]

Nachtrag:

Wobei die von mir vorgeschlagene Lösung auf dem MAC viel zu langsam ist.

Auf dem MAC läuft allerdings sowohl die von EMBA, als auch die von Sir Rufo vorgeschlagene Lösung(beide aber eben nicht unter Windows).

Also könnte man die Sache erst mal mit {$IFDEF MAC} usw. lösen. Unter Windows zur Not ["erst mal", bis wir es richtig wissen] die von mir vorgeschlagene Lösung, unter MAC die von Sir Rufo.

[Sir Rufo]

Zitat von Harry Stahl:

Nachtrag:

Wobei die von mir vorgeschlagene Lösung auf dem MAC viel zu langsam ist.

Auf dem MAC läuft allerdings sowohl die von EMBA, als auch die von Sir Rufo vorgeschlagene Lösung(beide aber eben nicht unter Windows).

Also könnte man die Sache erst mal mit {$IFDEF MAC} usw. lösen. Unter Windows zur Not ["erst mal", bis wir es richtig wissen] die von mir vorgeschlagene Lösung, unter MAC die von Sir Rufo.

Deine Lösung unterscheidet sich von meiner Lösung durch das Aufrufen von Sleep.

BTW Die Abfrage ist überflüssig denn der Setter prüft schon, ob sich der Wert ändert und löst nur dann ein Repaint aus:

Delphi-Quellcode:

  if (Image1.Width <> Image1.Bitmap.Width) or (Image1.Height <> Image1.Bitmap.height) then begin
    Image1.Width:=Image1.Bitmap.Width;
    Image1.Height:=Image1.Bitmap.Height;
  end;

[Harry Stahl]

Zitat von Sir Rufo:

Deine Lösung unterscheidet sich von meiner Lösung durch das Aufrufen von Sleep.

Nein, Du hast noch einen zusätzlichen Prozedur-Aufruf und im Else-zweig einen möglichen Thread-Aufruf.

Zitat von Sir Rufo:

BTW Die Abfrage ist überflüssig denn der Setter prüft schon, ob sich der Wert ändert und löst nur dann ein Repaint aus:

Delphi-Quellcode:

  if (Image1.Width <> Image1.Bitmap.Width) or (Image1.Height <> Image1.Bitmap.height) then begin
    Image1.Width:=Image1.Bitmap.Width;
    Image1.Height:=Image1.Bitmap.Height;
  end;

Das stimmt zwar, dass beim Setter Repaint nur ausgelöst wird, wenn die Bitmap sich im Ausmaß geändert hat, aber es werden davon unabhängig IMMER beim Setter noch andere Aktionen für das TImage ausgeführt, die letztlich überflüssig sind.

Ich habe das hier gerade mal getestet, auf 1 Mio Durchläufe macht das ca. 200 MS Unterschied aus. Nun gut, ist nicht die Welt hier. Aber es gibt andere Beispiele wo sich der (überflüssige) Aufruf von Settern deutlich mehr auf die Performance auswirkt. Deswegen habe ich es mir angewöhnt, Setter nur aufzurufen, wenn es wirklich notwendig ist.