MPlayer: Fix component being broken in Linux (gtk2) after Lazarus commit "bfd34850 LCL-GTK2: Remove a boolean param from GetWidgetInfo and use new func GetOrCreateWidgetInfo. Identify memory leaks." on Aug 11, 2019. Issue #39070. Based on patch by Michael Köcher. Update "Simple" demo project.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@9262 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2024-03-03 11:45:23 +00:00 · 2024-03-03 11:45:23 +00:00 · 9a46c50c6f
commit 9a46c50c6f
parent 67802d571d
6 changed files with 76 additions and 114 deletions
--- a/components/mplayer/examples/Simple/project1.lpi
+++ b/components/mplayer/examples/Simple/project1.lpi
@ -1,10 +1,12 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
  <ProjectOptions>
-    <Version Value="9"/>
+    <Version Value="12"/>
    <General>
+      <Flags>
+        <CompatibilityMode Value="True"/>
+      </Flags>
      <SessionStorage Value="InProjectDir"/>
-      <MainUnit Value="0"/>
      <ResourceType Value="res"/>
      <UseXPManifest Value="True"/>
      <Icon Value="0"/>
@ -16,9 +18,10 @@
      <Version Value="2"/>
    </PublishOptions>
    <RunParams>
-      <local>
-        <FormatVersion Value="1"/>
-      </local>
+      <FormatVersion Value="2"/>
+      <Modes Count="1">
+        <Mode0 Name="default"/>
+      </Modes>
    </RunParams>
    <RequiredPackages Count="2">
      <Item1>
@ -40,6 +43,7 @@
        <ComponentName Value="Form1"/>
        <HasResources Value="True"/>
        <ResourceBaseClass Value="Form"/>
+        <UnitName Value="Unit1"/>
      </Unit1>
    </Units>
  </ProjectOptions>
@ -49,6 +53,9 @@
      <IncludeFiles Value="$(ProjOutDir)"/>
    </SearchPaths>
    <Linking>
+      <Debugging>
+        <DebugInfoType Value="dsDwarf3"/>
+      </Debugging>
      <Options>
        <Win32>
          <GraphicApplication Value="True"/>
--- a/components/mplayer/examples/Simple/project1.lpr
+++ b/components/mplayer/examples/Simple/project1.lpr
@ -9,8 +9,6 @@ uses
  Interfaces, // this includes the LCL widgetset
  Forms, Unit1;

-{$IFDEF WINDOWS}{$R project1.rc}{$ENDIF}
-
 {$R *.res}

 begin
--- a/components/mplayer/examples/Simple/project1.res
+++ b/components/mplayer/examples/Simple/project1.res
--- a/components/mplayer/examples/Simple/unit1.lfm
+++ b/components/mplayer/examples/Simple/unit1.lfm
@ -7,12 +7,12 @@ object Form1: TForm1
  Caption = 'Form1'
  ClientHeight = 390
  ClientWidth = 583
+  LCLVersion = '3.99.0.0'
  OnCreate = FormCreate
-  LCLVersion = '1.2.4.0'
  object MPlayerControl1: TMPlayerControl
    Left = 6
-    Height = 334
-    Top = 27
+    Height = 336
+    Top = 25
    Width = 571
    Align = alClient
    BorderSpacing.Around = 6
@ -21,28 +21,29 @@ object Form1: TForm1
  end
  object Panel1: TPanel
    Left = 0
-    Height = 21
+    Height = 19
    Top = 0
    Width = 583
    Align = alTop
    AutoSize = True
-    ClientHeight = 21
+    BevelOuter = bvNone
+    ClientHeight = 19
    ClientWidth = 583
    TabOrder = 1
    object PlaySpeedButton: TSpeedButton
-      Left = 1
+      Left = 0
      Height = 19
-      Top = 1
-      Width = 26
+      Top = 0
+      Width = 32
      Align = alLeft
      AutoSize = True
-      Caption = 'Play'
+      Caption = ' Play '
      OnClick = PlaySpeedButtonClick
    end
    object PauseSpeedButton: TSpeedButton
-      Left = 27
+      Left = 32
      Height = 19
-      Top = 1
+      Top = 0
      Width = 35
      Align = alLeft
      AutoSize = True
@ -50,9 +51,9 @@ object Form1: TForm1
      OnClick = PauseSpeedButtonClick
    end
    object StopSpeedButton: TSpeedButton
-      Left = 62
+      Left = 67
      Height = 19
-      Top = 1
+      Top = 0
      Width = 28
      Align = alLeft
      AutoSize = True
@ -60,9 +61,9 @@ object Form1: TForm1
      OnClick = StopSpeedButtonClick
    end
    object OpenSpeedButton: TSpeedButton
-      Left = 90
+      Left = 95
      Height = 19
