paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-25 17:02:40 +02:00
Code Issues Packages Projects Releases Wiki Activity
f088b13a3e
lazarus/lcl/interfaces/gtk/gtkobject.inc
michael f088b13a3e + Initial import 
git-svn-id: trunk@2 -
2000-07-13 10:28:31 +00:00

3373 lines
116 KiB
PHP
Raw Blame History

(******************************************************************************
TGTKObject
******************************************************************************)
const
BOOL_RESULT: array[Boolean] of String = ('False', 'True');
{------------------------------------------------------------------------------
Method: TGtkObject.Create
Params: None
Returns: Nothing
Contructor for the class.
------------------------------------------------------------------------------}
constructor TGtkObject.Create;
begin
inherited Create;
FCaptureHandle := 0;
FKeyStateList := TList.Create;
FDeviceContexts := TList.Create;
FGDIObjects := TList.Create;
FMessageQueue := TList.Create;
FAccelGroup := gtk_accel_group_new();
end;
{------------------------------------------------------------------------------
Method: Tgtkobject.Destroy
Params: None
Returns: Nothing
Destructor for the class.
------------------------------------------------------------------------------}
destructor TgtkObject.Destroy;
var
n: Integer;
p: PMsg;
begin
if (FDeviceContexts.Count > 0) or (FGDIObjects.Count > 0)
then begin
WriteLN(Format('[TgtkObject.Destroy] WARNING: There are %d unreleased DCs and %d unreleased GDIObjects' ,[FDeviceContexts.Count, FGDIObjects.Count]));
end;
if FMessageQueue.Count > 0
then begin
WriteLN(Format('[TgtkObject.Destroy] WARNING: There are %d messages left in the queue! I''ll free them' ,[FMessageQueue.Count]));
for n := 0 to FMessageQueue.Count - 1 do
begin
p := PMsg(FMessageQueue.Items[n]);
Dispose(P);
end;
end;
FMessageQueue.Free;
FDeviceContexts.Free;
FGDIObjects.Free;
FKeyStateList.Free;
gtk_accel_group_unref(FAccelGroup);
inherited Destroy;
end;
{------------------------------------------------------------------------------
Method: TGtkObject,HandleEvents
Params: None
Returns: Nothing
*Note: Passes execution control to the GTK engine
------------------------------------------------------------------------------}
procedure TgtkObject.HandleEvents;
var
Msg: TMsg;
begin
//gtk_main;
gtk_main_iteration_do(True);
//Should we handle this ???
with FMessageQueue do
while Count > 0 do
begin
Msg := PMsg(Items[0])^;
Delete(0);
with Msg do
SendMessage(hWND, Message, WParam, LParam);
end;
end;
{------------------------------------------------------------------------------
Method: TGtkObject.DoEvents
Params: None
Returns: Nothing
*Note: Tells GTK Engine to process pending events
------------------------------------------------------------------------------}
procedure TgtkObject.DoEvents;
begin
// dont block waiting for an event
//gtk_main_iteration_do(False);
gtk_main_iteration;
end;
{------------------------------------------------------------------------------
Method: TGtkObject.AppTerminate
Params: None
Returns: Nothing
*Note: Tells GTK Engine to halt and destroy
------------------------------------------------------------------------------}
procedure TGtkObject.AppTerminate;
begin
gdk_Cursor_Destroy(Cursor_Watch);
gdk_Cursor_Destroy(Cursor_Arrow);
gdk_Cursor_Destroy(Cursor_Cross);
gdk_Cursor_Destroy(Cursor_Hand1);
gdk_Cursor_Destroy(Cursor_XTerm);
gtk_object_unref(PGTKObject(FGTKToolTips));
FGTKToolTips := nil;
gtk_main_quit;
end;
{------------------------------------------------------------------------------
Method: TGtkObject.Init
Params: None
Returns: Nothing
*Note: Initialite GTK engine
------------------------------------------------------------------------------}
procedure TGtkObject.Init;
begin
{ initialize app level gtk engine }
gtk_set_locale ();
{ call init and pass no args}
gtk_init (@argc, @argv);
//Create default cursor types
Cursor_Watch := gdk_Cursor_New(gdk_Watch);
Cursor_Arrow := gdk_Cursor_New(gdk_Arrow);
Cursor_Cross := gdk_Cursor_New(gdk_Cross);
Cursor_Hand1 := gdk_Cursor_New(gdk_Hand1);
Cursor_XTerm := gdk_Cursor_New(gdk_XTerm);
gtk_key_snooper_install(@GTKKeySnooper, @FKeyStateList);
// Init tooltips
FGTKToolTips := gtk_tooltips_new;
gtk_object_ref(PGTKObject(FGTKToolTips));
gtk_toolTips_Enable(FGTKToolTips);
end;
{------------------------------------------------------------------------------
Method: TGtkObject.IntSendMessage3
Params: LM_Message - message to be processed by GTK
Sender - sending control
data - pointer to (optional)
Returns: depends on the message and the sender
Processes messages from different components.
WARNING: the result of this function sometimes is not always really an
integer!!!!!
------------------------------------------------------------------------------}
function TgtkObject.IntSendMessage3(LM_Message : Integer; Sender : TObject; data : pointer) : integer;
var
pStr : PChar;
pStr2 : PChar;
TempStr : string;
GList : pGList;
Widget : PGtkWidget;
SelectionMode : TGtkSelectionMode;
AOwner : TControl;
AParent: TWinControl;
Pixmap : pgdkPixMap;
PenColor : TColor;
TheStyle : pgtkStyle;
fWindow :pGdkWindow;
gc : pgdkGC;
p: Pointer;
Num : Integer;
ListItem : PGtkListItem;
box1 : pgtkWidget;
pixmapwid : pGtkWidget;
mask : pGDKBitmap;
style : pgtkStyle;
pLabel : PgtkWidget;
begin
result := 0; //default value just in case nothing sets it
Assert(False, 'Trace:Message recieved');
if Sender <> nil then
Assert(False, Format('Trace:[TgtkObject.IntSendMessage3] %s --> Sent LM_Message: $%x (%s); Data: %d', [Sender.ClassName, LM_Message, GetMessageName(LM_Message), Integer(data)]));
case LM_Message of
LM_Create :
begin
Assert(False, 'Trace:Callling CreateComponent');
CreateComponent(Sender);
Assert(False, 'Trace:Called CreateComponent');
end;
LM_AddChild :
begin
Assert(False, 'Trace:Adding a child to Parent');
If (TWinControl(Sender).Parent is TToolbar) then
Begin
// Assert(False, Format('Trace:[TgtkObject.IntSendMessage3] %s --> %s ---calling INSERTBUTTON from Add Child', [AParent.ClassName, Sender.ClassNAme]));
exit;
end
else
Begin
AParent := (Sender as TWinControl).Parent;
Assert(False, Format('Trace:[TgtkObject.IntSendMessage3] %s --> Calling Add Child: %s', [AParent.ClassName, Sender.ClassNAme]));
AddChild(Pgtkwidget(AParent.Handle), PgtkWidget((Sender as TWinControl).Handle), AParent.Left, AParent.Top);
end;
end;
LM_BRINGTOFRONT:
begin
Assert(False, 'Trace:TODO:bringtofront');
end;
LM_BTNDEFAULT_CHANGED :
Begin
if (TButton(Sender).Default) and (GTK_WIDGET_CAN_DEFAULT(pgtkwidget(TButton(Sender).handle))) then
gtk_widget_grab_default(pgtkwidget(TButton(Sender).handle))
else
gtk_widget_Draw_Default(pgtkwidget(TButton(Sender).Handle)); //this isn't right but I'm not sure what to call
end;
LM_DESTROY :
begin
if (Sender is TTimer) then
begin
Assert(False, 'Trace:removing timer!!!');
gtk_timeout_remove((Sender as TTimer).TimerID);
end
else begin
if Sender is TWinControl
then gtk_widget_destroy( PGtkWidget(TWinControl(Sender).Handle))
else begin
if (Sender is TCustomDialog)
then gtk_widget_destroy( PGtkWidget(TCustomDialog(Sender).Handle));
end;
end;
end;
LM_DRAGINFOCHANGED :
Begin
(*
if ((Sender is TEdit) and((Sender as TEdit).DragMode = dmAutoMatic)) then
Begin
//drag and drop
gtk_drag_dest_set (p,
GTK_DEST_DEFAULT_ALL,
target_table, TargetEntrys - 1,
GDK_ACTION_COPY or GDK_ACTION_MOVE);
gtk_signal_connect( PgtkObject(p), 'drag_data_received',
TGTKSignalFunc( @edit_drag_data_received), Sender);
gtk_drag_source_set (p, GDK_BUTTON1_MASK,
target_table, TargetEntrys,
GDK_ACTION_COPY or GDK_ACTION_MOVE);
gtk_drag_source_set_icon (p,
gtk_widget_get_colormap (pgtkwidget(p)),
drag_icon, drag_mask);
gtk_signal_connect (GTK_OBJECT (p), 'drag_data_get',
GTK_SIGNAL_FUNC (@Edit_source_drag_data_get), Sender);
gtk_signal_connect (GTK_OBJECT (p), 'drag_data_delete',
GTK_SIGNAL_FUNC (@Edit_source_drag_data_delete), Sender);
end
else
Begin
//drag and drop
gtk_drag_dest_set (p,
GTK_DEST_DEFAULT_ALL,
target_table, TargetEntrys - 1,
GDK_ACTION_COPY or GDK_ACTION_MOVE);
gtk_signal_connect( PgtkObject(p), 'drag_data_received',
TGTKSignalFunc( @edit_drag_data_received), Sender);
gtk_drag_source_set (p, GDK_BUTTON1_MASK,
target_table, TargetEntrys,
GDK_ACTION_COPY or GDK_ACTION_MOVE);
gtk_drag_source_set_icon (p,
gtk_widget_get_colormap (pgtkwidget(p)),
drag_icon, drag_mask);
gtk_signal_connect (GTK_OBJECT (p), 'drag_data_get',
GTK_SIGNAL_FUNC (@Edit_source_drag_data_get), Sender);
gtk_signal_connect (GTK_OBJECT (p), 'drag_data_delete',
GTK_SIGNAL_FUNC (@Edit_source_drag_data_delete), Sender);
end;
*)
end;
//TBitBtn
LM_IMAGECHANGED, LM_LAYOUTCHANGED :
Begin
Assert(False, 'Trace:********************');
Widget := PgtkWidget(TBitBtn(Sender).Handle);
Assert(False, 'Trace:1');
box1 := gtk_object_get_data(pgtkObject(widget),'HBox');
if box1 <> nil then
begin
Assert(False, 'Trace:REMOVING THE HBOX');
gtk_container_remove(PgtkContainer(box1),gtk_object_get_data(pgtkObject(widget),'Label'));
gtk_container_remove(PgtkContainer(box1),gtk_object_get_data(pgtkObject(widget),'Pixmap'));
gtk_container_remove(PgtkContainer(widget),box1);
gtk_widget_destroy(box1);
end;
if (TBitBtn(Sender).Layout = blGlyphLeft) or (TBitBtn(Sender).Layout = blGlyphRight) then
Begin
Assert(False, 'Trace:GLYPHLEFT or GLYPHRIGHT');
box1 := gtk_hbox_new(False,0);
end
else Begin
Assert(False, 'Trace:GLYPHTOP or GLYPHBOTTOM');
box1 := gtk_vbox_new(False,0);
end;
Assert(False, 'Trace:2');
pixmap := pgdkPixmap(PgdiObject(TBitBtn(Sender).Glyph.handle)^.GDIBitmapObject);
Assert(False, 'Trace:3');
if PgdiObject(TBitBtn(Sender).Glyph.handle)^.GDIBitmapMaskObject <> nil
then pixmapwid := gtk_pixmap_new(pixmap,PgdiObject(TBitBtn(Sender).Glyph.handle)^.GDIBitmapMAskObject)
else pixmapwid := gtk_pixmap_new(pixmap,nil);
Assert(False, 'Trace:4');
TempStr := TBitBtn(Sender).Caption;
pStr := StrAlloc(length(TempStr) + 1);
StrPCopy(pStr, TempStr);
pLabel := gtk_label_new(pstr);
StrDispose(pStr);
Assert(False, 'Trace:5');
if (TBitBtn(Sender).Layout = blGlyphLeft) or (TBitBtn(Sender).Layout = blGlyphTop) then
begin
Assert(False, 'Trace:GLYPHLEFT or GLYPHTOP');
gtk_box_pack_start(pGTKBox(Box1),pixmapwid,False,False,TBitBtn(Sender).Spacing);
gtk_box_pack_start(pGTKBox(Box1),pLabel,False,False,TBitBtn(Sender).Spacing);
end
else begin
Assert(False, 'Trace:GLYPHRIGHT or GLYPHBOTTOM');
gtk_box_pack_start(pGTKBox(Box1),pLabel,False,False,TBitBtn(Sender).Spacing);
gtk_box_pack_start(pGTKBox(Box1),pixmapwid,False,False,TBitBtn(Sender).Spacing);
end;
Assert(False, 'Trace:6');
gtk_object_set_data(pgtkObject(widget),'Label',pLabel);
gtk_object_set_data(pgtkObject(widget),'HBox',Box1);
gtk_object_set_data(pgtkObject(widget),'Pixmap',pixmapwid);
Assert(False, 'Trace:7');
gtk_widget_show(pixmapwid);
gtk_widget_show(pLabel);
gtk_container_add(PgtkContainer(widget),box1);
gtk_widget_show(box1);
Assert(False, 'Trace:********************');
end;
LM_LOADXPM:
Begin
if (sender is TBitmap) then
Begin
Assert(False, 'Trace:pixmap name '+strpas(data));
pixmap := gdk_pixmap_create_from_xpm(PdeviceContext(TBitmap(sender).handle)^.drawable,nil,nil,pchar(data));
Assert(False, 'Trace:1');
if Pixmap = nil
then Assert(False, 'Trace:PIXMAP NOT LOADED!');
PdeviceContext(TBitmap(sender).handle)^.CurrentBitmap :=pgdiObject(pixmap);
end;
end;
LM_TB_BUTTONCOUNT:
begin
if (Sender is TToolbar)
then Result := pgtkToolbar(TToolbar(Sender).handle)^.num_Children
else Result := -1;
end;
LM_SETENABLED:
begin
if (sender is TWincontrol)
then gtk_widget_set_sensitive(pgtkwidget(TWinControl(sender).handle),TControl(sender).Enabled)
else
if (sender is TMenuItem)
then gtk_widget_set_sensitive(pgtkwidget(TMenuItem(sender).handle),TMenuItem(sender).Enabled)
else Assert(False, 'Trace:***************NOT SUPPORTED*******************');
end;
LM_SETFILTER :
begin
pStr := StrAlloc(length(TFileDialog(Sender).Filter) + 1);
StrPCopy(pStr, TFileDialog(Sender).Filter);
gtk_file_selection_complete(PGtkFileSelection((Sender as TCustomDialog).Handle), pstr);
StrDispose(pStr);
end;
LM_SETFILENAME :
begin
pStr := StrAlloc(length(TFileDialog(Sender).Filename) + 1);
StrPCopy(pStr, TFileDialog(Sender).Filename);
gtk_file_selection_set_filename( PGtkFileSelection((Sender as TCustomDialog).Handle), pStr);
StrDispose(pStr);
end;
LM_SETFOCUS:gtk_widget_grab_focus(PgtkWidget(TWinControl(sender).handle));
LM_SetSize :
begin
Assert(False, Format('Trace:[TgtkObject.IntSendMessage3] %s --> LM_SetSize(%d, %d, %d, %d)', [Sender.ClassNAme, pTRect(Data)^.Left,pTRect(Data)^.Top,pTRect(Data)^.Right,pTRect(Data)^.Bottom]));
ResizeChild(Sender,pTRect(Data)^.Left,pTRect(Data)^.Top,pTRect(Data)^.Right,pTRect(Data)^.Bottom);
end;
LM_SetText :
begin
SetText(PgtkWidget((Sender as TWinControl).Handle), Data);
end;
LM_SETCOLOR: SetColor(Sender);
LM_SETPixel: SetPixel(Sender,Data);
LM_GETPixel: GetPixel(Sender,Data);
LM_ShowHide :
begin
Assert(False, Format('Trace:[TgtkObject.IntSendMessage3] %s --> Show/Hide', [Sender.ClassNAme]));
ShowHide(Sender);
end;
LM_ShowModal :
begin
if Sender is TCustomForm then
begin
Widget:= PgtkWidget(TCustomForm(Sender).Handle);
end
else begin
Widget:= PgtkWidget(TCustomDialog(Sender).Handle);
pStr:= StrAlloc(Length(TCustomDialog(Sender).Title) + 1);
try
StrPCopy(pStr, TCustomDialog(Sender).Title);
gtk_window_set_title(PGtkWindow(Widget), pStr);
finally
StrDispose(pStr);
end;
end;
gtk_window_set_position(PGtkWindow(Widget), GTK_WIN_POS_CENTER);
gtk_widget_show(Widget);
gtk_window_set_modal(PGtkWindow(Widget), true);
{ Don't grab anything - this is done by gtk_window_set_modal }
//gtk_grab_add(PgtkWidget(TWinControl(Sender).Handle));
end;
LM_SetCursor : SetCursor(Sender);
LM_SetLabel :
begin
SetLabel(Sender,Data);
end;
LM_ReDraw :
begin
Assert(False, Format('Trace:[TgtkObject.IntSendMessage3] %s --> Redraw', [Sender.ClassName]));
if (Sender is TCanvas) then
ReDraw(PgtkWidget((Sender as TCanvas).Handle))
else
if not (sender is TSpeedbutton) then
ReDraw(PgtkWidget((Sender as TWinControl).Handle))
else
(Sender as TSpeedButton).perform(LM_PAINT,0,0);
end;
LM_AddPage :
begin
Assert(False, Format('Trace:[TgtkObject.IntSendMessage3] %s --> Add NB page: %s', [Sender.ClassName, TLMNotebookEvent(Data^).Child.ClassName]));
AddNBPage(TControl(Sender), TLMNotebookEvent(Data^).Child, TLMNotebookEvent(Data^).Page);
end;
LM_RemovePage :
begin
RemoveNBPage(TControl(Sender), TLMNotebookEvent(Data^).Page);
end;
LM_ShowTabs :
begin
gtk_notebook_set_show_tabs(PGtkNotebook(TWinControl(Sender).Handle), Boolean(Integer(TLMNotebookEvent(Data^).ShowTabs)));
end;
LM_SetTabPosition :
begin
case TTabPosition(TLMNotebookEvent(Data^).TabPosition^) of
tpTop : gtk_notebook_set_tab_pos(PGtkNotebook(TWinControl(Sender).Handle), GTK_POS_TOP);
tpBottom: gtk_notebook_set_tab_pos(PGtkNotebook(TWinControl(Sender).Handle), GTK_POS_BOTTOM);
tpLeft : gtk_notebook_set_tab_pos(PGtkNotebook(TWinControl(Sender).Handle), GTK_POS_LEFT);
tpRight : gtk_notebook_set_tab_pos(PGtkNotebook(TWinControl(Sender).Handle), GTK_POS_RIGHT);
end;
end;
LM_INSERTTOOLBUTTON:
begin
Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!!!!!!!!');
Assert(False, 'Trace:Toolbutton being inserted');
Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!!!!!!!!');
If (SENDER is TWINCONTROL) Then
Begin
pStr := StrAlloc(Length(ttoolbutton(SENDER).Caption)+1);
StrPCopy(pStr,ttoolbutton(SENDER).Caption);
pStr2 := StrAlloc(Length(tcontrol(Sender).Hint)+1);
StrPCopy(pStr2,tcontrol(Sender).Hint);
end
else Begin
raise Exception.Create('Can not assign this control to the toolbar');
exit;
end;
num := TToolbar(TWinControl(Sender).parent).Buttonlist.IndexOf(TControl(Sender));
if num < 0 then Num := TToolbar(TWinControl(Sender).parent).Buttonlist.Count+1;
Assert(False, Format('Trace:NUM = %d in INSERTBUTTON',[num]));
{Make sure it's created!!}
if TWinControl(Sender).handle = 0
then IntSendMessage3(LM_CREATE,Sender,nil);
gtk_toolbar_insert_widget(pGTKToolbar(TWinControl(sender).parent.Handle),
pgtkwidget(tWinControl(Sender).handle),pstr,pStr2,Num);
StrDispose(pStr);
StrDispose(pStr2);
Assert(False, 'Trace:!!!!!!!!!!!!!!!!!!!!!!!!!');
end;
LM_DELETETOOLBUTTON:
Begin
with pgtkToolbar(TToolbar(TWinControl(Sender).parent).handle)^ do
children := g_list_remove(pgList(children), sender);
// pgtkToolbar(TToolbar(TWinControl(Sender).parent).handle)^.children :=
// g_list_remove(pgList(pgtkToolbar(TToolbar(TWinControl(Sender).parent).handle)^.children),
// sender);
end;
LM_Invalidate :
begin
Assert(False, 'Trace:Trying to invalidate window... !!!');
//THIS DOESN'T WORK YET....
{
Event.thetype := GDK_EXPOSE;
Event.window := PgtkWidget((Sender as TWinControl).Handle)^.Window;
Event.Send_Event := 0;
Event.X := 0;
Event.Y := 0;
Event.Width := PgtkWidget((Sender as TWinControl).Handle)^.Allocation.Width;
Event.Height := PgtkWidget((Sender as TWinControl).Handle)^.Allocation.Height;
gtk_Signal_Emit_By_Name(PgtkObject((Sender as TWinControl).Handle),'expose_event',[(Sender as TWinControl).Handle,Sender,@Event]);
Assert(False, 'Trace:Signal Emitted - invalidate window');
}
gtk_widget_queue_draw(PGtkWidget((Sender as TWinControl).Handle));
end;
LM_InvalidateRect :
begin
//Erase and then write over that section in the rect
PixMap := gtk_object_get_data(PgtkObject((Sender as TWinControl).Handle),'Pixmap');
if Assigned(PixMap) then
begin
PenColor := TCustomForm(Sender).Color;
gdk_draw_rectangle(pixmap,GetPen(pixmap,TColortoTgdkColor(PenColor)),1,TREct(data^).Left,TRect(data^).Top,TRect(Data^).Right-TRect(Data^).Left,TRect(Data^).Bottom-TRect(Data^).Top);
gtk_widget_queue_draw(PGtkWidget((Sender as TWinControl).Handle));
//The following should eventually be implemented. It's supposed
// to allow the component to ONLY draw the invalidated rectangle, not the entire widget.
{ widget := gtk_Object_get_data(pgtkobject((Sender as TWinControl).Handle),'Fixed');
fWindow := pGtkWidget(widget)^.window;
gc := gdk_gc_new(PgdkWindow(fWindow));
TheStyle := widget^.TheStyle;
gdk_draw_pixmap(fwindow,TheStyle^.fg_gc[GTK_WIDGET_STATE (widget)],
pixmap,
TRect(data^).Left,TRect(data^).Top,
TRect(data^).Left,TRect(data^).Top,
TRect(data^).Right -TRect(data^).Left,TRect(data^).Bottom - TRect(data^).Top);
}
end;
end;
LM_SCREENINIT :
begin
{ Initialize gdk }
//??? shouldn't this go to init ????
gdk_init(@argc, @argv);
//???--????
{ Compute pixels per inch variable }
PLMScreenInit(Data)^.PixelsPerInchX:= Round(gdk_screen_width / (gdk_screen_width_mm / 25.4));
PLMScreenInit(Data)^.PixelsPerInchY:= Round(gdk_screen_height / (gdk_screen_height_mm / 25.4));
PLMScreenInit(Data)^.ColorDepth:= gdk_visual_get_system^.depth;
end;
LM_GETITEMS :
begin
if (Sender as TControl).fCompStyle = csCListBox
then begin
Widget:= GetCoreChildWidget(PGtkWidget((Sender as TWinControl).Handle));
Data := TGtkCListStringList.Create(PGtkCList(Widget));
Result := integer(Data);
end
else begin
case (Sender as TControl).fCompStyle of
csComboBox : Widget:= PGtkCombo((Sender as TWinControl).Handle)^.list;
csListBox : Widget:= GetCoreChildWidget(PGtkWidget((Sender as TWinControl).Handle));
else
raise Exception.Create('Message LM_GETITEMS - Not implemented');
end;
Data:= TGtkListStringList.Create(PGtkList(Widget));
Result:= Integer(Data);
end;
end;
LM_GETTEXT :
begin
Assert (true, 'WARNING:[TgtkObject.IntSendMessage3] usage of LM_GETTEXT superfluous, use interface-function GetText instead');
Result := integer (nil);
end;
LM_GETITEMINDEX :
begin
case (Sender as TControl).fCompStyle of
csListBox:
begin
if TListBox(Sender).MultiSelect then
Widget:= PGtkList(GetCoreChildWidget(PGtkWidget(TWinControl(Sender).Handle)))^.last_focus_child
else begin
GList:= PGtkList(GetCoreChildWidget(PGtkWidget(TWinControl(Sender).Handle)))^.selection;
if GList = nil
then Widget:= nil
else Widget:= PGtkWidget(GList^.data);
end;
if Widget = nil
then Result:= -1
else Result:= gtk_list_child_position(PGtkList(GetCoreChildWidget(PGtkWidget(TWinControl(Sender).Handle))), Widget);
end;
csCListBox:
begin
GList:= PGtkCList(GetCoreChildWidget(PGtkWidget(TWinControl(Sender).Handle)))^.selection;
if GList = nil
then Result := -1
else Result := integer(GList^.Data);
end;
csNotebook:
begin
TLMNotebookEvent(Data^).Page := gtk_notebook_get_current_page(PGtkNotebook(TWinControl(Sender).Handle));
end;
end;
end;
LM_SETITEMINDEX :
begin
case (Sender as TControl).fCompStyle of
csComboBox:
gtk_list_select_item(PGTKLIST(PGTKCOMBO(TWinControl(Sender).Handle)^.list), Integer(Data));
csListBox:
gtk_list_select_item(PGtkList(GetCoreChildWidget(PGtkWidget(TWinControl(Sender).Handle))), Integer(Data));
csCListBox:
gtk_clist_select_row(
PGtkCList(GetCoreChildWidget(PGtkWidget(TWinControl(Sender).Handle))),
Integer(Data),
1); // column
csNotebook:
begin
Assert(False, 'Trace:Setting Page to ' + IntToStr(TLMNotebookEvent(Data^).Page));
gtk_notebook_set_page(PGtkNotebook(TWinControl(Sender).Handle), TLMNotebookEvent(Data^).Page);
end;
end;
end;
LM_GETSELSTART :
begin
if (Sender as TControl).fCompStyle = csComboBox then
begin
Result:= gtk_editable_get_position(PGtkEditable(PGtkCombo((Sender as TWinControl).Handle)^.entry));
end;
end;
LM_GETSELLEN :
begin
if (Sender as TControl).fCompStyle = csComboBox then
begin
Result:= PGtkEditable(PGtkCombo((Sender as TWinControl).Handle)^.entry)^.selection_end_pos -
PGtkEditable(PGtkCombo((Sender as TWinControl).Handle)^.entry)^.selection_start_pos;
end;
end;
LM_GETLIMITTEXT :
begin
if (Sender as TControl).fCompStyle = csComboBox then
begin
Result:= PGtkEntry(PGtkCombo((Sender as TWinControl).Handle)^.entry)^.text_max_length;
end;
end;
LM_SETSELSTART :
begin
if (Sender is TControl) and (TControl(Sender).fCompStyle = csComboBox) then
begin
gtk_editable_set_position(PGtkEditable(PGtkCombo(TWinControl(Sender).Handle)^.entry), Integer(Data));
end;
end;
LM_SETSELLEN :
begin
if (Sender is TControl) and (TControl(Sender).fCompStyle = csComboBox) then
begin
gtk_editable_select_region(PGtkEditable(PGtkCombo(TWinControl(Sender).Handle)^.entry),
gtk_editable_get_position(PGtkEditable(PGtkCombo(TWinControl(Sender).Handle)^.entry)),
gtk_editable_get_position(PGtkEditable(PGtkCombo(TWinControl(Sender).Handle)^.entry)) + Integer(Data));
end;
end;
LM_GetLineCount :
begin
end;
LM_GETSELCOUNT :
begin
case (Sender as TControl).fCompStyle of
csListBox : Result:= g_list_length(PGtkList(GetCoreChildWidget(PGtkWidget((Sender as TWinControl).Handle)))^.selection);
csCListBox: Result:= g_list_length(PGtkCList(GetCoreChildWidget(PGtkWidget((Sender as TWinControl).Handle)))^.selection);
end;
end;
LM_GETSEL :
begin
if (Sender as TWinControl).fCompStyle = csListBox then
begin
{ Get the child in question of that index }
ListItem:= g_list_nth_data(PGtkList(GetCoreChildWidget(PGtkWidget(TWinControl(Sender).Handle)))^.children, Integer(Data^));
Result:= g_list_index(PGtkList(GetCoreChildWidget(PGtkWidget(TWinControl(Sender).Handle)))^.selection, ListItem);
end
else if (Sender as TControl).fCompStyle = csCListBox then
begin
{ Get the selections }
GList:= PGtkCList(GetCoreChildWidget(PGtkWidget(
(Sender as TWinControl).Handle)))^.selection;
Result := -1; { assume: nothing found }
while Assigned(GList) and (result = -1) do
begin
if integer(GList^.data) = integer(Data^)
then Result := 0
else GList := GList^.Next;
end;
end;
end;
LM_SETLIMITTEXT :
begin
if (Sender is TControl) and (TControl(Sender).fCompStyle = csComboBox)
then gtk_entry_set_max_length(PGtkEntry(PGtkCombo(TWinControl(Sender).Handle)^.entry), Integer(Data^));
end;
LM_SORT :
begin
if (Sender is TControl) and assigned (data) then
begin
case TControl(Sender).fCompStyle of
csComboBox,
csListBox : TGtkListStringList(TLMSort(Data^).List).Sorted:= TLMSort(Data^).IsSorted;
csCListBox : TGtkCListStringList(TLMSort(Data^).List).Sorted := TLMSort(Data^).IsSorted;
end
end
end;
LM_SETSEL :
begin
if (Sender is TControl) and
(TControl(Sender).fCompStyle in [csListBox, csCListBox]) and
assigned (data) then
begin
if (TControl(Sender).fCompStyle = csListBox) then
begin
if TLMSetSel(Data^).Selected
then gtk_list_select_item(PGtkList(GetCoreChildWidget(PGtkWidget(TWinControl(Sender).Handle))), TLMSetSel(Data^).Index)
else gtk_list_unselect_item(PGtkList(GetCoreChildWidget(PGtkWidget(TWinControl(Sender).Handle))), TLMSetSel(Data^).Index);
end
else if (TControl(Sender).fCompStyle = csCListBox) then
begin
if TLMSetSel(Data^).Selected
then gtk_clist_select_row(PGtkCList(GetCoreChildWidget(PGtkWidget(TWinControl(Sender).Handle))),TLMSetSel(Data^).Index,0)
else gtk_clist_unselect_row(PGtkCList(GetCoreChildWidget(PGtkWidget(TWinControl(Sender).Handle))),TLMSetSel(Data^).Index,0);
end;
end;
end;
LM_SETSELMODE :
begin
if (Sender is TControl) and
(TControl(Sender).fCompStyle in [csListBox, csCListBox]) and
assigned (data) then
begin
if TLMSetSelMode(Data^).MultiSelect then
begin
if TLMSetSelMode(Data^).ExtendedSelect
then SelectionMode:= GTK_SELECTION_EXTENDED
else SelectionMode:= GTK_SELECTION_MULTIPLE;
end
else
SelectionMode:= GTK_SELECTION_BROWSE;
case (Sender as TControl).fCompStyle of
csListBox : gtk_list_set_selection_mode(PGtkList(GetCoreChildWidget(PGtkWidget(TWinControl(Sender).Handle))), SelectionMode);
csCListBox : gtk_clist_set_selection_mode(PGtkCList(GetCoreChildWidget(PGtkWidget(TWinControl(Sender).Handle))),SelectionMode);
else
Assert (true, 'WARNING:[TgtkObject.IntSendMessage3] usage of LM_SETSELMODE unimplemented for actual component');
end;
end;
end;
LM_SETBORDER :
begin
if (Sender is TControl) and (TControl(Sender).fCompStyle = csListBox) then
begin
{ In TempWidget, a viewport is stored }
Widget:= PGtkWidget(PGtkBin(TWinControl(Sender).Handle)^.child);
if TListBox(Sender).BorderStyle = TBorderStyle(bsSingle)
then gtk_viewport_set_shadow_type(PGtkViewPort(Widget), GTK_SHADOW_IN)
else gtk_viewport_set_shadow_type(PGtkViewPort(Widget), GTK_SHADOW_NONE);
end;
if (Sender as TControl).fCompStyle = csCListBox
then begin
if TListBox(Sender).BorderStyle = TBorderStyle(bsSingle)
then
gtk_clist_set_shadow_type(
PGtkCList(GetCoreChildWidget(PGtkWidget(TWinControl(Sender).Handle))),
GTK_SHADOW_IN)
else
gtk_clist_set_shadow_type(
PGtkCList(GetCoreChildWidget(PGtkWidget(TWinControl(Sender).Handle))),
GTK_SHADOW_NONE);
end;
end;
LM_GETVALUE: Result := GetValue (Sender, data);
LM_SETVALUE: Result := SetValue (Sender, data);
LM_SETPROPERTIES: Result := SetProperties(Sender);
LM_ATTACHMENU: AttachMenu(Sender);
else
Assert(True, Format ('WARNING: Unhandled message %d in IntSendMessage3 send by %s --> message:Redraw', [LM_Message, Sender.ClassName]));
// unhandled message
end;
end;
{------------------------------------------------------------------------------
Function: TGtkObject.GetText
Params: Sender: The control to retrieve the text from
Returns: the requested text
Retrieves the text from a gtk control. this is a replacement for
the LM_GetText message.
------------------------------------------------------------------------------}
function TGtkObject.GetText(Sender: TControl; var Text: String): Boolean;
var
CS: PChar;
begin
Result := True;
case Sender.fCompStyle of
csComboBox: Text := StrPas(gtk_entry_get_text(PGtkEntry(PGtkCombo((Sender as TWinControl).Handle)^.entry)));
csEdit : Text := StrPas(gtk_entry_get_text(PgtkEntry((Sender as TWinControl).Handle)));
csMemo : begin
CS := gtk_editable_get_chars(PGtkEditable(GetCoreChildWidget(PGtkWidget((Sender as TWinControl).Handle))), 0, -1);
Text := StrPas(CS);
g_free(CS);
end;
else
Result := False;
end;
end;
{------------------------------------------------------------------------------
Method: TGtkObject.ResizeChild
Params: sender - the object which invoked this function
Left,Top,Width,Height - new dimensions for the control
Returns: Nothing
*Note: Resize a child widget on the parents fixed widget
------------------------------------------------------------------------------}
procedure TgtkObject.ResizeChild(Sender : TObject;Left,Top,Width,Height : Integer);
var
pFixed: PGTKFixed;
pWidget: PGTKWidget;
Parent: TWinControl;
begin
Assert(false, (Format('trace:[TgtkObject.ResizeChild] %s --> Resize', [Sender.ClassNAme])));
Parent := TControl(Sender).Parent;
if not (Sender is TSpeedButton) then
begin
pWidget := pgtkWidget(TWinControl(Sender).Handle);
gtk_widget_set_usize(pWidget, Width, Height);
if not ((Parent = nil) or (Sender is TCustomForm)) then
begin
pFixed := GetFixedWidget(PGtkWidget(Parent.Handle));
if pFixed <> nil
then gtk_fixed_move(pFixed, pWidget, Left, Top)
else Assert(False, 'Trace:ERROR!!!! - no Fixed Widget found to use when resizing....');
end
else begin
gtk_widget_set_uposition(pWidget, Left, Top);
end;
end
end;
{------------------------------------------------------------------------------
Method: TGtkObject.AddChild
Params: parent -
child -
left, top -
Returns: Nothing
*Note: Adds A Child to a Parent Widget
------------------------------------------------------------------------------}
procedure TgtkObject.AddChild(Parent,Child : Pointer; Left,Top: Integer);
var
pFixed: PGTKFixed;
begin
Assert(False, 'Trace:ADDCHILD');
pFixed := GetFixedWidget(PGtkWidget(Parent));
if pFixed <> nil
then gtk_fixed_put(pFixed, Child, Left, Top);
// gtk_object_set_data(PgtkObject(Child),'Owner',Parent);
end;
{------------------------------------------------------------------------------
Method: TGtkObject.SetText
Params: Child -
data -
Returns: Nothing
Sets the text of a control.
WARNING: This should possibly be merged with the SetLabel method!
It's only left in here for TStatusBar right now cause it
may be nice to use it with different panels.
------------------------------------------------------------------------------}
procedure TgtkObject.SetText(Child, Data: Pointer);
type
pMsg = ^TLMSetControlText;
var
pStr: PChar;
begin
case pMsg(Data)^.fCompStyle of
csStatusBar : gtk_statusbar_push(PGTKStatusBar(Child),pMsg(Data)^.Panel,pMsg(Data)^.Userdata);
else
writeln ('STOPPOK: [TGtkObject.SetText] Possible superfluous use of SetText, use SetLabel instead!');
end;
{STOPPOK: Code seems superfluous, see SetLabel instead
// Stoppok: Hmm, this cast looks quite dangerous if the code above is also valid
case TLMNotebookEvent(Data^).fCompStyle of
csNotebook :
begin
writeln ('STOPPOK: [TGtkObject.SetText] Notebook: Why the hell are we getting here?');
pStr := StrAlloc(Length(TLMNotebookEvent(Data^).Str) + 1);
StrPCopy(pStr, TLMNotebookEvent(Data^).Str);
gtk_notebook_set_tab_label_text(PGtkNotebook(TWinControl(TLMNotebookEvent(Data^).Parent).handle),
PGtkWidget(TWinControl(TLMNotebookEvent(Data^).Child).handle),
pStr);
end;
end;
}
end;
{------------------------------------------------------------------------------
Method: TGtkObject.SetCursor
Params: Sender - the control which invoked this method
Returns: Nothing
Sets the cursor for a widget
WARNING: Sender will be casted to TControl, CLEANUP!
------------------------------------------------------------------------------}
procedure TgtkObject.SetCursor(Sender : TObject);
var CursorType : Integer;
begin
Assert(False, 'Trace:IN SETCURSOR');
If not(Sender is TWinControl) or(TWinControl(Sender).Handle = 0) then EXIT;
Assert(False, 'Trace:IN SETCURSOR CASE STATEMENT');
case TControl(Sender).Cursor of
crAppStart : gdk_window_set_cursor (pgtkWidget(TWinControl(Sender).Handle)^.window, Cursor_Watch);
crArrow : gdk_window_set_cursor (pgtkWidget(TWinControl(Sender).Handle)^.window, Cursor_Arrow);
crCross : gdk_window_set_cursor (pgtkWidget(TWinControl(Sender).Handle)^.window, Cursor_Cross);
crHandPoint: gdk_window_set_cursor (pgtkWidget(TWinControl(Sender).Handle)^.window, Cursor_hand1);
crIBeam : gdk_window_set_cursor (pgtkWidget(TWinControl(Sender).Handle)^.window, Cursor_XTerm);
// crDefault : CursorType := GDK_Arrow;
else
Exit;
end;
end;
{------------------------------------------------------------------------------
Method: TGtkObject.SetLabel
Params: sender - the calling object
data - String (PChar) to be set as label for a control
Returns: Nothing
Sets the label text on a widget
------------------------------------------------------------------------------}
procedure TgtkObject.SetLabel(Sender : TObject; Data : Pointer);
var
P : Pointer;
pLabel: pchar;
begin
if Sender is TWinControl
then Assert(False, Format('Trace:[TgtkObject.SetLabel] %s --> label %s', [Sender.ClassName, TControl(Sender).Caption]))
else Assert(False, Format('Trace:WARNING: [TgtkObject.SetLabel] %s --> No Decendant of TWinControl', [Sender.ClassName]));
P := Pointer(TWinControl(Sender).Handle);
Assert(p = nil, 'Trace:WARNING: [TgtkObject.SetLabel] --> got nil pointer');
Assert(False, 'Trace:Setting Str1 in SetLabel');
pLabel := pchar(Data);
case TControl(Sender).fCompStyle of
csBitBtn : IntSendMessage3(LM_IMAGECHANGED,SENDER,nil);
csButton,
csToolButton : with PgtkButton(P)^ do
begin
if Child = nil then
begin
Assert(False, Format('trace:[TgtkObject.SetLabel] %s has no child label', [Sender.ClassName]));
child := gtk_label_new(pLabel)
end
else begin
Assert(False, Format('trace:[TgtkObject.SetLabel] %s has child label', [Sender.ClassName]));
gtk_label_set_text(pgtkLabel(Child), PLabel);
end;
end;
csForm,
csFileDialog,
csColorDialog,
csFontDialog : gtk_window_set_title(pGtkWindow(p),PLabel);
csLabel : gtk_label_set_text(pGtkLabel(p), pLabel);
csCheckBox : gtk_label_set_text(pGtkLabel( pgtkCheckButton(p)^.Toggle_Button.Button.Child),pLabel);
csGroupBox : gtk_frame_set_label(pgtkFrame(P),pLabel);
csEdit : gtk_entry_set_text(pGtkEntry(P),pLabel);
csMemo : begin
P := GetCoreChildWidget(P);
gtk_text_freeze(PGtkText(P));
gtk_text_set_point(PGtkText(P), 0);
gtk_text_forward_delete(
PGtkText(P),
gtk_text_get_length(PGtkText(P)));
gtk_text_insert(PGtkText(P), nil, nil, nil, pLabel, -1);
gtk_text_thaw(PGtkText(P));
end;
csPage : gtk_notebook_set_tab_label_text(PGtkNotebook((TWinControl(Sender).Parent).handle),
PGtkWidget(P),
PGChar(data));
//GET? WHY should this be right? p := gtk_notebook_get_tab_label(PGTKNoteBook(TWinControl(Sender).Parent.Handle), P);
csComboBox : gtk_entry_set_text(PGtkEntry(PGtkCombo(P)^.entry), PLabel);
else
Assert(True, Format ('WARNING: [TgtkObject.SetLabel] --> not handled for class %s ', [Sender.ClassName]));
end;
Assert(False, Format('trace:[TgtkObject.SetLabel] %s --> END', [Sender.ClassName]));
end;
{------------------------------------------------------------------------------}
{ TGtkObject SetColor }
{ *Note: Changes the form's default background color }
{------------------------------------------------------------------------------}
procedure TgtkObject.SetColor(Sender : TObject);
{var
TheStyle : pGtkStyle;
widget : pgtkWidget;
NewColor : TgdkColor;}
begin
if Sender is TWincontrol
then with TWincontrol(Sender) do
begin
// Temphack to set backcolor, till better solution
if HandleAllocated then SetBKColor(Handle, ColorToRGB(Color));
end;
// OBSOLETE
//NOT USED RIGHT NOW..........CAUSES ALL FORMS TO USE THESE COLORS!!!!!!
{
widget := TCustomForm(Sender).handle;
TheStyle := pgtkWidget(widget)^.thestyle;
NewColor := ConvertTogdk(TCustomForm(Sender).Color);
gdk_color_alloc (gdk_colormap_get_system (), @NewColor);
gdk_gc_set_foreground (TheStyle^.fg_gc[GTK_STATE_NORMAL], @NewColor);
gdk_gc_set_background (TheStyle^.fg_gc[GTK_STATE_NORMAL], @NewColor);
}
end;
{------------------------------------------------------------------------------
Function: ObjectToGTKObject
Params: AObject: A LCL Object
Returns: The GTKObject of the given object
Returns the GTKObject of the given object, nil if no object available
------------------------------------------------------------------------------}
function ObjectToGTKObject(const AObject: TObject): gtk_object;
begin
if AObject is TWinControl
then
Result := gtk_Object(TWinControl(AObject).Handle)
else
if AObject is TControlCanvas
then
Result := gtk_Object(TControlCanvas(AObject).Handle)
else
if AObject is TMenuItem
then
Result := gtk_Object(TMenuItem(AObject).Handle)
else
Result := nil;
end;
{------------------------------------------------------------------------------
Function: TGTKObject.SetCallback
Params: Msg - message for which to set a callback
sender - object to which callback will be send
Returns: nothing
Applies a Message to the sender
------------------------------------------------------------------------------}
procedure TGTKObject.SetCallback(Msg : LongInt; Sender : TObject);
procedure ConnectSignal(const AObject:gtk_Object; const ASignal: PChar; const ACallBackProc: Pointer; const ReqSignalMask: TGdkEventMask);
var
RealizeHandler, Handler: PGTKHandler;
RealizeID, SignalID: guint;
begin
if ACallBackProc <> nil then
begin
// first loop though the handlers to:
// - check if a handler already exists
// - Find the realize handler to change data
Handler := gtk_object_get_data_by_id (AObject, gtk_handler_quark);
SignalID := gtk_signal_lookup(ASignal, GTK_OBJECT_TYPE(AObject));
RealizeID := gtk_signal_lookup('realize', GTK_OBJECT_TYPE(AObject));
RealizeHandler := nil;
while (Handler <> nil) do
with Handler^ do
begin
//look for realize handler
if (Id > 0) and
(Signal_ID = RealizeID) and
(Func = TGTKSignalFunc(@GTKRealizeCB))
then RealizeHandler := Handler;
if (Id > 0) and
(Signal_ID = SignalID) and
(Func = TGTKSignalFunc(ACallBackProc)) and
(func_data = Pointer(Sender))
then begin
Assert(False, Format('Trace:WARNING: [TGTKObject.SetCallback] %s signal <%s> set twice', [Sender.ClassName, ASignal]));
Exit;
end;
Handler := Next;
end;
// if we are here no handler was defined yet
Assert(False, Format('trace:[TGTKObject.SetCallback] %s signal <%s>', [Sender.ClassName, ASignal]));
gtk_signal_connect(AObject, ASignal, TGTKSignalFunc(ACallBackProc), Sender);
if ReqSignalMask <> 0 then
begin
if RealizeHandler = nil
then gtk_signal_connect(AObject, 'realize', TGTKSignalFunc(@GTKRealizeCB), Pointer(ReqSignalMask))
else TGdkEventMask(RealizeHandler^.func_data) := TGdkEventMask(RealizeHandler^.func_data) or ReqSignalMask;
end;
end;
end;
procedure ConnectSignal(const AObject:gtk_Object; const ASignal: PChar; const ACallBackProc: Pointer);
begin
ConnectSignal(AObject, ASignal, ACallBackProc, 0);
end;
var
gObject, gFixed: PGTKObject;
begin
gObject := ObjectToGTKObject(Sender);
if gObject = nil then Exit;
gFixed := PGTKObject(GetFixedWidget(gObject));
if gFixed = nil then gFixed := gObject;
case Msg of
LM_SHOWWINDOW :
begin
ConnectSignal(gObject, 'show', @gtkshowCB);
ConnectSignal(gObject, 'hide', @gtkhideCB);
end;
LM_DESTROY :
begin
ConnectSignal(gObject, 'destroy', @gtkdestroyCB);
end;
LM_CLOSEQUERY :
begin
ConnectSignal(gObject, 'delete-event', @gtkdeleteCB);
end;
LM_ACTIVATE :
begin
ConnectSignal(gObject, 'activate', @gtkactivateCB);
end;
LM_ACTIVATEITEM :
begin
ConnectSignal(gObject, 'activate-item', @gtkactivateCB);
end;
LM_CHANGED :
if sender is TTrackBar
then ConnectSignal(gtk_Object(gtk_range_get_adjustment(GTK_RANGE(gObject))) , 'value_changed', @gtkvaluechanged)
else if sender is TNotebook
then ConnectSignal(gObject, 'switch-page', @gtkswitchpage)
else if sender is TCustomCombobox
then ConnectSignal (PGtkObject(PGtkCombo(gobject)^.entry), 'changed', @gtkchangedCB)
else
ConnectSignal(gObject, 'changed', @gtkchangedCB);
LM_CLICKED :
begin
Assert(False, 'Trace:OBSOLETE: [TGTKObject.SetCallback] LM_CLICKED');
ConnectSignal(gObject, 'clicked', @gtkclickedCB);
end;
LM_CONFIGUREEVENT :
begin
ConnectSignal(gObject, 'configure-event', @gtkconfigureevent);
end;
LM_PAINT :
begin
// ConnectSignal(gFixed, 'show', @GTKDrawDefault);
ConnectSignal(gFixed, 'expose-event', @GTKExposeEvent);
ConnectSignal(gFixed, 'draw', @GTKDraw);
end;
LM_EXPOSEEVENT :
begin
// ConnectSignal(gFixed, 'expose-event', @gtkexposeevent)
end;
LM_FOCUS :
begin
//ConnectSignal(gObject, 'focus', @gtkfocusCB);
ConnectSignal(gObject, 'focus-in-event', @gtkFocusCB);
ConnectSignal(gObject, 'focus-out-event', @gtkKillFocusCB);
end;
LM_KEYDOWN,
LM_CHAR,
LM_KEYUP,
LM_SYSKEYDOWN,
LM_SYSCHAR,
LM_SYSKEYUP:
begin
ConnectSignal(gFixed, 'key-press-event', @GTKKeyUpDown, GDK_KEY_PRESS_MASK);
ConnectSignal(gFixed, 'key-release-event', @GTKKeyUpDown, GDK_KEY_RELEASE_MASK);
end;
LM_MOUSEMOVE:
begin
ConnectSignal(gFixed, 'motion-notify-event', @GTKMotionNotify, GDK_POINTER_MOTION_MASK)
end;
LM_PRESSED :
begin
Assert(False, 'Trace:OBSOLETE: [TGTKObject.SetCallback] LM_PRESSED');
ConnectSignal(gObject, 'pressed', @gtkpressedCB);
end;
LM_RELEASED :
begin
Assert(False, 'Trace:OBSOLETE: [TGTKObject.SetCallback] LM_RELEASED');
ConnectSignal(gObject, 'released', @gtkreleasedCB);
end;
LM_MOVECURSOR :
begin
ConnectSignal(gObject, 'move-cursor', @gtkmovecursorCB);
end;
LM_LBUTTONDOWN,
LM_RBUTTONDOWN,
LM_MBUTTONDOWN,
LM_MOUSEWHEEL :
begin
ConnectSignal(gFixed, 'button-press-event', @gtkmousebtnpress, GDK_BUTTON_PRESS_MASK);
end;
LM_LBUTTONUP,
LM_RBUTTONUP,
LM_MBUTTONUP:
begin
ConnectSignal(gFixed, 'button-release-event', @gtkmousebtnrelease, GDK_BUTTON_RELEASE_MASK);
end;
LM_ENTER :
begin
if sender is TButton
then ConnectSignal(gObject, 'enter', @gtkenterCB)
else ConnectSignal(gObject, 'focus-in-event', @gtkFocusInNotifyCB); //TODO: check this focus in is mapped to focus
end;
LM_EXIT :
begin
if sender is TButton
then ConnectSignal(gObject, 'leave', @gtkleaveCB)
else ConnectSignal(gObject, 'focus-out-event', @gtkFocusOutNotifyCB);
end;
LM_LEAVE :
begin
ConnectSignal(gObject, 'leave', @gtkleaveCB);
end;
LM_WINDOWPOSCHANGED: //LM_SIZEALLOCATE, LM_RESIZE :
begin
ConnectSignal(gObject, 'size-allocate', @gtksize_allocateCB);
end;
LM_CHECKRESIZE :
begin
ConnectSignal(gObject, 'check-resize', @gtkresizeCB);
end;
LM_INSERTTEXT :
begin
ConnectSignal(gObject, 'insert-text', @gtkinserttext);
end;
LM_DELETETEXT :
begin
ConnectSignal(gObject, 'delete-text', @gtkdeletetext);
end;
LM_SETEDITABLE :
begin
ConnectSignal(gObject, 'set-editable', @gtkseteditable);
end;
LM_MOVEWORD :
begin
ConnectSignal(gObject, 'move-word', @gtkmoveword);
end;
LM_MOVEPAGE :
begin
ConnectSignal(gObject, 'move-page', @gtkmovepage);
end;
LM_MOVETOROW :
begin
ConnectSignal(gObject, 'move-to-row', @gtkmovetorow);
end;
LM_MOVETOCOLUMN :
begin
ConnectSignal(gObject, 'move-to-column', @gtkmovetocolumn);
end;
LM_KILLCHAR :
begin
ConnectSignal(gObject, 'kill-char', @gtkkillchar);
end;
LM_KILLWORD :
begin
ConnectSignal(gObject, 'kill-word', @gtkkillword);
end;
LM_KILLLINE :
begin
ConnectSignal(gObject, 'kill-line', @gtkkillline);
end;
LM_CUTTOCLIP :
begin
ConnectSignal(gObject, 'cut-clipboard', @gtkcuttoclip);
end;
LM_COPYTOCLIP :
begin
ConnectSignal(gObject, 'copy-clipboard', @gtkcopytoclip);
end;
LM_PASTEFROMCLIP :
begin
ConnectSignal(gObject, 'paste-clipboard', @gtkpastefromclip);
end;
LM_HSCROLL:
begin
ConnectSignal(PGTKObject(gtk_scrolled_window_get_hadjustment(PGTKScrolledWindow(gObject))), 'value-changed', @GTKHScrollCB);
end;
LM_VSCROLL:
begin
ConnectSignal(PGTKObject(gtk_scrolled_window_get_vadjustment(PGTKScrolledWindow(gObject))), 'value-changed', @GTKVScrollCB);
end;
(*
LM_WINDOWPOSCHANGED:
begin
ConnectSignal(gObject, 'size-allocate', @gtkSizeAllocateCB);
// ConnectSignal(gObject, 'move_resize', @gtkmoveresize);
end;
*)
else
Assert(False, Format('Trace:ERROR: Signal %d not found!', [Msg]));
end;
end;
{------------------------------------------------------------------------------
Function: TGTKObject.RemoveCallBacks
Params: sender - object for which ro remove callbacks
Returns: nothing
Removes Call Back Signals from the sender
------------------------------------------------------------------------------}
procedure TGTKObject.RemoveCallbacks(Sender : TObject);
var
gObject : gtk_Object;
begin
gObject := ObjectToGTKObject(Sender);
if gObject = nil then Exit;
gtk_signal_handlers_destroy(gObject);
end;
{------------------------------------------------------------------------------
Function: TGTKObject.CreateComponent
Params: sender - object for which to create visual representation
Returns: nothing
Tells GTK Engine to create a widget
------------------------------------------------------------------------------}
procedure TgtkObject.CreateComponent(Sender : TObject);
const
FormStyleMap : array[TFormBorderStyle] of integer = (
GTK_WINDOW_DIALOG, GTK_WINDOW_TOPLEVEL, GTK_WINDOW_TOPLEVEL,
GTK_WINDOW_TOPLEVEL, GTK_WINDOW_POPUP, GTK_WINDOW_POPUP
);
FormSizeableMap : array[TFormBorderStyle] of gint = (0, 0, 1, 0, 0, 1);
FormBorderWidth : array[TFormBorderStyle] of gint = (0, 1, 2, 1, 1, 2);
type
Tpixdata = Array[1..20] of String;
var
caption : string;
StrTemp : PChar;
TempWidget : PGTKWidget;
p : pointer;
CompStyle, TempInt : Integer;
Adjustment: PGTKAdjustment;
//for csBitBtn
box1 : pgtkWidget;
pixmap : pGdkPixMap;
pixmapwid : pGtkWidget;
mask : pGDKBitmap;
style : pgtkStyle;
label1 : pgtkwidget;
TempStr : String;
pStr : PChar;
Pixdata : TPixData;
tmp_key : Integer;
menu_accel : pointer;
begin
Assert(False, 'Trace:In CreateComponet');
p := nil;
if (Sender is TControl)
then caption := TControl(Sender).caption
else if (Sender is TMenuItem)
then caption := TMenuItem(Sender).caption
else
caption := 'Unknown';
// the following is for debug only
if caption = '' then caption := Sender.ClassName;
Assert(False, 'Trace:----------------------Creating component in TgtkObject- STR = '+caption+'-');
// until here remove when debug not needed
if caption = '' then caption := 'Blank';
strTemp := StrAlloc(length(caption) + 1);
StrPCopy(strTemp, caption);
Assert(False, 'Trace:1');
if (Sender is TControl)
then CompStyle := TControl(Sender).FCompStyle
else if (Sender is TTimer)
then CompStyle := csTimer
else if (Sender is TMenu)
then CompStyle := TMenu(Sender).FCompStyle
else if (Sender is TMenuItem)
then CompStyle := TMenuItem(Sender).FCompStyle
else if (Sender is TCustomDialog)
then CompStyle := TCustomDialog(Sender).FCompStyle
else
Compstyle := csNone;
case CompStyle of
csAlignment :
begin
p := gtk_alignment_new(0.5,0.5,0,0);
gtk_widget_show(p);
end;
csBitBtn :
begin
Assert(False, 'Trace:CSBITBTN CREATE*************************');
p := gtk_button_new;
box1 := gtk_hbox_new(False,0);
gtk_container_set_border_width(PgtkContainer(box1),2);
style := gtk_widget_get_style(pGTKWidget(p));
TempStr := './images/menu.xpm';
pStr := StrAlloc(length(TempStr) + 1);
StrPCopy(pStr, TempStr);
pixmap := gdk_pixmap_create_from_xpm(pgtkWidget(p)^.window, @Mask,
@style^.bg[GTK_STATE_NORMAL],pStr);
StrDispose(pStr);
pixmapwid := gtk_pixmap_new(pixmap,mask);
label1 := gtk_label_new(StrTemp);
gtk_box_pack_start(pGTkBox(Box1),pixmapwid,False,False,3);
gtk_box_pack_start(pGTkBox(box1), label1, FALSE, FALSE, 3);
gtk_widget_show(pixmapwid);
gtk_widget_show(label1);
gtk_Container_add(PgtkContainer(p),box1);
gtk_widget_show(box1);
gtk_object_set_data(pgtkObject(p),'HBox',box1);
gtk_object_set_data(pgtkObject(p),'Pixmap',PixMapwid);
gtk_object_set_data(pgtkObject(p),'Label',Label1);
Assert(False, 'Trace:CSBITBTN CREATE EXITING*************************');
end;
csButton :
begin
p := gtk_button_new_with_label(StrTemp);
end;
csCheckbox :
begin
p := gtk_check_button_new_with_label(strTemp);
end;
csComboBox :
begin
p := gtk_combo_new();
gtk_entry_set_text(PGtkEntry(PGtkCombo(p)^.entry), StrTemp);
end;
csListBox :
begin
p:= gtk_scrolled_window_new(nil, nil);
GTK_WIDGET_UNSET_FLAGS(PGtkScrolledWindow(p)^.hscrollbar, GTK_CAN_FOCUS);
GTK_WIDGET_UNSET_FLAGS(PGtkScrolledWindow(p)^.vscrollbar, GTK_CAN_FOCUS);
gtk_scrolled_window_set_policy(PGtkScrolledWindow(p), GTK_POLICY_AUTOMATIC, GTK_POLICY_AUTOMATIC);
gtk_widget_show(p);
TempWidget:= gtk_list_new;
gtk_scrolled_window_add_with_viewport(PGtkScrolledWindow(p), TempWidget);
gtk_container_set_focus_vadjustment(PGtkContainer(TempWidget),
gtk_scrolled_window_get_vadjustment(PGtkScrolledWindow(p)));
gtk_container_set_focus_hadjustment(PGtkContainer(TempWidget),
gtk_scrolled_window_get_hadjustment(PGtkScrolledWindow(p)));
gtk_widget_show(TempWidget);
SetCoreChildWidget(p, TempWidget);
SetMainWidget(p, TempWidget);
end;
csCListBox :
begin
Assert(False, 'Trace:!!!!!!!!!!!!!!!! Creating Clist box !!!!!!!!!!!!!!');
p:= gtk_scrolled_window_new(nil, nil);
GTK_WIDGET_UNSET_FLAGS(PGtkScrolledWindow(p)^.hscrollbar,
GTK_CAN_FOCUS);
GTK_WIDGET_UNSET_FLAGS(PGtkScrolledWindow(p)^.vscrollbar,
GTK_CAN_FOCUS);
gtk_scrolled_window_set_policy(PGtkScrolledWindow(p),
GTK_POLICY_AUTOMATIC,
GTK_POLICY_AUTOMATIC);
gtk_widget_show(p);
with Sender as TCListBox
do begin
TempWidget:= gtk_clist_new(ListColumns);
gtk_container_add(PGtkContainer(p), TempWidget);
for TempInt := 0 to ListColumns - 1 do
gtk_clist_set_column_width(PGtkCList(TempWidget), TempInt, (Width-50) div ListColumns);
end;
gtk_widget_show(TempWidget);
SetCoreChildWidget(p, TempWidget);
SetMainWidget(p, TempWidget);
end;
csEdit :
begin
p := gtk_entry_new();
end;
csFileDialog :
begin
P := gtk_file_selection_new(StrTemp);
{****This is a major hack put by Cliff Baeseman to solve
a gtk win32 dll implementation problem where the headers implementation
does not match the linux version**** }
{$ifdef LINUX}
gtk_signal_connect( gtk_object((PGtkFileSelection(P))^.ok_button), 'clicked', gtk_signal_func(@gtkDialogOKclickedCB), Sender);
gtk_signal_connect( gtk_object((PGtkFileSelection(P))^.cancel_button), 'clicked', gtk_signal_func(@gtkDialogCancelclickedCB), Sender);
{$endif}
{$ifdef WIN32}
gtk_signal_connect( gtk_object((PGtkFileSelection(P))^.cancel_button), 'clicked', gtk_signal_func(@gtkDialogOKclickedCB), Sender);
gtk_signal_connect( gtk_object((PGtkFileSelection(P))^.help_button), 'clicked', gtk_signal_func(@gtkDialogCancelclickedCB), Sender);
{$endif}
gtk_signal_connect( gtk_object(P), 'destroy', gtk_Signal_Func(@gtkDialogDestroyCB), Sender);
end;
csColorDialog :
begin
P := gtk_color_selection_dialog_new(StrTemp);
// We will only add this line if we see problem in the future with the color dialog MAH 7-31-99
// gtk_color_selection_set_update_policy(GTK_COLOR_SELECTION((GTK_COLOR_SELECTION_DIALOG(P))^.colorsel), GTK_UPDATE_DISCONTINUOUS);
gtk_signal_connect( gtk_object((GTK_COLOR_SELECTION_DIALOG(P))^.ok_button), 'clicked', gtk_signal_func(@gtkDialogOKclickedCB), Sender);
gtk_signal_connect( gtk_object((GTK_COLOR_SELECTION_DIALOG(P))^.cancel_button), 'clicked', gtk_signal_func(@gtkDialogCancelclickedCB), Sender);
gtk_signal_connect( gtk_object(P), 'destroy', gtk_Signal_Func(@gtkDialogDestroyCB), Sender);
end;
csFontDialog :
begin
P := gtk_Font_selection_dialog_new(StrTemp);
gtk_signal_connect( gtk_object((GTK_FONT_SELECTION_DIALOG(P))^.ok_button), 'clicked', gtk_signal_func(@gtkDialogOKclickedCB), Sender);
gtk_signal_connect( gtk_object((GTK_FONT_SELECTION_DIALOG(P))^.cancel_button), 'clicked', gtk_signal_func(@gtkDialogCancelclickedCB), Sender);
gtk_signal_connect( gtk_object(P), 'destroy', gtk_Signal_Func(@gtkDialogDestroyCB), Sender);
end;
csFixed: //used for TWinControl, maybe change this to csWinControl
begin
p := GTKAPIWidget_New;
gtk_scrolled_window_set_policy(PGTKScrolledWindow(p), GTK_POLICY_NEVER, GTK_POLICY_NEVER);
Adjustment := gtk_scrolled_window_get_vadjustment(PGTKScrolledWindow(p));
if Adjustment <> nil
then with Adjustment^ do
begin
gtk_object_set_data(PGTKObject(Adjustment), 'ScrollBar', PGTKScrolledWindow(p)^.VScrollBar);
Step_Increment := 1;
end;
Adjustment := gtk_scrolled_window_get_hadjustment(PGTKScrolledWindow(p));
if Adjustment <> nil
then with Adjustment^ do
begin
gtk_object_set_data(PGTKObject(Adjustment), 'ScrollBar', PGTKScrolledWindow(p)^.HScrollBar);
Step_Increment := 1;
end;
end;
csForm :
begin
Assert(Sender is TForm);
p := gtk_window_new(FormStyleMap[TForm(Sender).BorderStyle]);
gtk_container_set_border_width(GTK_CONTAINER(P), 2);
TempInt:= FormSizeableMap[TForm(Sender).BorderStyle];
gtk_window_set_policy (GTK_WINDOW (p), TempInt, TempInt, 0);
gtk_window_set_title(pGtkWindow(p), strTemp);
TempWidget := gtk_fixed_new();
gtk_container_add(GTK_CONTAINER(p), TempWidget);
gtk_widget_show(TempWidget);
SetFixedWidget(p, TempWidget);
SetMainWidget(p, TempWidget);
//drag icons
if Drag_Icon = nil then
Drag_Icon := gdk_pixmap_colormap_create_from_xpm_d (nil, gtk_widget_get_colormap (p),
@Drag_Mask,
nil, @IMGDrag_Icon);
end;
csFrame :
begin
P := gtk_frame_new(' ');
gtk_frame_set_shadow_type(pGtkFrame(P),GTK_SHADOW_NONE);
end;
csLabel :
begin
P := gtk_label_new(StrTemp);
gtk_misc_set_alignment(PGTKMISC(P), 0.0 , 1.0);
end;
csMemo :
begin
// Assert(False, 'Trace:Creating a MEMO...');
P := gtk_hbox_new(false, 0);
TempWidget := gtk_text_new(nil,nil);
gtk_text_set_editable (PGtkText(TempWidget), not (Sender as TMemo).ReadOnly);
gtk_text_set_word_wrap(PGtkText(TempWidget), Integer((Sender as TCustomMemo).WordWrap));
gtk_box_pack_start(PGtkBox(P), TempWidget, true, true, 0);
gtk_widget_show(TempWidget);
SetCoreChildWidget(p, TempWidget);
SetMainWidget(p, TempWidget);
case (Sender as TCustomMemo).Scrollbars of
ssVertical, ssBoth:
begin
TempWidget := gtk_vscrollbar_new(PGtkText(TempWidget)^.vadj);
gtk_box_pack_start(PGtkBox(P), TempWidget, false, false, 0);
gtk_widget_show(TempWidget);
SetMainWidget(p, TempWidget);
end;
end;
gtk_widget_show(P);
end;
csMenuBar :
begin
P := gtk_menu_bar_new();
gtk_container_add(GTK_Container(GetFixedWidget(Pointer(TWinControl(TMenu(Sender).Owner).Handle))), P);
SetAccelGroup(p, gtk_accel_group_get_default);
gtk_widget_show(p);
end;
csMenuItem :
begin
if Caption <> '-'
then begin
//Check for an shortcut key
tempInt := pos('&', Caption);
if tempInt <> 0 then
begin
StrTemp[tempInt - 1] := '_';
P := gtk_menu_item_new_with_label('');
SetAccelKey(P, gtk_label_parse_uline(PGTKLabel(PGTKBin(p)^.Child), StrTemp));
end
else P := gtk_menu_item_new_with_label(Strtemp)
end
else P := gtk_menu_item_new;
gtk_widget_show (p);
end;
csNotebook :
begin
P := gtk_notebook_new();
gtk_notebook_set_show_tabs(P, false); // Turn tabs off
{
MWE: The FixedWidged pops up as an Page
We don't want that. BTW Adding controls to the notebookcontrol ???
}
{ TempWidget := gtk_fixed_new();
gtk_container_add(GTK_CONTAINER(p), TempWidget);
gtk_widget_show(TempWidget);
gtk_Object_Set_Data(Pgtkobject(p),'Fixed',tempWidget);
gtk_object_set_data(PGTKObject(TempWidget), 'Main', p);
gtk_Object_Set_Data(Pgtkobject(tempwidget),'Owner',p);
??? Fixed object_data not only a container ???
Without, the notebook dumps
This should be fixed someday
}
Assert(False, 'Trace:FIXME !!! [TgtkObject.CreateComponent] csNotebook --> gtk_Object_Set_Data');
SetFixedWidget(p, p);
end;
csRadioButton :
with sender as TRadioButton do
begin
if group = 0 then
begin
P := gtk_radio_button_new_with_label(PGsList(group),StrTemp);
group := THandle (gtk_radio_button_group (GTk_Radio_Button(P)));
end
else begin
P := gtk_radio_button_new_with_label(gtk_radio_button_group (GTk_Radio_Button(group)),StrTemp);
end;
end;
csScrolledWindow :
begin
P := gtk_scrolled_window_new(nil,nil);
end;
csSpeedButton:
Begin
{p := gtk_drawing_area_new();
gtk_drawing_area_size(pGTKDrawingArea(p),22,22);}
//nothing done here. We are only worried about the canvas
end;
csSpinEdit :
begin
p := gtk_spin_button_new(PgtkAdjustment(gtk_adjustment_new(1,1,100,1,1,1)),1,0);
end;
csSTATUSBAR :
begin
P := gtk_statusbar_new();
Assert(False, 'Trace:In CreateComponent --StatusBar');
end;
csgtkTable :
begin
P := gtk_table_new(2,2,False);
end;
csToggleBox :
begin
P := gtk_toggle_button_new_with_label(StrTemp);
end;
csToolbar:
begin
p := gtk_toolbar_new(GTK_ORIENTATION_HORIZONTAL,GTK_TOOLBAR_BOTH);
gtk_widget_show (P);
end;
csToolButton:
begin
if TToolButton(Sender).Style = tbsButton then
Begin
p := gtk_button_new_with_label(StrTemp);
Assert(False, 'Trace:TTOOLBUTTON created as type TBSBUTTON');
end
else
Begin
p := gtk_button_new_with_label(StrTemp);
Assert(False, 'Trace:TTOOLBUTTON created as type TBSBUTTON because type was unknown');
end;
gtk_widget_show (P);
{ p := gtk_toolbar_prepend_item(pGTKToolbar(TWinControl(TWincontrol(sender).Parent).Handle),
str,Str2,nil,nil,gtk_signal_func(@gtkclickedCB),Sender);
}
end;
csGroupBox:
begin
P := gtk_frame_new (StrTemp);
TempWidget := gtk_fixed_new();
gtk_container_add(GTK_CONTAINER(p), TempWidget);
gtk_widget_show(TempWidget);
SetFixedWidget(p, TempWidget);
SetMainWidget(p, TempWidget);
gtk_widget_show (P);
end;
csTimer:
begin
Assert(False, 'Trace:Creating a timer in CreateComponent');
with (Sender as TTimer) do
TimerID := gtk_timeout_add (Interval, @gtkTimerCB, Sender);
end;
csPage: // TPage - Notebook page
begin
P := gtk_hbox_new(false, 0);
TempWidget := gtk_fixed_new();
gtk_container_add(GTK_CONTAINER(P), TempWidget);
gtk_widget_show(TempWidget);
SetFixedWidget(p, TempWidget);
SetMainWidget(p, TempWidget);
gtk_widget_show (P);
end;
csProgressBar:
with (TProgressBar (Sender)) do
begin
{ Create a GtkAdjusment object to hold the range of the progress bar }
TempWidget := PGtkWidget( gtk_adjustment_new (Position, Min, Max, 0, 0, 0));
{ Create the GtkProgressBar using the adjustment }
P := gtk_progress_bar_new_with_adjustment (PGtkAdjustment (TempWidget));
end;
csTrackBar:
with (TTrackBar (Sender)) do
begin
TempWidget := PGtkWidget( gtk_adjustment_new (Position, Min, Max, linesize, pagesize, 0));
if (Orientation = trHorizontal)
then P := gtk_hscale_new (PGTKADJUSTMENT (TempWidget))
else P := gtk_vscale_new (PGTKADJUSTMENT (TempWidget));
gtk_scale_set_digits (PGTKSCALE (P), 0);
end;
end; //case
if (Sender is TWinControl) then
begin
TWinControl(Sender).Handle := THandle(p);
if p <> nil
then gtk_object_set_data(pgtkobject(p),'Sender',Sender);
end
else if (Sender is TMenuItem)
then TMenuItem(Sender).Handle := HMenu(p)
else if (Sender is TMenu)
then TMenu(Sender).Items.Handle := HMenu(p)
else if (Sender is TCustomDialog)
then TCustomDialog(Sender).Handle:= THandle(p);
//Set these for functions like GetWindowLong Added 01/07/2000
{}
SetLCLObject(p, Sender);
if p <> nil then
Begin
gtk_object_set_data(pgtkObject(p),'Style',0);
gtk_object_set_data(pgtkObject(p),'ExStyle',0);
end;
{}
StrDispose(StrTemp);
end;
{------------------------------------------------------------------------------}
{ TGtkObject GetLabel }
{ *Note: Returns a widgets lable value }
{------------------------------------------------------------------------------}
function TgtkObject.GetLabel(CompStyle: Integer; P : Pointer) : String;
var
pLabel: Pointer;
begin
Result := 'Label';
case CompStyle of
csLabel: gtk_label_get(PGTKLabel(p),@Result);
csForm : Result := String(PgtkWindow(p)^.Title);
csPage : begin
pLabel := gtk_notebook_get_tab_label(PGTKNoteBook(TWinControl(P).Parent.Handle), PGTKWidget(TWinControl(P).Handle));
if pLabel <> nil then gtk_label_get(pLabel, @Result);
end;
end;
end;
{------------------------------------------------------------------------------}
{ TGtkObject AssignSelf }
{ *Note: Assigns a pointer to self on a widget }
{------------------------------------------------------------------------------}
procedure TgtkObject.AssignSelf(Child,Data : Pointer);
begin
gtk_Object_Set_Data(Pgtkobject(Child),'Self',Data);
end;
{------------------------------------------------------------------------------}
{ TGtkObject ShowHide }
{ *Note: Show or hide a widget }
{------------------------------------------------------------------------------}
procedure TgtkObject.ShowHide(Sender : TObject);
begin
if TControl(Sender).Visible
then gtk_widget_show(PgtkWidget(TWinControl(Sender).Handle))
else gtk_widget_hide(PgtkWidget(TWinControl(Sender).Handle));
end;
{------------------------------------------------------------------------------}
{ TGtkObject AddNBPage }
{ *Note: Add Notebook Page }
{------------------------------------------------------------------------------}
procedure TgtkObject.AddNBPage(Parent, Child: TObject; Index: Integer);
var
Msg: TLMNotebookEvent;
pStr: PCHar;
begin
Assert(false, 'Trace:Adding a notebook page');
pStr := StrAlloc(Length(TWinControl(Child).Caption) + 1);
try
StrPCopy(pStr, TWinControl(Child).Caption);
gtk_notebook_insert_page(PGtkNotebook(TWinControl(Parent).Handle),
PGtkWidget(TWinControl(Child).Handle),
gtk_label_new(pStr),
Index);
finally
strDispose(pStr);
end;
// gtk_object_set_data(PGtkObject(TPage(Child).Handle), 'Owner', pgtkwidget(TWinControl(Parent).handle));
end;
{------------------------------------------------------------------------------}
{ TGtkObject RemoveNBPage }
{ *Note: Remove Notebook Page }
{------------------------------------------------------------------------------}
procedure TgtkObject.RemoveNBPage(Parent: TObject; Index: Integer);
begin
Assert(false, 'Trace:Removing a notebook page');
gtk_notebook_remove_page(PGtkNotebook(TWinControl(Parent).Handle), Index);
end;
{------------------------------------------------------------------------------}
{ TGtkObject ReDraw }
{ *Note: }
{------------------------------------------------------------------------------}
procedure TgtkObject.ReDraw(Child : Pointer);
var
fWindow :pGdkWindow;
widget : PgtkWIdget;
PixMap : pgdkPixMap;
gc : PGDKGc;
begin
Assert(False, 'Trace:In AutoRedraw in GTKObject');
Widget := GetFixedWidget(Child);
pixmap := gtk_Object_get_data(pgtkobject(Child),'Pixmap');
if PixMap = nil then Exit;
fWindow := pGtkWidget(widget)^.window;
gc := gdk_gc_new(PgdkWindow(fWindow));
gdk_draw_pixmap(fwindow,PGtkStyle(widget^.TheStyle)^.fg_gc[GTK_WIDGET_STATE (widget)],
pixmap,
0,0,
0,0,
pgtkwidget(widget)^.allocation.width, pgtkwidget(widget)^.allocation.height);
end;
{------------------------------------------------------------------------------}
{ TGtkObject FontSetName }
{ *Note: }
{------------------------------------------------------------------------------}
procedure TgtkObject.FontSetName(Sender : TObject);
{var
StrTemp : PChar;
Name : String;
Msg : Integer;
NewHandle: THandle;}
begin
Assert(False, 'Trace:OBSOLETE: [TgtkObject.FontSetName]');
(*
Assert(False, 'Trace:1');
Name := TFont(Sender).Name;
Assert(False, 'Trace:2');
strTemp := StrAlloc(length(Name) + 1);
Assert(False, 'Trace:3');
StrPCopy(strTemp, Name);
Assert(False, 'Trace:4');
NewHandle := THandle(gdk_font_load(strTemp));
if NewHandle = 0 then //Load a DEFAULT font
begin
Assert(False, 'Trace:[TgtkObject.FontSetName] WARNING: Loading Default Font');
StrDispose(StrTemp);
strTemp := StrAlloc(Length('-*-courier-bold-r-normal--*-120-*-*-*-*-iso8859-1') + 1);
StrPCopy(strTemp, '-*-courier-bold-r-normal--*-120-*-*-*-*-iso8859-1');
NewHandle := THandle(gdk_font_load(strTemp));
end;
if NewHandle <> 0
then begin
if TFont(sender).Handle <> 0
then gdk_font_unref(pgdkFont(TFont(Sender).Handle));
Assert(False, 'Trace:5');
TFont(Sender).Handle := NewHandle;
Assert(False, 'Trace:6');
Msg := LM_Changed;
TObject(sender).Dispatch(Msg);
end
else Assert(False, Format('Trace:[TgtkObject.FontSetName] WARNING: Could not load font: %s', [strTemp]));;
Assert(False, 'Trace:7');
StrDispose(StrTemp);
Assert(False, 'Trace:8');
*)
end;
{------------------------------------------------------------------------------}
{ TGtkObject GetFontInfo }
{ *Note: }
{------------------------------------------------------------------------------}
procedure TgtkObject.GetFontInfo(Sender : TObject; Data : Pointer);
var
Font :pGdkfont;
lBearing,rBearing,w,ascent,descent : LongInt;
Str : String;
FontName : String;
I : Integer;
begin
Assert(False, 'Trace:OBSOLETE: [TgtkObject.GetFontInfo]');
{
Assert(False, 'Trace:FONT GetInfo');
Font := PgdkFont(TFont(Sender).Handle);
gdk_String_extents(Font,Data,@lbearing,@rBearing,@w,@ascent,@descent);
Assert(False, 'Trace:' + Inttostr(lbearing)+','+Inttostr(rBearing)+','+Inttostr(w)+','+Inttostr(Ascent)+','+Inttostr(descent));
// Only for Extra properties
// TODO: implement them though GetTextMetrics, not here
(*
Str := String(Data^);
// use the name to see if the AVERAGE WIDTH is stored there, otherwise use w
FontName := TFont(Sender).Name;
for I := 1 to 11 do
delete(FontName,pos('-',FontName),1);
delete(FontName,1,pos('-',FontName));
//FontName should now start with the average SIZE or a dash
if (FontName[1] <> '-') and (FontName[1] <> '*') then
begin
Delete(FontName,pos('-',FontName),length(FontName));
W := StrtoInt(FontName);
end
else
w := gdk_Text_width(Font,Data,Length(Str));
if w <= 0 then
begin
gdk_String_extents(Font,Data,@lbearing,@rBearing,@w,@ascent,@descent);
W := lBEaring + rBearing;
end;
*)
// Extra properties
// TODO: implement them though GetTextMetrix, not here
//TFont(Sender).XBias := lbearing;;
//TFOnt(Sender).YBias := ascent - descent;
//TFont(Sender).Width := w;
//-----------------
TFont(Sender).height := Ascent+Descent;
}
end;
{------------------------------------------------------------------------------
Method: TGtkObject.SetPixel
Params: Sender : the lcl object which called this func via SenMessage
Data : pointer to a TLMSetGetPixel record
Returns: nothing
Set the color of the specified pixel on the window?screen?object?
------------------------------------------------------------------------------}
procedure TgtkObject.SetPixel(Sender : TObject; Data : Pointer);
var
fWindow : pGdkWindow;
gc : pgdkGC;
Image : pGDKImage;
widget : PgtkWidget;
begin
Widget := PgtkWidget(TCanvas(sender).Handle);
Image := gtk_Object_get_data(pgtkobject(widget),'Image');
if Image = nil
then Image := gdk_image_get(pgtkWidget(widget)^.window,0,0,widget^.allocation.width,widget^.allocation.height);
gdk_image_put_pixel(Image,TLMSetGetPixel(data^).X,TLMSetGetPixel(data^).Y,TLMSetGetPixel(data^).PixColor);
gtk_Object_set_data(pgtkobject(Widget),'Image',Image);
widget := GetFixedWidget(Widget);
fWindow := pGtkWidget(widget)^.window;
gc := gdk_gc_new(PgdkWindow(fWindow));
gdk_draw_image(fwindow,PGtkStyle(widget^.TheStyle)^.fg_gc[GTK_WIDGET_STATE (widget)],
Image,
TLMSetGetPixel(data^).X,TLMSetGetPixel(data^).Y,
TLMSetGetPixel(data^).X,TLMSetGetPixel(data^).Y,
1,1);
end;
{------------------------------------------------------------------------------
Method: TGtkObject.GetPixel
Params: Sender : the lcl object which called this func via SenMessage
Data : pointer to a TLMSetGetPixel record
Returns: nothing
Get the color of the specified pixel on the window?screen?object?
------------------------------------------------------------------------------}
procedure TgtkObject.GetPixel(Sender : TObject; Data : Pointer);
var
Image : pGDKImage;
widget : PgtkWidget;
WasNil : Boolean;
begin
Widget := PgtkWidget(TCanvas(sender).Handle);
Image := gtk_Object_get_data(pgtkobject(widget),'Image');
if Image = nil then
begin
WasNil := True;
Image := gdk_image_get(pgtkWidget(widget)^.window,0,0,widget^.allocation.width,widget^.allocation.height);
end;
TLMSetGetPixel(data^).PixColor := gdk_image_get_pixel(Image,TLMSetGetPixel(data^).X,TLMSetGetPixel(data^).Y);
If WasNil then gtk_Object_set_data(pgtkobject(Widget),'Image',Image);
end;
{------------------------------------------------------------------------------
Method: TGtkObject.GetValue
Params: Sender : the lcl object which called this func via SenMessage
Data : pointer to component specific variable
Returns: currently always 0
Depending on the compStyle, this function will get the current value
of a GTK object and save it in the variable referenced by 'data'.
This function should be used to synchronize the state of an lcl-object
with the corresponding GTK-object.
------------------------------------------------------------------------------}
function TgtkObject.GetValue (Sender : TObject; data : pointer) : integer;
var
Handle : Pointer;
begin
result := 0; // default if nobody sets it
if Sender is TWinControl
then Assert(False, Format('Trace:[TgtkObject.GetValue] %s', [Sender.ClassName]))
else Assert(False, Format('Trace:WARNING: [TgtkObject.GetValue] %s --> No Decendant of TWinControl', [Sender.ClassName]));
Handle := Pointer(TWinControl(Sender).Handle);
Assert (Handle = nil, 'WARNING: [TgtkObject.GetValue] --> got nil pointer (no gtkobject)');
case TControl(Sender).fCompStyle of
csTrackbar : integer (data^) := round (gtk_range_get_adjustment (GTK_RANGE (handle))^.value);
csRadiobutton,
csCheckbox : if gtk_toggle_button_get_active (PGtkToggleButton (handle))
then TCheckBoxState (data^) := cbChecked
else TCheckBoxState (data^) := cbUnChecked;
else
Assert (true, Format ('WARNING:[TgtkObject.GetValue] failed for %s', [Sender.ClassName]));
end;
end;
{------------------------------------------------------------------------------
Method: TGtkObject.SetValue
Params: Sender : the lcl object which called this func via SenMessage
Data : pointer to component specific variable
Returns: currently always 0
Depending on the compStyle, this function will apply the parameter 'data'
to the GTK object repesenting the lcl-object which called the function.
This function should for be used in cases where the most common property
of an object has changed (e.g. the position of a trackbar). If more than
one property changed use the SetProperties function instead;
------------------------------------------------------------------------------}
function TgtkObject.SetValue (Sender : TObject; data : pointer) : integer;
var
Handle : Pointer;
begin
result := 0; // default if nobody sets it
if Sender is TWinControl
then Assert(False, Format('Trace:[TgtkObject.SetValue] %s', [Sender.ClassName]))
else Assert(False, Format('Trace:WARNING: [TgtkObject.SetValue] %s --> No Decendant of TWinControl', [Sender.ClassName]));
Handle := Pointer(TWinControl(Sender).Handle);
Assert (Handle = nil, 'WARNING: [TgtkObject.SetValue] --> got nil pointer (no gtkobject)');
case TControl(Sender).fCompStyle of
csProgressBar: gtk_progress_set_value (GTK_PROGRESS (handle), integer (data^));
csTrackbar : begin
gtk_range_get_adjustment (GTK_RANGE (handle))^.value := integer (data^);
gtk_signal_emit_by_name (PGtkObject (gtk_range_get_adjustment (GTK_RANGE (handle))), 'value_changed');
end;
csRadiobutton,
csCheckbox : if TCheckBoxState (data^) = cbChecked
then gtk_toggle_button_set_active( PGtkToggleButton (handle), TRUE)
else gtk_toggle_button_set_active( PGtkToggleButton (handle), FALSE);
else
Assert (true, Format ('WARNING:[TgtkObject.SetValue] failed for %s', [Sender.ClassName]));
end;
end;
{------------------------------------------------------------------------------
Method: TGtkObject.SetProperties
Params: Sender : the lcl object which called this func via SenMessage
Returns: currently always 0
Depending on the compStyle, this function will apply all properties of
the calling object to the corresponding GTK object.
------------------------------------------------------------------------------}
function TgtkObject.SetProperties (Sender : TObject) : integer;
var
Handle : Pointer;
Widget : PGtkWidget;
xAlign : gfloat;
yAlign : gfloat;
begin
result := 0; // default if nobody sets it
if Sender is TWinControl
then Assert(False, Format('Trace:[TgtkObject.SetProperties] %s', [Sender.ClassName]))
else Assert(False, Format('Trace:WARNING: [TgtkObject.SetProperties] %s --> No Decendant of TWinControl', [Sender.ClassName]));
Handle := Pointer(TWinControl(Sender).Handle);
Assert (Handle = nil, 'WARNING: [TgtkObject.SetProperties] --> got nil pointer');
case TControl(Sender).fCompStyle of
csProgressBar :
with (TProgressBar (Sender)) do
begin
Widget := PGtkWidget( gtk_adjustment_new (0, Min, Max, 0, 0, 0));
gtk_progress_set_adjustment (GTK_PROGRESS (handle), PGtkAdjustment (Widget));
gtk_progress_set_value (GTK_PROGRESS (handle), Position);
if Smooth
then gtk_progress_bar_set_bar_style (GTK_PROGRESS_BAR (handle), GTK_PROGRESS_CONTINUOUS)
else gtk_progress_bar_set_bar_style (GTK_PROGRESS_BAR (handle), GTK_PROGRESS_DISCRETE);
case Orientation of
pbVertical : gtk_progress_bar_set_orientation(GTK_PROGRESS_BAR (handle), GTK_PROGRESS_BOTTOM_TO_TOP);
pbRightToLeft : gtk_progress_bar_set_orientation(GTK_PROGRESS_BAR (handle), GTK_PROGRESS_RIGHT_TO_LEFT);
pbTopDown : gtk_progress_bar_set_orientation(GTK_PROGRESS_BAR (handle), GTK_PROGRESS_TOP_TO_BOTTOM);
else { pbHorizontal is default }
gtk_progress_bar_set_orientation(GTK_PROGRESS_BAR (handle), GTK_PROGRESS_LEFT_TO_RIGHT);
end;
if BarShowText then
begin
gtk_progress_set_format_string (GTK_PROGRESS (handle), '%v from [%l-%u] (=%p%%)');
gtk_progress_set_show_text (GTK_PROGRESS (handle), 1);
end
else
gtk_progress_set_show_text (GTK_PROGRESS (handle), 0);
end;
csTrackbar :
with (TTrackBar (Sender)) do
begin
Widget := PGtkWidget (gtk_range_get_adjustment (GTK_RANGE (handle)));
PGtkAdjustment(Widget)^.lower := Min;
PGtkAdjustment(Widget)^.Upper := Max;
PGtkAdjustment(Widget)^.Value := Position;
PGtkAdjustment(Widget)^.step_increment := LineSize;
PGtkAdjustment(Widget)^.page_increment := PageSize;
{ now do some of the more sophisticated features }
{ Hint: For some unknown reason we have to disable the draw_value first,
otherwise it's set always to true }
gtk_scale_set_draw_value (PGTKSCALE (handle), false);
if ShowScale then
begin
gtk_scale_set_draw_value (PGTKSCALE (handle), ShowScale);
case ScalePos of
trLeft : gtk_scale_set_value_pos (PGTKSCALE (handle), GTK_POS_LEFT);
trRight : gtk_scale_set_value_pos (PGTKSCALE (handle), GTK_POS_RIGHT);
trTop : gtk_scale_set_value_pos (PGTKSCALE (handle), GTK_POS_TOP);
trBottom: gtk_scale_set_value_pos (PGTKSCALE (handle), GTK_POS_BOTTOM);
end;
end;
//Not here (Delphi compatibility): gtk_signal_emit_by_name (GTK_Object (Widget), 'value_changed');
end;
csLabel :
with TLabel(Sender) do
begin
case Alignment of
taLeftJustify : xAlign := 0.0;
taCenter : xAlign := 0.5;
taRightJustify : xAlign := 1.0;
else
xAlign := 0.0; // default, shouldn't happen
end;
case Layout of
tlTop : yAlign := 0.0;
tlCenter : yAlign := 0.5;
tlBottom : yAlign := 1.0;
else
yAlign := 1.0; //default, shouldn't happen
end;
gtk_misc_set_alignment(PGTKMISC(Handle), xAlign, yAlign);
gtk_label_set_line_wrap(PGTKLABEL(Handle),WordWrap);
end;
else
Assert (true, Format ('WARNING:[TgtkObject.SetProperties] failed for %s', [Sender.ClassName]));
end;
end;
{------------------------------------------------------------------------------
Method: TGtkObject.UpdateHint
Params: Sender : the lcl object which called this func
Returns: currently always 0
Sets the tooltip text of the sending control.
------------------------------------------------------------------------------}
function TGtkObject.UpdateHint(Sender: TObject) : integer;
var
StrTemp : PChar;
begin
Result := 0; // default if nobody sets it
if Sender is TWinControl then
with Sender as TWinControl do
begin
if (Length(Hint) > 0) and ShowHint
then begin
strTemp := StrAlloc(Length(Hint) + 1);
try
StrPCopy(strTemp, Hint);
// ?? TODO something with short and long hints ??
gtk_ToolTips_Set_Tip(FGTKToolTips, PgtkWidget(Handle), StrTemp, StrTemp);
finally
StrDispose(strTemp);
end;
end
else gtk_ToolTips_Set_Tip(FGTKToolTips, PgtkWidget(Handle), nil, nil);
end;
end;
{------------------------------------------------------------------------------
Method: TGtkObject.AttachMenu
Params: Sender : the lcl object which called this func
Returns: nothing
Attaches the calling Menu to its Parent
------------------------------------------------------------------------------}
procedure TGtkObject.AttachMenu(Sender: TObject);
var
AccelKey: Integer;
AccelGroup: PGTKAccelGroup;
MenuParent, MenuItem: Pointer;
begin
with (Sender as TMenuItem) do
begin
MenuItem := Pointer(Handle);
if (Parent.GetParentMenu <> nil) and
(Parent.GetParentMenu.Items.IndexOf(TMenuItem(Sender)) <> -1) then //mainmenu
begin
MenuParent := Pointer(Parent.Handle);
gtk_menu_bar_append(MenuParent, MenuItem);
end
else begin
// find the menu container
MenuParent := gtk_object_get_data(PGtkObject(Parent.Handle), 'ContainerMenu');
if MenuParent = nil then
begin
MenuParent := gtk_menu_new;
gtk_object_set_data(PGtkObject(Parent.Handle), 'ContainerMenu', MenuParent);
gtk_menu_item_set_submenu(PGTKMenuItem(Parent.Handle), MenuParent);
AccelGroup := gtk_accel_group_new;
gtk_menu_set_accel_group(MenuParent, AccelGroup);
SetAccelGroup(MenuParent, AccelGroup);
end;
gtk_menu_append(MenuParent, MenuItem);
end;
// Add accelerators
AccelGroup := GetAccelGroup(MenuParent);
AccelKey := GetAccelKey(MenuItem);
if (AccelGroup <> nil) and (AccelKey <> 0)
then gtk_accel_group_add(AccelGroup, AccelKey, GDK_MOD1_MASK, GTK_ACCEL_LOCKED, MenuItem, 'activate_item');
end;
end;
{------------------------------------------------------------------------------
Function: IsValidDC
Params: DC: a (LCL) devicecontext
Returns: True if valid
Checks if the given DC is valid.
------------------------------------------------------------------------------}
function TgtkObject.IsValidDC(const DC: HDC): Boolean;
begin
Result := FDeviceContexts.IndexOf(Pointer(DC)) <> -1;
Assert(False, Format('Trace:[TgtkObject.IsValidDC] DC: 0x%x --> %s', [Integer(DC), BOOL_RESULT[Result]]));
end;
{------------------------------------------------------------------------------
Function: IsValidGDIObject
Params: GDIObject: a (LCL) gdiObject
Returns: True if valid
Checks if the given GDIObject is valid
------------------------------------------------------------------------------}
function TgtkObject.IsValidGDIObject(const GDIObject: HGDIOBJ): Boolean;
begin
Result := FGDIObjects.IndexOf(Pointer(GDIObject)) <> -1;
// Result := (GDIObject <> 0);
if Result then
try
with PGdiObject(GDIObject)^ do
case GDIType of
gdiBitmap : begin
case GDIBitmapType of
gbPixmap: Result := GDIPixmapObject <> nil;
gbBitmap: Result := GDIBitmapObject <> nil;
gbImage: Result := GDIRawImageObject <> nil;
else
Result := False;
end;
end;
gdiBrush : Result := True; //Result := GDIBrushPixmap <> nil; //GDIBrushPixmap may be nil
gdiFont : Result := GDIFontObject <> nil;
gdiPen : Result := True;
// gdiRegion :
else
Result := False;
end;
except
on Exception do Result := False;
end;
Assert(False, Format('Trace:[TgtkObject.IsValidGDIObject] GDIObject: 0x%x --> %s', [Integer(GDIObject), BOOL_RESULT[Result]]));
end;
{------------------------------------------------------------------------------
Function: IsValidGDIObjectType
Params: GDIObject: a (LCL) gdiObject
GDIType: the requested type
Returns: True if valid
Checks if the given GDIObject is valid and the GDItype is the requested type
------------------------------------------------------------------------------}
function TgtkObject.IsValidGDIObjectType(const GDIObject: HGDIOBJ; const GDIType: TGDIType): Boolean;
begin
Result := IsValidGDIObject(GDIObject) and (PGdiObject(GDIObject)^.GDIType = GDIType);
end;
{------------------------------------------------------------------------------
Function: NewDC
Params: none
Returns: a gtkwinapi DeviceContext
Creates an initial DC
------------------------------------------------------------------------------}
function TgtkObject.NewDC: PDeviceContext;
var
n: Integer;
begin
Assert(False, Format('Trace:==> [TgtkObject.NewDC]', []));
New(Result);
with Result^ do
begin
hWnd := 0;
GC := nil;
Drawable := nil;
PenPos.X := 0;
PenPos.Y := 0;
CurrentBitmap := nil;
CurrentFont := nil;
CurrentPen := nil;
CurrentBrush := nil;
SavedContext := nil;
gdk_color_black(gdk_colormap_get_system, @CurrentTextColor);
gdk_color_white(gdk_colormap_get_system, @CurrentBackColor);
end;
n := FDeviceContexts.Add(Result);
Assert(False, Format('Trace:<== [TgtkObject.NewDC] FDeviceContexts[%d] --> 0x%p', [n, Result]));
end;
{------------------------------------------------------------------------------
Function: NewGDIObject
Params: none
Returns: a gtkwinapi DeviceContext
Creates an initial DC
------------------------------------------------------------------------------}
function TgtkObject.NewGDIObject(const GDIType: TGDIType): PGdiObject;
var
n: Integer;
begin
Assert(False, Format('Trace:==> [TgtkObject.NewGDIObject]', []));
New(Result);
FillChar(Result^, SizeOf(TGDIObject), 0);
Result^.GDIType := GDIType;
n := FGDIObjects.Add(Result);
Assert(False, Format('Trace:<== [TgtkObject.NewGDIObject] FGDIObjects[%d] --> 0x%p', [n, Result]));
end;
{------------------------------------------------------------------------------
Function: CreateDefaultBrush
Params: none
Returns: a Brush GDIObject
Creates an default brush, used for initial values
------------------------------------------------------------------------------}
function TgtkObject.CreateDefaultBrush: PGdiObject;
begin
Result := NewGDIObject(gdiBrush);
Result^.GDIBrushFill := GDK_SOLID;
gdk_color_white(gdk_colormap_get_system, @Result^.GDIBrushColor);
end;
{------------------------------------------------------------------------------
Function: CreateDefaultFont
Params: none
Returns: a Font GDIObject
Creates an default font, used for initial values
------------------------------------------------------------------------------}
function TgtkObject.CreateDefaultFont: PGdiObject;
begin
Result := NewGDIObject(gdiFont);
Result^.GDIFontObject := gdk_font_load('-*-helvetica-bold-r-normal--*-120-*-*-*-*-iso8859-1');
end;
{------------------------------------------------------------------------------
Function: CreateDefaultPen
Params: none
Returns: a Pen GDIObject
Creates an default pen, used for initial values
------------------------------------------------------------------------------}
function TgtkObject.CreateDefaultPen: PGdiObject;
begin
Result := NewGDIObject(gdiPen);
Result^.GDIPenStyle := PS_SOLID;
gdk_color_black(gdk_colormap_get_system, @Result^.GDIPenColor);
end;
{ =============================================================================
$Log$
Revision 1.1 2000/07/13 10:28:29 michael
+ Initial import
Revision 1.28 2000/07/12 20:57:08 lazarus
- some minor cleanups
- cleanups in Set/Get Pixel
- fixed to minor bugs related to Trackbar
stoppok
Revision 1.27 2000/07/09 20:46:38 lazarus
- lots of new comments for methods
- SetText: Code for Notebook removed (surrounded with comments)!
- SetLabel: Code for NoteBook changed from ....get_label to ....set_label
- some new asserts
- many changes to beautify code
stoppok
Revision 1.26 2000/07/09 20:18:56 lazarus
MWE:
+ added new controlselection
+ some fixes
~ some cleanup
Revision 1.25 2000/07/02 05:51:41 lazarus
Started code-review, beautified some oarts, nearly no code changes by now, stoppok
Revision 1.24 2000/06/29 21:09:14 lazarus
some minor cleanups, stoppok
Revision 1.23 2000/06/29 18:08:56 lazarus
Shane
Looking for the editor problem I made a few changes. I changed everything back to the original though.
Revision 1.22 2000/06/28 13:11:38 lazarus
Fixed TNotebook so it gets page change events. Shane
Revision 1.21 2000/06/24 21:26:19 lazarus
*** empty log message ***
Revision 1.20 2000/06/19 18:21:22 lazarus
Spinedit was never getting created
Shane
Revision 1.19 2000/06/14 21:51:27 lazarus
MWE:
+ Added menu accelerators. Not finished
Revision 1.18 2000/06/13 21:51:19 lazarus
MWE:
+ Started adding menu accels
Revision 1.17 2000/06/13 20:50:42 lazarus
MWE:
- Started to remove obsolete/dead code/messages
HJO:
* Fixed messages in showmodal of 2nd form
* Fixed modal result for button
Revision 1.16 2000/06/09 11:35:22 lazarus
More shortcut work.
Shane
Revision 1.15 2000/06/08 17:32:53 lazarus
trying to add accel to menus.
Shane
Revision 1.14 2000/05/30 22:28:41 lazarus
MWE:
Applied patches from Vincent Snijders:
+ Added GetWindowRect
* Fixed horz label alignment
+ Added vert label alignment
Revision 1.13 2000/05/27 22:33:01 lazarus
MWE:
+ Forgot to add Ref/UnRef to Tooltips
Revision 1.12 2000/05/27 22:20:56 lazarus
MWE & VRS:
+ Added new hint code
Revision 1.11 2000/05/27 19:15:50 lazarus
MWE:
- Removed Linux dependencies. Functions are supported in wingtk
Revision 1.10 2000/05/25 19:34:31 lazarus
MWE:
* Fixed messagequeue.count bug in GTKObject.Destroy
(thanks to Vincent Snijders)
Revision 1.9 2000/05/11 22:04:15 lazarus
MWE:
+ Added messagequeue
* Recoded SendMessage and Peekmessage
+ Added postmessage
+ added DeliverPostMessage
Revision 1.8 2000/05/10 22:52:58 lazarus
MWE:
= Moved some global api stuf to gtkobject
Revision 1.7 2000/05/09 02:05:08 lazarus
Replaced writelns with Asserts. CAW
Revision 1.6 2000/05/08 15:56:59 lazarus
MWE:
+ Added support for mwedit92 in Makefiles
* Fixed bug # and #5 (Fillrect)
* Fixed labelsize in ApiWizz
+ Added a call to the resize event in WMWindowPosChanged
Revision 1.5 2000/05/08 12:54:20 lazarus
Removed some writeln's
Added alignment for the TLabel. Isn't working quite right.
Added the shell code for WindowFromPoint and GetParent.
Added FindLCLWindow
Shane
Revision 1.4 2000/05/03 17:19:29 lazarus
Added the TScreem forms code by hongli@telekabel.nl
Shane
Revision 1.3 2000/04/17 19:50:06 lazarus
Added some compiler stuff built into Lazarus.
This depends on the path to your compiler being correct in the compileroptions
dialog.
Shane
Revision 1.2 2000/04/13 21:25:16 lazarus
MWE:
~ Added some docu and did some cleanup.
Hans-Joachim Ott <hjott@compuserve.com>:
* TMemo.Lines works now.
+ TMemo has now a property Scrollbar.
= TControl.GetTextBuf revised :-)
+ Implementation for CListBox columns added
* Bug in TGtkCListStringList.Assign corrected.
Revision 1.1 2000/03/30 22:51:42 lazarus
MWE:
Moved from ../../lcl
Revision 1.143 2000/03/30 21:57:44 lazarus
MWE:
+ Added some general functions to Get/Set the Main/Fixed/CoreChild
widget
+ Started with graphic scalig/depth stuff. This is way from finished
Hans-Joachim Ott <hjott@compuserve.com>:
+ Added some improvements for TMEMO
Revision 1.142 2000/03/30 18:07:53 lazarus
Added some drag and drop code
Added code to change the unit name when it's saved as a different name. Not perfect yet because if you are in a comment it fails.
Shane
Revision 1.141 2000/03/24 14:40:41 lazarus
A little polishing and bug fixing.
Revision 1.140 2000/03/23 22:48:56 lazarus
MWE & Hans-Joachim Ott <hjott@compuserve.com>:
+ added replacement for LM_GetText
Revision 1.139 2000/03/23 20:40:03 lazarus
Added some drag code
Shane
Revision 1.138 2000/03/22 17:09:29 lazarus
*** empty log message ***
Revision 1.137 2000/03/21 18:53:28 lazarus
Added code for TBitBtn. Not finished but looks like mostly working.
Shane
Revision 1.136 2000/03/20 20:08:33 lazarus
Added a generic MOUSE class.
Shane
Revision 1.135 2000/03/19 23:01:42 lazarus
MWE:
= Changed splashscreen loading/colordepth
= Chenged Save/RestoreDC to platform dependent, since they are
relative to a DC
Revision 1.134 2000/03/17 19:19:58 lazarus
Added Hans Ott's code for TMemo
Shane
Revision 1.133 2000/03/15 20:15:31 lazarus
MOdified TBitmap but couldn't get it to work
Shane
Revision 1.132 2000/03/15 01:09:58 lazarus
MWE:
+ Removed comment on LM_IMAGECHANGED in TgtkObject.IntSendMessage3
it does compile (compiler hickup ?)
Revision 1.131 2000/03/15 00:51:57 lazarus
MWE:
+ Added LM_Paint on expose
+ Added forced creation of gdkwindow if needed
~ Modified DrawFrameControl
+ Added BF_ADJUST support on DrawEdge
- Commented out LM_IMAGECHANGED in TgtkObject.IntSendMessage3
(It did not compile)
Revision 1.130 2000/03/14 19:49:04 lazarus
Modified the painting process for TWincontrol. Now it runs throug it's FCONTROLS list and paints all them
Shane
Revision 1.129 2000/03/13 23:17:34 lazarus
MWE:
+ finished hide caret
+ added blinking caret
Revision 1.128 2000/03/10 18:31:09 lazarus
Added TSpeedbutton code
Shane
Revision 1.127 2000/03/09 23:47:53 lazarus
MWE:
* Fixed colorcache
* Fixed black window in new editor
~ Did some cosmetic stuff
From Peter Dyson <peter@skel.demon.co.uk>:
+ Added Rect api support functions
+ Added the start of ScrollWindowEx
Revision 1.126 2000/03/04 00:05:21 lazarus
MWE: added changes from Hans (HJO)
Revision 1.125 2000/03/03 22:58:26 lazarus
MWE:
Fixed focussing problem.
LM-FOCUS was bound to the wrong signal
Added GetKeyState api func.
Now LCL knows if shift/trl/alt is pressed (might be handy for keyboard
selections ;-)
Revision 1.124 2000/03/03 20:22:03 lazarus
Trying to add TBitBtn
Shane
Revision 1.123 2000/03/01 00:41:03 lazarus
MWE:
Fixed updateshowing problem
Added some debug code to display the name of messages
Did a bit of cleanup in main.pp to get the code a bit more readable
(my editor does funny things with tabs if the indent differs)
Revision 1.122 2000/02/26 23:48:36 lazarus
MWE:
FIxed notebook, forgot getlabel code
Revision 1.121 2000/02/26 23:31:50 lazarus
MWE:
Fixed notebook crash on insert
Fixed loadfont problem for win32 (tleast now a fontname is required)
Revision 1.120 2000/02/25 19:28:34 lazarus
Played with TNotebook to see why it crashes when I add a tab and the tnotebook is showing. Havn't figured it out
Shane
Revision 1.119 2000/02/24 21:15:30 lazarus
Added TCustomForm.GetClientRect and RequestAlign to try and get the controls to align correctly when a MENU is present. Not Complete yet.
Fixed the bug in TEdit that caused it not to update it's text property. I will have to
look at TMemo to see if anything there was affected.
Added SetRect to WinAPI calls
Added AdjustWindowRectEx to WINAPI calls.
Shane
Revision 1.118 2000/02/24 09:10:12 lazarus
TListBox.Selected bug fixed.
Revision 1.117 2000/02/23 22:08:38 lazarus
MInor changes for listboxCVS: Committing in .
Revision 1.116 2000/02/22 22:19:49 lazarus
TCustomDialog is a descendant of TComponent.
Initial cuts a form's proper Close behaviour.
Revision 1.115 2000/02/22 21:29:42 lazarus
Added a few more options in the editor like closeing a unit. Also am keeping track of what page , if any, they are currently on.
Shane
Revision 1.114 2000/02/22 17:32:49 lazarus
Modified the ShowModal call.
For TCustomForm is simply sets the visible to true now and adds fsModal to FFormState. In gtkObject.inc FFormState is checked. If it contains fsModal then either gtk_grab_add or gtk_grab_remove is called depending on the value of VISIBLE.
The same goes for TCustomDialog (open, save, font, color).
I moved the Execute out of the individual dialogs and moved it into TCustomDialog and made it virtual because FONT needs to set some stuff before calling the inherited execute.
Shane
Revision 1.113 2000/02/20 20:13:47 lazarus
On my way to make alignments and stuff work :-)
Revision 1.112 2000/02/19 18:11:59 lazarus
More work on moving, resizing, forms' border style etc.
Revision 1.111 2000/02/18 19:38:52 lazarus
Implemented TCustomForm.Position
Better implemented border styles. Still needs some tweaks.
Changed TComboBox and TListBox to work again, at least partially.
Minor cleanups.
Revision 1.110 2000/01/25 22:04:27 lazarus
MWE:
The first primitive Caret functions are getting visible
Revision 1.109 2000/01/22 20:07:46 lazarus
Some cleanups. It needs much more cleanup than this.
Worked around a compiler bug (?) in mwCustomEdit.
Reverted some changes to font generation and increased font size.
Revision 1.108 2000/01/18 22:18:34 lazarus
Moved bitmap creation into appropriate place. Cleaned up a bit.
Finished DeleteObject procedure.
Revision 1.107 2000/01/17 23:33:06 lazarus
MWE:
fixed: nil pointer reference in DeleteObject
fixed: some trace info didn't start with 'trace:'
Revision 1.106 2000/01/17 20:36:25 lazarus
Fixed Makefile again.
Made implementation of TScreen and screen info saner.
Began to implemented DeleteObject in GTKWinAPI.
Fixed a bug in GDI allocation which in turn fixed A LOT of other bugs :-)
Revision 1.105 2000/01/16 23:23:04 lazarus
MWE:
Added/completed scrollbar API funcs
Revision 1.104 2000/01/16 20:24:42 lazarus
Did some introductory work on TScreen.
Only the PixelsPerInch property is implemented at the moment.
Revision 1.103 2000/01/14 15:01:15 lazarus
Changed SETCURSOR so the cursor's were created in the gtkObject.Init and destroyed in GTkObject.AppTerminate
Shane
Revision 1.102 2000/01/14 00:33:31 lazarus
MWE:
Added Scrollbar messages
Revision 1.101 2000/01/13 22:44:05 lazarus
MWE:
Created/updated net gtkwidget for TWinControl decendants
also improved foccusing on such a control
Revision 1.100 2000/01/11 20:51:39 lazarus
*** empty log message ***
Revision 1.98 2000/01/10 00:07:12 lazarus
MWE:
Added more scrollbar support for TWinControl
Most signals for TWinContorl are jet connected to the wrong widget
(now scrolling window, should be fixed)
Added some cvs entries
Revision 1.97 2000/01/07 21:14:13 lazarus
Added code for getwindowlong and setwindowlong.
Shane
Revision 1.96 2000/01/05 23:13:13 lazarus
MWE:
Made some changes to the ideeditor to track notebook problems
Revision 1.95 2000/01/04 19:16:09 lazarus
Stoppok:
- new messages LM_GETVALUE, LM_SETVALUE, LM_SETPROPERTIES
- changed trackbar, progressbar, checkbox to use above messages
- some more published properties for above components
(all properties derived from TWinControl)
- new functions SetValue, GetValue, SetProperties in gtk-interface
Revision 1.94 2000/01/03 00:19:21 lazarus
MWE:
Added keyup and buttonup events
Added LM_MOUSEMOVE callback
Started with scrollbars in editor
Revision 1.93 2000/01/02 00:28:00 lazarus
Stoppok:
- changes for creation of radiobuttons
Revision 1.92 1999/12/31 14:58:01 lazarus
MWE:
Set unkown VK_ codesto 0
Added pfDevice support for bitmaps
Revision 1.91 1999/12/30 19:49:07 lazarus
*** empty log message ***
Revision 1.90 1999/12/30 19:04:13 lazarus
- Made TRadiobutton work again
- Some more cleanups to checkbox code
stoppok
Revision 1.89 1999/12/30 18:54:35 lazarus
Fixed the problem that occured when more than one button was added to the toolbar.
Also, I set it up so practically any widget (component) can be added to the toolbar now. In main.pp I have a TCOMBOBOX control being added. I will create a example program and place it into the examples directory.
Shane
Revision 1.88 1999/12/30 10:38:59 lazarus
Some changes to Checkbox code.
stoppok
Revision 1.87 1999/12/29 20:38:23 lazarus
Modified the toolbar so it now displays itself. However, I can only add one button at this point. I will fix that soon....
Shane
Revision 1.86 1999/12/29 09:35:43 lazarus
MWE:
Reapplied lost changes
Revision 1.85 1999/12/29 00:39:35 lazarus
Changes to make trackbar/progressbar working again.
stopppok
Revision 1.84 1999/12/29 00:04:47 lazarus
MWE:
Refined key events. TODO get vk keycodes for non alpha keys
Revision 1.83 1999/12/28 01:10:53 lazarus
MWE:
Added most common virtual keycodes
Revision 1.82 1999/12/27 22:32:15 lazarus
MWE:
Fixed triple chars in editor. Events where fired more than once. Now
it is checked if there already exists a callback.
Revision 1.81 1999/12/23 21:48:13 lazarus
*** empty log message ***
Revision 1.78 1999/12/22 01:16:03 lazarus
MWE:
Changed/recoded keyevent callbacks
We Can Edit!
Commented out toolbar stuff
Revision 1.77 1999/12/21 21:35:52 lazarus
committed the latest toolbar code. Currently it doesn't appear anywhere and I have to get it to add buttons correctly through (I think) setstyle. I think I'll implement the LM_TOOLBARINSERTBUTTON call there.
Shane
Revision 1.76 1999/12/20 21:01:13 lazarus
Added a few things for compatability with Delphi and TToolbar
Shane
Revision 1.75 1999/12/18 18:27:31 lazarus
MWE:
Rearranged some events to get a LM_SIZE, LM_MOVE and LM_WINDOWPOSCHANGED
Initialized the TextMetricstruct to zeros to clear unset values
Get mwEdit to show more than one line
Fixed some errors in earlier commits
Revision 1.74 1999/12/14 22:21:11 lazarus
*** empty log message ***
Revision 1.73 1999/12/10 00:47:01 lazarus
MWE:
Fixed some samples
Fixed Dialog parent is no longer needed
Fixed (Win)Control Destruction
Fixed MenuClick
Revision 1.72 1999/12/08 00:56:07 lazarus
MWE:
Fixed menus. Events aren't enabled yet (dumps --> invalid typecast ??)
Revision 1.71 1999/12/07 01:19:25 lazarus
MWE:
Removed some double events
Changed location of SetCallBack
Added call to remove signals
Restructured somethings
Started to add default handlers in TWinControl
Made some parts of TControl and TWinControl more delphi compatible
... and lots more ...
Revision 1.70 1999/12/03 00:26:47 lazarus
MWE:
fixed control location
added gdiobject reference counter
Revision 1.69 1999/11/26 00:10:57 lazarus
MWE:
removed test unit
commented some obsolete parts
Revision 1.68 1999/11/25 23:45:08 lazarus
MWE:
Added font as GDIobject
Added some API testcode to testform
Commented out some more IFDEFs in mwCustomEdit
Revision 1.67 1999/11/19 14:44:37 lazarus
Changed the FONTSETNAME to try and load a default font if the first one doesn't work. This is being done for testing and probably will be removed later.
Shane
Revision 1.66 1999/11/19 01:09:43 lazarus
MWE:
implemented TCanvas.CopyRect
Added StretchBlt
Enabled creation of TCustomControl.Canvas
Added a temp hack in TWinControl.Repaint to get a LM_PAINT
Revision 1.65 1999/11/18 00:13:08 lazarus
MWE:
Partly Implemented SelectObject
Added ExTextOut
Added GetTextExtentPoint
Added TCanvas.TextExtent/TextWidth/TextHeight
Added TSize and HPEN
Revision 1.64 1999/11/17 01:16:39 lazarus
MWE:
Added some more API stuff
Added an initial TBitmapCanvas
Added some DC stuff
Changed and commented out, original gtk linedraw/rectangle code. This
is now called through the winapi wrapper.
Revision 1.63 1999/11/16 01:32:22 lazarus
MWE:
Added some more DC functionality
Revision 1.62 1999/11/15 00:40:22 lazarus
MWE:
Added GetDC, ReleaseDC, Rectangle functions
Revision 1.61 1999/11/13 13:03:34 lazarus
MWE:
Started to implement some platform dependent WINAPI stuff
Added a baseclass for InterfaceObject
Started messing around with canvasses
Revision 1.60 1999/11/05 00:34:10 lazarus
MWE: Menu structure updated, events and visible code not added yet
Revision 1.59 1999/11/01 01:28:29 lazarus
MWE: Implemented HandleNeeded/CreateHandle/CreateWND
Now controls are created on demand. A call to CreateComponent shouldn't
be needed. It is now part of CreateWnd
Revision 1.58 1999/10/28 17:17:42 lazarus
Removed references to FCOmponent.
Shane
Revision 1.57 1999/10/05 02:17:04 lazarus
Cleaned up the code to make it more readable. CAW
Revision 1.56 1999/09/30 21:59:01 lazarus
MWE: Fixed TNoteBook problems
Modifications: A few
- Removed some debug messages
+ Added some others
* changed fixed widged of TPage. Code is still broken.
+ TWinControls are also added to the Controls collection
+ Added TControl.Controls[] property
Revision 1.55 1999/09/26 13:30:15 lazarus
Implemented OnEnter & OnExit events for TTrackbar. These properties
and handler functions have been added to TWincontrol, two new
callbacks have been added to gtkcallback.
stoppok
Revision 1.54 1999/09/25 17:10:21 lazarus
Modified TEDIT to give the correct text when you use Edit1.Text
Thanks to Ned Boddie for noticing the error and sending the fix.
Revision 1.53 1999/09/23 20:33:30 lazarus
reintroduced changes to TTrackbar from v1.46 which where lost in 1.48.
Some addtional changes to TTrackbar also applied.
stoppok
Revision 1.52 1999/09/22 20:29:53 lazarus
*** empty log message ***
Revision 1.49 1999/09/21 23:46:54 lazarus
*** empty log message ***
Revision 1.48 1999/09/17 23:18:45 lazarus
Commented out a line in gtkobject that contaied the variable SCALEDIGITS that was not defined. Line 664
Editor has some additons as well.
Revision 1.46 1999/09/17 20:49:03 lazarus
Some changes to trackbar component (added lineSize/PageSize properties,
removed scaledigits property)
stoppok
Revision 1.45 1999/09/17 04:33:56 lazarus
Got the GETPIXEL and SETPIXEL to work (I think)
Shane
Revision 1.44 1999/09/15 03:45:23 lazarus
Modified Editor. It displays files now.
Revision 1.43 1999/09/15 03:17:31 lazarus
Changes to Editor.pp
If the text was actually displayed, then it would work better. :-)
Revision 1.42 1999/09/13 03:22:12 lazarus
Moved Notebook code to utilize IntSendMessage3 function. caw
Revision 1.41 1999/09/11 12:16:16 lazarus
Fixed a bug in key press evaluation. Initial cut at Invalidate problem.
Revision 1.40 1999/09/03 22:01:02 lazarus
Added TTrackBar
stoppok
Revision 1.39 1999/08/25 18:53:05 lazarus
Added Canvas.pixel property which allows
the user to get/set the pixel color. This will be used in the editor
to create the illusion of the cursor by XORing the pixel with black.
Shane
Revision 1.38 1999/08/24 20:18:01 lazarus
*** empty log message ***
Revision 1.37 1999/08/21 13:57:38 lazarus
Implemented TListBox.BorderStyle. The listbox is scrollable now.
Revision 1.36 1999/08/20 18:34:16 lazarus
*** empty log message ***
Revision 1.35 1999/08/19 18:40:53 lazarus
Added stuff for TProgressBar
stoppok Aug. 19 1999
Revision 1.34 1999/08/17 16:46:26 lazarus
Slight modification to Editor.pp
Shane
Revision 1.32 1999/08/16 22:32:45 peter
* commented move_resize which doesn't exists under gtk 1.2.3
Revision 1.31 1999/08/16 20:48:05 lazarus
Added a changed event for TFOnt and code to get the average size of the font. Doesn't seem to work very well yet.
The "average size" code is found in gtkobject.inc.
Revision 1.30 1999/08/16 18:45:42 lazarus
Added a TFont Dialog plus minor additions.
Shane Aug 16th 1999 14:07 CST
Revision 1.29 1999/08/15 16:17:57 lazarus
Win32 fix CEB
Revision 1.28 1999/08/14 10:05:54 lazarus
Added TListBox ItemIndex property. Made ItemIndex public for TComboBox and TListBox.
Revision 1.27 1999/08/07 17:59:21 lazarus
buttons.pp the DoLeave and DoEnter were connected to the wrong
event.
The rest were modified to use the new SendMessage function. MAH
Revision 1.26 1999/08/07 00:11:51 lazarus
Added the gtklistlh.inc and gtklistsi.inc files
Revision 1.25 1999/08/06 23:55:29 lazarus
Patched some files with a patch from Michal Bukovjan for
TComboBox and TListBox.
Revision 1.24 1999/08/04 19:52:47 lazarus
Fixed the cursor display problem on Linux.
KeyPRess still crashes.
Have to figure out how to calc where the cursor should be going yet.
Revision 1.23 1999/08/03 06:31:58 lazarus
Moved all TNotebook GTK code to gtkint units
Revision 1.22 1999/08/03 02:52:22 lazarus
Added changes for CustomComboBox
Revision 1.21 1999/08/01 21:46:28 lazarus
Modified the GETWIDTH and GETHEIGHT of TFOnt so you can use it to calculate the length in Pixels of a string. This is now used in the editor.
Shane
Revision 1.20 1999/08/01 00:07:44 lazarus
Alignment Changes CEB
Revision 1.19 1999/07/31 06:39:29 lazarus
Modified the IntSendMessage3 to include a data variable. It isn't used
yet but will help in merging the Message2 and Message3 features.
Adjusted TColor routines to match Delphi color format
Added a TGdkColorToTColor routine in gtkproc.inc
Finished the TColorDialog added to comDialog example. MAH
}
Reference in New Issue View Git Blame Copy Permalink