// Use AppDB.utl     // Create data tables

Use Base.nui     // Item_Property command, Various macros (FOR_EX...), cArray, cSet and cStack classes
Use API_Attr.nui // Functions for querying API attributes
Use FDX.nui      // cFDX class
Use DBMS.nui     // Basic DBMS functions (No User Interface)
Use StructEx.utl // Restructuring extensions
Use Strings.nui  // String manipulation for VDF (No User Interface)

#IF 1=0
 Meta information fields

 CAPSLOCK
 RANGE
 VALUELIST



#ENDIF

desktop_section
  object oAppDB_FdxFileDef is a cFdxFileDef 
  end_object
end_desktop_section

class cListOfAppDb is a cArray
  item_property_list
    item_property integer phAppDb.i
  end_item_property_list cListOfAppDb
  procedure RegisterAppDb integer lhAppDb
    integer liRow
    get row_count to liRow
    set phAppDb.i liRow to lhAppDb
  end_procedure
end_class // cListOfAppDb

desktop_section
  object oListOfAllAppDb is a cListOfAppDb 
  end_object
end_desktop_section

class cAppDbFieldList is a cArray
  item_property_list
    item_property string  psName.i       // Field name
    item_property integer piType.i       // Field type
    item_property integer piLength.i
    item_property integer piPrecision.i
    item_property integer piOverlapFrom.i
    item_property integer piOverlapTo.i
    item_property integer piMainIndex.i
    item_property integer piRelFile.i
    item_property integer piRelField.i
    item_property integer piOverlapOffset.i
  end_item_property_list cAppDbFieldList
  procedure DoReset
    send delete_data
  end_procedure
  function iFindFieldName.s string lsFieldName returns integer
    integer liMax liRow
    get row_count to liMax
    decrement liMax
    move (uppercase(lsFieldName)) to lsFieldName
    for liRow from 0 to liMax
      if (uppercase(psName.i(self,liRow))=lsFieldName) function_return liRow
    loop
    function_return -1
  end_function
  function iByteLengthFieldRange integer liFromRow integer liToRow returns integer
    integer liRval liRow liType liLength
    move 0 to liRval
    for liRow from liFromRow to liToRow
      get piType.i liRow to liType
      if (liType<>DF_OVERLAP) begin
        get piLength.i liRow to liLength
        if liType eq DF_BCD move (liLength/2) to liLength
        move (liRval+liLength) to liRval
      end
    loop
    function_return liRval
  end_function
  procedure DoEndDefinition
    integer liRow liMax liFromRow liToRow liOffset liLength
    get row_count to liMax
    decrement liMax
    for liRow from 0 to liMax // Dates
      if (piType.i(self,liRow)=DF_DATE) set piLength.i liRow to 3
    loop
    for liRow from 0 to liMax
      if (piType.i(self,liRow)=DF_OVERLAP) begin
        move (piOverlapFrom.i(self,liRow)-1) to liFromRow
        move (piOverlapTo.i(self,liRow)-1) to liToRow
        get iByteLengthFieldRange 0 (liFromRow-1) to liOffset
        increment liOffSet
        get iByteLengthFieldRange liFromRow liToRow to liLength
        set piLength.i liRow to liLength
        set piOverlapOffset.i liRow to liOffset
      end
    loop
  end_procedure
  procedure DoAddField string lsName integer liType number lnLength
    integer liRow liPrecision
//    if (length(lsName)>15) error 254 ("Field name too long ("+lsName+")")
    get row_count to liRow
    set psName.i   liRow to lsName
    set piType.i   liRow to liType
    if liType eq DF_BCD begin
      move (lnLength-integer(lnLength)*10) to liPrecision
      move (integer(lnLength)) to lnLength
      set piLength.i liRow to (lnLength+liPrecision)
      set piPrecision to liPrecision
    end
    else set piLength.i liRow to lnLength
  end_procedure
  procedure Set piPrecision integer liPrecision
    set piPrecision.i (row_count(self)-1) to liPrecision
  end_procedure
  procedure Set piMainIndex integer liIndex
    set piMainIndex.i (row_count(self)-1) to liindex
  end_procedure
  procedure Set piOverlapFieldRange integer liFieldFrom integer liFieldTo
    set piOverlapFrom.i (row_count(self)-1) to liFieldFrom
    set piOverlapTo.i   (row_count(self)-1) to liFieldTo
  end_procedure
  procedure Set piRelation integer liFile integer liField
    set piRelFile.i  (row_count(self)-1) to liFile
    set piRelField.i (row_count(self)-1) to liField
  end_procedure
