|
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 - metrics - downloadIndex: B T
Length: 31612 (0x7b7c)
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_Atom_Defs;
use Xlbt_Atom_Defs;
with Xlbt_Basic;
use Xlbt_Basic;
with Xlbt_Error;
use Xlbt_Error;
with Xlbt_Event;
use Xlbt_Event;
with Xlbt_Exceptions;
use Xlbt_Exceptions;
with Xlbt_Misc;
use Xlbt_Misc;
with Xlbt_Proc_Var;
use Xlbt_Proc_Var;
with Xlbt_Reply;
use Xlbt_Reply;
with Xlbt_Request;
use Xlbt_Request;
with Xlbt_String;
use Xlbt_String;
with Xlbt_Window;
use Xlbt_Window;
with Xlbp_Proc_Var;
use Xlbp_Proc_Var;
with Xlbp_U_Char_Converters;
use Xlbp_U_Char_Converters;
with Xlbit_Library3;
use Xlbit_Library3;
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_Property is
------------------------------------------------------------------------------
-- X Library Window Properties
--
-- Xlbp_Window_Property - Working with window properties
------------------------------------------------------------------------------
-- Copyright 1989 - 1991 by Rational, Santa Clara, California.
-- Copyright 1988 by Wyse Technology, Inc., San Jose, Ca.,
-- 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, Rational, or Wyse
-- not be used in advertising or publicity pertaining to distribution of
-- the software without specific, written prior permission.
--
-- MIT, Rational, and Wyse disclaim all warranties with regard to this
-- software, including all implied warranties of merchantability and fitness,
-- in no event shall MIT, Rational, or Wyse 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_Change_Property (Display : X_Display;
Window : X_Window;
Property : X_Atom;
Representation : X_Atom;
Format : U_Char; -- 8, 16, 32
Mode : X_Property_Mode;
Data : U_Char_Array) is
------------------------------------------------------------------------------
-- X_Change_Property
------------------------------------------------------------------------------
Extra_Words : S_Natural := (Data'Length + 3) / 4;
Element_Count : S_Long;
begin
----Make sure that our arguments make sense.
case Format is
when 8 =>
Element_Count := Data'Length;
when 16 =>
if Data'Length rem 2 /= 0 then
raise Constraint_Error; -- Data has an odd length.
end if;
Element_Count := Data'Length / 2;
when 32 =>
if Data'Length rem 4 /= 0 then
raise Constraint_Error; -- Data has non-modulo-4 length
end if;
Element_Count := Data'Length / 4;
when others =>
raise Constraint_Error; -- He passed in a garbage format.
end case;
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Change_Property_Request
(Display, (Kind => Change_Property,
Length => X_Change_Property_Request'Size / 32 +
U_Short (Extra_Words),
Pad1 => 0,
Pad2 => 0,
Pad3 => 0,
Mode => Mode,
Window => Window,
Property => Property,
Representation => Representation,
Format => Format,
N_Units => Element_Count),
Extra_Words * 4);
----Send the extra data for the reply.
Put_U_Char_Array (Display, Data);
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Change_Property;
--\f
procedure X_Delete_Property (Display : X_Display;
Window : X_Window;
Property : X_Atom) is
------------------------------------------------------------------------------
-- X_Delete_Property
------------------------------------------------------------------------------
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Delete_Property_Request
(Display, (Kind => Delete_Property,
Length => X_Delete_Property_Request'Size / 32,
Pad => 0,
Window => Window,
Property => Property));
----Catch unexpected exceptions;
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Delete_Property;
--\f
procedure Free_X_Text_Property (Prop : in out X_Text_Property) is
------------------------------------------------------------------------------
-- Prop - Specifies the X_Text_Property whose contents are to be freed
--
-- Called to free up any heap storage contained within an X_Text_Property.
-- Since an X_Text_Property is a record type and not an access type the
-- X_Text_Property itself is not freed; only its contents.
------------------------------------------------------------------------------
begin
Free_U_Char_List (Prop.Value);
end Free_X_Text_Property;
--\f
procedure X_Get_Window_Property (Display : X_Display;
Window : X_Window;
Property : X_Atom;
Offset : S_Natural;
Maximum_Length : S_Natural;
Delete : Boolean;
Representation : X_Atom;
Actual_Type : out X_Atom;
Actual_Format : out U_Char;
N_Items : out S_Natural;
Bytes_After : out S_Natural;
Data : out U_Char_List;
Status : out X_Status) is
------------------------------------------------------------------------------
-- X_Get_Window_Property
-- Call Get_Data_Raw (and friends) to retrieve the data.
------------------------------------------------------------------------------
Uca : U_Char_List;
Errorstatus : X_Status;
Reply : X_Reply_Contents;
Extra_Return : S_Natural;
Bytes_Total : S_Natural;
Format : U_Char;
Ni : S_Natural;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Get_Property_Request
(Display, (Kind => Get_Property,
Length => X_Get_Property_Request'Size / 32,
Window => Window,
Property => Property,
Representation => Representation,
Delete => From_Boolean (Delete),
Data_Offset => Offset,
Data_Length => Maximum_Length));
----Read the reply header.
Get_Reply (Display => Display,
Code => Get_Property,
Reply => Reply,
Extra => 0,
Discard => False,
Status => Errorstatus);
----If we failed for some reason then return that failure.
if Errorstatus = Failed then
Actual_Type := None_X_Atom;
Actual_Format := 8;
N_Items := 0;
Bytes_After := 0;
Data := None_U_Char_List;
Status := Failed;
Unlock_Display (Display);
Sync_Handle (Display);
return;
end if;
----Return the information from the reply.
Actual_Type := Reply.Get_Property.Property_Type;
Actual_Format := Reply.Get_Property.Format;
Format := Reply.Get_Property.Format;
Extra_Return := S_Natural (Reply.Get_Property.N_Items);
N_Items := Extra_Return;
Ni := Extra_Return;
Bytes_After := S_Natural (Reply.Get_Property.Bytes_After);
----Validate the format.
if Reply.Get_Property.Property_Type /= None_X_Atom then
case Reply.Get_Property.Format is
when 8 =>
null;
when 16 =>
null;
when 32 =>
null;
----This part of the code should never be reached. If it is, the server
-- sent back a property with an invalid format. This is a Bad_Implementation
-- error.
when others =>
declare
Error : X_Error_Contents :=
(Kind => Bad_Implementation,
Send_Event => False,
Serial => Display.Request,
Nothing =>
(Kind => Error_Event,
Code => Bad_Implementation,
Sequence_Number =>
U_Short (Display.Request rem
(S_Long (U_Short'Last) + 1)),
Pad0 => (others => 0),
Major_Opcode => Get_Property,
Minor_Opcode => 0,
Pad => (others => 0)));
Proc : X_Procedure_Variable;
begin
X_Lib.Get_Error (Display, Proc);
Proc_Var_X_Error_Function.Call
(Proc_Var_X_Error_Function.To_Pv (Proc),
Display, Error);
end;
Actual_Type := None_X_Atom;
Actual_Format := 8;
N_Items := 0;
Bytes_After := 0;
Status := Failed;
Unlock_Display (Display);
Sync_Handle (Display);
return;
end case;
end if;
----Figure the number of bytes in the message.
if Ni = 0 then
Data := None_U_Char_List;
else
case Format is
when 8 =>
Bytes_Total := Ni;
when 16 =>
Bytes_Total := Ni * 2;
when 32 =>
Bytes_Total := Ni * 4;
when others =>
raise X_Library_Confusion;
end case;
----Allocate the space for the data and then read it.
begin
Uca := new U_Char_Array (1 .. Bytes_Total);
exception
when others =>
Eat_Raw_Data (Display, Bytes_Total);
raise;
end;
Data := Uca;
Get_U_Char_Array (Display, Uca.all);
end if;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; and return success.
Unlock_Display (Display);
Sync_Handle (Display);
Status := Successful;
end X_Get_Window_Property;
--\f
procedure X_Get_Text_Property (Display : X_Display;
Window : X_Window;
Data : out X_String_Pointer;
Property : X_Atom;
Status : out X_Status) is
------------------------------------------------------------------------------
-- Display - Specifies the display to use.
-- Window - Specifies the window to use.
-- Data - Receives a record of the received data
-- Property - Specifies the property atom.
-- Status - Returns Successful if we succeeded and Failed if not.
--
-- Called to obtain the "textual" data associated with some window's
-- (window-manager) property. The Data'length received is equal to:
-- Length = (Data.Format / 8) * Data.N_Items
------------------------------------------------------------------------------
Prop : X_Text_Property;
Stat : X_Status;
begin
X_Get_Text_Property (Display, Window, Prop, Property, Stat);
if Stat /= Successful then
Status := Failed;
Data := None_X_String_Pointer;
return;
end if;
X_Text_Property_To_String (Prop, Data, Status);
Free_X_Text_Property (Prop);
exception
when others =>
Free_X_Text_Property (Prop);
raise;
end X_Get_Text_Property;
--\f
procedure X_Get_Text_Property (Display : X_Display;
Window : X_Window;
Data : out X_Text_Property;
Property : X_Atom;
Status : out X_Status) is
------------------------------------------------------------------------------
-- Display - Specifies the display to use.
-- Window - Specifies the window to use.
-- Data - Receives a record of the received data
-- Property - Specifies the property atom.
-- Status - Returns Successful if we succeeded and Failed if not.
--
-- Called to obtain the "textual" data associated with some window's
-- (window-manager) property. The Data'length received is equal to:
-- Length = (Data.Format / 8) * Data.N_Items
------------------------------------------------------------------------------
Actual_Type : X_Atom;
Actual_Format : U_Char;
N_Items : S_Natural;
Leftover : S_Natural;
Uca : U_Char_List;
Stat : X_Status;
begin
X_Get_Window_Property (Display, Window, Property, 0, 1_000_000,
False, Any_Property_Type, Actual_Type,
Actual_Format, N_Items, Leftover, Uca, Stat);
if Stat /= Successful or else Actual_Type = None_X_Atom then
Data := (Encoding => None_X_Atom,
Format => 0,
N_Items => 0,
Value => None_U_Char_List);
Status := Failed;
else
Data := (Encoding => Actual_Type,
Format => Actual_Format,
N_Items => N_Items,
Value => Uca);
Status := Successful;
end if;
end X_Get_Text_Property;
--\f
function X_List_Properties (Display : X_Display;
Window : X_Window) return X_Atom_List is
------------------------------------------------------------------------------
-- X_List_Properties
------------------------------------------------------------------------------
Rep : X_Reply_Contents;
Stat : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_List_Properties_Request
(Display, (Kind => List_Properties,
Length => X_List_Properties_Request'Size / 32,
Pad => 0,
Id => Window));
----Read the reply header.
Get_Reply (Display => Display,
Code => List_Properties,
Reply => Rep,
Extra => 0,
Discard => False,
Status => Stat);
----If we failed then return null as if the reply was no-properties.
if Stat = Failed or else
Rep.List_Properties.N_Properties = 0 then
Unlock_Display (Display);
Sync_Handle (Display);
return None_X_Atom_List;
end if;
----Allocate an array of the correct size and read the properties.
declare
List : X_Atom_List;
Nbytes : constant S_Natural :=
S_Natural (Rep.List_Properties.N_Properties) *
X_Atom'Size / 8;
begin
begin
List := new X_Atom_Array
(1 .. S_Natural
(Rep.List_Properties.N_Properties));
exception
when others =>
Eat_Raw_Data (Display, S_Natural (Rep.List_Properties.
N_Properties) *
(X_Atom'Size / 8));
raise;
end;
Get_X_Atom_Array (Display, List.all);
Unlock_Display (Display);
Sync_Handle (Display);
return List;
exception
when others =>
Free_X_Atom_List (List);
raise;
end;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
end X_List_Properties;
--\f
procedure X_Rotate_Window_Properties (Display : X_Display;
Window : X_Window;
Properties : X_Atom_Array;
N_Positions : S_Short) is
------------------------------------------------------------------------------
-- X_Rotate_Properties
------------------------------------------------------------------------------
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Rotate_Properties_Request
(Display,
(Kind => Rotate_Properties,
Length =>
X_Rotate_Properties_Request'Size / 32 + Properties'Length,
Pad => 0,
Window => Window,
N_Atoms => Properties'Length,
N_Positions => N_Positions));
----Send the extra data for the request. The subtype is crucial. If you get
-- rid of it and "eliminate the unnecessary copy" then you will send the
-- bounds of Properties as well as the data portion of Properties. Prop has
-- no embedded bounds information; it is pure data.
Put_X_Atom_Array (Display, Properties);
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; and return.
Unlock_Display (Display);
Sync_Handle (Display);
end X_Rotate_Window_Properties;
--\f
procedure X_Set_Text_Property (Display : X_Display;
Window : X_Window;
Data : X_String;
Property : X_Atom) is
------------------------------------------------------------------------------
-- Display - Specifies the display to use.
-- Window - Specifies the window to use.
-- Data - Specifies a record of the new data
-- Property - Specifies the property atom.
--
-- Called to set the "textual" data associated with some window's
-- (window-manager) property. The Data'length sent is expected to be equal to:
-- Length = (Data.Format / 8) * Data.N_Items
--
-- Free the storage in the Data after use with the Free_X_Text_Property routine.
------------------------------------------------------------------------------
Prop : X_Text_Property;
begin
X_String_To_Text_Property (Data, Prop);
X_Change_Property (Display, Window, Property, Prop.Encoding,
Prop.Format, Prop_Mode_Replace, Prop.Value.all);
Free_X_Text_Property (Prop);
exception
when others =>
Free_X_Text_Property (Prop);
raise;
end X_Set_Text_Property;
--\f
procedure X_Set_Text_Property (Display : X_Display;
Window : X_Window;
Data : X_Text_Property;
Property : X_Atom) is
------------------------------------------------------------------------------
-- Display - Specifies the display to use.
-- Window - Specifies the window to use.
-- Data - Specifies a record of the new data
-- Property - Specifies the property atom.
--
-- Called to set the "textual" data associated with some window's
-- (window-manager) property. The Data'length sent is expected to be equal to:
-- Length = (Data.Format / 8) * Data.N_Items
--
-- Free the storage in the Data after use with the Free_X_Text_Property routine.
------------------------------------------------------------------------------
begin
X_Change_Property (Display, Window, Property, Data.Encoding,
Data.Format, Prop_Mode_Replace, Data.Value.all);
end X_Set_Text_Property;
--\f
procedure X_String_List_To_Text_Property (List : X_String_Pointer_Array;
Data : out X_Text_Property) is
------------------------------------------------------------------------------
-- List - Specifies the list of strings to convert
-- Data - Receives the converted list
--
-- Converts the list of strings into a X_Text_Property. Each string is
-- included verbatim with an added trailing Ascii.Nul added to the end.
-- The final string does not have a trailing null.
--
-- Free the storage in the list after use with the Free_X_String(8)_List
-- routine.
-- Free the storage in the Data after use with the Free_X_Text_Property routine.
------------------------------------------------------------------------------
N_Chars : S_Natural;
Ldata : X_Text_Property;
begin
----Compute the number of characters that we will be placing into the property.
if List'Length > 0 then
N_Chars := List'Length - 1;
for I in List'Range loop
N_Chars := N_Chars + List (I)'Length;
end loop;
else
N_Chars := 0;
end if;
----Allocate a UCA list that is that big.
Ldata.Encoding := Xa_String;
Ldata.Format := 8;
Ldata.N_Items := N_Chars;
Ldata.Value := new U_Char_Array (1 .. N_Chars);
Data := Ldata;
----Now copy the strings into the Value.
if List'Length = 0 then
return;
end if;
N_Chars := 0;
for I in List'First .. List'Last - 1 loop
To_Uca (Ldata.Value (N_Chars + 1 .. N_Chars + List (I)'Length),
List (I).all);
N_Chars := N_Chars + List (I)'Length + 1;
Ldata.Value (N_Chars) := 0;
end loop;
To_Uca (Ldata.Value (N_Chars + 1 .. N_Chars + List (List'Last)'Length),
List (List'Last).all);
exception
when others =>
Free_X_Text_Property (Ldata);
Data := None_X_Text_Property;
raise;
end X_String_List_To_Text_Property;
--\f
procedure X_Text_Property_To_String_List (Data : X_Text_Property;
List : out X_String_Pointer_List;
Status : out X_Status) is
------------------------------------------------------------------------------
-- Data - Specifies the converted list
-- List - Receives NULL or the result list
-- Status - Receives Successful if we succeeded and Failed if not.
--
-- Converts the X_Text_Property into a list of strings. Returns NULL if
-- Successful but the list is empty or if Failed.
--
-- Free the storage in the Data after use with the Free_X_Text_Property routine.
-- Free the storage in the list after use with the Free_X_String(8)_List
-- routine.
------------------------------------------------------------------------------
N_Elem : S_Natural;
End_Elem : S_Natural;
New_List : X_String_Pointer_List;
begin
----Make sure we understand how to do it.
if Data.Encoding /= Xa_String or else Data.Format /= 8 then
List := None_X_String_Pointer_List;
Status := Failed;
return;
end if;
----If there is no list then return null.
if Data.N_Items = 0 then
List := None_X_String_Pointer_List;
Status := Successful;
return;
end if;
----Count the number of strings.
N_Elem := 1;
End_Elem := Data.Value'First + Data.N_Items - 1;
for I in Data.Value'First .. End_Elem loop
if Data.Value (I) = 0 then
N_Elem := N_Elem + 1;
end if;
end loop;
----Allocate the result array and then go locate the various strings.
New_List := new X_String_Pointer_Array (1 .. N_Elem);
N_Elem := Data.Value'First;
for I in New_List'First .. New_List'Last - 1 loop
for J in N_Elem .. End_Elem loop
if Data.Value (J) = 0 then
New_List (I) := new X_String (1 .. J - N_Elem - 1);
From_Uca (New_List (I).all, Data.Value (N_Elem .. J - 1));
exit;
end if;
end loop;
end loop;
New_List (New_List'Last) := new X_String (1 .. End_Elem - N_Elem - 1);
From_Uca (New_List (New_List'Last).all,
Data.Value (N_Elem .. End_Elem));
----Return our result.
List := New_List;
Status := Successful;
exception
when others =>
Free_X_String_Pointer_List (New_List);
raise;
end X_Text_Property_To_String_List;
--\f
procedure X_String_To_Text_Property (Str : X_String;
Data : out X_Text_Property) is
------------------------------------------------------------------------------
-- Str - Specifies the string to convert
-- Data - Receives the converted list
--
-- Converts the string into a X_Text_Property.
--
-- Free the storage in the list after use with the Free_X_String(8)_List
-- routine.
-- Free the storage in the Data after use with the Free_X_Text_Property routine.
------------------------------------------------------------------------------
Ldata : X_Text_Property;
begin
----Allocate a UCA list that is that big.
Ldata.Encoding := Xa_String;
Ldata.Format := 8;
Ldata.N_Items := Str'Length;
Ldata.Value := new U_Char_Array (1 .. Str'Length);
Data := Ldata;
----Now copy the string into the Value.
To_Uca (Ldata.Value.all, Str);
exception
when others =>
Free_X_Text_Property (Ldata);
Data := None_X_Text_Property;
raise;
end X_String_To_Text_Property;
--\f
procedure X_Text_Property_To_String (Data : X_Text_Property;
Str : out X_String_Pointer;
Status : out X_Status) is
------------------------------------------------------------------------------
-- Data - Specifies the converted list
--
-- Converts the X_Text_Property into a single string.
-- Free the storage in the Data after use with the Free_X_Text_Property routine.
-- Free the storage in the string after use with the Free_X_String(8)_Pointer
-- routine.
------------------------------------------------------------------------------
New_Str : X_String_Pointer;
begin
----Make sure we understand how to do it.
if Data.Encoding /= Xa_String or else Data.Format /= 8 then
Str := None_X_String_Pointer;
Status := Failed;
return;
end if;
----If there is no list then return null.
if Data.N_Items = 0 then
Str := None_X_String_Pointer;
Status := Successful;
return;
end if;
----Allocate the string and convert it.
New_Str := new X_String (1 .. Data.N_Items);
From_Uca (New_Str.all, Data.Value.all);
Str := New_Str;
Status := Successful;
exception
when Constraint_Error =>
----We assume this to be a uca->string conversion error.
Free_X_String_Pointer (New_Str);
Str := null;
Status := Failed;
return;
when others =>
Free_X_String_Pointer (New_Str);
raise;
end X_Text_Property_To_String;
--\f
end Xlbp_Window_Property;