      *>----------------------------------------------------------------
      *> A COBOLComp5 stores a COBOL pic x(n) comp-5 enabling you to
      *> treat data of this type as an object.
      *> This class provides the basic comparison operators,
      *> display mechanism and hashing methods for comp5 items.
      *> Its main use is to provide templates for creating collections
      *> "ofValues", and associations.
      *>
      *>#See method "newClass" in class "intrnsic".
      *>
      *> Copyright (C) 1991-1999 Micro Focus International Ltd.
      *>
      *>----------------------------------------------------------------
      $set mfoo localcount(100)
       class-id. COBOLComp5 data is protected
               inherits from intrinsic with data.


        object section.
        class-control.
           intrinsic is class "intrnsic"
           cobolcomp5 is class "comp5"
           cobolcompx is class "compx"
           characterarray is class "chararry"
           cobolpicx is class "picx".
       working-storage section.
       78 maxsize       value 8.
       01 endian5 pic x(4) comp-5 value 1.
       01 endianX pic x(4) comp-x redefines endian5.
       01 whatEnd pic x comp-5.
           88 highEnd value 1.
           88 lowEnd value 0.

       class-object.

       object-storage section.

      *>----------------------------------------------------------------
      *> PRIVATE. initialize class data
      *>----------------------------------------------------------------
       method-id. "initializeclass".
       procedure division.
           invoke super "initializeclass"
           move 4 to storagerequirements
           invoke self "reset"
           exit method.
       end method "initializeclass".

      *>----------------------------------------------------------------
      *> Return a template which can be used when creating collections.
      *> Length of template must be specified. Hence only data of the
      *> same length can be stored in collections.
      *> If you need to store variable length Intrinsics in
      *> collections, then you need to create instances of the intrinsic
      *> subclasses and store those.
      *>----------------------------------------------------------------
       method-id. "newClass".
       local-storage section.
       01 exceptionnumber             pic s9(9) comp-5.
       01 aSize                       pic s9(9) comp-5.

       linkage section.
       01 alength        pic s9(9) comp-5.
       01 lnkclass              usage object reference.

       procedure division using alength returning lnkclass.
          if aLength = 4
              set lnkClass to CobolComp5
          else
              invoke super "newClass" using aLength
                  returning lnkClass
          end-if
       exit method.
       end method "newClass".


      *>----------------------------------------------------------------
      *> Return 1 indicating this is a COBOLComp-5 object.
      *>----------------------------------------------------------------
       method-id. "isComp5".
       linkage section.
       01 lnkBool          pic x comp-5.

       procedure division returning lnkBool.
           move 1 to lnkBool
           exit method.
       end method "isComp5".

      *>----------------------------------------------------------------
      *> Return CobolCOMP5 as the baseclass for all clones of the class
      *> CobolCOMP5
      *>----------------------------------------------------------------
       method-id. "baseClass".
       linkage section.
       01 lnkclass          usage object reference.

       procedure division returning lnkclass.
           set lnkclass to cobolcomp5
           exit method.
       end method "baseClass".

      *>----------------------------------------------------------------
      *> PRIVATE. Determine what type of chip we are running on by
      *> testing which end of a comp-5 is set when assigning it to 1.
      *>----------------------------------------------------------------
       method-id. "reset".
       procedure division.
           if endianX = 1
               set lowEnd to true
           else
               set highEnd to true
           end-if
           exit method.
       end method "reset".

      *>----------------------------------------------------------------
      *> PRIVATE. Returns 0 if running on a low-end chip (which means
      *> comp-5 and comp-x are the same). Returns 1 if running on a
      *> high-end chip (eg Intel)
      *>----------------------------------------------------------------
       method-id. "testComp5Order".
       linkage section.
       01  lnkflag pic x comp-5.
       procedure division returning lnkflag.
           move whatEnd to lnkflag
           exit method.
       end method "testComp5Order".

      *>----------------------------------------------------------------
      *> Return the maximum size that this class can be.
      *>----------------------------------------------------------------
       method-id. "maximumSize".
       linkage section.
       01 alength        pic x(4) comp-5.

       procedure division returning alength.
           move maxsize to alength.
           exit method.
       end method "maximumSize".

       end class-object.

       Object.

       object-storage section.
      *>----------------------------------------------------------------
      *> Return True if the cobolCOMP5 indicated by compareValue and
      *> compareLength is Equal to this CobolCOMP5 else return False.
      *>----------------------------------------------------------------
       method-id. "equalbyLengthValue".
       local-storage section.

       01 arealcomp5-1           pic x(8) comp-5.
       01 realcomp5bytes1        pic x(8) redefines arealcomp5-1.
       01 arealcomp5-2           pic x(8) comp-5.
       01 realcomp5bytes2        pic x(8) redefines arealcomp5-2.
       01 sReq                   pic x(4) comp-5.

       linkage section.
       01 comparevalue  pic x.
       01 bool           pic x comp-5.
           88  istrue  value 1.
           88  isfalse value 0.
       01 comparelength  pic x(4) comp-5.

       procedure division using comparelength comparevalue
                      returning bool.
           move zero to arealcomp5-1 arealcomp5-2
           invoke selfclass "sizeInBytes" returning sReq
           if highEnd
               move comparevalue(1:compareLength)
                                 to realcomp5bytes2(1 : comparelength)
               move instancedata(1 : sReq) to realcomp5bytes1(1 : sReq)
           else
               move comparevalue(1:compareLength)
                                to realcomp5bytes2(maxSize -
                           compareLength + 1 : comparelength)
               move instancedata(1 : sReq) to
                 realcomp5bytes1(maxSize - sReq + 1 : sReq)
           end-if
           if arealcomp5-2 = arealcomp5-1
               set istrue to true
           else
               set isfalse to true
           end-if
           exit method.
       end method "equalbyLengthValue".

      *>----------------------------------------------------------------
      *> Return True if this CobolCOMP5 is less than the cobolCOMP5
      *> indicated by compareValue and compareLength else return False.
      *>----------------------------------------------------------------
       method-id. "lessThanByLengthValue".
       local-storage section.

       01 arealcomp5-1           pic x(8) comp-5.
       01 realcomp5bytes1        pic x(8) redefines arealcomp5-1.
       01 arealcomp5-2           pic x(8) comp-5.
       01 realcomp5bytes2        pic x(8) redefines arealcomp5-2.
       01 sReq                   pic x(4) comp-5.
       linkage section.
       01 comparevalue  pic x.
       01 bool           pic x comp-5.
           88  istrue  value 1.
           88  isfalse value 0.
       01 comparelength  pic x(4) comp-5.

       procedure division using comparelength comparevalue
                                               returning bool.
           move zero to arealcomp5-1 arealcomp5-2
           invoke selfclass "sizeInBytes" returning sReq
           if highEnd
               move instancedata(1 : sReq) to realcomp5bytes1(1 : sReq)
               move comparevalue(1:compareLength)
                         to realcomp5bytes2(1 : comparelength)
           else
               move instancedata(1 : sReq) to realcomp5bytes1
                   (maxSize - sReq + 1 : sReq)
               move comparevalue(1:compareLength) to realcomp5bytes2
                   (maxSize - compareLength + 1 : comparelength)
           end-if
           if arealcomp5-1 < arealcomp5-2
               set istrue to true
           else
               set isfalse to true
           end-if
           exit method.
       end method "lessThanByLengthValue".

      *>----------------------------------------------------------------
      *> PRIVATE.
      *>----------------------------------------------------------------
       method-id. "streamOutCPT".
       local-storage section.
       01 realComp5            pic x(4) comp-5.
       01 realcomp5bytes       pic x(4) redefines realcomp5.
       01 dispComp5            pic 9(10).
       01 lsSize               pic x(4) comp-5.
       linkage section.
       01 lnkStream            usage object reference.

       procedure division using lnkStream.
           move instancedata(1 : 4) to realcomp5bytes(1 : 4)
           move realComp5 to dispComp5
           move 10 to lsSize
           invoke lnkStream "WriteNoIndent" using lsSize dispComp5
           exit method.
       end method "streamOutCPT".
      *>----------------------------------------------------------------
      *> Return True if this CobolCOMP5 is greater than the cobolCOMP5
      *> indicated by compareValue and compareLength else return False.
      *>----------------------------------------------------------------
       method-id. "greaterThanByLengthValue".
       local-storage section.

       01 arealcomp5-1           pic x(8) comp-5.
       01 realcomp5bytes1        pic x(8) redefines arealcomp5-1.
       01 arealcomp5-2           pic x(8) comp-5.
       01 realcomp5bytes2        pic x(8) redefines arealcomp5-2.
       01 sReq                   pic x(4) comp-5.

       linkage section.
       01 comparevalue  pic x.
       01 bool           pic x comp-5.
           88  istrue  value 1.
           88  isfalse value 0.
       01 comparelength  pic x(4) comp-5.

       procedure division using comparelength comparevalue
                                                  returning bool.
           move zero to arealcomp5-1 arealcomp5-2
           invoke selfclass "sizeInBytes" returning sReq
           if highEnd
               move instancedata(1 : sReq) to realcomp5bytes1(1 : sReq)
               move comparevalue(1:compareLength)
                         to realcomp5bytes2(1 : comparelength)
           else
               move instancedata(1 : sReq) to realcomp5bytes1
                       (maxSize - sReq + 1 : sReq)
               move comparevalue(1:compareLength) to realcomp5bytes2
                       (maxSize - compareLength + 1 : comparelength)
           end-if
           if arealcomp5-1 > arealcomp5-2
               set istrue to true
           else
               set isfalse to true
           end-if
           exit method.
       end method "greaterThanByLengthValue".

      *>----------------------------------------------------------------
      *> Return self or a new object if this was an intrinsic invoke
      *>----------------------------------------------------------------
       method-id. "asComp5".
       linkage section.
       01 lnkobjref usage object reference.

       procedure division returning lnkobjref.
           if self = null
               invoke selfclass "withValue" using instanceData
                       returning lnkobjref
           else
               set lnkobjref to self
           end-if
           exit method
       end method "asComp5".
      *>----------------------------------------------------------------
      *> Return an instance of a COMPX with the same value as this
      *> COMP5.
      *>----------------------------------------------------------------
       method-id. "asCompX".
       local-storage section.

       01 realcompx              pic x(8) comp-x.
       01 realcompxbytes         pic x(8) redefines realcompx.
       01 arealcomp5-1           pic x(8) comp-5.
       01 realcomp5bytes1        pic x(8) redefines arealcomp5-1.
       01 startpt                pic x(4) comp-5.
       01 anewclass              usage object reference.
       01 sReq                   pic x(4) comp-5.

       linkage section.
       01 anintrinsic    usage object reference.

       procedure division returning anintrinsic.
           move zero to arealcomp5-1
           invoke selfclass "sizeInBytes" returning sReq
           invoke cobolcompx "newClass" using sReq returning anewclass
           compute startpt = maxsize - sReq + 1
           move zero to arealcomp5-1
           if highEnd
               move instancedata(1 : sReq) to realcomp5bytes1(1 : sReq)
           else
               move instancedata(1 : sReq) to realcomp5bytes1
                   (startpt : sReq)
           end-if
           move arealcomp5-1 to realcompx
           invoke anewclass "withValue" using realcompxbytes(startpt :
                                                sReq)
                                 returning anintrinsic
           exit method.
       end method "asCompX".
      *>----------------------------------------------------------------
      *> Return the hash value of the COMP5 item
      *>----------------------------------------------------------------
       method-id. "hash".
       local-storage section.

       01 arealcomp5-1           pic x(8) comp-5.
       01 realcomp5bytes1        pic x(8) redefines arealcomp5-1.
       01 sReq                   pic x(4) comp-5.

       linkage section.
       01 ahashvalue     pic s9(9) comp-5.

       procedure division returning ahashvalue.
           invoke selfclass "sizeInBytes" returning sReq
           move zero to arealcomp5-1
           if highEnd
               move instancedata(1 : sReq) to realcomp5bytes1(1 : sReq)
           else
               move instancedata(1 : sReq) to realcomp5bytes1
                       (maxSize - sReq + 1 : sReq)
           end-if
           move arealcomp5-1 to ahashvalue
           if ahashvalue < 0
               compute ahashvalue = - ahashvalue
           end-if
           exit method.
       end method "hash".

      *>----------------------------------------------------------------
      *> Convert this comp-5 to a picx representation with no leading
      *> zeroes
      *>----------------------------------------------------------------

       method-id. "asPicX".
       local-storage section.

       01 asize                  pic x(4) comp-5.
       01 adisplayfield          pic 9(18).
       01 arealcomp5-1           pic x(8) comp-5.
       01 realcomp5bytes1        pic x(8) redefines arealcomp5-1.
       01 i                      pic x(4) comp-5.
       01 sReq                   pic x(4) comp-5.

       linkage section.
       01 lnkstring               usage object reference.

       procedure division returning lnkstring.
           move zero to arealcomp5-1
           invoke selfclass "sizeInBytes" returning sReq
           if highEnd
               move instancedata(1 : sReq) to realcomp5bytes1(1 : sReq)
           else
               move instancedata(1 : sReq) to realcomp5bytes1
                   (maxSize - sReq + 1 : sReq)
           end-if
           move arealcomp5-1 to adisplayfield
           perform varying i from 1 by 1 until i > 18 or
                                 adisplayfield(i:1) not = 0
           end-perform
           if i > 18
               move 1 to asize
               move 18 to i
           else
               compute asize = 18 - i + 1
           end-if
           invoke cobolpicx "withLengthValue" using asize
                                              adisplayfield(i : asize)
                            returning lnkstring
           exit method.
       end method "asPicX".
      *>----------------------------------------------------------------
      *> Convert this comp-5 to a characterArray representation with
      *> no leading zeroes
      *>----------------------------------------------------------------

       method-id. "asCharacterArray".
       local-storage section.

       01 asize                  pic x(4) comp-5.
       01 adisplayfield          pic 9(18).
       01 arealcomp5-1           pic x(8) comp-5.
       01 realcomp5bytes1        pic x(8) redefines arealcomp5-1.
       01 i                      pic x(4) comp-5.
       01 sReq                   pic x(4) comp-5.

       linkage section.
       01 lnkstring               usage object reference.

       procedure division returning lnkstring.
           move zero to arealcomp5-1
           invoke selfclass "sizeInBytes" returning sReq
           if highEnd
               move instancedata(1 : sReq) to realcomp5bytes1(1 : sReq)
           else
               move instancedata(1 : sReq) to realcomp5bytes1
                   (maxSize - sReq + 1 : sReq)
           end-if
           move arealcomp5-1 to adisplayfield
           perform varying i from 1 by 1 until i > 18 or
                                 adisplayfield(i:1) not = 0
           end-perform
           if i > 18
               move 1 to asize
               move 18 to i
           else
               compute asize = 18 - i + 1
           end-if
           invoke characterArray "withLengthValue" using asize
                                              adisplayfield(i : asize)
                            returning lnkstring
           exit method.
       end method "asCharacterArray".
      *>----------------------------------------------------------------
      *> Convert this comp-5 to a characterArray representation in HEX
      *>----------------------------------------------------------------

       method-id. "asHEX".
       local-storage section.

       01 adisplayarea           pic x(32).
       01 arealcomp5-1           pic x(8) comp-5.
       01 realcomp5bytes1        pic x(8) redefines arealcomp5-1.
       01 arealcompX             pic x(8) comp-X.
       01 i                      pic x(4) comp-5.
       01 sReq                   pic x(4) comp-5.
       01 Digit                  pic x comp-x.
       01 DigitX redefines Digit pic x.
       01 ByteCount              pic x(4) comp-5.
       01 LoopCount              pic x(4) comp-5.

       linkage section.
       01 lnkstring               usage object reference.

       procedure division returning lnkstring.

           move zero to arealcomp5-1
           invoke selfclass "sizeInBytes" returning sReq
           if highEnd
               move instancedata(1 : sReq) to realcomp5bytes1(1 : sReq)
           else
               move instancedata(1 : sReq) to realcomp5bytes1
                   (maxSize - sReq + 1 : sReq)
           end-if
           move arealcomp5-1 to arealcompX


           *> skip past leading nulls
           move 0 to i
           move 1 to bytecount
           move length of arealcompX to LoopCount
           perform until ByteCount > LoopCount
                        or arealcompX(ByteCount:1) not = X"00"
              add 1 to ByteCount
           end-perform

           if ByteCount > LoopCount
              move "0" to adisplayarea(1:2)
              move 1 to i
           else
              move 0 to i
              perform until ByteCount > LoopCount
                 move H"F0" to Digit           *> High nibble
                 call "CBL_AND" using arealcompX(ByteCount:1)
                                      Digit
                                      by value 1
                 divide H"10" into Digit
                 if Digit > 9
                    add 55 to Digit
                 else
                    add 48 to digit
                 end-if
                 add 1 to i
                 move DigitX to aDisplayArea(i:1)
                 move H"0F" to Digit           *> low nibble
                 call "CBL_AND" using arealcompX(ByteCount:1)
                                      Digit
                                      by value 1
                 if Digit > 9
                    add 55 to Digit
                 else
                    add 48 to digit
                 end-if
                 add 1 to i
                 move DigitX to aDisplayArea(i:1)
                 add 1 to ByteCount
              end-perform
           end-if

           invoke characterArray "withLengthValue" using i
                                              adisplayarea(1 : i)
                            returning lnkstring
           exit method.
       end method "asHEX".


       end object.
       end class cobolcomp5.
