      *>----------------------------------------------------------------
      *> An instance of EntryCallback stores an entry-point which can
      *> be called later.
      *> In effect it wraps the block of code for an entry-point inside
      *> an object which you can store or pass to other objects.
      *>
      *> Send the "invoke" message to an EntryCallback instance to
      *> execute the method stored inside it.
      *>
      *>#See the section Using Callbacks.
      *>
      *>!Note
      *> The maximum message length is 30 characters.
      *>
      *> Copyright (C) 1991-1999 Micro Focus International Ltd.
      *>
      *>----------------------------------------------------------------
      $set  nosmalldd mfoo
       class-id. entryCallback data is protected
               inherits from Dependent
                  with data.

       special-names.
           call-convention 0 is paramcountcheck
           call-convention 66 is WAPI
           .
        object section.
        class-control.
           CharacterArray is class "chararry"
           entryCallback is class "entrycll"
           Dependent is class "dependnt".

       working-storage section.

       class-object.

       object-storage section.

      *>----------------------------------------------------------------
      *> Return an instance of EntryCallback pointing to the entry-point
      *> aMessageName and up to six parameters. When you send this
      *> instance the "invoke" message, it invokes aMessageName on
      *> object aReceiver.
      *>
      *> The parameters p1 to p6 are optional. The addresses of any
      *> parameters you pass into the "new" method are stored in the
      *> Callback instance. When you invoke the Callback instance, the
      *> parameters are passed through to method aMessageName preceeding
      *> the parameters passed through with the "invoke" message.
      *>
      *> If you pass in more than six parameters with the "new" method
      *> then Callback raises an exception.
      *>
      *>#See the section Using Callbacks.
      *>
      *>----------------------------------------------------------------
       method-id. "new".
       local-storage section.
       01  local-stuff.
        02 exceptionnumber          pic s9(9) comp-5.
        02 sendObjectHandle         usage object reference.
        02 messageText              pic x(80).
        02 parmPointer              usage pointer.
        02 serverid                 pic x(4) comp-5.

       linkage section.
       01 p1                   usage object reference.
       01 p2                   usage object reference.
       01 p3                   usage object reference.
       01 p4                   usage object reference.
       01 p5                   usage object reference.
       01 p6                   usage object reference.
       01 p7notallowed         usage object reference.
       01 result               usage object reference.
       01 amessagename         pic x(80).
       01 parmDescriptor       pic x.

       procedure division paramcountcheck
                        using amessagename p1 p2 p3 p4 p5 p6
                        p7notallowed
                        returning result.
           if address of p7notallowed not = null
               move 20 to exceptionnumber
               invoke self "raiseException" using exceptionnumber
                                             returning result
               exit method
           else
               invoke super "basicnew" returning result
               invoke result "initialize" using amessagename
                                                   p1
                                                   p2
                                                   p3
                                                   p4
                                                   p5
                                                   p6
           end-if
           exit method.
       end method "new".
       end class-object.

       Object.

       object-storage section.


       01 critSect             pointer.



       01 finalizeStatus       pic x comp-5.
                88 requestFinalize value 1.


      *>>---------------------------------------------------------------
      *>> The name of the method to be isInvoked
      *>>---------------------------------------------------------------

       01 messagename          pic x(81). *>> 80 + 1 for the space
                                          *>>terminator

       78 maxnumparams         value 15.
      *>>---------------------------------------------------------------
      *>> A cobol table storing the addresses of the parameters passed
      *>> when an instance of BoundMethod is created
      *>>---------------------------------------------------------------

       01 parameters occurs maxnumparams.
          05 Objectparms       usage object reference.

      *>>---------------------------------------------------------------
      *>> The number of parameters passed at instantiation
      *>>---------------------------------------------------------------
       01 numparams            pic x(4) comp-5.


      *>>---------------------------------------------------------------
      *>> Counts how many times this bound method has been isInvoked in
      *>> the current call chain
      *>>---------------------------------------------------------------

       01 isInvoked            pic x(4) comp-5.

      *>----------------------------------------------------------------
      *> Return true if this bound method is executing in the current
      *> call chain.
      *>----------------------------------------------------------------
       method-id. "active".
       linkage section.
       01 bool             pic x comp-5.
           88 isfalse      value 0.
           88 istrue       value 1.

       procedure division returning bool.
           copy "csenter".
           if isInvoked > 0
               set istrue to true
           else
               set isfalse to true
           end-if
           copy "csleave".
           exit method.
       end method "active".
      *>----------------------------------------------------------------
      *> Return the entry-point name of this Callback.
      *> Returns 81 characters as it includes the space terminator.
      *>----------------------------------------------------------------
       method-id. "getMessage".
       linkage section.
       01 lnkMessage        pic x(81).
       procedure division returning lnkMessage.
           move messageName to lnkMessage
           exit method.
       end method "getMessage".

      *>----------------------------------------------------------------
      *> Return a description for this instance.
      *>----------------------------------------------------------------
       method-id. "description".
       01 wsString          pic x(160) value " for code entitled ".
       local-storage section.
       01 lsString         usage object reference.
       01 lsString2        usage object reference.       
       01 i                pic x(4) comp-5.

       linkage section.
       01 lnkMessage        pic x(81).
       procedure division returning lnkMessage.
           invoke super "description" returning lsString
           move messageName to wsString(20:)
           invoke CharacterArray "withValue" using wsString
                                        returning lsString2
           invoke lsString "concat" using lsString2 
                                returning lnkMessage
           invoke lsString "finalize" returning lsString           
           invoke lsString2 "finalize" returning lsString2
           exit method.
       end method "description".

      *>----------------------------------------------------------------
      *> Returns true if lnkCallback is an instance of EntryCallback
      *> for the same entry-point as the receiver.
      *>----------------------------------------------------------------
       method-id. "equal".
       local-storage section.
       01 lsMessage          pic x(81).
       01 lsClass            object reference.

       linkage section.
       01 lnkCallback        object reference.
       01 lnkBool            pic x comp-5.
          88 isTrue          value 1.
          88 isFalse         value 0.

       procedure division using lnkCallback returning lnkBool.
           invoke lnkCallback "getMessage" returning lsMessage
           invoke lnkCallback "class" returning lsClass
           if messageName = lsMessage and lsClass = selfclass
               set isTrue to true
           else
               set isFalse to true
           end-if
           exit method.
       end method "equal".
      *>----------------------------------------------------------------
      *> Return the value of the nth parameter
      *>----------------------------------------------------------------
       method-id. "getParameter".
       local-storage section.
       01 exceptionNumber  pic x(4) comp-5.
       linkage section.
       01 n                pic x(4) comp-5.
       01 anObject         usage object reference.
       procedure division using n returning anObject.
           if n <= numParams
               set anObject to objectParms(n)
           else
               move 17 to exceptionNumber
               invoke self "raiseException" using exceptionNumber
                           returning anObject
           end-if
           exit method.
       end method "getParameter".

      $if gc defined
      *>----------------------------------------------------------------
      *> Delete the critical section used in implementation.
      *>----------------------------------------------------------------
       method-id. "terminating".
       procedure division.
           copy "csdelete".
           invoke super "terminating" 
           exit method.
       end method "terminating".

      $else
      *>----------------------------------------------------------------
      *> Destroy this callback if it is not on the stack.
      *>----------------------------------------------------------------
       method-id. "finalize".
       linkage section.
       01 anObject         usage object reference.
       procedure division returning anObject.
           copy "csenter".
           if isInvoked = zero
               copy "csleave".
               copy "csdelete".
               invoke super "finalize" returning anObject
           else
               set requestFinalize to true
           end-if
           exit method.
       end method "finalize".
      $end
      *>----------------------------------------------------------------
      *> PRIVATE. Initialize the new instance of this entryCallback.
      *>----------------------------------------------------------------

       method-id. "initialize".
       local-storage section.
       01 i pic x(4) comp-5.
       01 lsCharSize        pic x(4) comp-5.

       01 aString  usage object reference.

       linkage section.
       01 p1                   usage object reference.
       01 p2                   usage object reference.
       01 p3                   usage object reference.
       01 p4                   usage object reference.
       01 p5                   usage object reference.
       01 p6                   usage object reference.
       01 amessagename         pic x(80).

       procedure division paramcountcheck using amessagename p1 p2
                                                       p3 p4 p5 p6.
           copy "csinit".
           move zero to numParams
           if address of p1 not = null
               set objectParms(1) to p1
               move 1 to numParams
               if address of p2 not = null
                   set objectParms(2) to p2
                   move 2 to numParams
                   if address of p3 not = null
                       set objectParms(3) to p3
                       move 3 to numParams
                       if address of p4 not = null
                           set objectParms(4) to p4
                           move 4 to numParams
                           if address of p5 not = null
                               set objectParms(5) to p5
                               move 5 to numParams
                               if address of p6 not = null
                                   set objectParms(6) to p6
                                   move 6 to numParams
                               end-if
                           end-if
                       end-if
                   end-If
               end-if
           end-if
           move spaces to messagename

           *>> Need to search for initial quote to allow
           *>> spacey entry names.


           if amessagename(1:1) = '"'
               move 2 to i
               invoke CharacterArray "charLengthInBytes"
                           using amessagename(i:1)
                       returning lsCharSize
               perform until amessagename(i:lsCharSize) = '"'
                   add lsCharSize to i
                   invoke CharacterArray "charLengthInBytes"
                           using amessagename(i:1)
                       returning lsCharSize
               end-perform

               invoke characterArray "withByteLengthValue"
                                      using i
                                            amessageName
                   returning aString

           else
               invoke characterArray "withSpaceOrNullTerminator"
                       using amessageName
                   returning aString
           end-if


           invoke aString "sizeInBytes" returning i
           if i > 79
               move "entryCallbackMethodNameTooLong" to messageName
           else
               invoke aString "getValue" returning messageName
           end-if
           invoke aString "finalize" returning aString
           move zero to isInvoked
           exit method.
       end method "initialize".
      *>----------------------------------------------------------------
      *> Determine how many parameters there are and call the method
      *> with that number of paramters. The number of parameters is
      *> determined by calculating the sum of the optional parameters
      *> passsed when this CallBack was instantiated and the number of
      *> parameters passed on the invoke message. The parameters passed
      *> on this call succeed those passed at instantiation. The maximum
      *> number of parameters that can be passed with the invoke call is
      *> three, if any more are passed then an exception will be raised.
      *> Return the result of the method executed.
      *>----------------------------------------------------------------

       method-id. "invoke".
       local-storage section.
       01  local-stuff.
        02 ooreturnptr              usage object reference.
        02 exceptionnumber          pic s9(9) comp-5.
        02 numparamsplusargs        pic s9(9) comp-5.
        02 i                        pic x(4) comp-5.
       01 lsObject                  usage object reference.

       01 theParameters.
          05 parm              usage pointer occurs maxnumparams.
       01 lsDoneLeave              pic x comp-5.

       linkage section.
       01 blockeval            usage object reference.
       01 anarg1               usage object reference.
       01 anarg2               usage object reference.
       01 anarg3               usage object reference.
       01 anarg4               usage object reference.
       01 anarg5               usage object reference.
       01 anarg6               usage object reference.
       01 anarg7               usage object reference.
       01 anarg8               usage object reference.
       01 anarg9               usage object reference.
       01 anarg10notallowed    usage object reference.

       procedure division paramcountcheck
                  using anarg1 anarg2 anarg3 anArg4 anArg5
                        anArg6 anArg7 anArg8 anArg9 anArg10NotAllowed
                            returning blockeval.
           copy "csenter".
           move 0 to lsDoneLeave
           move low-values to theParameters
           if address of blockeval = null
               set address of blockeval to address of ooreturnptr
           end-if
           if address of anarg10NotAllowed not = null
               move 21 to exceptionnumber
               invoke self "raiseException" using exceptionnumber
                                             returning blockeval
           else
               perform varying i from 1 by 1 until i > numParams
                   set parm(i) to address of objectParms(i)
               end-perform
               move numparams to numparamsplusargs
               if address of anarg1 not = null
                   add 1 to numparamsplusargs
                   set parm(numparamsplusargs) to address of anarg1
                   if address of anarg2 not = null
                       add 1 to numparamsplusargs
                       set parm(numparamsplusargs) to address of anarg2
                       if address of anarg3 not = null
                           add 1 to numparamsplusargs
                           set parm(numparamsplusargs) to
                                                      address of anarg3
                       end-if
                       if address of anarg4 not = null
                           add 1 to numparamsplusargs
                           set parm(numparamsplusargs) to
                                                      address of anarg4
                       end-if
                       if address of anarg5 not = null
                           add 1 to numparamsplusargs
                           set parm(numparamsplusargs) to
                                                      address of anarg5
                       end-if
                       if address of anarg6 not = null
                           add 1 to numparamsplusargs
                           set parm(numparamsplusargs) to
                                                      address of anarg6
                       end-if
                       if address of anarg7 not = null
                           add 1 to numparamsplusargs
                           set parm(numparamsplusargs) to
                                                      address of anarg7
                       end-if
                       if address of anarg8 not = null
                           add 1 to numparamsplusargs
                           set parm(numparamsplusargs) to
                                                      address of anarg8
                       end-if
                       if address of anarg9 not = null
                           add 1 to numparamsplusargs
                           set parm(numparamsplusargs) to
                                                      address of anarg9
                       end-if

                   end-if
               end-if
               add 1 to isInvoked
               call messagename using by value parm(1)
                                      by value parm(2)
                                      by value parm(3)
                                      by value parm(4)
                                      by value parm(5)
                                      by value parm(6)
                                      by value parm(7)
                                      by value parm(8)
                                      by value parm(9)
                                      by value parm(10)
                                      by value parm(11)
                                      by value parm(12)
                                      by value parm(13)
                                      by value parm(14)
                                      by value parm(15)
                          returning blockeval

               subtract 1 from isInvoked

      $if gc not defined
               if requestFinalize and isInvoked = 0
                   move 1 to lsDoneLeave
                   copy "csleave".
                   invoke self "finalize" returning lsObject
               end-if
      $end
           end-if
           if lsDoneLeave = 0
               copy "csleave".
               continue
           end-if
           exit method.
       end method "invoke".
       end object.
       end class entryCallback.
