⟦642a0f2a0⟧

TextFile

with Xlbt_Arithmetic;  
use Xlbt_Arithmetic;  
with Xlbt_Display3;  
use Xlbt_Display3;  
with Xlbt_Error;  
use Xlbt_Error;  
with Xlbt_Extension;  
use Xlbt_Extension;  
with Xlbt_Proc_Var;  
use Xlbt_Proc_Var;  
with Xlbt_Rm3;  
use Xlbt_Rm3;  
with Xlbt_String;  
use Xlbt_String;

with Xlbp_Proc_Var;  
use Xlbp_Proc_Var;  
with Xlbp_Rm;  
use Xlbp_Rm;  
with Xlbp_Rm_Name;  
use Xlbp_Rm_Name;

with Xlbit_Library2;  
use Xlbit_Library2;  
with Xlbit_Library3;  
use Xlbit_Library3;  
with Xlbit_Library4;  
use Xlbit_Library4;

with Xlbmt_Network_Types;  
use Xlbmt_Network_Types;  
with Xlbmt_Parameters;  
use Xlbmt_Parameters;

with Xlbmp_Error_Log;  
use Xlbmp_Error_Log;

package body Xlbp_Error is
------------------------------------------------------------------------------
-- X Library Error Control
--
-- Xlbp_Error - Provides control over error responses within the X Library.
------------------------------------------------------------------------------
-- 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.
--
--                  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, or Rational
-- not be used in advertising or publicity pertaining to distribution of
-- the software without specific, written prior permission.
--
-- Digital, MIT, and Rational disclaim all warranties with regard to this
-- software, including all implied warranties of merchantability and fitness,
-- in no event shall Digital, 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.
------------------------------------------------------------------------------
-- ****************************************************************************
-- * Date      - /Name/ Comment
-- *
-- *  7-NOV-90 - /GEB/ Implement the new multitasking protection scheme for
-- *           -  library state.
-- ****************************************************************************

--\f

    procedure Initialize_Error_Message_Db is  
    begin

----If the database already exists then we're getting more than one call to
--  ourselves.  More than one task may have looked, all at the same time,
--  to see if the database existed.

        Lock_Mutex (Mutex);         -- Lock out all other initializers.
        if X_Lib_Error_Message_Db /= None_X_Rm_Database then  
            Unlock_Mutex (Mutex);   -- Someone else got there first.
            return;                 -- Return and use his database.
        end if;

----No database, read it from the file.  If we don't get a database back then
--  that's because of an error.  Fake an empty database so we won't try again
--  and again recursively.

        declare  
            Status : X_Rm_Status;  
            Fake   : X_Rm_Database;  
            Real   : X_Rm_Database;  
        begin

----Create an empty database so that X_Rm_Get_File_Database has a way to
--  report errors that doesn't recurse infinitely with us.

            begin  
                Fake := new X_Rm_Database_Rec;  
            exception  
                when others =>  
                    Unlock_Mutex (Mutex);  
                    raise;  
            end;  
            X_Lib_Error_Message_Db := Fake;     -- Prevent infinite recursion.
            X_Rm_Get_File_Database (X_Error_Database, Real, Status);  
            if Real /= None_X_Rm_Database then  
                X_Lib_Error_Message_Db := Real;  
                Free_X_Rm_Database (Fake);  
            end if;  
            if Status /= Rm_Successful then  
                Unlock_Mutex (Mutex);  
                X_Report_Error ("XlibError",  
                                "ReadErrorDb",  
                                "Error reading error database file: %1",  
                                To_X_String (X_Error_Database));  
                return;  
            end if;

----If we get any exceptions then we must perform damage control.  If we have
--  no present database then fake an empty one before we report the error.

        exception  
            when others =>  
                if Real /= None_X_Rm_Database then  
                    X_Lib_Error_Message_Db := Real;  
                    Free_X_Rm_Database (Fake);  
                end if;  
                Unlock_Mutex (Mutex);  
                raise;  
        end;

    end Initialize_Error_Message_Db;

