|
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: 49523 (0xc173)
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_Hint3;
use Xlbt_Hint3;
with Xlbt_String;
use Xlbt_String;
with Xlbt_Window;
use Xlbt_Window;
with Xlbp_Atom;
use Xlbp_Atom;
with Xlbp_U_Char_Converters;
use Xlbp_U_Char_Converters;
with Xlbp_Window_Property;
use Xlbp_Window_Property;
with Xlbit_Hint2;
use Xlbit_Hint2;
with Xlbip_Internal;
use Xlbip_Internal;
with Xlbmp_Environment;
use Xlbmp_Environment;
package body Xlbp_Hint is
------------------------------------------------------------------------------
-- X Library Hints - Window Manager Hints
--
-- Xlbp_Hint - Support for the various Window Manager properties of a window.
------------------------------------------------------------------------------
-- Copyright 1989 - 1991 by Rational, Santa Clara, California.
-- Copyright 1987 - 1989 by Digital Equipment Corporation, Maynard, Mass.
-- Copyright 1987 - 1989 by Massachusetts Institute of Technology,
-- Cambridge, Massachusetts.
-- Copyright 1988 - 1988 by Wyse Technology, Inc., San Jose, Ca.,
--
-- 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 Digital, MIT, Rational, or
-- Wyse not be used in advertising or publicity pertaining to distribution of
-- the software without specific, written prior permission.
--
-- Digital, MIT, Rational, and Wyse disclaim all warranties with regard to this
-- software, including all implied warranties of merchantability and fitness,
-- in no event shall Digital, 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_Get_Class_Hint (Display : X_Display;
Window : X_Window;
Class_Hint : out X_Class_Hint;
Status : out X_Status) is
Hint : X_Class_Hint;
Actual_Type : X_Atom;
Actual_Format : U_Char;
N_Items : S_Natural;
Leftover : S_Natural;
Buff : U_Char_List;
Succ : X_Status;
begin
----Get the property.
X_Get_Window_Property (Display, Window, Xa_Wm_Class, 0,
S_Long'Last - 4, False, Xa_String, Actual_Type,
Actual_Format, N_Items, Leftover, Buff, Succ);
----We must have it and it must be in the right format.
if Succ = Successful and then
Actual_Type = Xa_String and then
Actual_Format = 8 then
----Search for the separating null.
for I in Buff'Range loop
if Buff (I) = 0 then
Hint.Res_Name := new X_String (1 .. I - 1);
From_Uca (Hint.Res_Name.all, Buff (1 .. I - 1));
if I = Buff'Last then
----If the Res_Class is empty then there may
-- only be one string.
Hint.Res_Class := new X_String'(Hint.Res_Name.all);
elsif Buff (Buff'Last) = 0 then
Hint.Res_Class := new X_String (1 .. Buff'Last - I - 1);
From_Uca (Hint.Res_Class.all,
Buff (I + 1 .. Buff'Last - 1));
else
Hint.Res_Class := new X_String (1 .. Buff'Last - I);
From_Uca (Hint.Res_Class.all,
Buff (I + 1 .. Buff'Last));
end if;
Free_U_Char_List (Buff);
Class_Hint := Hint;
Status := Successful;
return;
end if;
end loop;
end if;
----We come here if the property is missing or bad.
Free_U_Char_List (Buff);
Class_Hint := None_X_Class_Hint;
Status := Failed;
exception
when others =>
Free_X_String_Pointer (Hint.Res_Name);
Free_X_String_Pointer (Hint.Res_Class);
raise;
end X_Get_Class_Hint;
--\f
procedure X_Set_Class_Hint (Display : X_Display;
Window : X_Window;
Class_Hint : X_Class_Hint;
Status : out X_Status) is
Llen : S_Natural := Class_Hint.Res_Name'Length;
Clen : S_Natural := Class_Hint.Res_Class'Length;
Uca : U_Char_Array (1 .. 2 + Llen + Clen);
Ucai : S_Natural := 0;
begin
for I in Class_Hint.Res_Name'Range loop
Ucai := Ucai + 1;
Uca (Ucai) := X_Character'Pos (Class_Hint.Res_Name (I));
end loop;
Ucai := Ucai + 1;
Uca (Ucai) := 0;
for I in Class_Hint.Res_Class'Range loop
Ucai := Ucai + 1;
Uca (Ucai) := X_Character'Pos (Class_Hint.Res_Class (I));
end loop;
Ucai := Ucai + 1;
Uca (Ucai) := 0;
X_Change_Property (Display => Display,
Window => Window,
Property => Xa_Wm_Class,
Representation => Xa_String,
Format => 8,
Mode => Prop_Mode_Replace,
Data => Uca);
Status := Successful;
end X_Set_Class_Hint;
--\f
procedure X_Get_Wm_Colormap_Windows (Display : X_Display;
Window : X_Window;
Windows : out X_Window_List;
Status : out X_Status) is
------------------------------------------------------------------------------
-- Display - Specifies the display to use.
-- W - Specifies the window to use.
-- Windows - Receives None_X_Window_List or a list of windows
-- Status - Receives Successful if we succeeded; Failed if not.
--
-- Called to fetch the list of window identifiers stored in the
-- WM_COLORMAP_WINDOWS property on the specified window. Returns Failed if
-- a) the property has never been set, b) the property is set but it does not
-- have the correct type, format, or size. The list must be freed after use
-- with the Free_X_Window_List routine.
------------------------------------------------------------------------------
Data : U_Char_List;
Actual_Type : X_Atom;
Actual_Format : U_Char;
Leftover : S_Natural;
Nitems : S_Natural;
Succ : X_Status;
Wins : X_Window_List;
begin
----Initialize out parameters.
Windows := None_X_Window_List;
----Make sure we have the internal atom that we need to do this.
if Display.Atoms.Wm_Colormap_Windows = None_X_Atom then
Actual_Type := X_Intern_Atom (Display,
"WM_COLORMAP_WINDOWS", False);
if Actual_Type = None_X_Atom then
Status := Failed;
return;
end if;
Lock_Display (Display);
Display.Atoms.Wm_Colormap_Windows := Actual_Type;
Unlock_Display (Display);
end if;
----Get the property and make sure we really got it.
X_Get_Window_Property
(Display, Window, Display.Atoms.Wm_Colormap_Windows,
0, 1_000_000, False, Xa_Window, Actual_Type,
Actual_Format, Nitems, Leftover, Data, Succ);
if Succ /= Successful then
Status := Failed;
return;
end if;
----Make sure that we have the correct format.
if Actual_Type /= Xa_Window or else
Actual_Format /= 32 then
Free_U_Char_List (Data);
Status := Failed;
return;
end if;
----Convert the data into a window array.
Wins := new X_Window_Array (1 .. Nitems);
From_Uca (Wins.all, Data.all);
Free_U_Char_List (Data);
Windows := Wins;
Status := Successful;
exception
when others =>
Free_U_Char_List (Data);
Free_X_Window_List (Wins);
raise;
end X_Get_Wm_Colormap_Windows;
--\f
procedure X_Set_Wm_Colormap_Windows (Display : X_Display;
Window : X_Window;
Windows : X_Window_Array;
Status : out X_Status) is
------------------------------------------------------------------------------
-- Display - Specifies the display to use.
-- W - Specifies the window to use.
-- Windows - Specifies the window list.
-- Status - Receives Successful if we succeeded; Failed if not.
--
-- Sets the WM_COLORMAP_WINDOWS property for the specified window. The
-- property is set to have a type of WINDOW and a format of 32.
--
-- WM_COLORMAP_WINDOWS type: WINDOW format:32
------------------------------------------------------------------------------
A : X_Atom;
Data : U_Char_Array (1 .. X_Window'Size / U_Char'Size * Windows'Length);
begin
----Make sure that our internal atom exists.
if Display.Atoms.Wm_Colormap_Windows = None_X_Atom then
A := X_Intern_Atom (Display, "WM_COLORMAP_WINDOWS", False);
if A = None_X_Atom then
Status := Failed;
return;
end if;
Lock_Display (Display);
Display.Atoms.Wm_Colormap_Windows := A;
Unlock_Display (Display);
end if;
----Convert and send the data.
To_Uca (Data, Windows);
X_Change_Property (Display => Display,
Window => Window,
Property => Display.Atoms.Wm_Colormap_Windows,
Representation => Xa_Window,
Format => 32,
Mode => Prop_Mode_Replace,
Data => Data);
Status := Successful;
end X_Set_Wm_Colormap_Windows;
--\f
procedure X_Get_Rgb_Colormaps (Display : X_Display;
Window : X_Window;
Colormaps : out X_Standard_Colormap_List;
Property : X_Atom;
Status : out X_Status) is
------------------------------------------------------------------------------
-- Display - Specifies the display to use.
-- W - Specifies the window to use.
-- Stdcmap - Receives the color map(s) associated with the Property.
-- Property - Specifies the property to query.
-- Status - Receives Successful if we succeeded; Failed if not.
--
-- Used to obtain the color map definition(s) associated with the standard
-- color map property specified.
--
-- If the property exists, is of type RGB_COLOR_MAP, is of format 32, and is
-- long enough to contain a colormap definition we allocate and fill in the
-- space for the returned colormaps and returns Status = Successful.
--
-- If the Visual_Id of a colormap is not present then we assume the default
-- visual for the screen. If the Kill_Id is not present then None is used;
-- meaning that the resources cannot be released.
------------------------------------------------------------------------------
Data : U_Char_List;
Actual_Type : X_Atom; -- how the prop was actually stored
Actual_Format : U_Char; -- ditto
Leftover : S_Natural; -- how much was left over
Nitems : S_Natural; -- number of 32bits read
Ncmaps : S_Natural; -- number of structs this makes
Old_Style : Boolean := False; -- if was too short
Def_Visual : X_Visual_Id := None_X_Visual_Id;-- visual if prop short
Cmaps : X_Standard_Colormap_List; -- our return value
Sp : X_Screen;
Succ : X_Status;
Cmap_Size : constant S_Natural :=
X_Standard_Colormap'Size / U_Char'Size;
begin
----Initialize our out parameters.
Colormaps := None_X_Standard_Colormap_List;
----Get the window property and see if we really got it.
X_Get_Window_Property (Display, Window, Property, 0, 1_000_000,
False, Xa_Rgb_Color_Map, Actual_Type,
Actual_Format, Nitems, Leftover, Data, Succ);
if Succ /= Successful then
Status := Failed;
return;
end if;
----If it is the wrong type, the wrong format, or too small for us, then punt.
if Actual_Type /= Xa_Rgb_Color_Map or else
Actual_Format /= 32 or else
Nitems < Cmap_Size - 8 then
Free_U_Char_List (Data);
Status := Failed;
return;
end if;
----See how many properties were found; if pre-ICCCM size then assume default
-- visual and a kill id of None.
if Nitems < Cmap_Size then
----Old style; pre-ICCCM.
Ncmaps := 1;
Old_Style := True;
if Nitems < Cmap_Size - 1 then
Sp := Internal_X_Screen_Of_Window (Display, Window);
if Sp = None_X_Screen then
Free_U_Char_List (Data);
Status := Failed;
return;
end if;
Def_Visual := Sp.Root_Visual.Visual_Id;
end if;
----New style; post-ICCCM. Make sure we have an integral number of colormaps.
else
Ncmaps := Nitems / Cmap_Size;
if Ncmaps * Cmap_Size /= Nitems then
Free_U_Char_List (Data);
Status := Failed;
return;
end if;
end if;
---Allocate the result array.
Cmaps := new X_Standard_Colormap_Array (1 .. Ncmaps);
----And fill it in, handling compatibility with pre-ICCCM short stdcmaps.
declare
Map : S_Natural := Cmaps'First;
Prop : S_Natural := Data'First;
begin
for I in 1 .. Ncmaps loop
if Old_Style then
From_Uca (Cmaps (Map),
Data (Prop .. Prop + Cmap_Size - 1 - 8) &
(1 .. 8 => 0));
Cmaps (Map).Kill_Id := None_X_Id;
else
From_Uca (Cmaps (Map), Data (Prop .. Prop + Cmap_Size - 1));
end if;
if Def_Visual /= None_X_Visual_Id then
Cmaps (Map).Visual_Id := Def_Visual;
end if;
Map := Map + 1;
Prop := Prop + Cmap_Size; -- Only every 1 small/old cmap.
end loop;
end;
Free_U_Char_List (Data);
Colormaps := Cmaps;
Status := Successful;
exception
when others =>
Free_U_Char_List (Data);
Free_X_Standard_Colormap_List (Cmaps);
raise;
end X_Get_Rgb_Colormaps;
--\f
procedure X_Set_Rgb_Colormaps (Display : X_Display;
Window : X_Window;
Colormaps : X_Standard_Colormap_Array;
Property : X_Atom;
Status : out X_Status) is
------------------------------------------------------------------------------
-- Display - Specifies the display to use.
-- W - Specifies the window to use.
-- Stdcmap - Specifies the Colormap(s) to use.
-- Property - Specifies the property to set.
--
-- Used by window managers to create standard color map properties.
--
-- The colormap(s) are stored with type RGB_COLOR_MAP and a format of 32.
--
-- It is the caller's responsibility to honor the ICCCM restriction that only
-- RGB_DEFAULT_MAP contain more than one definition.
------------------------------------------------------------------------------
Cmap_Size : constant S_Natural :=
X_Standard_Colormap'Size / U_Char'Size;
Data : U_Char_Array (1 .. Colormaps'Length * Cmap_Size);
begin
if Colormaps'Length < 1 then
return;
end if;
To_Uca (Data, Colormaps);
X_Change_Property (Display => Display,
Window => Window,
Property => Property,
Representation => Xa_Rgb_Color_Map,
Format => 32,
Mode => Prop_Mode_Replace,
Data => Data);
Status := Successful;
end X_Set_Rgb_Colormaps;
--\f
procedure X_Set_Command (Display : X_Display;
Window : X_Window;
Arg_V : X_String_Pointer_Array;
Status : out X_Status) is
N_Bytes : S_Natural;
begin
----Count the number of characters we need to include in the property.
N_Bytes := 0;
for I in Arg_V'Range loop
if Arg_V (I) /= None_X_String_Pointer then
N_Bytes := N_Bytes + Arg_V (I)'Length + 1;
else
N_Bytes := N_Bytes + 1;
end if;
end loop;
----Create the uca version of the property and then set it.
declare
Bp : U_Char_Array (1 .. N_Bytes);
Bpi : S_Natural := 1;
Sp : X_String_Pointer;
begin
for I in Arg_V'Range loop
Sp := Arg_V (I);
if Sp /= None_X_String_Pointer then
To_Uca (Bp (Bpi .. Bpi + Sp'Length - 1), Arg_V (I).all);
Bpi := Bpi + Sp'Length;
end if;
Bp (Bpi) := 0;
Bpi := Bpi + 1;
end loop;
X_Change_Property (Display => Display,
Window => Window,
Property => Xa_Wm_Command,
Representation => Xa_String,
Format => 8,
Mode => Prop_Mode_Replace,
Data => Bp);
end;
Status := Successful;
end X_Set_Command;
--\f
procedure X_Get_Command (Display : X_Display;
Window : X_Window;
Arg_V : out X_String_Pointer_List;
Status : out X_Status) is
------------------------------------------------------------------------------
-- Display - Specifies the display to use.
-- Window - Specifies the window to ask about
--
-- Called to fetch the command arguments which were used in a call to
-- X_Set_Class_Hint. Returns an empty array if a) the WM_COMMAND property
-- has never been set, b) the original command list was empty as well, c)
-- the property is set but it does not have the correct type, format, or size.
------------------------------------------------------------------------------
Tp : X_Text_Property;
Stat : X_Status;
begin
X_Get_Text_Property (Display, Window, Tp, Xa_Wm_Command, Stat);
if Stat /= Successful then
Status := Failed;
return;
end if;
----Ignore trailing <NUL> if present since a UNIX WM_COMMAND is nul-terminated.
if Tp.N_Items > 0 and then
Tp.Value (Tp.N_Items - 1) = 0 then
Tp.N_Items := Tp.N_Items - 1;
end if;
----Create a string list and return if successful.
X_Text_Property_To_String_List (Tp, Arg_V, Status);
Free_X_Text_Property (Tp);
exception
when others =>
Free_X_Text_Property (Tp);
raise;
end X_Get_Command;
--\f
procedure X_Get_Icon_Sizes (Display : X_Display;
Window : X_Window;
List : out X_Icon_Size_List;
Status : out X_Status) is
Succ : X_Status;
Actual_Type : X_Atom;
Actual_Format : U_Char;
Leftover : S_Natural;
N_Items : S_Natural;
Buff : U_Char_List;
New_List : X_Icon_Size_List;
begin
----Ask for the property.
X_Get_Window_Property
(Display => Display,
Window => Window,
Property => Xa_Wm_Icon_Size,
Offset => 0,
Maximum_Length => 1_000_000,
Delete => False,
Representation => Xa_Wm_Icon_Size,
Actual_Type => Actual_Type,
Actual_Format => Actual_Format,
N_Items => N_Items,
Bytes_After => Leftover,
Data => Buff,
Status => Succ);
----Make sure we have what we wanted.
if Succ = Failed or else
Actual_Type /= Xa_Wm_Icon_Size or else
N_Items < X_Icon_Size'Size / 32 or else
N_Items rem X_Icon_Size'Size / 32 /= 0 or else
Actual_Format /= 32 then
Status := Failed;
----Convert the bytes to an array and return it.
else
New_List := new X_Icon_Size_Array
(1 .. N_Items / (X_Icon_Size'Size /
S_Natural (Actual_Format)));
From_Uca (New_List.all, Buff.all);
List := New_List;
Status := Successful;
end if;
Free_U_Char_List (Buff);
exception
when others =>
Free_U_Char_List (Buff);
Free_X_Icon_Size_List (New_List);
raise;
end X_Get_Icon_Sizes;
--\f
procedure X_Set_Icon_Sizes (Display : X_Display;
Window : X_Window;
List : X_Icon_Size_Array;
Status : out X_Status) is
Data : U_Char_Array (1 .. X_Icon_Size'Size / U_Char'Size * List'Length);
begin
To_Uca (Data, List);
X_Change_Property (Display => Display,
Window => Window,
Property => Xa_Wm_Icon_Size,
Representation => Xa_Wm_Icon_Size,
Format => 32,
Mode => Prop_Mode_Replace,
Data => Data);
Status := Successful;
end X_Set_Icon_Sizes;
--\f
procedure X_Get_Wm_Name (Display : X_Display;
Window : X_Window;
Name : out X_Text_Property;
Status : out X_Status) is
begin
X_Get_Text_Property (Display, Window, Name, Xa_Wm_Name, Status);
end X_Get_Wm_Name;
--\f
procedure X_Get_Wm_Icon_Name (Display : X_Display;
Window : X_Window;
Name : out X_Text_Property;
Status : out X_Status) is
begin
X_Get_Text_Property (Display, Window, Name, Xa_Wm_Icon_Name, Status);
end X_Get_Wm_Icon_Name;
--\f
procedure X_Set_Wm_Icon_Name (Display : X_Display;
Window : X_Window;
Icon_Name : X_Text_Property;
Status : out X_Status) is
begin
X_Set_Text_Property (Display, Window, Icon_Name, Xa_Wm_Icon_Name);
Status := Successful;
end X_Set_Wm_Icon_Name;
--\f
procedure X_Set_Wm_Name (Display : X_Display;
Window : X_Window;
Name : X_Text_Property;
Status : out X_Status) is
begin
X_Set_Text_Property (Display, Window, Name, Xa_Wm_Name);
Status := Successful;
end X_Set_Wm_Name;
--\f
procedure X_Get_Wm_Normal_Hints (Display : X_Display;
Window : X_Window;
Hints : out X_Size_Hints;
Status : out X_Status) is
begin
X_Get_Wm_Size_Hints (Display, Window,
Xa_Wm_Normal_Hints, Hints, Status);
end X_Get_Wm_Normal_Hints;
--\f
procedure X_Set_Wm_Normal_Hints (Display : X_Display;
Window : X_Window;
Hints : X_Size_Hints;
Status : out X_Status) is
begin
X_Set_Wm_Size_Hints (Display, Window,
Xa_Wm_Normal_Hints, Hints, Status);
end X_Set_Wm_Normal_Hints;
--\f
procedure X_Get_Wm_Protocols (Display : X_Display;
Window : X_Window;
Protocols : out X_Atom_List;
Status : out X_Status) is
------------------------------------------------------------------------------
-- Display - Specifies the display to use.
-- W - Specifies the window to use.
-- Protocols - Receives the window protocols list.
-- Status - Returns Successful if we succeeded; Failed if not.
--
-- Fetches the protocol list for the window.
--
-- Called to fetch the protocol list which was used in a call to
-- X_Set_Class_Hint. Returns Failed if a) the WM_PROTOCOLS property
-- has never been set, b) the property is set but it does not have the correct
-- type, format, or size.
--
-- Free the list with Free_X_Atom_List after use.
------------------------------------------------------------------------------
Data : U_Char_List;
Actual_Type : X_Atom;
Actual_Format : U_Char;
Leftover : S_Natural;
Nitems : S_Natural;
Atoms : X_Atom_List;
Succ : X_Status;
begin
Protocols := None_X_Atom_List;
if Display.Atoms.Wm_Protocols = None_X_Atom then
Actual_Type := X_Intern_Atom (Display, "WM_PROTOCOLS", False);
if Actual_Type = None_X_Atom then
Status := Failed;
return;
end if;
Lock_Display (Display);
Display.Atoms.Wm_Protocols := Actual_Type;
Unlock_Display (Display);
end if;
----Get the property.
X_Get_Window_Property (Display, Window, Display.Atoms.Wm_Protocols,
0, 1_000_000, False, Xa_Atom, Actual_Type,
Actual_Format, Nitems, Leftover, Data, Succ);
if Succ /= Successful then
Status := Failed;
return;
end if;
if Actual_Type /= Xa_Atom or else
Actual_Format /= 32 then
Free_U_Char_List (Data);
Status := Failed;
return;
end if;
Atoms := new X_Atom_Array (1 .. Nitems);
From_Uca (Atoms.all, Data.all);
Free_U_Char_List (Data);
Status := Successful;
exception
when others =>
Free_U_Char_List (Data);
Free_X_Atom_List (Atoms);
raise;
end X_Get_Wm_Protocols;
--\f
procedure X_Set_Wm_Protocols (Display : X_Display;
Window : X_Window;
Protocols : X_Atom_Array;
Status : out X_Status) is
------------------------------------------------------------------------------
-- Display - Specifies the display to use.
-- W - Specifies the window to use.
-- Protocols - Specifies the protocols to be set for this window.
-- Status - Returns Successful if we succeeded; Failed if not.
--
-- Sets the protocol list for a window.
--
-- The property is stored with a type of XA_ATOM and a format of 32.
------------------------------------------------------------------------------
A : X_Atom;
Data : U_Char_Array (1 .. X_Atom'Size / U_Char'Size * Protocols'Length);
begin
if Display.Atoms.Wm_Protocols = None_X_Atom then
A := X_Intern_Atom (Display, "WM_PROTOCOLS", False);
if A = None_X_Atom then
Status := Failed;
return;
end if;
Lock_Display (Display);
Display.Atoms.Wm_Protocols := A;
Unlock_Display (Display);
end if;
To_Uca (Data, Protocols);
X_Change_Property (Display => Display,
Window => Window,
Property => Display.Atoms.Wm_Protocols,
Representation => Xa_Atom,
Format => 32,
Mode => Xlbt_Window.Prop_Mode_Replace,
Data => Data);
Status := Successful;
end X_Set_Wm_Protocols;
--\f
procedure X_Get_Wm_Size_Hints (Display : X_Display;
Window : X_Window;
Property : X_Atom;
Hints : out X_Size_Hints;
Status : out X_Status) is
Phints : X_Size_Hints_Protocol;
Actual_Type : X_Atom;
Actual_Format : U_Char;
Leftover : S_Natural;
N_Items : S_Natural;
Succ : X_Status;
Buff : U_Char_List;
Hsize : constant S_Natural := X_Size_Hints_Protocol'Size / U_Char'Size;
begin
----Request the property from the server.
X_Get_Window_Property (Display,
Window,
Property,
0,
S_Long (X_Size_Hints'Size / 32),
False,
Xa_Wm_Size_Hints,
Actual_Type,
Actual_Format,
N_Items,
Leftover,
Buff,
Succ);
----See if we got a positive reply. If the data is not of the expected form
-- or size or format then we simply reject it and return.
if Succ = Failed or else Actual_Type /= Xa_Wm_Size_Hints or else
(N_Items /= X_Size_Hints_Protocol'Size / 32 and then
N_Items /= X_Size_Hints_Protocol'Size / 32 - 3) or else
Actual_Format /= 32 then
Free_U_Char_List (Buff);
Hints := None_X_Size_Hints;
Status := Failed;
return;
end if;
----If the data is of the new form then convert it one way. If the data is
-- of the old (shorter) from then convert it after appending some extra
-- zeroes to make it the expected length. Turn off any bogus flags that
-- may be accidentally turned on by an old server or whatever.
if N_Items >= X_Size_Hints_Protocol'Size / 32 then
From_Uca (Phints, Buff (Buff'First .. Buff'First + Hsize - 1));
Phints.Flags := Phints.Flags and
X_Size_Hints_Flags'
(U_S_Position | U_S_Size | P_Position |
P_Size | P_Min_Size | P_Max_Size |
P_Resize_Inc | P_Aspect |
P_Base_Size | P_Win_Gravity => True,
others => False);
else
From_Uca (Phints, Buff.all & (1 .. (3 * 32) / U_Char'Size => 0));
Phints.Flags := Phints.Flags and
X_Size_Hints_Flags'
(U_S_Position | U_S_Size | P_Position |
P_Size | P_Min_Size | P_Max_Size |
P_Resize_Inc | P_Aspect => True,
others => False);
end if;
----Return the data to the user (after re-representing it). We do it this
-- way because we cannot rely upon Ada compilers to implement rep-spec's at
-- all so Hints and PHints are different types rather than the same type with
-- different rep's. Otherwise we could just do Hints := PHints and let Ada
-- rules do the rest.
Hints :=
(Flags => Phints.Flags,
X => Phints.X,
Y => Phints.Y,
Width => Phints.Width,
Height => Phints.Height,
Min_Width => Phints.Min_Width,
Min_Height => Phints.Min_Height,
Max_Width => Phints.Max_Width,
Max_Height => Phints.Max_Height,
Width_Inc => Phints.Width_Inc,
Height_Inc => Phints.Height_Inc,
Min_Aspect => Phints.Min_Aspect,
Max_Aspect => Phints.Max_Aspect,
Base_Width => Phints.Base_Width,
Base_Height => Phints.Base_Height,
Win_Gravity => X_Window_Gravity'Val
(X_Size_Hints_Gravity'Pos (Phints.Win_Gravity))
);
Status := Successful;
end X_Get_Wm_Size_Hints;
--\f
procedure X_Set_Wm_Size_Hints (Display : X_Display;
Window : X_Window;
Property : X_Atom;
Hints : X_Size_Hints;
Status : out X_Status) is
Phints : X_Size_Hints_Protocol;
Uca : U_Char_Array (1 .. X_Size_Hints_Protocol'Size / U_Char'Size);
begin
Phints := (Flags => Hints.Flags,
X => Hints.X,
Y => Hints.Y,
Width => Hints.Width,
Height => Hints.Height,
Min_Width => Hints.Min_Width,
Min_Height => Hints.Min_Height,
Max_Width => Hints.Max_Width,
Max_Height => Hints.Max_Height,
Width_Inc => Hints.Width_Inc,
Height_Inc => Hints.Height_Inc,
Min_Aspect => Hints.Min_Aspect,
Max_Aspect => Hints.Max_Aspect,
Base_Width => Hints.Base_Width,
Base_Height => Hints.Base_Height,
Win_Gravity => X_Size_Hints_Gravity'Val
(X_Window_Gravity'Pos (Hints.Win_Gravity))
);
To_Uca (Uca, Phints);
X_Change_Property (Display => Display,
Window => Window,
Property => Property,
Representation => Xa_Wm_Size_Hints,
Format => 32,
Mode => Prop_Mode_Replace,
Data => Uca);
Status := Successful;
end X_Set_Wm_Size_Hints;
--\f
procedure X_Set_Wm_Properties (Display : X_Display;
Window : X_Window;
Window_Name : X_String;
Icon_Name : X_String;
Arg_V : X_String_Pointer_Array;
Normal : X_Size_Hints;
Wm : X_Wm_Hints;
Class : X_Class_Hint;
Status : out X_Status) is
Win : X_Text_Property;
Icn : X_Text_Property;
begin
X_String_To_Text_Property (Window_Name, Win);
X_String_To_Text_Property (Icon_Name, Icn);
X_Set_Wm_Properties (Display, Window, Win, Icn, Arg_V,
Normal, Wm, Class, Status);
Free_X_Text_Property (Win);
Free_X_Text_Property (Icn);
exception
when others =>
Free_X_Text_Property (Win);
Free_X_Text_Property (Icn);
raise;
end X_Set_Wm_Properties;
--\f
------------------------------------------------------------------------------
-- X_Set_WM_Properties sets the following properties:
-- WM_NAME type: TEXT format: varies?
-- WM_ICON_NAME type: TEXT format: varies?
-- WM_HINTS type: WM_HINTS format: 32
-- WM_COMMAND type: TEXT format: varies?
-- WM_CLIENT_MACHINE type: TEXT format: varies?
-- WM_NORMAL_HINTS type: WM_SIZE_HINTS format: 32
-- WM_CLASS type: STRING/STRING format: 8
------------------------------------------------------------------------------
procedure X_Set_Wm_Properties (Display : X_Display;
Window : X_Window;
Window_Name : X_Text_Property;
Icon_Name : X_Text_Property;
Arg_V : X_String_Pointer_Array;
Normal : X_Size_Hints;
Wm : X_Wm_Hints;
Class : X_Class_Hint;
Status : out X_Status) is
------------------------------------------------------------------------------
-- Display - Specifies the display to use.
-- W - Specifies the window to decorate.
-- Name - Specifies the name of the window.
-- Icon_String - Specifies the name of the window's icon.
-- Icon_Pixmap - Specifies the pixmap to be used for the icon; or None_Pixmap.
-- Arg_V - Specifies the command arguments used to start the application.
-- Normal - Specifies a series of window manager sizing hints.
-- Wm - Specifies a series of window manager control hints.
-- Class - Specifies a application name/class hint
--
-- Provides a way to specify a minimum set of properties that describe the
-- "quickie" application to a window manager.
--
-- If Window_Name = "" then the WM_NAME property is not set.
--
-- If Icon_Name = "" then the WM_ICON_NAME property is not set.
--
-- If Arg_V'Length = 0 then the WM_COMMAND property is not set.
--
-- If Normal = None_X_Size_Hints then the WM_NORMAL_HINTS property
--
-- If Wm = None_X_Wm_Hints then the WM_HINTS property is not set.
--
-- If Class = None_X_Class_hints then the WM_CLASS property is not set.
------------------------------------------------------------------------------
Prop : X_Text_Property;
Host : constant X_String := X_Env_Get_Host_Name;
Succ : X_Status;
begin
if Window_Name /= None_X_Text_Property then
X_Set_Wm_Name (Display, Window, Window_Name, Succ);
end if;
if Icon_Name /= None_X_Text_Property then
X_Set_Wm_Icon_Name (Display, Window, Icon_Name, Succ);
end if;
if Arg_V'Length /= 0 then
X_Set_Command (Display, Window, Arg_V, Succ);
end if;
X_String_To_Text_Property (Host, Prop);
X_Set_Wm_Client_Machine (Display, Window, Prop, Succ);
Free_X_Text_Property (Prop);
if Normal /= None_X_Size_Hints then
X_Set_Wm_Normal_Hints (Display, Window, Normal, Succ);
end if;
if Wm /= None_X_Wm_Hints then
X_Set_Wm_Hints (Display, Window, Wm, Succ);
end if;
declare
Cl : X_Class_Hint := Class;
Set : Boolean := False;
begin
if Cl.Res_Name = None_X_String_Pointer then
Set := True;
Cl.Res_Name := X_Env_Get_Environment_Variable ("RESOURCE_NAME");
end if;
if Cl.Res_Class = None_X_String_Pointer then
Cl.Res_Class := Cl.Res_Name;
end if;
if Cl = None_X_Class_Hint then
if Arg_V'Length > 0 then
Set := True;
Cl.Res_Name := new X_String'(X_Env_Strip_Program_Name
(Arg_V (Arg_V'First).all));
Cl.Res_Class := Cl.Res_Name;
end if;
end if;
if Cl /= None_X_Class_Hint then
X_Set_Class_Hint (Display, Window, Cl, Succ);
if Set then
Free_X_String_Pointer (Cl.Res_Name);
end if;
end if;
exception
when others =>
if Set then
Free_X_String_Pointer (Cl.Res_Name);
end if;
raise;
end;
Status := Successful;
end X_Set_Wm_Properties;
--\f
procedure X_Get_Transient_For_Hint (Display : X_Display;
Window : X_Window;
Parent : out X_Window;
Status : out X_Status) is
Actual_Type : X_Atom;
Actual_Format : U_Char;
N_Items : S_Natural;
Leftover : S_Natural;
Buff : U_Char_List;
Succ : X_Status;
begin
----Get the property.
X_Get_Window_Property (Display,
Window,
Xa_Wm_Transient_For,
0,
X_Window'Size / 32,
False,
Xa_Window,
Actual_Type,
Actual_Format,
N_Items,
Leftover,
Buff,
Succ);
----See if we got what we asked for.
if Succ /= Failed and then
Actual_Type = Xa_Window and then
N_Items >= X_Window'Size / 32 and then
Actual_Format = 32 then
From_Uca (Parent, Buff.all);
Status := Successful;
----We got garbage.
else
Parent := None_X_Window;
Status := Failed;
end if;
----Free up storage and return.
Free_U_Char_List (Buff);
exception
when others =>
Free_U_Char_List (Buff);
raise;
end X_Get_Transient_For_Hint;
--\f
procedure X_Set_Transient_For_Hint (Display : X_Display;
Window : X_Window;
Parent : X_Window;
Status : out X_Status) is
Uca : U_Char_Array (1 .. X_Window'Size / U_Char'Size);
begin
To_Uca (Uca, Parent);
X_Change_Property (Display => Display,
Window => Window,
Property => Xa_Wm_Transient_For,
Representation => Xa_Window,
Format => 32,
Mode => Prop_Mode_Replace,
Data => Uca);
Status := Successful;
end X_Set_Transient_For_Hint;
--\f
procedure X_Get_Wm_Hints (Display : X_Display;
Window : X_Window;
Wm_Hints : out X_Wm_Hints;
Status : out X_Status) is
Actual_Type : X_Atom;
Actual_Format : U_Char;
Leftover : S_Natural;
N_Items : S_Natural;
Succ : X_Status;
Buff : U_Char_List;
begin
X_Get_Window_Property (Display,
Window,
Xa_Wm_Hints,
0,
S_Long (X_Wm_Hints'Size / 32),
False,
Xa_Wm_Hints,
Actual_Type,
Actual_Format,
N_Items,
Leftover,
Buff,
Succ);
if Succ = Failed or else
Actual_Type /= Xa_Wm_Hints or else
N_Items < X_Wm_Hints'Size / 32 - 1 or else
Actual_Format /= 32 then
Wm_Hints := None_X_Wm_Hints;
Status := Failed;
return;
end if;
----Some X servers prior to X11R3 forgot to send the last full-word
-- of the X_Wm_Hints; this is the Window_Group field. We
-- allow the N_Items to be as-much-as 1 word smaller than the real
-- complete record.
if N_Items = X_Wm_Hints'Size / 32 - 1 then
From_Uca (Wm_Hints, Buff.all & (1 .. 4 => 0));
else
From_Uca (Wm_Hints,
Buff (Buff'First ..
Buff'First + X_Wm_Hints'Size / U_Char'Size - 1));
end if;
Free_U_Char_List (Buff);
Status := Successful;
exception
when others =>
Free_U_Char_List (Buff);
raise;
end X_Get_Wm_Hints;
--\f
procedure X_Set_Wm_Hints (Display : X_Display;
Window : X_Window;
Wm_Hints : X_Wm_Hints;
Status : out X_Status) is
Uca : U_Char_Array (1 .. X_Wm_Hints'Size / U_Char'Size);
begin
To_Uca (Uca, Wm_Hints);
X_Change_Property (Display => Display,
Window => Window,
Property => Xa_Wm_Hints,
Representation => Xa_Wm_Hints,
Format => 32,
Mode => Prop_Mode_Replace,
Data => Uca);
Status := Successful;
end X_Set_Wm_Hints;
--\f
procedure X_Get_Wm_Client_Machine (Display : X_Display;
Window : X_Window;
Machine : out X_Text_Property;
Status : out X_Status) is
begin
X_Get_Text_Property (Display, Window, Machine,
Xa_Wm_Client_Machine, Status);
end X_Get_Wm_Client_Machine;
--\f
procedure X_Set_Wm_Client_Machine (Display : X_Display;
Window : X_Window;
Machine : X_Text_Property;
Status : out X_Status) is
begin
X_Set_Text_Property (Display, Window, Machine, Xa_Wm_Client_Machine);
Status := Successful;
end X_Set_Wm_Client_Machine;
--\f
end Xlbp_Hint;