|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 18312 (0x4788)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─ ⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦059497ac5⟧
└─⟦this⟧
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_Basic;
use Xlbt_Basic;
with Xlbt_Basic2;
use Xlbt_Basic2;
with Xlbt_Key;
use Xlbt_Key;
with Xlbt_Misc;
use Xlbt_Misc;
with Xlbt_Reply;
use Xlbt_Reply;
with Xlbt_Request;
use Xlbt_Request;
with Xlbt_Window;
use Xlbt_Window;
with Xlbip_Get_Reply;
use Xlbip_Get_Reply;
with Xlbip_Internal;
use Xlbip_Internal;
with Xlbip_Put_Request;
use Xlbip_Put_Request;
with Xlbmt_Network_Types;
use Xlbmt_Network_Types;
package body Xlbp_Window_Information is
------------------------------------------------------------------------------
-- X Library Miscellaneous Window Information
--
-- Xlbp_Window_Information - Provide useful miscellaneous information
------------------------------------------------------------------------------
-- Copyright 1989 - 1991 by Rational, Santa Clara, California.
-- Copyright 1985 - 1989 by the Massachusetts Institute of Technology
--
-- All Rights Reserved.
--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright notice(s) appear in all copies and that
-- both that copyright notice(s) and this permission notice appear in
-- supporting documentation, and that the names of MIT or Rational not be
-- used in advertising or publicity pertaining to distribution of the software
-- without specific, written prior permission.
--
-- MIT and Rational disclaim all warranties with regard to this software,
-- including all implied warranties of merchantability and fitness, in no
-- event shall MIT or Rational be liable for any special, indirect or
-- consequential damages or any damages whatsoever resulting from loss of use,
-- data or profits, whether in an action of contract, negligence or other
-- tortious action, arising out of or in connection with the use or performance
-- of this software.
------------------------------------------------------------------------------
--\f
procedure X_Get_Geometry (Display : X_Display;
Drawable : X_Drawable;
Root : out X_Window;
X : out S_Short;
Y : out S_Short;
Width : out U_Short;
Height : out U_Short;
Border_Width : out U_Short;
Depth : out U_Char;
Status : out X_Status) is
-------------------------------------------------------------------------------
-- X_Get_Geometry
------------------------------------------------------------------------------
Rep : X_Reply_Contents;
Succ : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Get_Geometry_Request
(Display, (Kind => Get_Geometry,
Length => X_Get_Geometry_Request'Size / 32,
Pad => 0,
Id => Drawable));
----Get the reply.
Get_Reply (Display => Display,
Code => Get_Geometry,
Reply => Rep,
Extra => 0,
Discard => True,
Status => Succ);
----If we failed then return that to the user.
if Succ = Failed then
Root := None_X_Window;
X := 0;
Y := 0;
Width := 0;
Height := 0;
Border_Width := 0;
Depth := 0;
Status := Failed;
Unlock_Display (Display);
Sync_Handle (Display);
return;
end if;
----Copy the info to our output parameters.
Root := Rep.Get_Geometry.Root;
X := Rep.Get_Geometry.X;
Y := Rep.Get_Geometry.Y;
Width := Rep.Get_Geometry.Width;
Height := Rep.Get_Geometry.Height;
Border_Width := Rep.Get_Geometry.Border_Width;
Depth := Rep.Get_Geometry.Depth;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; and return success.
Status := Successful;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Get_Geometry;
--\f
procedure X_Get_Window_Attributes (Display : X_Display;
Window : X_Window;
Values : in out X_Window_Attributes;
Status : out X_Status) is
------------------------------------------------------------------------------
-- X_Get_Window_Attributes
------------------------------------------------------------------------------
Rep : X_Reply_Contents;
Succ : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the Window Attributes request.
Put_X_Get_Window_Attributes_Request
(Display, (Kind => Get_Window_Attributes,
Length => X_Get_Window_Attributes_Request'Size / 32,
Pad => 0,
Id => Window));
----Get the reply to our query.
Get_Reply (Display => Display,
Code => Get_Window_Attributes,
Reply => Rep,
Extra => 0,
Discard => True,
Status => Succ);
----If that failed then return that as our status.
if Succ = Failed then
Status := Failed;
Unlock_Display (Display);
Sync_Handle (Display);
return;
end if;
----Return those attributes that we have.
Values.Class := Rep.Get_Window_Attributes.Class;
Values.Bit_Gravity := Rep.Get_Window_Attributes.Bit_Gravity;
Values.Win_Gravity := Rep.Get_Window_Attributes.Win_Gravity;
Values.Backing_Store := Rep.Get_Window_Attributes.Backing_Store;
Values.Backing_Planes :=
Rep.Get_Window_Attributes.Backing_Bit_Planes;
Values.Backing_Pixel := Rep.Get_Window_Attributes.Backing_Pixel;
Values.Save_Under := To_Boolean
(Rep.Get_Window_Attributes.Save_Under);
Values.Colormap := Rep.Get_Window_Attributes.Colormap;
Values.Map_Installed :=
To_Boolean (Rep.Get_Window_Attributes.Map_Installed);
Values.Map_State := Rep.Get_Window_Attributes.Map_State;
Values.All_Event_Masks := Rep.Get_Window_Attributes.All_Event_Masks;
Values.Your_Event_Mask := Rep.Get_Window_Attributes.Your_Event_Mask;
Values.Do_Not_Propagate_Mask :=
X_Event_Mask_Short_To_Long
(Rep.Get_Window_Attributes.Do_Not_Propagate_Mask);
Values.Override_Redirect := To_Boolean
(Rep.Get_Window_Attributes.Override);
Internal_X_Vid_To_Visual
(Display, Rep.Get_Window_Attributes.Visual_Id,
Values.Visual, Succ);
----Now send the Geometry request.
Put_X_Get_Geometry_Request
(Display, (Kind => Get_Geometry,
Length => X_Get_Geometry_Request'Size / 32,
Pad => 0,
Id => Window.Drawable));
----Get the reply.
Get_Reply (Display => Display,
Code => Get_Geometry,
Reply => Rep,
Extra => 0,
Discard => True,
Status => Succ);
----If we failed this part then return failed as our status.
if Succ = Failed then
Status := Failed;
Unlock_Display (Display);
Sync_Handle (Display);
return;
end if;
----Return the attributes that this gave us.
Values.X := Rep.Get_Geometry.X;
Values.Y := Rep.Get_Geometry.Y;
Values.Width := Rep.Get_Geometry.Width;
Values.Height := Rep.Get_Geometry.Height;
Values.Border_Width := Rep.Get_Geometry.Border_Width;
Values.Depth := Rep.Get_Geometry.Depth;
Values.Root := Rep.Get_Geometry.Root;
----Find the correct screen so that applications have an easier time.
for I in Display.Screens'Range loop
if Display.Screens (I).Root = Rep.Get_Geometry.Root then
Values.Screen := Display.Screens (I);
exit;
end if;
end loop;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return a successful status.
Status := Successful;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Get_Window_Attributes;
--\f
procedure X_Query_Pointer (Display : X_Display;
Window : X_Window;
Root : out X_Window;
Child : out X_Window;
Root_X : out U_Short;
Root_Y : out U_Short;
Window_X : out S_Short;
Window_Y : out S_Short;
Mask : out X_Key_Button_Mask;
Same_Screen : out Boolean) is
------------------------------------------------------------------------------
-- X_Query_Pointer
------------------------------------------------------------------------------
Rep : X_Reply_Contents;
Succ : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Query_Pointer_Request
(Display, (Kind => Query_Pointer,
Length => X_Query_Pointer_Request'Size / 32,
Pad => 0,
Id => Window));
----Read the reply to our request.
Get_Reply (Display => Display,
Code => Query_Pointer,
Reply => Rep,
Extra => 0,
Discard => True,
Status => Succ);
----If we didn't get a reply then return all 0's.
if Succ = Failed then
Root := None_X_Window;
Child := None_X_Window;
Root_X := 0;
Root_Y := 0;
Window_X := 0;
Window_Y := 0;
Mask := None_X_Key_Button_Mask;
Same_Screen := False;
Unlock_Display (Display);
Sync_Handle (Display);
return;
end if;
----Return our results.
Root := Rep.Query_Pointer.Root;
Child := Rep.Query_Pointer.Child;
Root_X := Rep.Query_Pointer.Root_X;
Root_Y := Rep.Query_Pointer.Root_Y;
Window_X := Rep.Query_Pointer.Win_X;
Window_Y := Rep.Query_Pointer.Win_Y;
Same_Screen := To_Boolean (Rep.Query_Pointer.Same_Screen);
Mask := Rep.Query_Pointer.Mask;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Query_Pointer;
--\f
procedure X_Query_Tree (Display : X_Display;
Window : X_Window;
Root : out X_Window;
Parent : out X_Window;
Children : out X_Window_List;
Status : out X_Status) is
------------------------------------------------------------------------------
-- X_Query_Tree
------------------------------------------------------------------------------
Rep : X_Reply_Contents;
N_Chillin : S_Natural;
Succ : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Query_Tree_Request
(Display, (Kind => Query_Tree,
Length => X_Query_Tree_Request'Size / 32,
Pad => 0,
Window => Window));
----Read the reply header.
Get_Reply (Display => Display,
Code => Query_Tree,
Reply => Rep,
Extra => 0,
Discard => False,
Status => Succ);
----If we failed then return that info.
if Succ = Failed then
Unlock_Display (Display);
Sync_Handle (Display);
Root := None_X_Window;
Parent := None_X_Window;
Children := None_X_Window_List;
Status := Failed;
return;
end if;
----Return our new information.
declare
Chillin : X_Window_List;
begin
N_Chillin := S_Natural (Rep.Query_Tree.N_Children);
Parent := Rep.Query_Tree.Parent;
Root := Rep.Query_Tree.Root;
Status := Successful;
begin
Chillin := new X_Window_Array (1 .. N_Chillin);
exception
when others =>
Eat_Raw_Data (Display, N_Chillin * (X_Window'Size / 8));
raise;
end;
----Convert the children list and return it on the heap. Yes, the subtype
-- is crucial. If you remove it then your code will look correct but it will
-- not work; magic memory type layout, yuck.
if N_Chillin /= 0 then
Get_X_Window_Array (Display, Chillin.all);
end if;
Children := Chillin;
exception
when others =>
Free_X_Window_List (Chillin);
raise;
end;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Normal return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Query_Tree;
--\f
procedure X_Translate_Coordinates (Display : X_Display;
Source : X_Window;
Destination : X_Window;
Source_X : S_Short;
Source_Y : S_Short;
Destination_X : out S_Short;
Destination_Y : out S_Short;
Child : out X_Window;
Same_Screen : out Boolean) is
------------------------------------------------------------------------------
-- X_Translate_Coordinates
------------------------------------------------------------------------------
Rep : X_Reply_Contents;
Succ : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Translate_Coords_Request
(Display, (Kind => Translate_Coords,
Length => X_Translate_Coords_Request'Size / 32,
Pad => 0,
Src_Window => Source,
Dst_Window => Destination,
Src_X => Source_X,
Src_Y => Source_Y));
----Read the reply.
Get_Reply (Display => Display,
Code => Translate_Coords,
Reply => Rep,
Extra => 0,
Discard => True,
Status => Succ);
----If we failed then return all 0's.
if Succ = Failed then
Destination_X := 0;
Destination_Y := 0;
Child := None_X_Window;
Same_Screen := False;
----Return our results.
else
Child := Rep.Translate_Coords.Child;
Destination_X := Rep.Translate_Coords.Dst_X;
Destination_Y := Rep.Translate_Coords.Dst_Y;
Same_Screen := To_Boolean (Rep.Translate_Coords.Same_Screen);
end if;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; and return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Translate_Coordinates;
--\f
end Xlbp_Window_Information;