uglcContextGtkCustomVisual.pas

   1 unit uglcContextGtkCustomVisual;
   2
   3 { Package:      OpenGLCore
   4   Prefix:       glc - OpenGL Core
   5   Beschreibung: diese Unit enthält Klassen zum Erzeugen von Visuals (unter Linux),
   6                 auf denen ein OpenGL Kontext erstellt werden kann }
   7
   8 {$mode objfpc}{$H+}
   9
  10 interface
  11
  12 uses
  13   Classes, SysUtils, Controls, LCLType, InterfaceBase, LMessages, WSLCLClasses, WSControls,
  14   X, XLib, glib2, gdk2, gdk2x, gtk2, Gtk2Def, Gtk2Int;
  15
  16 type
  17   TCustomVisualControl = class(TWinControl)
  18   private
  19     FIntWidget: PGtkWidget;
  20     FVisualID: TVisualID;
  21   protected
  22     function WSCreateHandle({%H-}const WSPrivate: TWSPrivateClass; const AParams: TCreateParams): TLCLIntfHandle;
  23     procedure WSBeforeDestroyHandle;
  24   public
  25     constructor Create(TheOwner: TComponent; const aVisualID: TVisualID); overload;
  26     property Widget: PGtkWidget read FIntWidget;
  27   end;
  28
  29
  30   TWSCustomVisualControl = class(TWSWinControl)
  31   published
  32     class function CreateHandle(const AWinControl: TWinControl;
  33                                 const AParams: TCreateParams): TLCLIntfHandle; override;
  34     class procedure DestroyHandle(const AWinControl: TWinControl); override;
  35   end;
  36
  37
  38 implementation
  39
  40 type
  41   PGtkCustomWidget = ^TGtkCustomWidget;
  42   TGtkCustomWidget = record
  43     darea: TGtkDrawingArea;
  44   end;
  45
  46   PGtkCustomWidgetClass = ^TGtkCustomWidgetClass;
  47   TGtkCustomWidgetClass = record
  48     parent_class: TGtkDrawingAreaClass;
  49   end;
  50
  51 var
  52   custom_widget_type: TGtkType = 0;
  53   custom_widget_parent_class: Pointer = nil;
  54
  55 function GTK_TYPE_CUSTOM_WIDGET: TGtkType; forward;
  56
  57
  58 procedure g_return_if_fail(b: boolean; const Msg: string);
  59 begin
  60   if not b then raise Exception.Create(Msg);
  61 end;
  62
  63 procedure g_return_if_fail(b: boolean);
  64 begin
  65   g_return_if_fail(b,'');
  66 end;
  67
  68 function GTK_IS_CUSTOM_WIDGET(obj: Pointer): Boolean;
  69 begin
  70   GTK_IS_CUSTOM_WIDGET:=GTK_CHECK_TYPE(obj,GTK_TYPE_CUSTOM_WIDGET);
  71 end;
  72
  73 function GTK_CUSTOM_WIDGET(obj: Pointer): PGtkCustomWidget;
  74 begin
  75   g_return_if_fail(GTK_IS_CUSTOM_WIDGET(obj),'');
  76   Result:=PGtkCustomWidget(obj);
  77 end;
  78
  79 procedure gtk_custom_widget_init(custom_widget: PGTypeInstance; theClass: gpointer); cdecl;
  80 begin
  81   if theClass=nil then ;
  82   //DebugLn(['gtk_custom_widget_init START']);
  83   gtk_widget_set_double_buffered(PGtkWidget(custom_widget),gdkFALSE);
  84   GTK_WIDGET_UNSET_FLAGS(PGtkWidget(custom_widget),GTK_NO_WINDOW);
  85   //DebugLn(['gtk_custom_widget_init END']);
  86 end;
  87
  88 procedure gtk_custom_widget_destroy(obj: PGtkObject); cdecl;
  89 begin
  90   g_return_if_fail (obj <>nil,'');
  91   g_return_if_fail (GTK_IS_CUSTOM_WIDGET(obj),'');
  92
  93   if Assigned(GTK_OBJECT_CLASS(custom_widget_parent_class)^.destroy) then
  94     GTK_OBJECT_CLASS(custom_widget_parent_class)^.destroy(obj);
  95 end;
  96
  97 procedure gtk_custom_widget_class_init(klass: Pointer); cdecl;
  98 var
  99   object_class: PGtkObjectClass;
 100 begin
 101   custom_widget_parent_class := gtk_type_class(gtk_drawing_area_get_type());
 102   g_return_if_fail(custom_widget_parent_class<>nil,'gtk_custom_widget_class_init parent_class=nil');
 103   object_class := PGtkObjectClass(klass);
 104   g_return_if_fail(object_class<>nil,'gtk_custom_widget_class_init object_class=nil');
 105
 106   object_class^.destroy := @gtk_custom_widget_destroy;
 107 end;
 108
 109 function custom_widget_size_allocateCB(Widget: PGtkWidget; Size: pGtkAllocation;
 110   Data: gPointer): GBoolean; cdecl;
 111 const
 112   CallBackDefaultReturn = {$IFDEF GTK2}false{$ELSE}true{$ENDIF};
 113 var
 114   SizeMsg: TLMSize;
 115   GtkWidth, GtkHeight: integer;
 116   LCLControl: TWinControl;
 117 begin
 118   Result := CallBackDefaultReturn;
 119   if not GTK_WIDGET_REALIZED(Widget) then begin
 120     // the widget is not yet realized, so this GTK resize was not a user change.
 121     // => ignore
 122     exit;
 123   end;
 124   if Size=nil then ;
 125   LCLControl:=TWinControl(Data);
 126   if LCLControl=nil then exit;
 127   //DebugLn(['gtkglarea_size_allocateCB ',DbgSName(LCLControl)]);
 128
 129   gtk_widget_get_size_request(Widget, @GtkWidth, @GtkHeight);
 130
 131   SizeMsg.Msg:=0;
 132   FillChar(SizeMsg,SizeOf(SizeMsg),0);
 133   with SizeMsg do
 134   begin
 135     Result := 0;
 136     Msg := LM_SIZE;
 137     SizeType := Size_SourceIsInterface;
 138     Width := SmallInt(GtkWidth);
 139     Height := SmallInt(GtkHeight);
 140   end;
 141   //DebugLn(['gtkglarea_size_allocateCB ',GtkWidth,',',GtkHeight]);
 142   LCLControl.WindowProc(TLMessage(SizeMsg));
 143 end;
 144
 145 function GTK_TYPE_CUSTOM_WIDGET: TGtkType;
 146 const
 147   custom_widget_type_name = 'GtkGLArea';
 148   custom_widget_info: TGtkTypeInfo = (
 149     type_name: custom_widget_type_name;
 150     object_size: SizeOf(TGtkCustomWidget);
 151     class_size:  SizeOf(TGtkCustomWidgetClass);
 152     class_init_func:  @gtk_custom_widget_class_init;
 153     object_init_func: @gtk_custom_widget_init;
 154     reserved_1: nil;
 155     reserved_2: nil;
 156     base_class_init_func: nil;
 157   );
 158 begin
 159   if (custom_widget_type=0) then begin
 160     custom_widget_type:=gtk_type_unique(gtk_drawing_area_get_type(),@custom_widget_info);
 161   end;
 162   Result:=custom_widget_type;
 163 end;
 164
 165 { TCustomVisualControl }
 166
 167 constructor TCustomVisualControl.Create(TheOwner: TComponent; const aVisualID: TVisualID);
 168 begin
 169   inherited Create(TheOwner);
 170   FIntWidget:= nil;
 171   fVisualID:= aVisualID;
 172   SetBounds(0, 0, 200, 200);
 173 end;
 174
 175 function TCustomVisualControl.WSCreateHandle(const WSPrivate: TWSPrivateClass; const AParams: TCreateParams): TLCLIntfHandle;
 176 var
 177   cmap: PGdkColormap;
 178   gdkvis: PGdkVisual;
 179 begin
 180   // is the requested VisualID different from what the widget would get?
 181   cmap  := gdk_colormap_get_system;
 182   gdkvis:= gdk_colormap_get_visual(cmap);
 183   if XVisualIDFromVisual(gdk_x11_visual_get_xvisual(gdkvis)) <> FVisualID then begin
 184     gdkvis:= gdkx_visual_get(FVisualID);
 185     cmap  := gdk_colormap_new(gdkvis, false);
 186   end;
 187
 188   FIntWidget:= gtk_type_new(GTK_TYPE_CUSTOM_WIDGET);
 189   gtk_widget_set_colormap(FIntWidget, cmap);
 190
 191   Result:= TLCLIntfHandle({%H-}PtrUInt(FIntWidget));
 192   PGtkobject(FIntWidget)^.flags:= PGtkobject(FIntWidget)^.flags or GTK_CAN_FOCUS;
 193   TGTK2WidgetSet(WidgetSet).FinishCreateHandle(Self,FIntWidget,AParams);
 194   g_signal_connect_after(FIntWidget, 'size-allocate', TGTKSignalFunc(@custom_widget_size_allocateCB), Self);
 195 end;
 196
 197 procedure TCustomVisualControl.WSBeforeDestroyHandle;
 198 begin
 199   if not HandleAllocated then exit;
 200 end;
 201
 202
 203 { TWSCustomVisualControl }
 204
 205 class function TWSCustomVisualControl.CreateHandle(const AWinControl: TWinControl; const AParams: TCreateParams): TLCLIntfHandle;
 206 begin
 207   if csDesigning in AWinControl.ComponentState then begin
 208     // do not use "inherited CreateHandle", because the LCL changes the hierarchy at run time
 209     Result:= TWSWinControlClass(ClassParent).CreateHandle(AWinControl,AParams);
 210   end else
 211     Result:= (AWinControl as TCustomVisualControl).WSCreateHandle(WSPrivate, AParams);
 212 end;
 213
 214 class procedure TWSCustomVisualControl.DestroyHandle(const AWinControl: TWinControl);
 215 begin
 216   (AWinControl as TCustomVisualControl).WSBeforeDestroyHandle;
 217   // do not use "inherited DestroyHandle", because the LCL changes the hierarchy at run time
 218   TWSWinControlClass(ClassParent).DestroyHandle(AWinControl);
 219 end;
 220
 221 initialization
 222   RegisterWSComponent(TCustomVisualControl,TWSCustomVisualControl);
 223
 224 end.
 225