OpenGLCore/uglcContextGtkCustomVisual.pas

unit uglcContextGtkCustomVisual;

{ Package:      OpenGLCore
  Prefix:       glc - OpenGL Core
  Beschreibung: diese Unit enthält Klassen zum Erzeugen von Visuals (unter Linux),
                auf denen ein OpenGL Kontext erstellt werden kann }

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Controls, LCLType, InterfaceBase, LMessages, WSLCLClasses, WSControls,
  X, XLib, glib2, gdk2, gdk2x, gtk2, Gtk2Def, Gtk2Int;

type
  TCustomVisualControl = class(TWinControl)
  private
    FIntWidget: PGtkWidget;
    FVisualID: TVisualID;
  protected
    function WSCreateHandle({%H-}const WSPrivate: TWSPrivateClass; const AParams: TCreateParams): TLCLIntfHandle;
    procedure WSBeforeDestroyHandle;
  public
    constructor Create(TheOwner: TComponent; const aVisualID: TVisualID); overload;
    property Widget: PGtkWidget read FIntWidget;
  end;


  TWSCustomVisualControl = class(TWSWinControl)
  published
    class function CreateHandle(const AWinControl: TWinControl;
                                const AParams: TCreateParams): TLCLIntfHandle; override;
    class procedure DestroyHandle(const AWinControl: TWinControl); override;
  end;


implementation

type
  PGtkCustomWidget = ^TGtkCustomWidget;
  TGtkCustomWidget = record
    darea: TGtkDrawingArea;
  end;

  PGtkCustomWidgetClass = ^TGtkCustomWidgetClass;
  TGtkCustomWidgetClass = record
    parent_class: TGtkDrawingAreaClass;
  end;

var
  custom_widget_type: TGtkType = 0;
  custom_widget_parent_class: Pointer = nil;

function GTK_TYPE_CUSTOM_WIDGET: TGtkType; forward;


procedure g_return_if_fail(b: boolean; const Msg: string);
begin
  if not b then raise Exception.Create(Msg);
end;

procedure g_return_if_fail(b: boolean);
begin
  g_return_if_fail(b,'');
end;

function GTK_IS_CUSTOM_WIDGET(obj: Pointer): Boolean;
begin
  GTK_IS_CUSTOM_WIDGET:=GTK_CHECK_TYPE(obj,GTK_TYPE_CUSTOM_WIDGET);
end;

function GTK_CUSTOM_WIDGET(obj: Pointer): PGtkCustomWidget;
begin
  g_return_if_fail(GTK_IS_CUSTOM_WIDGET(obj),'');
  Result:=PGtkCustomWidget(obj);
end;

procedure gtk_custom_widget_init(custom_widget: PGTypeInstance; theClass: gpointer); cdecl;
begin
  if theClass=nil then ;
  //DebugLn(['gtk_custom_widget_init START']);
  gtk_widget_set_double_buffered(PGtkWidget(custom_widget),gdkFALSE);
  GTK_WIDGET_UNSET_FLAGS(PGtkWidget(custom_widget),GTK_NO_WINDOW);
  //DebugLn(['gtk_custom_widget_init END']);
end;

procedure gtk_custom_widget_destroy(obj: PGtkObject); cdecl;
begin
  g_return_if_fail (obj <>nil,'');
  g_return_if_fail (GTK_IS_CUSTOM_WIDGET(obj),'');

  if Assigned(GTK_OBJECT_CLASS(custom_widget_parent_class)^.destroy) then
    GTK_OBJECT_CLASS(custom_widget_parent_class)^.destroy(obj);
end;

procedure gtk_custom_widget_class_init(klass: Pointer); cdecl;
var
  object_class: PGtkObjectClass;
begin
  custom_widget_parent_class := gtk_type_class(gtk_drawing_area_get_type());
  g_return_if_fail(custom_widget_parent_class<>nil,'gtk_custom_widget_class_init parent_class=nil');
  object_class := PGtkObjectClass(klass);
  g_return_if_fail(object_class<>nil,'gtk_custom_widget_class_init object_class=nil');

  object_class^.destroy := @gtk_custom_widget_destroy;
end;

function custom_widget_size_allocateCB(Widget: PGtkWidget; Size: pGtkAllocation;
  Data: gPointer): GBoolean; cdecl;
const
  CallBackDefaultReturn = {$IFDEF GTK2}false{$ELSE}true{$ENDIF};
var
  SizeMsg: TLMSize;
  GtkWidth, GtkHeight: integer;
  LCLControl: TWinControl;