end_class // cAppDbFieldList

class cAppDbIndexList is a cArray
  procedure construct_object integer liImg
    forward send construct_object liImg
    property integer piCurrentDefiningIndex public -1
  end_procedure
  item_property_list
    item_property integer piOnline.i // On-line/Batch
    item_property string  psFields.i
    item_property string  psUppercase.i
    item_property string  psDirection.i
  end_item_property_list cAppDbIndexList
  function iSegments.i integer liIndex returns integer
    function_return (length(psFields.i(self,liIndex))/4)
  end_function
  procedure DoReset
    send delete_data
  end_procedure
  procedure DoAddIndex integer liIndex integer liOnLine
    set piCurrentDefiningIndex to liIndex
    set piOnline.i liIndex to liOnline
  end_procedure
  procedure DoAddSegment integer liField integer lbUppercased integer liDirection
    integer liIndex
    get piCurrentDefiningIndex to liIndex
    set psFields.i    liIndex to (psFields.i(self,liIndex)+pad(string(liField),4))
    set psUppercase.i liIndex to (psUppercase.i(self,liIndex)+pad(string(lbUppercased),4))
    set psDirection.i liIndex to (psDirection.i(self,liIndex)+pad(string(liDirection),4))
  end_procedure
  function iHelpExtract.si string lsValue integer liSegment returns integer
    function_return (mid(lsValue,4,liSegment-1*4+1))
  end_function
  function iIndexSegmentField integer liIndex integer liSegment returns integer
    function_return (iHelpExtract.si(self,psFields.i(self,liIndex),liSegment))
  end_function
  function iIndexSegmentUppercase integer liIndex integer liSegment returns integer
    function_return (iHelpExtract.si(self,psUppercase.i(self,liIndex),liSegment))
  end_function
  function iIndexSegmentDirection integer liIndex integer liSegment returns integer
    function_return (iHelpExtract.si(self,psDirection.i(self,liIndex),liSegment))
  end_function
end_class // cAppDbIndexList