-      Top = 1
+      Top = 0
      Width = 52
      Align = alLeft
      AutoSize = True
@ -79,7 +80,7 @@ object Form1: TForm1
  end
  object OpenDialog1: TOpenDialog
    Options = [ofFileMustExist, ofEnableSizing, ofViewDetail]
-    left = 235
-    top = 127
+    Left = 235
+    Top = 127
  end
 end
--- a/components/mplayer/examples/Simple/unit1.pas
+++ b/components/mplayer/examples/Simple/unit1.pas
@ -5,8 +5,10 @@ unit Unit1;
 interface

 uses
-  Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
-  Buttons, ComCtrls, ExtCtrls, MPlayerCtrl;
+  Classes, SysUtils, FileUtil, LazFileUtils, LazUtf8, LResources,
+  Forms, Controls, Graphics, Dialogs, Buttons, ComCtrls, ExtCtrls,
+  {$ifdef MSWINDOWS} WinDirs, {$endif}
+  MPlayerCtrl;

 type

@ -80,8 +82,10 @@ begin
  {$else $IFDEF Windows}
   // Download MPlayer generic for Windows and save under Programm Folder Directory
   // http://sourceforge.net/projects/mplayer-win32/
-   MPlayerControl1.MPlayerPath:=extractfilepath(application.exename)+'MPlayer\mplayer.exe' ;
-   //MPlayerControl1.StartParam:='-zoom -fs';
+   MPlayerControl1.MPlayerPath := Application.Location + 'MPlayer\mplayer.exe' ;
+  // Or: if your MPlayer is installed as usual:
+  // MPlayerControl1.MPlayerPath := AppendPathDelim(GetWindowsSpecialDir(FOLDERID_ProgramFilesX86, false)) + 'MPlayer for Windows\mplayer.exe';
+  //MPlayerControl1.StartParam:='-zoom -fs';
  {$endif}
 end;

--- a/components/mplayer/mplayerctrl.pas
+++ b/components/mplayer/mplayerctrl.pas
@ -70,6 +70,10 @@ Changes:
              Exposed OnMouseWheel and implemented wheelmouse scrolling through video in FullFeatured
                demo
              / Mike Thompson
+  2024-02-22  Removed GTK2 related Stuff.
+             IDE was crashing when MPlayer had been installed before!
+             Added a Panel as Child to FCanvas for Output Video.
+             / six1

 TODO
              EXTENSIVE TESTING UNDER LINUX
@ -99,7 +103,7 @@ uses
  LResources, LMessages, Graphics, ExtCtrls, FileUtil, Process, UTF8Process,
  LazFileUtils
  {$ifdef Linux}
-  , gtk2int, gtk2, glib2, gdk2x, Gtk2WSControls, GTK2Proc, Gtk2Def
+  , gtk2, gdk2x
  {$endif}
  ;

@ -157,6 +161,9 @@ type
    FOutList: TStringList;
    FVideoInfo: TVideoInfo;
    FAudioInfo: TAudioInfo;
+    {$ifdef Linux}
+    FDisplayPanel: TPanel;
+    {$endif}
    function GetPosition: single;
    function GetRate: single;
    procedure SetImagePath(AValue: string);
@ -240,16 +247,6 @@ type
    property OnGrabImage; // Fired when mplayer reports the filename of the image grab
  end;

-  { TWSMPlayerControl }
-
-  {$ifdef Linux}
-  TWSMPlayerControl = class(TGtk2WSWinControl)
-  published
-    class function CreateHandle(const AWinControl: TWinControl;
-                                const AParams: TCreateParams): HWND; override;
-    class procedure DestroyHandle(const AWinControl: TWinControl); override;
-  end;
-  {$endif}

 Const
  ON_PLAYING_INTERVAL = 500 / (24*60*60*1000);
@ -438,19 +435,25 @@ procedure TCustomMPlayerControl.WMPaint(var Message: TLMPaint);
 begin
  Include(FControlState, csCustomPaint);
  inherited WMPaint(Message);
-  if (csDesigning in ComponentState) and (FCanvas<>nil) then begin
-    with FCanvas do begin
-      if Message.DC <> 0 then
-        Handle := Message.DC;
-      Brush.Color:=clLtGray;
-      Pen.Color:=clRed;
-      Rectangle(0,0,Self.Width-1,Self.Height-1);
-      MoveTo(0,0);
-      LineTo(Self.Width,Self.Height);
-      MoveTo(0,Self.Height);
-      LineTo(Self.Width,0);
-      if Message.DC <> 0 then
-        Handle := 0;
+  if (FCanvas<>nil) then begin
+    if (csDesigning in ComponentState) then begin
+      with FCanvas do begin
+        if Message.DC <> 0 then
+          Handle := Message.DC;
+        Brush.Color:=clLtGray;
+        Rectangle(0,0,Self.Width-1,Self.Height-1);
+        Pen.Color:=clRed;
+        Line(0, 0, Self.Width, Self.Height);
+        Line(0, Self.Height, Self.Width, 0);
+        if Message.DC <> 0 then
+          Handle := 0;
+      end;
+    end else
+    begin
+      with FCanvas do begin
+        Brush.Color := clBlack;
+        Rectangle(0,0,Self.Width,Self.Height);
+      end;
    end;
  end;
  Exclude(FControlState, csCustomPaint);
