{****************************************************************************** Misc Support Functs ****************************************************************************** used by: GTKObject GTKWinAPI GTKCallback ****************************************************************************** ***************************************************************************** * * * This file is part of the Lazarus Component Library (LCL) * * * * See the file COPYING.LCL, included in this distribution, * * for details about the copyright. * * * * This program is distributed in the hope that it will be useful, * * but WITHOUT ANY WARRANTY; without even the implied warranty of * * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * * * ***************************************************************************** } {$IFOPT C-} // Uncomment for local trace // {$C+} // {$DEFINE ASSERT_IS_ON} {$ENDIF} {------------------------------------------------------------------------------ procedure RaiseException(const Msg: string); Raises an exception. gdb does not catch fpc Exception objects, therefore this procedure raises a standard AV which is catched by gdb. ------------------------------------------------------------------------------} procedure RaiseException(const Msg: string); begin writeln('ERROR in gtk-interface: ',Msg); // creates an exception, that gdb catches: writeln('Creating gdb catchable error:'); if (length(Msg) div (length(Msg) div 10000))=0 then ; end; {------------------------------------------------------------------------------ function CreatePChar(const s: string): PChar; Allocates a new PChar ------------------------------------------------------------------------------} function CreatePChar(const s: string): PChar; begin Result:=StrAlloc(length(s) + 1); StrPCopy(Result, s); end; {------------------------------------------------------------------------------ function ComparePChar(P1, P2: PChar): boolean; Checks if P1 and P2 have the same content. ------------------------------------------------------------------------------} function ComparePChar(P1, P2: PChar): boolean; begin if (P1<>P2) then begin if (P1<>nil) and (P2<>nil) then begin while (P1^=P2^) do begin if P1^<>#0 then begin inc(P1); inc(P2); end else begin Result:=true; exit; end; end; end; Result:=false; end else begin Result:=true; end; end; {------------------------------------------------------------------------------ Function: FindChar Params: Width, Height: Size of the image Depth: Depth of the image Returns: a GDIRawImage Creates a RawImage ------------------------------------------------------------------------------} function FindChar(c: char; p:PChar; Max: integer): integer; begin Result:=0; while (Resultc then inc(Result) else exit; end; Result:=-1; end; {------------------------------------------------------------------------------ function GtkWidgetIsA(Widget: PGtkWidget; AType: TGtkType): boolean; The GTK_IS_XXX macro functions in the fpc gtk1.x bindings are not correct. They just test the highest level. This function checks just like the real C macros. ------------------------------------------------------------------------------} function GtkWidgetIsA(Widget: PGtkWidget; AType: TGtkType): boolean; begin Result:=(Widget<>nil) and (PGtkTypeObject(Widget)^.klass<>nil) and gtk_type_is_a(PGtkTypeClass(PGtkTypeObject(Widget)^.klass)^.thetype, AType); end; {------------------------------------------------------------------------------ function WidgetIsDestroyingHandle(Widget: PGtkWidget): boolean; Tests if Destruction Mark is set. ------------------------------------------------------------------------------} function WidgetIsDestroyingHandle(Widget: PGtkWidget): boolean; begin Result:=gtk_object_get_data(PGtkObject(Widget),'LCLDestroyingHandle')<>nil; end; {------------------------------------------------------------------------------ procedure SetWidgetIsDestroyingHandle(Widget: PGtkWidget); Marks widget for destruction. ------------------------------------------------------------------------------} procedure SetWidgetIsDestroyingHandle(Widget: PGtkWidget); begin gtk_object_set_data(PGtkObject(Widget),'LCLDestroyingHandle',Widget); end; {------------------------------------------------------------------------------ function ComponentIsDestroyingHandle(AWinControl: TWinControl): boolean; Tests if Destruction Mark is set. ------------------------------------------------------------------------------} function ComponentIsDestroyingHandle(AWinControl: TWinControl): boolean; begin Result:= (AWinControl<>nil) and (AWinControl is TWinControl) and (AWinControl.HandleAllocated) and WidgetIsDestroyingHandle(PGtkWidget(AWinControl.Handle)); end; {------------------------------------------------------------------------------ function LockOnChange(GtkObject: PGtkObject; LockOffset: integer): integer; Adds LockOffset to the OnChangeLock and returns the result. ------------------------------------------------------------------------------} function LockOnChange(GtkObject: PGtkObject; LockOffset: integer): integer; begin Result:=Integer(gtk_object_get_data(GtkObject,'OnChangeLock')); if LockOffset<>0 then begin inc(Result); gtk_object_set_data(GtkObject,'OnChangeLock',Pointer(Result)); end; end; {------------------------------------------------------------------------------ procedure SetComboBoxText(ComboWidget: PGtkCombo; const NewText: string); Sets the text of the combobox entry. ------------------------------------------------------------------------------} procedure SetComboBoxText(ComboWidget: PGtkCombo; NewText: PChar); begin //writeln('SetComboBoxText ',HexStr(Cardinal(ComboWidget),8),' "',NewText,'"'); // lock combobox, so that no OnChange event is fired LockOnChange(PGtkObject(ComboWidget^.entry),+1); // set text if NewText <> nil then gtk_entry_set_text(PGtkEntry(ComboWidget^.entry), NewText) else gtk_entry_set_text(PGtkEntry(ComboWidget^.entry), #0); // unlock combobox LockOnChange(PGtkObject(ComboWidget^.entry),-1); end; {------------------------------------------------------------------------------ function GetComboBoxItemIndex(ComboBox: TComboBox): integer; Returns the current ItemIndex of a TComboBox ------------------------------------------------------------------------------} function GetComboBoxItemIndex(ComboBox: TComboBox): integer; begin Result:=ComboBox.Items.IndexOf(ComboBox.Text); end; {------------------------------------------------------------------------------ procedure SetComboBoxItemIndex(ComboBox: TComboBox; Index: integer); Returns the current ItemIndex of a TComboBox ------------------------------------------------------------------------------} procedure SetComboBoxItemIndex(ComboBox: TComboBox; Index: integer); var ComboWidget: PGtkCombo; begin ComboWidget:=PGtkCombo(ComboBox.Handle); gtk_list_select_item(PGtkList(ComboWidget^.list),Index); if Index>=0 then SetComboBoxText(ComboWidget,PChar(ComboBox.Items[Index])); end; {------------------------------------------------------------------------------ function GtkPaintMessageToPaintMessage(GtkPaintMsg: TLMGtkPaint): TLMPaint; Converts a LM_GtkPaint message to a LM_PAINT message ------------------------------------------------------------------------------} function GtkPaintMessageToPaintMessage(GtkPaintMsg: TLMGtkPaint): TLMPaint; begin Result.Msg:=LM_PAINT; Result.DC:=GetDC(THandle(GtkPaintMsg.Widget)); Result.Unused:=0; Result.Result:=0; end; {------------------------------------------------------------------------------ Function: NewGDIRawImage Params: Width, Height: Size of the image Depth: Depth of the image Returns: a GDIRawImage Creates a RawImage ------------------------------------------------------------------------------} function NewGDIRawImage(const AWidth, AHeight: Integer; const ADepth: Byte): PGDIRawImage; begin Result := AllocMem(SizeOf(TGDIRawImage) + ((AWidth * AHeight) - 1) * SizeOf(TGDIRGB)); // FillChar(Result^, SizeOf(TGDIRawImage), 0); with Result^ do begin Height := AHeight; Width := AWidth; Depth := ADepth; end; end; {------------------------------------------------------------------------------ Function: AllocGDKColor Params: AColor: A RGB color (TColor) Returns: an Allocated GDKColor Allocated a GDKColor from a winapi color ------------------------------------------------------------------------------} function AllocGDKColor(const AColor: LongInt): TGDKColor; begin with Result do begin Red := ((AColor shl 8) and $00FF00) or ((AColor ) and $0000FF); Green := ((AColor ) and $00FF00) or ((AColor shr 8 ) and $0000FF); Blue := ((AColor shr 8) and $00FF00) or ((AColor shr 16) and $0000FF); end; gdk_colormap_alloc_color(gdk_colormap_get_system, @Result, False, True); end; {------------------------------------------------------------------------------ Function: CopyDCData Params: DestinationDC: a dc to copy data to SourceDC: a dc to copy data from Returns: True if succesful Creates a copy DC from the given DC ------------------------------------------------------------------------------} function CopyDCData(DestinationDC, SourceDC: TDeviceContext): Boolean; var GCValues: TGDKGCValues; begin Assert(False, Format('Trace:> [CopyDCData] DestDC:0x%x, SourceDC:0x%x', [Integer(DestinationDC), Integer(SourceDC)])); Result := (DestinationDC <> nil) and (SourceDC <> nil); if Result then begin with DestinationDC do begin Wnd := SourceDC.Wnd; Drawable := SourceDC.Drawable; if GC<>nil then begin gdk_gc_unref(GC); GC:=nil; DCFlags:=DCFlags-[dcfPenSelected]; end; if (SourceDC.GC <> nil) and (Drawable <> nil) then begin gdk_gc_get_values(SourceDC.GC, @GCValues); GC := gdk_gc_new_with_values(Drawable, @GCValues, 3 { $3FF}); DCFlags:=DCFlags-[dcfPenSelected]; end; Origin := SourceDC.Origin; SpecialOrigin := SourceDC.SpecialOrigin; PenPos := SourceDC.PenPos; if (dcfTextMetricsValid in SourceDC.DCFlags) then begin Include(DCFlags,dcfTextMetricsValid); DCTextMetric := SourceDC.DCTextMetric; end else Exclude(DCFlags,dcfTextMetricsValid); CurrentBitmap := SourceDC.CurrentBitmap; CurrentFont := SourceDC.CurrentFont; CurrentPen := SourceDC.CurrentPen; CurrentBrush := SourceDC.CurrentBrush; //CurrentPalette := SourceDC.CurrentPalette; CurrentTextColor := SourceDC.CurrentTextColor; CurrentBackColor := SourceDC.CurrentBackColor; ClipRegion := SourceDC.ClipRegion; SelectedColors := dcscCustom; SavedContext := nil; end; end; Assert(False, Format('Trace:< [CopyDCData] DestDC:0x%x, SourceDC:0x%x --> %d', [Integer(DestinationDC), Integer(SourceDC), Integer(Result)])); end; Function RegionType(RGN : PGDKRegion) : Longint; var aRect : TGDKRectangle; rRGN : hRGN; begin If RGN = nil then Result := ERROR else If gdk_region_empty(RGN) then Result := NULLREGION else begin gdk_region_get_clipbox(RGN,@aRect); With aRect do rRGN := CreateRectRgn(X, Y, X + Width, Y + Height); if gdk_region_equal(PGDIObject(rRGN)^.GDIRegionObject, RGN) then Result := SIMPLEREGION else Result := COMPLEXREGION; DeleteObject(rRGN); end; end; {------------------------------------------------------------------------------ Procedure SelectGDIRegion(const DC: HDC); Applies the current clipping region of the DC (DeviceContext) to the gc (GDK Graphic context - pgdkGC) ------------------------------------------------------------------------------} Procedure SelectGDIRegion(const DC: HDC); var Region: PGdiObject; DCOrigin: TPoint; RGNType : Longint; begin with TDeviceContext(DC) do begin gdk_gc_set_clip_region(gc, nil); gdk_gc_set_clip_rectangle (gc, nil); If (ClipRegion <> 0) then begin Region:=PGDIObject(ClipRegion); RGNType := RegionType(Region^.GDIRegionObject); If (RGNType <> ERROR) and (RGNType <> NULLREGION) then begin DCOrigin:=GetDCOffset(TDeviceContext(DC)); if (DCOrigin.X<>0) or (DCOrigin.Y<>0) then gdk_region_offset(Region^.GDIRegionObject,DCOrigin.X,DCOrigin.Y); gdk_gc_set_clip_region(gc, PGDIObject(ClipRegion)^.GDIRegionObject); if (DCOrigin.X<>0) or (DCOrigin.Y<>0) then gdk_region_offset(Region^.GDIRegionObject,-DCOrigin.X,-DCOrigin.Y); end; end; end; end; Procedure FreeGDIColor(var GDIColor : TGDIColor); begin if (cfColorAllocated in GDIColor.ColorFlags) then begin if (GDIColor.Colormap <> nil) then gdk_colormap_free_colors(GDIColor.Colormap,@GDIColor.Color, 1); //GDIColor.Color.Pixel := -1; Exclude(GDIColor.ColorFlags,cfColorAllocated); end; end; procedure SetGDIColorRef(var GDIColor : TGDIColor; NewColorRef: TColorRef); begin if GDIColor.ColorRef=NewColorRef then exit; FreeGDIColor(GDIColor); GDIColor.ColorRef:=NewColorRef; end; Procedure AllocGDIColor(DC : hDC; var GDIColor : TGDIColor); var RGBColor : Longint; begin if not (cfColorAllocated in GDIColor.ColorFlags) then begin FreeGDIColor(GDIColor); Case GDIColor.ColorRef of clScrollbar..clEndColors: RGBColor := GetSysColor(GDIColor.ColorRef and $FF); else RGBColor := GDIColor.ColorRef and $FFFFFF; end; With GDIColor.Color do begin Red := RGB(0,GetRValue(RGBColor),0); Green := RGB(0,GetGValue(RGBColor),0); Blue := RGB(0,GetBValue(RGBColor),0); Pixel := 0; end; {with TDeviceContext(DC) do If CurrentPalette <> nil then GDIColor.Colormap := CurrentPalette^.PaletteColormap else} GDIColor.Colormap := GDK_Colormap_get_system; gdk_colormap_alloc_color(GDIColor.Colormap, @GDIColor.Color,True,True); Include(GDIColor.ColorFlags,cfColorAllocated); end; end; Procedure EnsureGCColor(DC: hDC; ColorType: TDevContextsColorType; IsSolidBrush: Boolean; AsBackground: Boolean); var GC: PGDKGC; GDIColor: TGDIColor; Procedure EnsureAsGCValues; var AllocFG : Boolean; begin FreeGDIColor(GDIColor); With GetSysGCValues(GDIColor.ColorRef) do begin gdk_gc_set_fill(GC, fill); AllocFG := Foreground.Pixel = 0; If AllocFG then gdk_colormap_alloc_color(GDK_Colormap_get_system, @Foreground,True,True); gdk_gc_set_foreground(GC, @foreground); Case Fill of GDK_TILED : If Tile <> nil then begin gdk_gc_set_ts_origin(GC, ts_x_origin, ts_y_origin); gdk_gc_set_tile(GC, Tile); end; GDK_STIPPLED, GDK_OPAQUE_STIPPLED: If stipple <> nil then begin gdk_gc_set_background(GC, @background); gdk_gc_set_ts_origin(GC, ts_x_origin, ts_y_origin); gdk_gc_set_stipple(GC, stipple); end; end; If AllocFG then gdk_colormap_free_colors(GDK_Colormap_get_system, @Foreground,1); end; end; Procedure EnsureAsColor; begin AllocGDIColor(DC, GDIColor); If AsBackground then gdk_gc_set_background(GC, @GDIColor.Color) else begin gdk_gc_set_fill(GC, GDK_SOLID); gdk_gc_set_foreground(GC, @GDIColor.Color); end; end; begin GC:=TDeviceContext(DC).GC; with TDeviceContext(DC) do begin case ColorType of dccCurrentBackColor: GDIColor:=CurrentBackColor; dccCurrentTextColor: GDIColor:=CurrentTextColor; dccGDIBrushColor : GDIColor:=CurrentBrush^.GDIBrushColor; dccGDIPenColor : GDIColor:=CurrentPen^.GDIPenColor; else exit; end; Case GDIColor.ColorRef of clScrollbar, clInfoBk, clMenu, clHighlight, clHighlightText, clBtnFace: //often have a BK Pixmap If IsSolidBrush then EnsureAsGCValues else EnsureAsColor;//GC's with Pixmaps can't work w/Hatch's (yet) clBtnShadow, clBtnHighlight, clBtnText, clInfoText, clWindow, clWindowText, clMenuText, clGrayText ://should never have a BK Pixmap EnsureAsGCValues; else EnsureAsColor; end; end; end; //----------------------------------------------------------------------------- { Palette Index<->RGB Hash Functions } type TIndexRGB = record Index: longint; RGB: longint; end; PIndexRGB = ^TIndexRGB; function GetIndexAsKey(p: pointer): pointer; begin Result:=Pointer(PIndexRGB(p)^.Index + 1); end; function GetRGBAsKey(p: pointer): pointer; begin Result:=Pointer(PIndexRGB(p)^.RGB + 1); end; function PaletteIndexToIndexRGB(Pal : PGDIObject; I : longint): PIndexRGB; var HashItem: PDynHashArrayItem; begin Result := nil; HashItem:=Pal^.IndexTable.FindHashItemWithKey(Pointer(I + 1)); if HashItem<>nil then Result:=PIndexRGB(HashItem^.Item); end; function PaletteRGBToIndexRGB(Pal : PGDIObject; RGB : longint): PIndexRGB; var HashItem: PDynHashArrayItem; begin Result := nil; HashItem:=Pal^.RGBTable.FindHashItemWithKey(Pointer(RGB + 1)); if HashItem<>nil then Result:=PIndexRGB(HashItem^.Item); end; { Palette Index<->RGB lookup Functions } function PaletteIndexExists(Pal : PGDIObject; I : longint): Boolean; begin Result := Pal^.IndexTable.ContainsKey(Pointer(I + 1)); end; function PaletteRGBExists(Pal : PGDIObject; RGB : longint): Boolean; begin Result := Pal^.RGBTable.ContainsKey(Pointer(RGB + 1)); end; function PaletteAddIndex(Pal : PGDIObject; I, RGB : Longint): Boolean; var IndexRGB: PIndexRGB; begin New(IndexRGB); IndexRGB^.Index:=I; IndexRGB^.RGB:=RGB; Pal^.IndexTable.Add(IndexRGB); Result := PaletteIndexExists(Pal, I); If Not Result then Dispose(IndexRGB) else begin Pal^.RGBTable.Add(IndexRGB); Result := PaletteRGBExists(Pal, RGB); If not Result then begin Pal^.IndexTable.Remove(IndexRGB); Dispose(IndexRGB); end; end; end; function PaletteDeleteIndex(Pal : PGDIObject; I : Longint): Boolean; var RGBIndex : PIndexRGB; begin RGBIndex := PaletteIndextoIndexRGB(Pal,I); Result := RGBIndex = nil; If not Result then begin Pal^.IndexTable.Remove(RGBIndex); If PaletteRGBExists(Pal, RGBIndex^.RGB) then Pal^.RGBTable.Remove(RGBIndex); Dispose(RGBIndex); end; end; function PaletteIndexToRGB(Pal : PGDIObject; I : longint): longint; var RGBIndex : PIndexRGB; begin RGBIndex := PaletteIndextoIndexRGB(Pal,I); if RGBIndex = nil then Result := -1//InvalidRGB else Result := RGBIndex^.RGB; end; function PaletteRGBToIndex(Pal : PGDIObject; RGB : longint): longint; var RGBIndex : PIndexRGB; begin RGBIndex := PaletteRGBtoIndexRGB(Pal,RGB); if RGBIndex = nil then Result:=-1//InvalidIndex else Result := RGBIndex^.Index; end; Procedure InitializePalette(Pal : PGDIObject; Entries : PPALETTEENTRY; RGBCount : Longint); var PalEntries : PPALETTEENTRY; I : Integer; RGBValue : Longint; begin PalEntries := Entries; For I := 0 to RGBCount - 1 do begin If PaletteIndexExists(Pal, I) then PaletteDeleteIndex(Pal, I); With PalEntries[I] do RGBValue := RGB(peRed, peGreen, peBlue) {or (peFlags shl 32)??}; If not PaletteRGBExists(Pal, RGBValue) then PaletteAddIndex(Pal, I, RGBValue); end; end; {------------------------------------------------------------------------------ Procedure: GTKEventState2ShiftState Params: KeyState: The gtk keystate Returns: the TShiftState for the given KeyState GTKEventState2ShiftState converts a GTK event state to a LCL/Delphi TShiftState ------------------------------------------------------------------------------} function GTKEventState2ShiftState(KeyState: Word): TShiftState; begin result:=[]; if (KeyState and GDK_SHIFT_MASK) <> 0 then Result := Result + [ssShift]; if (KeyState and GDK_LOCK_MASK) <> 0 then Result := Result + [ssCaps]; if (KeyState and GDK_CONTROL_MASK) <> 0 then Result := Result + [ssCtrl]; if (KeyState and GDK_MOD1_MASK) <> 0 then Result := Result + [ssAlt]; //if (KeyState and GDK_MOD2_MASK) <> 0 then Result := Result + [??ssWindows??]; if (KeyState and GDK_MOD3_MASK) <> 0 then Result := Result + [ssNum]; if (KeyState and GDK_MOD4_MASK) <> 0 then Result := Result + [ssSuper]; if (KeyState and GDK_MOD5_MASK) <> 0 then Result := Result + [ssScroll]; if (KeyState and GDK_BUTTON1_MASK) <> 0 then Result := Result + [ssLeft]; if (KeyState and GDK_BUTTON2_MASK) <> 0 then Result := Result + [ssMiddle]; if (KeyState and GDK_BUTTON3_MASK) <> 0 then Result := Result + [ssRight]; //if (KeyState and GDK_BUTTON4_MASK) <> 0 then Result := Result + [??WheelMouse??]; //if (KeyState and GDK_BUTTON5_MASK) <> 0 then Result := Result + [??WheelMouse??]; if (KeyState and GDK_RELEASE_MASK) <> 0 then Result := Result + [ssAltGr]; end; {------------------------------------------------------------------------------ ------------------------------------------------------------------------------} function KeyToListCode(KeyCode, VirtKeyCode: Word; Extended: boolean): integer; begin if VirtKeyCode = VK_UNKNOWN then Result := KEYMAP_VKUNKNOWN and KeyCode else Result := VirtKeyCode; if Extended then Result := Result or KEYMAP_EXTENDED; end; {------------------------------------------------------------------------------ Procedure: GetGTKKeyInfo Params: Event: Requested info KeyCode: the ASCII key code of the eventkey VirtualKey: the virtual key code of the eventkey SysKey: True if the key is a syskey Extended: True if the key is an extended key Toggle: True if the key is a toggle key and its value is on Returns: Nothing GetGTKKeyInfo returns information about the given key event ------------------------------------------------------------------------------} procedure GetGTKKeyInfo(const Event: PGDKEventKey; var KeyCode,VirtualKey: Word; var SysKey, Extended, Toggle: Boolean); var ShiftState: TShiftState; begin VirtualKey := VK_UNKNOWN; KeyCode := $FFFF; SysKey := (Event^.State and GDK_MOD1_MASK) <> 0; ShiftState := GTKEventState2ShiftState(Event^.State); Extended := False; Toggle := False; {if Event^.Length>0 then begin writeln('GetGTKKeyInfo Event^.KeyVal=',Event^.KeyVal, ' Event^.Length=',Event^.Length,' ',ord(Event^.theString[0]) ); end;} case Event^.KeyVal of // Normal ASCII chars 32..255: begin { Assign key code} KeyCode := Event^.KeyVal; //TODO: create VK_ code --> [*] and [8] have a different KeyCode but same VK_ code case Chr(KeyCode) of '@': VirtualKey:=VK_AT; 'A'..'Z', '0'..'9', ' ': VirtualKey := KeyCode; 'a'..'z': VirtualKey := KeyCode - Ord('a') + Ord('A'); '/': VirtualKey := VK_SLASH; ',': VirtualKey := VK_COMMA; '=': VirtualKey := VK_EQUAL; '*': VirtualKey := VK_MULTIPLY; '+': VirtualKey := VK_ADD; '-': VirtualKey := VK_SUBTRACT; '.': VirtualKey := VK_POINT; end; { look for control code } if (ssCtrl in ShiftState) and (Chr(KeyCode) in ['@'..'Z']) then Dec(KeyCode, Ord('@')); end; GDK_dead_circumflex: begin KeyCode := Ord('^'); end; GDK_KP_Space: begin KeyCode := VK_SPACE; VirtualKey := VK_SPACE; end; GDK_KP_Tab: begin KeyCode := VK_TAB; VirtualKey := VK_TAB; end; GDK_KP_Enter: begin KeyCode := VK_Return; VirtualKey := VK_Return; end; GDK_Tab: begin KeyCode := VK_TAB; VirtualKey := VK_TAB; end; GDK_Return: begin KeyCode := VK_RETURN; VirtualKey := VK_RETURN; end; GDK_Linefeed: begin KeyCode := $0A; VirtualKey := $0A; end; // Cursor block / keypad GDK_Insert: begin VirtualKey := VK_INSERT; Extended := True; end; GDK_Home: begin VirtualKey := VK_HOME; Extended := True; end; GDK_Left: begin VirtualKey := VK_LEFT; Extended := True; end; GDK_Up: begin VirtualKey := VK_UP; Extended := True; end; GDK_Right: begin VirtualKey := VK_RIGHT; Extended := True; end; GDK_Down: begin VirtualKey := VK_DOWN; Extended := True; end; GDK_Page_Up: begin VirtualKey := VK_PRIOR; Extended := True; end; GDK_Page_Down: begin VirtualKey := VK_NEXT; Extended := True; end; GDK_End: begin VirtualKey := VK_END; Extended := True; end; GDK_KP_Insert: VirtualKey := VK_INSERT; GDK_KP_Home: VirtualKey := VK_HOME; GDK_KP_Left: VirtualKey := VK_LEFT; GDK_KP_Up: VirtualKey := VK_UP; GDK_KP_Right: VirtualKey := VK_RIGHT; GDK_KP_Down: VirtualKey := VK_DOWN; GDK_KP_Page_Up: VirtualKey := VK_PRIOR; GDK_KP_Page_Down: VirtualKey := VK_NEXT; GDK_KP_End: VirtualKey := VK_END; GDK_Num_Lock: VirtualKey := VK_NUMLOCK; GDK_KP_F1: VirtualKey := VK_F1; GDK_KP_F2: VirtualKey := VK_F2; GDK_KP_F3: VirtualKey := VK_F3; GDK_KP_F4: VirtualKey := VK_F4; GDK_KP_Equal: begin VirtualKey := VK_EQUAL; if not (ssCtrl in ShiftState) then KeyCode := Ord('='); end; GDK_KP_Multiply: begin VirtualKey := VK_MULTIPLY; if not (ssCtrl in ShiftState) then KeyCode := Ord('*'); end; GDK_KP_Add: begin VirtualKey := VK_ADD; if not (ssCtrl in ShiftState) then KeyCode := Ord('+'); end; GDK_KP_Separator: begin VirtualKey := VK_SEPARATOR; // if not CtrlDown then KeyCode := Ord('????'); end; GDK_KP_Subtract: begin VirtualKey := VK_SUBTRACT; if not (ssCtrl in ShiftState) then KeyCode := Ord('-'); end; GDK_KP_Decimal: begin VirtualKey := VK_DECIMAL; if not (ssCtrl in ShiftState) then KeyCode := Ord('.'); end; GDK_KP_Divide: begin VirtualKey := VK_DIVIDE; Extended := True; if not (ssCtrl in ShiftState) then KeyCode := Ord('/'); end; GDK_KP_0..GDK_KP_9: begin VirtualKey := VK_NUMPAD0 + (Event^.KeyVal - GDK_KP_0); if not (ssCtrl in ShiftState) then KeyCode := Ord('0') + (Event^.KeyVal - GDK_KP_0); end; GDK_BackSpace: VirtualKey := VK_BACK; GDK_Clear_Key: VirtualKey := VK_CLEAR; GDK_Pause: VirtualKey := VK_PAUSE; GDK_Scroll_Lock: VirtualKey := VK_SCROLL; GDK_Sys_Req: VirtualKey := VK_SNAPSHOT; GDK_Escape: VirtualKey := VK_ESCAPE; GDK_Delete_Key: VirtualKey := VK_DELETE; // GDK_Multi_key = $FF20; // GDK_SingleCandidate = $FF3C; // GDK_MultipleCandidate = $FF3D; // GDK_PreviousCandidate = $FF3E; GDK_Kanji: VirtualKey := VK_KANJI; // GDK_Muhenkan = $FF22; // GDK_Henkan_Mode = $FF23; // GDK_Henkan = $FF23; // GDK_Romaji = $FF24; // GDK_Hiragana = $FF25; // GDK_Katakana = $FF26; // GDK_Hiragana_Katakana = $FF27; // GDK_Zenkaku = $FF28; // GDK_Hankaku = $FF29; // GDK_Zenkaku_Hankaku = $FF2A; // GDK_Touroku = $FF2B; // GDK_Massyo = $FF2C; // GDK_Kana_Lock = $FF2D; // GDK_Kana_Shift = $FF2E; // GDK_Eisu_Shift = $FF2F; // GDK_Eisu_toggle = $FF30; // GDK_Zen_Koho = $FF3D; // GDK_Mae_Koho = $FF3E; GDK_Select: VirtualKey := VK_SELECT; GDK_Print: VirtualKey := VK_PRINT; GDK_Execute: VirtualKey := VK_EXECUTE; GDK_Menu: VirtualKey := VK_MENU; // GDK_Find = $FF68; GDK_Cancel: VirtualKey := VK_CANCEL; GDK_Help: VirtualKey := VK_HELP; GDK_Break: VirtualKey := VK_CANCEL; GDK_Mode_switch: VirtualKey := VK_MODECHANGE; // GDK_script_switch = $FF7E; GDK_Caps_Lock: VirtualKey := VK_CAPITAL; // GDK_Shift_Lock = $FFE6; GDK_Shift_L: begin VirtualKey := VK_SHIFT; end; GDK_Shift_R: begin VirtualKey := VK_SHIFT; Extended := True; end; GDK_Control_L: begin VirtualKey := VK_CONTROL; end; GDK_Control_R: begin VirtualKey := VK_CONTROL; Extended := True; end; GDK_Alt_L: begin SysKey := True; VirtualKey:= VK_MENU; end; GDK_Alt_R: begin SysKey := True; VirtualKey:= VK_MENU; Extended := True; end; // Function keys GDK_F1..GDK_F24: VirtualKey := VK_F1 + (Event^.KeyVal - GDK_F1); //By VVI - fixing cyrillic keys //GDK_* is like a koi8-r, it is KOI8-R code +$600. GDK_cyrillic_io..GDK_cyrillic_Capital_hardsign: KeyCode := Event^.KeyVal mod $100; end; if VirtualKey=VK_UNKNOWN then begin // map all other keys to VK_IRREGULAR + KeyCode if ShortInt(KeyCode)>=0 then VirtualKey := MapIrregularVirtualKey(VK_IRREGULAR + KeyCode) else VirtualKey := VK_IRREGULAR; end; end; {------------------------------------------------------------------------------ Procedure: StoreCommonDialogSetup Params: ADialog: TCommonDialog Returns: none Stores the size of a TCommonDialog. ------------------------------------------------------------------------------} procedure StoreCommonDialogSetup(ADialog: TCommonDialog); var DlgWindow: PGtkWidget; begin if (ADialog=nil) or (ADialog.Handle=0) then exit; DlgWindow:=PGtkWidget(ADialog.Handle); if DlgWindow^.Allocation.Width>0 then ADialog.Width:=DlgWindow^.Allocation.Width; if DlgWindow^.Allocation.Height>0 then ADialog.Height:=DlgWindow^.Allocation.Height; end; {------------------------------------------------------------------------------ Procedure: DestroyCommonDialogAddOns Params: ADialog: TCommonDialog Returns: none Free the memory of additional data of a TCommonDialog ------------------------------------------------------------------------------} procedure DestroyCommonDialogAddOns(ADialog: TCommonDialog); var DlgWindow: PGtkWidget; HistoryList: TList; // list of TFileSelHistoryListEntry FilterList: TList; // list of TFileSelFilterListEntry AHistoryEntry: PFileSelHistoryEntry; AFilterEntry: PFileSelFilterEntry; i: integer; begin if (ADialog=nil) or (ADialog.Handle=0) then exit; DlgWindow:=PGtkWidget(ADialog.Handle); if ADialog is TOpenDialog then begin // free history HistoryList:=TList(gtk_object_get_data(PGtkObject(DlgWindow), 'LCLHistoryList')); if HistoryList<>nil then begin for i:=0 to HistoryList.Count-1 do begin AHistoryEntry:=PFileSelHistoryEntry(HistoryList[i]); StrDispose(AHistoryEntry^.Filename); AHistoryEntry^.Filename:=nil; Dispose(AHistoryEntry); end; HistoryList.Free; gtk_object_set_data(PGtkObject(DlgWindow),'LCLHistoryList',nil); end; // free filter FilterList:=TList(gtk_object_get_data(PGtkObject(DlgWindow), 'LCLFilterList')); if FilterList<>nil then begin for i:=0 to FilterList.Count-1 do begin AFilterEntry:=PFileSelFilterEntry(FilterList[i]); StrDispose(AFilterEntry^.Description); AFilterEntry^.Description:=nil; StrDispose(AFilterEntry^.Mask); AFilterEntry^.Mask:=nil; Dispose(AFilterEntry); end; FilterList.Free; gtk_object_set_data(PGtkObject(DlgWindow),'LCLFilterList',nil); end; end; end; {------------------------------------------------------------------------------ Procedure: DeliverMessage Params: Message: the message to process Returns: True if handled Generic function which calls the WindowProc if defined, otherwise the dispatcher ------------------------------------------------------------------------------} function DeliverMessage(const Target: Pointer; var AMessage): Integer; begin if Target=nil then writeln('[DeliverMessage] Target = nil'); {$IFDEF VerboseDeliverMessage} writeln('DeliverMessage ',TComponent(Target).Name,':',TObject(Target).ClassName, ' Message=',TLMessage(AMessage).Msg); {$ENDIF} if TObject(Target) is TControl then begin TControl(Target).WindowProc(TLMessage(AMessage)); end else begin TObject(Target).Dispatch(TLMessage(AMessage)); end; Result := TLMessage(AMessage).Result; end; {------------------------------------------------------------------------------ Function: ObjectToGTKObject Params: AObject: A LCL Object Returns: The GTKObject of the given object Returns the GTKObject of the given object, nil if no object available ------------------------------------------------------------------------------} function ObjectToGTKObject(const AObject: TObject): PGtkObject; var handle : HWND; begin Handle := 0; if not assigned(AObject) then begin assert (false, 'TRACE: [ObjectToGtkObject] Object not assigned'); end else if (AObject is TWinControl) then begin if TWinControl(AObject).HandleAllocated then handle := TWinControl(AObject).Handle; end else if (AObject is TMenuItem) then begin if TMenuItem(AObject).HandleAllocated then handle := TMenuItem(AObject).Handle; end else if (AObject is TMenu) then begin if TMenu(AObject).HandleAllocated then handle := TMenu(AObject).Items.Handle; end else if (AObject is TCommonDialog) then begin {if TCommonDialog(AObject).HandleAllocated then } handle := TCommonDialog(AObject).Handle; end else begin Assert(False, Format('Trace: [ObjectToGtkObject] Message received with unhandled class-type <%s>', [AObject.ClassName])); end; Result := gtk_object (handle); if handle = 0 then Assert (false, 'Trace: [ObjectToGtkObject]****** Warning: handle = 0 *******'); end; (*********************************************************************** Widget member functions ************************************************************************) // ---------------------------------------------------------------------- // the main widget is the widget passed as handle to the winAPI // main data is stored in the fixed form to get a reference to its parent // ---------------------------------------------------------------------- function GetMainWidget(const Widget: Pointer): Pointer; begin if Widget<>nil then begin Result := gtk_object_get_data(Widget, 'Main'); if Result = nil then Result := Widget; // the widget is the main widget itself. end else RaiseException('GetMainWidget Widget=nil'); end; procedure SetMainWidget(const ParentWidget, ChildWidget: Pointer); begin if ChildWidget<>nil then begin if (ParentWidget<>ChildWidget) then gtk_object_set_data(ChildWidget, 'Main', ParentWidget) else raise Exception.Create('SetMainWidget ChildWidget=ParentWidget'); end else RaiseException('SetMainWidget ChildWidget=nil'); end; { ------------------------------------------------------------------------------ Get the fixed widget of a widget. Every LCL control with a clientarea, has at least a main widget for the control and a fixed widget for the client area. If the Fixed widget is not set, use the widget itself as a fallback. ------------------------------------------------------------------------------ } function GetFixedWidget(const Widget: Pointer): Pointer; begin if Widget<>nil then begin Result := gtk_object_get_data(Widget, 'Fixed'); if Result = nil then Result:= Widget; end else begin RaiseException('GetFixedWidget Widget=nil'); end; end; { ------------------------------------------------------------------------------ Set the fixed widget of a widget. Every LCL control with a clientarea, has at least a main widget for the control and a fixed widget for the client area. ------------------------------------------------------------------------------ } procedure SetFixedWidget(const ParentWidget, FixedWidget: Pointer); begin if (ParentWidget<>nil) then gtk_object_set_data(ParentWidget, 'Fixed', FixedWidget) else RaiseException('SetFixedWidget ParentWidget=nil'); end; {------------------------------------------------------------------------------ Procedure FixedMoveControl(Parent, Child : PGTKWIdget; Left, Top : Longint); Move a childwidget on a client area (fixed or layout widget). ------------------------------------------------------------------------------} Procedure FixedMoveControl(Parent, Child : PGTKWIdget; Left, Top : Longint); begin If GTKWidgetIsA(Parent, GTK_Layout_Get_Type) then gtk_Layout_move(PGtkLayout(Parent), Child, Left, Top) else If GTKWidgetIsA(Parent, GTK_Fixed_Get_Type) then gtk_fixed_move(PGtkFixed(Parent), Child, Left, Top) else WriteLn('[FixedMoveControl] WARNING: Invalid Fixed Widget'); end; {------------------------------------------------------------------------------ Procedure FixedPutControl(Parent, Child : PGTKWIdget; Left, Top : Longint); Add a childwidget onto a client area (fixed or layout widget). ------------------------------------------------------------------------------} Procedure FixedPutControl(Parent, Child : PGTKWIdget; Left, Top : Longint); begin If GTKWidgetIsA(Parent, GTK_Fixed_Get_Type) then gtk_fixed_put(PGtkFixed(Parent), Child, Left, Top) else If GTKWidgetIsA(Parent, GTK_Layout_Get_Type) then gtk_Layout_Put(PGtkLayout(Parent), Child, Left, Top) else WriteLn('[FixedPutControl] WARNING: Invalid Fixed Widget.', ' Parent=',HexStr(Cardinal(Parent),8), ' Child=',HexStr(Cardinal(Child),8) ); end; {------------------------------------------------------------------------------ Function GetControlWindow(Control: Pointer) : PGDKWindow; Get the gdkwindow of a widget. ------------------------------------------------------------------------------} Function GetControlWindow(Control: Pointer) : PGDKWindow; begin If Control <> nil then begin If not GTKWidgetIsA(PGTKWidget(Control), GTK_Layout_Get_Type) then Result := PGTKWidget(Control)^.Window else Result := PGtkLayout(Control)^.bin_window; end else RaiseException('GetControlWindow Control=nil'); end; {------------------------------------------------------------------------------ function GetDCOffset(DC: TDeviceContext): TPoint; Returns the DC offset for the DC Origin. ------------------------------------------------------------------------------} function GetDCOffset(DC: TDeviceContext): TPoint; var Fixed : PGTKWIdget; Adjustment: PGtkAdjustment; begin if (DC<>nil) then begin Result:=DC.Origin; if (DC.SpecialOrigin) and (DC.Wnd<>0) then begin Fixed := GetFixedWidget(PGTKWidget(DC.Wnd)); if GtkWidgetIsA(Fixed,GTK_LAYOUT_GET_TYPE) then begin // ToDo: add comment Adjustment:=gtk_layout_get_hadjustment(PGtkLayout(Fixed)); if Adjustment<>nil then dec(Result.X,Trunc(Adjustment^.Value-Adjustment^.Lower)); Adjustment:=gtk_layout_get_vadjustment(PGtkLayout(Fixed)); if Adjustment<>nil then dec(Result.Y,Trunc(Adjustment^.Value-Adjustment^.Lower)); end; end; end else begin Result.X:=0; Result.Y:=0; end; end; // ---------------------------------------------------------------------- // Creates a WinWidget info structure for the given widget // Info needed by the API of a HWND (=Widget) // // This structure obsoletes: // "core-child", "fixed", "class" // ---------------------------------------------------------------------- function CreateWidgetInfo(const Widget: Pointer): PWinWidgetInfo; begin if Widget = nil then Result:= nil else begin New(Result); FillChar(Result^, SizeOf(Result^), 0); gtk_object_set_data(Widget, 'widgetinfo', Result); end; end; function GetWidgetInfo(const Widget: Pointer; const Create: Boolean): PWinWidgetInfo; var MainWidget: PGtkObject; begin if Widget <> nil then begin MainWidget:= GetMainWidget(Widget); if MainWidget = nil then MainWidget:= Widget; Result:= gtk_object_get_data(MainWidget, 'widgetinfo'); if (Result = nil) and Create then begin Result := CreateWidgetInfo(MainWidget); Result^.ImplementationWidget:= PGtkWidget(MainWidget); end; end else Result:=nil; end; procedure FreeWinWidgetInfo(Widget: Pointer); var WinWidgetInfo: PWinWidgetInfo; begin if Widget=nil then exit; WinWidgetInfo := gtk_object_get_data(Widget, 'widgetinfo'); if WinWidgetInfo<>nil then begin Dispose(WinWidgetInfo); gtk_object_set_data(Widget,'widgetinfo',nil); end; end; {------------------------------------------------------------------------------- procedure DestroyWidget(Widget: PGtkWidget); -------------------------------------------------------------------------------} procedure DestroyWidget(Widget: PGtkWidget); begin FreeWinWidgetInfo(Widget); gtk_widget_destroy(Widget); end; {------------------------------------------------------------------------------- function GetGtkNoteBookDummyPage(ANoteBookWidget: PGtkNoteBook): PGtkWidget; Retrieves the DummyWidget associated with the ANoteBookWidget -------------------------------------------------------------------------------} function GetGtkNoteBookDummyPage(ANoteBookWidget: PGtkNoteBook): PGtkWidget; begin Result:=gtk_object_get_data(PGtkObject(ANoteBookWidget),'LCLDummyPage'); end; {------------------------------------------------------------------------------- procedure SetGtkNoteBookDummyPage(ANoteBookWidget: PGtkNoteBook; DummyWidget: PGtkWidget): PGtkWidget; Associates the DummyWidget with the ANoteBookWidget -------------------------------------------------------------------------------} procedure SetGtkNoteBookDummyPage(ANoteBookWidget: PGtkNoteBook; DummyWidget: PGtkWidget); begin gtk_object_set_data(PGtkObject(ANoteBookWidget),'LCLDummyPage',DummyWidget); end; {------------------------------------------------------------------------------ UpdateNoteBookClientWidget Params: ANoteBook: TObject This procedure updates the 'Fixed' object data. * obsolete * ------------------------------------------------------------------------------} procedure UpdateNoteBookClientWidget(ANoteBook: TObject); var ClientWidget: PGtkWidget; NoteBookWidget: PGtkNotebook; begin if not TCustomNotebook(ANoteBook).HandleAllocated then exit; NoteBookWidget:=PGtkNotebook(TCustomNotebook(ANoteBook).Handle); ClientWidget:=nil; SetFixedWidget(NoteBookWidget,ClientWidget); end; {------------------------------------------------------------------------------- Some need the LCLobject which created this widget. -------------------------------------------------------------------------------} procedure SetLCLObject(const Widget: Pointer; const AnObject: TObject); begin if (Widget <> nil) then gtk_object_set_data(Widget, 'Class', Pointer(AnObject)); end; function GetLCLObject(const Widget: Pointer): TObject; begin Result := TObject(gtk_object_get_data(Widget, 'Class')); end; function GetParentLCLObject(Widget: PGtkWidget): TObject; begin while (Widget<>nil) do begin Result:=GetLCLObject(Widget); if Result<>nil then exit; Widget:=Widget^.Parent; end; Result:=nil; end; {------------------------------------------------------------------------------- Some need the HiddenLCLobject which created a parent of this widget. -------------------------------------------------------------------------------} procedure SetHiddenLCLObject(const Widget: Pointer; const AnObject: TObject); begin if (Widget <> nil) then gtk_object_set_data(Widget, 'LCLHiddenClass', Pointer(AnObject)); end; function GetHiddenLCLObject(const Widget: Pointer): TObject; begin Result := TObject(gtk_object_get_data(Widget, 'LCLHiddenClass')); end; {------------------------------------------------------------------------------- GetWidgetScreenPos Returns the absolute left top position of a widget on the screen. -------------------------------------------------------------------------------} function GetWidgetOrigin(TheWidget: PGtkWidget): TPoint; var TheWindow: PGdkWindow; {$IFDEF RaiseExceptionOnNilPointers} LCLObject: TObject; {$ENDIF} begin TheWindow:=GetControlWindow(TheWidget); if TheWindow<>nil then gdk_window_get_origin(TheWindow,@Result.X,@Result.Y) else begin {$IFDEF RaiseExceptionOnNilPointers} LCLobject:=GetLCLObject(TheWidget); write('GetWidgetOrigin '); if LCLObject=nil then write(' LCLObject=nil') else if LCLObject is TControl then write(' LCLObject=',TControl(LCLObject).Name,':',TControl(LCLObject).ClassName) else write(' LCLObject=',TControl(LCLObject).ClassName); writeln(''); RaiseException('GetWidgetOrigin Window=nil'); {$ENDIF} Result.X:=0; Result.Y:=0; end; // check if the gdkwindow is the clientwindow of the parent if gtk_widget_get_parent_window(TheWidget)=TheWindow then begin // the widget is using its parent window // -> adjust the coordinates inc(Result.X,TheWidget^.Allocation.X); inc(Result.Y,TheWidget^.Allocation.Y); end; end; {------------------------------------------------------------------------------- GetWidgetClientScreenPos Returns the absolute left top position of a widget's client area on the screen. -------------------------------------------------------------------------------} function GetWidgetClientOrigin(TheWidget: PGtkWidget): TPoint; var ClientWidget: PGtkWidget; ClientWindow: PGdkWindow; begin ClientWidget:=GetFixedWidget(TheWidget); if ClientWidget<>TheWidget then begin ClientWindow:=GetControlWindow(ClientWidget); if ClientWindow<>nil then begin gdk_window_get_origin(ClientWindow,@Result.X,@Result.Y); exit; end; end; Result:=GetWidgetOrigin(TheWidget); end; {------------------------------------------------------------------------------- TranslateGdkPointToClientArea Translates SourcePos relative to SourceWindow to a coordinate relative to the client area of the LCL WinControl. -------------------------------------------------------------------------------} function TranslateGdkPointToClientArea(SourceWindow: PGdkWindow; SourcePos: TPoint; DestinationWidget: PGtkWidget): TPoint; var SrcWindowOrigin: TPoint; ClientAreaWindowOrigin: TPoint; Src2ClientAreaVector: TPoint; begin if SourceWindow=nil then begin {$IFDEF RaiseExceptionOnNilPointers} RaiseException('TranslateGdkPointToClientArea Window=nil'); {$ENDIF} writeln('WARNING: TranslateGdkPointToClientArea SourceWindow=nil'); end; gdk_window_get_origin(SourceWindow,@SrcWindowOrigin.X,@SrcWindowOrigin.Y); ClientAreaWindowOrigin:=GetWidgetClientOrigin(DestinationWidget); Src2ClientAreaVector.X:=ClientAreaWindowOrigin.X-SrcWindowOrigin.X; Src2ClientAreaVector.Y:=ClientAreaWindowOrigin.Y-SrcWindowOrigin.Y; Result.X:=SourcePos.X-Src2ClientAreaVector.X; Result.Y:=SourcePos.Y-Src2ClientAreaVector.Y; end; {------------------------------------------------------------------------------ Function: UpdateMouseCaptureControl Params: none Returns: none Sets MCaptureControl to the current capturing widget. ------------------------------------------------------------------------------} procedure UpdateMouseCaptureControl; var OldMouseCaptureWidget, CurMouseCaptureWidget: PGtkWidget; begin OldMouseCaptureWidget:=MouseCaptureWidget; CurMouseCaptureWidget:=gtk_grab_get_current; if OldMouseCaptureWidget<>CurMouseCaptureWidget then begin // notify the new capture control MouseCaptureWidget:=CurMouseCaptureWidget; MouseCapureByLCL:=false; if MouseCaptureWidget<>nil then SendMessage(HWnd(MouseCaptureWidget), LM_CAPTURECHANGED, 0, HWnd(OldMouseCaptureWidget)); end; end; {------------------------------------------------------------------------------ procedure ReleaseLCLMouseCapture; If the current mouse capture was captured by the LCL, release the capture. ------------------------------------------------------------------------------} procedure ReleaseMouseCapture(OnlyIfCapturedByLCL: boolean); var OldCaptureWidget: PGtkWidget; begin if OnlyIfCapturedByLCL and not MouseCapureByLCL then exit; {$IfNDef ActivateMouseCapture} exit; {$EndIf} repeat OldCaptureWidget:=gtk_grab_get_current; if OldCaptureWidget<>nil then gtk_grab_remove(OldCaptureWidget) else break; until false; end; {------------------------------------------------------------------------------ procedure: SetCursor Params: AWinControl : TWinControl Returns: Nothing Sets the cursor for a widget. ------------------------------------------------------------------------------} procedure SetCursor(AWinControl : TWinControl; Data: Pointer); procedure DoSetCursor(AWindow: PGdkWindow; Cursor: pGDKCursor); begin if Cursor <> nil then gdk_window_set_cursor(AWindow, Cursor); end; procedure SetDesigningCursor(AWindow: PGdkWindow; Cursor: PGdkCursor); var ChildWindows, ListEntry: PGList; begin DoSetCursor(AWindow, Cursor); ChildWindows:=gdk_window_get_children(AWindow); ListEntry:=ChildWindows; while ListEntry<>nil do begin SetDesigningCursor(PGdkWindow(ListEntry^.Data), Cursor); ListEntry:=ListEntry^.Next; end; g_list_free(ChildWindows); end; var AWidget, FixWidget: PGtkWidget; AWindow: PGdkWindow; NewCursor: PGdkCursor; begin if not ((AWinControl is TWinControl) and AWinControl.HandleAllocated) then exit; AWidget:= PGtkWidget(AWinControl.Handle); if csDesigning in AWinControl.ComponentState then begin AWindow:=GetControlWindow(AWidget); if AWindow = nil then exit; if Data = nil then SetDesigningCursor(AWindow, GetGDKMouseCursor(crDefault)) else begin NewCursor:= GetGDKMouseCursor(Integer(Data)); if NewCursor <> nil then SetDesigningCursor(AWindow, NewCursor); end; end else begin FixWidget:= GetFixedWidget(AWidget); AWindow:= GetControlWindow(FixWidget); if AWindow = nil then exit; NewCursor:= GetGDKMouseCursor(AWinControl.Cursor); if NewCursor <> nil then DoSetCursor(AWindow, NewCursor); end; end; {------------------------------------------------------------------------------- procedure ConnectSignal(const AnObject:gtk_Object; const ASignal: PChar; const ACallBackProc: Pointer; const ReqSignalMask: TGdkEventMask; Flags: TConnectSignalFlags); Connects a gtk signal handler. -------------------------------------------------------------------------------} procedure InitDesignSignalMasks; var SignalType: TDesignSignalType; begin DesignSignalMasks[dstUnknown]:=0; for SignalType:=Low(TDesignSignalType) to High(TDesignSignalType) do DesignSignalMasks[SignalType]:=1 shl ord(SignalType); end; function DesignSignalNameToType(Name: PChar; After: boolean): TDesignSignalType; begin for Result:=Low(TDesignSignalType) to High(TDesignSignalType) do if ComparePChar(DesignSignalNames[Result],Name) and (DesignSignalAfter[Result]=After) then exit; Result:=dstUnknown; end; function GetDesignSignalMask(Widget: PGtkWidget): TDesignSignalMask; begin Result:=TDesignSignalMask(gtk_object_get_data(PGtkObject(Widget), 'LCLDesignMask')); end; procedure SetDesignSignalMask(Widget: PGtkWidget; NewMask: TDesignSignalMask); begin gtk_object_set_data(PGtkObject(Widget),'LCLDesignMask',Pointer(NewMask)); end; function GetDesignOnlySignalFlag(Widget: PGtkWidget; DesignSignalType: TDesignSignalType): boolean; begin Result:=(GetDesignSignalMask(Widget) and DesignSignalMasks[DesignSignalType])<>0; end; procedure ConnectSignal(const AnObject:gtk_Object; const ASignal: PChar; const ACallBackProc: Pointer; LCLComponent: TComponent; const ReqSignalMask: TGdkEventMask; SFlags: TConnectSignalFlags); var RealizeHandler, Handler: PGTKHandler; RealizeID, SignalID: guint; WinWidgetInfo: PWinWidgetInfo; MainWidget: PGtkWidget; OldDesignMask, NewDesignMask: TDesignSignalMask; DesignSignalType: TDesignSignalType; begin if ACallBackProc = nil then exit; // first loop through the handlers to: // - check if a handler already exists // - Find the realize handler to change data Handler := gtk_object_get_data_by_id (AnObject, gtk_handler_quark); SignalID := gtk_signal_lookup(ASignal, GTK_OBJECT_TYPE(AnObject)); if csfConnectRealize in SFlags then RealizeID := gtk_signal_lookup('realize', GTK_OBJECT_TYPE(AnObject)) else RealizeID := 0; RealizeHandler := nil; DesignSignalType:=DesignSignalNameToType(ASignal,csfAfter in SFlags); while (Handler <> nil) do begin with Handler^ do begin // check if signal is already connected if (Id > 0) and (Signal_ID = SignalID) and (Func = TGTKSignalFunc(ACallBackProc)) and (func_data = Pointer(LCLComponent)) and (((flags and bmSignalAfter)<>0)=(csfAfter in SFlags)) then begin Assert(False, Format('Trace:WARNING: [TGTKObject.SetCallback] %s signal <%s> set twice', [LCLComponent.ClassName, ASignal])); // signal is already connected // update the DesignSignalMask if (DesignSignalType<>dstUnknown) and (not (csfDesignOnly in SFlags)) then begin OldDesignMask:=GetDesignSignalMask(PGtkWidget(AnObject)); NewDesignMask:= OldDesignMask and not DesignSignalMasks[DesignSignalType]; if OldDesignMask<>NewDesignMask then SetDesignSignalMask(PGtkWidget(AnObject),NewDesignMask); end; Exit; end; // look for realize handler if (csfConnectRealize in SFlags) and (Id > 0) and (Signal_ID = RealizeID) and (Func = TGTKSignalFunc(@GTKRealizeCB)) and (func_data = Pointer(LCLComponent)) and ((flags and bmSignalAfter)=0) // test if not after then RealizeHandler := Handler; Handler := Next; end; end; // if we are here, then no handler was defined yet // -> register handler //if (Msg=LM_LBUTTONUP) then writeln('CONNECT ',ReqSignalMask,' Widget=',HexStr(Cardinal(AnObject),8)); if csfAfter in SFlags then gtk_signal_connect_after(AnObject, ASignal, TGTKSignalFunc(ACallBackProc),LCLComponent) else gtk_signal_connect (AnObject, ASignal, TGTKSignalFunc(ACallBackProc),LCLComponent); // update signal mask which will be set in the realize handler if (csfUpdateSignalMask in SFlags) and (ReqSignalMask <> 0) then begin MainWidget:=GetMainWidget(PGtkWidget(AnObject)); if MainWidget=nil then MainWidget:=PGtkWidget(AnObject); WinWidgetInfo:=GetWidgetInfo(MainWidget,true); WinWidgetInfo^.EventMask:=WinWidgetInfo^.EventMask or ReqSignalMask; end; // -> register realize handler if (csfConnectRealize in SFlags) and (RealizeHandler = nil) and (RealizeID<>0) then begin //writeln('REALIZE CONNECT Widget=',HexStr(Cardinal(AnObject),8)); gtk_signal_connect(AnObject, 'realize', TGTKSignalFunc(@GTKRealizeCB), LCLComponent); gtk_signal_connect_after(AnObject, 'realize', TGTKSignalFunc(@GTKRealizeAfterCB), LCLComponent); end; // update the DesignSignalMask if (DesignSignalType<>dstUnknown) then begin OldDesignMask:=GetDesignSignalMask(PGtkWidget(AnObject)); if csfDesignOnly in SFlags then NewDesignMask:=OldDesignMask or DesignSignalMasks[DesignSignalType] else NewDesignMask:=OldDesignMask and not DesignSignalMasks[DesignSignalType]; if OldDesignMask<>NewDesignMask then SetDesignSignalMask(PGtkWidget(AnObject),NewDesignMask); end; end; procedure ConnectSignal(const AnObject:gtk_Object; const ASignal: PChar; const ACallBackProc: Pointer; LCLComponent: TComponent; const ReqSignalMask: TGdkEventMask); begin ConnectSignal(AnObject,ASignal,ACallBackProc,LCLComponent,ReqSignalMask, [csfConnectRealize,csfUpdateSignalMask]); end; procedure ConnectSignalAfter(const AnObject:gtk_Object; const ASignal: PChar; const ACallBackProc: Pointer; LCLComponent: TComponent; const ReqSignalMask: TGdkEventMask); begin ConnectSignal(AnObject,ASignal,ACallBackProc,LCLComponent,ReqSignalMask, [csfConnectRealize,csfUpdateSignalMask,csfAfter]); end; procedure ConnectSignal(const AnObject:gtk_Object; const ASignal: PChar; const ACallBackProc: Pointer; LCLComponent: TComponent); begin ConnectSignal(AnObject,ASignal,ACallBackProc,LCLComponent,0); end; procedure ConnectSignalAfter(const AnObject:gtk_Object; const ASignal: PChar; const ACallBackProc: Pointer; LCLComponent: TComponent); begin ConnectSignalAfter(AnObject,ASignal,ACallBackProc,LCLComponent,0); end; {------------------------------------------------------------------------------ procedure: ConnectInternalWidgetsSignals Params: AWidget: PGtkWidget; AWinControl: TWinControl Returns: Nothing Connects hidden child widgets signals. Many gtk widgets create internally child widgets (e.g. scrollbars). In Design mode these widgets should not auto react themselves, but instead send messages to the lcl. Therefore these widgets are connected also to our signal handlers. This procedure is called by the realize-after handler of all LCL widgets and each time the design mode of a LCL control changes. ------------------------------------------------------------------------------} procedure ConnectInternalWidgetsSignals(AWidget: PGtkWidget; AWinControl: TWinControl); function WidgetIsInternal(TheWidget: PGtkWidget): boolean; begin Result:=(TheWidget<>nil) and (PGtkWidget(AWinControl.Handle)<>TheWidget) and (GetMainWidget(TheWidget)=nil); end; procedure ConnectSignals(TheWidget: PGtkWidget); forward; procedure ConnectChilds(TheWidget: PGtkWidget); var ContainerWidget: PGtkContainer; ScrolledWindow: PGtkScrolledWindow; BinWidget: PGtkBin; ChildEntry: PGSList; ChildWidget: PGtkWidget; begin if GtkWidgetIsA(TheWidget,GTK_CONTAINER_TYPE) then begin // this is a container widget -> connect all childs ContainerWidget:=PGtkContainer(TheWidget); ChildEntry:=ContainerWidget^.resize_widgets; while ChildEntry<>nil do begin ChildWidget:=PGtkWidget(ChildEntry^.Data); ConnectSignals(ChildWidget); ChildEntry:=ChildEntry^.Next; end; end; if GtkWidgetIsA(TheWidget,GTK_BIN_TYPE) then begin BinWidget:=PGtkBin(TheWidget); ConnectSignals(BinWidget^.child); end; if GtkWidgetIsA(TheWidget,GTK_SCROLLED_WINDOW_TYPE) then begin ScrolledWindow:=PGtkScrolledWindow(TheWidget); ConnectSignals(ScrolledWindow^.hscrollbar); ConnectSignals(ScrolledWindow^.vscrollbar); end; if GtkWidgetIsA(TheWidget,GTK_COMBO_TYPE) then begin ConnectSignals(PGtkCombo(TheWidget)^.entry); ConnectSignals(PGtkCombo(TheWidget)^.button); end; end; procedure ConnectSignals(TheWidget: PGtkWidget); var LCLObject, HiddenLCLObject: TObject; DesignSignalType: TDesignSignalType; DesignFlags: TConnectSignalFlags; begin if TheWidget=nil then exit; // check if TheWidget belongs to another LCL object LCLObject:=GetLCLObject(TheWidget); HiddenLCLObject:=GetHiddenLCLObject(TheWidget); if (LCLObject<>nil) and (LCLObject<>AWinControl) then exit; if (HiddenLCLObject<>nil) and (HiddenLCLObject<>AWinControl) then exit; // connect signals needed for design mode: for DesignSignalType:=Low(TDesignSignalType) to High(TDesignSignalType) do begin if DesignSignalType=dstUnknown then continue; DesignFlags:=[csfDesignOnly]; if DesignSignalAfter[DesignSignalType] then Include(DesignFlags,csfAfter); ConnectSignal(PGtkObject(TheWidget),DesignSignalNames[DesignSignalType], DesignSignalFuncs[DesignSignalType],AWinControl,0, DesignFlags); end; if WidgetIsInternal(TheWidget) then // mark widget as 'hidden' connected SetHiddenLCLObject(TheWidget,AWinControl); // connect recursively ... ConnectChilds(TheWidget); end; begin if (AWinControl=nil) or (AWidget=nil) or (not (csDesigning in AWinControl.ComponentState)) then exit; ConnectSignals(AWidget); end; // ---------------------------------------------------------------------- // The Accelgroup and AccelKey is needed by menus // ---------------------------------------------------------------------- function GetAccelGroup(const Widget: PGtkWidget; CreateIfNotExists: boolean): PGTKAccelGroup; begin Result := PGTKAccelGroup(gtk_object_get_data(PGtkObject(Widget),'AccelGroup')); if (Result=nil) and CreateIfNotExists then begin {$IFDEF VerboseAccelerator} writeln('GetAccelGroup CREATING Widget=',HexStr(Cardinal(Widget),8),' CreateIfNotExists=',CreateIfNotExists); {$ENDIF} Result:=gtk_accel_group_new; SetAccelGroup(Widget,Result); if GtkWidgetIsA(Widget,GTK_WINDOW_TYPE) then ShareWindowAccelGroups(Widget); end; end; procedure SetAccelGroup(const Widget: PGtkWidget; const AnAccelGroup: PGTKAccelGroup); begin if (Widget = nil) then exit; gtk_object_set_data(PGtkObject(Widget), 'AccelGroup', AnAccelGroup); if AnAccelGroup<>nil then begin // attach group to widget {$IFDEF VerboseAccelerator} writeln('SetAccelGroup AnAccelGroup=',HexStr(Cardinal(AnAccelGroup),8),' IsMenu=',GtkWidgetIsA(Widget,GTK_MENU_TYPE)); {$ENDIF} if GtkWidgetIsA(Widget,GTK_MENU_TYPE) then gtk_menu_set_accel_group(PGtkMenu(Widget), AnAccelGroup) else begin gtk_accel_group_attach(AnAccelGroup, PGtkObject(Widget)); end; end; end; procedure FreeAccelGroup(const Widget: PGtkWidget); var AccelGroup: PGTKAccelGroup; begin AccelGroup:=GetAccelGroup(Widget,false); if AccelGroup<>nil then begin {$IFDEF VerboseAccelerator} writeln('FreeAccelGroup AccelGroup=',HexStr(Cardinal(AccelGroup),8)); {$ENDIF} gtk_accel_group_unref(AccelGroup); SetAccelGroup(Widget,nil); end; end; procedure ShareWindowAccelGroups(AWindow: PGtkWidget); procedure AttachUnique(TheWindow: PGtkWidget; TheAccelGroup: PGTKAccelGroup); begin if (TheAccelGroup=nil) or ((TheAccelGroup^.attach_objects<>nil) and (g_slist_find(TheAccelGroup^.attach_objects, TheWindow)<>nil)) then exit; gtk_accel_group_attach(TheAccelGroup, PGtkObject(TheWindow)); end; var TheForm, CurForm: TCustomForm; i: integer; TheAccelGroup, CurAccelGroup: PGTKAccelGroup; CurWindow: PGtkWidget; begin TheForm:=TCustomForm(GetLCLObject(AWindow)); // check if visible TCustomForm (not frame) if (TheForm=nil) or (not (TheForm is TCustomForm)) or (not TheForm.Visible) or (TheForm.Parent<>nil) or (csDesigning in TheForm.ComponentState) then exit; // check if modal form if fsModal in TheForm.FormState then begin // a modal form does not share accelerators exit; end; // check if there is an accelerator group TheAccelGroup:=GetAccelGroup(AWindow,false); // this is a normal form // -> share accelerators with all other visible normal forms for i:=0 to Screen.FormCount-1 do begin CurForm:=Screen.Forms[i]; if (CurForm=TheForm) or (not CurForm.HandleAllocated) or (not CurForm.Visible) or (fsModal in CurForm.FormState) or (CurForm.Parent<>nil) or (csDesigning in CurForm.ComponentState) then continue; CurWindow:=PGtkWidget(CurForm.Handle); CurAccelGroup:=GetAccelGroup(CurWindow,false); {$IFDEF VerboseAccelerator} writeln('ShareWindowAccelGroups ',TheForm.Name,':',TheForm.ClassName, ' <-> ',CurForm.Name,':',CurForm.ClassName); {$ENDIF} // cross connect AttachUnique(CurWindow,TheAccelGroup); AttachUnique(AWindow,CurAccelGroup); end; end; procedure UnshareWindowAccelGroups(AWindow: PGtkWidget); procedure Detach(TheWindow: PGtkWidget; TheAccelGroup: PGTKAccelGroup); begin if (TheAccelGroup=nil) or (TheAccelGroup^.attach_objects=nil) or (g_slist_find(TheAccelGroup^.attach_objects, TheWindow)=nil) then exit; gtk_accel_group_detach(TheAccelGroup, PGtkObject(TheWindow)); end; var TheForm, CurForm: TCustomForm; i: integer; TheAccelGroup, CurAccelGroup: PGTKAccelGroup; CurWindow: PGtkWidget; begin TheForm:=TCustomForm(GetLCLObject(AWindow)); // check if TCustomForm if (TheForm=nil) or (not (TheForm is TCustomForm)) then exit; TheAccelGroup:=GetAccelGroup(AWindow,false); // -> unshare accelerators with all other forms for i:=0 to Screen.FormCount-1 do begin CurForm:=Screen.Forms[i]; if (CurForm=TheForm) or (not CurForm.HandleAllocated) then continue; CurWindow:=PGtkWidget(CurForm.Handle); CurAccelGroup:=GetAccelGroup(CurWindow,false); {$IFDEF VerboseAccelerator} writeln('UnshareWindowAccelGroups ',TheForm.Name,':',TheForm.ClassName, ' <-> ',CurForm.Name,':',CurForm.ClassName); {$ENDIF} // unlink Detach(CurWindow,TheAccelGroup); Detach(AWindow,CurAccelGroup); end; end; function GetAccelGroupForComponent(Component: TComponent; CreateIfNotExists: boolean): PGTKAccelGroup; var Control: TControl; MenuItem: TMenuItem; Form: TCustomForm; Menu: TMenu; begin Result:=nil; if Component=nil then exit; if Component is TMenuItem then begin MenuItem:=TMenuItem(Component); Menu:=MenuItem.GetParentMenu; if (Menu=nil) or (Menu.Parent=nil) then exit; {$IFDEF VerboseAccelerator} writeln('GetAccelGroupForComponent A ',Component.Name,':',Component.ClassName); {$ENDIF} Result:=GetAccelGroupForComponent(Menu.Parent,CreateIfNotExists); end else if Component is TControl then begin Control:=TControl(Component); while Control.Parent<>nil do Control:=Control.Parent; if Control is TCustomForm then begin Form:=TCustomForm(Control); if Form.HandleAllocated then begin Result:=GetAccelGroup(PGtkWidget(Form.Handle),CreateIfNotExists); {$IFDEF VerboseAccelerator} writeln('GetAccelGroupForComponent C ',Component.Name,':',Component.ClassName); {$ENDIF} end; end; end; {$IFDEF VerboseAccelerator} writeln('GetAccelGroupForComponent END ',Component.Name,':',Component.ClassName,' Result=',HexStr(Cardinal(Result),8)); {$ENDIF} end; function GetAccelKey(Widget: PGtkWidget): PAcceleratorKey; begin Result := PAcceleratorKey(gtk_object_get_data(PGtkObject(Widget),'AccelKey')); end; function SetAccelKey(const Widget: PGtkWidget; Key: guint; Mods: TGdkModifierType; const Signal: string): PAcceleratorKey; begin if (Widget = nil) then exit; Result:=GetAccelKey(Widget); if Result=nil then begin if Key<>GDK_VOIDSYMBOL then begin New(Result); FillChar(Result^,SizeOf(Result),0); end; end else begin if Key=GDK_VOIDSYMBOL then begin Dispose(Result); Result:=nil; end; end; if (Result<>nil) then begin Result^.Key:=Key; Result^.Mods:=Mods; Result^.Signal:=Signal; Result^.Realized:=false; end; {$IFDEF VerboseAccelerator} writeln('SetAccelKey Widget=',HexStr(Cardinal(Widget),8), ' Key=',Key,' Mods=',HexStr(Cardinal(Mods),8), ' Signal="',Signal,'" Result=',HexStr(Cardinal(Result),8)); {$ENDIF} gtk_object_set_data(PGtkObject(Widget), 'AccelKey', Result); end; procedure ClearAccelKey(Widget: PGtkWidget); begin SetAccelKey(Widget,GDK_VOIDSYMBOL,0,''); end; procedure RealizeAccelerator(Component: TComponent; Widget : PGtkWidget); var AccelKey: PAcceleratorKey; AccelGroup: PGTKAccelGroup; begin if (Component=nil) or (Widget=nil) then RaiseException('RealizeAccelerate: invalid input'); // Set the accelerator AccelKey:=GetAccelKey(Widget); if (AccelKey=nil) or (AccelKey^.Realized) then exit; if AccelKey^.Key<>GDK_VOIDSYMBOL then begin AccelGroup:=GetAccelGroupForComponent(Component,true); if AccelGroup<>nil then begin {$IFDEF VerboseAccelerator} writeln('RealizeAccelerator Add Accelerator ', Component.Name,':',Component.ClassName, ' Widget=',HexStr(Cardinal(Widget),8), ' Signal=',AccelKey^.Signal, ' Key=',AccelKey^.Key,' Mods=',AccelKey^.Mods, ''); {$ENDIF} gtk_widget_add_accelerator(Widget, PChar(AccelKey^.Signal), AccelGroup, AccelKey^.Key, AccelKey^.Mods, GTK_ACCEL_VISIBLE); AccelKey^.Realized:=true; end else begin AccelKey^.Realized:=false; end; end else begin AccelKey^.Realized:=true; end; end; procedure UnrealizeAccelerator(Widget : PGtkWidget); var AccelKey: PAcceleratorKey; begin if (Widget=nil) then RaiseException('UnrealizeAccelerate: invalid input'); AccelKey:=GetAccelKey(Widget); if (AccelKey=nil) or (not AccelKey^.Realized) then exit; if AccelKey^.Signal<>'' then begin {$IFDEF VerboseAccelerator} writeln('UnrealizeAccelerator ', ' Widget=',HexStr(Cardinal(Widget),8), ' Signal=',AccelKey^.Signal, ' Key=',AccelKey^.Key,' Mods=',AccelKey^.Mods, ''); {$ENDIF} gtk_widget_remove_accelerators(Widget, PChar(AccelKey^.Signal), false); end; AccelKey^.Realized:=false; end; procedure RegroupAccelerator(Widget: PGtkWidget); begin UnrealizeAccelerator(Widget); RealizeAccelerator(TComponent(GetLCLObject(Widget)),Widget); end; procedure Accelerate(Component: TComponent; const Widget : PGtkWidget; const Key: guint; Mods: TGdkModifierType; const Signal : string); var OldAccelKey: PAcceleratorKey; begin if (Component=nil) or (Widget=nil) or (Signal='') then RaiseException('Accelerate: invalid input'); {$IFDEF VerboseAccelerator} writeln('Accelerate ',Component.Name,':',Component.ClassName,' Key=',Key,' Mods=',HexStr(Cardinal(Mods),8),' Signal=',Signal); {$ENDIF} // delete old accelerator key OldAccelKey:=GetAccelKey(Widget); if (OldAccelKey <> nil) then begin if (OldAccelKey^.Key=Key) and (OldAccelKey^.Mods=Mods) and (OldAccelKey^.Signal=Signal) then begin // no change exit; end; UnrealizeAccelerator(Widget); end; // Set the accelerator SetAccelKey(Widget,Key,Mods,Signal); if (Key<>GDK_VOIDSYMBOL) and (not (csDesigning in Component.ComponentState)) then RealizeAccelerator(Component,Widget); end; procedure Accelerate(Component: TComponent; const Widget : PGtkWidget; const Msg: TLMShortCut; const Signal : string); var GDKModifier: TGdkModifierType; GDKKey: guint; begin { Map the shift states } GDKModifier:= 0; if ssShift in Msg.NewModifier then GDKModifier:= GDK_SHIFT_MASK; if ssAlt in Msg.NewModifier then GDKModifier:= GDKModifier + GDK_MOD1_MASK; if ssCtrl in Msg.NewModifier then GDKModifier:= GDKModifier + GDK_CONTROL_MASK; GDKKey:= VK2GDK(Msg.NewKey); Accelerate(Component,Widget,GDKKey,GDKModifier,Signal); end; {------------------------------------------------------------------------------ procedure GetGdkPixmapFromGraphic(LCLGraphic: TGraphic; var IconImg, IconMask: PGdkPixmap; var Width, Height: integer); Extracts some information from the Handle of a TGraphic ------------------------------------------------------------------------------} procedure GetGdkPixmapFromGraphic(LCLGraphic: TGraphic; var IconImg, IconMask: PGdkPixmap; var Width, Height: integer); var GDIObject: PGdiObject; begin IconImg:=nil; IconMask:=nil; Width:=0; Height:=0; if (LCLGraphic=nil) then exit; if LCLGraphic is TBitmap then GDIObject:=PgdiObject(TBitmap(LCLGraphic).Handle) else GDIObject:=nil; if GDIObject<>nil then begin IconImg:=GDIObject^.GDIBitmapObject; IconMask:=GDIObject^.GDIBitmapMaskObject; if IconImg<>nil then gdk_window_get_size (IconImg, @Width, @Height); end; end; {------------------------------------------------------------------------------ procedure GetGdkPixmapFromGraphic(LCLGraphic: TGraphic; var IconImg, IconMask: PGdkPixmap; var Width, Height: integer); Extracts some information from the Handle of the icon of a TMenuItem ------------------------------------------------------------------------------} procedure GetGdkPixmapFromMenuItem(LCLMenuItem: TMenuItem; var IconImg, IconMask: PGdkPixmap; var Width, Height: integer); begin IconImg:=nil; IconMask:=nil; Width:=0; Height:=0; if LCLMenuItem=nil then exit; if LCLMenuItem.Graphic<>nil then GetGdkPixmapFromGraphic(LCLMenuItem.Graphic,IconImg,IconMask,Width,Height); end; {------------------------------------------------------------------------------ function MENU_ITEM_CLASS(widget: PGtkWidget): PGtkMenuItemClass; Returns the gtk klass of a menuitem widget. ------------------------------------------------------------------------------} function MENU_ITEM_CLASS(widget: PGtkWidget): PGtkMenuItemClass; begin Result:=GTK_MENU_ITEM_CLASS(PGtkObject(widget)^.klass); end; {------------------------------------------------------------------------------ function CHECK_MENU_ITEM_CLASS(widget: PGtkWidget): PGtkCheckMenuItemClass; Returns the gtk klass of a checkmenuitem widget. ------------------------------------------------------------------------------} function CHECK_MENU_ITEM_CLASS(widget: PGtkWidget): PGtkCheckMenuItemClass; begin Result:=GTK_CHECK_MENU_ITEM_CLASS(PGtkObject(widget)^.klass); end; {------------------------------------------------------------------------------ function GetRadioMenuItemGroup(LCLMenuItem: TMenuItem): PGSList; Returns the radio group list with the GroupIndex of the MenuItem ------------------------------------------------------------------------------} function GetRadioMenuItemGroup(LCLMenuItem: TMenuItem): PGSList; var ParentMenuItem: TMenuItem; i: integer; begin Result:=nil; if (LCLMenuItem=nil) or (LCLMenuItem.GroupIndex=0) then exit; ParentMenuItem:=LCLMenuItem.Parent; if ParentMenuItem=nil then exit; for i:=0 to ParentMenuItem.Count-1 do begin if ParentMenuItem[i].RadioItem and (ParentMenuItem[i].GroupIndex=LCLMenuItem.GroupIndex) and (ParentMenuItem[i]<>LCLMenuItem) and ParentMenuItem[i].HandleAllocated and GtkWidgetIsA(Pointer(ParentMenuItem[i].Handle), GTK_RADIO_MENU_ITEM_TYPE) then begin Result:=gtk_radio_menu_item_group( GTK_RADIO_MENU_ITEM(ParentMenuItem[i].Handle)); exit; end; end; end; {------------------------------------------------------------------------------ function GetRadioMenuItemGroup(MenuItem: PGtkRadioMenuItem): PGSList; Returns the radio group list with the GroupIndex of the MenuItem ------------------------------------------------------------------------------} function GetRadioMenuItemGroup(MenuItem: PGtkRadioMenuItem): PGSList; begin if MenuItem=nil then Result:=nil else Result:=GetRadioMenuItemGroup(TMenuItem(GetLCLObject(MenuItem))); end; {------------------------------------------------------------------------------ procedure UpdateRadioGroupChecks(RadioGroup: PGSList); Set 'checked' for all menuitems in the group ------------------------------------------------------------------------------} procedure UpdateRadioGroupChecks(RadioGroup: PGSList); var CurListItem: PGSList; MenuItem: PGtkMenuItem; LCLMenuItem: TMenuItem; begin if RadioGroup=nil then exit; CurListItem:=RadioGroup; // set active radiomenuitem while CurListItem<>nil do begin MenuItem:=PGtkMenuItem(CurListItem^.Data); if MenuItem<>nil then begin LCLMenuItem:=TMenuItem(GetLCLObject(MenuItem)); if (LCLMenuItem<>nil) and LCLMenuItem.Checked then begin gtk_check_menu_item_set_active(PGtkCheckMenuItem(MenuItem), LCLMenuItem.Checked); end; end; CurListItem:=CurListItem^.Next; end; CurListItem:=RadioGroup; // deactivate the other radiomenuitems while CurListItem<>nil do begin MenuItem:=PGtkMenuItem(CurListItem^.Data); if MenuItem<>nil then begin LCLMenuItem:=TMenuItem(GetLCLObject(MenuItem)); if (LCLMenuItem<>nil) then begin gtk_check_menu_item_set_active(PGtkCheckMenuItem(MenuItem), LCLMenuItem.Checked); end; end; CurListItem:=CurListItem^.Next; end; end; {------------------------------------------------------------------------------ procedure DrawMenuItemIcon(MenuItem: PGtkCheckMenuItem; area: PGdkRectangle); cdecl; Handler for drawing the icon of a menuitem. ------------------------------------------------------------------------------} procedure DrawMenuItemIcon(MenuItem: PGtkCheckMenuItem; Area: PGdkRectangle); cdecl; var Widget: PGtkWidget; Container: PgtkContainer; ALeft, ATop, BorderWidth: gint; LCLMenuItem: TMenuItem; IconImg, IconMask: PGdkPixmap; IconWidth, IconHeight: integer; AWindow: PGdkWindow; begin if (MenuItem=nil) then exit; if not (GTK_WIDGET_DRAWABLE (PGtkWidget(MenuItem))) then exit; // get icon LCLMenuItem:=TMenuItem(GetLCLObject(MenuItem)); GetGdkPixmapFromMenuItem(LCLMenuItem,IconImg,IconMask,IconWidth,IconHeight); if IconImg=nil then begin // call default draw function OldCheckMenuItemDrawProc(MenuItem,Area); exit; end; // calculate left and top Widget := PGtkWidget (MenuItem); AWindow:=GetControlWindow(Widget); if AWindow=nil then exit; Container := GTK_CONTAINER (MenuItem); BorderWidth := Container^.flag0 and bm_TGtkContainer_border_width; ALeft := (BorderWidth + PGtkStyle(Widget^.theStyle)^.klass^.xthickness + 2) +((PGtkMenuItem(MenuItem)^.toggle_size-IconWidth) div 2); ATop := (Widget^.Allocation.Height - IconHeight) div 2; // draw icon gdk_gc_set_clip_mask(pGtkStyle(Widget^.theStyle)^.Black_gc, IconMask); gdk_gc_set_clip_origin(pGtkStyle(Widget^.theStyle)^.Black_gc,ALeft,ATop); gdk_draw_pixmap(AWindow,pGtkStyle(Widget^.theStyle)^.Black_gc, IconImg,0,0,ALeft,ATop,-1,-1); gdk_gc_set_clip_mask(pGtkStyle(Widget^.theStyle)^.Black_gc, nil); end; {------------------------------------------------------------------------------ procedure MenuSizeRequest(widget:PGtkWidget; requisition:PGtkRequisition); cdecl; SizeAllocate Handler for check menuitem widgets. ------------------------------------------------------------------------------} procedure MenuSizeRequest(widget:PGtkWidget; requisition:PGtkRequisition); cdecl; var CurToggleSize, MaxToggleSize: integer; MenuShell: PGtkMenuShell; ListItem: PGList; MenuItem, CheckMenuItem: PGtkMenuItem; LCLMenuItem: TMenuItem; IconImg, IconMask: PGdkPixmap; Width, Height: integer; begin MaxToggleSize:=0; MenuShell:=GTK_MENU_SHELL(widget); ListItem:=MenuShell^.Children; CheckMenuItem:=nil; while ListItem<>nil do begin MenuItem:=PGtkMenuItem(ListItem^.Data); if GTK_IS_CHECK_MENU_ITEM(PGtkWidget(MenuItem)) then begin CheckMenuItem:=MenuItem; CurToggleSize:=OldCheckMenuItemToggleSize; LCLMenuItem:=TMenuItem(GetLCLObject(MenuItem)); if LCLMenuItem<>nil then begin GetGdkPixmapFromMenuItem(LCLMenuItem,IconImg,IconMask,Width,Height); if IconImg<>nil then begin if CurToggleSizenil then MENU_ITEM_CLASS(PGtkWidget(CheckMenuItem))^.toggle_size:=MaxToggleSize; OldMenuSizeRequestProc(Widget,requisition); end; {------------------------------------------------------------------------------ procedure SetMenuItemLabelText(LCLMenuItem: TMenuItem; MenuItemWidget: PGtkWidget); Sets the caption of a menuitem ------------------------------------------------------------------------------} procedure SetMenuItemLabelText(LCLMenuItem: TMenuItem; MenuItemWidget: PGtkWidget); var ShortCutPos: integer; s: string; LabelWidget: PGtkLabel; begin if (MenuItemWidget=nil) or (LCLMenuItem=nil) then exit; LabelWidget:=gtk_object_get_data(PGtkObject(MenuItemWidget), 'LCLLabel'); if LabelWidget=nil then exit; //Check for a shortcut key s:=LCLMenuItem.Caption; ShortCutPos := pos('&', s); if ShortCutPos <> 0 then begin if (LCLMenuItem.Parent<>nil) and (LCLMenuItem.Parent.HandleAllocated) and GtkWidgetIsA(PGtkWidget(LCLMenuItem.Parent.Handle),GTK_MENU_BAR_TYPE) then begin // this is a menu item in the main bar of a form // -> accelerator should be Alt+Key s[ShortCutPos] := '_'; Accelerate(LCLMenuItem,MenuItemWidget, gtk_label_parse_uline(LabelWidget,PChar(s)), GDK_MOD1_MASK,'activate_item'); end else begin // Because gnome changes menuitem shortcuts via keyboard, we can't // set the accelerator. // It would be cool, to know if a window manager with the gnome feature // is running, but there is probably no reliable code to do that, so we // simply delete all ampersands and don't set the letter shortcut. DeleteAmpersands(s); gtk_label_set_text(LabelWidget,PChar(s)); {Accelerate(LCLMenuItem,MenuItemWidget, gtk_label_parse_uline(LabelWidget,PChar(s)),0,'activate_item');} end; end else begin gtk_label_set_text(LabelWidget,PChar(s)); end; end; {------------------------------------------------------------------------------ procedure CreateInnerMenuItem(LCLMenuItem: TMenuItem; MenuItemWidget: PGtkWidget); Creates the inner widgets of a menuitem widget. ------------------------------------------------------------------------------} procedure CreateInnerMenuItem(LCLMenuItem: TMenuItem; MenuItemWidget: PGtkWidget); var HBoxWidget: PGtkWidget; LabelWidget: PGtkAccelLabel; procedure CreateIcon; var IconImg, IconMask: PGdkPixmap; IconWidth, IconHeight: integer; MinHeightWidget: PGtkWidget; begin // the icon will be painted instead of the toggle // of a normal gtkcheckmenuitem // get the icon GetGdkPixmapFromMenuItem(LCLMenuItem,IconImg,IconMask,IconWidth,IconHeight); if IconImg<>nil then begin // set the toggle width GTK_MENU_ITEM(MenuItemWidget)^.toggle_size:=IconWidth; GTK_MENU_ITEM(MenuItemWidget)^.flag0:= PGtkMenuItem(MenuItemWidget)^.flag0 or bm_show_toggle_indicator; // set our own draw handler if OldCheckMenuItemDrawProc=nil then OldCheckMenuItemDrawProc:= CHECK_MENU_ITEM_CLASS(MenuItemWidget)^.draw_indicator; CHECK_MENU_ITEM_CLASS(MenuItemWidget)^.draw_indicator:=@DrawMenuItemIcon; // add a dummy widget for the icon height MinHeightWidget:=gtk_label_new(''); gtk_widget_show(MinHeightWidget); gtk_widget_set_usize(MinHeightWidget,1,IconHeight); gtk_box_pack_start(GTK_BOX(HBoxWidget),MinHeightWidget,false,false,0); end else MinHeightWidget:=nil; gtk_object_set_data(PGtkObject(MenuItemWidget), 'LCLMinHeight',MinHeightWidget); end; procedure CreateLabel; begin // create a label for the Caption LabelWidget:=PGtkAccelLabel(gtk_accel_label_new('')); gtk_misc_set_alignment(GTK_MISC (LabelWidget), 0.0, 0.5); gtk_object_set_data(PGtkObject(MenuItemWidget), 'LCLLabel', LabelWidget); gtk_container_add(GTK_CONTAINER(HBoxWidget),PgtkWidget(LabelWidget)); SetMenuItemLabelText(LCLMenuItem,MenuItemWidget); gtk_accel_label_set_accel_widget(GTK_ACCEL_LABEL(LabelWidget),MenuItemWidget); gtk_widget_show(PGtkWidget(LabelWidget)); end; begin HBoxWidget:=gtk_object_get_data(PGtkObject(MenuItemWidget), 'LCLHBox'); if HBoxWidget=nil then begin // create inner widgets if LCLMenuItem.Caption='-' then begin // a separator is an empty gtkmenuitem exit; end; HBoxWidget:=gtk_hbox_new(false,0); gtk_object_set_data(PGtkObject(MenuItemWidget), 'LCLHBox', HBoxWidget); CreateIcon; CreateLabel; gtk_container_add(GTK_CONTAINER(MenuItemWidget),HBoxWidget); gtk_widget_show(HBoxWidget); end else begin // there are already inner widgets if LCLMenuItem.Caption='-' then begin // a separator is an empty gtkmenuitem -> delete the inner widgets DestroyWidget(HBoxWidget); gtk_object_set_data(PGtkObject(MenuItemWidget), 'LCLHBox', nil); end else begin // just update the content SetMenuItemLabelText(LCLMenuItem,MenuItemWidget); end; end; end; {------------------------------------------------------------------------------ function CreateMenuItem(LCLMenuItem: TMenuItem): Pointer; Creates a new menuitem widget. ------------------------------------------------------------------------------} function CreateMenuItem(LCLMenuItem: TMenuItem): Pointer; var MenuItemWidget: PGtkWidget; begin // create the menuitem widget (normal, check or radio) if LCLMenuItem.Caption='-' then // create separator MenuItemWidget:=gtk_menu_item_new else if LCLMenuItem.RadioItem and not LCLMenuItem.HasIcon then begin MenuItemWidget:=gtk_radio_menu_item_new(nil); end else if LCLMenuItem.IsCheckItem or LCLMenuItem.HasIcon then begin MenuItemWidget:=gtk_check_menu_item_new; end else MenuItemWidget:=gtk_menu_item_new; if GtkWidgetIsA(MenuItemWidget,GTK_CHECK_MENU_ITEM_TYPE) then begin // set 'ShowAlwaysCheckable' gtk_check_menu_item_set_show_toggle(PGtkCheckMenuItem(MenuItemWidget), LCLMenuItem.ShowAlwaysCheckable); // set 'Checked' gtk_check_menu_item_set_active(PGtkCheckMenuItem(MenuItemWidget), LCLMenuItem.Checked); if (OldCheckMenuItemToggleSize=0) then OldCheckMenuItemToggleSize:=MENU_ITEM_CLASS(MenuItemWidget)^.toggle_size; end; // set attributes (enabled and rightjustify) gtk_widget_set_sensitive(MenuItemWidget, LCLMenuItem.Enabled); if LCLMenuItem.RightJustify then gtk_menu_item_right_justify(PGtkMenuItem(MenuItemWidget)); // create the hbox containing the label and the control CreateInnerMenuItem(LCLMenuItem,MenuItemWidget); gtk_widget_show(MenuItemWidget); Result:=MenuItemWidget; end; {------------------------------------------------------------------------------ TgtkObject SetSizeNotification Params: Widget: PGtkWidget A widget that is the handle of a lcl control. When the gtk sends a size signal, it is not send directly to the LCL. All gtk size/move messages are collected and only the last one for each widget is sent to the LCL. This is neccessary, because the gtk sends size messages several times and it replays resizes. Since the LCL reacts to every size notification and resizes child controls, this results in a perpetuum mobile. ------------------------------------------------------------------------------} procedure SaveSizeNotification(Widget: PGtkWidget); {$IFDEF VerboseSizeMsg} var LCLControl: TWinControl; {$ENDIF} begin {$IFDEF VerboseSizeMsg} write('SaveSizeNotification Widget=',HexStr(Cardinal(Widget),8)); LCLControl:=TWinControl(GetLCLObject(Widget)); if (LCLControl<>nil) then begin if LCLControl is TWinControl then writeln(' ',LCLControl.Name,':',LCLControl.ClassName) else writeln(' ERROR: ',LCLControl.ClassName); end else begin writeln(' ERROR: LCLControl=nil'); end; {$ENDIF} if not FWidgetsResized.Contains(Widget) then FWidgetsResized.Add(Widget); end; {------------------------------------------------------------------------------ TgtkObject SaveClientSizeNotification Params: FixWidget: PGtkWidget A widget that is the fixed widget of a lcl control. When the gtk sends a size signal, it is not send directly to the LCL. All gtk size/move messages are collected and only the last one for each widget is sent to the LCL. This is neccessary, because the gtk sends size messages several times and it replays resizes. Since the LCL reacts to every size notification and resizes child controls, this results in a perpetuum mobile. ------------------------------------------------------------------------------} procedure SaveClientSizeNotification(FixWidget: PGtkWidget); {$IFDEF VerboseSizeMsg} var LCLControl: TWinControl; MainWidget: PGtkWidget; {$ENDIF} begin {$IFDEF VerboseSizeMsg} MainWidget:=GetMainWidget(FixWidget); write('SaveClientSizeNotification', ' FixWidget=',HexStr(Cardinal(FixWidget),8), ' MainWIdget=',HexStr(Cardinal(MainWidget),8)); LCLControl:=TWinControl(GetLCLObject(MainWidget)); if (LCLControl<>nil) then begin if LCLControl is TWinControl then writeln(' ',LCLControl.Name,':',LCLControl.ClassName) else writeln(' ERROR: ',LCLControl.ClassName); end else begin writeln(' ERROR: LCLControl=nil'); end; {$ENDIF} if not FFixWidgetsResized.Contains(FixWidget) then FFixWidgetsResized.Add(FixWidget); end; {------------------------------------------------------------------------------- CreateTopologicalSortedWidgets Params: HashArray: TDynHashArray of PGtkWidget Creates a topologically sorted TList of PGtkWidget. -------------------------------------------------------------------------------} function CreateTopologicalSortedWidgets(HashArray: TDynHashArray): TList; type PTopologicalEntry = ^TTopologicalEntry; TTopologicalEntry = record Widget: PGtkWidget; ParentLevel: integer; end; function GetParentLevel(AControl: TControl): integer; // nil has lvl -1 // a control without parent has lvl 0 begin Result:=-1; while AControl<>nil do begin inc(Result); AControl:=AControl.Parent; end; end; var TopologicalList: PTopologicalEntry; HashItem: PDynHashArrayItem; i, Lvl, MaxLevel: integer; LCLControl: TControl; LevelCounts: PInteger; begin //writeln(' KKK0'); Result:=TList.Create; if HashArray.Count=0 then exit; // put all widgets into an array and calculate their parent levels GetMem(TopologicalList,SizeOf(TTopologicalEntry)*HashArray.Count); HashItem:=HashArray.FirstHashItem; i:=0; MaxLevel:=0; //writeln(' KKK1 HashArray.Count=',HashArray.Count); while HashItem<>nil do begin TopologicalList[i].Widget:=HashItem^.Item; //writeln(' KKK21 i=',i,' Widget=',HexStr(Cardinal(TopologicalList[i].Widget),8)); LCLControl:=TControl(GetLCLObject(TopologicalList[i].Widget)); if (LCLControl=nil) or (not (LCLControl is TControl)) then RaiseException('CreateTopologicalSortedWidgets: ' +'Widget without LCL control'); Lvl:=GetParentLevel(LCLControl); TopologicalList[i].ParentLevel:=Lvl; if MaxLevel0) then begin //writeln('[TgtkObject.WaitForClipboardAnswer] B'); exit; end; DateTimeToSystemTime(Time,StartTime); //writeln('[TgtkObject.WaitForClipboardAnswer] C'); Application.ProcessMessages; //writeln('[TgtkObject.WaitForClipboardAnswer] D'); if (c^.Data.Selection<>0) then begin //writeln('[TgtkObject.WaitForClipboardAnswer] E Yeah, Response received'); exit; end; //writeln('[TgtkObject.WaitForClipboardAnswer] F'); // start a timer to make sure not waiting forever Timer := gtk_timeout_add(500, @WaitForClipbrdAnswerDummyTimer, nil); try repeat // just wait ... {$IFDEF DEBUG_CLIPBOARD} writeln('[TgtkObject.WaitForClipboardAnswer] G'); {$ENDIF} Application.HandleMessage; if (c^.Data.Selection<>0) then begin {$IFDEF DEBUG_CLIPBOARD} writeln('[TgtkObject.WaitForClipboardAnswer] E Yeah, Response received'); {$ENDIF} exit; end; DateTimeToSystemTime(Time,CurTime); until (CurTime.Second-StartTime.Second>1); finally {$IFDEF DEBUG_CLIPBOARD} writeln('[TgtkObject.WaitForClipboardAnswer] H'); {$ENDIF} // stop the timer gtk_timeout_remove(Timer); //writeln('[TgtkObject.WaitForClipboardAnswer] END'); end; Result:=false; end; {------------------------------------------------------------------------------ Function: RequestSelectionData Params: ClipboardWidget - widget with connected signals 'selection_get' and 'selection_clear_event' ClipboardType FormatID - the selection target format wanted Returns: the TGtkSelectionData record requests the format FormatID of clipboard of type ClipboardType and waits til clipboard/selection answer arrived (max 1 second) ! While waiting the messagequeue will be processed ! ------------------------------------------------------------------------------} function RequestSelectionData(ClipboardWidget: PGtkWidget; ClipboardType: TClipboardType; FormatID: cardinal): TGtkSelectionData; var TimeID: cardinal; i: integer; c: PClipboardEventData; begin {$IFDEF DEBUG_CLIPBOARD} writeln('[RequestSelectionData] FormatID=',FormatID); {$ENDIF} FillChar(Result,SizeOf(TGtkSelectionData),0); if (ClipboardWidget=nil) or (FormatID=0) or (ClipboardTypeAtoms[ClipboardType]=0) then exit; TimeID:=1000; repeat repeat inc(TimeID); if TimeID>1100 then exit; i:=ClipboardSelectionData.Count-1; while (i>=0) and (PClipboardEventData(ClipboardSelectionData[i])^.TimeID<>TimeID) do dec(i); until (i<0); New(c); c^.TimeID:=TimeID; FillChar(c^.Data,SizeOf(TGtkSelectionData),0); ClipboardSelectionData.Add(c); {$IFDEF DEBUG_CLIPBOARD} writeln('[RequestSelectionData] TimeID=',TimeID); {$ENDIF} if gtk_selection_convert(ClipboardWidget, ClipboardTypeAtoms[ClipboardType], FormatID, TimeID)<>0 then break; ClipboardSelectionData.Remove(c); Dispose(c); until false; try if not WaitForClipboardAnswer(c) then exit; Result:=c^.Data; finally ClipboardSelectionData.Remove(c); Dispose(c); end; end; {------------------------------------------------------------------------------ Function: FreeClipboardTargetEntries Params: ClipboardType Returns: - frees the memory of a ClipboardTargetEntries list ------------------------------------------------------------------------------} procedure FreeClipboardTargetEntries(ClipboardType: TClipboardType); var i: integer; begin if ClipboardTargetEntries[ClipboardType]<>nil then begin for i:=0 to ClipboardTargetEntryCnt[ClipboardType]-1 do StrDispose(ClipboardTargetEntries[ClipboardType][i].Target); FreeMem(ClipboardTargetEntries[ClipboardType]); end; end; Function CreateFormContents(var FormWidget : Pointer) : Pointer; var TempWidget, TempWidget2 : Pointer; begin // Create the VBox, we need that to place controls outside // the client area (like menu and the statusbar) Result := gtk_vbox_new(False, 0); If FormWidget = nil then FormWidget := Result; // Create the form client area TempWidget := gtk_scrolled_window_new(nil,nil); gtk_box_pack_end(Result, TempWidget, True, True, 0); gtk_widget_show(TempWidget); gtk_object_set_data(FormWidget,'scroll_area', TempWidget); TempWidget2 := gtk_layout_new(nil, nil); gtk_container_add(TempWidget, TempWidget2); gtk_widget_show(TempWidget2); SetFixedWidget(FormWidget, TempWidget2); SetMainWidget(FormWidget, TempWidget2); GTK_WIDGET_UNSET_FLAGS(PGtkScrolledWindow(TempWidget)^.hscrollbar, GTK_CAN_FOCUS); GTK_WIDGET_UNSET_FLAGS(PGtkScrolledWindow(TempWidget)^.vscrollbar, GTK_CAN_FOCUS); gtk_scrolled_window_set_policy(PGtkScrolledWindow(TempWidget), GTK_POLICY_NEVER, GTK_POLICY_NEVER); end; {------------------------------------------------------------------------------ Function: IndexOfStyle Params: WName Returns: Index of Style Returns the Index within the Styles property of WNAME ------------------------------------------------------------------------------} function IndexOfStyle(const WName : String): integer; begin if Styles<>nil then begin for Result:=0 to Styles.Count-1 do if AnsiCompareText(WName,Styles[Result])=0 then exit; end; Result:=-1; end; {------------------------------------------------------------------------------ Function: ReleaseStyle Params: WName Returns: nothing Tries to release a Style corresponding to the Widget Name passed, aka 'button', 'default', checkbox', etc. This should only be called on theme change or on application terminate. ------------------------------------------------------------------------------} Type PStyleObject = ^TStyleObject; TStyleObject = Record Style : PGTKStyle; Widget : PGTKWidget; end; Function NewStyleObject : PStyleObject; begin New(Result); Result^.Widget := nil; Result^.Style := nil; end; Procedure FreeStyleObject(var StyleObject : PStyleObject); begin If StyleObject <> nil then begin If StyleObject^.Widget <> nil then GTK_Widget_Destroy(StyleObject^.Widget); If StyleObject^.Style <> nil then If StyleObject^.Style^.Ref_Count > 0 then GTK_Style_Unref(StyleObject^.Style); Dispose(StyleObject); StyleObject := nil; end; end; Procedure ReleaseStyle(const WName : String); var l : Longint; s : PStyleObject; begin If Not Assigned(Styles) then exit; l := IndexOfStyle(WName); If l >= 0 then begin If Styles.Objects[l] <> nil then Try s := PStyleObject(Styles.Objects[l]); FreeStyleObject(S); Except Writeln('[ReleaseStyle] : Unable To Unreference Style'); end; Styles.Delete(l); end; end; {------------------------------------------------------------------------------ Function: GetStyle Params: none Returns: Returns a Corresponding Style Tries to get the Style corresponding to the Widget Name passed, aka 'button', 'default', checkbox', etc. for use within such routines as DrawFrameControl to attempt to supply theme dependent drawing. Styles are stored in a TStrings list which is only updated on theme change, to ensure fast efficient retrieval of Styles. ------------------------------------------------------------------------------} function GetStyle(const WName : String) : PGTKStyle; var Tp : Pointer; l : Longint; StyleObject : PStyleObject; begin Result := nil; If Not Assigned(Styles) then exit; l:=IndexOfStyle(WName); If l < 0 then begin StyleObject := NewStyleObject; If AnsiCompareText(WName,'button')=0 then StyleObject^.Widget := GTK_BUTTON_NEW else If AnsiCompareText(WName,'default')=0 then StyleObject^.Widget := GTK_WIDGET_NEW(GTK_WIDGET_TYPE,nil,[]) else If AnsiCompareText(WName,'window')=0 then StyleObject^.Widget := GTK_WINDOW_NEW(0) else If AnsiCompareText(WName,'checkbox')=0 then begin StyleObject^.Widget := GTK_CHECK_BUTTON_NEW; end else If AnsiCompareText(WName,'radiobutton')=0 then StyleObject^.Widget := GTK_RADIO_BUTTON_NEW(nil) else If AnsiCompareText(WName,'menu')=0 then StyleObject^.Widget := GTK_MENU_NEW else If AnsiCompareText(WName,'menuitem')=0 then StyleObject^.Widget := GTK_MENU_ITEM_NEW else If AnsiCompareText(WName,'scrollbar')=0 then StyleObject^.Widget := gtk_hscrollbar_new(nil)//can't dif. between Horiz/Vert. Styles else If AnsiCompareText(WName,'tooltip')=0 then begin TP := gtk_tooltips_new; StyleObject^.Widget := nil; GTK_Tooltips_Force_Window(TP); gtk_widget_ensure_style(PGTKTooltips(TP)^.Tip_Window); StyleObject^.Style:=GTK_RC_GET_STYLE(PGTKTooltips(TP)^.Tip_Window); end else If AnsiCompareText(WName,'gtk_default')=0 then begin StyleObject^.Widget := nil; StyleObject^.Style := gtk_style_new; end else begin FreeStyleObject(StyleObject); exit; end; If (StyleObject^.Widget <> nil) then begin gtk_widget_ensure_style(StyleObject^.Widget); StyleObject^.Style:=GTK_RC_GET_STYLE(StyleObject^.Widget); end; If StyleObject^.Style <> nil then If AnsiCompareText(WName,'gtk_default')<>0 then StyleObject^.Style:=GTK_Style_Ref(StyleObject^.Style); if StyleObject^.Style <> nil then begin Styles.AddObject(WName, TObject(StyleObject)); Result:=StyleObject^.Style; If StyleObject^.Widget <> nil then UpdateSysColorMap(StyleObject^.Widget); end else If AnsiCompareText(WName,'default')<>0 then Result := GetStyle('default'); If AnsiCompareText(WName,'tooltip')=0 then GTK_Object_Destroy(Tp); end else Result := PStyleObject(Styles.Objects[l])^.Style; end; Function GetStyleWidget(WName : String) : PGTKWidget; var l : Longint; begin Result := nil; l:=IndexOfStyle(WName); If (l > -1) or (GetStyle(WName) <> nil) then begin l:=IndexOfStyle(WName); Result := PStyleObject(Styles.Objects[l])^.Widget; end; end; {------------------------------------------------------------------------------ Function: GetDefaultFont Params: none Returns: Returns the default Font For Text/Font Routines: if the Font is invalid, this can be used instead, or if the DT_internal flag is used(aka use system font) this is used. This is also the font returned by GetStockObject(SYSTEM_FONT). It attempts to get the font from the default Style, or if none is available, a new style(aka try and get GTK builtin values), if that fails tries to get a generic fixed font, if THAT fails, it gets whatever font is available. If the result is not nil it MUST be GDK_FONT_UNREF'd when done. ------------------------------------------------------------------------------} function GetDefaultFont : PGDKFont; var Style : PGTKStyle; begin Result := nil; Style := GetStyle('default'); if Style = nil then Style := GetStyle('gtk_default'); If Style <> nil then begin If Style^.Font <> nil then Result := Style^.Font else If (Style^.RC_Style <> nil) and (Style^.RC_Style^.font_name <> nil) then Result := gdk_font_load(Style^.RC_Style^.font_name); end; If Result = nil then Result := gdk_fontset_load('-*-fixed-*-*-*-*-*-120-*-*-*-*-*-*'); if Result = nil then Result := gdk_fontset_load('-*-*-*-*-*-*-*-*-*-*-*-*-*-*'); If Result <> nil then Result := gdk_font_ref(Result); end; Function GetSysGCValues(Color : TColorRef) : TGDKGCValues; var Style : PGTKStyle; GC : PGDKGC; Pixmap : PGDKPixmap; SysColor : TColorRef; begin Color := Color and $FF; {Set defaults in case something goes wrong} FillChar(Result, SizeOf(Result), 0); SysColor := GetSysColor(Color); Result.foreground.Red := RGB(0,GetRValue(SysColor),0); Result.foreground.Green := RGB(0,GetGValue(SysColor),0); Result.foreground.Blue := RGB(0,GetBValue(SysColor),0); Result.Fill := GDK_Solid; {$IfDef Disable_GC_SysColors} exit; {$EndIf} Case Color of {These are WM/X defined, but might be possible to get} {COLOR_BACKGROUND COLOR_CAPTIONTEXT COLOR_INACTIVECAPTIONTEXT} {These Are incompatible or WM defined} {COLOR_ACTIVECAPTION COLOR_INACTIVECAPTION COLOR_GRADIENTACTIVECAPTION COLOR_GRADIENTINACTIVECAPTION COLOR_WINDOWFRAME COLOR_ACTIVEBORDER COLOR_INACTIVEBORDER} COLOR_INFOBK : begin Style := GetStyle('tooltip'); If Style = nil then exit; Pixmap := Style^.bg_pixmap[GTK_STATE_NORMAL]; If Pixmap <> nil then begin Result.Fill := GDK_Tiled; Result.Tile := Pixmap; end else begin GC := Style^.bg_gc[GTK_STATE_NORMAL]; If GC = nil then begin Result.Fill := GDK_Solid; Result.foreground := Style^.bg[GTK_STATE_PRELIGHT]; end else GDK_GC_Get_Values(GC, @Result); end; end; COLOR_INFOTEXT : begin Style := GetStyle('tooltip'); If Style = nil then exit; GC := Style^.fg_gc[GTK_STATE_NORMAL]; If GC = nil then begin Result.Fill := GDK_Solid; Result.foreground := Style^.fg[GTK_STATE_NORMAL]; end else GDK_GC_Get_Values(GC, @Result); end; COLOR_Menu, COLOR_SCROLLBAR, COLOR_BTNFACE : begin Case Color of COLOR_BTNFACE : Style := GetStyle('window'); COLOR_MENU : Style := GetStyle('menu'); COLOR_SCROLLBAR : Style := GetStyle('scrollbar'); end; If Style = nil then exit; Pixmap := Style^.bg_pixmap[GTK_STATE_NORMAL]; If Pixmap <> nil then begin Result.Fill := GDK_Tiled; Result.Tile := Pixmap; end else begin GC := Style^.bg_gc[GTK_STATE_NORMAL]; If GC = nil then begin Result.Fill := GDK_Solid; Result.foreground := Style^.fg[GTK_STATE_NORMAL]; end else GDK_GC_Get_Values(GC, @Result); end; end; COLOR_3DDKSHADOW, COLOR_BTNSHADOW : begin Style := GetStyle('button'); If Style = nil then exit; GC := Style^.dark_gc[GTK_STATE_NORMAL]; If GC = nil then begin Result.Fill := GDK_Solid; Result.foreground := Style^.dark[GTK_STATE_NORMAL]; end else GDK_GC_Get_Values(GC, @Result); end; COLOR_GRAYTEXT : begin Style := GetStyle('default'); If Style = nil then exit; GC := Style^.text_gc[GTK_STATE_INSENSITIVE]; GDK_GC_Get_Values(GC, @Result); end; COLOR_MENUTEXT, COLOR_WINDOWTEXT, COLOR_BTNTEXT : begin Case Color of COLOR_BTNTEXT : Style := GetStyle('button'); COLOR_MENUTEXT : Style := GetStyle('menuitem'); COLOR_WINDOWTEXT : Style := GetStyle('default'); end; If Style = nil then exit; GC := Style^.text_gc[GTK_STATE_NORMAL]; If GC = nil then begin Result.Fill := GDK_Solid; Result.foreground := Style^.text[GTK_STATE_NORMAL]; end else GDK_GC_Get_Values(GC, @Result); end; COLOR_3DLIGHT, COLOR_BTNHIGHLIGHT : begin Style := GetStyle('button'); If Style = nil then exit; GC := Style^.light_gc[GTK_STATE_NORMAL]; If GC = nil then begin Result.Fill := GDK_Solid; Result.foreground := Style^.light[GTK_STATE_NORMAL]; end else GDK_GC_Get_Values(GC, @Result); end; COLOR_WINDOW : begin Style := GetStyle('default'); If Style = nil then exit; GC := Style^.base_gc[GTK_STATE_NORMAL]; If GC = nil then begin Result.Fill := GDK_Solid; Result.foreground := Style^.base[GTK_STATE_NORMAL]; end else GDK_GC_Get_Values(GC, @Result); end; COLOR_HIGHLIGHT : begin Style := GetStyle('default'); If Style = nil then exit; GC := Style^.bg_gc[GTK_STATE_SELECTED]; If GC = nil then begin Result.Fill := GDK_Solid; Result.foreground := Style^.bg[GTK_STATE_SELECTED]; end else GDK_GC_Get_Values(GC, @Result); end; COLOR_HIGHLIGHTTEXT : begin Style := GetStyle('default'); If Style = nil then exit; GC := Style^.bg_gc[GTK_STATE_PRELIGHT]; If GC = nil then begin Result.Fill := GDK_Solid; Result.foreground := Style^.bg[GTK_STATE_PRELIGHT]; end else GDK_GC_Get_Values(GC, @Result); end; {????????????? COLOR_HOTLIGHT : begin end; ?????????????} {????????????????? COLOR_APPWORKSPACE : begin end; ?????????????????} end; end; Function DeleteAmpersands(var Str : String) : Longint; // convert double ampersands to single & and delete single & // return the position of the letter after the first deleted single ampersand // in the new string var Tmp : String; SrcPos, DestPos, SrcLen: integer; begin Result := -1; // for speedup reasons check if Str must be changed SrcLen:=length(Str); SrcPos:=SrcLen; while (SrcPos>=1) and (Str[SrcPos]<>'&') do dec(SrcPos); if SrcPos<1 then exit; // copy Str to Tmp and convert ampersands on the fly SetLength(Tmp,SrcLen); SrcPos:=1; DestPos:=1; while (SrcPos<=SrcLen) do begin if Str[SrcPos]<>'&' then begin // copy normal char Tmp[DestPos]:=Str[SrcPos]; inc(SrcPos); inc(DestPos); end else begin inc(SrcPos); if (SrcPos<=SrcLen) and (Str[SrcPos]='&') then begin // double ampersand Tmp[DestPos]:='&'; inc(DestPos); inc(SrcPos); end else begin // single ampersand if Result<1 then Result:=DestPos; end; end; end; SetLength(Tmp,DestPos-1); Str:=Tmp; end; {------------------------------------------------------------------------------- Function Ampersands2Underscore(Src: PChar) : PChar; Creates a new PChar. Deletes escaping ampersands, replaces the first single ampersand with an underscore and deleting all other single ampersands. -------------------------------------------------------------------------------} function Ampersands2Underscore(Src: PChar) : PChar; var i, j: Longint; ShortenChars, FirstAmpersand, NewLength, SrcLength: integer; begin // count ampersands and find first ampersand ShortenChars:= 0; // chars to delete FirstAmpersand:= -1; SrcLength:= StrLen(Src); { Look for amperands. If found, check if it is an escaped ampersand. If it is, don't count it in. } i:=0; while i '&' then begin // copy normal char Result[j]:= Src[i]; end else begin // ampersand if (i < (SrcLength - 1)) and (Src[i+1] = '&') then begin // escaping ampersand found inc(i); Result[j]:='&'; end else begin // single ampersand found if i = FirstAmpersand then begin // replace first single ampersand with underscore Result[j]:='_'; end else begin // delete single ampersand dec(j); end; end; end; Inc(i); Inc(j); end; Result[NewLength]:=#0; end; {------------------------------------------------------------------------------- Function RemoveAmpersands(Src: PChar; LineLength : Longint) : PChar; Creates a new PChar removing all escaping ampersands. -------------------------------------------------------------------------------} function RemoveAmpersands(Src: PChar; LineLength : Longint) : PChar; var i, j: Longint; ShortenChars, NewLength, SrcLength: integer; begin // count ampersands and find first ampersand ShortenChars:= 0; // chars to delete SrcLength:= LineLength; { Look for amperands. If found, check if it is an escaped ampersand. If it is, don't count it in. } i:=0; while i '&' then begin // copy normal char Result[j]:= Src[i]; end else begin // ampersand if (i < (SrcLength - 1)) and (Src[i+1] = '&') then begin // escaping ampersand found inc(i); Result[j]:='&'; end else // delete single ampersand dec(j); end; Inc(i); Inc(j); end; Result[NewLength]:=#0; end; {------------------------------------------------------------------------------- Function GetTextExtentIgnoringAmpersands(Font : PGDKFont; Str : PChar; LineLength : Longint; lbearing, rbearing, width, ascent, descent : Pgint); Gets text extent of a string, ignoring escaped Ampersands. -------------------------------------------------------------------------------} Procedure GetTextExtentIgnoringAmpersands(Font : PGDKFont; Str : PChar; LineLength : Longint; lbearing, rbearing, width, ascent, descent : Pgint); var NewStr : PChar; i: integer; begin NewStr:=Str; // first check if Str contains an ampersand: if (Str<>nil) then begin i:=0; while (not (Str[i] in [#0,'&'])) do inc(i); if Str[i]='&' then begin NewStr := RemoveAmpersands(Str, LineLength); LineLength:=StrLen(NewStr); end; end; gdk_text_extents(Font, NewStr, LineLength, lbearing, rBearing, width, ascent, descent); if NewStr<>Str then StrDispose(NewStr); end; {------------------------------------------------------------------------------ function FontIsDoubleByteCharsFont(TheFont: PGdkFont): boolean; This is only a heuristic ------------------------------------------------------------------------------} function FontIsDoubleByteCharsFont(TheFont: PGdkFont): boolean; var SingleCharLen, DoubleCharLen: integer; begin SingleCharLen:=gdk_text_width(TheFont, 'A', 1); DoubleCharLen:=gdk_text_width(TheFont, 'AA', 2); Result:=(SingleCharLen=0) and (DoubleCharLen>0); end; {------------------------------------------------------------------------------ Method: GDKPixel2GDIRGB Params: Pixel - a GDK Pixel, refers to Index in Colormap/Visual Visual - a GDK Visual, if nil, the System Default is used Colormap - a GDK Colormap, if nil, the System Default is used Returns: TGDIRGB A convenience function for use with GDK Image's. It takes a pixel value retrieved from gdk_image_get_pixel, and uses the passed Visual and Colormap to try and look up actual RGB values. ------------------------------------------------------------------------------} Function GDKPixel2GDIRGB(Pixel : Longint; Visual : PGDKVisual; Colormap : PGDKColormap) : TGDIRGB; var Color : TGDKColor; GdkColorContext : PGdkColorContext; begin FillChar(Result, SizeOf(TGDIRGB),0); If (Visual = nil) or (Colormap = nil) then begin Visual := GDK_Visual_Get_System; Colormap := GDK_Colormap_Get_System; end; gdk_error_trap_push; Color.Pixel := Pixel; GdkColorContext := gdk_color_context_new(Visual,Colormap); gdk_color_context_query_color(GdkColorContext,@Color); gdk_color_context_free(GdkColorContext); Result.Red := Color.Red shr 8; Result.Green := Color.Green shr 8; Result.Blue := Color.Blue shr 8; gdk_error_trap_pop; end; {------------------------------------------------------------------------------ Function GetWindowDecorations(AForm : TCustomForm) : Longint; ------------------------------------------------------------------------------} Function GetWindowDecorations(AForm : TCustomForm) : Longint; var ABorderStyle: TFormBorderStyle; begin if not (csDesigning in AForm.ComponentState) then ABorderStyle:=AForm.BorderStyle else ABorderStyle:=bsSizeable; Case ABorderStyle of bsNone : Result := 0; bsSingle : Result := GDK_DECOR_BORDER or GDK_DECOR_TITLE or GDK_DECOR_MENU or GDK_DECOR_MINIMIZE or GDK_DECOR_MAXIMIZE; bsSizeable : Result := GDK_DECOR_ALL; bsDialog : Result := GDK_DECOR_BORDER or GDK_DECOR_TITLE or GDK_DECOR_MENU or GDK_DECOR_MINIMIZE; bsToolWindow : Result := GDK_DECOR_BORDER or GDK_DECOR_TITLE or GDK_DECOR_MENU or GDK_DECOR_MINIMIZE; bsSizeToolWin :Result := GDK_DECOR_BORDER or GDK_DECOR_TITLE or GDK_DECOR_MENU or GDK_DECOR_MINIMIZE; end; end; {------------------------------------------------------------------------------ Function GetWindowFunction(AForm : TCustomForm) : Longint; ------------------------------------------------------------------------------} Function GetWindowFunction(AForm : TCustomForm) : Longint; var ABorderStyle: TFormBorderStyle; begin if not (csDesigning in AForm.ComponentState) then ABorderStyle:=AForm.BorderStyle else ABorderStyle:=bsSizeable; Case ABorderStyle of bsNone : Result := GDK_FUNC_MOVE or GDK_FUNC_CLOSE; bsSingle : Result := GDK_FUNC_RESIZE or GDK_FUNC_MOVE or GDK_FUNC_MINIMIZE or GDK_FUNC_CLOSE; bsSizeable : Result := GDK_FUNC_ALL; bsDialog : Result := GDK_FUNC_CLOSE or GDK_FUNC_MINIMIZE or GDK_FUNC_MOVE; bsToolWindow : Result := GDK_FUNC_RESIZE or GDK_FUNC_MOVE or GDK_FUNC_MINIMIZE or GDK_FUNC_CLOSE; bsSizeToolWin : Result := GDK_FUNC_RESIZE or GDK_FUNC_MOVE or GDK_FUNC_MINIMIZE or GDK_FUNC_CLOSE or GDK_FUNC_RESIZE; end; end; function GetGDKMouseCursor(Cursor: TCursor): PGdkCursor; begin if (CursorcrHigh) then Cursor:=crDefault; if GDKMouseCursors[Cursor]=nil then GDKMouseCursors[Cursor]:=gdk_cursor_new(CursorToGDKCursor[Cursor]); Result:=GDKMouseCursors[Cursor]; end; Procedure FreeGDKCursors; var i: integer; begin for i:=Low(GDKMouseCursors) to High(GDKMouseCursors) do begin if GDKMouseCursors[i]<>nil then begin gdk_Cursor_Destroy(GDKMouseCursors[i]); GDKMouseCursors[i]:=nil; end; end; end; Procedure FillScreenFonts(ScreenFonts : TStrings); var theFonts : PPChar; Tmp: AnsiString; I, N: Integer; begin ScreenFonts.Clear; {$IfNdef Win32} If X11Display = nil then X11Display := XOpenDisplay(GDK_GET_DISPLAY); theFonts := XListFonts(X11Display,PChar('-*-*-*-*-*-*-*-*-*-*-*-*-*-*'), 10000, @N); For I := 0 to N - 1 do If theFonts[I] <> nil then begin Tmp := ExtractFamilyFromXLFDName(AnsiString(theFonts[I])); If Tmp <> '' then If ScreenFonts.IndexOf(Tmp) < 0 then ScreenFonts.Append(Tmp); end; XFreeFontNames(theFonts); {$EndIf Win32} end; {$IFDEF ASSERT_IS_ON} {$UNDEF ASSERT_IS_ON} {$C-} {$ENDIF} { ============================================================================= $Log$ Revision 1.152 2002/02/09 01:48:23 mattias renamed TinterfaceObject.Init to AppInit and TWinControls can now contain childs in gtk Revision 1.151 2002/12/05 22:16:32 mattias double byte char font started Revision 1.150 2002/11/23 13:48:46 mattias added Timer patch from Vincent Snijders Revision 1.149 2002/11/09 18:13:35 lazarus MG: fixed gdkwindow checks Revision 1.148 2002/11/05 20:03:42 lazarus MG: implemented hints Revision 1.147 2002/11/02 22:25:38 lazarus MG: implemented TMethodList and Application Idle handlers Revision 1.146 2002/10/30 12:37:26 lazarus MG: mouse cursors are now allocated on demand Revision 1.145 2002/10/28 21:04:26 lazarus AJ: fixed mem leek in FillScreenFonts Revision 1.144 2002/10/28 18:17:04 lazarus MG: impoved focussing, unfocussing on destroy and fixed unit search Revision 1.143 2002/10/27 22:37:12 lazarus MG: added verbosity to delivermessage Revision 1.142 2002/10/27 11:51:35 lazarus MG: fixed memleaks Revision 1.141 2002/10/25 15:27:03 lazarus AJ: Moved form contents creation to gtkproc for code reuse between GNOME and GTK, and to make GNOME MDI programming easier later on. Revision 1.140 2002/10/22 12:12:09 lazarus MG: accelerators are now shared between non modal forms Revision 1.139 2002/10/21 22:12:48 lazarus MG: fixed frmactivate Revision 1.138 2002/10/21 18:21:38 lazarus AJ:minor styles improvement; fixed drawing checks under all(?) themes Revision 1.137 2002/10/21 14:40:52 lazarus MG: fixes for 1.1 Revision 1.136 2002/10/21 13:51:58 lazarus AJ: GetDefaultFont - try to get GTK builtin value if style fails Revision 1.135 2002/10/21 13:15:24 lazarus AJ:Try and fall back on default style if nil(aka default theme) Revision 1.134 2002/10/21 03:23:36 lazarus AJ: rearranged GTK init stuff for proper GNOME init & less duplication between interfaces Revision 1.133 2002/10/20 21:54:04 lazarus MG: fixes for 1.1 Revision 1.132 2002/10/20 21:49:11 lazarus MG: fixes for fpc1.1 Revision 1.131 2002/10/20 19:03:57 lazarus AJ: minor fixes for FPC 1.1 Revision 1.130 2002/10/18 16:08:10 lazarus AJ: Partial HintWindow Fix; Added Screen.Font & Font.Name PropEditor; Started to fix ComboBox DropDown size/pos Revision 1.129 2002/10/17 21:00:18 lazarus MG: fixed uncapturing of mouse Revision 1.128 2002/10/17 15:09:33 lazarus MG: made mouse capturing more strict Revision 1.127 2002/10/15 22:28:06 lazarus AJ: added forcelinebreaks Revision 1.126 2002/10/15 16:01:37 lazarus MG: fixed timers Revision 1.125 2002/10/15 07:01:30 lazarus MG: fixed timer checking Revision 1.124 2002/10/10 19:59:41 lazarus MG: get always a default font Revision 1.123 2002/10/10 19:43:17 lazarus MG: accelerated GetTextMetrics Revision 1.122 2002/10/10 08:57:25 lazarus MG: applied cyrillic patch from vasily Revision 1.121 2002/10/10 08:51:15 lazarus MG: added paint messages for some gtk internal widgets Revision 1.120 2002/10/09 10:22:55 lazarus MG: fixed client origin coordinates Revision 1.119 2002/10/08 23:44:00 lazarus AJ: started GNOME interface & modified gtk interface so everything is public/protected Revision 1.118 2002/10/08 14:10:02 lazarus MG: added TDeviceContext.SelectedColors Revision 1.117 2002/10/08 13:42:25 lazarus MG: added TDevContextColorType Revision 1.116 2002/10/08 10:08:47 lazarus MG: accelerated GDIColor allocating Revision 1.115 2002/10/07 20:50:59 lazarus MG: accelerated SelectGDKPenProps Revision 1.114 2002/10/06 17:55:46 lazarus MG: JITForms now sets csDesigning before creation Revision 1.113 2002/10/05 10:37:22 lazarus MG: fixed TComboBox.ItemIndex on CreateWnd Revision 1.112 2002/10/04 20:46:53 lazarus MG: improved TComboBox.SetItemIndex Revision 1.111 2002/10/04 16:38:15 lazarus MG: no OnChange event when app sets Text of TComboBox Revision 1.110 2002/10/03 14:47:32 lazarus MG: added TComboBox.OnPopup+OnCloseUp+ItemWidth Revision 1.109 2002/10/03 06:55:45 lazarus MG: fixed Ampersands2Underscore Revision 1.108 2002/10/01 10:05:50 lazarus MG: changed PDeviceContext into class TDeviceContext Revision 1.107 2002/09/30 22:39:22 lazarus MG: fixed setcursor Revision 1.106 2002/09/30 20:19:13 lazarus MG: fixed flickering of modal forms Revision 1.105 2002/09/29 15:08:43 lazarus MWE: Applied patch from "Andrew Johnson" Patch includes: -fixes Problems with hiding modal forms -temporarily fixes TCustomForm.BorderStyle in bsNone -temporarily fixes problems with improper tabbing in TSynEdit Revision 1.104 2002/09/27 20:52:24 lazarus MWE: Applied patch from "Andrew Johnson" Here is the run down of what it includes - -Vasily Volchenko's Updated Russian Localizations -improvements to GTK Styles/SysColors -initial GTK Palette code - (untested, and for now useless) -Hint Windows and Modal dialogs now try to stay transient to the main program form, aka they stay on top of the main form and usually minimize/maximize with it. -fixes to Form BorderStyle code(tool windows needed a border) -fixes DrawFrameControl DFCS_BUTTONPUSH to match Win32 better when flat -fixes DrawFrameControl DFCS_BUTTONCHECK to match Win32 better and to match GTK theme better. It works most of the time now, but some themes, noteably Default, don't work. -fixes bug in Bitmap code which broke compiling in NoGDKPixbuf mode. -misc other cleanups/ fixes in gtk interface -speedbutton's should now draw correctly when flat in Win32 -I have included an experimental new CheckBox(disabled by default) which has initial support for cbGrayed(Tri-State), and WordWrap, and misc other improvements. It is not done, it is mostly a quick hack to test DrawFrameControl DFCS_BUTTONCHECK, however it offers many improvements which can be seen in cbsCheck/cbsCrissCross (aka non-themed) state. -fixes Message Dialogs to more accurately determine button Spacing/Size, and Label Spacing/Size based on current System font. -fixes MessageDlgPos, & ShowMessagePos in Dialogs -adds InputQuery & InputBox to Dialogs -re-arranges & somewhat re-designs Control Tabbing, it now partially works - wrapping around doesn't work, and subcontrols(Panels & Children, etc) don't work. TabOrder now works to an extent. I am not sure what is wrong with my code, based on my other tests at least wrapping and TabOrder SHOULD work properly, but.. Anyone want to try and fix? -SynEdit(Code Editor) now changes mouse cursor to match position(aka over scrollbar/gutter vs over text edit) -adds a TRegion property to Graphics.pp, and Canvas. Once I figure out how to handle complex regions(aka polygons) data properly I will add Region functions to the canvas itself (SetClipRect, intersectClipRect etc.) -BitBtn now has a Stored flag on Glyph so it doesn't store to lfm/lrs if Glyph is Empty, or if Glyph is not bkCustom(aka bkOk, bkCancel, etc.) This should fix most crashes with older GDKPixbuf libs. Revision 1.103 2002/09/26 21:29:30 lazarus MWE: Fixed window color Revision 1.102 2002/09/20 13:11:13 lazarus MG: fixed TPanel and Frame3D Revision 1.101 2002/09/19 16:45:54 lazarus MG: fixed Menu.Free and gdkwindow=nil bug Revision 1.100 2002/09/18 17:07:29 lazarus MG: added patch from Andrew Revision 1.99 2002/09/16 15:56:02 lazarus Resize cursors in designer. Revision 1.98 2002/09/12 16:49:05 lazarus MG: fixed SelectClipRegion Revision 1.97 2002/09/12 15:53:10 lazarus MG: small bugfixes Revision 1.96 2002/09/12 15:35:57 lazarus MG: small bugfixes Revision 1.95 2002/09/10 06:49:21 lazarus MG: scrollingwincontrol from Andrew Revision 1.94 2002/09/08 10:02:00 lazarus MG: fixed streaming visible=false Revision 1.93 2002/09/06 22:32:21 lazarus Enabled cursor property + property editor. Revision 1.92 2002/09/06 19:45:11 lazarus Cleanups plus a fix to TPanel parent/drawing problem. Revision 1.91 2002/09/06 16:46:17 lazarus MG: improved GetDCOffset Revision 1.90 2002/09/06 16:38:25 lazarus MG: added GetDCOffset Revision 1.89 2002/09/06 15:57:36 lazarus MG: fixed notebook client area, send messages and minor bugs Revision 1.88 2002/09/05 10:12:08 lazarus New dialog for multiline caption of TCustomLabel. Prettified TStrings property editor. Memo now has automatic scrollbars (not fully working), WordWrap and Scrollbars property Removed saving of old combo text (it broke things and is not needed). Cleanups. Revision 1.87 2002/09/03 20:02:01 lazarus Intermediate UI patch to show a bug. Revision 1.86 2002/09/03 11:32:51 lazarus Added shortcut keys to labels Support for alphabetically sorting the properties Standardize message and add shortcuts ala Kylix Published BorderStyle, unpublished BorderWidth ShowAccelChar and FocusControl ShowAccelChar and FocusControl for TLabel, escaped ampersands now work. Revision 1.85 2002/09/03 08:07:21 lazarus MG: image support, TScrollBox, and many other things from Andrew Revision 1.84 2002/09/02 19:10:32 lazarus MG: TNoteBook now starts with no Page and TPage has no auto names Revision 1.83 2002/08/31 11:37:11 lazarus MG: fixed destroying combobox Revision 1.82 2002/08/31 10:55:16 lazarus MG: fixed range check error in ampersands2underscore Revision 1.81 2002/08/31 07:58:22 lazarus MG: fixed resetting comobobox text Revision 1.80 2002/08/30 12:32:23 lazarus MG: MoveWindowOrgEx, Splitted FWinControls/FControls, TControl drawing, Better DesignerDrawing, ... Revision 1.79 2002/08/29 00:07:02 lazarus MG: fixed TComboBox and InvalidateControl Revision 1.78 2002/08/28 09:40:50 lazarus MG: reduced paint messages and DC getting/releasing Revision 1.77 2002/08/27 18:45:14 lazarus MG: propedits text improvements from Andrew, uncapturing, improved comobobox Revision 1.76 2002/08/27 06:40:51 lazarus MG: ShortCut support for buttons from Andrew Revision 1.75 2002/08/24 12:55:00 lazarus MG: fixed mouse capturing, OI edit focus Revision 1.74 2002/08/24 07:09:04 lazarus MG: fixed bracket hilighting Revision 1.73 2002/08/24 06:51:23 lazarus MG: from Andrew: style list fixes, autosize for radio/checkbtns Revision 1.72 2002/08/23 07:05:17 lazarus MG: started form renaming Revision 1.71 2002/08/22 16:43:36 lazarus MG: improved theme support from Andrew Revision 1.70 2002/08/22 16:22:39 lazarus MG: started debugging of mouse capturing Revision 1.69 2002/08/22 07:30:16 lazarus MG: freeing more unused GCs Revision 1.68 2002/08/21 13:35:25 lazarus MG: accelerations for synedit Revision 1.67 2002/08/21 11:29:36 lazarus MG: fixed mem some leaks in ide and gtk Revision 1.66 2002/08/21 10:46:37 lazarus MG: fixed unreleased gdiRegions Revision 1.65 2002/08/19 20:34:48 lazarus MG: improved Clipping, TextOut, Polygon functions Revision 1.64 2002/08/19 18:00:03 lazarus MG: design signals for gtk internal widgets Revision 1.63 2002/08/19 08:53:45 lazarus MG: fixed broken commit Revision 1.62 2002/08/19 08:50:28 lazarus MG: fixed parser for Clx enums and empty param lists Revision 1.61 2002/08/17 11:38:04 lazarus MG: fixed keygrabbing key translation Revision 1.60 2002/08/16 17:47:39 lazarus MG: added some IDE menuicons, fixed submenu indicator bug Revision 1.59 2002/08/15 15:46:49 lazarus MG: added changes from Andrew (Clipping) Revision 1.58 2002/08/15 15:11:01 lazarus MG: fixed showing menu accelarator shortcuts Revision 1.57 2002/08/15 13:37:58 lazarus MG: started menuitem icon, checked, radio and groupindex Revision 1.56 2002/08/05 07:43:29 lazarus MG: fixed BadCursor bug and Circle Reference of FixedWidget of csPanel Revision 1.55 2002/08/04 07:09:29 lazarus MG: fixed client events Revision 1.54 2002/07/23 07:40:52 lazarus MG: fixed get widget position for inherited gdkwindows Revision 1.53 2002/07/20 13:47:04 lazarus MG: fixed eventmask for realized windows Revision 1.52 2002/07/09 17:18:23 lazarus MG: fixed parser for external vars Revision 1.51 2002/06/26 15:11:10 lazarus MG: added new tool: Guess misplaced $IFDEF/$ENDIF Revision 1.50 2002/06/21 18:27:28 lazarus MG: non visual component icons are now centered Revision 1.49 2002/06/21 17:54:24 lazarus MG: in design mode the mouse cursor is now also set for hidden gdkwindows Revision 1.48 2002/06/21 16:59:16 lazarus MG: TControl.Cursor is now set, reduced auto reaction of widgets in design mode Revision 1.47 2002/06/19 19:46:10 lazarus MG: Form Editing: snapping, guidelines, modified on move/resize, creating components in csDesigning, ... Revision 1.46 2002/06/14 14:57:07 lazarus MG: fixed open file at cursor search path Revision 1.45 2002/06/11 13:41:11 lazarus MG: fixed mouse coords and fixed mouse clicked thru bug Revision 1.44 2002/06/09 14:00:42 lazarus MG: fixed persistent caret and implemented Form.BorderStyle=bsNone Revision 1.43 2002/06/04 15:17:23 lazarus MG: improved TFont for XLFD font names Revision 1.42 2002/05/31 06:45:23 lazarus MG: deactivated new system colors, till we got a consistent solution Revision 1.41 2002/05/30 14:11:13 lazarus MG: added filters and history to TOpenDialog Revision 1.40 2002/05/29 21:44:39 lazarus MG: improved TCommon/File/OpenDialog, fixed TListView scrolling and broder Revision 1.39 2002/05/28 19:39:46 lazarus MG: added gtk rc file support and started stule dependent syscolors Revision 1.38 2002/05/13 14:47:02 lazarus MG: fixed client rectangles, TRadioGroup, RecreateWnd Revision 1.37 2002/05/12 04:56:21 lazarus MG: client rect bugs nearly completed Revision 1.36 2002/05/10 06:05:57 lazarus MG: changed license to LGPL Revision 1.35 2002/05/09 12:41:30 lazarus MG: further clientrect bugfixes Revision 1.34 2002/05/06 08:50:37 lazarus MG: replaced logo, increased version to 0.8.3a and some clientrectbugfix Revision 1.33 2002/04/26 12:26:51 lazarus MG: improved clean up Revision 1.32 2002/03/31 23:20:38 lazarus MG: fixed initial size of TPage Revision 1.31 2002/03/31 22:01:38 lazarus MG: fixed unreleased/unpressed Ctrl/Alt/Shift Revision 1.30 2002/03/25 17:59:23 lazarus GTK Cleanup Shane Revision 1.29 2002/02/18 22:46:11 lazarus Implented TMenuItem.ShortCut (not much tested). Revision 1.28 2001/12/10 11:16:00 lazarus MG: added GDK_dead_circumflex key Revision 1.26 2001/11/16 20:08:41 lazarus Object inspector has hints now. Shane Revision 1.25 2001/11/12 16:56:08 lazarus MG: CLIPBOARD Revision 1.24 2001/10/31 16:29:23 lazarus Fixed the gtk mousemove bug where the control gets the coord's based on it's parent instead of itself. Shane Revision 1.23 2001/10/08 12:57:07 lazarus MG: fixed GetPixel Revision 1.22 2001/10/08 08:05:08 lazarus MG: fixed TColorDialog set color Revision 1.21 2001/10/07 07:28:34 lazarus MG: fixed setpixel and TCustomForm.OnResize event Revision 1.20 2001/09/30 08:34:52 lazarus MG: fixed mem leaks and fixed range check errors Revision 1.19 2001/06/20 17:34:37 lazarus MG: fixed unknown special key code Revision 1.17 2001/06/20 13:35:51 lazarus MG: added VK_IRREGULAR and key grabbing Revision 1.16 2001/06/16 09:14:39 lazarus MG: added lazqueue and used it for the messagequeue Revision 1.15 2001/06/05 10:32:06 lazarus MG: small bugfixes for bitbtn, handles Revision 1.14 2001/03/21 23:48:29 lazarus MG: fixed window positions Revision 1.12 2001/03/19 14:44:22 lazarus MG: fixed many unreleased DC and GDIObj bugs Revision 1.10 2001/01/25 21:38:57 lazarus MWE: * fixed lil bug I commetted yesterday (listbox crash) Revision 1.9 2001/01/24 23:26:40 lazarus MWE: = moved some types to gtkdef + added WinWidgetInfo + added some initialization to Application.Create Revision 1.8 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.7 2001/01/08 21:59:36 lazarus MWE: ~ applieed patch from Peter Vreman to reflect compiler fix Revision 1.6 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.5 2000/10/09 22:50:32 lazarus MWE: * fixed some selection code + Added selection sample Revision 1.4 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.3 2000/08/10 10:55:45 lazarus Changed TCustomDialog to TCommonDialog Shane Revision 1.2 2000/07/30 21:48:34 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.1 2000/07/13 10:28:29 michael + Initial import Revision 1.8 2000/06/29 18:08:56 lazarus Shane Looking for the editor problem I made a few changes. I changed everything back to the original though. Revision 1.7 2000/06/19 18:21:22 lazarus Spinedit was never getting created Shane Revision 1.6 2000/06/14 21:51:27 lazarus MWE: + Added menu accelerators. Not finished Revision 1.5 2000/05/11 22:04:16 lazarus MWE: + Added messagequeue * Recoded SendMessage and Peekmessage + Added postmessage + added DeliverPostMessage Revision 1.4 2000/05/10 22:52:58 lazarus MWE: = Moved some global api stuf to gtkobject Revision 1.3 2000/05/10 01:45:12 lazarus Replaced writelns with Asserts. Put ERROR and WARNING messages back to writelns. CAW Revision 1.2 2000/05/08 15:56:59 lazarus MWE: + Added support for mwedit92 in Makefiles * Fixed bug # and #5 (Fillrect) * Fixed labelsize in ApiWizz + Added a call to the resize event in WMWindowPosChanged Revision 1.1 2000/03/30 22:51:42 lazarus MWE: Moved from ../../lcl Revision 1.11 2000/03/30 21:57:44 lazarus MWE: + Added some general functions to Get/Set the Main/Fixed/CoreChild widget + Started with graphic scalig/depth stuff. This is way from finished Hans-Joachim Ott : + Added some improvements for TMEMO Revision 1.10 2000/03/19 23:01:43 lazarus MWE: = Changed splashscreen loading/colordepth = Chenged Save/RestoreDC to platform dependent, since they are relative to a DC Revision 1.9 2000/03/16 23:58:46 lazarus MWE: Added TPixmap for XPM support Revision 1.8 2000/03/08 23:57:38 lazarus MWE: Added SetSysColors Fixed TEdit text bug (thanks to hans-joachim ott ) Finished GetKeyState Added changes from Peter Dyson - a new GetSysColor - some improvements on ExTextOut Revision 1.7 2000/03/03 22:58:26 lazarus MWE: Fixed focussing problem. LM-FOCUS was bound to the wrong signal Added GetKeyState api func. Now LCL knows if shift/trl/alt is pressed (might be handy for keyboard selections ;-) Revision 1.6 2000/01/22 20:07:47 lazarus Some cleanups. It needs much more cleanup than this. Worked around a compiler bug (?) in mwCustomEdit. Reverted some changes to font generation and increased font size. Revision 1.5 1999/09/17 14:58:54 lazarus Changes made to editor.pp Can now press END and some other similiar keys work. Typing works, but doesn't paint correctly yet. Revision 1.4 1999/07/31 06:39:30 lazarus Modified the IntSendMessage3 to include a data variable. It isn't used yet but will help in merging the Message2 and Message3 features. Adjusted TColor routines to match Delphi color format Added a TGdkColorToTColor routine in gtkproc.inc Finished the TColorDialog added to comDialog example. MAH }