--\f

    function X_Error_List (Error_Code : X_Error_Code) return X_String is  
    begin  
        case Error_Code is  
            when Success =>
                -- No error
                return X_Get_Error_String  
                          ("XProtoError", "0", "Not An Error (0)");  
            when Bad_Request =>
                -- Bad_Request
                return X_Get_Error_String  
                          ("XProtoError", "1",  
                           "Bad_Request (1, invalid request code or " &  
                              "no such operation)");  
            when Bad_Value =>
                -- Bad_Value
                return X_Get_Error_String  
                          ("XProtoError", "2",  
                           "Bad_Value (2, integer parameter out " &  
                              "of range for operation)");  
            when Bad_Window =>
                -- Bad_Window
                return X_Get_Error_String  
                          ("XProtoError", "3",  
                           "Bad_Window (3, invalid Window parameter)");  
            when Bad_Pixmap =>
                -- Bad_Pixmap
                return X_Get_Error_String  
                          ("XProtoError", "4",  
                           "Bad_Pixmap (4, invalid Pixmap parameter)");  
            when Bad_Atom =>
                -- Bad_Atom
                return X_Get_Error_String  
                          ("XProtoError", "5",  
                           "Bad_Atom (5, invalid Atom parameter)");  
            when Bad_Cursor =>
                -- Bad_Cursor
                return X_Get_Error_String  
                          ("XProtoError", "6",  
                           "Bad_Cursor (6, invalid Cursor parameter)");  
            when Bad_Font =>
                -- Bad_Font
                return X_Get_Error_String  
                          ("XProtoError", "7",  
                           "Bad_Font (7, invalid Font parameter)");  
            when Bad_Match =>
                -- Bad_Match
                return X_Get_Error_String  
                          ("XProtoError", "8",  
                           "Bad_Match (8, invalid parameter attributes)");  
            when Bad_Drawable =>
                -- Bad_Drawable
                return  
                   X_Get_Error_String  
                      ("XProtoError", "9",  
                       "Bad_Drawable (9, invalid Pixmap or Window parameter)");  
            when Bad_Access =>
                -- Bad_Access
                return X_Get_Error_String  
                          ("XProtoError", "10",  
                           "Bad_Access (10, attempt to access " &  
                              "private resource denied)");  
            when Bad_Alloc =>
                -- Bad_Alloc
                return  
                   X_Get_Error_String  
                      ("XProtoError", "11",  
                       "Bad_Alloc (11, insufficient resources for operation)");  
            when Bad_Color =>
                -- Bad_Color
                return X_Get_Error_String  
                          ("XProtoError", "12",  
                           "Bad_Color (12, invalid Colormap parameter)");  
            when Bad_Gc =>
                -- Bad_GC
                return X_Get_Error_String ("XProtoError", "13",  
                                           "Bad_Gc (13, invalid GC parameter)");  
            when Bad_Id_Choice =>
                -- Bad_ID_Choice
                return X_Get_Error_String  
                          ("XProtoError", "14",  
                           "Bad_Id_Choice (14, invalid resource ID " &  
                              "chosen for this connection)");  
            when Bad_Name =>
                -- Bad_Name
                return X_Get_Error_String  
                          ("XProtoError", "15",  
                           "Bad_Name (15, named color or Font does not exist)");  
            when Bad_Length =>
                -- Bad_Length
                return X_Get_Error_String  
                          ("XProtoError", "16",  
                           "Bad_Length (16, poly request too large or" &  
                              " internal Xlib length error)");  
            when Bad_Implementation =>
                -- Bad_Implementation
                return X_Get_Error_String  
                          ("XProtoError", "17",  
                           "Bad_Implementation " &  
                              "(17, server does not implement operation)");  
            when others =>  
                return "**Unknown Error Code" &  
                          To_X_String  
                             (Natural'Image (X_Error_Code'Pos (Error_Code))) &  
                          "** ";  
        end case;  
    end X_Error_List;

