(****************************************************************************** TGTKObject ******************************************************************************) {$IFOPT C-} // Uncomment for local trace // {$C+} // {$DEFINE ASSERT_IS_ON} {$ENDIF} 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; FKeyStateList := TList.Create; FDeviceContexts := TDynHashArray.Create(-1); FGDIObjects := TDynHashArray.Create(-1); FMessageQueue := TLazQueue.Create; FPaintMessages := TDynHashArray.Create(-1); FPaintMessages.OwnerHashFunction := @HashPaintMessage; FAccelGroup := gtk_accel_group_new(); FTimerData := TList.Create; end; {------------------------------------------------------------------------------ Method: Tgtkobject.Destroy Params: None Returns: Nothing Destructor for the class. ------------------------------------------------------------------------------} destructor TgtkObject.Destroy; const GDITYPENAME: array[TGDIType] of String = ('gdiBitmap', 'gdiBrush' ,'gdiFont', 'gdiPen', 'gdiRegion'); var n: Integer; p: PMsg; pTimerInfo : PGtkITimerinfo; GDITypeCount: array[TGDIType] of Integer; GDIType: TGDIType; HashItem: PDynHashArrayItem; QueueItem, OldQueueItem: PLazQueueItem; begin // tidy up the messages QueueItem:=FMessageQueue.First; while (QueueItem<>nil) do begin p := PMsg(QueueItem^.Data); if p^.Message=LM_PAINT then begin //writeln('[TgtkObject.Destroy] freeing unused paint message ',HexStr(p^.WParam,8)); FPaintMessages.Remove(QueueItem); ReleaseDC(0,P^.WParam); Dispose(P); OldQueueItem:=QueueItem; QueueItem:=QueueItem^.Next; FMessageQueue.Delete(OldQueueItem); end else QueueItem:=QueueItem^.Next; end; if FPaintMessages.Count>0 then begin WriteLn('[TgtkObject.Destroy] WARNING: There are ',FPaintMessages.Count ,' unremoved LM_PAINT message links left.'); end; if (FDeviceContexts.Count > 0) then begin WriteLN(Format('[TgtkObject.Destroy] WARNING: There are %d unreleased DCs, a detailed dump follows:' ,[FDeviceContexts.Count])); n:=0; write('[TgtkObject.Destroy] DCs: '); HashItem:=FDeviceContexts.FirstHashItem; while (n<7) and (HashItem<>nil) do begin write(' ',HexStr(Cardinal(HashItem^.Item),8)); HashItem:=HashItem^.Next; inc(n); end; writeln(); end; if (FGDIObjects.Count > 0) then begin WriteLN(Format('[TgtkObject.Destroy] WARNING: There are %d unreleased GDIObjects, a detailed dump follows:' ,[FGDIObjects.Count])); for GDIType := Low(GDIType) to High(GDIType) do begin for GDIType := Low(GDIType) to High(GDIType) do GDITypeCount[GDIType] := 0; n:=0; write('[TgtkObject.Destroy] GDIOs:'); HashItem := FGDIObjects.FirstHashItem; while (HashItem <> nil) do begin if n < 7 then write(' ',HexStr(Cardinal(HashItem^.Item),8)); Inc(GDITypeCount[PGdiObject(HashItem^.Item)^.GDIType]); HashItem := HashItem^.Next; Inc(n); end; Writeln(); for GDIType := Low(GDIType) to High(GDIType) do if GDITypeCount[GDIType] > 0 then WriteLN(Format('[TgtkObject.Destroy] %s: %d', [GDITYPENAME[GDIType], GDITypeCount[GDIType]])); end; 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])); while FMessageQueue.First<>nil do begin p := PMsg(FMessageQueue.First^.Data); Dispose(P); FMessageQueue.Delete(FMessageQueue.First); end; end; n := FTimerData.Count; if (n > 0) then begin WriteLN(Format('[TgtkObject.Destroy] WARNING: There are %d TimerInfo structures left, I''ll free them' ,[n])); while (n > 0) do begin dec (n); pTimerInfo := PGtkITimerinfo (FTimerData.Items[n]); Dispose (pTimerInfo); FTimerData.Delete (n); end; end; FMessageQueue.Free; FPaintMessages.Free; FDeviceContexts.Free; FGDIObjects.Free; FKeyStateList.Free; FTimerData.Free; gtk_accel_group_unref(FAccelGroup); inherited Destroy; end; {------------------------------------------------------------------------------ Method: TGtkObject.HandleEvents Params: None Returns: Nothing *Note: Handle all pending messages of the GTK engine ------------------------------------------------------------------------------} procedure TgtkObject.HandleEvents; var Msg: TMsg; p: pMsg; begin //gtk_main; // first let gtk handle all its messages while gtk_events_pending<>0 do gtk_main_iteration_do(False); // then handle our own messages with FMessageQueue do while First<>nil do begin p := PMsg(First^.Data); Msg := p^; if Msg.Message=LM_PAINT then FPaintMessages.Remove(First); Delete(First); with Msg do SendMessage(hWND, Message, WParam, LParam); case Msg.Message of LM_PAINT: ReleaseDC(0,Msg.WParam); end; Dispose(p); end; end; {------------------------------------------------------------------------------ Method: TGtkObject.WaitMessage Params: None Returns: Nothing *Note: Passes execution control to the GTK engine ------------------------------------------------------------------------------} procedure TgtkObject.WaitMessage; begin gtk_main_iteration_do(True); 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); gdk_Cursor_Destroy(Cursor_StdArrow); gdk_Cursor_Destroy(Cursor_HSplit); gdk_Cursor_Destroy(Cursor_VSplit); gdk_Cursor_Destroy(Cursor_SizeNWSE); gdk_Cursor_Destroy(Cursor_SizeNS); gdk_Cursor_Destroy(Cursor_SizeNESW); gdk_Cursor_Destroy(Cursor_SizeWE); gtk_object_unref(PGTKObject(FGTKToolTips)); FGTKToolTips := nil; DeleteObject(FStockNullBrush); DeleteObject(FStockBlackBrush); DeleteObject(FStockLtGrayBrush); DeleteObject(FStockGrayBrush); DeleteObject(FStockDkGrayBrush); DeleteObject(FStockWhiteBrush); // MG: using gtk_main_quit is not a clean way to close //gtk_main_quit; end; {------------------------------------------------------------------------------ Method: TGtkObject.Init Params: None Returns: Nothing *Note: Initialite GTK engine ------------------------------------------------------------------------------} procedure TGtkObject.Init; var LogBrush: TLogBrush; //Attributes: TGdkWindowAttr; //AttributesMask: gint; FG,BG : TgdkColor; //foreground and background begin // initialize app level gtk engine gtk_set_locale (); // call init and pass cmd line 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); Cursor_StdArrow := gdk_Cursor_New(GDK_LEft_Ptr); Cursor_HSplit := gdk_Cursor_New(GDK_SB_H_DOUBLE_ARROW); Cursor_VSplit := gdk_Cursor_New(GDK_SB_V_DOUBLE_ARROW); Cursor_SizeNWSE := gdk_Cursor_New(GDK_TOP_LEFT_CORNER); Cursor_SizeNS := gdk_Cursor_New(GDK_SB_V_DOUBLE_ARROW); Cursor_SizeNESW := gdk_Cursor_New(GDK_BOTTOM_LEFT_CORNER); Cursor_SizeWE := gdk_Cursor_New(GDK_SB_H_DOUBLE_ARROW); gtk_key_snooper_install(@GTKKeySnooper, @FKeyStateList); // Init tooltips FGTKToolTips := gtk_tooltips_new; gtk_object_ref(PGTKObject(FGTKToolTips)); gtk_toolTips_Enable(FGTKToolTips); FG.red := $FFFF; FG.Green := $FFFF; fg.blue := $FFFF; BG.REd := $4444; bg.Green := $ffff; bg.Blue := $1111; gtk_toolTips_set_colors(FGTKToolTips,@FG,@BG); // Init stock objects; LogBrush.lbStyle := BS_NULL; FStockNullBrush := CreateBrushIndirect(LogBrush); LogBrush.lbStyle := BS_SOLID; LogBrush.lbColor := $000000; FStockBlackBrush := CreateBrushIndirect(LogBrush); LogBrush.lbColor := $C0C0C0; FStockLtGrayBrush := CreateBrushIndirect(LogBrush); LogBrush.lbColor := $808080; FStockGrayBrush := CreateBrushIndirect(LogBrush); LogBrush.lbColor := $404040; FStockDkGrayBrush := CreateBrushIndirect(LogBrush); LogBrush.lbColor := $FFFFFF; FStockWhiteBrush := CreateBrushIndirect(LogBrush); // clipboard ClipboardTypeAtoms[ctPrimarySelection]:=GDK_SELECTION_PRIMARY; ClipboardTypeAtoms[ctSecondarySelection]:=GDK_SELECTION_SECONDARY; ClipboardTypeAtoms[ctClipboard]:=gdk_atom_intern('CLIPBOARD',0); end; function TgtkObject.RecreateWnd(Sender: TObject): Integer; var aParent : TWinControl; Begin //could we just call IntSendMessage?? //destroy old widget if TWinControl(Sender).HandleAllocated then begin if MCaptureHandle=TWinControl(Sender).Handle then MCaptureHandle:=0; gtk_widget_destroy(PgtkWidget(TWinControl(Sender).Handle)); end; aParent := TWinControl(Sender).Parent; aParent.RemoveControl(TControl(Sender)); TWincontrol(Sender).Parent := nil; TWincontrol(Sender).Parent := aParent; //writeln('[TgtkObject.RecreateWnd] ',Sender.ClassName); ResizeChild(Sender,TWinControl(Sender).Left,TWinControl(Sender).Top, TWinControl(Sender).Width,TWinControl(Sender).Height); ShowHide(Sender); Result:=0; 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 handle : hwnd; // handle of sender pStr : PChar; // temporary string pointer, must be allocated/disposed when used! Widget : PGtkWidget; // pointer to gtk-widget (local use when neccessary) AParent : TWinControl; // only used twice, replace with typecasts! Pixmap : pgdkPixMap; box1 : pgtkWidget; // currently only used for TBitBtn pixmapwid : pGtkWidget; // currently only used for TBitBtn, possibly replace with pixmap!!!! pLabel : PgtkWidget; // currently only used as extra label-widget for TBitBtn Num : Integer; // currently only used for LM_INSERTTOOLBUTTON and LM_ADDITEM pStr2 : PChar; // currently only used for LM_INSERTTOOLBUTTON GList : pGList; // Only used for listboxes, replace with widget!!!!! SelectionMode : TGtkSelectionMode; // currently only used for listboxes ListItem : PGtkListItem; // currently only used for listboxes AddItemListItem : TListItem; Rect : TRect; FormIconGdiObject: PGdiObject; // currently only used by LM_SETFORMICON QueueItem, OldQueueItem: PLazQueueItem; // currently only used by LM_DESTROY MsgPtr : PMsg; // currently only used by LM_DESTROY Count : Integer; //Used in TListView LM_LV_CHANGEITEM Titles : Array [0..255] of PChar; begin Result := 0; //default value just in case nothing sets it Assert(False, 'Trace:Message received'); 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)])); // The following case is now split into 2 separate parts: // 1st part should contain all messages which don't need the "handle" variable // 2nd part has to contain all parts which need the handle // Reason for this split are performance issues since we need RTTI to // retrieve the handle case LM_Message of LM_Create : CreateComponent(Sender); 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_SetCursor : SetCursor(Sender); LM_SetLabel : SetLabel(Sender,Data); LM_GETVALUE : Result := GetValue (Sender, data); LM_SETVALUE : Result := SetValue (Sender, data); LM_SETPROPERTIES: Result := SetProperties(Sender); { LM_SETDESIGNING Used in Main.pp. Used to set anything specifically needed when setting controls to Designing. } LM_SETDESIGNING : Begin //Result := SetDesigning(sender); //trying to prevent some key actions.... //this didn't work.... //if not (csAcceptsControls in TControl(Sender).ControlStyle) then gtk_widget_set_sensitive(PgtkWidget(TWinControl(sender).Handle),False); if (Sender is TCustomComboBox) then begin gtk_combo_disable_activate(PGTKCombo(TWinControl(sender).handle)); end; end; LM_RECREATEWND : Result := RecreateWnd(sender); LM_ATTACHMENU: AttachMenu(Sender); else begin handle := hwnd(ObjectToGtkObject(Sender)); //??? if handle = nil then assert (false, Format ('Trace: [TgtkObject.IntSendMessage3] %s --> got handle=nil',[Sender.ClassName])); Case LM_Message of LM_SetText : SetText(PgtkWidget(Handle), Data); 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; if Not Assigned(AParent) then Begin Assert(true, Format('Trace: [TgtkObject.IntSendMessage3] %s --> Parent is not assigned', [Sender.ClassName])); end else Begin Assert(False, Format('Trace: [TgtkObject.IntSendMessage3] %s --> Calling Add Child: %s', [AParent.ClassName, Sender.ClassNAme])); AddChild(Pgtkwidget(AParent.Handle), PgtkWidget(Handle), AParent.Left, AParent.Top); end; end; end; {Used by: TListView } LM_LV_DELETEITEM : begin if (Sender is TListView) then begin writeln('IN LM_LV_DELETEITEM'); Num := Integer(data^); gtk_clist_remove(PgtkCList(Handle),Num); end; end; LM_LV_CHANGEITEM : begin writeln('IN LM_LV_CHANGEITEM'); if (Sender is TListView) then begin Num := Integer(data^); Writeln('NUM,Rows = ',num,',',PGTKCList(Handle)^.rows); AddItemListItem := TListView(sender).Items[Num]; Writeln('AddItemListItem.Caption = ',AddItemListItem.Caption); pStr := StrAlloc(length(AddItemListItem.Caption) + 1); StrPCopy(pStr, AddItemListItem.Caption); gtk_clist_set_text(PgtkCList(Handle),num,0,pStr); StrDispose(pStr); for count := 0 to AddItemListItem.SubItems.Count-1 do Begin pStr := StrAlloc(length(AddItemListItem.SubItems.Strings[Count]) + 1); StrPCopy(pStr, AddItemListItem.SubItems.Strings[Count]); gtk_clist_set_text(PgtkCList(Handle),num,count+1,pStr); StrDispose(pStr); end; end; end; LM_LV_ADDITEM : begin if (Sender is TListView) then begin //get last item and add it.. Writeln('LV_AddItem'); pStr := StrAlloc(length('Test') + 1); StrPCopy(pStr, 'Test'); Titles[0] := pStr; for Count := 1 to 255 do Titles[Count] := nil; Num := gtk_clist_append(PgtkCList(Handle),@Titles); Writeln('NUm in AddItem is =',num); StrDispose(pStr); AddItemListItem := TListView(sender).Items[TListView(sender).Items.Count-1]; if AddItemListItem <> nil then Begin gtk_clist_set_text(PgtkCList(handle),num,0,@AddItemListItem.Caption); end; Writeln('LV_AddItem DONE'); end; end; LM_BRINGTOFRONT: begin { Assert(False, 'Trace:TODO:bringtofront'); //For now just hide and show again. if (Sender is TControl) then begin TControl(Sender).Parent.RemoveControl(TControl(Sender)); writeln('Removed control ', TControl(Sender).Name); TControl(Sender).Parent.InsertControl(TControl(Sender)); writeln('Inserted control ', TControl(Sender).Name); end; } if (Sender is TCustomForm) then Begin Widget := PgtkWidget(TCustomForm(Sender).Handle); gdk_window_raise(Widget^.Window); end; end; LM_BTNDEFAULT_CHANGED : Begin if (TButton(Sender).Default) and (GTK_WIDGET_CAN_DEFAULT(pgtkwidget(handle))) then gtk_widget_grab_default(pgtkwidget(handle)) else gtk_widget_Draw_Default(pgtkwidget(Handle)); //this isn't right but I'm not sure what to call end; LM_DESTROY : begin if (Sender is TWinControl) or (Sender is TCommonDialog) then begin //writeln('>>> LM_DESTROY ',Sender.Classname,' Sender=',HexStr(Cardinal(Sender),8),' Handle=',HexStr(Cardinal(Handle),8)); if Handle<>0 then begin if MCaptureHandle=Handle then MCaptureHandle:=0; if ClipboardWidget=PGtkWidget(Handle) then begin // clipboard widget destroyed if (Application<>nil) and (Application.MainForm<>nil) and (Application.MainForm.HandleAllocated) and (Application.MainForm.Handle<>Handle) then // there is still the main form left -> use it for clipboard SetClipboardWidget(PGtkWidget(Application.MainForm.Handle)) else // program closed -> close clipboard SetClipboardWidget(nil); end; //writeln('>>> LM_DESTROY A ',Sender.Classname,' Sender=',HexStr(Cardinal(Sender),8),' Handle=',HexStr(Cardinal(Handle),8)); { MG: Important: If Sender is TForm and one of its components was focused by SetFocus then the next line will produce a gtk warning. The PGtkWidget(Handle) is also a dirty cast. If Sender is TForm, Handle is a PGtkWindow ! } if gtk_type_is_a(gtk_object_type(PGtkObject(Handle)), GTKAPIWidget_GetType) then DestroyCaret(Handle); gtk_widget_destroy(PGtkWidget(Handle)); //writeln('>>> LM_DESTROY END ',Sender.Classname,' Sender=',HexStr(Cardinal(Sender),8),' Handle=',HexStr(Cardinal(Handle),8)); end; // remove all remaining messages to this component QueueItem:=FMessageQueue.First; while (QueueItem<>nil) do begin MsgPtr := PMsg(QueueItem^.Data); if MsgPtr^.HWnd=Handle then begin // remove message if MsgPtr^.Message=LM_PAINT then begin FPaintMessages.Remove(QueueItem); ReleaseDC(0,MsgPtr^.WParam); end; Dispose(MsgPtr); OldQueueItem:=QueueItem; QueueItem:=QueueItem^.Next; FMessageQueue.Delete(OldQueueItem); end else QueueItem:=QueueItem^.Next; end; end else Assert (False, Format ('Trace:Dont know how to destroy component %s', [sender.classname])); 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:********************'); Assert(False, 'Trace:1'); box1 := gtk_object_get_data(pgtkObject(handle),'HBox'); if box1 <> nil then begin Assert(False, 'Trace:REMOVING THE HBOX'); gtk_container_remove(PgtkContainer(box1),gtk_object_get_data(pgtkObject(handle),'Label')); PixMapWid:=gtk_object_get_data(pgtkObject(handle),'Pixmap'); if PixMapWid<>nil then gtk_container_remove(PgtkContainer(box1),PixMapWid); gtk_container_remove(PgtkContainer(handle),box1); // gtk_container_remove automatically destroys box1 if ref count=0 // so we dont need 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 begin PixMapWid := gtk_pixmap_new(pixmap, PgdiObject(TBitBtn(Sender).Glyph.handle)^.GDIBitmapMaskObject) end else begin PixMapWid := gtk_pixmap_new(pixmap,nil); end; Assert(False, 'Trace:4'); pStr := StrAlloc(length(TBitBtn(Sender).Caption) + 1); StrPCopy(pStr, TBitBtn(Sender).Caption); 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(handle),'HBox',Box1); gtk_object_set_data(pgtkObject(handle),'Label',pLabel); gtk_object_set_data(pgtkObject(handle),'Pixmap',PixMapWid); Assert(False, 'Trace:7'); gtk_widget_show(pixmapwid); gtk_widget_show(pLabel); gtk_container_add(PgtkContainer(handle),box1); gtk_widget_show(box1); Assert(False, 'Trace:********************'); end; //SH: think of TBitmap.handle!!!! 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_POPUPSHOW : Begin gtk_menu_popup (PgtkMenu(TPopupMenu(Sender).Handle), nil, nil, nil, nil, 0, 0); {Displays a menu and makes it available for selection. Applications can use this function to display context-sensitive menus, and will typically supply NULL for the parent_menu_shell, parent_menu_item, func and data parameters. The default menu positioning function will position the menu at the current pointer position. menu : a GtkMenu. parent_menu_shell : the menu shell containing the triggering menu item. parent_menu_item : the menu item whose activation triggered the popup. func : a user supplied function used to position the menu. data : user supplied data to be passed to func. button : the button which was pressed to initiate the event. activate_time : the time at which the activation event occurred. } end; LM_SETFILTER : begin if Sender is TFileDialog then begin pStr := StrAlloc(length(TFileDialog(Sender).Filter) + 1); try StrPCopy(pStr, TFileDialog(Sender).Filter); gtk_file_selection_complete(PGtkFileSelection(Handle), pstr); finally StrDispose(pStr); end; end; end; LM_SETFILENAME : begin if Sender is TFileDialog then begin pStr := StrAlloc(length(TFileDialog(Sender).Filename) + 1); try StrPCopy(pStr, TFileDialog(Sender).Filename); gtk_file_selection_set_filename( PGtkFileSelection(Handle), pStr); finally StrDispose(pStr); end; end; end; LM_SETFOCUS: begin writeln('[TgtkObject.IntSendMessage3] LM_SETFOCUS ',TObject(Sender).ClassName); if GTK_WIDGET_CAN_FOCUS(PgtkWidget(Handle)) then gtk_widget_grab_focus(PgtkWidget(handle)) else Writeln('The control '+TControl(Sender).name+' can not get focus'); end; LM_SetSize : begin Assert(False, Format('Trace: [TgtkObject.IntSendMessage3] %s --> LM_SetSize(%d, %d, %d, %d)', [Sender.ClassNAme, PRect(Data)^.Left,PRect(Data)^.Top,PRect(Data)^.Right,PRect(Data)^.Bottom])); //writeln('[IntSendMessage3.lm_setsize] Left=',PRect(Data)^.Left,' Top=',PRect(Data)^.Top, // ' Right=',PRect(Data)^.Right,' Bottom=',PRect(Data)^.Bottom); //writeln('[LM_SetSize] A ',Sender.ClassName,' ',PgtkWidget(Handle)^.window<>nil); ResizeChild(Sender,PRect(Data)^.Left,PRect(Data)^.Top, PRect(Data)^.Right,PRect(Data)^.Bottom); //writeln('[LM_SetSize] B ',Sender.ClassName,' ',PgtkWidget(Handle)^.window<>nil); end; LM_ShowModal : begin if Sender is TCommonDialog then begin // Should be done elsewhere (eg via SetLabel) not here! pStr:= StrAlloc(Length(TCommonDialog(Sender).Title) + 1); try StrPCopy(pStr, TCommonDialog(Sender).Title); gtk_window_set_title(PGtkWindow(handle), pStr); finally StrDispose(pStr); end; end; gtk_window_set_position(PGtkWindow(handle), GTK_WIN_POS_CENTER); if Sender is TColorDialog then SetColorDialogColor(Pointer(Handle),TColorDialog(Sender).Color); gtk_widget_show(PGtkWidget(handle)); gtk_window_set_modal(PGtkWindow(handle), true); end; LM_TB_BUTTONCOUNT: begin if (Sender is TToolbar) then Result := pgtkToolbar(handle)^.num_Children else Result := -1; end; //SH: think of TCanvas.handle!!!! 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 begin if Sender is TControl then ReDraw(PgtkWidget(Handle)) end else If TSpeedbutton(sender).Visible then (Sender as TSpeedButton).Perform(LM_PAINT,0,0) else Begin Rect := TSpeedButton(sender).BoundsRect; InvalidateRect(TSpeedButton(sender).Parent.Handle,@Rect,True); end; end; LM_AddPage : begin if Sender is TControl then 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; end; LM_RemovePage : begin if Sender is TControl then RemoveNBPage(TControl(Sender), TLMNotebookEvent(Data^).Page); end; LM_ShowTabs : begin gtk_notebook_set_show_tabs(PGtkNotebook(Handle), Boolean(Integer(TLMNotebookEvent(Data^).ShowTabs))); end; LM_SetTabPosition : begin case TTabPosition(TLMNotebookEvent(Data^).TabPosition^) of tpTop : gtk_notebook_set_tab_pos(PGtkNotebook(Handle), GTK_POS_TOP); tpBottom: gtk_notebook_set_tab_pos(PGtkNotebook(Handle), GTK_POS_BOTTOM); tpLeft : gtk_notebook_set_tab_pos(PGtkNotebook(Handle), GTK_POS_LEFT); tpRight : gtk_notebook_set_tab_pos(PGtkNotebook(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); try StrPCopy(pStr,TToolbutton(SENDER).Caption); pStr2 := StrAlloc(Length(TControl(Sender).Hint)+1); finally StrPCopy(pStr2,TControl(Sender).Hint); end; 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 handle = 0 then IntSendMessage3(LM_CREATE,Sender,nil); gtk_toolbar_insert_widget(pGTKToolbar(TWinControl(sender).parent.Handle), pgtkwidget(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); // Next 3 lines: should be same as above, remove when above lines are proofed // 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(Handle)^.Window; Event.Send_Event := 0; Event.X := 0; Event.Y := 0; Event.Width := PgtkWidget((Handle)^.Allocation.Width; Event.Height := PgtkWidget(Handle)^.Allocation.Height; gtk_Signal_Emit_By_Name(PgtkObject(Handle),'expose_event',[(Sender as TWinControl).Handle,Sender,@Event]); Assert(False, 'Trace:Signal Emitted - invalidate window'); } gtk_widget_queue_draw(PGtkWidget(Handle)); end; LM_SETFORMICON : begin if Sender is TCustomForm then begin if (Handle<>0) and (Data<>nil) then begin FormIconGdiObject:=Data; //writeln('LM_SETFORMICON ',FormIconGdiObject<>nil,' ',pgtkWidget(Handle)^.Window<>nil); if (FormIconGdiObject<>nil) and (pgtkWidget(Handle)^.Window<>nil) then begin gdk_window_set_icon(pgtkWidget(Handle)^.Window, nil, FormIconGdiObject^.GDIBitmapObject, FormIconGdiObject^.GDIBitmapMaskObject); end; end; end; end; LM_SCREENINIT : begin { 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(Handle)); Data := TGtkCListStringList.Create(PGtkCList(Widget)); Result := integer(Data); end else begin case (Sender as TControl).fCompStyle of csComboBox : Widget:= PGtkCombo(Handle)^.list; csListBox : Widget:= GetCoreChildWidget(PGtkWidget(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 Handle<>0 then begin if TListBox(Sender).MultiSelect then Widget:= PGtkList( GetCoreChildWidget(PGtkWidget(Handle)))^.last_focus_child else begin GList:= PGtkList( GetCoreChildWidget(PGtkWidget(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(Handle))), Widget); end else Result:=-1; end; csCListBox: begin GList:= PGtkCList(GetCoreChildWidget(PGtkWidget(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(Handle)); end; end; end; LM_SETITEMINDEX : begin case (Sender as TControl).fCompStyle of csComboBox: gtk_list_select_item(PGTKLIST(PGTKCOMBO(Handle)^.list), Integer(Data)); csListBox : gtk_list_select_item(PGtkList(GetCoreChildWidget(PGtkWidget(Handle))), Integer(Data)); csCListBox: gtk_clist_select_row(PGtkCList(GetCoreChildWidget(PGtkWidget(Handle))), Integer(Data), 1); // column csNotebook: begin Assert(False, 'Trace:Setting Page to ' + IntToStr(TLMNotebookEvent(Data^).Page)); //writeln('LM_SETITEMINDEX A ',HexStr(Cardinal(Handle),8),', ',TLMNotebookEvent(Data^).Page); gtk_notebook_set_page(PGtkNotebook(Handle), TLMNotebookEvent(Data^).Page); //writeln('LM_SETITEMINDEX B ',TLMNotebookEvent(Data^).Page); end; end; end; LM_GETSELSTART : begin if (Sender as TControl).fCompStyle = csComboBox then begin Result:= gtk_editable_get_position(PGtkEditable(PGtkCombo(Handle)^.entry)); end; end; LM_GETSELLEN : begin if (Sender as TControl).fCompStyle = csComboBox then begin Result:= PGtkEditable(PGtkCombo(Handle)^.entry)^.selection_end_pos - PGtkEditable(PGtkCombo(Handle)^.entry)^.selection_start_pos; end; end; LM_GETLIMITTEXT : begin if (Sender as TControl).fCompStyle = csComboBox then begin Result:= PGtkEntry(PGtkCombo(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(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(Handle)^.entry), gtk_editable_get_position(PGtkEditable(PGtkCombo(Handle)^.entry)), gtk_editable_get_position(PGtkEditable(PGtkCombo(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(Handle)))^.selection); csCListBox: Result:= g_list_length(PGtkCList(GetCoreChildWidget(PGtkWidget(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(Handle)))^.children, Integer(Data^)); Result:= g_list_index(PGtkList(GetCoreChildWidget(PGtkWidget(Handle)))^.selection, ListItem); end else if (Sender as TControl).fCompStyle = csCListBox then begin { Get the selections } GList:= PGtkCList(GetCoreChildWidget(PGtkWidget(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(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(Handle))), TLMSetSel(Data^).Index) else gtk_list_unselect_item(PGtkList(GetCoreChildWidget(PGtkWidget(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(Handle))),TLMSetSel(Data^).Index,0) else gtk_clist_unselect_row(PGtkCList(GetCoreChildWidget(PGtkWidget(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 TControl(Sender).fCompStyle of csListBox : gtk_list_set_selection_mode(PGtkList(GetCoreChildWidget(PGtkWidget(Handle))), SelectionMode); csCListBox : gtk_clist_set_selection_mode(PGtkCList(GetCoreChildWidget(PGtkWidget(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) then begin if (TControl(Sender).fCompStyle = csListBox) then begin { In TempWidget, a viewport is stored } Widget:= PGtkWidget(PGtkBin(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 else if TControl(Sender).fCompStyle = csCListBox then begin if TListBox(Sender).BorderStyle = TBorderStyle(bsSingle) then gtk_clist_set_shadow_type( PGtkCList(GetCoreChildWidget(PGtkWidget(Handle))), GTK_SHADOW_IN) else gtk_clist_set_shadow_type( PGtkCList(GetCoreChildWidget(PGtkWidget(Handle))), GTK_SHADOW_NONE); end; end; end; else if Sender<>nil then Assert(True, Format('WARNING: Unhandled message %d in IntSendMessage3' +'send by %s --> message:Redraw', [LM_Message, Sender.ClassName])); // unhandled message end; // end of 2nd case end; // end of else-part of 1st case end; // end of 1st case 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; IsTopLevelWidget: boolean; begin //writeln('[TgtkObject.ResizeChild] START ',TControl(Sender).Name,':',Sender.Classname,' Left=',Left,' Top=',Top,' Width=',Width,' Height=',Height); Assert(false, (Format('trace: [TgtkObject.ResizeChild] %s --> Resize', [Sender.ClassNAme]))); Parent := TControl(Sender).Parent; if Sender is TWinControl then begin if TWinControl(Sender).HandleAllocated then begin if not (Sender is TSpeedButton) then begin pWidget := pgtkWidget(TWinControl(Sender).Handle); IsTopLevelWidget:=(Sender is TCustomForm) and (Parent=nil); if IsTopLevelWidget then gtk_window_set_default_size(PgtkWindow(pWidget),Width,Height); if IsTopLevelWidget then gtk_widget_set_usize(pWidget, -1, -1); gtk_widget_set_usize(pWidget, Width, Height); //writeln('[TgtkObject.ResizeChild] D IsTopLevelWidget=',IsTopLevelWidget); if not IsTopLevelWidget then begin if Parent<>nil then begin pFixed := GetFixedWidget(PGtkWidget(Parent.Handle)); if pFixed <> nil then begin gtk_fixed_move(pFixed, pWidget, Left, Top); end else begin Assert(False, 'Trace:ERROR!!!! - no Fixed Widget found to use when resizing....'); end; end else begin Assert(False, 'Trace:ERROR !!! - no Fixed Widget found to use when resizing....'); raise Exception('ARG2'); end; end else begin gtk_widget_set_uposition(pWidget, Left, Top); end; end; end; end; //writeln('[TgtkObject.ResizeChild] END ',Sender.Classname,' Left=',Left,' Top=',Top,' Width=',Width,' Height=',Height); 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 num : Integer; begin case pMsg(Data)^.fCompStyle of csStatusBar : begin num := gtk_statusbar_get_context_id(PGTKStatusBar(Child),PChar(inttostr(pMsg(Data)^.panel))); gtk_statusbar_push(PGTKStatusBar(Child),num,pMsg(Data)^.Userdata); end else writeln ('STOPPOK: [TGtkObject.SetText] Possible superfluous use of SetText, use SetLabel instead!'); end; {STOPPOK: Code seems superfluous, see SetLabel instead} 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); crHourGlass: gdk_window_set_cursor (pgtkWidget(TWinControl(Sender).Handle)^.window, Cursor_Watch); crDefault : gdk_window_set_cursor (pgtkWidget(TWinControl(Sender).Handle)^.window, Cursor_StdArrow); crHSplit : gdk_window_set_cursor (pgtkWidget(TWinControl(Sender).Handle)^.window, Cursor_HSplit); crVSplit : gdk_window_set_cursor (pgtkWidget(TWinControl(Sender).Handle)^.window, Cursor_VSplit); crSizeNWSE : gdk_window_set_cursor (pgtkWidget(TWinControl(Sender).Handle)^.window, Cursor_SizeNWSE); crSizeNS : gdk_window_set_cursor (pgtkWidget(TWinControl(Sender).Handle)^.window, Cursor_SizeNS); crSizeNESW : gdk_window_set_cursor (pgtkWidget(TWinControl(Sender).Handle)^.window, Cursor_SizeNESW); crSizeWE : gdk_window_set_cursor (pgtkWidget(TWinControl(Sender).Handle)^.window, Cursor_SizeWE); 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 begin Assert(False, Format('Trace:WARNING: [TgtkObject.SetLabel] %s --> No Decendant of TWinControl', [Sender.ClassName])); writeln('[TgtkObject.SetLabel] ERROR: Sender (',Sender.Classname,')' ,'is not TWinControl '); Halt; end; 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: 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 if (Sender is TCustomForm) then Begin ConnectSignal(gObject, 'focus-in-event', @gtkfrmactivate); ConnectSignal(gObject, 'focus-out-event', @gtkfrmdeactivate); end else ConnectSignal(gObject, 'activate', @gtkactivateCB); end; LM_ACTIVATEITEM : begin ConnectSignal(gObject, 'activate-item', @gtkactivateCB); end; LM_CHANGED : if sender is TTrackBar then begin ConnectSignal(gtk_Object(gtk_range_get_adjustment( GTK_RANGE(gObject))) , 'value_changed', @gtkvaluechanged); end 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', @gtkchanged_editbox); LM_CLICKED : begin ConnectSignal(gObject, 'clicked', @gtkclickedCB); end; LM_CONFIGUREEVENT : begin ConnectSignal(gObject, 'configure-event', @gtkconfigureevent); end; LM_DAYCHANGED : //calendar Begin ConnectSignal(gObject, 'day-selected', @gtkdaychanged); ConnectSignal(gObject, 'day-selected-double-click', @gtkdaychanged); end; LM_PAINT : begin 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); if (sender is TCustomComboBox) then Begin ConnectSignal(PgtkObject(PgtkCombo(TCustomComboBox(sender).handle)^.entry), 'focus-in-event', @gtkFocusCB); ConnectSignal(PgtkObject(PgtkCombo(TCustomComboBox(sender).handle)^.entry), 'focus-out-event', @gtkKillFocusCB); ConnectSignal(PgtkObject(PgtkCombo(TCustomComboBox(sender).handle)^.list), 'focus-in-event', @gtkFocusCB); ConnectSignal(PgtkObject(PgtkCombo(TCustomComboBox(sender).handle)^.list), 'focus-out-event', @gtkKillFocusCB); end else Begin ConnectSignal(gObject, 'focus-in-event', @gtkFocusCB); ConnectSignal(gObject, 'focus-out-event', @gtkKillFocusCB); end; end; LM_KEYDOWN, LM_CHAR, LM_KEYUP, LM_SYSKEYDOWN, LM_SYSCHAR, LM_SYSKEYUP: begin if (sender is TComboBox) then Begin ConnectSignal(PgtkObject(PgtkCombo(TComboBox(sender).handle)^.entry), 'key-press-event', @GTKKeyUpDown, GDK_KEY_PRESS_MASK); ConnectSignal(PgtkObject(PgtkCombo(TComboBox(sender).handle)^.entry), 'key-release-event', @GTKKeyUpDown, GDK_KEY_RELEASE_MASK); end else if (sender is TCustomForm) then Begin ConnectSignal(PgtkObject(TCustomForm(sender).handle), 'key-press-event', @GTKKeyUpDown, GDK_KEY_PRESS_MASK); ConnectSignal(PgtkObject(TCustomForm(sender).handle), 'key-release-event', @GTKKeyUpDown, GDK_KEY_RELEASE_MASK); end else if (sender is TCustomListBox) then Begin //TODO:listbox is STILL not sendig keypress events even wtih these lines. ConnectSignal(PgtkObject(GetCoreChildWidget(PgtkWidget(TCustomListBox(sender).handle))), 'key-press-event', @GTKKeyUpDown, GDK_KEY_PRESS_MASK); ConnectSignal(PgtkObject(GetCoreChildWidget(PgtkWidget(TCustomListBox(sender).handle))), 'key-release-event', @GTKKeyUpDown, GDK_KEY_RELEASE_MASK); end; ConnectSignal(gFixed, 'key-press-event', @GTKKeyUpDown, GDK_KEY_PRESS_MASK); ConnectSignal(gFixed, 'key-release-event', @GTKKeyUpDown, GDK_KEY_RELEASE_MASK); end; LM_MONTHCHANGED : //calendar Begin ConnectSignal(gObject, 'month-changed', @gtkmonthchanged); ConnectSignal(gObject, 'prev-month', @gtkmonthchanged); ConnectSignal(gObject, 'next-month', @gtkmonthchanged); end; LM_MOUSEMOVE: begin if (sender is TComboBox) then Begin ConnectSignal(PgtkObject(PgtkCombo(TComboBox(sender).handle)^.entry), 'motion-notify-event', @GTKMotionNotify, GDK_POINTER_MOTION_MASK); ConnectSignal(PgtkObject(PgtkCombo(TComboBox(sender).handle)^.button), 'motion-notify-event', @GTKMotionNotify, GDK_POINTER_MOTION_MASK); end else 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 if (sender is TCustomComboBox) then Begin ConnectSignal(PgtkObject(PgtkCOmbo(gObject)^.entry), 'button-press-event', @gtkmousebtnpress, GDK_BUTTON_PRESS_MASK); ConnectSignal(PgtkObject(PgtkCOmbo(gObject)^.button) , 'button-press-event', @gtkmousebtnpress, GDK_BUTTON_PRESS_MASK); // Connecting the list seems to cause errors. Maybe we are returning the wrong boolean in the callback func // ConnectSignal(PgtkObject(PgtkCOmbo(gObject)^.list), 'button-press-event', @gtkmousebtnpress, GDK_BUTTON_PRESS_MASK); end else ConnectSignal(gFixed, 'button-press-event', @gtkmousebtnpress, GDK_BUTTON_PRESS_MASK); end; LM_LBUTTONUP, LM_RBUTTONUP, LM_MBUTTONUP: begin if (sender is TCustomComboBox) then Begin ConnectSignal(PgtkObject(PgtkCOmbo(gObject)^.entry), 'button-release-event', @gtkmousebtnrelease, GDK_BUTTON_RELEASE_MASK); ConnectSignal(PgtkObject(PgtkCOmbo(gObject)^.button) , 'button-release-event', @gtkmousebtnrelease, GDK_BUTTON_RELEASE_MASK); // Connecting the list seems to cause errors. Maybe we are returning the wrong boolean in the callback func // ConnectSignal(PgtkObject(PgtkCOmbo(gObject)^.list), 'button-release-event', @gtkmousebtnrelease, GDK_BUTTON_RELEASE_MASK); end else 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_YEARCHANGED : //calendar Begin ConnectSignal(gObject, 'prev-year', @gtkyearchanged); ConnectSignal(gObject, 'next-year', @gtkyearchanged); 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 to remove callbacks Returns: nothing Removes Call Back Signals from the sender ------------------------------------------------------------------------------} procedure TGTKObject.RemoveCallbacks(Sender : TObject); var gObject : gtk_Object; Info: PWinWidgetInfo; Widget: pointer; begin gObject := ObjectToGTKObject(Sender); if gObject = nil then Exit; if (Sender is TWinControl) and (TWinControl(Sender).HandleAllocated) then begin Widget:=Pointer(TWinControl(Sender).Handle); Info := GetWidgetInfo(Widget, False); if Info <> nil then Dispose(Info); gtk_object_set_data(Widget, 'widgetinfo', nil); end; 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); //unused: FormBorderWidth : array[TFormBorderStyle] of gint = (0, 1, 2, 1, 1, 2); //unused:type //unused: Tpixdata = Array[1..20] of String; var caption : ansistring; // the caption of "Sender" StrTemp : PChar; // same as "caption" but as PChar TempWidget : PGTKWidget; // pointer to gtk-widget (local use when neccessary) p : pointer; // ptr to the newly created GtkWidget CompStyle, // componentstyle (type) of GtkWidget which will be created TempInt : Integer; // local use when neccessary Adjustment: PGTKAdjustment; // currently only used for csFixed // - for csBitBtn Box : Pointer; // currently only used for TBitBtn and TForm //pixmap : pGdkPixMap; // TBitBtn - the default pixmap pixmapwid : pGtkWidget; // currently only used for TBitBtn //mask : pGDKBitmap; // currently only used for TBitBtn //style : pgtkStyle; // currently only used for TBitBtn label1 : pgtkwidget; // currently only used for TBitBtn //TempStr : String; // currently only used for TBitBtn to load default pixmap //pStr : PChar; // currently only used for TBitBtn to load default pixmap begin Assert(False, 'Trace:In CreateComponet'); p := nil; CompStyle := csNone; Caption := Sender.ClassName; if (Sender is TControl) then begin caption := TControl(Sender).caption; CompStyle := TControl(Sender).FCompStyle end else if (Sender is TMenuItem) then begin caption := TMenuItem(Sender).caption; CompStyle := TMenuItem(Sender).FCompStyle; end else if (Sender is TMenu) or (Sender is TPopupMenu) then CompStyle := TMenu(Sender).FCompStyle else if (Sender is TCommonDialog) then CompStyle := TCommonDialog(Sender).FCompStyle else ; // ToDo: the following is for debug only if caption = '' then caption := Sender.ClassName; Assert(False, 'Trace:----------------------Creating component in TgtkObject- STR = '+caption+'-'); // ToDo: until here remove when debug not needed if caption = '' then caption := 'Blank'; strTemp := StrAlloc(length(caption) + 1); StrPCopy(strTemp, caption); Assert(False, 'Trace:1'); case CompStyle of csAlignment : begin p := gtk_alignment_new(0.5,0.5,0,0); gtk_widget_show(p); end; csArrow : begin p := gtk_arrow_new(gtk_arrow_left,gtk_shadow_etched_in); end; csBitBtn : begin Assert(False, 'Trace:CSBITBTN CREATE*************************'); p := gtk_button_new; if (TBitBtn(Sender).Layout = blGlyphLeft) or (TBitBtn(Sender).Layout = blGlyphRight) then begin Assert(False, 'Trace:GLYPHLEFT or GLYPHRIGHT'); Box := gtk_hbox_new(False,0); end else Begin Assert(False, 'Trace:GLYPHTOP or GLYPHBOTTOM'); Box := gtk_vbox_new(False,0); end; gtk_container_set_border_width(PgtkContainer(Box),2); //style := gtk_widget_get_style(pGTKWidget(p)); { // is this neccessary? // MWE: nope, if needed, it should be done static 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); PixMapWid := nil; Label1 := gtk_label_new(StrTemp); //gtk_box_pack_start(pGTkBox(Box),pixmapwid,False,False,3); gtk_box_pack_start(pGTkBox(Box), Label1, FALSE, FALSE, 3); //gtk_widget_show(pixmapwid); gtk_widget_show(Label1); gtk_Container_add(PgtkContainer(p),Box); gtk_widget_show(Box); gtk_object_set_data(pgtkObject(p),'HBox',Box); 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; csCalendar : begin p := gtk_calendar_new(); 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); //-------------------------- // MWE: will be obsoleted SetCoreChildWidget(p, TempWidget); //-------------------------- GetWidgetInfo(p, True)^.ImplementationWidget := 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); //-------------------------- // MWE: will be obsoleted SetCoreChildWidget(p, TempWidget); //-------------------------- GetWidgetInfo(p, True)^.ImplementationWidget := TempWidget; SetMainWidget(p, TempWidget); end; csListView : Begin if TCustomListView(sender).Columns.Count > 0 then P := PgtkWidget(gtk_clist_new(TCustomListView(sender).Columns.Count)) else P := PgtkWidget(gtk_clist_new(1)); gtk_widget_show(P); 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); if Sender is TOpenDialog then begin // set extra options if ofAllowMultiSelect in TOpenDialog(Sender).Options then begin LastFileSelectRow := -1; gtk_signal_connect( gtk_object(PGtkCList(PGtkFileSelection(P)^.file_list)), 'select-row', gtk_signal_func(@gtkOpenDialogRowSelectCB), Sender); gtk_clist_set_selection_mode( PGtkCList(PGtkFileSelection(P)^.file_list),GTK_SELECTION_MULTIPLE); end; end; 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 writeln('[TgtkObject.CreateComponent] csFixed A ',Sender.Classname); p := GTKAPIWidget_New; writeln('[TgtkObject.CreateComponent] csFixed B'); 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]); // I comment the next line because this causes that when I align something // it's right and bottom don't visible. //Nagy Zsolt 2001/03/27 // 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_policy (GTK_WINDOW (p), 1, 1, 0); gtk_window_set_title(pGtkWindow(p), strTemp); // the clipboard needs a widget if ClipboardWidget=nil then SetClipboardWidget(p); // Create the VBox, we need that to place controls outside // the client area (like menu) Box := gtk_vbox_new(False, 0); gtk_container_add(p, Box); gtk_widget_show(Box); // Create the form client area TempWidget := gtk_fixed_new(); gtk_box_pack_end(Box, TempWidget, True, True, 0); 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; csHintWindow : Begin p := gtk_window_new(FormStyleMap[bsToolWindow]{gtk_window_Popup}); gtk_window_set_policy (GTK_WINDOW (p), 0, 0, 0); // Box := gtk_vbox_new(False, 0); // gtk_container_add(p, Box); // gtk_widget_show(Box); // Create the form client area TempWidget := gtk_fixed_new(); gtk_container_add(p, TempWidget);// gtk_box_pack_end(Box, TempWidget, True, True, 0); gtk_widget_show(TempWidget); SetFixedWidget(p, TempWidget); SetMainWidget(p, TempWidget); gtk_widget_show(p); end; csImage : Begin p := gtk_image_new(nil,nil); end; csLabel : begin P := gtk_label_new(StrTemp); gtk_misc_set_alignment(PGTKMISC(P), 0.0 , 1.0); end; csMemo : begin P := gtk_scrolled_window_new(nil, nil); 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_widget_show(TempWidget); gtk_container_add(p, TempWidget); case (Sender as TCustomMemo).Scrollbars of ssHorizontal: gtk_scrolled_window_set_policy(p, GTK_POLICY_ALWAYS, GTK_POLICY_NEVER); ssVertical: gtk_scrolled_window_set_policy(p, GTK_POLICY_NEVER, GTK_POLICY_ALWAYS); ssBoth: gtk_scrolled_window_set_policy(p, GTK_POLICY_ALWAYS, GTK_POLICY_ALWAYS); else gtk_scrolled_window_set_policy(p, GTK_POLICY_NEVER, GTK_POLICY_NEVER); end; //-------------------------- // MWE: will be obsoleted SetCoreChildWidget(p, TempWidget); //-------------------------- GetWidgetInfo(p, True)^.ImplementationWidget := TempWidget; (* // 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); //-------------------------- // MWE: will be obsoleted SetCoreChildWidget(p, TempWidget); //-------------------------- GetWidgetInfo(p, True)^.ImplementationWidget := TempWidget; SetMainWidget(p, TempWidget); if (Sender as TCustomMemo).Scrollbars in [ssVertical, ssBoth] then 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; { if (Sender as TCustomMemo).Scrollbars in [ssHorizontal, ssBoth] then begin TempWidget := gtk_hscrollbar_new(PGtkText(TempWidget)^.hadj); gtk_box_pack_start(PGtkBox(P), TempWidget, false, false, 0); gtk_widget_show(TempWidget); SetMainWidget(p, TempWidget); end; } *) gtk_widget_show(P); end; csMainMenu: begin p := gtk_menu_bar_new(); // get the VBox, the form has one child, a VBox Box := PGTKBin(TWinControl(TMenu(Sender).Owner).Handle)^.Child; gtk_box_pack_start(Box, p, False, False, 0); SetAccelGroup(p, gtk_accel_group_get_default); 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_scrollable(P, true); gtk_notebook_popup_enable(P); 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; csScrollBar : begin if (TScrollBar(sender).kind = sbHorizontal) then begin P := gtk_hscrollbar_new(PgtkAdjustment(gtk_adjustment_new(1,TScrollBar(sender).min, TScrollBar(sender).max, TScrollBar(sender).SmallChange, TScrollBar(sender).LargeChange, TScrollBar(sender).Pagesize))); end else Begin P := gtk_vscrollbar_new(PgtkAdjustment(gtk_adjustment_new(1,TScrollBar(sender).min, TScrollBar(sender).max, TScrollBar(sender).SmallChange, TScrollBar(sender).LargeChange, TScrollBar(sender).Pagesize))); 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; 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; csPopupMenu : with (TPopupMenu(Sender)) do Begin P := gtk_menu_new(); 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 TCommonDialog) then TCommonDialog(Sender).Handle:= THandle(p); // MWE: next will be obsoleted by WinWidgetInfo //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); Assert(False, 'Trace:Leaving CreateComponent'); end; {------------------------------------------------------------------------------} { TGtkObject GetLabel } { *Note: Returns a widgets lable value } {------------------------------------------------------------------------------} function TgtkObject.GetLabel(CompStyle: Integer; P : Pointer) : String; var pLabel: Pointer; aPChar: PChar; begin Result := 'Label'; case CompStyle of csLabel: begin gtk_label_get(PGTKLabel(p),@aPChar); Result:=StrPas(aPChar); end; csForm : Result := StrPas(PgtkWindow(p)^.Title); csPage : begin pLabel := gtk_notebook_get_tab_label( PGTKNoteBook(TWinControl(P).Parent.Handle), PGTKWidget(TWinControl(P).Handle)); if pLabel <> nil then begin gtk_label_get(pLabel, @aPChar); Result:=StrPas(aPChar); end; 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); var FormIconGdiObject: PGDIObject; FormWidget: PGTKWidget; begin FormWidget:=PgtkWidget(TWinControl(Sender).Handle); //if Sender is TForm then //writeln('[TgtkObject.ShowHide] START ',Sender.ClassName,' Visible=',TControl(Sender).Visible,' Window=',FormWidget^.Window<>nil); if TControl(Sender).Visible then begin gtk_widget_show(FormWidget); if (Sender is TCustomForm) and (FormWidget^.Window<>nil) then begin FormIconGdiObject:=PGDIObject(TCustomForm(Sender).GetIconHandle); if (FormIconGdiObject<>nil) then begin gdk_window_set_icon(FormWidget^.Window, nil, FormIconGdiObject^.GDIBitmapObject, FormIconGdiObject^.GDIBitmapMaskObject); end; end; end else Begin gtk_widget_hide(FormWidget); end; //if Sender is TForm then //writeln('[TgtkObject.ShowHide] END ',Sender.ClassName,' Window=',FormWidget^.Window<>nil); end; {------------------------------------------------------------------------------} { TGtkObject AddNBPage } { *Note: Add Notebook Page } {------------------------------------------------------------------------------} procedure TgtkObject.AddNBPage(Parent, Child: TObject; Index: Integer); var 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), '1', 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; {------------------------------------------------------------------------------ Method: TGtkObject.SetPixel Params: Sender : the lcl object which called this func via SendMessage 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 PDC : PDeviceContext; Image : pGDKImage; Widget : PgtkWidget; GDKColor: TGDKColor; pFixed : PGTKFixed; fWindow : pGdkWindow; begin PDC := PDeviceContext(TCanvas(Sender).Handle); if PDC = nil then exit; Widget := PgtkWidget(PDC^.HWnd); Image := gtk_Object_get_data(pgtkobject(widget),'Image'); if Image = nil then begin Image := gdk_image_get(pgtkWidget(widget)^.window,0,0, widget^.allocation.width,widget^.allocation.height); if Image = nil then exit; gtk_Object_set_data(pgtkobject(Widget),'Image',Image); end; GDKColor:=AllocGDKColor(TLMSetGetPixel(data^).PixColor); //writeln('SetPixel: Color=',HexStr(TLMSetGetPixel(data^).PixColor,8),' GDKColor=',HexStr(GDKColor.Pixel,8)); gdk_image_put_pixel(Image,TLMSetGetPixel(data^).X,TLMSetGetPixel(data^).Y, GDKColor.Pixel); pFixed := GetFixedWidget(Widget); if pFixed <> nil then Widget:=PgtkWidget(pFixed); fWindow := pGtkWidget(Widget)^.window; 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 PDC : PDeviceContext; Image : pGDKImage; Widget : PgtkWidget; GDKColor: TGDKColor; GdkColorContext: PGdkColorContext; begin PDC := PDeviceContext(TCanvas(Sender).Handle); if PDC = nil then exit; Widget := PgtkWidget(PDC^.HWnd); Image := gtk_Object_get_data(pgtkobject(Widget),'Image'); if Image = nil then begin Image := gdk_image_get(pgtkWidget(widget)^.window,0,0, widget^.allocation.width,widget^.allocation.height); if Image = nil then exit; gtk_Object_set_data(pgtkobject(Widget),'Image',Image); end; GDKColor.Pixel := gdk_image_get_pixel(Image, TLMSetGetPixel(data^).X,TLMSetGetPixel(data^).Y); GdkColorContext:= gdk_color_context_new(gdk_visual_get_system,gdk_colormap_get_system); gdk_color_context_query_color(GdkColorContext,@GDKColor); gdk_color_context_free(GdkColorContext); TLMSetGetPixel(data^).PixColor := TGDKColorToTColor(GDKColor); end; {------------------------------------------------------------------------------ Method: TGtkObject.SetColorDialogColor Params: ColorSelection : a gtk color selection dialog; Color : the color to select Returns: nothing Set the color of the coor selection dialog ------------------------------------------------------------------------------} procedure TgtkObject.SetColorDialogColor(ColorSelection: PGtkColorSelection; Color: TColor); var SelectionColor: PGDouble; // currently only used by TColorDialog colorSel : GTK_COLOR_SELECTION; begin GetMem(SelectionColor,4*SizeOf(GDouble)); try Color:=ColorToRGB(Color); SelectionColor[0]:=(Color and $ff)/255; SelectionColor[1]:=((Color shr 8) and $ff)/255; SelectionColor[2]:=((Color shr 16) and $ff)/255; SelectionColor[3]:=0.0; colorSel := GTK_COLOR_SELECTION( (GTK_COLOR_SELECTION_DIALOG(ColorSelection))^.colorsel); gtk_color_selection_set_color(colorSel,SelectionColor); finally FreeMem(SelectionColor); end; 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; Year,Month,Day : Integer; //used for csCalendar 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 : if (handle <> nil) then begin integer(data^) := round(gtk_range_get_adjustment( GTK_RANGE (handle))^.value); end else integer(data^) := 0; csRadiobutton, csCheckbox : if gtk_toggle_button_get_active (PGtkToggleButton (handle)) then TCheckBoxState (data^) := cbChecked else TCheckBoxState (data^) := cbUnChecked; csCalendar :Begin gtk_calendar_get_date(PgtkCalendar(handle),@Year, @Month, @Day); //TODO: account for local settings like date format //Form some reason, the month is zero based. TLMCalendar(data^).Date := StrtoDate(Inttostr(Day)+'-'+Inttostr(Month+1)+'-'+Inttostr(Year)); end; 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; //used for csCalendar Date : TDateTime; Year,Month,Day : String; gtkcalendardisplayoptions : TGtkCalendarDisplayOptions; NUm : Integer; ArrowType : TGTKArrowType; ShadowType : TGTKShadowType; 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 if Handle = nil then Exit; 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); csCalendar : Begin Date := TLMCalendar(data^).Date; Year := FormatDateTime('yyyy',Date); Month := FormatDateTime('mm',Date); Day := FormatDateTime('dd',Date); gtk_calendar_select_month(PgtkCalendar(handle),StrtoInt(Month)-1,StrToInt(Year)); gtk_calendar_select_day(PgtkCalendar(handle),StrToInt(Day)); //set display options Num := 0; if (dsShowHeadings in TLMCalendar(data^).DisplaySettings) then num := Num + (1 shl 0); if (dsShowDayNames in TLMCalendar(data^).DisplaySettings) then num := Num + (1 shl 1); if (dsNoMonthChange in TLMCalendar(data^).DisplaySettings) then num := Num + (1 shl 2); if (dsShowWeekNumbers in TLMCalendar(data^).DisplaySettings) then num := Num + (1 shl 3); if (dsStartMonday in TLMCalendar(data^).DisplaySettings) then num := Num + (1 shl 4); gtkCalendarDisplayOptions := TgtkCalendarDisplayOPtions(num); gtk_Calendar_Display_options(PgtkCalendar(handle),gtkCalendarDisplayOptions); //readonly if TLMCalendar(data^).ReadOnly then gtk_calendar_freeze(PgtkCalendar(handle)) else gtk_calendar_thaw(PgtkCalendar(handle)); end; csArrow : Begin if TLmArrow(data^).ArrowType = atUp then ArrowType := GTK_ARROW_UP else if TLMArrow(data^).ArrowType = atLeft then ArrowType := GTK_ARROW_LEFT else if TLMArrow(data^).ArrowType = atRight then ArrowType := GTK_ARROW_RIGHT else ArrowType := GTK_ARROW_DOWN; case TLMArrow(data^).ShadowType of stNONE : ShadowType := GTK_SHADOW_NONE; stIN : ShadowType := GTK_SHADOW_IN; stOut : ShadowType := GTK_SHADOW_OUT; stEtchedIn : ShadowType := GTK_SHADOW_ETCHED_IN; stEtchedOut : ShadowType := GTK_SHADOW_ETCHED_OUT; else ShadowType := GTK_SHADOW_NONE; end; gtk_arrow_set(PgtkArrow(handle),ArrowType,ShadowType); end 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; const aGTKJustification: array[TColumnAlignment] of TGTKJustification = (GTK_JUSTIFY_LEFT,GTK_JUSTIFY_RIGHT,GTK_JUSTIFY_CENTER); aGTkSelectionMode: Array[Boolean] of TGtkSelectionMode = (GTK_SELECTION_SINGLE,GTk_SELECTION_EXTENDED); var Handle : Pointer; Widget : PGtkWidget; xAlign : gfloat; yAlign : gfloat; I,X : Integer; ColName : String; pColName : PChar; pRowText : PChar; Image : PgdkImage; 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 csEdit : with (TCustomEdit(Sender)) do Begin gtk_entry_set_editable(PgtkEntry(handle),not(TCustomEdit(sender).ReadOnly)); gtk_entry_set_max_length(PgtkEntry(handle),TCustomEdit(sender).MaxLength); end; 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; csScrollBar: with (TScrollBar (Sender)) do begin //set properties for the range 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 := SmallChange; PGtkAdjustment(Widget)^.page_increment := LargeChange; 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; csListView : With TCustomListView(sender) do Begin //set up columns.. // gtk_clist_freeze(PgtkCList(Handle)); for I := 0 to Columns.Count-1 do Begin ColName := Columns.Item[i].Caption; GetMem(pColName,Length(colname)+1); pColName := StrPcopy(pColName,ColName); gtk_clist_set_column_title(Pgtkclist(Handle),I,pColName); Dispose(pColName); //set column alignment gtk_clist_set_column_justification(PgtkCList(Handle),I,aGTKJUSTIFICATION[Columns.Item[i].Alignment]); end; //sorting if (TCustomListView(sender).ViewStyle = vsReport) then gtk_clist_column_titles_show(PgtkCList(Handle)) else gtk_clist_column_titles_Hide(PgtkCList(Handle)); gtk_clist_set_sort_column(PgtkCList(Handle),TCustomListView(sender).SortColumn); //multiselect gtk_clist_set_selection_mode(PgtkCList(Handle),aGTkSelectionMode[TCustomListView(sender).MultiSelect]); //TODO:This doesn't work right now // gtk_clist_set_auto_sort(PgtkCList(handle),TCustomListView(sender).Sorted); // //do items... // for I := 0 to TCustomListView(sender).Items.Count-1 do Begin GetMem(pRowText,Length(TListItem(TCustomListView(sender).Items[i]).Caption)+1); pRowText := StrPcopy(pRowText,TListItem(TCustomListView(sender).Items[i]).Caption); gtk_clist_set_text(Pgtkclist(Handle),0,I+1,pRowText); freemem(pRowText); if (TCustomListView(sender).ViewStyle = vsReport) then //columns showing For X := 1 to Columns.Count-1 do begin if ( X <= TListItem(TCustomListView(sender).Items[i]).SubItems.Count) then Begin GetMem(pRowText,Length(TListItem(TCustomListView(sender).Items[i]).SubItems.Strings[X-1])+1); pRowText := StrPcopy(pRowText,TListItem(TCustomListView(sender).Items[i]).SubItems.Strings[X-1]); gtk_clist_set_text(Pgtkclist(Handle),X,I+1,pRowText); freemem(pRowText); end; end; //for loop end; gtk_clist_thaw(PgtkCList(Handle)); end; csImage: Begin //Image changed. Widget := PgtkWidget(PdeviceContext(TBitmap(sender).handle)); Image := gdk_image_get(pgtkWidget(widget)^.window,0,0,widget^.allocation.width,widget^.allocation.height); if Handle = nil then TWinControl(sender).Handle := THandle(gtk_image_new(Image,nil)) else gtk_image_set(PgtkImage(handle),Image,nil); 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 or (csDesigning in ComponentState)) 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.Contains(Pointer(DC)); 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 := (GDIObject<>0) and (FGDIObjects.Contains(Pointer(GDIObject))); // 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; 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; FDeviceContexts.Add(Result); //writeln('[TgtkObject.NewDC] ',HexStr(Cardinal(Result),8),' ',FDeviceContexts.Count); // Assert(False, Format('Trace:< [TgtkObject.NewDC] FDeviceContexts[%d] --> 0x%p', [n, Result])); end; (* {------------------------------------------------------------------------------ Function: FreeDC Params: ADC: A DC to Free Returns: nothing Frees an initial DC It does not free the GDI objects. See ReleaseDC for a smarter function. ------------------------------------------------------------------------------} function TgtkObject.FreeDC(ADC: PDeviceContext); var n: Integer; begin //writeln('[TgtkObject.FreeDC] ',HexStr(Cardinal(ADC),8)); Assert(False, Format('Trace:> [TgtkObject.FreeDC] DC:0x%p', [ADC])); if ADC <> nil then begin if ADC^.SavedContext <> nil then begin writeln('[TgtkObject.FreeDC] WARNING: there is an unused saved context left!'); FreeDC(ADC^.SavedContext); end; Assert(ADC^.CurrentBitmap = nil, 'trace: [TgtkObject.FreeDC] CurrentBitmap <> nil'); Assert(ADC^.CurrentFont = nil, 'trace: [TgtkObject.FreeDC] CurrentFont <> nil'); Assert(ADC^.CurrentPen = nil, 'trace: [TgtkObject.FreeDC] CurrentPen <> nil'); Assert(ADC^.CurrentBrush = nil, 'trace: [TgtkObject.FreeDC] CurrentBrush <> nil'); if ADC^.GC <> nil then gdk_gc_unref(ADC^.GC); n := FDeviceContexts.Remove(ADC); Dispose(ADC); end; Assert(False, Format('Trace:< [TgtkObject.FreeDC] FDeviceContexts[%d]', [n])); end; *) {------------------------------------------------------------------------------ Function: NewGDIObject Params: none Returns: a gtkwinapi DeviceContext Creates an initial DC ------------------------------------------------------------------------------} function TgtkObject.NewGDIObject(const GDIType: TGDIType): PGdiObject; begin Assert(False, Format('Trace:> [TgtkObject.NewGDIObject]', [])); New(Result); FillChar(Result^, SizeOf(TGDIObject), 0); Result^.GDIType := GDIType; FGDIObjects.Add(Result); //writeln('[TgtkObject.NewGDIObject] ',HexStr(Cardinal(Result),8),' ',FGDIObjects.Count); Assert(False, Format('Trace:< [TgtkObject.NewGDIObject] FGDIObjects --> 0x%p', [Result])); end; {------------------------------------------------------------------------------ Function: CreateDefaultBrush Params: none Returns: a Brush GDIObject Creates an default brush, used for initial values ------------------------------------------------------------------------------} function TgtkObject.CreateDefaultBrush: PGdiObject; begin //write(' TgtkObject.CreateDefaultBrush ->'); 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 //write(' TgtkObject.CreateDefaultFont ->'); 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 //write(' TgtkObject.CreateDefaultPen ->'); Result := NewGDIObject(gdiPen); Result^.GDIPenStyle := PS_SOLID; gdk_color_black(gdk_colormap_get_system, @Result^.GDIPenColor); end; {------------------------------------------------------------------------------ Function: HashPaintMessage Params: a PaintMessage in the Message queue (= PLazQueueItem) Returns: a hash index Calculates a hash of the handle in the PaintMessage which is used by the FPaintMessages (which is a TDynHashArray). ------------------------------------------------------------------------------} function TgtkObject.HashPaintMessage(p: pointer): integer; var h: integer; begin h:=PMsg(PLazQueueItem(p)^.Data)^.HWnd; if h<0 then h:=-h; Result:=((h mod 5364329)+(h mod 17)) mod FPaintMessages.Capacity; end; {------------------------------------------------------------------------------ Function: FindPaintMessage Params: a window handle Returns: nil or a Paint Message to the widget Searches in FPaintMessages for a LM_PAINT message with HandleWnd. ------------------------------------------------------------------------------} function TgtkObject.FindPaintMessage(HandleWnd: HWnd): PLazQueueItem; var h: integer; HashItem: PDynHashArrayItem; begin h:=HandleWnd; if h<0 then h:=-h; h:=((h mod 5364329)+(h mod 17)) mod FPaintMessages.Capacity; HashItem:=FPaintMessages.GetHashItem(h); if HashItem<>nil then begin Result:=PLazQueueItem(HashItem^.Item); if PMsg(Result^.Data)^.HWnd=HandleWnd then exit; HashItem:=HashItem^.Next; while (HashItem<>nil) and (HashItem^.IsOverflow) do begin Result:=PLazQueueItem(HashItem^.Item); if PMsg(Result^.Data)^.HWnd=HandleWnd then exit; HashItem:=HashItem^.Next; end; end; Result:=nil; end; {------------------------------------------------------------------------------ Function: SetClipboardWidget Params: TargetWidget: PGtkWidget - This widget will be connected to all clipboard signals which are all handled by the TGtkObject itself. Returns: none All supported targets are added to the new widget. This way, no one, especially not the lcl, will notice the change. ;) ------------------------------------------------------------------------------} procedure TgtkObject.SetClipboardWidget(TargetWidget: PGtkWidget); type TGtkTargetSelectionList = record Selection: Cardinal; List: PGtkTargetList; end; PGtkTargetSelectionList = ^TGtkTargetSelectionList; const gtk_selection_handler_key: PChar = 'gtk-selection-handlers'; {$IFDEF DEBUG_CLIPBOARD} function gtk_selection_target_list_get(Widget: PGtkWidget; ClipboardType: TClipboardType): PGtkTargetList; var SelectionLists, CurSelList: PGList; TargetSelList: PGtkTargetSelectionList; begin SelectionLists := gtk_object_get_data (PGtkObject(Widget), gtk_selection_handler_key); CurSelList := SelectionLists; while (CurSelList<>nil) do begin TargetSelList := CurSelList^.Data; if (TargetSelList^.Selection = ClipboardTypeAtoms[ClipboardType]) then begin Result:=TargetSelList^.List; exit; end; CurSelList := CurSelList^.Next; end; Result:=nil; end; procedure WriteTargetLists(Widget: PGtkWidget); var c: TClipboardType; TargetList: PGtkTargetList; TmpList: PGList; Pair: PGtkTargetPair; begin writeln(' WriteTargetLists WWW START'); for c:=Low(TClipboardType) to High(TClipboardType) do begin TargetList:=gtk_selection_target_list_get(Widget,c); writeln(' WriteTargetLists WWW ',ClipboardTypeName[c],' ',TargetList<>nil); if TargetList<>nil then begin TmpList:=TargetList^.List; while TmpList<>nil do begin Pair:=PGtkTargetPair(TmpList^.Data); writeln(' WriteTargetLists BBB ',Pair^.Target); TmpList:=TmpList^.Next; end; end; end; writeln(' WriteTargetLists WWW END'); end; {$ENDIF} procedure ClearTargetLists(Widget: PGtkWidget); // MG: Reading in gtk internas is dirty, but there seems to be no other way // to clear the old target lists var SelectionLists, CurSelList: PGList; TargetSelList: PGtkTargetSelectionList; begin {$IFDEF DEBUG_CLIPBOARD} writeln(' ClearTargetLists WWW START'); {$ENDIF} SelectionLists := gtk_object_get_data (PGtkObject(Widget), gtk_selection_handler_key); CurSelList := SelectionLists; while (CurSelList<>nil) do begin TargetSelList := CurSelList^.Data; gtk_target_list_unref(TargetSelList^.List); g_free(TargetSelList); CurSelList := CurSelList^.Next; end; g_list_free(SelectionLists); gtk_object_set_data (PGtkObject(Widget),gtk_selection_handler_key,0); {$IFDEF DEBUG_CLIPBOARD} writeln(' ClearTargetLists WWW END'); {$ENDIF} end; var c: TClipboardType; begin if ClipboardWidget=TargetWidget then exit; {$IFDEF DEBUG_CLIPBOARD} writeln('[TgtkObject.SetClipboardWidget] ',ClipboardWidget<>nil,' -> ',TargetWidget<>nil); {$ENDIF} if ClipboardWidget<>nil then begin {$IFDEF DEBUG_CLIPBOARD} WriteTargetLists(ClipboardWidget); {$ENDIF} ClearTargetLists(ClipboardWidget); {$IFDEF DEBUG_CLIPBOARD} WriteTargetLists(ClipboardWidget); {$ENDIF} end; ClipboardWidget:=TargetWidget; if ClipboardWidget<>nil then begin // connect widget to all clipboard signals gtk_signal_connect(PGtkObject(ClipboardWidget),'selection_received', TGTKSignalFunc(@ClipboardSelectionReceivedHandler),0); gtk_signal_connect(PGtkObject(ClipboardWidget),'selection_get', TGTKSignalFunc(@ClipboardSelectionRequestHandler),0); gtk_signal_connect(PGtkObject(ClipboardWidget),'selection_clear_event', TGTKSignalFunc(@ClipboardSelectionLostOwnershipHandler),0); // add all supported targets for all clipboard types for c:=Low(TClipboardType) to High(TClipboardType) do begin if (ClipboardTargetEntries[c]<>nil) then begin gtk_selection_add_targets(ClipboardWidget,ClipboardTypeAtoms[c], ClipboardTargetEntries[c],ClipboardTargetEntryCnt[c]); end; end; end; end; {$IFDEF ASSERT_IS_ON} {$UNDEF ASSERT_IS_ON} {$C-} {$ENDIF} { ============================================================================= $Log$ Revision 1.96 2001/12/28 15:12:02 lazarus MG: LM_SIZE and LM_MOVE messages are now send directly, not queued Revision 1.95 2001/12/21 18:17:00 lazarus Added TImage class Shane Revision 1.94 2001/12/20 19:11:23 lazarus Changed the delay for the hints from 100 miliseconds to 500. I'm hoping this reduces the crashing for some people until I determine the problem. Shane Revision 1.93 2001/12/19 21:36:05 lazarus Added MultiSelect to TListView Shane Revision 1.92 2001/12/19 20:28:51 lazarus Enabled Alignment of columns in a TListView. Shane Revision 1.91 2001/12/18 21:10:01 lazarus MOre additions for breakpoints dialog Added a TSynEditPlugin in SourceEditor to get notified of lines inserted and deleted from the source. Shane Revision 1.90 2001/12/16 22:24:55 lazarus MG: changes for new compiler 20011216 Revision 1.89 2001/12/14 19:51:48 lazarus More changes to TListView Shane Revision 1.88 2001/12/14 18:38:56 lazarus Changed code for TListView Added a generic Breakpoints dialog Shane Revision 1.87 2001/12/12 20:19:19 lazarus Modified the the GTKFileSelection so that it will handle and use CTRL and SHIFT keys in a fashion similar to Windows. Revision 1.86 2001/12/12 14:39:25 lazarus MG: carets will now be auto destroyed on widget destroy Revision 1.85 2001/12/12 08:29:21 lazarus Add code to allow TOpenDialog to do multiple line selects. MAH Revision 1.84 2001/12/11 16:51:37 lazarus Modified the Watches dialog Shane Revision 1.83 2001/12/11 14:36:41 lazarus MG: started multiselection for TOpenDialog Revision 1.82 2001/12/07 20:12:15 lazarus Added a watch dialog. Shane Revision 1.81 2001/12/06 13:39:36 lazarus Added TArrow component Shane Revision 1.80 2001/12/05 18:23:48 lazarus Added events to Calendar Shane Revision 1.79 2001/12/05 17:40:00 lazarus Added READONLY to Calendar. Shane Revision 1.77 2001/11/26 14:19:34 lazarus Added some code to make the interbae components work better. Shane Revision 1.75 2001/11/21 14:55:33 lazarus Changes for combobox to receive butondown and up events DblClick events now working. Shane Revision 1.74 2001/11/20 18:30:32 lazarus Pressing DEL when form is the only thing selected in designer no longer crashes Lazarus. Shane Revision 1.73 2001/11/17 09:42:26 lazarus MG: fixed range check errors for FG,BG in Init Revision 1.72 2001/11/16 20:08:39 lazarus Object inspector has hints now. Shane Revision 1.71 2001/11/14 17:46:58 lazarus Changes to make toggling between form and unit work. Added BringWindowToTop Shane Revision 1.70 2001/11/12 16:56:08 lazarus MG: CLIPBOARD Revision 1.69 2001/11/10 10:48:02 lazarus MG: fixed set formicon on invisible forms Revision 1.68 2001/11/09 19:14:24 lazarus HintWindow changes Shane Revision 1.67 2001/11/09 14:33:41 lazarus MG: fixed GetItemIndex-Handle-NotAllocated-Crash bug Revision 1.66 2001/11/05 18:18:19 lazarus added popupmenu+arrows to notebooks, added target filename Revision 1.65 2001/11/01 21:30:35 lazarus Changes to Messagebox. Added line to CodeTools to prevent duplicate USES entries. Revision 1.64 2001/10/31 16:29:22 lazarus Fixed the gtk mousemove bug where the control gets the coord's based on it's parent instead of itself. Shane Revision 1.63 2001/10/16 20:01:28 lazarus MG: removed splashform fix, because of the unpredictable side effects Revision 1.62 2001/10/16 10:51:10 lazarus MG: added clicked event to TButton, MessageDialog reacts to return key Revision 1.60 2001/10/09 09:46:59 lazarus MG: added codetools, fixed synedit unindent, fixed MCatureHandle Revision 1.59 2001/10/08 12:57:07 lazarus MG: fixed GetPixel Revision 1.58 2001/10/08 08:05:08 lazarus MG: fixed TColorDialog set color Revision 1.57 2001/10/07 07:28:34 lazarus MG: fixed setpixel and TCustomForm.OnResize event Revision 1.56 2001/09/30 08:34:52 lazarus MG: fixed mem leaks and fixed range check errors Revision 1.55 2001/08/07 11:05:51 lazarus MG: small bugfixes Revision 1.54 2001/07/01 23:33:13 lazarus MG: added WaitMessage and HandleEvents is now non blocking Revision 1.53 2001/06/28 18:15:04 lazarus MG: bugfixes for destroying controls Revision 1.52 2001/06/26 21:44:32 lazarus MG: reduced paint messages Revision 1.51 2001/06/26 00:08:36 lazarus MG: added code for form icons from Rene E. Beszon Revision 1.49 2001/06/14 14:57:59 lazarus MG: small bugfixes and less notes Revision 1.47 2001/06/05 10:32:05 lazarus MG: small bugfixes for bitbtn, handles Revision 1.45 2001/05/13 22:07:09 lazarus Implemented BringToFront / SendToBack. Revision 1.44 2001/04/13 17:56:17 lazarus MWE: * Moved menubar outside clientarea * Played a bit with the IDE layout * Moved the creation of the toolbarspeedbuttons to a separate function Revision 1.43 2001/04/06 22:25:14 lazarus * TTimer uses winapi-interface now instead of sendmessage-interface, stoppok Revision 1.42 2001/03/27 21:12:54 lazarus MWE: + Turned on longstrings + modified memotest to add lines Revision 1.41 2001/03/27 14:27:43 lazarus Changes from Nagy Zsolt Shane Revision 1.40 2001/03/26 14:58:31 lazarus MG: setwindowpos + bugfixes Revision 1.36 2001/03/19 18:51:57 lazarus MG: added dynhasharray and renamed tsynautocompletion Revision 1.35 2001/03/19 14:44:22 lazarus MG: fixed many unreleased DC and GDIObj bugs Revision 1.31 2001/03/12 12:17:02 lazarus MG: fixed random function results Revision 1.30 2001/02/20 16:53:27 lazarus Changes for wordcompletion and many other things from Mattias. Shane Revision 1.29 2001/02/06 18:19:38 lazarus Shane Revision 1.28 2001/02/06 14:52:47 lazarus Changed TSpeedbutton in gtkobject so it erases itself when it's set to visible=false; Shane Revision 1.27 2001/02/04 04:18:12 lazarus Code cleanup and JITFOrms bug fix. Shane Revision 1.26 2001/02/02 20:13:39 lazarus Codecompletion changes. Added code to Uniteditor for code completion. Also, added code to gtkobject.inc so forms now get keypress events. Shane Revision 1.25 2001/02/01 19:34:50 lazarus TScrollbar created and a lot of code added. It's cose to working. Shane Revision 1.24 2001/01/31 21:16:45 lazarus Changed to TCOmboBox focusing. Shane Revision 1.23 2001/01/28 21:06:07 lazarus Changes for TComboBox events KeyPress Focus. Shane Revision 1.22 2001/01/28 03:51:42 lazarus Fixed the problem with Changed for ComboBoxs Shane Revision 1.21 2001/01/24 23:26:40 lazarus MWE: = moved some types to gtkdef + added WinWidgetInfo + added some initialization to Application.Create Revision 1.20 2001/01/24 03:21:03 lazarus Removed gtkDrawDefualt signal function from gtkcallback.inc It was no longer used. Shane Revision 1.19 2001/01/23 23:33:55 lazarus MWE: - Removed old LM_InvalidateRect - did some cleanup in old code + added some comments on gtkobject data (gtkproc) Revision 1.18 2001/01/13 03:09:37 lazarus Minor changes Shane Revision 1.17 2001/01/10 20:12:29 lazarus Added the Nudge feature to the IDE. Shane Revision 1.16 2001/01/09 18:23:21 lazarus Worked on moving controls. It's just not working with the X and Y coord's I'm getting. Shane Revision 1.15 2001/01/04 15:09:05 lazarus Tested TCustomEdit.Readonly, MaxLength and CharCase. Shane Revision 1.14 2001/01/04 13:52:00 lazarus Minor changes to TEdit. Not tested. Shane Revision 1.13 2000/12/29 19:20:27 lazarus Shane Revision 1.11 2000/12/22 19:55:38 lazarus Added the Popupmenu code to the LCL. Now you can right click on the editor and a PopupMenu appears. Shane Revision 1.10 2000/12/19 18:43:13 lazarus Removed IDEEDITOR. This causes the PROJECT class to not function. Saving projects no longer works. I added TSourceNotebook and TSourceEditor. They do all the work for saving/closing/opening units. Somethings work but they are in early development. Shane Revision 1.9 2000/10/09 22:50:32 lazarus MWE: * fixed some selection code + Added selection sample Revision 1.8 2000/09/10 23:08:31 lazarus MWE: + Added CreateCompatibeleBitamp function + Updated TWinControl.WMPaint + Added some checks to avoid gtk/gdk errors - Removed no fixed warning from GetDC - Removed some output Revision 1.7 2000/08/10 10:55:45 lazarus Changed TCustomDialog to TCommonDialog Shane Revision 1.6 2000/08/09 18:32:10 lazarus Added more code for the find function. Shane Revision 1.5 2000/07/30 21:48:33 lazarus MWE: = Moved ObjectToGTKObject to GTKProc unit * Fixed array checking in LoadPixmap = Moved LM_SETENABLED to API func EnableWindow and EnableMenuItem ~ Some cleanup Revision 1.4 2000/07/23 18:59:35 lazarus more cleanups, stoppok Revision 1.3 2000/07/23 10:51:53 lazarus - cleanups in IntSendMessage3 - minor cleanups in other functions stoppok Revision 1.2 2000/07/16 20:59:03 lazarus - some more cleanups (removal of unused variables), stoppok Revision 1.1 2000/07/13 10:28:29 michael + Initial import }