1 unit uglcContextGtkCustomVisual;
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 }
13 Classes, SysUtils, Controls, LCLType, InterfaceBase, LMessages, WSLCLClasses, WSControls,
14 X, XLib, glib2, gdk2, gdk2x, gtk2, Gtk2Def, Gtk2Int;
17 TCustomVisualControl = class(TWinControl)
19 FIntWidget: PGtkWidget;
22 function WSCreateHandle({%H-}const WSPrivate: TWSPrivateClass; const AParams: TCreateParams): TLCLIntfHandle;
23 procedure WSBeforeDestroyHandle;
25 constructor Create(TheOwner: TComponent; const aVisualID: TVisualID); overload;
26 property Widget: PGtkWidget read FIntWidget;
30 TWSCustomVisualControl = class(TWSWinControl)
32 class function CreateHandle(const AWinControl: TWinControl;
33 const AParams: TCreateParams): TLCLIntfHandle; override;
34 class procedure DestroyHandle(const AWinControl: TWinControl); override;
41 PGtkCustomWidget = ^TGtkCustomWidget;
42 TGtkCustomWidget = record
43 darea: TGtkDrawingArea;
46 PGtkCustomWidgetClass = ^TGtkCustomWidgetClass;
47 TGtkCustomWidgetClass = record
48 parent_class: TGtkDrawingAreaClass;
52 custom_widget_type: TGtkType = 0;
53 custom_widget_parent_class: Pointer = nil;
55 function GTK_TYPE_CUSTOM_WIDGET: TGtkType; forward;
58 procedure g_return_if_fail(b: boolean; const Msg: string);
60 if not b then raise Exception.Create(Msg);
63 procedure g_return_if_fail(b: boolean);
65 g_return_if_fail(b,'');
68 function GTK_IS_CUSTOM_WIDGET(obj: Pointer): Boolean;
70 GTK_IS_CUSTOM_WIDGET:=GTK_CHECK_TYPE(obj,GTK_TYPE_CUSTOM_WIDGET);
73 function GTK_CUSTOM_WIDGET(obj: Pointer): PGtkCustomWidget;
75 g_return_if_fail(GTK_IS_CUSTOM_WIDGET(obj),'');
76 Result:=PGtkCustomWidget(obj);
79 procedure gtk_custom_widget_init(custom_widget: PGTypeInstance; theClass: gpointer); cdecl;
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']);
88 procedure gtk_custom_widget_destroy(obj: PGtkObject); cdecl;
90 g_return_if_fail (obj <>nil,'');
91 g_return_if_fail (GTK_IS_CUSTOM_WIDGET(obj),'');
93 if Assigned(GTK_OBJECT_CLASS(custom_widget_parent_class)^.destroy) then
94 GTK_OBJECT_CLASS(custom_widget_parent_class)^.destroy(obj);
97 procedure gtk_custom_widget_class_init(klass: Pointer); cdecl;
99 object_class: PGtkObjectClass;
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');
106 object_class^.destroy := @gtk_custom_widget_destroy;
109 function custom_widget_size_allocateCB(Widget: PGtkWidget; Size: pGtkAllocation;
110 Data: gPointer): GBoolean; cdecl;
112 CallBackDefaultReturn = {$IFDEF GTK2}false{$ELSE}true{$ENDIF};
115 GtkWidth, GtkHeight: integer;
116 LCLControl: TWinControl;
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.
125 LCLControl:=TWinControl(Data);
126 if LCLControl=nil then exit;
127 //DebugLn(['gtkglarea_size_allocateCB ',DbgSName(LCLControl)]);
129 gtk_widget_get_size_request(Widget, @GtkWidth, @GtkHeight);
132 FillChar(SizeMsg,SizeOf(SizeMsg),0);
137 SizeType := Size_SourceIsInterface;
138 Width := SmallInt(GtkWidth);
139 Height := SmallInt(GtkHeight);
141 //DebugLn(['gtkglarea_size_allocateCB ',GtkWidth,',',GtkHeight]);
142 LCLControl.WindowProc(TLMessage(SizeMsg));
145 function GTK_TYPE_CUSTOM_WIDGET: TGtkType;
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;
156 base_class_init_func: nil;
159 if (custom_widget_type=0) then begin
160 custom_widget_type:=gtk_type_unique(gtk_drawing_area_get_type(),@custom_widget_info);
162 Result:=custom_widget_type;
165 { TCustomVisualControl }
167 constructor TCustomVisualControl.Create(TheOwner: TComponent; const aVisualID: TVisualID);
169 inherited Create(TheOwner);
171 fVisualID:= aVisualID;
172 SetBounds(0, 0, 200, 200);
175 function TCustomVisualControl.WSCreateHandle(const WSPrivate: TWSPrivateClass; const AParams: TCreateParams): TLCLIntfHandle;
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);
188 FIntWidget:= gtk_type_new(GTK_TYPE_CUSTOM_WIDGET);
189 gtk_widget_set_colormap(FIntWidget, cmap);
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);
197 procedure TCustomVisualControl.WSBeforeDestroyHandle;
199 if not HandleAllocated then exit;
203 { TWSCustomVisualControl }
205 class function TWSCustomVisualControl.CreateHandle(const AWinControl: TWinControl; const AParams: TCreateParams): TLCLIntfHandle;
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);
211 Result:= (AWinControl as TCustomVisualControl).WSCreateHandle(WSPrivate, AParams);
214 class procedure TWSCustomVisualControl.DestroyHandle(const AWinControl: TWinControl);
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);
222 RegisterWSComponent(TCustomVisualControl,TWSCustomVisualControl);