      *>----------------------------------------------------------------
      *> The ExceptionManager stores and manages exception handlers.
      *> Each exception handler is a callback which you register against
      *> the object by sending the message "register" to the
      *> ExceptionManager.
      *>
      *> The ExceptionManager also provides the "errorMessage" method to
      *> retrieve the error message for a specific exception number.
      *>#See the section Exception Handling.
      *>#See method "register".
      *>#See method "errorMessage".
      *>
      *> Copyright (C) 1991-1999 Micro Focus International Ltd.
      *>
      *>----------------------------------------------------------------
      $if multithreaded defined
      $set serial
      $end

      $set mfoo
       class-id. Exceptionmanager data is protected
                       inherits from dependent with data.


        object section.
        class-control.
           Dependent is class "dependnt"
           ExceptionManager is class "exptnmgr"
           callback is class "callback"
           cobolcomp5 is class "comp5"
           cobolpicx is class "picx"
           identitydictionary is class "idictnry"
           dictionary is class "dictinry"
           association is class "associtn"
           characterArray is class "chararry"
           orderedcollection is class "ordrdcll"
           .

       class-object.

       object-storage section.
      *>>---------------------------------------------------------------
      *>> The default system handler for this class library
      *>>---------------------------------------------------------------
       01 systemhandler            usage object reference value null.

      *>>---------------------------------------------------------------
      *>> A dictionary which maps an object to an exception handler
      *>>---------------------------------------------------------------

       01 exceptionlist        usage object reference value null.

      *>>---------------------------------------------------------------
      *>> Used when the user's handler whether instance, class or system
      *>> based fails (results in recursive exception)
      *>>---------------------------------------------------------------

       01 backupsystemhandler  usage object reference value null.

      *>>---------------------------------------------------------------
      *>> Determines whether the last exception raised was for a static
      *>> or a real object. This may be used to determine whether the
      *>> object handle or the static class was passed as a parameter to
      *>> the handler
      *>>---------------------------------------------------------------


       01 exceptiontype        pic x comp-5 value 0.
           88 staticexception value 1.
           88 referenceexception value 0.

      *>>---------------------------------------------------------------
      *>> Dictionary to store registered message strings
      *>>---------------------------------------------------------------
       01 strregister-dict object reference value null.
       01 fregister-dict object reference value null.

      *>>---------------------------------------------------------------
      *>> An ordered collection used to store exception handlers
      *>>---------------------------------------------------------------
       01 systemhandlers       usage object reference value null.

      *>----------------------------------------------------------------
      *> PRIVATE. initialize class data
      *>----------------------------------------------------------------
       method-id. "initializeclass".

       local-storage section.
       01 i                         pic s9(9) comp-5.
       01 messageselector           pic x(80).

       procedure division.
           invoke super "initializeclass"
           if systemhandlers = null then
               move "DefaultHandler" to messageselector
               invoke callback "new" using self messageselector
                                       returning systemhandler
               invoke callback "new" using self messageselector
                                       returning backupsystemhandler
               move 10 to i
               invoke identitydictionary "ofValues" using
                                 association i returning exceptionlist
               invoke orderedcollection "ofReferences" using i
                                 returning systemhandlers
               invoke systemhandlers "add" using systemhandler
           end-if
           exit method.
       end method "initializeclass".
      *>---------------------------------------------------------------
      *> Overrides the system handler and returns the previous system
      *> handler.
      *>---------------------------------------------------------------
       method-id. "setSystemHandler".
       linkage section.
       01 lnkSystemHandler     usage object reference.
       01 lnkOldSystemHandler  usage object reference.

       procedure division using lnkSystemHandler
                      returning lnkOldSystemHandler.
           invoke systemhandlers "first" returning lnkOldSystemHandler
           invoke systemhandlers "addFirst" using lnkSystemHandler
           exit method.
       end method "setSystemHandler".
      *>---------------------------------------------------------------
      *> Return the system handler.
      *>---------------------------------------------------------------
       method-id. "getSystemHandler".
       linkage section.
       01 lnkSystemHandler     usage object reference.

       procedure division returning lnkSystemHandler.
           invoke systemhandlers "first" returning lnkSystemHandler
           exit method.
       end method "getSystemHandler".
      *>---------------------------------------------------------------
      *> Returns the description of the error for anExceptionNumber.
      *> If the number is less than 10,000 then this is a Micro Focus
      *> predefined exception, so it looks in the file OOCOBOL.LNG.
      *> Otherwise it is a user-defined exception.
      *> If the error number is less than 65536, we look in the file
      *> USERDF.LBR\USER.LNG.
      *> Otherwise we expect that the error has been previously
      *> registered with the system by invoking either
      *> "registermessagefile" or "registermessagestring", so we look
      *> in the appropriate registered location.
      *>---------------------------------------------------------------
       method-id. "errorMessage".
       working-storage section.
       01 cblextension                 pic x(20) value "lng ".
       78 usrlibraryname               value "user ".
       78 usrMsgfilename               value "user ".
       78 cblMsgfilename               value "oocobol ".
       78 cbllibrary                   value " ".
       01 UTILSLBR                  pic x(9) value "utils.lbr".

       local-storage section.
       01 i                            pic s9(9) comp-5.
       01 msgBuffer                    pic x(80).

       01 nlsBlock.
           03 message-set-number       pic xx comp-x.
           03 message-number           pic xx comp-x.
           03 max-buffer-len           pic xx comp-x.
           03 actual-message-len       pic xx comp-x.
           03 msg-flags                pic xx comp-x.
       01 lsmessage                    usage object reference.
       01 msgNumber                    pic x(4) comp-5.
       01 aSize                        pic x(4) comp-5.
       01.
          03 lbrandfile.
             05 ls-lbrname             pic x(6).
             05                        pic x.
             05 ls-filename            pic x(8).
             05                        pic x.
          03 lsbool                    pic x comp-x.

       linkage section.
       01 anexceptionnumber            pic s9(9) comp-5.
       01 amessage                     usage object reference.

       procedure division using anexceptionnumber
                          returning amessage.
           move anexceptionnumber to msgNumber
           move length of msgBuffer to max-buffer-len
           move 1 to message-set-number
           move zero to msg-flags
           move msgNumber to message-number
           if msgNumber <= 10000
               move cbllibrary to ls-lbrname
               move cblmsgfilename to ls-filename
               perform make-call
           else
               if strregister-dict not = null then
                   invoke strregister-dict "includeskey" using msgnumber
                                returning lsbool
                   if lsbool = 1 then
                       invoke strregister-dict "atornil" using msgnumber
                                returning lsmessage
                       invoke lsmessage "copy" returning amessage
                       exit method
                   end-if
               end-if
               if fregister-dict = null then
                   move 0 to lsbool
               else
                   divide msgnumber by 65536 giving asize
                   multiply asize by 65536 giving asize
                   invoke fregister-dict "includes" using asize
                             returning lsbool
               end-if
               if lsbool = 1 then
                   invoke fregister-dict "keyatdata" using asize
                                returning lbrandfile
                   perform make-call
               else
                   move usrlibraryname to ls-lbrname
                   move usrmsgfilename to ls-filename
                   perform make-call
               end-if
           end-if

           evaluate return-code
               when 0
                  move actual-message-len to asize
                  invoke characterarray "withByteLengthValue"
                                                using asize msgBuffer
                                            returning amessage
               when other
                  move zero to i
                  invoke CharacterArray "withLength" using i
                                                 returning aMessage
           end-evaluate
           exit method.

       make-call section.
           if message-number > 10000
               subtract 10000 from message-number
           end-if
           call "CBL_NLS_GET_MSG" using ls-lbrname
                                        ls-filename
                                        cblextension
                                        nlsBlock
                                        msgBuffer
           on exception
               call UTILSLBR
               call "CBL_NLS_GET_MSG" using ls-lbrname
                                            ls-filename
                                            cblextension
                                            nlsBlock
                                            msgBuffer
           end-call
           .
       end method "errorMessage".
      *>---------------------------------------------------------------
      *> PRIVATE. Returns true if the last exception raised was for
      *> an object reference as opposed to a static
      *>---------------------------------------------------------------
       method-id. "raisedReference".
       linkage section.
       01 lsbool                   pic x comp-5.
          88 lsistrue              value 1.
          88 lsisfalse             value 0.

       procedure division returning lsbool.
           if referenceexception
               set lsistrue to true
           else
               set lsisfalse to true
           end-if
           exit method.
       end method "raisedReference".
      *>---------------------------------------------------------------
      *> PRIVATE. Returns true if the last exception raised was for
      *> a static
      *>---------------------------------------------------------------
       method-id. "raisedStatic".
       linkage section.
       01 lsbool                   pic x comp-5.
          88 lsistrue              value 1.
          88 lsisfalse             value 0.

       procedure division returning lsbool.
           move exceptiontype to lsbool
           exit method.
       end method "raisedStatic".
      *>---------------------------------------------------------------
      *> PRIVATE. Causes the registered handler for a static instance
      *> of the class anObject to be invoked
      *>---------------------------------------------------------------
       method-id. "raiseStatic".
       local-storage section.
       01 acallback            usage object reference.

       linkage section.
       01 anobject             usage object reference.
       01 anexceptionnumber    pic s9(9) comp-5.
       01 astring              usage object reference.
       01 result               usage object reference.

       procedure division using anobject anexceptionnumber astring
                               returning result.

           invoke self "handler" using anobject
                               returning acallback
           set staticexception to true
           invoke acallback "invoke" using anobject
                                           anexceptionnumber
                                           astring
                                 returning result
           exit method.
       end method "raiseStatic".
      *>---------------------------------------------------------------
      *> PRIVATE. Causes the registered handler for anObject to be
      *> invoked.
      *>---------------------------------------------------------------
       method-id. "raise".
       local-storage section.
       01 acallback            usage object reference.

       linkage section.
       01 anobject             usage object reference.
       01 anexceptionnumber    pic s9(9) comp-5.
       01 astring              usage object reference.
       01 result               usage object reference.

       procedure division using anobject anexceptionnumber astring
                               returning result.
           invoke self "handler" using anobject
                               returning acallback
           set referenceexception to true
           invoke acallback "invoke" using anobject
                                           anexceptionnumber
                                           astring
                                 returning result.
           exit method.
       end method "raise".
      *>---------------------------------------------------------------
      *> PRIVATE. Return the handler that will get invoked if an
      *> exception is raised upon the object anObject.
      *>---------------------------------------------------------------
       method-id. "handler".
       local-storage section.
       01 aclass               usage object reference.
       01 bool                 pic x comp-5.
          88 istrue            value 1.
          88 isfalse           value 0.
       01 i                    pic x(4) comp-5.
       01 j                    pic x(4) comp-5.

       linkage section.
       01 anobject             usage object reference.
       01 ahandler             usage object reference.

       procedure division using anobject
                               returning ahandler.
           set ahandler to null
           invoke exceptionlist "includesKey" using anobject
                               returning bool
           if istrue
               invoke exceptionlist "at" using anobject
                               returning ahandler
           else
               invoke anobject "class" returning aclass
               invoke exceptionlist "includesKey" using aclass
                               returning bool
               if istrue
                   invoke exceptionlist "at" using aclass
                               returning ahandler
               end-if
           end-if
           if ahandler not = null
               invoke ahandler "active" returning bool
           else
               set istrue to true
           end-if
           if istrue
               invoke systemhandlers "size" returning j
               perform varying i from 1 by 1 until isfalse or i > j
                   invoke systemhandlers "at" using i returning ahandler
                   invoke ahandler "active" returning bool
               end-perform
               if istrue then
                   set ahandler to backupsystemhandler
               end-if
           end-if
           exit method.
       end method "handler".
      *>----------------------------------------------------------------
      *> Remove the ExceptionManager that is registered with anObject
      *> Returns true if an exception handler was cancelled, false
      *> otherwise.
      *>----------------------------------------------------------------
       method-id. "cancel".
       local-storage section.

       linkage section.
       01 anobject             usage object reference.
       01 bool                 pic x comp-5.
           88 istrue           value 1.
           88 isfalse          value 0.

       procedure division using anobject returning bool.
           invoke exceptionlist "includesKey" using anobject
                               returning bool
           if istrue
                invoke exceptionlist "removeKey" using anobject
           end-if
           exit method.
       end method "cancel".
      *>----------------------------------------------------------------
      *> Register aHandler with anObject so that when an exception is
      *> raised aHandler is invoked.
      *> aHandler should be a CallBack pointing to a method which expects
      *> three parameters and returns an object reference.
      *> The first parameter will be an object reference containing the
      *> object upon which the exception was raised.
      *> The second parameter will be a pic x(4) comp-5 item containing
      *> the exception number.
      *> The third parameter is optional. It will be an object reference
      *> containing either null or an ordered collection of characterarray
      *> objects, which can contain additional information about the error.
      *>----------------------------------------------------------------
       method-id. "register".
       linkage section.
       01 anobject             usage object reference.
       01 ahandler             usage object reference.

       procedure division using anobject ahandler.
          invoke exceptionlist "atPut" using anobject ahandler
          exit method.
       end method "register".

      *>----------------------------------------------------------------
      *> Register message file with a range of error numbers, so if an
      *> exception is raised on a number within the range the exception
      *> handler knows which file to open to retrieve the error message
      *> text.
      *> Returns the offset to which error numbers for that file should
      *> be added before invoking the exception handler
      *> It is assumed that the error numbers in each file will be
      *> less than 65536.
      *>----------------------------------------------------------------
       method-id. "registermessagefile".
       local-storage section.
       01 dictentry.
          03 lbrandfile.
             05 ls-lbrname     pic x(6).
             05                pic x.
             05 ls-filename    pic x(8).
             05                pic x.
          03 alength           pic x(4) comp-5.
       01.
          03 x16class          object reference.
          03 x4c5class         object reference.
          03 assoctemplate     object reference.
          03 lsbool            pic x comp-x.

       linkage section.
       01 lbrname              pic x(6).
       01 filename             pic x(8).
       01 msgoffset            pic s9(9) comp-5.

       procedure division using lbrname filename returning msgoffset.
          move spaces to lbrandfile
          unstring lbrname delimited by space into ls-lbrname
          unstring filename delimited by space into ls-filename
          if fregister-dict = null then
              move 16 to alength
              invoke cobolpicx "newclass" using alength
                               returning x16class
              move 4 to alength
              invoke cobolcomp5 "newclass" using alength
                               returning x4c5class

              invoke association "newclass" using
                               x16class
                               x4c5class
                               returning assoctemplate
              move 16 to alength
              invoke dictionary "ofvalues" using
                               assoctemplate
                               alength
                               returning fregister-dict
          end-if
          invoke fregister-dict "includeskey" using lbrandfile
                               returning lsbool
          if lsbool = 1 then
            *> this lbr/filename combination has already been registered
              invoke fregister-dict "atornil" using lbrandfile
                               returning msgoffset
              exit method
          end-if
          invoke fregister-dict "size" returning msgoffset
          add 2 to msgoffset
          multiply msgoffset by 65536 giving msgoffset
          invoke fregister-dict "atput" using lbrandfile msgoffset
          exit method.
       end method "registermessagefile".
      *>----------------------------------------------------------------
      *> Returns the offset to which error numbers from a file which has
      *> previously been registered by invoking "registermessagefile"
      *> should be added before invoking the exception handler
      *> If the file has not been registered, zero is returned.
      *>----------------------------------------------------------------
       method-id. "querymessagefile".
       local-storage section.
       01 dictentry.
          03 lbrandfile.
             05 ls-lbrname     pic x(6).
             05                pic x.
             05 ls-filename    pic x(8).
             05                pic x.
          03 alength           pic x(4) comp-5.
       01.
          03 lsbool            pic x comp-x.

       linkage section.
       01 lbrname              pic x(6).
       01 filename             pic x(8).
       01 msgoffset            pic s9(9) comp-5.

       procedure division using lbrname filename returning msgoffset.
          move spaces to lbrandfile
          unstring lbrname delimited by space into ls-lbrname
          unstring filename delimited by space into ls-filename
          move 0 to msgoffset
          if fregister-dict = null then
              exit method
          end-if
          invoke fregister-dict "includeskey" using lbrandfile
                               returning lsbool
          if lsbool = 1 then
              *> this lbr/filename combination has been registered
              invoke fregister-dict "atornil" using lbrandfile
                               returning msgoffset
              exit method
          end-if
          exit method.
       end method "querymessagefile".
      *>----------------------------------------------------------------
      *> Register error message text.
      *> Returns an error number which should be used when the
      *> exception handler is invoked.
      *>----------------------------------------------------------------
       method-id. "registermessagestring".
       local-storage section.
       01 dictentry.
          03 alength       pic x(4) comp-5.
       01.
          03 x16class      object reference.
          03 x4c5class     object reference.
          03 assoctemplate object reference.
          03 exceptionnum  pic s9(9) comp-5.
          03 result        object reference.
          03 amessage      object reference.

       01 lsObject         object reference.

       linkage section.
       01 errorstring      object reference.
       01 errornum         pic s9(9) comp-5.

       procedure division using errorstring returning errornum.
          if strregister-dict = null then
              move 4 to alength
              invoke cobolcomp5 "newclass" using alength
                           returning x4c5class
              set lsObject to null
              invoke association "newclass" using
                           x4c5class
                           lsObject *> means object reference
                           returning assoctemplate
              move 56 to alength
              invoke dictionary "ofvalues" using
                           assoctemplate
                           alength
                           returning strregister-dict
          end-if
          *> we cannot easily tell if this message string has already
          *> been registered, so always re-register.
          invoke strregister-dict "size" returning errornum
          if errornum >= 65535 then
              *> can't cope with more than 65535 messages
              move 39 to exceptionnum
              invoke self "raiseexception" using exceptionnum
                           returning result
              exit method
          end-if
          add 65537 to errornum
          invoke errorstring "copy" returning amessage
          invoke strregister-dict "atput" using errornum amessage
          exit method.
       end method "registermessagestring".

      *>----------------------------------------------------------------
      *> PRIVATE. This method the default exception handler is called
      *> whenever an exception is raised and not trapped by the user.
      *> This can be overidden either by registering an exception
      *> handler for a particular class by invoking the "register"
      *> method, or by overriding the system handler by invoking the
      *> "setSystemHandler" method.
      *> Notice invoking this method may cause execution to terminate.
      *>----------------------------------------------------------------
       method-id. "defaultHandler".
       local-storage section.
       01 anobjectreference    usage object reference.
       01 anobjectnumber
           redefines anobjectreference  pic x(ObjectReferenceSize)
                                       comp-5.
       01 adisplayobjectnumber pic 9(8).
       01 i                       pic x(4) comp-5.
       01 j                    pic x(4) comp-5.
       01 astring              usage object reference.
       01 amessage             usage object reference.
       01 achar                pic x.
       01 trueorfalse          pic 9 comp-5.
          88 istrue  value 1.
          88 isfalse value 0.
       01 lsmsgfh               object reference.
       01 string1               usage object reference.
       01 string2               usage object reference.
       01 lsPos.
                03 colnum  pic x comp-x.
                03 rownum  pic x comp-x.
       01 lsStatus             pic x(4) comp-5.

       linkage section.
       01 errnumber            pic x(4) comp-5.
       01 anobject             usage object reference.
       01 lnktextstringclln    usage object reference.

       procedure division using anobject errnumber lnktextstringclln.
           *>> This really forces the default window
           *>> to be displayed.

           call "CBL_GET_CSR_POS" using lsPos
                                returning lsStatus

           display spaces

           if errNumber = 23 *>> If can't create instance
                             *>> Probably can't create anything else
                             *>> Won't be able to use msgfh
               display "Exception 23 not trapped. instance not created"
                            with no advancing
               display "Hit enter to terminate program."
               accept achar
               stop run
           else
               invoke self "registerBaseMessageFile"
                                returning lsmsgfh
               *>> Special handling for does not understand exception
               if errnumber = 24
           *>> LNG 7 "Exception 24 not trapped. %1$s object reference: %2$s"
                   set anobjectreference to anObject
                   move anobjectnumber to adisplayobjectnumber
                   invoke anObject "description" returning string1
                   move 8 to i
                   invoke characterarray "withlengthvalue"
                            using i adisplayobjectnumber
                            returning string2
                   move 2 to i
                   move 7 to j
                   invoke lsmsgfh "getmessage" using i j string1 string2
                   returning aString
                   invoke string1 "finalize" returning string1
                   invoke string2 "finalize" returning string2
                   invoke aString "display"
                   invoke aString "finalize" returning aString
                   display spaces
           *>> LNG 8: "Does not understand: %s"
                   invoke anObject "whatDidntIunderstand"
                                returning string1
                   move 2 to i
                   move 8 to j
                   invoke lsmsgfh "getmessage" using i j string1
                                returning aString
                   invoke string1 "finalize" returning string1
                   invoke aString "display"
                   invoke aString "finalize" returning aString
                   display spaces
               else
           *>> LNG 9: "Exception %s not trapped by %s."
                   invoke errnumber as cobolcomp5 "asCharacterArray"
                                returning string1
                   invoke ExceptionManager "raisedStatic"
                                       returning trueorfalse
                   if isfalse
                       invoke anobject "description" returning string2
                   else
                       invoke anobject "description" returning string2
           *>>         invoke null as anobject "description"
           *>>                 returning string2
                   end-if
                   move 2 to i
                   move 9 to j
                   invoke lsmsgfh "getmessage" using i j string1 string2
                   returning aString
                   invoke string1 "finalize" returning string1
                   invoke string2 "finalize" returning string2
                   invoke aString "display"
                   invoke aString "finalize" returning aString
                   display spaces

           *>> LNG 10: 'Description: "%s"'
                   invoke ExceptionManager "errorMessage" using
                               errnumber returning amessage
                   invoke aMessage "size" returning i
                   if i > 0
                       invoke amessage "trimBlanks" returning string1

                       move 2 to i
                       move 10 to j
                       invoke lsmsgfh "getmessage" using i j string1
                                returning aString
                       invoke string1 "finalize" returning string1
                       invoke aString "display"
                       invoke aString "finalize" returning aString
                       display spaces
                   end-if
                   invoke amessage "finalize" returning amessage
                   if lnktextstringclln not = null then
                       invoke lnktextstringclln "size" returning i
                       if i > 0 then
                           perform varying j from 1 by 1 until j > i
                               invoke lnktextstringclln "at" using j
                                    returning astring
                               invoke astring "display"
                               display space
                           end-perform
                       end-if
                   end-if
               end-if
           end-if

           *>> LNG 11: "Hit T to terminate program. Hit any other key to continue."
           move 2 to i
           move 11 to j
           invoke lsmsgfh "getmessage" using i j
                   returning aString
           invoke aString "display"
           invoke aString "finalize" returning aString
           invoke lsmsgfh "finalize" returning lsmsgfh
           display space

           call "CBL_READ_KBD_CHAR" using achar
           if aChar = "T" or aChar = "t"
                 stop run
           end-if
           exit method.
       end method "DefaultHandler".

       end class-object.

       Object.

       object-storage section.

       end object.
       end class ExceptionManager.