class cAppDbTable is a cAppDbFieldList
  procedure construct_object integer liImg
    integer liSelf
    forward send construct_object liImg
    property integer piFile            public 0
    property string  psRoot            public ""
    property string  psLogicalName     public ""
    property string  psUserName        public ""
    property integer piMaxRecords      public 10000
    property integer piMultiuser       public DF_FILE_USER_MULTI
    property integer piReuse_deleted   public DF_FILE_DELETED_REUSE
    property integer piCompression     public DF_FILE_COMPRESS_NONE
    property integer piIntegrity_check public DFTRUE
    property integer piTransaction     public DF_FILE_TRANSACTION_CLIENT_ATOMIC
    property integer piLockType        public DF_LOCK_TYPE_FILE
    object oAppDbIndexList is a cAppDbIndexList 
    end_object

    property integer prv.DefineCalled public DFFALSE

    move self to liSelf
    send DoRegisterTableDefinition liSelf // Caught by enclosing cAppDb object
  end_procedure

  procedure OnDefine
  end_procedure

  procedure DoDefine
    ifnot (prv.DefineCalled(self)) begin
      set prv.DefineCalled to DFTRUE // Important that this is first.
      send DoReset_Help DFFALSE
      send OnDefine
      send DoEndDefinition
    end
  end_procedure

  procedure DoReset_Help integer lbAll
    forward send DoReset
    send DoReset to (oAppDbIndexList(self))
    if lbAll begin
      set piFile            to 0
      set psRoot            to ""
      set psLogicalName     to ""
      set psUserName        to ""
      set piMaxRecords      to 10000
      set piMultiuser       to DF_FILE_USER_MULTI
      set piReuse_deleted   to DF_FILE_DELETED_REUSE
      set piCompression     to DF_FILE_COMPRESS_NONE
      set piIntegrity_check to DF_FILE_INTEGRITY_CHECK
      set piTransaction     to DF_FILE_TRANSACTION_CLIENT_ATOMIC
    end
  end_procedure

  procedure DoReset
    send DoReset_Help DFTRUE
  end_procedure

  procedure set FileListValues integer liFile string lsRoot string lsLogicalName string lsUserName
    set piFile        to liFile
    set psRoot        to lsRoot
    set psLogicalName to lsLogicalName
    set psUserName    to lsUserName
  end_procedure

  procedure DoAddIndex integer liIndex integer lbOnLine
    send DoAddIndex to (oAppDbIndexList(self)) liIndex lbOnLine
  end_procedure
  procedure DoAddSegment integer liField integer lbUppercased integer liDirection
    send DoAddSegment to (oAppDbIndexList(self)) liField lbUppercased liDirection
  end_procedure
  procedure DoAddOnlineIndex integer liIndex string lsFieldNames
    integer liItem liSegments liField
    integer lbUppercased lbDescending
    string lsFieldName
    send DoAddIndex liIndex DF_INDEX_TYPE_ONLINE
    get HowManyWords lsFieldNames " ," to liSegments
    for liItem from 1 to liSegments
      get ExtractWord lsFieldNames " ," liItem to lsFieldName

      if (left(lsFieldName,1)="-") begin
        move (StringRightBut(lsFieldName,1)) to lsFieldName
        move DFTRUE to lbDescending
      end
      else move DFFALSE to lbDescending

      if (uppercase(lsFieldName)=lsFieldName) move DFTRUE to lbUppercased
      else move DFFALSE to lbUppercased

      get iFindFieldName.s lsFieldName to liField
      increment liField

      if (liField=0 and uppercase(lsFieldName)<>"RECNUM") move -1 to liField

      if (liField<>-1) ;
         send DoAddSegment liField ;
           (if(lbUppercased,DF_CASE_IGNORED,DF_CASE_USED)) ;
           (if(lbDescending,DF_DESCENDING,DF_ASCENDING))
      else error 652 "Illegal fieldname in index spec (AppDB)"
    loop
  end_procedure
  procedure DoRelate string lsFileDotField
    string lsDFFileName lsFieldName
    integer lhObj liField
    get ExtractWord lsFileDotField "." 1 to lsDFFileName
    get ExtractWord lsFileDotField "." 2 to lsFieldName
    if (lsDFFileName="" or lsFieldName="") error 653 ("Illegal relation name ("+lsFileDotField+")")
    else begin
      get iFindObjectTableName.s lsDFFileName to lhObj
      if (lhObj=-1) error 654 ("Illegal relation name ("+lsFileDotField+")")
      else begin
        send DoDefine to lhObj
        get iFindFieldName.s of lhObj lsFieldName to liField
        if (liField=-1) error 655 ("Illegal relation name ("+lsFileDotField+")")
        else set piRelation to (piFile(lhObj)) (liField+1)
      end
    end
  end_procedure
  function iIndexSegmentField integer liIndex integer liSegment returns integer
    function_return (iIndexSegmentField(oAppDbIndexList(self),liIndex,liSegment))
  end_function
  function iIndexSegmentUppercase integer liIndex integer liSegment returns integer
    function_return (iIndexSegmentUppercase(oAppDbIndexList(self),liIndex,liSegment))
  end_function
  function iIndexSegmentDirection integer liIndex integer liSegment returns integer
    function_return (iIndexSegmentDirection(oAppDbIndexList(self),liIndex,liSegment))
  end_function
  function iIndexSegments integer liIndex returns integer
    function_return (iSegments.i(oAppDbIndexList(self),liIndex))
  end_function
  function iIndexType integer liIndex returns integer
    function_return (piOnline.i(oAppDbIndexList(self),liIndex))
  end_function

  procedure OnTableOpened
  end_procedure
  procedure OnTableCreated // Sent when a definition was created
  end_procedure

  // Function returns   1   if table can be opened,
  //                    0   if not
  //             and   -1   if incompatible FileList data exists
  function iCheckFile returns integer
    integer liFile liRval
    string lsRoot lsFileListRoot
    get piFile to liFile
    get psRoot to lsRoot
    get API_AttrValue_FILELIST DF_FILE_ROOT_NAME liFile to lsFileListRoot
    if (lsFileListRoot="") begin // Maybe we should create the file
      set_attribute DF_FILE_ROOT_NAME    of liFile to lsRoot
      set_attribute DF_FILE_LOGICAL_NAME of liFile to (psLogicalName(self))
      set_attribute DF_FILE_DISPLAY_NAME of liFile to (rtrim(psUserName(self)))
    end

    get API_AttrValue_FILELIST DF_FILE_ROOT_NAME liFile to lsFileListRoot
    if (uppercase(DBMS_StripPathAndDriver(lsRoot))<>uppercase(DBMS_StripPathAndDriver(lsFileListRoot))) function_return -1 // Incompatible FileList data

    get DBMS_CanOpenFile liFile to liRval
    if liRval move 1 to liRval // Otherwise liRval indicates the driver needed
    else begin
      send DoTransferDefToFdx self (oAppDB_FdxFileDef(self))
      get RSX_CreateTableFromFDX (oAppDB_FdxFileDef(self)) liFile lsRoot to liRval
      if liRval send OnTableCreated
    end

    function_return liRval
  end_function

  function iOpen returns integer
    integer liFile liRval
    get piFile to liFile
    get DBMS_OpenFile liFile to liRval
    if liRval send OnTableOpened
    function_return liFile
  end_function
