Wiki Home

Vfp 6 Collection Class


Namespace: SoftwareEng
VFP8 introduces a native Collection Class, which can be used in FOR EACH, and which has a default "Items" property, so that the members can be referenced as:
CollectionObject.Items("Whatever")
* or as 
CollectionObject("Whatever")

However, there is a bug in VFP8 which breaks BOTH the FOR EACH and the Default "Items" property, so, until those bugs are fixed, using either is not recommended.

Therefore, you can implement your own Collection Class in VFP6/7, which is Just as Useful as the VFP8 Collection Class: It even has a default "Items" property, which is broken!! (that is, you can implement the default property, and it works some of the time, but not all the time)

Here is one implementation. This is not necessarily the best: you could improve it to be ordered by key, or to have faster lookups. I used a "getter" and "setter" methods so that subclasses can override these methods and use a storage mechanism other than the internal Array: You can make a subclass of this collection which is an interface to a particular branch of the registry, for example. Or (what I do) as an interface to your program's options.
DEFINE CLASS myCollection AS Session
  *  Author: William GC Steinford
  * Purpose: Provide a way to aggregate data in an easy to manage way.
  *          Also, allow for a string "key" to be associated with each
  *                item of data for easy retrieval.
  *          Also, allow for a subclass to override the "Getter" and
  *                "setter" methods to make "collection-like" classes
  *                that are groups of data stored anywhere.
  *
  DataSession = 1 && Default DataSession..Could use a private DS
  
  * Public Interface Properties:
  Count       = 0
  DIMENSION Items[1]
  DIMENSION Names[1]

  * Public Interface Methods:
  * Add( vDataItem [, cKey ] )
  * Delete( ncIdx )
  * Clear
  * GarbageCollect

  * Hidden implementation Properties:
  PROTECTED HashNames[1]      && vfpv6 allowed "PROTECTED DIMENSION prop[1]", vfp7 doesn't allow the DIMENSION keyword.
  PROTECTED SrchHashNames[1]  && These are 'cleaned up' for case-insensitive searching
  PROTECTED DataItems[1]      && This is the actual data.

  * Hidden implementation Methods:
  * Init
  * IndexOf      -- Looks up a particular Key
  * SetDataItem  -- Setter.. override to use storage other than array
  * ItemData     -- Getter.. override to use storage other than array
  * Items_Assign -- Intercepts Items["string"] to allow char keys
  *                   to be used in the array property.
  * Items_Access -- Intercepts Items["string"] to allow char keys
  *                   to be used in the array property.
  * Names_Assign -- Intercepts assignments of .Names to maintain
  *                   the HashNames lookup array, and to allow
  *                   subclasses to use other means of storage
  * Names_Access -- Intercepts accesses of .Names to allow
  *                   subclasses to use other means of storage
  
  PROCEDURE Init
    SET TALK OFF
    SET ECHO OFF
    * In case a subclass has a Private DS, set the required settings.
    if THIS.DataSession=2 && Initialize the Private DataSession
      SET DELETED ON
      SET COLLATE TO 'MACHINE'
      SET EXCLUSIVE OFF
    endif
  ENDPROC

  PROCEDURE Add( pvItem, pcHash )
    * Add pre-created Item to the collection
    LOCAL lnIdx, lnI
    lnIdx = 0
    if VarType(pcHash)='C' and not empty(pcHash)
      lnIdx = THIS.IndexOf(pcHash)
    endif
    if lnIdx=0
      THIS.Count = THIS.Count + 1
      DIMENSION THIS.DataItems[ THIS.Count ]
      DIMENSION THIS.HashNames[ THIS.Count ]
      DIMENSION THIS.SrchHashNames[ THIS.Count ]
      lnIdx = THIS.Count
      THIS.HashNames[lnIdx] = iif(VarType(pcHash)='C',pcHash,'')
      THIS.SrchHashNames[lnIdx] = upper(alltrim(THIS.HashNames[lnIdx]))
    endif
    THIS.DataItems[lnIdx]     = pvItem
    RETURN lnIdx
  ENDPROC &&--------------------
  PROCEDURE ItemData( pnIdx )
    * This is a hook to let subclasses return specific data
    * for specific indices
    if BETWEEN( pnIdx, 1, alen(THIS.DataItems) )
      RETURN THIS.DataItems[pnIdx]
    else
      RETURN .NULL.
    endif
  ENDPROC
  PROCEDURE SetItemData( pvNewVal, pnIdx )
    * This is a hook to let subclasses return specific data
    * for specific indices
    THIS.DataItems[pnIdx] = pvNewVal
    RETURN THIS.DataItems[pnIdx]
  ENDPROC
  PROCEDURE Items_Access( pncIdx )
    LOCAL RetVal, lnPos
    RetVal = .NULL.
    do case 
      case VarType(pncIdx)='C'
        lnPos = THIS.IndexOf(pncIdx)
        if lnPos>0
          RetVal = THIS.ItemData( lnPos ) 
        endif
      case VarType(pncIdx)='N'
        if Between(pncIdx,1,THIS.Count)
          RetVal = THIS.ItemData( pncIdx )
        endif
    endcase
    RETURN RetVal
  ENDPROC
  PROCEDURE IndexOf( pcIdx )
    LOCAL lnI, lcIdx
    * lnPos = aScan(THIS.HashNames,pncIdx)
    * Let's do it Case Insensitive
    lcIdx = Upper(alltrim(pcIdx))
    lnI = ascan( THIS.SrchHashNames, lcIdx )
    RETURN lnI
    
    for lnI = 1 to THIS.Count
      if upper(alltrim(THIS.HashNames[lnI]))==lcIdx
        RETURN lnI
      endif
    endfor
    RETURN 0
  ENDPROC
  PROCEDURE Items_Assign( pvNewVal, pncIdx )
    LOCAL RetVal, lnPos
    RetVal = .NULL.
    do case 
      case VarType(pncIdx)='C'
        lnPos = THIS.IndexOf(pncIdx)
        if lnPos>0
          RetVal = THIS.SetItemData( pvNewVal, lnPos ) 
        endif
      case VarType(pncIdx)='N'
        if Between(pncIdx,1,THIS.Count)
          RetVal = THIS.SetItemData( pvNewval,  pncIdx )
        endif
    endcase
    RETURN RetVal
  ENDPROC
  PROCEDURE Delete( pncIdx )
    LOCAL lnIdx
    do case
      case VarType(pncIdx)='N'
        lnIdx = pncIdx
      case VarType(pncIdx)='C'
        lnIdx = THIS.IndexOf(pncIdx)
    endcase
    if Between(lnIdx,1,THIS.Count)
      if THIS.Count > 1
        ADEL(THIS.DataItems, lnIdx )
        DIMENSION THIS.DataItems[THIS.Count-1,2]
      endif
      THIS.Count = THIS.Count - 1
    endif
  ENDPROC &&--------------------
  PROCEDURE Clear
    LOCAL lnI, lo
    FOR lnI = 1 to THIS.COUNT
      lo = THIS.DataItems[lnI]
      THIS.DataItems[lnI] = .NULL.
      IF VarType(lo)='O' and PEMSTATUS(lo, "GarbageCollect", 5)  && LEXv00.01 wgcs
        lo.GarbageCollect()
      ENDIF
      RELEASE lo
    ENDFOR
    THIS.Count = 0
    DIMENSION THIS.DataItems[1]
    DIMENSION THIS.HashNames[1]
    DIMENSION THIS.SrchHashNames[1]   && MsgCtr v10.03 wgcs 6/16/03
    THIS.HashNames[1]=''
    THIS.SrchHashNames[1]=''          && MsgCtr v10.03 wgcs 6/16/03
  ENDPROC &&--------------------
  PROCEDURE Names_Access( pnIdx )
    RETURN THIS.HashNames[pnIdx]
  ENDPROC
  PROCEDURE Names_Assign( pvNewVal, pnIdx )
    if VarType(pvNewVal)='C' ;
       AND VarType(pnIdx)='N' ;
       AND Between( pnIdx, 1, THIS.Count )
      THIS.HashNames[pnIdx] = pvNewVal
      THIS.SrchHashNames[pnIdx] = upper(alltrim(pvNewVal))
    endif
  ENDPROC
  
  PROCEDURE GarbageCollect
    THIS.Clear
  ENDPROC
ENDDEFINE



Contributors: wgcs
Category Code Samples
( Topic last updated: 2003.08.03 08:06:10 PM )