------------------------------------------------------------------------------ -- -- -- XVIEW ADA LIBRARY COMPONENTS -- -- -- -- XVIEW_NOTICE_PACKAGE -- -- -- -- B o d y -- -- -- -- Copyright (c) 1995 Andreas Almroth, All Rights Reserved -- -- -- -- The XVIEW ADA library is free software; you can redistribute it and/or -- -- modify it under terms of the GNU Library General Public License as -- -- published by the Free Software Foundation; either version 2, or (at your -- -- option) any later version. The XVIEW ADA library 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 Library General Public License for more details. -- -- You should have received a copy of the GNU Library General Public -- -- License along with the XVIEW ADA library; see the file COPYING.LIB. If -- -- not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, -- -- MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ -- Lots of bindings to XView C functions needs the Interfaces.C package. with Ada.Integer_Text_Io,Text_Io,Interfaces.C,Interfaces.C.Strings; use Ada.Integer_Text_Io,Text_Io; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; package body Xv_Notice_Package is XV_SHOW : constant := 1079052545; NOTICE_EVENT_PROC : constant := 1499728481; NOTICE_MESSAGE_STRING : constant := 1496123745; NOTICE_LOCK_SCREEN : constant := 1498417409; NOTICE_BLOCK_THREAD : constant := 1500383489; NOTICE_BUTTON : constant := 1493239810; NOTICE_STATUS : constant := 1499400705; ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- ComposeString ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- function ComposeString(Txt : in Xv_Base_Package.Strings) return String is Work : Unbounded_String; Work2 : Unbounded_String; Term : String (1..2); begin Term(1) := Character'Val(10); Term(2) := Character'Val(32); Work := To_Unbounded_String(Txt(Txt'First).all) & To_Unbounded_String(Term); if Txt'Last > 2 then for I in Txt'First + 1..Txt'Last - 1 loop Work2 := Work & To_Unbounded_String(Txt(I).all) & To_Unbounded_String(term); Work := Work2; Work2 := Work & To_Unbounded_String(Txt(2).all); Work := Work2; end loop; else Work2 := Work & To_Unbounded_String(Txt(2).all); Work := Work2; end if; return To_String(Work); end ComposeString; ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- xv_notice ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- function xv_set (owner : Xv_opaque; cmd : Integer; data : Integer; term : Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); function xv_set (owner : Xv_opaque; cmd : Integer; data : Interfaces.C.Char_Array; term : Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); function xv_set (owner : Xv_opaque; cmd : Integer; data : Interfaces.C.Char_Array; Data2 : Integer; term : Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); function xv_set (owner : Xv_opaque; cmd : Integer; data : Interfaces.C.Char_Array; Data2 : Integer; cmd2 : Integer; data3 : Interfaces.C.Char_Array; Data4 : Integer; term : Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); function xv_set (owner : Xv_opaque; cmd : Integer; data : Interfaces.C.Char_Array; Data2 : Integer; cmd2 : Integer; data3 : Interfaces.C.Char_Array; Data4 : Integer; cmd3 : Integer; data5 : Interfaces.C.Char_Array; Data6 : Integer; term : Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); function xv_set (owner : Xv_opaque; cmd : Integer; data : Interfaces.C.Char_Array; Data2 : Integer; cmd2 : Integer; data3 : Interfaces.C.Char_Array; Data4 : Integer; cmd3 : Integer; data5 : Interfaces.C.Char_Array; Data6 : Integer; cmd5 : Integer; data7 : Interfaces.C.Char_Array; Data8 : Integer; term : Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); function xv_set (owner : Xv_opaque; cmd : Integer; data : Interfaces.C.Char_Array; Data2 : Integer; cmd2 : Integer; data3 : Interfaces.C.Char_Array; Data4 : Integer; cmd3 : Integer; data5 : Interfaces.C.Char_Array; Data6 : Integer; cmd5 : Integer; data7 : Interfaces.C.Char_Array; Data8 : Integer; cmd6 : Integer; data9 : Interfaces.C.Char_Array; Data10 : Integer; term : Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); function xv_set (owner : Xv_opaque; cmd : Integer; func : callback_notice_ptr; term : Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); ----------------------------------------------------------------------------- function xv_get (owner : Xv_opaque; cmd : Integer; term : Integer) return Integer; pragma import (C,xv_get,"xv_get"); ----------------------------------------------------------------------------- procedure Initialize (V : in out Xv_Notice) is function Xv_Create (owner : Xv_opaque; pkg : Xv_pkg_ptr; term : Integer) return Notice; pragma import (C,xv_create,"xv_create"); function Xv_Set (owner : Xv_opaque; cmd : Integer; data : Integer_ptr; term : Integer) return Xv_object; pragma Import (C,xv_set,"xv_set"); -- Initialize panel_base pointer Xv_Notice_Pkg : Xv_Pkg_Ptr; pragma Import (C,Xv_Notice_Pkg,"my_xv_notice_pkg"); Xv_Rc : Xv_Object; begin V.Base := Xv_Create(V.Parent,Xv_Notice_Pkg,0); if V.State = 1 then Xv_rc := xv_set(Xv_opaque(V.base),NOTICE_LOCK_SCREEN,Integer(1),0); else Xv_rc := xv_set(Xv_opaque(V.base),NOTICE_LOCK_SCREEN,Integer(0),0); end if; -- Xv_Rc := Xv_Set(Xv_opaque(V.base),NOTICE_MESSAGE_STRING, -- Interfaces.C.to_C(ComposeString(V.Text.all),True),0); end Initialize; ----------------------------------------------------------------------------- procedure Finalize (V : in out Xv_Notice) is procedure xv_destroy (object : Xv_Opaque); pragma import (C,xv_destroy,"xv_destroy"); begin Xv_Destroy(Xv_Opaque(V.Base)); end Finalize; ----------------------------------------------------------------------------- function Get_Notice (V : in Xv_Notice) return Notice is begin return V.base; end Get_Notice; ----------------------------------------------------------------------------- procedure Set_Callback(V : in Xv_Notice; func : callback_notice_ptr) is Xv_rc : Xv_object; begin Xv_rc := xv_set(Xv_opaque(V.base),NOTICE_EVENT_PROC,func,0); end Set_Callback; ----------------------------------------------------------------------------- procedure Set_Text (V : in Xv_Notice; txt : Xv_Base_Package.Strings) is Xv_rc : Xv_object; begin Xv_rc := xv_set(Xv_opaque(V.base),NOTICE_MESSAGE_STRING, Interfaces.C.to_C(ComposeString(Txt),True),0); end Set_Text; ----------------------------------------------------------------------------- procedure Set_Lock_Screen (V : in Xv_Notice; state : Boolean) is Xv_rc : Xv_object; begin if State = True then Xv_rc := xv_set(Xv_opaque(V.base),NOTICE_LOCK_SCREEN,Integer(1),0); else Xv_rc := xv_set(Xv_opaque(V.base),NOTICE_LOCK_SCREEN,Integer(0),0); end if; end Set_Lock_Screen; ----------------------------------------------------------------------------- procedure Set_Block_Thread (V : in Xv_Notice; state : Boolean) is Xv_rc : Xv_object; begin if State = True then Xv_rc := xv_set(Xv_opaque(V.base),NOTICE_BLOCK_THREAD,Integer(1),0); else Xv_rc := xv_set(Xv_opaque(V.base),NOTICE_BLOCK_THREAD,Integer(0),0); end if; end Set_Block_Thread; ----------------------------------------------------------------------------- procedure Set_Buttons (V : in Xv_Notice; buttons : Notice_Buttons_ptr) is Xv_rc : Xv_object; begin case Get_Size(Buttons) is when 1 => Xv_rc := xv_set(Xv_opaque(V.base), NOTICE_BUTTON, Interfaces.C.To_C(To_String(Get_Text(Buttons,1)),True), Get_Value(Buttons,1),0); when 2 => Xv_rc := xv_set(Xv_opaque(V.base), NOTICE_BUTTON, Interfaces.C.To_C(To_String(Get_Text(Buttons,1)),True), Get_Value(Buttons,1), NOTICE_BUTTON, Interfaces.C.To_C(To_String(Get_Text(Buttons,2)),True), Get_Value(Buttons,2),0); when 3 => Xv_rc := xv_set(Xv_opaque(V.base), NOTICE_BUTTON, Interfaces.C.To_C(To_String(Get_Text(Buttons,1)),True), Get_Value(Buttons,1), NOTICE_BUTTON, Interfaces.C.To_C(To_String(Get_Text(Buttons,2)),True), Get_Value(Buttons,2), NOTICE_BUTTON, Interfaces.C.To_C(To_String(Get_Text(Buttons,3)),True), Get_Value(Buttons,3),0); when 4 => Xv_rc := xv_set(Xv_opaque(V.base), NOTICE_BUTTON, Interfaces.C.To_C(To_String(Get_Text(Buttons,1)),True), Get_Value(Buttons,1), NOTICE_BUTTON, Interfaces.C.To_C(To_String(Get_Text(Buttons,2)),True), Get_Value(Buttons,2), NOTICE_BUTTON, Interfaces.C.To_C(To_String(Get_Text(Buttons,3)),True), Get_Value(Buttons,3), NOTICE_BUTTON, Interfaces.C.To_C(To_String(Get_Text(Buttons,4)),True), Get_Value(Buttons,4),0); when 5 => Xv_rc := xv_set(Xv_opaque(V.base), NOTICE_BUTTON, Interfaces.C.To_C(To_String(Get_Text(Buttons,1)),True), Get_Value(Buttons,1), NOTICE_BUTTON, Interfaces.C.To_C(To_String(Get_Text(Buttons,2)),True), Get_Value(Buttons,2), NOTICE_BUTTON, Interfaces.C.To_C(To_String(Get_Text(Buttons,3)),True), Get_Value(Buttons,3), NOTICE_BUTTON, Interfaces.C.To_C(To_String(Get_Text(Buttons,4)),True), Get_Value(Buttons,4), NOTICE_BUTTON, Interfaces.C.To_C(To_String(Get_Text(Buttons,5)),True), Get_Value(Buttons,5),0); when others => raise Constraint_Error; end case; end Set_Buttons; ----------------------------------------------------------------------------- function Get_Choosen (V : in Xv_Notice) return Integer is begin return Xv_Get(Xv_opaque(V.Base),NOTICE_STATUS,0); end Get_Choosen; ----------------------------------------------------------------------------- procedure Show_Notice (V : in Xv_Notice) is Xv_rc : Xv_object; begin Xv_Rc := xv_set(Xv_opaque(V.base),XV_SHOW,Integer(1),0); end Show_Notice; ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- Notice_buttons ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- procedure Initialize (V : in out Notice_Buttons) is begin for I in V.Data'Range loop V.Data(I) := new Notice_Data; end loop; end Initialize; procedure Finalize (V : in out Notice_Buttons) is begin null; end Finalize; procedure Set_Text(V : in Notice_Buttons_Ptr; Idx : Positive; Txt : String) is begin V.Data(Idx).Txt := To_Unbounded_String(Txt); end Set_Text; procedure Set_Value(V : in Notice_Buttons_Ptr; Idx : Positive; num : Integer) is begin V.Data(Idx).Value := num; end Set_Value; function Get_Text(V : in Notice_Buttons_Ptr; Idx : Positive) return Unbounded_String is begin return V.Data(Idx).Txt; end Get_Text; function Get_Value(V : in Notice_Buttons_Ptr; Idx : Positive) return Integer is begin return V.Data(Idx).Value; end Get_Value; function Get_Size(V : in Notice_Buttons_Ptr) return Positive is begin return V.Data'Last; end Get_Size; end Xv_Notice_Package;