@ -537,6 +540,13 @@ begin
  TControlCanvas(FCanvas).Control := Self;
  SetInitialBounds(0, 0, 160, 90);

+  {$ifdef Linux}
+  FDisplayPanel := TPanel.Create(self);
+  FDisplayPanel.Parent := self;
+  FDisplayPanel.Visible := false;
+  FDisplayPanel.Top := -200;
+  {$endif}
+
  FOutlist := TStringList.Create;

  FMPlayerPath := 'mplayer' + GetExeExt;
@ -639,11 +649,11 @@ begin
  if not FindMPlayerPath then
    raise Exception.Create(MPlayerPath+' not found');

-  {$IFDEF Linux}
-    CurWindowID := GDK_WINDOW_XWINDOW({%H-}PGtkWidget(PtrUInt(Handle))^.window);
+  {$ifdef Linux}
+    CurWindowID := GDK_WINDOW_XWINDOW({%H-}PGtkWidget(PtrUInt(FDisplayPanel.Handle))^.window);
  {$else}
    CurWindowID := Handle;
-  {$ENDIF}
+  {$endif}

  FPlayerProcess := TProcessUTF8.Create(Self);
  FPlayerProcess.Options := FPlayerProcess.Options + [poUsePipes, poNoConsole];
@ -740,7 +750,7 @@ begin
    begin
      if DC <> 0 then
        Handle := DC;
-      Brush.Color := clLtGray;
+      Brush.Color := clBlack;
      Rectangle(0, 0, Self.Width, Self.Height);
      if DC <> 0 then
        Handle := 0;
@ -811,65 +821,7 @@ begin
  end;
 end;

-{$ifdef Linux}
-function MPLayerWidgetDestroyCB(Widget: PGtkWidget; {%H-}data: gPointer): GBoolean; cdecl;
-begin
-  FreeWidgetInfo(Widget); // created in TWSMPlayerControl.CreateHandle
-  Result:=false;
-end;
-
-{ TWSMPlayerControl }
-
-class function TWSMPlayerControl.CreateHandle(const AWinControl: TWinControl;
-  const AParams: TCreateParams): HWND;
-var
-  NewWidget: PGtkWidget;
-  WidgetInfo: PWidgetInfo;
-  Allocation: TGTKAllocation;
-begin
-  if csDesigning in AWinControl.ComponentState then
-    Result:=inherited CreateHandle(AWinControl,AParams)
-  else begin
-    NewWidget:=gtk_event_box_new;
-
-    WidgetInfo := GetWidgetInfo(NewWidget,true); // destroyed in MPLayerWidgetDestroyCB
-    WidgetInfo^.LCLObject := AWinControl;
-    WidgetInfo^.Style := AParams.Style;
-    WidgetInfo^.ExStyle := AParams.ExStyle;
-    WidgetInfo^.WndProc := {%H-}PtrUInt(AParams.WindowClass.lpfnWndProc);
-
-    // set allocation
-    Allocation.X := AParams.X;
-    Allocation.Y := AParams.Y;
-    Allocation.Width := AParams.Width;
-    Allocation.Height := AParams.Height;
-    gtk_widget_size_allocate(NewWidget, @Allocation);
-
-    if csDesigning in AWinControl.ComponentState then begin
-      // at designtime setup normal handlers
-      TGtk2WidgetSet(WidgetSet).FinishCreateHandle(AWinControl,NewWidget,AParams);
-    end else begin
-      // at runtime
-      g_signal_connect(GPointer(NewWidget), 'destroy',
-                       TGTKSignalFunc(@MPLayerWidgetDestroyCB), WidgetInfo);
-    end;
-    Result:=HWND({%H-}PtrUInt(Pointer(NewWidget)));
-    DebugLn(['TWSMPlayerControl.CreateHandle ',dbgs(NewWidget)]);
-  end;
-end;
-
-class procedure TWSMPlayerControl.DestroyHandle(const AWinControl: TWinControl
-  );
-begin
-  inherited DestroyHandle(AWinControl);
-end;
-{$endif}
-
 initialization
-  {$ifdef Linux}
-  RegisterWSComponent(TCustomMPlayerControl,TWSMPlayerControl);
-  {$endif}
-
  {$I mplayerctrl.lrs}
 end.