end_class // cAppDbTable

class cAppDb is a cArray
  procedure construct_object integer liImg
    forward send construct_object liImg
    property string  psLocation     public ""
    property integer piDescriptImg  public 0
    send RegisterAppDb to (oListOfAllAppDb(self)) self
  end_procedure

  procedure DoReset
    integer liItm liMax lhObj
    get item_count to liMax
    decrement liMax
    for liItm from 0 to liMax
      get value item liItm to lhObj
      if lhObj send request_destroy_object to lhObj
    loop
    send delete_data
  end_procedure

  procedure DoRegisterTableDefinition integer lhObj
    set value item (item_count(self)) to lhObj
  end_procedure

  function iFindObjectTableName.s string lsDFFileName returns integer
    integer liItm liMax lhObj
    get item_count to liMax
    decrement liMax
    move (uppercase(lsDFFileName)) to lsDFFileName
    for liItm from 0 to liMax
      get value item liItm to lhObj
      if (uppercase(psLogicalName(lhObj))=lsDFFileName) function_return lhObj
    loop
    // function_return 0
  end_function

  function iFindTableRow.i integer liFile returns integer
    integer liItm liMax
    get item_count to liMax
    decrement liMax
    for liItm from 0 to liMax
      if (piFile(value(self,liItm))=liFile) function_return liItm
    loop
    function_return -1
  end_function

  function iOperational returns integer
    integer liItm liMax lhObj liStatus liRval
    get item_count to liMax
    decrement liMax
    move 1 to liRval
    for liItm from 0 to liMax
      get value item liItm to lhObj
      get iCheckFile of lhObj to liStatus
      if (liStatus<>1) move 0 to liRval
    loop
    function_return liRval
  end_function

  function iOpen returns integer
    integer liItm liMax lhObj liStatus liRval
    get item_count to liMax
    decrement liMax
    move 1 to liRval
    for liItm from 0 to liMax
      get value item liItm to lhObj
      get iOpen of lhObj to liStatus
      if (liStatus=0) move 0 to liRval
    loop
    function_return liRval
  end_function

  function iCreateNewTableObject integer liFile string lsRoot string lsLogical string lsDisplay returns integer
    integer liRval
    object oAppDbTable is a cAppDbTable
      set FileListValues to liFile lsRoot lsLogical lsDisplay
      move self to liRval
    end_object
    function_return liRval
  end_function
end_class // cAppDb

