------------------------------------------------------------------------------ -- -- -- XVIEW ADA LIBRARY COMPONENTS -- -- -- -- XV_FRAME_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 Interfaces.C,Interfaces.C.Strings,Ada.Text_Io; use Ada.Text_Io; -- Because of the need of initializing XView, we need to have the command -- line arguments, and therefore the Ada.command_line package. -- with Ada.command_line; -- use Ada.command_line; package body Xv_Frame_Package is package Int_Io is new Integer_Io (Integer); use Int_Io; XV_SHOW : constant := 1079052545; XV_WIDTH : constant := 1246234689; XV_HEIGHT : constant := 1246300289; XV_X : constant := 1246103617; XV_Y : constant := 1246169217; FRAME_BUSY : constant := 1376389377; FRAME_CLOSED : constant := 1376717057; FRAME_LABEL : constant := 1078397281; FRAME_MAX_SIZE : constant := 1384712194; FRAME_MIN_SIZE : constant := 1384646658; FRAME_CMD_PANEL : constant := 1377372673; FRAME_SHOW_HEADER : constant := 1384253697; FRAME_SHOW_FOOTER : constant := 1383926017; FRAME_LEFT_FOOTER : constant := 1379993953; FRAME_RIGHT_FOOTER : constant := 1383270753; XV_DISPLAY : constant := 1248725505; ----------------------------------------------------------------------------- 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 : Integer; term : Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); function xv_set (owner : Xv_opaque; cmd : Integer; data : Boolean; term : Integer) return Xv_object; pragma import (C,xv_set,"xv_set"); function xv_set (owner : Xv_opaque; cmd : Integer; data1 : Integer; data2 : Integer; 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"); function xv_get (owner : Xv_opaque; cmd : Integer; term : Integer) return Xv_opaque; pragma import (C,xv_get,"xv_get"); function xv_get (owner : Xv_opaque; cmd : Integer; term : Integer) return Boolean; pragma import (C,xv_get,"xv_get"); function xv_get_string (owner : Xv_opaque; cmd : Integer; term : Integer) return Interfaces.C.Strings.chars_ptr; pragma import (C,xv_get_string,"xv_get"); ----------------------------------------------------------------------------- procedure Set_Pos (V : in Xv_Frame; X,Y : Integer) is Xv_Rc : Xv_Object; begin Xv_Rc := Xv_Set(Xv_Opaque(V.Base),XV_X,X,0); Xv_Rc := Xv_Set(Xv_Opaque(V.Base),XV_Y,Y,0); end Set_Pos; ----------------------------------------------------------------------------- procedure Set_Size (V : in Xv_Frame; W,H : Integer) is Xv_Rc : Xv_Object; begin Xv_Rc := Xv_Set(Xv_Opaque(V.Base),XV_WIDTH,W,0); Xv_Rc := Xv_Set(Xv_Opaque(V.Base),XV_HEIGHT,H,0); end Set_Size; ----------------------------------------------------------------------------- procedure Set_Min_Size (V : in out Xv_Frame; W,H : Integer) is Xv_Rc : Xv_Object; begin V.Min_Width := W; V.Min_Height := H; Xv_Rc := Xv_Set(Xv_Opaque(V.Base),FRAME_MIN_SIZE, V.Min_Width,V.Min_Height,0); end Set_Min_Size; ----------------------------------------------------------------------------- procedure Set_Max_Size (V : in out Xv_Frame; W,H : Integer) is Xv_Rc : Xv_Object; begin V.Max_Width := W; V.Max_Height := H; Xv_Rc := Xv_Set(Xv_Opaque(V.Base),FRAME_MAX_SIZE, V.Max_Width,V.Max_Height,0); end Set_Max_Size; ----------------------------------------------------------------------------- procedure Set_Title (V : in out Xv_Frame ; Tit : String) is Xv_Rc : Xv_Object; begin Xv_Rc := Xv_Set(Xv_Opaque(V.Base),FRAME_LABEL, Interfaces.C.To_C(Tit,True),0); end Set_Title; ----------------------------------------------------------------------------- procedure Show_Frame (V : in Xv_Frame) is Xv_Rc : Xv_Object; begin Xv_Rc := Xv_Set(Xv_Opaque(V.Base),XV_SHOW,Integer(1),0); end Show_Frame; ----------------------------------------------------------------------------- procedure Hide_Frame (V : in Xv_Frame) is Xv_Rc : Xv_Object; begin Xv_Rc := Xv_Set(Xv_Opaque(V.Base),XV_SHOW,Integer(0),0); end Hide_Frame; ----------------------------------------------------------------------------- procedure Show_Header (V : in Xv_Frame) is Xv_Rc : Xv_Object; begin Xv_Rc := Xv_Set(Xv_Opaque(V.Base),FRAME_SHOW_HEADER,Integer(1),0); end Show_Header; ----------------------------------------------------------------------------- procedure Hide_Header (V : in Xv_Frame) is Xv_Rc : Xv_Object; begin Xv_Rc := Xv_Set(Xv_Opaque(V.Base),FRAME_SHOW_HEADER,Integer(0),0); end Hide_Header; ----------------------------------------------------------------------------- procedure Show_Footer (V : in Xv_Frame) is Xv_Rc : Xv_Object; begin Xv_Rc := Xv_Set(Xv_Opaque(V.Base),FRAME_SHOW_FOOTER,Integer(1),0); end Show_Footer; ----------------------------------------------------------------------------- procedure Hide_Footer (V : in Xv_Frame) is Xv_Rc : Xv_Object; begin Xv_Rc := Xv_Set(Xv_Opaque(V.Base),FRAME_SHOW_FOOTER,Integer(0),0); end Hide_Footer; ----------------------------------------------------------------------------- procedure Set_Left_Footer (V : in Xv_Frame; Tit : String) is Xv_Rc : Xv_Object; begin Xv_Rc := Xv_Set(Xv_Opaque(V.Base),FRAME_LEFT_FOOTER, Interfaces.C.To_C(Tit,True),0); end Set_Left_Footer; ----------------------------------------------------------------------------- procedure Set_Right_Footer (V : in Xv_Frame; tit : String) is Xv_rc : Xv_object; begin Xv_rc := xv_set(Xv_opaque(V.base),FRAME_RIGHT_FOOTER, Interfaces.C.To_C(tit,True),0); end Set_Right_Footer; ----------------------------------------------------------------------------- function Get_Title (V : in Xv_Frame) return String is begin return Interfaces.C.Strings.Value(xv_get_string(Xv_opaque(V.base), FRAME_LABEL,0)); end Get_Title; ----------------------------------------------------------------------------- function Get_Min_Size (V : in Xv_Frame) return IntegerPair is rc : IntegerPair; begin rc.X := V.min_width; rc.Y := V.min_height; return rc; end Get_Min_Size; ----------------------------------------------------------------------------- function Get_Max_Size (V : in Xv_Frame) return IntegerPair is rc : IntegerPair; begin rc.X := V.max_width; rc.Y := V.max_height; return rc; end Get_Max_Size; ----------------------------------------------------------------------------- function Get_Pos (V : in Xv_Frame) return IntegerPair is rc : IntegerPair; begin rc.X := xv_get(Xv_opaque(V.base),XV_X,0); rc.Y := xv_get(Xv_opaque(V.base),XV_Y,0); return rc; end Get_Pos; ----------------------------------------------------------------------------- function Get_Size (V : in Xv_Frame) return IntegerPair is rc : IntegerPair; begin rc.X := xv_get(Xv_opaque(V.base),XV_WIDTH,0); rc.Y := xv_get(Xv_opaque(V.base),XV_HEIGHT,0); return rc; end Get_Size; ----------------------------------------------------------------------------- function Get_Frame (V : in Xv_Frame) return Frame is begin return V.base; end Get_Frame; ----------------------------------------------------------------------------- procedure Iconify_Frame (V : in Xv_Frame; State : Boolean) is Xv_Rc : Xv_Object; begin if State = True then Xv_Rc := Xv_Set(Xv_Opaque(V.Base),FRAME_CLOSED,Integer(1),0); elsif State = False then Xv_Rc := Xv_Set(Xv_Opaque(V.Base),FRAME_CLOSED,Integer(0),0); end if; end Iconify_Frame; ----------------------------------------------------------------------------- procedure Busy_Frame (V : in Xv_Frame; State : Boolean) is Xv_Rc : Xv_Object; begin if State = True then Xv_Rc := Xv_Set(Xv_Opaque(V.Base),FRAME_BUSY,Integer(1),0); elsif State = False then Xv_Rc := Xv_Set(Xv_Opaque(V.Base),FRAME_BUSY,Integer(0),0); end if; end Busy_Frame; ----------------------------------------------------------------------------- -- function Get_Display_Depth return Display_Depth is -- display : X.Xlib.XDisplay_access; -- screen_num: Interfaces.C.Int; -- begin -- display := X.Xlib.XOpenDisplay(null); -- screen_num := X.Xlib.DefaultScreen(display); -- -- case X.Xlib.DefaultDepth(Display,Screen_num) is -- when 0 => -- raise INVALID_OBJECT; -- when 1 => -- return MONO; -- when 2 => -- return TWOBITS; -- when 4 => -- return FOURBITS; -- when 8 => -- return EIGHTBITS; -- when 12 => -- return TWELVEBITS; -- when 16 => -- return SIXTEENBITS; -- when 24 => -- return TWENTYFOURBITS; -- when 32 => -- return THIRTYTWOBITS; -- when 64 => -- return SIXTYFOURBITS; -- when others => -- return MONO; -- end case; -- end Get_Display_Depth; function Get_Display_Depth (obj : Frame) return Display_Depth is function my_get_depth (owner : Frame) return Integer; pragma import (C,my_get_depth,"my_get_depth"); begin case my_get_depth(obj) is when 0 => raise INVALID_OBJECT; when 1 => return MONO; when 2 => return TWOBITS; when 4 => return FOURBITS; when 8 => return EIGHTBITS; when 12 => return TWELVEBITS; when 16 => return SIXTEENBITS; when 24 => return TWENTYFOURBITS; when 32 => return THIRTYTWOBITS; when 64 => return SIXTYFOURBITS; when others => return MONO; end case; end Get_Display_Depth; ----------------------------------------------------------------------------- function destroy_func(client : Notify_client; status : Integer) return Integer is begin if status = DESTROY_CLEANUP then raise QUIT_PROGRAM; return DESTROY_DONE; end if; return DESTROY_DONE; end destroy_func; ----------------------------------------------------------------------------- procedure Window_Loop (V : in Xv_Frame) is function xv_main_loop (frme : Frame) return Xv_opaque; pragma import (C,xv_main_loop,"xv_main_loop"); procedure notify_interpose_destroy_func(client : Frame; func : Notify_Func_ptr); pragma import (C,notify_interpose_destroy_func,"notify_interpose_destroy_func"); procedure XFlush (dsp : Integer); pragma import (C,XFlush,"XFlush"); xv_rc : Xv_opaque := 0; my_loop : Boolean := True; begin notify_interpose_destroy_func(V.base,Destroy_Func'access); xv_rc := Xv_opaque(xv_set(Xv_opaque(V.base),XV_SHOW,True,0)); xv_rc := xv_main_loop(V.base); end Window_Loop; ----------------------------------------------------------------------------- -- icon_image : aliased Image_data(1..512) := ( icon_image : aliased Image_data := ( 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,127,254, 0, 0, 0, 0, 0, 15,128, 1,240, 0, 0, 0, 0,117, 85, 85, 94, 0, 0, 0, 1,128, 0, 0, 1,128, 0, 0, 7, 85, 85, 85, 85, 96, 0, 0, 24, 0, 0, 0, 0, 24, 0, 0,117, 85,117,245,213, 86, 0, 0,128, 0, 97,225,128, 1, 0, 1, 85, 85,119,119, 85, 85,128, 2, 0, 0, 30, 51, 0, 0, 64, 5, 85, 85, 93,119, 85, 85, 96, 8, 0, 0, 30, 18, 0, 0, 16, 21, 85, 85,119, 95, 85, 85, 88, 16, 0, 0, 97,140, 0, 0, 8, 53, 85, 85,117,221, 85, 85, 84, 32, 0, 0, 0, 0, 0, 0, 4, 85, 85, 85, 85, 85, 85, 85, 86, 64, 0, 0, 0, 0, 0, 0, 2, 85, 85, 85, 85, 85, 85, 85, 86, 64, 0, 0, 0, 0, 0, 0, 2, 85, 85, 85, 85, 85, 85, 85, 86, 64, 1,135,192,192, 60,124, 2, 85, 87,215,117,245,103,117, 86, 64, 2, 70, 49, 32,102,192, 2, 53, 86,119,119, 53,103,253, 84, 32, 6,102, 51, 48, 62, 12, 4, 21, 87,247,119,245, 87, 93, 88, 16, 12, 54, 54, 24, 6,204, 8, 13, 93,119,119, 93,119,221, 80, 4, 12, 55,198, 24, 60,120, 32, 3, 85, 85, 85, 85, 85, 85, 64, 1, 0, 0, 0, 0, 0, 0,128, 0,213, 85, 85, 85, 85, 85, 0, 0, 96, 0, 0, 0, 0, 6, 0, 0, 29, 85, 85, 85, 85, 88, 0, 0, 6, 0, 0, 0, 0, 96, 0, 0, 1,213, 85, 85, 85,128, 0, 0, 0,112, 0, 0, 14, 0, 0, 0, 0, 15,213, 85,240, 0, 0, 0, 0, 0,127,254, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0); procedure Initialize (V : in out Xv_Frame) is function xv_create (owner : Xv_opaque; pkg : Xv_pkg_ptr; term : Integer) return Frame; pragma import (C,xv_create,"xv_create"); xv_frame_base_pkg : Xv_pkg_ptr; pragma import (C,xv_frame_base_pkg,"my_xv_frame_base_pkg"); icon_ptr : xv_icon_ptr; image_ptr : xv_server_image_ptr; begin V.Base := xv_create(0, xv_frame_base_pkg,0); if V.Base = 0 then raise NO_OBJECT_CREATED; end if; image_ptr := new Xv_Server_image(Icon_Image'Access,64,64); icon_ptr := new Xv_Icon(Xv_opaque(V.base),Get_Server_Image(Image_Ptr.all)); Set_Title(Icon_Ptr.all,Command_Name); end Initialize; ----------------------------------------------------------------------------- procedure Finalize (V : in out Xv_Frame) is procedure Xv_Destroy_Safe (object : Xv_Opaque); pragma import (C,Xv_Destroy_Safe,"xv_destroy_safe"); begin Xv_Destroy_Safe(Xv_Opaque(V.Base)); end Finalize; ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- -- FRAME_CMD ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- procedure Set_Size (V : in Xv_Frame_Cmd; W,H : Integer) is Xv_rc : Xv_object; begin Xv_rc := xv_set(Xv_opaque(V.base),XV_WIDTH,w,0); Xv_rc := xv_set(Xv_opaque(V.base),XV_HEIGHT,h,0); end Set_Size; ----------------------------------------------------------------------------- procedure Set_Title (V : in Xv_Frame_Cmd; tit : String) is Xv_rc : Xv_object; begin Xv_rc := xv_set(Xv_opaque(V.base),FRAME_LABEL, Interfaces.C.To_C(tit,True),0); end Set_Title; ----------------------------------------------------------------------------- function Get_Size (V : in Xv_Frame_Cmd) return IntegerPair is rc : IntegerPair; begin rc.X := xv_get(Xv_opaque(V.base),XV_WIDTH,0); rc.Y := xv_get(Xv_opaque(V.base),XV_HEIGHT,0); return rc; end Get_Size; ----------------------------------------------------------------------------- function Get_Frame_Cmd_Panel (V : in Xv_Frame_Cmd) return Xv_opaque is begin return V.Cmd_Panel; end Get_Frame_Cmd_Panel; ----------------------------------------------------------------------------- function Get_Title (V : in Xv_Frame_Cmd) return String is begin return Interfaces.C.Strings.Value(xv_get_string(Xv_opaque(V.base), FRAME_LABEL,0)); end Get_Title; ----------------------------------------------------------------------------- procedure Show_Frame_Cmd (V : in Xv_Frame_Cmd) is Xv_rc : Xv_object; begin Xv_rc := xv_set(Xv_opaque(V.base),XV_SHOW,Integer(1),0); end Show_Frame_Cmd; ----------------------------------------------------------------------------- procedure Hide_Frame_Cmd (V : in Xv_Frame_Cmd) is Xv_rc : Xv_object; begin Xv_rc := xv_set(Xv_opaque(V.base),XV_SHOW,Integer(0),0); end Hide_Frame_Cmd; ----------------------------------------------------------------------------- function Get_Frame_Cmd_Status (V : in Xv_Frame_Cmd) return Boolean is Xv_rc : Boolean; begin Xv_rc := xv_get(Xv_opaque(V.base),XV_SHOW,0); return Xv_rc; end Get_Frame_Cmd_Status; ----------------------------------------------------------------------------- procedure Show_Footer (V : in Xv_Frame_Cmd) is Xv_rc : Xv_object; begin Xv_rc := xv_set(Xv_opaque(V.base),FRAME_SHOW_FOOTER,Integer(1),0); end Show_Footer; ----------------------------------------------------------------------------- procedure Hide_Footer (V : in Xv_Frame_Cmd) is Xv_rc : Xv_object; begin Xv_rc := xv_set(Xv_opaque(V.base),FRAME_SHOW_FOOTER,Integer(0),0); end Hide_Footer; ----------------------------------------------------------------------------- procedure Set_Left_Footer (V : in Xv_Frame_Cmd; Tit : String) is Xv_rc : Xv_object; begin Xv_rc := xv_set(Xv_opaque(V.base),FRAME_LEFT_FOOTER, Interfaces.C.To_C(tit,True),0); end Set_Left_Footer; ----------------------------------------------------------------------------- procedure Busy_Frame_Cmd (V : in Xv_Frame_Cmd; State : Boolean) is Xv_Rc : Xv_Object; begin if State = True then Xv_Rc := Xv_Set(Xv_Opaque(V.Base),FRAME_BUSY,Integer(1),0); elsif State = False then Xv_Rc := Xv_Set(Xv_Opaque(V.Base),FRAME_BUSY,Integer(0),0); end if; end Busy_Frame_Cmd; ----------------------------------------------------------------------------- procedure Set_Right_Footer (V : in Xv_Frame_Cmd; Tit : String) is Xv_rc : Xv_object; begin Xv_rc := xv_set(Xv_opaque(V.base),FRAME_RIGHT_FOOTER, Interfaces.C.To_C(tit,True),0); end Set_Right_Footer; ----------------------------------------------------------------------------- procedure Initialize (V : in out Xv_Frame_Cmd) is function xv_create (owner : Frame; pkg : Xv_pkg_ptr; term : Integer) return Frame_cmd; pragma import (C,xv_create,"xv_create"); xv_frame_cmd_pkg : Xv_pkg_ptr; pragma import (C,xv_frame_cmd_pkg,"my_xv_frame_cmd_pkg"); begin V.Base := xv_create(V.Parent, xv_frame_cmd_pkg,0); if V.Base = 0 then raise NO_OBJECT_CREATED; end if; V.Cmd_Panel := xv_get(Xv_opaque(V.Base),FRAME_CMD_PANEL,0); end Initialize; ----------------------------------------------------------------------------- procedure Finalize (V : in out Xv_Frame_Cmd) is procedure Xv_Destroy_Safe (object : Xv_Opaque); pragma import (C,Xv_Destroy_Safe,"xv_destroy_safe"); begin Xv_Destroy_Safe(Xv_Opaque(V.Base)); end Finalize; ----------------------------------------------------------------------------- function Get_Frame_Cmd (V : in Xv_Frame_Cmd) return Frame_Cmd is begin return V.base; end Get_Frame_Cmd; end Xv_Frame_Package;