--\f

    function X_Get_Error_Database_Text (Display : X_Display;  
                                        Name    : X_String;  
                                        Message : X_String;  
                                        Default : X_String) return X_String is

        Rep    : X_Rm_Representation;  
        Result : X_Rm_Value;  
        Db     : X_Rm_Database;  
    begin

        if X_Lib_Error_Message_Db = None_X_Rm_Database then  
            Initialize_Error_Message_Db;  
        end if;

        X_Rm_Get_Resource (Db, Name & '.' & Message,  
                           "ErrorType.ErrorNumber", Rep, Result);

        if Result /= None_X_Rm_Value then  
            declare  
                Str : constant X_String := Result.V_X_String_Pointer.all;  
            begin  
                return Str;  
            exception  
                when Constraint_Error =>  
                    null;  
            end;  
        end if;  
        return Default;


    end X_Get_Error_Database_Text;

--\f

    function X_Get_Error_Text (Display : X_Display;  
                               Kind    : X_Error_Code) return X_String is  
        Ext   : X_Extension;  
        Buff1 : constant X_String := To_X_String (X_Error_Code'Image (Kind));  
    begin

        declare  
            Buff2 : constant X_String :=  
               Buff1 & " : " &  
                  X_Get_Error_Database_Text  
                     (Display, "XProtoError", Buff1, X_Error_List (Kind));  
            Buff3 : X_String (1 .. 2000);  
            Buffi : S_Natural         := 0;  
        begin  
            Ext := Display.Ext_Procs;  
            while Ext /= null loop-- call out to any extensions
                if Ext.Error_String /= None_X_Procedure_Variable then  
                    declare  
                        Buff4        : constant X_String :=  
                           Proc_Var_X_Error_String_Extension.Call  
                              (Proc_Var_X_Error_String_Extension.To_Pv  
                                  (Ext.Error_String), Display, Kind, Ext.Codes);  
                        Buff4_Length : S_Natural         := Buff4'Length;  
                    begin  
                        if Buff4_Length + 2 > Buff3'Last - Buffi then  
                            Buff4_Length := Buff3'Last - Buffi - 2;  
                        end if;  
                        Buff3 (Buffi + 1) := '[';  
                        Buff3 (Buffi + 1 + 1 .. Buffi + 1 + Buff4_Length) :=  
                           Buff4;  
                        Buff3 (Buffi + 1 + Buff4_Length + 1) := ']';  
                        Buffi := Buffi + 2 + Buff4_Length;  
                    end;  
                end if;  
                Ext := Ext.Next;  
            end loop;  
            if Buffi = 0 then  
                return Buff2;  
            else  
                return Buff2 & Buff3 (1 .. Buffi);  
            end if;  
        end;

    end X_Get_Error_Text;

--\f

    function X_Get_Error_String (Name1   : X_String;  
                                 Name2   : X_String;  
                                 Default : X_String) return X_String is
------------------------------------------------------------------------------
--  Name1   - Specifies the first part of the error name
--  Name2   - Specifies the second part of the error name
--  Default - Specifies a default error message string
--
-- Called to obtain Name1.Name2 or else Name1.Name2.1 & Name1.Name2.2 & ...
-- from the error message database.  If we can't find either type of entry
-- then we return the Default value.
------------------------------------------------------------------------------
        Error   : X_Error_String;  
        Names   : X_Rm_Name_Array (1 .. 4);  
        Classes : X_Rm_Class_Array (1 .. 4);  
        Rep     : X_Rm_Representation;  
        Value   : X_Rm_Value;  
        Db      : X_Rm_Database;

        function Further_Error_Lines (Level : S_Natural) return X_String is
            ----------------------------------------------------------------
            -- Called to obtain Name1.Name2.2, Name1.Name2.3, etc. from
            -- the error message database.  Our caller has already obtained
            -- Name1.Name2.1 from there.  We return either "" or else
            -- Lf & Name1.Name2.Level.
            ----------------------------------------------------------------
            Level_String : constant X_String :=  
               To_X_String (S_Natural'Image (Level));  
            Rep          : X_Rm_Representation;  
            Value        : X_Rm_Value;  
        begin

            Names (3) := X_Rm_String_To_Name  
                            (Level_String (Level_String'First + 1 ..  
                                              Level_String'Last));  
            X_Rm_Get_Resource (Db, Names, Classes, Rep, Value);  
            if Value = None_X_Rm_Value then  
                return "";  
            else  
                return Lf & Value.V_X_String_Pointer.all &  
                          Further_Error_Lines (Level + 1);  
            end if;

        end Further_Error_Lines;

    begin

----Convert our arguments into the proper Quark values so we can query the
--  database.

        Names (1) := X_Rm_String_To_Name (Name1);  
        Names (2) := X_Rm_String_To_Name (Name2);  
        Names (3) := None_X_Rm_Name;  
        Names (4) := None_X_Rm_Name;

        Classes (1) := X_Rm_String_To_Class ("ErrorType");  
        Classes (2) := X_Rm_String_To_Class ("ErrorNumber");  
        Classes (3) := None_X_Rm_Class;  
        Classes (4) := None_X_Rm_Class;

----Lock the X_Lib database.

        if X_Lib_Error_Message_Db = None_X_Rm_Database then  
            Initialize_Error_Message_Db;  
        end if;

----See if the database has an error message with these simple names.

        X_Rm_Get_Resource (Db, Names, Classes, Rep, Value);

----If the entry is there then return the string value.

        if Value /= None_X_Rm_Value then  
            declare  
                Str : constant X_String := Value.V_X_String_Pointer.all;  
            begin  
                return Str;  
            end;

----If the entry is not there then see if Name.Message.1 is there.

        else  
            Names (3) := X_Rm_String_To_Name ("1");  
            X_Rm_Get_Resource (Db, Names, Classes, Rep, Value);

----If Name.Message.1 is not there then return the Default.

            if Value = None_X_Rm_Value then  
                return Default;  
            end if;

----If Name.Message.1 is there then see if Name.Message.2 is there also.

            declare  
                Str : constant X_String := Value.V_X_String_Pointer.all &  
                                              Further_Error_Lines (2);  
            begin  
                return Str;  
            end;  
        end if;

    end X_Get_Error_String;

--\f

    function X_Set_Error_Handler (Handler : Proc_Var_X_Error_Function.Pv)  
                                 return Proc_Var_X_Error_Function.Pv is
------------------------------------------------------------------------------
-- X_Error_Handler - This function sets the X non-fatal error handler
-- (X_Error_Function_Pv) to be the specified routine.  If NULL is passed in
-- the original error handler is restored.  The old routine is returned.
------------------------------------------------------------------------------
        use Proc_Var_X_Error_Function;  
        Old : X_Procedure_Variable;  
    begin

        X_Lib.Set_Error (Display => None_X_Display,  
                         Proc => Proc_Var_X_Error_Function.From_Pv (Handler),  
                         Old_Proc => Old,  
                         All_Displays => True);  
        return Proc_Var_X_Error_Function.To_Pv (Old);

    end X_Set_Error_Handler;

--\f

    function X_Set_Error_Handler (Display : X_Display;  
                                  Handler : Proc_Var_X_Error_Function.Pv)  
                                 return Proc_Var_X_Error_Function.Pv is
------------------------------------------------------------------------------
-- X_Error_Handler - This function sets the X non-fatal error handler
-- (X_Error_Function_Pv) to be the specified routine.  If NULL is passed in
-- the original error handler is restored.  The old routine is returned.
------------------------------------------------------------------------------
        use Proc_Var_X_Error_Function;  
        Old : X_Procedure_Variable;  
    begin

        X_Lib.Set_Error (Display => Display,  
                         Proc => Proc_Var_X_Error_Function.From_Pv (Handler),  
                         Old_Proc => Old,  
                         All_Displays => False);  
        return Proc_Var_X_Error_Function.To_Pv (Old);

    end X_Set_Error_Handler;

--\f

    function X_Set_Io_Error_Handler (Handler : Proc_Var_X_Io_Error_Function.Pv)  
                                    return Proc_Var_X_Io_Error_Function.Pv is
------------------------------------------------------------------------------
-- X_Set_IO_Error_Handler - This function sets the X fatal I/O error handler
-- (X_IO_Error_Function_Pv) to be the specified routine.  If NULL is passed in
-- the original error handler is restored.  The previous routine is returned.
------------------------------------------------------------------------------
        use Proc_Var_X_Io_Error_Function;  
        Old : X_Procedure_Variable;  
    begin  
        X_Lib.Set_Io_Error  
           (Display      => None_X_Display,  
            Proc         => Proc_Var_X_Io_Error_Function.From_Pv (Handler),  
            Old_Proc     => Old,  
            All_Displays => True);  
        return Proc_Var_X_Io_Error_Function.To_Pv (Old);  
    end X_Set_Io_Error_Handler;

--\f

    function X_Set_Io_Error_Handler (Display : X_Display;  
                                     Handler : Proc_Var_X_Io_Error_Function.Pv)  
                                    return Proc_Var_X_Io_Error_Function.Pv is
------------------------------------------------------------------------------
-- X_Set_IO_Error_Handler - This function sets the X fatal I/O error handler
-- (X_IO_Error_Function_Pv) to be the specified routine.  If NULL is passed in
-- the original error handler is restored.  The previous routine is returned.
------------------------------------------------------------------------------
        use Proc_Var_X_Io_Error_Function;  
        Old : X_Procedure_Variable;  
    begin  
        X_Lib.Set_Io_Error  
           (Display      => Display,  
            Proc         => Proc_Var_X_Io_Error_Function.From_Pv (Handler),  
            Old_Proc     => Old,  
            All_Displays => False);  
        return Proc_Var_X_Io_Error_Function.To_Pv (Old);  
    end X_Set_Io_Error_Handler;

--\f

    function X_Set_Report_Handler (Handler : Proc_Var_X_Report_Error.Pv)  
                                  return Proc_Var_X_Report_Error.Pv is
------------------------------------------------------------------------------
-- X_Report_Error_Handler - This function sets the handler that prints all
-- error messages (X_Error_Report_Pv) to be the specified routine.  If NULL is
-- passed in the original error handler is restored.  The old routine is
-- returned.
------------------------------------------------------------------------------
        use Proc_Var_X_Report_Error;  
        Old : X_Procedure_Variable;  
    begin  
        X_Lib.Set_Io_Error (Display => None_X_Display,  
                            Proc => Proc_Var_X_Report_Error.From_Pv (Handler),  
                            Old_Proc => Old,  
                            All_Displays => True);  
        return Proc_Var_X_Report_Error.To_Pv (Old);  
    end X_Set_Report_Handler;

--\f

    function X_Set_Report_Handler (Display : X_Display;  
                                   Handler : Proc_Var_X_Report_Error.Pv)  
                                  return Proc_Var_X_Report_Error.Pv is
------------------------------------------------------------------------------
-- X_Report_Error_Handler - This function sets the handler that prints all
-- error messages (X_Error_Report_Pv) to be the specified routine.  If NULL is
-- passed in the original error handler is restored.  The old routine is
-- returned.
------------------------------------------------------------------------------
        use Proc_Var_X_Report_Error;  
        Old : X_Procedure_Variable;  
    begin  
        X_Lib.Set_Io_Error (Display => Display,  
                            Proc => Proc_Var_X_Report_Error.From_Pv (Handler),  
                            Old_Proc => Old,  
                            All_Displays => False);  
        return Proc_Var_X_Report_Error.To_Pv (Old);  
    end X_Set_Report_Handler;

--\f

end Xlbp_Error;
DataMuseum.dk

Rational R1000/400 Tapes

⟦642a0f2a0⟧ TextFile

Derivation

TextFile
