------------------------------------------------------------------------------- -- -- -- Ada Interface to the X Window System and Motif(tm)/Lesstif -- -- Copyright (c) 1996-2002 Hans-Frieder Vogt -- -- This file also copyright (c) 2002 Vadim Godunko -- -- -- -- Adabindx is free software; you can redistribute it and/or modify it -- -- under the terms of the GNU General Public License as published by the -- -- Free Software Foundation; either version 2 of the License, or (at your -- -- option) any later version. -- -- -- -- 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. -- -- See the GNU General Public License for more details. -- -- -- -- You should have received a copy of the GNU General Public License -- -- along with this program; if not, write to the -- -- Free Software Foundation, Inc., -- -- 59 Temple Place - Suite 330, -- -- Boston, MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU General Public License. -- -- -- -- X Window System is copyrighted by the X Consortium -- -- Motif(tm) is copyrighted by the Open Software Foundation, Inc. -- -- and by The Open Group -- -- -- -- -- ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- -- -- HISTORY: -- 2002-10-17 Vadim Godunko: first definition of this file -- ------------------------------------------------------------------------------- with Interfaces.C; with Interfaces.C.Strings; with Interfaces.C.Wstrings; with X_Toolkit.Internal; package body Xm_Widgets.Primitive.Text.Data_Field is --------------------------------------------------------------------------- --! --! XtFree --! --! --------------------------------------------------------------------------- procedure XtFree (Value : in Interfaces.C.Strings.chars_ptr); procedure XtFree (Value : in Interfaces.C.Wstrings.wchars_ptr); pragma Import (C, XtFree,"XtFree"); --------------------------------------------------------------------------- --! --! Xm_Create_Data_Field --! --------------------------------------------------------------------------- function Xm_Create_Data_Field (Parent : in Widget; Name : in String; Arglist : in Arg_List := Null_Arg_List) return Widget is function XmCreateDataField (Parent : in Widget; Name : in Interfaces.C.char_array; Args : in X_Toolkit.Internal.Arg_Rec_Access; Count : in Cardinal) return Widget; pragma Import (C, XmCreateDataField, "XmCreateDataField"); begin return XmCreateDataField (Parent, Interfaces.C.To_C (Name), X_Toolkit.Internal.Hook (Arglist), Cardinal (Length (Arglist))); end Xm_Create_Data_Field; --------------------------------------------------------------------------- --! --! Xm_Data_Field_Copy --! --------------------------------------------------------------------------- procedure Xm_Data_Field_Copy (W : in Widget; Clip_Time : in X_Lib.Server_Time) is function XmDataFieldCopy (W : in Widget; Clip_Time : in X_Lib.Server_Time) return Xt_Boolean; pragma Import (C, XmDataFieldCopy, "XmDataFieldCopy"); begin if XmDataFieldCopy (W, Clip_Time) = Xt_Boolean'(False) then raise Xm_Data_Field_Dont_Own_Primary_Selection; end if; end Xm_Data_Field_Copy; --------------------------------------------------------------------------- --! --! Xm_Data_Field_Cut --! --------------------------------------------------------------------------- procedure Xm_Data_Field_Cut (W : in Widget; Clip_Time : in X_Lib.Server_Time) is function XmDataFieldCut (W : in Widget; Clip_Time : in X_Lib.Server_Time) return Xt_Boolean; pragma Import (C, XmDataFieldCut, "XmDataFieldCut"); begin if XmDataFieldCut (W, Clip_Time) = Xt_Boolean'(False) then raise Xm_Data_Field_Dont_Own_Primary_Selection; end if; end Xm_Data_Field_Cut; --------------------------------------------------------------------------- --! --! Xm_Data_Field_Get_Add_Mode --! --------------------------------------------------------------------------- function Xm_Data_Field_Get_Add_Mode (W : in Widget) return Boolean is function XmDataFieldGetAddMode (W : in Widget) return Xt_Boolean; pragma Import (C, XmDataFieldGetAddMode, "XmDataFieldGetAddMode"); begin return XmDataFieldGetAddMode (W) /= Xt_Boolean'(False); end Xm_Data_Field_Get_Add_Mode; --------------------------------------------------------------------------- --! --! Xm_Data_Field_Get_Editable --! --------------------------------------------------------------------------- function Xm_Data_Field_Get_Editable (W : in Widget) return Boolean is function XmDataFieldGetEditable (W : in Widget) return Xt_Boolean; pragma Import (C, XmDataFieldGetEditable, "XmDataFieldGetEditable"); begin return XmDataFieldGetEditable (W) /= Xt_Boolean'(False); end Xm_Data_Field_Get_Editable; --------------------------------------------------------------------------- --! --! Xm_Data_Field_Get_Selection --! --------------------------------------------------------------------------- function Xm_Data_Field_Get_Selection (W : in Widget) return String is function XmDataFieldGetSelection (W : in Widget) return Interfaces.C.Strings.chars_ptr; pragma Import (C, XmDataFieldGetSelection, "XmDataFieldGetSelection"); X_S : Interfaces.C.Strings.chars_ptr; begin X_S := XmDataFieldGetSelection (W); declare Result : constant String := Interfaces.C.Strings.Value (X_S); begin XtFree (X_S); return Result; end; end Xm_Data_Field_Get_Selection; --------------------------------------------------------------------------- --! --! Xm_Data_Field_Get_Selection --! --------------------------------------------------------------------------- function Xm_Data_Field_Get_Selection (W : in Widget) return Wide_String is function XmDataFieldGetSelectionWcs (W : in Widget) return Interfaces.C.Wstrings.wchars_ptr; pragma Import (C, XmDataFieldGetSelectionWcs, "XmDataFieldGetSelectionWcs"); X_S : Interfaces.C.Wstrings.wchars_ptr; begin X_S := XmDataFieldGetSelectionWcs (W); declare Result : constant Wide_String := Interfaces.C.Wstrings.Value (X_S); begin XtFree (X_S); return Result; end; end Xm_Data_Field_Get_Selection; --------------------------------------------------------------------------- --! --! Xm_Data_Field_Get_String --! --------------------------------------------------------------------------- function Xm_Data_Field_Get_String (W : in Widget) return String is function XmDataFieldGetString (W : in Widget) return Interfaces.C.Strings.chars_ptr; pragma Import (C, XmDataFieldGetString, "XmDataFieldGetString"); X_S : Interfaces.C.Strings.chars_ptr; begin X_S := XmDataFieldGetString (W); declare Result : constant String := Interfaces.C.Strings.Value (X_S); begin XtFree (X_S); return Result; end; end Xm_Data_Field_Get_String; --------------------------------------------------------------------------- --! --! Xm_Data_Field_Get_String --! --------------------------------------------------------------------------- function Xm_Data_Field_Get_String (W : in Widget) return Wide_String is function XmDataFieldGetStringWcs (W : in Widget) return Interfaces.C.Wstrings.wchars_ptr; pragma Import (C, XmDataFieldGetStringWcs, "XmDataFieldGetStringWcs"); X_S : Interfaces.C.Wstrings.wchars_ptr; begin X_S := XmDataFieldGetStringWcs (W); declare Result : constant Wide_String := Interfaces.C.Wstrings.Value (X_S); begin XtFree (X_S); return Result; end; end Xm_Data_Field_Get_String; --------------------------------------------------------------------------- --! --! Xm_Data_Field_Insert --! --------------------------------------------------------------------------- procedure Xm_Data_Field_Insert (W : in Widget; Position : in Xm_Text_Position; Value : in String) is procedure XmDataFieldInsert (W : in Widget; Position : in Xm_Text_Position; Value : in Interfaces.C.char_array); pragma Import (C, XmDataFieldInsert, "XmDataFieldInsert"); begin XmDataFieldInsert (W, Position, Interfaces.C.To_C (Value)); end Xm_Data_Field_Insert; --------------------------------------------------------------------------- --! --! Xm_Data_Field_Insert --! --------------------------------------------------------------------------- procedure Xm_Data_Field_Insert (W : in Widget; Position : in Xm_Text_Position; Value : in Wide_String) is procedure XmDataFieldInsertWcs (W : in Widget; Position : in Xm_Text_Position; Value : in Interfaces.C.wchar_array); pragma Import (C, XmDataFieldInsertWcs, "XmDataFieldInsertWcs"); begin XmDataFieldInsertWcs (W, Position, Interfaces.C.To_C (Value)); end Xm_Data_Field_Insert; --------------------------------------------------------------------------- --! --! Xm_Data_Field_Paste --! --------------------------------------------------------------------------- procedure Xm_Data_Field_Paste (W : in Widget) is function XmDataFieldPaste (W : in Widget) return Xt_Boolean; pragma Import (C, XmDataFieldPaste, "XmDataFieldPaste"); begin if XmDataFieldPaste (W) = Xt_Boolean'(False) then raise Xm_Data_Field_Dont_Own_Primary_Selection; end if; end Xm_Data_Field_Paste; --------------------------------------------------------------------------- --! --! Xm_Data_Field_Pos_To_XY --! --------------------------------------------------------------------------- procedure Xm_Data_Field_Pos_To_XY (W : in Widget; Position : in Xm_Text_Position; X : out X_Lib.Position; Y : out X_Lib.Position) is function XmDataFieldPosToXY (W : in Widget; Position : in Xm_Text_Position; X : in System.Address; Y : in System.Address) return Xt_Boolean; pragma Import (C, XmDataFieldPosToXY, "XmDataFieldPosToXY"); begin if XmDataFieldPosToXY (W, Position, X'Address, Y'Address) = Xt_Boolean'(False) then raise Xm_Data_Field_Not_In_Data_Field_Widget; end if; end Xm_Data_Field_Pos_To_XY; --------------------------------------------------------------------------- --! --! Xm_Data_Field_Replace --! --------------------------------------------------------------------------- procedure Xm_Data_Field_Replace (W : in Widget; From_Position : in Xm_Text_Position; To_Position : in Xm_Text_Position; Value : in String) is procedure XmDataFieldReplace (W : in Widget; From_Position : in Xm_Text_Position; To_Position : in Xm_Text_Position; Value : in Interfaces.C.char_array); pragma Import (C, XmDataFieldReplace, "XmDataFieldReplace"); begin XmDataFieldReplace (W, From_Position, To_Position, Interfaces.C.To_C (Value)); end Xm_Data_Field_Replace; --------------------------------------------------------------------------- --! --! Xm_Data_Field_Replace --! --------------------------------------------------------------------------- procedure Xm_Data_Field_Replace (W : in Widget; From_Position : in Xm_Text_Position; To_Position : in Xm_Text_Position; Value : in Wide_String) is procedure XmDataFieldReplaceWcs (W : in Widget; From_Position : in Xm_Text_Position; To_Position : in Xm_Text_Position; Value : in Interfaces.C.wchar_array); pragma Import (C, XmDataFieldReplaceWcs, "XmDataFieldReplaceWcs"); begin XmDataFieldReplaceWcs (W, From_Position, To_Position, Interfaces.C.To_C (Value)); end Xm_Data_Field_Replace; --------------------------------------------------------------------------- --! --! Xm_Data_Field_Set_Add_Mode --! --------------------------------------------------------------------------- procedure Xm_Data_Field_Set_Add_Mode (W : in Widget; State : in Boolean) is procedure XmDataFieldSetAddMode (W : in Widget; State : in Xt_Boolean); pragma Import (C, XmDataFieldSetAddMode, "XmDataFieldSetAddMode"); begin XmDataFieldSetAddMode (W, To_Xt_Boolean (State)); end Xm_Data_Field_Set_Add_Mode; --------------------------------------------------------------------------- --! --! Xm_Data_Field_Set_Editable --! --------------------------------------------------------------------------- procedure Xm_Data_Field_Set_Editable (W : in Widget; Editable : in Boolean) is procedure XmDataFieldSetEditable (W : in Widget; Editable : in Xt_Boolean); pragma Import (C, XmDataFieldSetEditable, "XmDataFieldSetEditable"); begin XmDataFieldSetEditable (W, To_Xt_Boolean (Editable)); end Xm_Data_Field_Set_Editable; --------------------------------------------------------------------------- --! --! Xm_Data_Field_Set_String --! --------------------------------------------------------------------------- procedure Xm_Data_Field_Set_String (W : in Widget; Value : in String) is procedure XmDataFieldSetString(W : in Widget; Value : in Interfaces.C.char_array); pragma Import (C, XmDataFieldSetString,"XmDataFieldSetString"); begin XmDataFieldSetString (W, Interfaces.C.To_C (Value)); end Xm_Data_Field_Set_String; -- --------------------------------------------------------------------------- -- --! -- --! Xm_Data_Field_Set_String -- --! -- --------------------------------------------------------------------------- -- procedure Xm_Data_Field_Set_String (W : in Widget; -- Value : in Wide_String) is -- procedure XmDataFieldSetStringWcs (W : in Widget; Value : in Interfaces.C.char_array); pragma Import (C, XmDataFieldSetString,"XmDataFieldSetString"); begin XmDataFieldSetString (W, Interfaces.C.To_C (Value)); end Xm_Data_Field_Set_String; -- --------------------------------------------------------------------------- -- --! -- --! Xm_Data_Field_Set_String -- --! -- --------------------------------------------------------------------------- -- procedure Xm_Data_Field_Set_String (W : in Widget; -- Value : in Wide_String) is -- procedure XmDataFieldSetStringWcs (W : in Widget; -- Value : in Interfaces.C.wchar_array); -- pragma Import (C, XmDataFieldSetStringWcs,"XmDataFieldSetStringWcs"); -- begin ---- UseGnat3.13p ----! -- the GNAT 3.13p runtime (and possibly earlies ones as well) raise ----! -- STORAGE_ERROR for Value with 'Length = 0 ----! -- This is a workaround to this problem ----! -- ----! if Value'Length = 0 then ----! declare ----! Value_String : constant Interfaces.C.Wchar_Array (0 .. 0) := ----! (others => Interfaces.C.wide_nul); ----! begin ----! XmDataFieldSetStringWcs (W, Value_String); ----! end; ----! else ----! XmDataFieldSetStringWcs (W, Interfaces.C.To_C (Value)); ----! end if; ---- NotGnat3.13p -- XmDataFieldSetStringWcs (W, Interfaces.C.To_C (Value)); ---- EndGnat3.13p -- end Xm_Data_Field_Set_String; --------------------------------------------------------------------------- --! --! Xm_Is_Data_Field --! --------------------------------------------------------------------------- function Xm_Is_Data_Field (W : in Widget) return Boolean is begin return Xt_Is_Subclass (W, Xm_Data_Field_Widget_Class); end Xm_Is_Data_Field; end Xm_Widgets.Primitive.Text.Data_Field;