procedure DoTransferDefToFdx global integer lhAppDbTable integer lhFdx
  integer liRow liMax liFile liFieldType liIndex liSegment liMaxSegment

  send DoDefine to lhAppDbTable
  send Reset to lhFdx
  get piFile of lhAppDbTable to liFile
  set piMainFile of lhFDX to liFile

  set AttrValue_FILE of lhFDX DF_FILE_MAX_RECORDS     liFile to (piMaxRecords(self))
  set AttrValue_FILE of lhFDX DF_FILE_MULTIUSER       liFile to (piMultiuser(self))
  set AttrValue_FILE of lhFDX DF_FILE_REUSE_DELETED   liFile to (piReuse_deleted(self))
  set AttrValue_FILE of lhFDX DF_FILE_COMPRESSION     liFile to (piCompression(self))
  set AttrValue_FILE of lhFDX DF_FILE_INTEGRITY_CHECK liFile to (piIntegrity_check(self))
  set AttrValue_FILE of lhFDX DF_FILE_TRANSACTION     liFile to (piTransaction(self))
  set AttrValue_FILE of lhFDX DF_FILE_LOCK_TYPE       liFile to (piLockType(self))
  set AttrValue_FILE of lhFDX DF_FILE_RECORD_LENGTH   liFile to 8 // Automatically incremented during field appending

  get row_count of lhAppDbTable to liMax
  set AttrValue_FILE of lhFDX DF_FILE_NUMBER_FIELDS liFile to liMax
  decrement liMax
  for liRow from 0 to liMax
    get piType.i of lhAppDbTable liRow to liFieldType
    set AttrValue_FIELD of lhFDX DF_FIELD_NAME          liFile (liRow+1) to (psName.i(lhAppDbTable,liRow))
    set AttrValue_FIELD of lhFDX DF_FIELD_TYPE          liFile (liRow+1) to liFieldType
    set AttrValue_FIELD of lhFDX DF_FIELD_LENGTH        liFile (liRow+1) to (piLength.i(lhAppDbTable,liRow))
    set AttrValue_FIELD of lhFDX DF_FIELD_PRECISION     liFile (liRow+1) to (piPrecision.i(lhAppDbTable,liRow))
    set AttrValue_FIELD of lhFDX DF_FIELD_RELATED_FILE  liFile (liRow+1) to (piRelFile.i(lhAppDbTable,liRow))
    set AttrValue_FIELD of lhFDX DF_FIELD_RELATED_FIELD liFile (liRow+1) to (piRelField.i(lhAppDbTable,liRow))
    set AttrValue_FIELD of lhFDX DF_FIELD_INDEX         liFile (liRow+1) to (piMainIndex.i(lhAppDbTable,liRow))
    if liFieldType eq DF_OVERLAP begin
      set AttrValue_FIELD of lhFDX DF_FIELD_OFFSET      liFile (liRow+1) to (piOverlapOffset.i(lhAppDbTable,liRow))
    end
  loop

  for liIndex from 1 to 15
    get iIndexSegments of lhAppDbTable liIndex to liMaxSegment
    if liMaxSegment begin
      set AttrValue_INDEX of lhFDX DF_INDEX_TYPE            liFile liIndex to (iIndexType(lhAppDbTable,liIndex))
      set AttrValue_INDEX of lhFDX DF_INDEX_NUMBER_SEGMENTS liFile liIndex to liMaxSegment
      for liSegment from 1 to liMaxSegment
        set AttrValue_IDXSEG of lhFDX DF_INDEX_SEGMENT_FIELD     liFile liIndex liSegment to (iIndexSegmentField(lhAppDbTable,liIndex,liSegment))
        set AttrValue_IDXSEG of lhFDX DF_INDEX_SEGMENT_DIRECTION liFile liIndex liSegment to (iIndexSegmentDirection(lhAppDbTable,liIndex,liSegment))
        set AttrValue_IDXSEG of lhFDX DF_INDEX_SEGMENT_CASE      liFile liIndex liSegment to (iIndexSegmentUppercase(lhAppDbTable,liIndex,liSegment))
      loop
    end
  loop
//send FDX_ModalDisplayFileAttributes lhFdx liFile
end_procedure
procedure DoTransferFdxToDef global integer lhFdx integer lhAppDbTable
end_procedure