      *>----------------------------------------------------------------
      *> A Cobolcompx stores a COBOL pic x(n) comp-x enabling you to
      *> treat data of this type as an object.
      *> This class provides the basic comparison operators,
      *> display mechanism and hashing methods for compx 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(150)
       class-id. cobolcompx data is protected
               inherits from intrinsic with data.


        object section.
        class-control.
           intrinsic is class "intrnsic"
           cobolcompx is class "compx"
           cobolpicx is class "picx"
           characterarray is class "chararry"
           cobolcomp5 is class "comp5".
       working-storage section.
       78 maxsize        value 8.

       class-object.

       object-storage section.

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

       procedure division.
           invoke super "initializeclass"
           move 4 to storagerequirements
           exit method.
       end method "initializeclass".

      *>----------------------------------------------------------------
      *> Return CobolCOMPX as the base class for any clone of CobolCOMPX
      *>----------------------------------------------------------------
       method-id. "baseClass".
       linkage section.
       01 lnkclass          usage object reference.

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

      *>----------------------------------------------------------------
      *> 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 CobolCompX
          else
              invoke super "newClass" using aLength
                  returning lnkClass
          end-if
       exit method.
       end method "newClass".

      *>----------------------------------------------------------------
      *> 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 cobolCOMPX (indicated by compareValue and
      *> compareLength) is Equal to this CobolCOMPX else return False.
      *>----------------------------------------------------------------
       method-id. "equalbyLengthValue".
       local-storage section.

       01 arealcompx-1           pic x(8) comp-x.
       01 realcompxbytes1        pic x(8) redefines arealcompx-1.
       01 arealcompx-2           pic x(8) comp-x.
       01 realcompxbytes2        pic x(8) redefines arealcompx-2.
       01 startpt                pic x(4) comp-5.
       01 sReq                   pic x(4) comp-5.

       linkage section.
       01 bool             pic x comp-x.
           88  istrue      value 1.
           88  isfalse     value 0.
       01 comparelength    pic x(4) comp-5.
       01 comparevalue.
           03 abyte        pic x  occurs 1 to maxsize
                               depending on comparelength.

       procedure division using comparelength comparevalue
                                            returning bool.
           invoke selfclass "sizeInBytes" returning sReq
           move zero to arealcompx-1 arealcompx-2
           compute startpt = maxsize - comparelength + 1
           move comparevalue to realcompxbytes2(startpt : comparelength)
           compute startpt = maxsize - SReq + 1
           move instancedata(1 : SReq) to realcompxbytes1(startpt:SReq)
           if arealcompx-2 = arealcompx-1
               set istrue to true
           else
               set isfalse to true
           end-if
           exit method.
       end method "equalbyLengthValue".

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

       01 arealcompx-1           pic x(8) comp-x.
       01 realcompxbytes1        pic x(8) redefines arealcompx-1.
       01 arealcompx-2           pic x(8) comp-x.
       01 realcompxbytes2        pic x(8) redefines arealcompx-2.
       01 startpt                pic x(4) comp-5.
       01 sReq                   pic x(4) comp-5.

       linkage section.
       01 bool             pic x comp-x.
           88  istrue      value 1.
           88  isfalse     value 0.
       01 comparelength    pic x(4) comp-5.
       01 comparevalue.
           03 abyte        pic x  occurs 1 to maxsize
                               depending on comparelength.

       procedure division using comparelength comparevalue
                                         returning bool.
           invoke selfclass "sizeInBytes" returning sReq
           compute startpt = maxsize - SReq + 1
           move zero to arealcompx-1 arealcompx-2
           move instancedata(1 : SReq) to realcompxbytes1(startpt:SReq)
           compute startpt = maxsize - comparelength + 1
           move comparevalue to realcompxbytes2(startpt : comparelength)
           if arealcompx-1 < arealcompx-2
               set istrue to true
           else
               set isfalse to true
           end-if
           exit method.
       end method "lessThanByLengthValue".

      *>----------------------------------------------------------------
      *> Return True if this CobolCOMPX is greater than the cobolCOMPX
      *> indicated by compareValue and compareLength else return False.
      *>----------------------------------------------------------------
       method-id. "greaterThanByLengthValue".
       local-storage section.

       01 arealcompx-1           pic x(8) comp-x.
       01 realcompxbytes1        pic x(8) redefines arealcompx-1.
       01 arealcompx-2           pic x(8) comp-x.
       01 realcompxbytes2        pic x(8) redefines arealcompx-2.
       01 startpt                pic x(4) comp-5.
       01 sReq                   pic x(4) comp-5.

       linkage section.
       01 bool             pic x comp-x.
           88  istrue      value 1.
           88  isfalse     value 0.
       01 comparelength    pic x(4) comp-5.
       01 comparevalue.
           03 abyte        pic x  occurs 1 to maxsize
                               depending on comparelength.

       procedure division using comparelength comparevalue
                                                  returning bool.
           invoke selfclass "sizeInBytes" returning sReq
           compute startpt = maxsize - SReq + 1
           move zero to arealcompx-1 arealcompx-2
           move instancedata(1 : SReq) to realcompxbytes1(startpt:SReq)
           compute startpt = maxsize - comparelength + 1
           move comparevalue to
                        realcompxbytes2(startpt:comparelength)
           if arealcompx-1 > arealcompx-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. "asCompX".
       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 "asCompX".
      *>----------------------------------------------------------------
      *> Return an instance of a COMP5 with the same value as this
      *> COMPX.
      *>----------------------------------------------------------------
       method-id. "asComp5".
       local-storage section.
       01 realcomp5              pic x(8) comp-5.
       01 realcomp5bytes         pic x(8) redefines realcomp5.
       01 arealcompx-1           pic x(8) comp-x.
       01 realcompxbytes1        pic x(8) redefines arealcompx-1.
       01 startpt                pic x(4) comp-5.
       01 anewclass                usage object reference.
       01 sReq                   pic x(4) comp-5.
       01 lsflag pic x comp-5.
           88 highEnd value 1.
           88 lowEnd value 0.

       linkage section.
       01 anintrinsic      usage object reference.

       procedure division returning anintrinsic.
           invoke selfclass "sizeInBytes" returning sReq
           move zero to arealcompx-1
           compute startpt = maxsize - SReq + 1
           move instancedata(1 : SReq) to realcompxbytes1(startpt:SReq)
           move arealcompx-1 to realcomp5
           invoke cobolcomp5 "newClass" using SReq returning anewclass
           invoke cobolcomp5 "testComp5Order" returning lsflag
           if HighEnd then
               invoke anewclass "withValue"
                          using realcomp5bytes(1 : SReq)
                          returning anintrinsic
           else
               invoke anewclass "withValue"
                          using realcomp5bytes(startpt : SReq)
                          returning anintrinsic
           end-if
           exit method.
       end method "asComp5".
      *>----------------------------------------------------------------
      *> Return the hash value of the COMPX item
      *>----------------------------------------------------------------
       method-id. "hash".
       local-storage section.

       01 arealcompx-1           pic x(8) comp-x.
       01 realcompxbytes1        pic x(8) redefines arealcompx-1.
       01 startpt                pic x(4) comp-5.
       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 arealcompx-1
           compute startpt = maxsize - SReq + 1
           move instancedata(1 : SReq) to realcompxbytes1(startpt:SReq)
           move arealcompx-1 to ahashvalue
           if ahashvalue < 0
               compute ahashvalue = - ahashvalue
           end-if
           exit method.
       end method "hash".

      *>----------------------------------------------------------------
      *> Convert this compx to a PICX with leading zeroes dismissed
      *>----------------------------------------------------------------
       method-id. "asPicX".
       local-storage section.

       01 adisplayfield          pic 9(18).
       01 arealcompx-1           pic x(8) comp-x.
       01 realcompxbytes1        pic x(8) redefines arealcompx-1.
       01 i                      pic x(4) comp-5.
       01 startpt                pic x(4) comp-5.
       01 asize                  pic x(4) comp-5.
       01 sReq                   pic x(4) comp-5.

       linkage section.
       01 lnkstring         usage object reference.

       procedure division returning lnkstring.
           invoke selfclass "sizeInBytes" returning sReq
           move zero to arealcompx-1
           compute startpt = maxsize - SReq + 1
           move instancedata(1 : SReq) to realcompxbytes1(startpt:SReq)
           move arealcompx-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 compx to a CharacterArray with leading zeroes
      *> dismissed
      *>----------------------------------------------------------------
       method-id. "asCharacterArray".
       local-storage section.

       01 adisplayfield          pic 9(18).
       01 arealcompx-1           pic x(8) comp-x.
       01 realcompxbytes1        pic x(8) redefines arealcompx-1.
       01 i                      pic x(4) comp-5.
       01 startpt                pic x(4) comp-5.
       01 asize                  pic x(4) comp-5.
       01 sReq                   pic x(4) comp-5.

       linkage section.
       01 lnkstring         usage object reference.

       procedure division returning lnkstring.
           invoke selfclass "sizeInBytes" returning sReq
           move zero to arealcompx-1
           compute startpt = maxsize - SReq + 1
           move instancedata(1 : SReq) to realcompxbytes1(startpt:SReq)
           move arealcompx-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".


      *>----------------------------------------------------------------
      *> Return 1 inidcating this is a CObol COmp-X object.
      *>----------------------------------------------------------------
       method-id. "isCompX".
       linkage section.
       01 lnkBool          pic x comp-5.

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

       end object.
       end class cobolcompx.