begin
  Result := CallBackDefaultReturn;
  if not GTK_WIDGET_REALIZED(Widget) then begin
    // the widget is not yet realized, so this GTK resize was not a user change.
    // => ignore
    exit;
  end;
  if Size=nil then ;
  LCLControl:=TWinControl(Data);
  if LCLControl=nil then exit;
  //DebugLn(['gtkglarea_size_allocateCB ',DbgSName(LCLControl)]);

  gtk_widget_get_size_request(Widget, @GtkWidth, @GtkHeight);

  SizeMsg.Msg:=0;
  FillChar(SizeMsg,SizeOf(SizeMsg),0);
  with SizeMsg do
  begin
    Result := 0;
    Msg := LM_SIZE;
    SizeType := Size_SourceIsInterface;
    Width := SmallInt(GtkWidth);
    Height := SmallInt(GtkHeight);
  end;
  //DebugLn(['gtkglarea_size_allocateCB ',GtkWidth,',',GtkHeight]);
  LCLControl.WindowProc(TLMessage(SizeMsg));
end;

function GTK_TYPE_CUSTOM_WIDGET: TGtkType;
const
  custom_widget_type_name = 'GtkGLArea';
  custom_widget_info: TGtkTypeInfo = (
    type_name: custom_widget_type_name;
    object_size: SizeOf(TGtkCustomWidget);
    class_size:  SizeOf(TGtkCustomWidgetClass);
    class_init_func:  @gtk_custom_widget_class_init;
    object_init_func: @gtk_custom_widget_init;
    reserved_1: nil;
    reserved_2: nil;
    base_class_init_func: nil;
  );
begin
  if (custom_widget_type=0) then begin
    custom_widget_type:=gtk_type_unique(gtk_drawing_area_get_type(),@custom_widget_info);
  end;
  Result:=custom_widget_type;
end;

{ TCustomVisualControl }

constructor TCustomVisualControl.Create(TheOwner: TComponent; const aVisualID: TVisualID);
begin
  inherited Create(TheOwner);
  FIntWidget:= nil;
  fVisualID:= aVisualID;
  SetBounds(0, 0, 200, 200);
end;

function TCustomVisualControl.WSCreateHandle(const WSPrivate: TWSPrivateClass; const AParams: TCreateParams): TLCLIntfHandle;
var
  cmap: PGdkColormap;
  gdkvis: PGdkVisual;
begin
  // is the requested VisualID different from what the widget would get?
  cmap  := gdk_colormap_get_system;
  gdkvis:= gdk_colormap_get_visual(cmap);
  if XVisualIDFromVisual(gdk_x11_visual_get_xvisual(gdkvis)) <> FVisualID then begin
    gdkvis:= gdkx_visual_get(FVisualID);
    cmap  := gdk_colormap_new(gdkvis, false);
  end;

  FIntWidget:= gtk_type_new(GTK_TYPE_CUSTOM_WIDGET);
  gtk_widget_set_colormap(FIntWidget, cmap);

  Result:= TLCLIntfHandle({%H-}PtrUInt(FIntWidget));
  PGtkobject(FIntWidget)^.flags:= PGtkobject(FIntWidget)^.flags or GTK_CAN_FOCUS;
  TGTK2WidgetSet(WidgetSet).FinishCreateHandle(Self,FIntWidget,AParams);
  g_signal_connect_after(FIntWidget, 'size-allocate', TGTKSignalFunc(@custom_widget_size_allocateCB), Self);
end;

procedure TCustomVisualControl.WSBeforeDestroyHandle;
begin
  if not HandleAllocated then exit;
end;


{ TWSCustomVisualControl }

class function TWSCustomVisualControl.CreateHandle(const AWinControl: TWinControl; const AParams: TCreateParams): TLCLIntfHandle;
begin
  if csDesigning in AWinControl.ComponentState then begin
    // do not use "inherited CreateHandle", because the LCL changes the hierarchy at run time
    Result:= TWSWinControlClass(ClassParent).CreateHandle(AWinControl,AParams);
  end else
    Result:= (AWinControl as TCustomVisualControl).WSCreateHandle(WSPrivate, AParams);
end;

class procedure TWSCustomVisualControl.DestroyHandle(const AWinControl: TWinControl);
begin
  (AWinControl as TCustomVisualControl).WSBeforeDestroyHandle;
  // do not use "inherited DestroyHandle", because the LCL changes the hierarchy at run time
  TWSWinControlClass(ClassParent).DestroyHandle(AWinControl);
end;

initialization
  RegisterWSComponent(TCustomVisualControl,TWSCustomVisualControl);

end.