Appendix C

DBUPLUS.EXE Source Modules

Note: In order for this utility to work properly, the source code in 
Appendix D must be compiled and linked in as well. This combination, 
including 15 other useful Clipper utilities, may be found in the package 
called The Pleiades: The Code That Tutors published by Sirius Software.

DBUPLUS.RMK

/* File                 DBUPLUS.RMK
   Notice               Copyright(c) 1991-1994 - Sirius Software Development, Inc
                                               - All Rights Reserved
                        415-399-9810

 */

db_objs:=dbpmain.obj dbpfunc.obj dbpsets.obj dbpopen.obj \
         dbpmake.obj dbpmod.obj dbpsrch.obj \
         dbpclose.obj dbpobj.obj dbpscope.obj \
         dbpmfunc.obj genfunc.obj

#ifndef NOPPO
  ppo = /p
#endif

#ifdef DEBUG
  beta = /b
#endif

includes = \producti\pleiades\include

.prg.obj:
   clipper $< /m /n /w /a /v /es2 /i$(includes) $(ppo) $(beta)

Dbpmain.obj      :       Dbpmain.prg
Dbpfunc.obj      :       Dbpfunc.prg
dbpsets.obj      :       dbpsets.prg
dbpopen.obj      :       dbpopen.prg
dbpmake.obj      :       dbpmake.prg
dbpmod.obj       :       dbpmod.prg
dbpsrch.obj      :       dbpsrch.prg
dbpclose.obj     :       dbpclose.prg
dbpobj.obj       :       dbpobj.prg
dbpscope.obj     :       dbpscope.prg
dbpmfunc.obj     :       dbpmfunc.prg
genfunc.obj      :       genfunc.prg

// Dependency rule for linking into the .exe
.obj.exe:
    rtlink @dbuplus.lnk

DBUPLUS.exe      :       $(db_objs)

// End of File: Dbuplus.rmk

DBUPLUS.LNK

FI DBPMAIN
FI DBPFUNC
FI DBPSETS
FI DBPOPEN
FI DBPMAKE
FI DBPMOD
FI DBPSRCH
FI DBPCLOSE
FI DBPOBJ
FI DBPSCOPE
FI DBPMFunc
FI genfunc
pll base52
OUTPUT dbuplus.exe

DBPMenu.ch

/* File:        DBPMENU.CH
   Notice:      Copyright(c) 1991-1994 Sirius Software Development, Inc. 
                                       - All Rights Reserved
   Author:      Steve Straley
   Project:     The Pleiades
*/

#define pSLASH 47
#define pMAIN_BAR_SPACE 3
#define  pNUM_ARR     1
   #define  pNUM_ELES    1 // Number of elements to display
   #define  pWIDEST_ELE  2 // Widest element
   #define  pDISP_ROW    3 // Row to display text menu on
   #define  pDISP_COL    4 // Col to display text menu on
   #define  pINIT_ELE    5 // Initial element
   #define  pREL_ELE     6 // Offset element
#define  pCHX_ARR        2 // Array of choices
   #define  pCHX_HOTLET  1 // Substring into CHX_STRING to be hot letter
   #define  pCHX_STRING  2 // Menu Selection text to display
#define  pFUNC_ARR       3 // Array of functions to execute
#define  pLOGIC_ARR      4 // Array of access
#define  pCOLOR_ELE      5 // Color scheme to use
#define  pSCREEN_ELE     6 // Image save

// Special enhancements of color for gernal purposes and for the menues
#define pMONO_MONITOR  1
#define pCOLOR_MONITOR 2
#define pCHR_NORM      1
#define pCHR_HIGH      2
#define pCHR_BLINK     3
#define pCHR_INV       4
#define pCHR_BINV      5
#define pCLR_SHAD      6
#define pCLR_DATA      7
#define pCLR_TEXT      8
#define pCLR_CALC      9
#define pCLR_INFLD    10
#define pCLR_NOCHX    11
#define pHOT_CHX      12
#define pCHR_SHAD     13
#define pCHR_DATA     14
#define pCHR_TEXT     15
#define pCHR_INFLD    16
#define pCLR_NORM     17
#define pCLR_HIGH     18
#define pCLR_BLINK    19
#define pCLR_INV      20
#define pCLR_BINV     21
#define pCLR_MENU     22
#define pCHR_MENU     23
#define pCLR_MESSAGE  24

// End of File: DBPMenu.ch

DBPMain.prg

/* File              DBPMAIN.PRG
   Notice            Copyright(c) 1991-94 Sirius Software Development, Inc.
                     All Rights Reserved
   Author            Steve Straley

   DBPMAIN is the main module for the DBUPLus program.  It handles capturing
   and processing keystrokes, and houses "main are" functions.

   The DBUPlus program is broken into 10 different .prg files.  These are:

   DBPMain  - Main menu module
   ---------------------------
      ActiveArea    Get/Set an array of the defined objects and active work area.
      AddMembers    Handles creating structures to hold open files.
      BoxArea       Highlight/de-highlight a window.
      ChangeArea    Change the currently active window.
      DBUplus       Startup, main menu, activate menu if necessary.
      DosShell      Allows user to shell to dos.
      DrawSCreen    Draws the main four window DBUPlus screen.
      Enditall      Closes all files, shuts down DBUPlus.
      FullScreen    TBrowse loop that incorporates a full screen.
      GetStart      Determines position in aMembers of browse object in
                    upper left quadrant.
      Help          Simple one screen help.
      Keystroke     Processes keys fetched in main TBrowse loop.
                    Also stabilizes currently active object.
      MakeStable    Handles stabilizing objects, and masking display
                    of objects that should not presently be viewable
      MoreKeys      Processes nonmovement keys by calling their
                    associated functions.
      MoveFour      Moves back/forward four work areas
      SetSeed       Stabilizes objects related to the currently
                    active object.  Called by Keystroke if current
                    object has relations.
      WinCalc       Calculates coordinates for each window

   DBPFunc  - .prg file that houses several self-contained functions that
              perform actions required by a variety of modules, but are
              specific to this application.
   ----------------------------------------------------------------------
      Adjmem           Writes values to a .mem file
      Askip            Skip block for browsing arrays.
      Atext            Creates an array of byte offsets and line widths
                       in order to read large files.
      ChkCond          Simple syntactical checker.
      CopyFiles        Function copying a file FROM/TO
      DirFormat        Constructs current directory with "\" front and back,
                       takes into account root directory
      GetExtension     Function to retrieve a 3 letter extension from user.
                       Used by a variety of functions to construct the
                       proper file name to retrieve the desired type of
                       file.
      GetVarsFromFile  Retrieves values from a .mem file
      Readtext         Called by AText, actually handles constructing the
                       correct byte offsets to define a "line" to view
                       in a text file.
      ShowGenError     General displayer of information in an error object.
      ShowStru         Displays structure of a database.
      Waitmsg          Displays/Erases flashing "Wait" message.

   DBPOpen  - Opens various types of files
   ---------------------------------------
      OpenDatabase     Opens .dbf file
      OpenIndex        Opens index file
      OpenVariables    Opens a .mem file
      OpenFlatFile     Opens a text file
      FileExist        Checks to determine existence of a file

   DBPClose - Closes various types of files
   ----------------------------------------
      CloseThem        Closes the file open in the current area
      WipeIndexes      Closes indexes open in the current area

   DBPMake  - Creates .dbf files
   -----------------------------------------
      Chkfile          Checks for existence of database to create, and
                       gives warning, but allows creation if desired
      Chkname          Validates nonduplicated field names
      Createindex      Creates an index for a .dbf file
      DBmodskip        Skip block for TBRowse used in creating databases
      Getval           Performs GETS for individual field descriptions
      MakeDatabase     Creates a .dbf file

   DBPMod   - Modifies values in files
   -----------------------------------------
      AddRecord        Adds a record to a database in vertical format
      DelRecord        Deletes current record
      EditRecord       Edits current record in database in vertical format
      Modfield         Modifies the field of a database
      ModStru          Modifies the structure of a database
      Packfiles        Packs the database
      Replfield        Replaces values in a field across records, with
                       scope conditions
      Zapfiles         Zaps the database

   DBPObj   - Performs object-wide operations
   ------------------------------------------
      Delcols          Deletes columns in an object
      Lockfield        Allows user to specify columns locked at left
      Twiddle          Reverse the order of pairs of columns

   DBPScope - Provides functions for scoped operations
   ---------------------------------------------------
      AppendFrom       Function for allowing user to specify
                       WHILE/FOR/NEXT, etc. conditions for appending
                       records from a database.
      Condchk          More full-featured condition syntax checker.
                       Handles opening files if necessary
                       (as with an APPEND FROM), testing condition
                       against the database.  Calls Chkcond() as its
                       last step.
      CopyTo           Function for allowing user to specify
                       WHILE/FOR/NEXT, etc. conditions for copying
                       records from a database.  Called by CopyFiles if
                       current TBrowse object is browsing a .dbf file.
      LooknShow        Validation for file to APPEND FROM or COPY TO
      Showtab          Function displaying info/clearing screen
                       when user presses TAB key while in a GET

   DBPSets - Provides functions that affect environment
   ----------------------------------------------------
      ChangeDrive      Allows user to change logged drive
      ChkArea          Allows user to look up active work area/aliases
      Displaydir       Called by Showdirectory , actually outputs file names
      DoStats          Displays settings that are window specific
      Instoggle        Toggles status of the cursor/insert on/off
      JoinArea         Sets a relation based on record number
      Neworder         Allows user to change SET ORDER TO index
      RelateThem       Sets a relation based on a key value
      Screenmodes      Allows user to toggle between 25/43 line mode
      Showdirectory    Parent function for displaying directory files
      ShowKeys         Shows the keys for currently active indexes
      SearchPath       Sets new path for file access
      SetaFilter       Sets a filter
      SetSoft          Toggles SET SOFTSEEK
      SetValues        Displays current SET values
      SetWrap          Toggles SET WRAP
      ToggleDelete     Toggles SET DELETED

   DBPSrch - Searches for values in files
   --------------------------------------
      Gotorecord       Performs a GOTO in the current file
      Locateit         Performs a LOCATE FOR search
      Seekitem         Performs a SEEK into a database
*/

#define CLIPPER  // To make sure CLIPPER stuff get's looked at

#include "PTInkey.ch"
#include "PTValue.ch"
#include "PTFuncs.ch"
#include "PTColor.ch"
#include "PTVerbs.ch"

#include "DBPMenu.ch"
#include "DBSTRUCT.ch"
#include "ERROR.ch"

#define  pOBJ_ELE   1          // TBROWSE element slot
#define  pALIAS_ELE 2          // Alias name slot
#define  pFILE_ELE  3          // Full path and file name slot
#define  pOBJ_TYPE  4          // Type of file slot
#define  pWIN_ELE   5          // Array of window coordinates
#define  pSELECT_BOX   1       // Code to select a box
#define  pUNSELECT_BOX 2       // Code to de-hilite a box
#define  pDOS_SIZE     48      // Amount of K to shell to DOS

// Used to reference correct window given object
#xtranslate  pACTIVE_WIN(<nArea>) => if(<nArea> \< 5,<nArea>,;
                                        if(<nArea> % 4 == 0,4,<nArea> % 4))

memvar getlist                // Unfortunate, but true... it's here
static nKeyend    as int      // Counter for # of times end is pressed
static nKeyhome   as int      // Counter for # of times home is pressed
static nActive    as int      // Points to active Tbrowse object
static nMultiple  as int      // Which set of four areas we are on
static aMembers   as array    // Array of Tbrowse objects
static nObjkeys   as int      // Keystrokes that manipulate Tbrowse objects
static cMenucolor as char     // Color string for menus
static cNormal    as char     // Color string for normal color
static cInverse   as char     // Color string for inverse color

/* Function DBUPlus
   --------------------------------------
   Syntax:  DBUPlus([cParams])
   Returns: NIL
   Notes:   Main module for DBUPlus.  Handles capturing keystrokes, and
            houses certain functions called from a variety of modules.

            cParams may be /BLACK to force monochrome mode

*/
function DbuPlus(cParams)

   local nKey             as int      // Keystroke
   local cKey             as char     // Keystroke character chr'd
   local bPrg2do          as block    // Block containing function to perform
   local cMenupath := ""  as char     // Path to where menu file is located
   local lMorelines       as logical  // Whether we are in 43 line mode
   local bNormalmode      as block    // Block when eval'd sets to 25, clears
   local lIsmono          as logical  // Whether mono mode or not
   local cSearch          as char     // Logical path for files
   local cDrive           as char     // Logical drive for files
   local lDeltoggle       as logical  // Toggle setting for SET DELETED
   local lFullscreen      as logical  // Whether in full screen mode or not
   local aMenus           as array    // Ragged array structure for menus
   local bOlderror        as block    // Posted error block
   local oError           as object   // Error block
   local cOldcolor        as char     // Original color

   cOldcolor := setcolor()

   if pcount() == 0
     lIsmono := !iscolor()
   else
     lIsmono := if("/BLACK" $ upper(cParams),pTRUE,pFALSE)
   endif

   // Colors are held in a static array in ColorCentral().
   // Init that array first to color or mono
   ColorCentral(if(lIsmono,pMONO_MONITOR,pCOLOR_MONITOR))

   cMenucolor := ColorCentral("Menu")
   cNormal    := ColorCentral("Normal")
   cInverse   := ColorCentral("Inverse")

   lMorelines  := pFALSE
   lDeltoggle  := pFALSE
   lFullscreen := pFALSE
   cDrive      := LoggedDrive()
   nObjkeys    :=  {pRIGHT_ARROW, pLEFT_ARROW, pUP_ARROW,;
                    pDOWN_ARROW,  pHOME,       pEND,;
                    pPGDN,        pPGUP}


   set( pSCOREBOARD, pOFF )
   set( pDELETED, lDeltoggle )    // Set deleted toggled off
   setkey( pF1, NIL )             // This is to allow the F1 to be used
                                  // in the keystrokes

   // ALTD(0)                 // shut off the ALT_D key
   set(pCANCEL, pOFF )        // shut off the ALT-C key
   // Set insert key to toggle insert mode and cursor shape
   setkey( pINS, {|| Instoggle()} )

   bNormalmode := {|| setcolor(cOldcolor),setmode(25,00), scroll(), ;
                                                          setpos(0,0)}

   AddMembers()
   cSearch   := DirFormat()

   // Update the environment area of aMembers
   DictPut(atail(aMembers),"Search",cSearch)
   DictPut(atail(aMembers),"Drive",cDrive)
   DictPut(atail(aMembers),"Path",cDrive+cSearch)
   DictPut(atail(aMembers),"Deleted",lDeltoggle)
   DictPut(atail(aMembers),"NormalMode",bNormalmode)
   DictPut(atail(aMembers),"MoreLines",lMorelines)
   DictPut(atail(aMembers),"FullScreen",lFullscreen)
   DictPut(atail(aMembers),"IsMono",lIsmono)

   nKeyend := nKeyhome := 0

   set( pSOFTSEEK, pTRUE )
   set( pWRAP, pTRUE )
   set( pPATH, cDrive + cSearch )

   if !file("DBUPLUS.mnu")    // Check for the menu file.
     // not here, so check for an environmental variable
     if ( cMenupath := getenv("DBUMENU") ) == ""
       // No environmental variable showing us the path
       Errorbeep()
       PressKeyMsg({{" The file 'DBUPLUS.mnu' is not in the ",;
                     " current directory, and I find no ",;
                     " DBUMENU environmental variable with ",;
                     " which to use to find the file.  Please ",;
                     " either copy the .mnu file into the ",;
                     " current directory, or set a DBUMENU ",;
                     " environmental variable to the path where ",;
                     " the file is located. "}})
       eval( bNormalmode )
       quit
     else
       // They entered an environmental variable - check it to see
       // if it shows dbuplus.mnu
       cMenupath := if(right(cMenupath,1) == "\",cMenupath,cMenupath+"\")
       if !file(cMenupath+"dbuplus.mnu")
         // No file in the path specified in environmental var
         Errorbeep()
         PressKeyMsg({{" There is no menu file in the current ",;
                       " directory.  I see that you have set up a",;
                       " DBUMENU variable, but the path I find is ",;
                       " ",;
                       cMenupath,;
                       " ",;
                       " There is no DBUPLUS.mnu file in that path."}})

         eval( bNormalmode )
         quit
       endif
     endif
   endif

   // Compile menu script file, using color specified, with the
   // menu bar starting on row 1
   @ maxrow(),0 say " Activating Menu "
   aMenus     := MenuMake(cMenupath+"DBUPLUS.mnu",cMenucolor,"1")
   @ maxrow(),0 clear

   DrawScreen()

   DispMessage(, maxrow(),0)
   ErrorMessage(,maxrow(),0)

   // Put in error block
   bOlderror := errorblock({|oError|break(oError)})

   // Process loop for master error recovery
   PROCESS
     begin sequence
     PROCESS // Main control loop

       setcursor(pCURSOR_OFF)
       devpos(maxrow()-1, 0 )
       devout( "Type Key, ESC exits, F1 for help, `/' invokes menu, `//' displays prior choice " )

       // Get keystroke, assign chr'd value to cKey
       cKey := upper(chr(nKey := inkey(0)))

       if nKey == pSLASH
         // Invokes menu.  Set home/end key counters to 0, open menus.

         nKeyhome := nKeyend := 0
         devpos(maxrow()-1, 0 )
         devout( "Arrow keys, RET accepts, ESC for prior menu                          " )
         bPrg2do := menu(aMenus,if(!lIsmono,"C","B"))
         @ maxrow()-1,0 clear
         if bPrg2do <> NIL
           eval(bPrg2do)
         endif


       else

         // nKeyhome/nKeyend are 'counters' for that key, a la WordPerfect.
         // Allows 'home-home' recognition.
         do case
         case nKey = pHOME
           nKeyhome++
           nKeyend := 0
         case nKey = pEND
           nKeyend++
           nKeyhome := 0
         otherwise
           nKeyhome := nKeyend := 0
         endcase

         // Check to see if hot key pressed
         MoreKeys( cKey, nKey )

       endif

       IF aMembers[nActive,pOBJ_ELE] IS pOBJECT
         // Check for movement key pressed AND stablize object
         KeyStroke( aMembers[nActive,pOBJ_ELE], nKey )
       endif

     END PROCESS

     recover using oError

       IF oError IS pOBJECT
         scroll( maxrow()-1,0, maxrow(),0 )
         // Test so that other BREAK statements won't invoke message
         Errorbeep()
         if oError:severity < ES_CATASTROPHIC
           WaitMsg(pTRUE)
           ShowGenError(oError)
           WaitMsg(pFALSE)
           loop
         else
           PressKeyMsg({;
               {" Error while running DBUPlus.  Program cancelled"}})
         endif
       endif
     end sequence
     exit

   END PROCESS

   VOID

/* Function Keystroke
   --------------------------------------
   Syntax:  Keystroke(<oObject>,<nKey>)
   Returns: .t. if an object movement key was processed, .f. if not
   Notes:   Used to manipulate objects

            oObject   Object under consideration
            nKey      Keystroke pressed

*/

function Keystroke( oObject, nKey )

  local lProcessedKey := pTRUE  as logical
  local lMovepointer := pFALSE  as logical

  // Begin stabilization, but allow keystroke to exit
  MakeStable( oObject )

  do case
  case nKey == pRIGHT_ARROW
    if oObject:colpos == oObject:colcount .and. ISWRAP()
      oObject:panhome()
    else
      oObject:right()
    endif

  case nKey == pLEFT_ARROW
    if oObject:colpos == 1 .and. ISWRAP()
      oObject:panend()
    else
      oObject:left()
    endif

  case nKey == pUP_ARROW
    oObject:up()
    lMovepointer := pTRUE

  case nKey == pDOWN_ARROW
    oObject:down()
    lMovepointer := pTRUE

  case nKey == pPGDN
    oObject:pageDown()
    lMovepointer := pTRUE

  case nKey == pPGUP
    oObject:pageUp()
    lMovepointer := pTRUE

  case nKey == pHOME  // here is where the nKeyhome counter kicks in
    do case
    case nKeyhome == 1
      oObject:home()
    case nKeyhome == 2
      oObject:panhome()
    case nKeyhome == 3
      oObject:panhome()
      oObject:gotop()
      oObject:refreshall()
      nKeyhome := 0
    endcase

  case nKey == pEND
    do case
    case nKeyend == 1
      oObject:end()
    case nKeyend == 2
      oObject:panend()
    case nKeyend == 3
      oObject:panend()
      oObject:gobottom()
      oObject:refreshall()
      nKeyend := 0
    endcase

  otherwise     // didn't have a movement keystroke
    lProcessedKey := pFALSE

  endcase

  if lProcessedkey
    MakeStable( oObject )
    if oObject:stable .and. lMovepointer
      // If the keys caused record pointer movement, make sure we
      // don't have to wrap, then check relations via SetSeed()

      do case
      case oObject:hittop .and. ISWRAP()
        oObject:gobottom()
        MakeStable( oObject, pTRUE)
      case oObject:hitbottom .and. ISWRAP()
        oObject:gotop()
        MakeStable( oObject, pTRUE)
      endcase

      SetSeed( nActive )

    endif

  endif

  return( lProcessedkey )

/* Function SetSeed
   --------------------------------------
   Syntax:  SetSeed( nThearea )
   Returns: NIL
   Notes:   Used to make sure all pointers in
            related areas set correctly

            nThearea  Work area to set

*/
function SetSeed( nThearea )

  local nCurrarea := select() as int
  local nCount    := 1        as int
  local xKey1                 as usual
  local bKey2                 as block
  local cRelateKey            as char

  select (nThearea)

  while !empty( dbrelation(nCount) )

    // loop 'til no more relations for this work area
    if upper(dbrelation(nCount)) == "RECNO()"
      xKey1 := recno()
      bKey2 := {||recno()}
    else
      // Note that the original code in the manual demonstrates
      // a technique that is perfectly ok when dealing with normalized
      // relations - that is, when the relation set in the parent
      // exactly matches that in the child.  However, Clipper allows
      // composite keys, and will accept a relation expression for the
      // parent that is only part of the child's key.  This causes
      // problems in the stabilization loop below, b/c the two expressions
      // are compared to determine if TBrowse has left the cursor off
      // the correct record by comparing the key expression of the child
      // with the relation expression of the parent.
      //
      // If the relation expression of the parent is a subset of the
      // child's key, then the loop that performs the up() message can
      // loop forever.  Thus, we change the code in the book to have
      // it examine the child's key NOT using the child's key expression,
      // but the relation expression from the parent.
      //
      // Next line is new...
      cRelateKey := dbrelation(nCount)
      xKey1 := &( cRelatekey )     // key in parent for child
      // implements late evaluation of macro in code block, i.e., each rec
      // Comment out old technique so that this program will work on
      // relations that are non-normalized, i.e., the parental expression
      // is a subset of the child's key.
      //
      // bKey2 := {|| &(indexkey(0)) }    // will evaluate key of child
      //
      // This new block takes into account that child's key can be a
      // superset of parent, and so child key is checked by using the
      // expression key of parent, not child.
      bKey2 := {|| &(cRelateKey)    }    // will evaluate key of child

    endif

    select( dbrselect(nCount) )

    // Parent has value found in child
    (aMembers[ select(),pOBJ_ELE] ):refreshall()
    MakeStable( aMembers[ select(),pOBJ_ELE] )

    if !eof()

      do case
      case xKey1 < eval( bKey2 )
        // parent recno is lower than child
        while xKey1 < eval( bKey2 )
          // Keep moving record pointer up, until keys match
          (aMembers[select(),pOBJ_ELE]):up()
          MakeStable(aMembers[select(),pOBJ_ELE])
        enddo
      case xKey1 > eval( bKey2 )
        // parent recno is higher than child
        while xKey1 > eval( bKey2 )
          (aMembers[select(),pOBJ_ELE]):down()
          MakeStable(aMembers[select(),pOBJ_ELE])
        enddo
      endcase

    endif

    if !empty( dbrelation() )
      // This means that the child we are on has relations.
      // Recursive call to handle the child's relations
      SetSeed( select() )
    endif

    select (nCurrarea)

    nCount++

  enddo

  VOID

/* Function MoreKeys
   --------------------------------------
   Syntax:  MoreKeys(<cKey>,<nKey>)
   Returns: NIL
   Notes:   Processes keystrokes NOT related to object movement
            cKey     CHR'd value of keystroke
            nKey     Keystroke entered
            oObject  Object to work on
*/
function MoreKeys( cKey, nKey )

   do case
   case cKey == "L"
     ScreenModes()
   case cKey == "M"
     MakeDatabase()
   case cKey == "O"
     OpenDatabase()
   case nKey == pTAB
     ChangeArea(1)
   case nKey == pSHIFT_TAB
     ChangeArea(-1)
   case nKey == pDEL
     DelRecord()
   case nKey == pALT_L
     LockField()
   case nKey == pENTER
     ModField()
   case nKey == pCTRL_RIGHT_ARROW
     MoveFour("NEXT")
   case nKey == pCTRL_LEFT_ARROW
     MoveFour("PRIOR")
   case  nKey == pF1
     Help()
   case nKey == pESC
     Enditall()
   case  nKey == pALT_A
     AppendFrom()
   case  nKey == pALT_E
     SetSoft()
   case nKey == pALT_F
     FullScreen()
   case  nKey == pALT_W
     SetWrap()
   case  nKey == pALT_T
     Twiddle()
   case  nKey == pALT_D
     DelCols()
   case  nKey == pALT_G
     ToggleDelete()
   case  nKey == pALT_C
     ChangeDrive()
   case  nKey == pALT_K
     PackFiles()
   case  nKey == pALT_S
     SetValues()
   case  nKey == pALT_V
     OpenVariables()
   case  nKey == pALT_O
     OpenFlatFile()
   case  nKey == pALT_P
     SearchPath()
   case  nKey == pALT_Y
     CopyFiles()
   case  nKey == pALT_B
     ShowDirectory()
   case  nKey == pALT_Q
     ModStru()
   case  nKey == pALT_Z
     DosShell()
   case cKey == "U"
     Closethem()
   case cKey == "G"
     GotoRecord()
   case cKey == "F"
     SetaFilter()
   case cKey == "J"
     JoinAreas()
   case cKey == "C"
     CreateIndex()
   case cKey == "X"
     NewOrder()
   case cKey == "W"
     WipeIndexes()
   case cKey == "A"
     AddRecord()
   case cKey == "E"
     EditRecord()
   case cKey == "R"
     RelateThem()
   case cKey == "D"
     ShowStru()
   case cKey == "S"
     SeekItem()
   case cKey == "K"
     ShowKeys()
   case cKey == "I"
     OpenIndex()
   case cKey == "V"
     LocateIt()
   case cKey == "Y"
     ReplField()
   case cKey == "Z"
     ZapFiles()
   endcase
   VOID

/* Function Fullscreen
   --------------------------------------
   Syntax:  Fullscreen()
   Returns: NIL
   Notes:   Moves to full screen mode.
*/
function Fullscreen()

   local cScreen                               as char
   local nTop                                  as int
   local nLeft                                 as int
   local nBottom                               as int
   local nRight                                as int
   local nKey                                  as int
   local aEnviron := ActiveArea()              as array
   local aMembers := aEnviron[1]               as array
   local nActive := aEnviron[2]                as int
   local oObject := aMembers[nActive,pOBJ_ELE] as object
   local bOlderror                             as block
   local oError                                as object

   if DictAt(atail(aMembers),"FullScreen")
     // already here, can get here again via more keys
     return(NIL)
   endif

   cScreen := savescreen()

   if empty( aMembers[nActive,pALIAS_ELE] )
     ErrorMessage( "Nothing open to browse!" )
   else
     bOlderror := errorblock({|oError| break(oError)})
     begin sequence
     // Indicate global stat that we are in full screen mode
     DictPut(atail(aMembers),"FullScreen",pTRUE)
     oObject := (aMembers[nActive,pOBJ_ELE])
     nTop    := oObject:ntop                // these are the old coordinates
     nLeft   := oObject:nleft               // that are saved to be restored
     nBottom := oObject:nbottom             // after this operation
     nRight  := oObject:nright

     scroll()
     dispbox(1,0,maxrow()-2,maxcol(), pDBAR)
     devpos(1,1)
     devout("Alias: "+aMembers[nActive,pALIAS_ELE])
     devpos(maxrow()-1, 0 )
     devout( "Type Key, ESC returns to split screen mode, F1 - help                    " )
     oObject:ntop     := 2
     oObject:nleft    := 1
     oObject:nbottom  := maxrow()-3
     oObject:nright   := maxcol()-1
     oObject:configure()

     REPEAT

       if MakeStable( oObject )

         do case
         case oObject:hittop .and. ISWRAP()
            oObject:gobottom()
            loop
         case oObject:hitbottom .and. ISWRAP()
            oObject:gotop()
            loop
         otherwise
            nKey := inkey(0)
         endcase

         do case
         case nKey == pHOME
           nKeyhome++
           nKeyend := 0
         case nKey == pEND
           nKeyend++
           nKeyhome := 0
         otherwise
           nKeyhome := nKeyend := 0
         endcase

         if nKey != pESC

           // In this scenario, we know that there is an object active,
           // so we can test for a movement keystroke.
           if !KeyStroke( oObject, nKey )
             // key pressed is not a member!
              MoreKeys( upper( chr(nKey) ), nKey)
              // in case they changed it
              oObject := (aMembers[nActive,pOBJ_ELE])
           endif
           CLEARESC()

         endif

       endif

     UNTIL (lastkey() == pESC)

     oObject:ntop     := nTop
     oObject:nleft    := nLeft
     oObject:nbottom  := nBottom
     oObject:nright   := nRight
     oObject:configure()
     DictPut(atail(aMembers),"FullScreen",pFALSE)
     recover using oError
       IF oError IS pOBJECT
         ErrorMessage( "Error during full screen!" )
         oObject:ntop     := nTop
         oObject:nleft    := nLeft
         oObject:nbottom  := nBottom
         oObject:nright   := nRight
         oObject:configure()
         DictPut(atail(aMembers),"FullScreen",pTRUE)
       endif
     end sequence
   endif

   CLEARESC()
   restscreen(,,,,cScreen )
   errorblock(bOlderror)

   VOID

/* Function DosShell
   --------------------------------------
   Syntax:  DosShell()
   Returns: NIL
   Notes:   Allows user to shell to dos
*/
function DosShell()

  local cScreen := savescreen()  as char
  local nRow    := row()         as int
  local nCol := col()            as int
  local nCursor := setcursor()   as int

  if memory(2) > pDOS_SIZE
    cls
    setcursor( pCURSOR_ON )
    outstd( chr(13) + "Type EXIT to Return to DBUPLUS!" )

    run Command

    restscreen(,,,,cScreen )
    setcursor( nCursor )
    setpos( nRow, nCol )
  else
    Errorbeep()
    PressKeyMsg({{" Not enough memory to shell to DOS! "}})
  endif

  VOID

/* Function DrawScreen
   --------------------------------------
   Syntax:  Drawscreen()
   Returns: NIL
   Notes:   Draws the split DBUPlus screen
*/
function DrawScreen()

   local aBoxes := {"33", "33",;
                    "Ŀ33", "33",}    as array

   local nCount                      as int
   local aEnviron := ActiveArea()    as array
   local aMembers := aEnviron[1]     as array
   local nActive := aEnviron[2]      as int
   local aWin                        as array
   local cDrive                      as char
   local cSearch                     as char
   local nEnd                        as int
   local nArea                       as int

   cDrive :=  DictAt(atail(aMembers),"Drive")
   cSearch := DictAt(atail(aMembers),"Search")
   setcolor( cNormal )

   cls

   nArea := select()

   nEnd := (((nMultiple * 4) - 4) + 1) + 3
   for nCount := (((nMultiple * 4) - 4) + 1) to nEnd
     aWin := aMembers[nCount,pWIN_ELE]
     @ aWin[1]-1,aWin[2]-1,aWin[3]+1,aWin[4]+1 ;
       BOX aBoxes[nCount - ((nMultiple * 4) - 4)]

     // Now display the area #
     @ aWin[1]-1,aWin[2]+1 SAY " " SAY str(nCount,3,0) SAY " "

     // If occupied by a file, print alias and stabilize it
     if empty(aMembers[nCount,pALIAS_ELE])

       @ aWin[1]-1,aWin[2]+6 say " Alias: Unknown"

     else

       @ aWin[1]-1,aWin[2]+6 say " Alias: " ;
                             SAY padr(aMembers[nCount,pALIAS_ELE],11)
       // Stabilize the object
       select( nCount )
       (aMembers[nCount,pOBJ_ELE]):refreshall()
       MakeStable(aMembers[nCount,pOBJ_ELE])

     endif

   next
   select( nArea )
   BoxArea(pACTIVE_WIN(nActive),pSELECT_BOX)
   devpos(0,0)
   devout( "DbuPlus(tm) 3.1   " )
   ShowPath(cDrive,cSearch)

   VOID

/* Function Help
   --------------------------------------
   Syntax:  Help()
   Returns: NIL
   Notes:   Displays help screen
*/
function Help()

   local cScreen := savescreen() as char
   local nRow    := 1            as int

   dispbox( 0, 0, maxrow(), maxcol(), pDBAR )
   @ 0,1 say " Help " say "Screen"
   @ nRow++, 2 say "A   - Add a record                        " ;
               SAY "ALT-A  - Append from a file    "
   @ nRow++, 2 say "C   - Create an Index                     " ;
               SAY "ALT-B  - Show Current Directory"
   @ nRow++, 2 say "D   - Display database structure          " ;
               SAY "ALT-C  - Change Logged Drive   "
   @ nRow++, 2 say "E   - Edit the existing record            " ;
               SAY "ALT-D  - Delete a column       "
   @ nRow++, 2 say "F   - Set a filter condition              " ;
               SAY "ALT-E  - Toggle exact match    "
   @ nRow++, 2 say "G   - Go to a record number               " ;
               SAY "ALT-F  - Full Screen Browse    "
   @ nRow++, 2 say "I   - Use an index                        " ;
               SAY "ALT-G  - Set Deleted toggle    "
   @ nRow++, 2 say "J   - Connect to areas by record #        " ;
               SAY "ALT-K  - Pack current file     "
   @ nRow++, 2 say "K   - Show Active Index Keys              " ;
               SAY "ALT-L  - Change Locked Fields  "
   @ nRow++, 2 say "L   - Switch line modes!                  " ;
               SAY "ALT-O  - Open Flat File        "
   @ nRow++, 2 say "M   - Make a DATABASE structure           " ;
               SAY "ALT-P  - Set Search Path       "
   @ nRow++, 2 say "O   - Open Database                       " ;
               SAY "ALT-Q  - Modify DBF Structure  "
   @ nRow++, 2 say "R   - Set a relation                      " ;
               SAY "ALT-S  - Show Set values       "
   @ nRow++, 2 say "S   - Seek an item                        " ;
               SAY "ALT-T  - Twiddle a column      "
   @ nRow++, 2 say "U   - Close a File (any type)             " ;
               SAY "ALT-V  - Open Variable File    "
   @ nRow++, 2 say "V   - Locate a Value                      " ;
               SAY "ALT-W  - Toggle wrap around    "
   @ nRow++, 2 say "W   - Close existing indexes              " ;
               SAY "ALT-Y  - Copy a File In Use    "
   @ nRow++, 2 say "X   - Change controlling index order      " ;
               SAY "ATL-Z  - DOS Shell             "
   @ nRow++, 2 say "Y   - Replace field across records        " ;
               SAY "DEL    - Delete the record     "
   @ nRow++, 2 say "Z   - Zap current database                " ;
               SAY "ENTER  - Edit field value      "            
   @ nRow++, 2 say "TAB - Select next quandrant            "    ;
               SAY "SHIFT-TAB - Select prior quadrant "
   @ nRow++, 2 say "^" say chr(26) ;
               say "  - Move to next group                  ^";
               say chr(27) say "     - Move to prior group   "
   @ nRow++, 2 say "All Cursor keys move highlighted bar in window"

   inkey(0)

   restscreen(,,,,cScreen )

   VOID

/* Function Enditall
   --------------------------------------
   Syntax:  Enditall()
   Returns: NIL
   Notes:   Shuts down the system

*/
function Enditall()

  local nCount                                              as int
  local aEnviron    := ActiveArea()                         as array
  local aMembers    := aEnviron[1]                          as array
  local bNormalmode := DictAt(atail(aMembers),"NormalMode") as block

  if YNMsg({ {"Are you sure you want to quit? "}})
    for nCount := 1 to (len(aMembers)-1)
      ActiveArea(nCount)  // Update active area pointer
      if !empty(aMembers[nCount,pFILE_ELE])
        select(nCount)
        CloseThem(pFALSE)
      endif
    next
    eval( bNormalmode )
    quit
  endif

  VOID

/* Function ActiveArea
   --------------------------------------
   Syntax:  ActiveArea([xSetvalue])
   Returns: NIL
   Notes:   If an argument is passed, it will be an array of numeric.
            If a numeric, then the active area is set.
            If an array, the aMembers array is set
*/

function ActiveArea(xSetvalue)

  local xRetval := NIL as usual

  if pcount() == 0
    xRetval := {aMembers,nActive}
  else
    IF xSetvalue IS pARRAY
      aMembers := xSetvalue
    else
      nActive := xSetvalue
    endif
  endif

  return( xRetval )

/* Function ChangeArea
   --------------------------------------
   Syntax:  Changearea(<nDir>)
   Returns: NIL
   Notes:   Moves window area highlight forward or back, depending on
            whether nDir is positive or negative

*/

function ChangeArea(nDir)

  local aWin    as array
  local nStart  as int

  if !(DictAt(atail(aMembers),"FullScreen"))
    // Un-hilite the area - nActive is the active area
    BoxArea(pACTIVE_WIN(nActive),pUNSELECT_BOX)
    aWin := aMembers[nActive,pWIN_ELE]
    @ aWin[1]-1,aWin[2]+6 say " Alias: "+;
      if( empty(aMembers[nActive,pALIAS_ELE]),"Unknown ",;
           padr(aMembers[nActive,pALIAS_ELE],11) )
    // Update nActive and hilite the new area
    nStart := GetStart()
    if nDir == 1
      // Moving forward
      if (nStart + 3) == nActive
        // We are on the lower right quadrant
        nActive := nStart
      else
        nActive++
      endif
    else
      // Moving backward
      if nStart == nActive
        // on the upper quadrant
        nActive += 3
      else
        nActive--
      endif
    endif
    select( nActive )
    ActiveArea(nActive)
    BoxArea(pACTIVE_WIN(nActive),pSELECT_BOX)
  endif

  VOID

/* Function Boxarea
   --------------------------------------
   Syntax:  Boxarea(<nArea>,<nColortype>)
   Returns: NIL
   Notes:   Highlites a work area box

            nArea       The area we want to box
            nColortype  Whether regular (1) or inverse (2)

*/
function BoxArea(nArea,nColortype)

  local aWin    := aMembers[nArea,pWIN_ELE]                   as array
  local lIsmono := DictAt(atail(aMembers),"IsMono")           as logical
  local cInv    := if( !lIsmono,chr(113),chr(112) )           as char
  local cNormal := if( !lIsmono, chr(31), chr(07))            as char
  local cColor  := if(nColortype == pSELECT_BOX,cInv,cNormal) as char


  Newcolor(aWin[1]-1,aWin[2]-1,aWin[1]-1,aWin[4]+1,cColor)  // top
  Newcolor(aWin[1]-1,aWin[2]-1,aWin[3]+1,aWin[2]-1,cColor)  // left side
  Newcolor(aWin[1]-1,aWin[4]+1,aWin[3]+1,aWin[4]+1,cColor)  // right side
  Newcolor(aWin[3]+1,aWin[2]-1,aWin[3]+1,aWin[4]+1,cColor)  // bottom

  VOID

/* Function AddMembers
   --------------------------------------
   Syntax:  AddMembers()
   Returns: NIL
   Notes:   Handles adding four members to the aMembers array

*/
function AddMembers()

  local nPos as int

  // Members is an array, whose elements are a 4 element array for
  // each object defined.  The 4 element array per each object is:
  // 1: Object
  // 2: Filename
  // 3: Alias
  // 4: File type - DBFFILE, MEMFILE, TXTFILE
  // 5: Window boundries as an array
  //
  if aMembers == NIL
    aMembers := {array(5),array(5),array(5),array(5)}
    aMembers[1,5] := {0,0,0,0}
    aMembers[2,5] := {0,0,0,0}
    aMembers[3,5] := {0,0,0,0}
    aMembers[4,5] := {0,0,0,0}
    // The last element holds environmental information
    // for all TBrowses, such as search path, SET status, etc.
    aadd(aMembers,DictNew())
    nMultiple := 1
    nActive   := 1
  else
    nPos := len(aMembers)
    asize(aMembers, nPos+4)
    // Move the dictionary to the last element
    aMembers[nPos+4] := aMembers[nPos]
    // Init the new members
    aMembers[nPos+0] := array(5)
    aMembers[nPos+1] := array(5)
    aMembers[nPos+2] := array(5)
    aMembers[nPos+3] := array(5)

    // Init the coordinates for the objects
    aMembers[nPos+0,5] := {0,0,0,0}
    aMembers[nPos+1,5] := {0,0,0,0}
    aMembers[nPos+2,5] := {0,0,0,0}
    aMembers[nPos+3,5] := {0,0,0,0}

    // Update multiple
    nMultiple++
    nActive := (nMultiple * 4) - 3
  endif

  // Calculate coordinates for the browse
  WinCalc()

  VOID

/* Function WinCalc
   --------------------------------------
   Syntax:  WinCalc()
   Returns: NIL
   Notes:   Handles updated window coordinates for defined objects
*/
function WinCalc

  local nCount as int
  local nLen   as int
  local nPtr   as int

  WaitMsg( pTRUE )
  nLen := int( (len(aMembers) - 1) / 4)
  for nCount := 1 to nLen

    nPtr := (nCount*4)-3
    // set the Window coordinate values
    aMembers[nPtr,pWIN_ELE,1] := 3
    aMembers[nPtr,pWIN_ELE,2] := 1
    aMembers[nPtr,pWIN_ELE,3] := int((maxrow()) / 2 ) - 1
    aMembers[nPtr,pWIN_ELE,4] := int( maxcol() / 2 ) -1
    // Reinitialize the browse coordinates
    if valtype( aMembers[nPtr,pOBJ_ELE] ) == pOBJECT
       (aMembers[nPtr,pOBJ_ELE]):ntop    := aMembers[nPtr,pWIN_ELE,1]
       (aMembers[nPtr,pOBJ_ELE]):nleft   := aMembers[nPtr,pWIN_ELE,2]
       (aMembers[nPtr,pOBJ_ELE]):nbottom := aMembers[nPtr,pWIN_ELE,3]
       (aMembers[nPtr,pOBJ_ELE]):nright  := aMembers[nPtr,pWIN_ELE,4]
       (aMembers[nPtr,pOBJ_ELE]):refreshall()
    endif

    nPtr := (nCount*4)-2
    aMembers[nPtr,pWIN_ELE,1] := int((maxrow()) / 2 ) + 1
    aMembers[nPtr,pWIN_ELE,2] := 1
    aMembers[nPtr,pWIN_ELE,3] := maxrow()-3
    aMembers[nPtr,pWIN_ELE,4] := int( maxcol() / 2 ) -1
    // Reinitialize the browse coordinates
    if valtype( aMembers[nPtr,pOBJ_ELE] ) == pOBJECT
       (aMembers[nPtr,pOBJ_ELE]):ntop    := aMembers[nPtr,pWIN_ELE,1]
       (aMembers[nPtr,pOBJ_ELE]):nleft   := aMembers[nPtr,pWIN_ELE,2]
       (aMembers[nPtr,pOBJ_ELE]):nbottom := aMembers[nPtr,pWIN_ELE,3]
       (aMembers[nPtr,pOBJ_ELE]):nright  := aMembers[nPtr,pWIN_ELE,4]
       (aMembers[nPtr,pOBJ_ELE]):refreshall()
    endif

    nPtr := (nCount*4)-1
    aMembers[nPtr,pWIN_ELE,1] := 3
    aMembers[nPtr,pWIN_ELE,2] := int( maxcol() / 2 ) + 1
    aMembers[nPtr,pWIN_ELE,3] := int((maxrow()) / 2 ) - 1
    aMembers[nPtr,pWIN_ELE,4] := maxcol() - 1
    // Reinitialize the browse coordinates
    if valtype( aMembers[nPtr,pOBJ_ELE] ) == pOBJECT
       (aMembers[nPtr,pOBJ_ELE]):ntop    := aMembers[nPtr,pWIN_ELE,1]
       (aMembers[nPtr,pOBJ_ELE]):nleft   := aMembers[nPtr,pWIN_ELE,2]
       (aMembers[nPtr,pOBJ_ELE]):nbottom := aMembers[nPtr,pWIN_ELE,3]
       (aMembers[nPtr,pOBJ_ELE]):nright  := aMembers[nPtr,pWIN_ELE,4]
       (aMembers[nPtr,pOBJ_ELE]):refreshall()
    endif

    nPtr := (nCount*4)
    aMembers[nPtr,pWIN_ELE,1] := int((maxrow()) / 2 ) + 1
    aMembers[nPtr,pWIN_ELE,2] := int( maxcol() / 2 ) + 1
    aMembers[nPtr,pWIN_ELE,3] := maxrow()-3
    aMembers[nPtr,pWIN_ELE,4] := maxcol() - 1
    // Reinitialize the browse coordinates
    if valtype( aMembers[nPtr,pOBJ_ELE] ) == pOBJECT
       (aMembers[nPtr,pOBJ_ELE]):ntop    := aMembers[nPtr,pWIN_ELE,1]
       (aMembers[nPtr,pOBJ_ELE]):nleft   := aMembers[nPtr,pWIN_ELE,2]
       (aMembers[nPtr,pOBJ_ELE]):nbottom := aMembers[nPtr,pWIN_ELE,3]
       (aMembers[nPtr,pOBJ_ELE]):nright  := aMembers[nPtr,pWIN_ELE,4]
       (aMembers[nPtr,pOBJ_ELE]):refreshall()
    endif

  next

  WaitMsg( pFALSE )

  VOID

/* Function MakeStable
   --------------------------------------
   Syntax:  MakeStable(<oObject>[,lForce])
   Returns: TRUE if object stable, else FALSE
   Notes:   Handles stabilizing an object, checks for whether it should
            write to the screen.
*/
function MakeStable( oObject, lForce )

  local lIsStable := pFALSE as logical
  local lShowIt   := pTRUE  as logical
  local cScreen             as char

  if pcount() == 1
   lForce := pFALSE
  endif

  // Test to see whether we should show this stabilization.  We should
  // not display only if browse is "off screen."  That is, if the four
  // windows hold work areas 5-8, and we are stabilizing a browse object
  // in work area 2.  Notice how GetStart is called with the select()
  // function as an argument.  This causes GetStart to return the starting
  // element in the quadrant as if we were in the group of four areas
  // in which select() logically resides.  Using this result we can compre
  // to nMultiple to see if the file we are about to stabilize is in the
  // same group of four areas that we are currently in (nMultiple).
  lShowit := ( (int( GetStart( select() ) / 4 )+1) == nMultiple )

  if !lShowit
    WaitMsg(pTRUE)
    cScreen := savescreen(0,0,maxrow(),maxcol())
    dispbegin()
  endif

  do case
  case aMembers[nActive,pOBJ_TYPE] == "DBFFILE" .and. reccount() == 0
    // Will be eof() if an empty database
    scroll(oObject:nTop,;
           oObject:nLeft,;
           oObject:nBottom,;
           oObject:nRight,0)
    // Put a message up in the window
    @ oObject:nTop,;
      oObject:nLeft + 10 say " Empty  File " color cInverse

  case aMembers[nActive,pOBJ_TYPE] == "DBFFILE" .and. eof()

    scroll((aMembers[select(),pOBJ_ELE]):nTop,;
           (aMembers[select(),pOBJ_ELE]):nLeft,;
           (aMembers[select(),pOBJ_ELE]):nBottom,;
           (aMembers[select(),pOBJ_ELE]):nRight,0)
    // Put a message up in the window
    @ (aMembers[select(),pOBJ_ELE]):nTop,;
      (aMembers[select(),pOBJ_ELE]):nLeft + 10 say ;
      " End of File " color cInverse

  otherwise

    lIsStable := IsStable( oObject, lForce )

  endcase

  if !lShowit
    restscreen(0,0,maxrow(),maxcol(),cScreen)
    dispend()
    WaitMsg(pFALSE)
  endif

  return( lIsStable )

/* Function MoveFour
   --------------------------------------
   Syntax:  MoveFour(<cDirection>)
   Returns: NIL
   Notes:   Moves to the next/prior page of four work areas
*/
function MoveFour(cDirection)

  local nStart   as int

  begin sequence

  if (DictAt(atail(aMembers),"FullScreen"))
    // User is in full screen mode
    break
  endif

  nStart := GetStart()

  do case
  case cDirection == "NEXT"
    // We get this far, all screens are full.
    //
    // See if the next block has been defined yet
    if (nStart + 4) == len(aMembers)
      // If so, we are on the last set - need to add 4 more
      AddMembers()

    else
      // Another set is already defined, just add to the pointer
      nActive += 4
      nMultiple++
    endif

  case cDirection == "PRIOR"

    if nStart == 1
      nActive := len( aMembers ) - 4
      nMultiple := int((len( aMembers ) - 5) / 4) + 1
    else
      nActive -= 4
      nMultiple--
    endif

  endcase

  select( nActive )
  DrawScreen()

  end sequence

  VOID

/* Function GetStart
   --------------------------------------
   Syntax:  GetStart([nArea])
   Returns: Element in aMembers that is in the upper left screen window
   Notes:   This function is used to figure out which element in aMembers
            resides in the upper left window quadrant.  By default, this
            function assumes that the group of four work areas where
            nActive currently resides should be used.  However, passing
            a different value in [nArea] can alter the behavior of this
            function.  Passing another number for [nArea] results in
            GetStart returning the element in aMembers that would be
            in the upper left quandrant, if nActive were equal to nArea.

            [nArea]   If passed, then this function is used to determine
                      other elements for that quadrant other than the
                      one in the group in which nActive resides.


*/
function GetStart(nArea)

  local nStart   as int
  local nCurrent as int

  if pcount() == 0
    nCurrent := nActive
  else
    nCurrent := nArea
  endif
  // Get to the area in the upper left box
  if nCurrent > 4

    if nCurrent % 4 == 0
      nStart := nCurrent - 3
    else
      nStart := nCurrent - ((nCurrent % 4) - 1)
    endif

  else

    nStart := 1

  endif

  return( nStart )

*******************

init procedure Statup()

  local nFile as int

  // If the DBUPLUS.MNU file is not here, create it...
  if getenv("DBUMENU") == "" .and. !file( "dbuplus.mnu" )
    nFile := fcreate( "dbuplus.mnu" )
    fwrite( nFile, "~File^\")
    fwrite( nFile, pCRLF )
    fwrite( nFile, " [")
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Open^\")
    fwrite( nFile, pCRLF )
    fwrite( nFile, "   [")
    fwrite( nFile, pCRLF )
    fwrite( nFile, "     ~Database^{||OpenDatabase()}\")
    fwrite( nFile, pCRLF )
    fwrite( nFile, "     ~Index^{||OpenIndex()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "     ~Memory File^{||OpenVariables()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "     ~Text File^{||OpenFlatFile()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "   ]") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Close^\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "   [") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "     ~All Files in Active Window^{||CloseThem()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "     ~All Open Indexes in Active Window^{||WipeIndexes()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "   ]") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~C*reate^\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "   [") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "     ~Database^{||MakeDatabase()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "     ~Index^{||CreateIndex()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "   ]") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Modify^\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "   [") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "     ~Add Record^{||AddRecord()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "     ~Edit Record^{||EditRecord()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "     ~Delete Record^{||DelRecord()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "     ~Pack Database^{||PackFiles()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "     ~Zap Database^{||ZapFiles()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "     ~Modify *Structure^{||ModStru()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "     ~Modify Field^{||ModField()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "     ~Replace Field^{||ReplField()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "     ~Append *From^{||AppendFrom()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "   ]") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Co*py^{||CopyFiles()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Display Database Structure^{||ShowStru()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, " ]") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "~Search^\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, " [") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Go To Record No.^{||GoToRecord()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Seek a Value^{||SeekItem()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Locate a Value^{||LocateIt()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, " ]") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "~Environment^\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, " [") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Set a *filter^{||SetaFilter()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Set *relation by record number^{||JoinAreas()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Set relation by *key value^{||RelateThem()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Set de*leted toggle^{||ToggleDelete()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Set search *path^{||SearchPath()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Set *wrap around^{||SetWrap()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Set exact *match^{||SetSoft()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Set controlling *index^{||NewOrder()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Set line m*ode^{||ScreenModes()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Show SET *values^{||SetValues()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Show ac*tive indexes^{||ShowKeys()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Show *current directory^{||ShowDirectory()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Set logged *drive^{||ChangeDrive()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, " ]") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "~Object^\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, " [") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Select *Window^\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "   [") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "    ~Select window *1^{||ChangeArea(1)}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "    ~Select window *2^{||ChangeArea(2)}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "    ~Select window *3^{||ChangeArea(3)}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "    ~Select window *4^{||ChangeArea(4)}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "   ]") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Delete *column^{||DelCols()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Full screen *browse^{||FullScreen()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Change locked *fields^{||LockField()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "  ~Twiddle column^{||Twiddle()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, " ]") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "~Quit^\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, " [") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "   ~Return to Dos^{||Enditall()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "   ~Shell to Dos^{||DosShell()}\") 
    fwrite( nFile, pCRLF )
    fwrite( nFile, "]") 
    fwrite( nFile, pCRLF )

    fclose(nFile)

  endif

// End of File: DBPMain.prg

DBPFunc.prg

/* File              DBPFUNC.prg
   Notice            Copyright(c) 1991-1994 Sirius Software Development, Inc. 
                     All Rights Reserved
   Author            Steve Straley
*/

#define CLIPPER

#include "PTFuncs.ch"
#include "PTValue.ch"
#include "PTInkey.ch"
#include "PTVerbs.ch"
#include "PTColor.ch"

#include "FILEIO.ch"
#include "DBSTRUCT.ch"

#define  pTYPECHAR chr(195)
#define  pTYPELOG  chr(204)
#define  pTYPENUM  chr(206)
#define  pTYPEDATE chr(196)
#define  pOBJ_ELE   1          // TBROWSE element slot
#define  pALIAS_ELE 2          // Alias name slot
#define  pFILE_ELE  3          // Full path and file name slot
#define  pOBJ_TYPE  4          // Type of file slot
#define  pWIN_ELE   5          // Array of window coordinates
#define  pSELECT_BOX   1       // Code to select a box
#define  pUNSELECT_BOX 2       // Code to de-hilite a box

memvar getlist

/* Function Adjmem
   --------------------------------------
   Module:  DBPFUNC
   Syntax:  Adjmem(<cMemfile>,<cMemvar>,<xMemvalue>)
   Example: Adjmem("TEST.mem","NAME","Brown")
   Returns: pTRUE if variable successfully updated, .f. if not
   Notes:   This function writes the value in <xMemvalue> back to the .mem
            file <cMemfile> at the position held by <cMemvar>.  It handles
            correctly adjusting the size of the file to accomodate changes
            in character strings.

            To delete a memory variable, pass NIL for xMemvalue
*/
function Adjmem(cMemfile,cMemvar,xMemvalue)

  local nMemhandle        as int      // Handle for .mem file
  local nMemlength        as int      // Size of file
  local nCurrloc          as int      // Where we are in the .mem file
  local cReadBuff         as char     // Buffer for reading
  local cVarname          as char     // Current variable name
  local lVarfound         as logical  // Whether variable name found 
  local nNextloc          as int      // Next file pointer location
  local cEofbuff          as char     // Buffer holding from current locale
  local xNewnumb          as usual    // Number constructed from IEEE
  local cWriteval         as char     // Value to write to disk
  local xVartype          as usual    // Type of variable
  local nVarrange         as int      // How many characters in data area
  local lNumsign          as logical  // pTRUE if positive number, .f. 
  local nFloat            as int      // Used to derive mantissa of IEEE
  local nExp              as int      // ""
  local nConv             as int      // Variable used to convert IEEE
  local nIntconv          as int      // ""
  local nWritelen         as int      // Bytes to write to disk
  local lRetval := pTRUE  as logical  // Return value

  begin sequence

  if pcount()<3
    lRetval := pFALSE
    break
  endif
  if !file(cMemfile)
    lRetval := pFALSE
    break
  endif
  cMemfile := upper(cMemfile)
  cMemvar  := upper(cMemvar)
  nMemhandle := fopen(cMemfile,FO_READWRITE)
  nMemlength := fseek(nMemhandle,0,FS_END)
  fseek(nMemhandle,0,FS_SET)  // reset pointer to bof()

  PROCESS
    if nMemlength<2
      fclose(nMemhandle)
      lRetval := pFALSE
      break
    else
      // This loop goes through the .mem file
      // until the right variable
      // that was passed is found in the file
      while fseek(nMemhandle,0,FS_RELATIVE)+1 < nMemlength
        // Variable specific information is contained
        // in the first 18 bytes of the variable packet.
        // The value of the variable is contained
        // from positon 33 on.
        nCurrloc := fseek(nMemhandle,0,FS_RELATIVE)
        cReadBuff := space(18)
        // Get var specific info
        fread(nMemhandle,@cReadBuff,18)
        // The variable name is in the first 10 position
        // with a chr(0) terminator.
        cVarname := left(cReadBuff,at(chr(0),cReadBuff)-1)
        // The variable type is in position 12 of the packet.
        // C3h is character or memo, CCh is logical, CEh is numeric,
        // C4h is date.
        xVartype := substr(cReadBuff,12,1)
        // For character and logical variables,
        // position 17 and 18 contain the hex
        // value for the range of the data. For
        // numeric and date variables, the range
        // is 8. This points to the end of the
        // variable packet.
        nVarrange := bin2w(right(cReadBuff,2))
        //
        if !(xVartype $ ( pTYPECHAR + pTYPELOG + pTYPENUM + pTYPEDATE ))
          //  Variable type not one we know about
          fclose(nMemhandle)
          lRetval := pFALSE
          break
        endif
        // we gulped 18, we need to get to 33...
        fseek(nMemhandle,14,FS_RELATIVE)  // Prepare to get data
        if xVartype $ (pTYPECHAR + pTYPELOG)
          // character range is given here, logical will be 1
          fseek(nMemhandle,nVarrange,FS_RELATIVE)
        else
          // If a number, skip 8
          fseek(nMemhandle,8,FS_RELATIVE)
        endif
        if cVarname == trim(cMemvar)
          // We have found the var in the .mem file that was passed to the
          // function.
          lVarfound := pTRUE
          exit
        else
          lVarfound := pFALSE
        endif
      enddo
      exit
    endif
  END PROCESS
  if lVarfound
    // Set pointer to variable.
    fseek(nMemhandle,nCurrloc,FS_SET)
    if (valtype(xMemvalue) == "U")
      // If a NIL is passed, then delete the var!
      // Set pointer to next variable location,
      // pull in remaining of .mem file
      nNextloc := nCurrloc+if(xVartype$(pTYPECHAR+pTYPELOG),nVarrange,8)+32
      fseek(nMemhandle,nNextloc,FS_SET)
      cEofbuff := space(nMemlength-nNextloc)
      fread(nMemhandle,@cEofbuff,nMemlength-nNextloc)

      // Set pointer to point just after and write remaining.
      fseek(nMemhandle,nCurrloc,FS_SET)
      fwrite(nMemhandle,cEofbuff,nMemlength-nNextloc)
      fwrite(nMemhandle,"",0)
      fclose(nMemhandle)
      lRetval := pTRUE
      break
    else
      do case
      case (xVartype == pTYPENUM ) .or. (xVartype == pTYPEDATE)
        if xVartype == pTYPENUM
          if valtype(xMemvalue) <> "N"
            lRetval := pFALSE
            break
          endif
          xNewNumb := xMemvalue
        else
          if valtype(xMemvalue) <> "D"
            // date type was not passed
            fclose(nMemhandle)
            lRetval := pFALSE
            break
          endif
          // 1757585 is the date number for 01/01/0100
          // so the data passed as character is converted to date
          // number.
          xNewNumb:= xMemvalue+1757585-ctod('01/01/0100')
        endif
        if xNewNumb == 0
          // If vartype is a number AND 0, all 8 bytes are 0.
          cWriteval := replicate(chr(0),8)
        else
          // We must float the number - 1 <= number <2
          lNumsign:= (xNewNumb>=0)         // Save the sign of the number
          xNewNumb:= abs(xNewNumb)         // Can't take the LOG of negative.
          nFloat :=  log(xNewNumb)/log(2)  // Get log base 2.
          nExp :=    int(nFloat)           // Get characteristic.
          nFloat -= nExp                   // Get mantissa.
          if nFloat < 0                    // If 0 < number < 1, we must
            nExp--                         // have a positive mantissa.
            nFloat++                       // Add 1 to mantissa and
          endif                            // subtract 1 from characteristic.
          nFloat := 2^nFloat-1             // We need fraction only.
          nExp := nExp+1023                // Normalize power to avoid -.

          // Standard technique to convert from decimal to base 16.
          nConv := 16*nFloat
          nIntconv := int(nConv)
          nFloat := (nConv-nIntconv)
          cWriteval := chr(16*(nExp%16)+nIntconv)+;
                     chr(if(lNumsign,0,128)+int(nExp/16))
          nConv := (65536*nFloat)
          nIntconv := int(nConv)
          nFloat := (nConv-nIntconv)
          cWriteval := i2bin(nIntconv)+cWriteval
          cWriteval := l2bin(int(65536*65536*nFloat))+cWriteval
        endif
        nWritelen := 8
      case xVartype == pTYPELOG
        if valtype(xMemvalue) <> "L"
          fclose(nMemhandle)
          lRetval := pFALSE
          break
        endif
        cWriteval := if(xMemvalue,chr(1),chr(0))
        nWritelen := 1
      case xVartype=pTYPECHAR // Character
        // with character, we have to write up to the beginning of the
        // variable, then write the new value, then write out the rest
        // of the file.
        if valtype(xMemvalue) <> "C"
          lRetval := pFALSE
          break
        endif
        nNextloc := nCurrloc+nVarrange+32
        nVarrange := 1+len(xMemvalue)
        fseek(nMemhandle,nCurrloc+16,FS_SET) // Set pointer to write data.
        fwrite(nMemhandle,i2bin(nVarrange),2)
        fseek(nMemhandle,nNextloc,FS_SET)    // Set pointer to next variable.
        cEofbuff := space(nMemlength-nNextloc)
        fread(nMemhandle,@cEofbuff,nMemlength-nNextloc)
        fseek(nMemhandle,nCurrloc+32,FS_SET) // Set pointer to write data.
        cWriteval := xMemvalue+chr(0)+cEofbuff
        nWritelen := nVarrange+nMemlength-nNextloc
      endcase
      if xVartype == pTYPENUM
        fseek(nMemhandle,nCurrloc+16,FS_SET) // Set pointer to write data.
        fwrite(nMemhandle,(chr(20)+chr(10)),2)
      endif
    endif
    fseek(nMemhandle,nCurrloc+32,FS_SET) // Set pointer to write data.
    fwrite(nMemhandle,cWriteval,nWritelen)
    lRetval := pTRUE
  else
    lRetval := pFALSE
  endif
  if xVartype == pTYPECHAR
    fwrite(nMemhandle,"",0)
  endif
  fclose(nMemhandle)
  end sequence

  return(lRetval)

/* Function GetVarsFromFile
   --------------------------------------
   Module:  DBPFUNC
   Syntax:  GetVarsFromFile(<cMemFileName>)
   Example: GetVarsFromFile(cFilename)
   Returns: Reference to array of values
   Notes:   This function reads the contents of a .mem file
            and loads an array with them.
*/

function GetVarsFromFile( cMemFileName )

   // The numeric and date writing portion of this function was converted
   // from suggestions from Essor Maso

   local nFhandle        as int   // .mem file handle
   local nFilesize       as int   // Size of .mem file
   local aRetval := {}   as array // Array for return value
   local cBuffer         as char  // Buffer for var info
   local cVarName        as char  // Name of variable
   local xVartype        as usual // Data type in variable
   local nVarrange       as int   // Number of bytes to read to get data
   local xVarDataValue   as usual
   local nPadding1       as int
   local nPadding2       as int
   local nPowerOf        as int
   local lMinusSign      as logical
   local nMantissa0      as int
   local nMantissa1      as int
   local nMantissa2      as int
   local nMantissa3      as int
   local nMantissaTot    as int
   local nNumberTemp     as int
   local nDecimals       as int
   local aItems          as array

   nFhandle := fopen(cMemFileName)
   nFilesize  := fseek(nFhandle, 0, FS_END)
   fseek(nFhandle, 0, FS_SET)

   if nFilesize > 1 .AND. nFhandle > 4
      // Size of file can be 1 if a SAVE ALL LIKE xxx has been issued,
      // and nothing matched the skeleton.  File handles through 4 are
      // reserved.
      while fseek(nFhandle, 0, FS_RELATIVE) + 1 < nFilesize
        // loop until .mem file characters all processed
        cBuffer := space(18)
        fread(nFhandle, @cBuffer, 18)

        cVarName     := left(cBuffer, at(chr(0), cBuffer) - 1 )
        xVartype     := substr(cBuffer, 12, 1)
        nVarrange    := if(xVartype $ (pTYPECHAR+pTYPELOG),;
                            bin2w(right(cBuffer, 2)),8)

        // Data starts in the 33rd byte, we are on 18 now...
        fseek(nFhandle,14,FS_RELATIVE)

        // Logical or character data is the next nVarrange bytes.
        // If Date or Numeric, the length of value is 8
        // (IEE standard, all numbers fit in 8 bytes).
        xVarDataValue := space(nVarrange)

        // Get the string of the value
        fread(nFhandle, @xVarDataValue, nVarrange)

        aItems := {}
        aadd( aItems, padr(cVarName,12) )

        do case
        case xVartype == pTYPECHAR
          aadd( aItems, "C" )
          aadd( aItems, xVarDataValue )

        case xVartype == pTYPELOG
          aadd( aItems,  "L")
          aadd( aItems, if( (asc(xVarDataValue) = 1), pTRUE, pFALSE) )

        case xVartype == pTYPENUM
          nPadding1     := Modulus(ASC(substr(xVardataValue, 8, 1)), 128) ;
                           * 16
          nPadding2     := int(asc(substr(xVardataValue, 7, 1)) / 16)
          nPowerOf      := nPadding1 + nPadding2 - 1023
          lMinusSign    := int(asc(substr(xVardataValue, 8, 1)) / 16) >= 8
          nMantissa0    := Modulus(asc(substr(xVardataValue, 7, 1)), 16) / 16
          nMantissa1    := bin2w(substr(xVardataValue, 5, 2)) / (65536*16)
          nMantissa2    := bin2w(substr(xVardataValue, 3, 2)) / ;
                           (65536 * 65536 * 16)
          nMantissa3    := bin2w(substr(xVardataValue, 1, 2)) / ;
                           (65536 * 65536 * 65536 * 16)
          nMantissaTot  := nMantissa0 + nMantissa1 + nMantissa2 + nMantissa3
          nNumberTemp   := if(lMinusSign, -(1 + nMantissaTot) * ;
                             (2 ^ nPowerOf),;
                             (1 + nMantissaTot) * (2 ^ nPowerOf))
          nDecimals    := asc(right(cBuffer, 1))

          aadd( aItems, "N" )
          aadd( aItems, round(nNumberTemp,nDecimals) )

        case xVartype == pTYPEDATE
          nPadding1    := Modulus(ASC(substr(xVardataValue, 8, 1)), 128) * 16
          nPadding2    := INT(ASC(substr(xVardataValue, 7, 1)) / 16)
          nPowerOf     := nPadding1 + nPadding2 - 1023
          lMinusSign   := INT(ASC(substr(xVardataValue, 8, 1)) / 16) >= 8
          nMantissa0   := Modulus(ASC(substr(xVardataValue, 7, 1)), 16) / 16
          nMantissa1   := bin2w(substr(xVardataValue, 5, 2)) / (65536*16)
          nMantissa2   := bin2w(substr(xVardataValue, 3, 2)) / ;
                          (65536 * 65536 * 16)
          nMantissa3   := bin2w(substr(xVardataValue, 1, 2)) / ;
                          (65536 * 65536 * 65536 * 16)
          nMantissaTot := nMantissa0 + nMantissa1 + nMantissa2 + nMantissa3
          nNumberTemp  := if(lMinusSign, -(1 + nMantissaTot) * ;
                          (2 ^ nPowerOf), (1 + nMantissaTot) * ;
                          (2 ^ nPowerOf))
          nDecimals    := asc(right(cBuffer, 1))

          aadd( aItems, "D" )
          aadd( aItems, ctod("01/01/0100") + nNumberTemp - 1757585 )
          // In order for Clipper to correctly turn a number into a date,
          // we must perform a calculation involving a date.  1757585 is
          // the Julian number for the date 01/01/0100.

        otherwise
           aadd( aItems, "U" )
           aadd( aItems, "Unknown" )

        endcase

        aadd( aRetval, aItems )

      enddo

   endif

   fclose( nFhandle )

   return( aRetval )

/* Function ChkCond
   --------------------------------------
   Syntax:  ChkCond(<cCondition>[,lShowit])
   Returns: pTRUE if condition is syntactically correct, pFALSE if not
   Notes:   <cTemp>   The condition to check
            [lShowit] Whether to give beep if no good

*/
function Chkcond(cCondition, lShowit)

  local cRetval               as char

  private cTemp := cCondition as char

  cRetval := type( cTemp )
  lShowit := if(pcount()<2,pTRUE,lShowit)
  if  "U" $ cRetval
    if lShowit
      Errorbeep()
      Presskeymsg({ {" Invalid expression! "} })
    endif
  endif
  return( cRetval )

/* Function CopyFiles
   --------------------------------------
   Syntax:  CopyFiles()
   Returns: NIL
   Notes:   Copies one file to another

*/
function CopyFiles()

  local cFilename   := space(50)     as char
  local cScreen     := savescreen()  as char
  local lCopyresult := pTRUE         as logical
  local aEnviron    := ActiveArea()  as array
  local aMembers    := aEnviron[1]   as array
  local nActive     := aEnviron[2]   as int

  begin sequence
  if aMembers[nActive,pFILE_ELE] == NIL
    Errorbeep()
    PressKeyMsg({{"No file is active."}})
    break
  endif
  if aMembers[nActive,pOBJ_TYPE] == "DBFFILE"
    lCopyresult := CopyTo(cFilename)
  else
     scroll( maxrow() - 1, 0, maxrow(), maxcol() )
     @ maxrow(), 0 say "Enter File Name To Copy To: " get cFilename ;
                pict "@!" ;
                valid if( file(trim(cFilename)), ;
                (ErrorMessage("That File Exists.  Any key to try again"),;
                 pFALSE), pTRUE )
     read
     if lastkey() != pESC
       scroll( maxrow(), 0, maxrow(), maxcol() )
       WaitMsg(pTRUE)
       lCopyresult := ;
          COPYFILE( trim(aMembers[nActive,pFILE_ELE]), trim(cFilename) )
       WaitMsg(pFALSE)
     else
       break
     endif
  endif
  ErrorBeep()
  if lCopyresult
    PressKeyMsg({{"Operation Completed."}})
  else
    PressKeyMsg({{"File not copied."}})
  endif
  end sequence

  restscreen(,,,,cScreen )

  VOID

/* Function ShowStru
   --------------------------------------
   Syntax:  ShowStru()
   Returns: NIL
   Notes:   Displays database structure
*/
function ShowStru()

   local cScreen  := savescreen() as char
   local aStru    := {}           as array    // holds structure
   local nCounter := 1            as int

   if empty( alias() )
     ErrorMessage( "No database is open!" )
   else
     aeval( dbstruct(), ;
            {|aEle| aadd(aStru, padl(nCounter++, 5) + ".  " + ;
                    padr(aEle[DBS_NAME],12) + aEle[DBS_TYPE] +;
                    padl(aEle[DBS_LEN],6) + padl(aEle[DBS_DEC], 5))} )
     dispbox(3,10,20,50,pDBAR)
     @ 3,15 say padc(alias(),14)
     achoice(4,11,19,49,aStru)
   endif

   restscreen(,,,,cScreen )
   CLEARESC()

   VOID

/* Function Waitmsg
   ------------------------------------------------------
   Syntax:  WaitMsg(<lOn>)
   Example: WaitMsg(pTRUE)
   Returns: NIL
   Notes:   Simply prints a "Wait" message
*/

function WaitMsg(lOn)

  static cScreen as char

  if lOn
    cScreen := savescreen(0,0,0,maxcol())
    @ 0,int(maxcol()/2) say " Wait " color ColorCentral("BlinkInv")
  else
    restscreen(0,0,0,maxcol(),cScreen)
  endif

  VOID

/* Function DirFormat
   ------------------------------------------------------
   Syntax:  DirFormat()
   Example: cSearch := DirFormat()
   Returns: Current directory properly formatted
   Notes:   If at root, returns "\", else returns "\" + dir + "\"
*/
function DirFormat

  local cRetval := curdir() as char

  if !empty(cRetval)
    cRetval := "\" + cRetval + "\"
  else
    cRetval := "\"
  endif

  return( cRetval )

/* Function Atext
   --------------------------------------
   Module:  DBPGEN
   Syntax:  Atext(<cfile>)
   Returns: An array that contains one element for each "line" in
            the file.
   Notes:   cFile   File to get
*/
function Atext( cFile )

  local nFhandle      as int
  local aRetval := {} as array

  if file( cFile )
     nFhandle := fopen( cFile )
     do case
     case nFhandle > 4
       aRetval := Readtext(nFhandle,132)
       fclose(nFhandle)
       if valtype(aRetval) == "U"
         aRetval := {}
       endif
     case nFhandle > 0
       fclose(nFhandle)
     endcase
  endif

  return( aRetval )

/* Function Readtext
   --------------------------------------
   Module:  DBPGEN
   Syntax:  Readtext(<nFile>,<nWidth>)
   Returns: An array that contains one element for each "line" in
            the file.

   Notes:   nFile   File handle
            nWidth  Width of the line

            A "line" is defined as either the number of bytes passed in the
            <nWidth> parameter, or the location in that width of a
            CR/LF pair, whichever is less.

            For example, width is 70, in the first 70 characters, a
            CR/LF pair appear in bytes 50,51.  The "line" would be
            51 bytes long, not 70, and a "1" would be stored as the
            array element.

*/
#define pBUFFER_SIZE 4096

function Readtext( nFile, nWidth )

  local cBuffer           as char      // Buffer to check
  local nBuffsize         as int       // Size of buffer
  local lExit := pFALSE   as logical   // Exit condition
  local nLoc              as int       // Location where CR/LF is found
  local nPntr := 0        as int       // Number of lines found
  local cTempbuff         as char      // Temporary buffer of nWidth size
  local aIndex            as array     // Array of lines
  local nOffset := 0      as int       // Counter of offset
  local cScreen           as char      // Screen save
  local cOldcolor         as char      // Current color setting
  local lAbort := pFALSE  as logical
  local nPage := 1        as int       // Number of pPOINTER_DEPTH pages
  local nSize             as int       // Size of file
  local nBytesread := 0   as int       // Total bytes read
  local cMessage          as char
  local cAlert            as char
  local cShadow           as char

  begin sequence
  cScreen := savescreen(10,30,16,52)
  cMessage := ColorCentral("Message")
  cAlert   := ColorCentral("Alert")
  cShadow  := ColorCentral("Shadow")
  cOldcolor := setcolor(cMessage)

  if (nSize := (fseek(nFile,0,FS_END))) > 6000000
    lAbort := pTRUE
    break
  endif

  fseek( nFile, 0, FS_SET )

  scroll(10,31,14,49)
  dispbox(10,30,15,50,pDBAR)
  Newcolor(16,31,16,52,cShadow)
  Newcolor(11,51,16,52,cShadow)
  @ 11,35 say "Scanning" color cAlert
  @ 13,32 say "Line: "
  @ 14,32 say "ESC aborts"

  aIndex := {}

  while !lExit

    nBuffsize := min(pBUFFER_SIZE,(nSize-nBytesread))
    cBuffer := space( nBuffsize )
    nBytesread += fread(nFile, @cBuffer, nBuffsize )
    lExit   := (nBytesread == nSize)

    if inkey() == pESC
      lAbort := pTRUE
      break
    endif

    PROCESS

      // Record current line
      cTempbuff := substr(cBuffer,1,nWidth)

      // Find end of line
      nLoc := at( pCRLF, cTempbuff )
      if empty( nLoc )
        // No CR/LF pairs, so use the specified width
        if len(cBuffer) >= nWidth
          aadd(aIndex,substr(cBuffer,1,nWidth))
          cBuffer := substr(cBuffer,nWidth+1)
          nOffset += nWidth
        else
          exit
        endif
      else
        // Found a CR/LF pair within the specified width, jump past it
        aadd(aIndex,substr(cBuffer,1,nLoc-1))
        cBuffer := substr(cBuffer,nLoc+2)
        nOffset += (nLoc+1)
      endif
      nPntr++ // Add to line counter
      devpos(13,40)
      devout( nPntr )
      if nPntr == 4096  // max for one array
        exit
      endif

    END PROCESS

    // Test for condition b/c of array depth
    if nPntr == 4096
      Errorbeep()
      PressKeyMsg({{" Maximum array depth reached.  Not all file ",;
                    " may have been loaded..."}})
      break
    endif

    if !lExit
      // Rewind the file pointer back to capture this
      // extra text next time
      if ! (len( cBuffer ) == 0)
        fseek(nFile,-(len(cBuffer)),FS_RELATIVE)
        nBytesread -= len(cBuffer)
      endif
    else
      if !empty(cBuffer)
        // get the last line
        aadd(aIndex,cBuffer)
      endif
    endif

  end
  end sequence
  setcolor(cOldcolor)
  restscreen(10,30,16,52,cScreen)

  return( if( lAbort, NIL, aIndex) )

/* Function Askip
   --------------------------------------
   Syntax:  Askip(n, nPointer, nLength)
   Returns: Number of elements skipped
   Notes:   Used in TBROWSE objects
*/

function Askip( n, nPointer, nLength )
   // what we are doing is deciding how much to "skip."  Remember,
   // this skipper is used when we are browsing through a nondatabase
   // file.
   //
   // Our first test is to decide if we skip the amount passed as `n',
   // if that will bump us over the top or the bottom.  If `n' is the amount
   // requested to skip, nPointer is the element we are currently on,
   // and nLength is the last element, we know that the current element plus
   // (nLength - nPointer) will put us at the last element.  Thus, if `n'
   // is GREATER than this, then we need to move by EITHER the difference
   // (nLength - nPointer) (a positive move), or down 1 less than where
   // we are now (1 - nPointer).
   //
   // If `n' is LESS than compare, then the skip action can be accomodated
   // within our window, and we allow the return value to be n.  Note
   // that if we are on the first element and press down arrow, or the
   // last element and press up, the resulting skip will be 0.  We handle
   // wrapping back around outside this function, by testing for a
   // hittop or hitbottom, and issuing the appropriate message.  See
   // function Keystroke for more information.

   local nCount                                                as int
   local compare1 := if(n >= 0, nLength-nPointer, nPointer-1 ) as int
   local compare2 := if(n >= 0, nLength-nPointer, 1-nPointer)  as int

   if abs(n) > compare1    // we are
     nCount := compare2
   else
     nCount := n
   endif

   return( nCount )

/* Function ShowGenError
   --------------------------------------
   Module:  DBPGEN
   Syntax:  ShowGenError(<oError>)
   Returns: NIL
   Notes:   Displays general info about error objects

*/

function ShowGenError(oError)
  Presskeymsg({{"                    Error!                   ",;
                " ",;
                " During operation of DBUPlus, an error was ",;
                " encountered.  Information pertaining to this",;
                " error is: ",;
                " ",;
                " Description:  "+oError:description,;
                " Filename:     "+oError:filename,;
                " Clipper code: "+str(oError:genCode),;
                " Sub-code:     "+str(oError:subcode),;
                " Operation:    "+if(!empty(oError:operation),;
                  oError:operation,"Unknown"),;
                " Subsystem:    "+oError:subsystem}})

  VOID

/* Function GetExtension
   --------------------------------------
   Module:  DBPGEN
   Syntax:  GetExtension(<cExtension>)
   Returns: NIL
   Notes:   Allows user to input a DOS extension skeleton
*/

function GetExtension(cExtension)

  scroll( maxrow() - 1, 0, maxrow(), maxcol() )
  @ maxrow(),  0 say "Extension: *."
  @ maxrow(), 13 get cExtension pict "@K"
  setcursor(pCURSOR_ON)
  read
  setcursor(pCURSOR_OFF)
  @ maxrow(),0 clear     // This clears the entire row...like SCROLL()
  if lastkey() == pESC
    cExtension := ""
  endif

  return (cExtension)

// End of File: Dbpfunc.prg

DBPSets.prg

/* File              DBPSETS.PRG
   Notice            Copyright(c) 1991-1994 Sirius Software Development, Inc.
                     All Rights Reserved
   Author            Steve Straley
*/

#define CLIPPER

#include "PTInkey.ch"
#include "PTValue.ch"
#include "PTFuncs.ch"
#include "PTVerbs.ch"
#include "PTColor.ch"

#include "DBPMenu.ch"

#include "DBSTRUCT.ch"
#include "DIRECTRY.ch"

#define  pOBJ_ELE   1          // TBROWSE element slot
#define  pALIAS_ELE 2          // Alias name slot
#define  pFILE_ELE  3          // Full path and file name slot
#define  pOBJ_TYPE  4          // Type of file slot
#define  pWIN_ELE   5          // Array of window coordinates
#define  pSELECT_BOX   1       // Code to select a box
#define  pUNSELECT_BOX 2       // Code to de-hilite a box
memvar getlist

/* SET functions
   --------------------------------------
   Returns: status of the various set functions, toggled

*/

function SetWrap     // Sets Wrap
  if YNMsg({ {" SET WRAP is " +;
              if(set( pWRAP), "ON. ", "OFF."),;
              " Shall I change? "}})
     set( pWRAP, !set( pWRAP ) )
  endif

  VOID

function SetSoft()   // Sets Softseek

  if YNMsg({ {" SET SOFTSEEK is " +;
              if(set( pSOFTSEEK), "ON. ", "OFF."),;
              " Shall I change? "}})
     set( pSOFTSEEK, !set( pSOFTSEEK ) )
  endif

  VOID

/* Function SetaFilter
   --------------------------------------
   Syntax:  SetaFilter()
   Returns: NIL
   Notes:   Creates a filter condition in the current area

*/
function SetaFilter()

  local cCondition := space(100)                                    as char
  local cScreen1   := savescreen(maxrow(),0,maxrow(),maxcol() )     as char
  local cScreen2   := savescreen(maxrow()-1,0,maxrow()-1,maxcol() ) as char
  local lDomore    := pTRUE                                         as logical
  local cTemp                                                       as char
  local aEnviron := ActiveArea()                                    as array
  local aMembers:= aEnviron[1]                                      as array
  local nActive := aEnviron[2]                                      as int
  local aFields := {}                                               as array

  scroll(maxrow()-1,0,maxrow()-1,maxcol() )
  if empty( alias(nActive) )
    ErrorMessage( "No database is open." )
  else
    if !empty( dbfilter() )
      ErrorTone()
      if YNMsg({ {" Filter exists.  Shall I remove? "}})
        dbclearfilter()
        (aMembers[ nActive,pOBJ_ELE] ):refreshall()
        lDomore := pFALSE
      else
        cCondition := padr( dbfilter(), 100 )
      endif
    endif
    if lDomore
      // Get the fields
      aeval(dbstruct(),{|aEle| aadd(aFields,padr(aEle[DBS_NAME],12)+;
                                            padr(aEle[DBS_TYPE],3)+;
                                            padr(str(aEle[DBS_LEN],3),5)+;
                                            str(aEle[DBS_DEC],3)) })

      ShowTab(maxrow(),8,space(24))  // Sets up ShowTab() after entry
      @ maxrow()-1, 0 say "Enter filter condition:   " ;
                      get cCondition ;
             when ShowTab(maxrow(),8,padr("Press TAB to list fields",24)) ;
                      picture "@S50" ;
                      valid ( cTemp := trim(cCondition), ;
                             CondChk(cTemp,aFields)) ;
                      send reader := {|oGet|DBPReader(oGet)}
      read
      if lastkey() != pESC
        // here, we want early evaluation, so it checks each record
        // Clipper knows to not macro expand it all over the place
        SETFILTER( &cTemp )
        (aMembers[nActive,pOBJ_ELE]):gotop()
        (aMembers[nActive,pOBJ_ELE]):refreshall()
      endif
      ShowTab()
    endif

  endif

  CLEARESC()
  restscreen(maxrow(),0,maxrow(),maxcol(), cScreen1 )
  restscreen(maxrow()-1,0,maxrow()-1,maxcol(), , cScreen2 )

  VOID

/* Function JoinAreas
   --------------------------------------
   Syntax:  JoinAreas()
   Returns: NIL
   Notes:   Relates two databases via RECNO()

*/
function JoinAreas()

  local cScreen1 := savescreen( maxrow(),  0, maxrow(), maxcol() ) as char
  local cScreen2 := savescreen( maxrow()-1,0,maxrow()-1,maxcol() ) as char
  local nCount                                                     as int
  local aEnviron := ActiveArea()                                   as array
  local nActive := aEnviron[2]                                     as int
  local aMembers:= aEnviron[1]                                     as array
  local nTemparea                                                  as int
  local lIsparent                                                  as logical
  local nJoinArea := 0                                             as int
  local cAlias                                                     as char
  local getlist := {}                                              as array

  begin sequence

  if (DictAt(atail(aMembers),"FullScreen"))
    // User is not in full screen mode
    break
  endif

  if empty( alias() )
    ErrorMessage( "Can not connect without a database open!" )
    break
  endif
  setcursor( pCURSOR_LOWER )
  scroll(maxrow(),0,maxrow(),maxcol())

  if !empty(dbrelation())
    // This file is parent to other areas - see if user wants to clear
    // out, or add others

    ErrorBeep()
    if YNMsg({ {" Existing relation.  You can delete it,",;
                " in which case I will then create a new",;
                " relation, based on record number.  ",;
                " OR, I will add the record number relation",;
                " to the current set of related areas.",;
                " ",;
                " Shall I delete the current relation? "}})
      // Cycle through relations, setting databases to the top
      nCount := 1
      while !empty(dbrelation(nCount))
        select( dbrselect(nCount) )
        go top
        (aMembers[select(),pOBJ_ELE]):refreshall()
        MakeStable(aMembers[select(),pOBJ_ELE])
      enddo
      select( nActive )
      dbclearrel()

    endif

  endif
  @ maxrow(), 0 say "What area to connect to (Tab for areas)" ;
                get nJoinArea pict "999" ;
                valid ChkArea(aMembers) .and. ;
                      nJoinArea > 0 .and. nJoinArea < 251 .and.;
                      nJoinarea <> nActive
  read
  if lastkey() == pESC
    break
  endif

  if empty( cAlias := alias( nJoinArea ) )
    ErrorMessage( "Cannot connect without a database open in that area!" )
    break
  endif

  if !empty(dbrelation(1))
    // This file already has workareas, check and make sure the
    // work area isn't already related
    nCount := 1
    while !empty(dbrelation(nCount))
      if dbrselect(nCount++) == nJoinArea
        ErrorMessage( "Work area entered already related to this database!" )
        break
      endif
    enddo
  endif

  if !empty( (cAlias)->(indexkey(0)) )
    ErrorMessage( "Can only relate to a database that has no indexes active!" )
    break
  endif

  // Now see if nJoinarea has the current area as a child.  If so, then
  // we can't do this - would be cyclical relations
  lIsparent := pFALSE
  nTemparea := select()
  select ( nJoinArea )
  nCount := 1
  while !empty(dbrelation(nCount))
    if dbrselect(nCount++) == nTemparea
      lIsparent := pTRUE
      exit
    endif
  enddo
  select (nTemparea)
  if lIsparent
    ErrorMessage( "Cannot connect to parent database!" )
    break
  endif
  set relation additive to recno() into (cAlias)
  goto recno()
  SetSeed( select() )

  end sequence
  restscreen(maxrow(),0,maxrow(),maxcol(), cScreen1 )
  restscreen(maxrow()-1,0,maxrow()-1,maxcol(), cScreen2 )
  CLEARESC()
  setcursor( pCURSOR_OFF )

  VOID

/* Function RelateThem
   --------------------------------------
   Syntax:  RelateThem()
   Returns: NIL
   Notes:   Relates two areas via a field in an index
*/
function RelateThem()

  local cScreen1 := savescreen( maxrow(),  0, maxrow(), maxcol() ) as char
  local cScreen2 := savescreen( maxrow()-1,0,maxrow()-1,maxcol() ) as char
  local aThefields := {}                                           as array
  local cConnect                                                   as char
  local nJoinArea  := 0                                            as int
  local cAlias                                                     as char
  local aEnviron := ActiveArea()                                   as array
  local nActive := aEnviron[2]                                     as int
  local aMembers:= aEnviron[1]                                     as array
  local nTemparea                                                  as int
  local lIsparent                                                  as logical
  local nCount := 1                                                as int
  local bOlderror                                                  as block
  local oError                                                     as object

  bOlderror := errorblock({|oError| break(oError)})
  begin sequence

  if (DictAt(atail(aMembers),"FullScreen"))
    // User is in full screen mode
    break
  endif

  if empty( alias() )
    ErrorMessage( "Must have a database open in order to relate!" )
    break
  endif

  setcursor( pCURSOR_LOWER )
  scroll(maxrow() - 1,0,maxrow()-1,maxcol() )

  // find out which areas have not already been attached
  if !empty(dbrelation())

    ErrorTone()
    if YNMsg({ {" Existing relation.  You can delete it,",;
               " in which case I will then create a new",;
               " relation, based on a field. ",;
               " ",;
               " Alternatively, I will add the relation",;
               " to the current set of related areas.",;
               " ",;
               " Shall I delete the current relation? "}})
      // Cycle through relations, setting databases to the top
      nCount := 1
      while !empty(dbrelation(nCount))
        select( dbrselect(nCount) )
        go top
        (aMembers[select(),pOBJ_ELE]):refreshall()
        MakeStable(aMembers[select(),pOBJ_ELE])
      enddo
      select( nActive )
      dbclearrel()

    endif

  endif

  // We will allow relation based on one field.  Further expansion
  // here would be nice, to allow relation on an expression that
  // evaluates to a key field.
  aeval( dbstruct(), {|aEle| aadd( aThefields, aEle[DBS_NAME] )} )

  cConnect := space(80)
  @ maxrow(), 0 say "Expression (TAB for fields):"
  // Check condition only for syntax here, pass pTRUE as third param
  // to Condchk
  @ maxrow(),30 get cConnect picture "@S40" ;
                    valid CondChk(cConnect,aThefields,pTRUE) ;
                    send reader := {|oGet|DBPReader(oGet)}
  read
  if lastkey() == pESC
    break
  endif

  scroll(maxrow(),0,maxrow(),maxcol())
  @ maxrow(), 0 say "What area to connect to (Tab for areas)" ;
                get nJoinArea pict "999" ;
                valid ChkArea(aMembers) .and. ;
                      nJoinArea > 0 .and. nJoinArea < 251 .and.;
                      nJoinarea <> nActive

  setcursor(pCURSOR_ON)

  read
  if lastkey() == pESC
    break
  endif

  if empty( cAlias := alias( nJoinarea ) )
    ErrorMessage( "Can not connect without a database open in that area!" )
    break
  endif

  if !empty(dbrelation(1))
    // This file already has work areas, check and make sure the
    // work area isn't already related
    nCount := 1
    while !empty(dbrelation(nCount))
      if dbrselect(nCount++) == nJoinArea
        ErrorMessage( "Work area entered already related to this database!" )
        break
      endif
    enddo
  endif

  // Now see if proposed area has THIS area as a child.  If so,
  // then we can't do this - would be cyclical relations
  lIsparent := pFALSE
  nTemparea := select()
  select ( nJoinArea )
  nCount := 1
  while !empty(dbrelation(nCount))
    if dbrselect(nCount++) == nTemparea
      lIsparent := pTRUE
      exit
    endif
  enddo
  select (nTemparea)
  if lIsparent
    ErrorMessage( "Can not connect to parent database!" )
    break
  endif
  cConnect := alltrim(cConnect)
  // We want late evaluation here
  set relation additive to &(cConnect) into (cAlias)
  goto recno()
  SetSeed(select())

  recover using oError
    IF oError IS pOBJECT
      ErrorMessage( " Error setting relation " )
      set relation to
    endif
  end sequence
  setcursor( pCURSOR_OFF )

  restscreen(maxrow(),0,maxrow(),maxcol(), cScreen1 )
  restscreen(maxrow()-1,0,maxrow()-1,maxcol(), cScreen2 )
  CLEARESC()
  errorblock(bOlderror)

  VOID

/* Function Toggledelete
   --------------------------------------
   Syntax:  Toggledelete()
   Returns: NIL
   Notes:   Toggles SET DELETED flag

*/
function ToggleDelete()

  local aEnviron := ActiveArea()                           as array
  local nActive := aEnviron[2]                             as int
  local oObject := aEnviron[1,nActive,pOBJ_ELE]            as object
  // Get environmental status for SET DELETED
  local lDeltoggle := DictAt(atail(aEnviron[1]),"Deleted") as logical

  if YNMsg({ {" SET DELETED is " + if(lDeltoggle, "ON. ", "OFF."),;
             " Shall I change? "}})
    set(pDELETED, (lDeltoggle := !lDeltoggle) )
    DictPut(atail(aEnviron[1]),"Deleted",lDeltoggle)
    if oObject IS pOBJECT
       oObject:refreshall()
    endif
  endif

  VOID

/* Function SearchPath
   --------------------------------------
   Syntax:  Searchpath()
   Returns: NIL
   Notes:   Allows user to change path for files
*/
function SearchPath()

  local aEnviron := ActiveArea()                     as array
  local aMembers := aEnviron[1]                      as array
  local nActive := aEnviron[2]                       as int
  local oObject := aMembers[nActive,pOBJ_ELE]        as object
  local cDrive := DictAt(atail(aMembers),"Drive")    as char
  local cSearch := DictAt(atail(aMembers),"Search")  as char

  // Build a directory list of current drive, don't build again unless
  // specifically asked, show it on the command line
  local cChoice := DirList(cDrive,pFALSE,pTRUE)      as char

  if !empty( cChoice ) .and. lastkey() != pESC
    cSearch := substr(cChoice, 3)
    DictPut(atail(aMembers),"Search",cSearch)
    DictPut(atail(aMembers),"Path",cDrive+cSearch)
    ShowPath(cDrive,cSearch)
  endif

  CLEARESC()

  VOID

/* Function NewOrder
   --------------------------------------
   Syntax:  NewOrder()
   Returns: NIL
   Notes:   Allows setting of a new index order
*/

function NewOrder()

  local nCurrent := indexord()   as int
  local aEnviron := ActiveArea() as array
  local aMembers := aEnviron[1]  as array
  local nActive  := aEnviron[2]  as int

  if empty( alias() )
    ErrorMessage( "No database nor index is open." )
  else
    scroll(maxrow()-1,0,maxrow(),maxcol())
    @ maxrow(), 0 say "Enter index order: " get nCurrent picture "##" ;
      valid nCurrent >= 0 .and. nCurrent <= 15
    read
    if lastkey() != pESC
      dbsetorder( nCurrent )
      (aMembers[nActive,pOBJ_ELE]):refreshall()
      (aMembers[nActive,pOBJ_ELE]):gotop()
    endif
    scroll(maxrow()-1,0,maxrow(),maxcol())
  endif
  CLEARESC()

  return( NIL )


/* Function ScreenModes
   --------------------------------------
   Syntax:  ScreenModes()
   Returns: NIL
   Notes:   Attempts to toggle between 43 and 25 line mode
*/
function ScreenModes()

  static bActivity                                          as block

  local aEnviron    := ActiveArea()                         as array
  local aMembers    := aEnviron[1]                          as array
  local nActive     := aEnviron[2]                          as int
  local lFullscreen := DictAt(atail(aMembers),"FullScreen") as logical
  local bNormalmode := DictAt(atail(aMembers),"NormalMode") as block
  local lMorelines  := DictAt(atail(aMembers),"MoreLines")  as logical

  if !lFullscreen

    if bActivity == NIL     // it's undefined! -- if valtype(bActivity) == "U"
      // Create code block of items to perform
      bActivity := {|| WinCalc(),;
                       DrawScreen(),;
                       aMembers := ActiveArea()[1],;
                       DispMessage(, maxrow(),0),;
                       ErrorMessage(,maxrow(),0) }
    endif

    if (lMorelines := !lMorelines)
      if !setmode(43,80)
        ErrorMessage( "Unable to handle 43 line mode!" )
        lMorelines := pFALSE
      else
        eval( bActivity )
      endif
    else
      eval( bNormalmode )
      eval( bActivity )
    endif
    DispMessage(, maxrow(),0)
    ErrorMessage(,maxrow(),0)
    DictPut(atail(aMembers),"MoreLines",lMoreLines)

  endif

  VOID

/* Function SetValues
   --------------------------------------
   Syntax:  SetValues
   Returns: NIL
   Notes:   Displays SET values

*/
function SetValues()

  local cScreen := savescreen()     as char
  local nArea   := select()         as int
  local nActive := ActiveArea()[2]  as int

  dispbox(0,0,maxrow(),maxcol(), pDBAR )
  @ 0,1 say " System Statistics "

  @ 1,  6 say " Wrap Around is " + if( set(pWRAP), "On", "Off" )
  @ 1, 30 say "Soft Seeking is " + if( set(pSOFTSEEK), "On", "Off" )
  @ 1, 60 say "Delete is set "   + if( set(pDELETED), "On", "Off" )

  // Get to the area in the upper left box
  nActive := GetStart()

  DoStats(nActive,{3,1})
  DoStats(nActive+1,{15,1})
  DoStats(nActive+2,{3,39})
  DoStats(nActive+3,{15,39})

  inkey(0)
  select(nArea)

  CLEARESC()
  restscreen(,,,,cScreen )

  VOID

/* Function DoStats
   --------------------------------------
   Syntax:  DoStats(<nArea>,<aPnts>)
   Returns: NIL
   Notes:   Displays information about a work area

            nArea       The work area we want to display
            aPnts       The boundaries to use
*/
function DoStats( nArea, aPnts )

  local nRow := aPnts[1] as int
  local nCol := aPnts[2] as int

  select( nArea )

  @ nRow++, nCol say "Window " + str(nArea,1) ;
                 say ": "  say if( empty(alias()), "None", alias() )
  @ nRow++, nCol say "           Last Record: " ;
                 say padl( lastrec(), 10 )
  @ nRow++, nCol say "         Active Record: " ;
                 say padl( recno(), 10 )
  @ nRow++, nCol say "    Active Index Order: " ;
                 say padl( indexord(), 10 )
  @ nRow++, nCol say "                   Key: " ;
                 say left( if( empty(indexkey(indexord())), ;
                           "Natural Order", indexkey(indexord()) ), 35)
  @ nRow++, nCol say "         Active Filter: " ;
                 say left( if( empty(dbfilter()), "None", dbfilter() ), 35)
  @ nRow++, nCol say "          Relation Key: " ;
                 say if( empty(dbrelation()), "None", dbrelation() )
  @ nRow++, nCol say "        Related Window: " ;
                 say if( empty(dbrselect()), "", "to Window " + ;
                                                 str(dbrselect(), 1) )

  VOID

/* Function Showkeys
   --------------------------------------
   Syntax:  Showkeys()
   Returns: NIL
   Notes:   Displays active indexes
*/
function ShowKeys()

   local cScreen := savescreen() as char
   local nCount                  as int

   if empty( alias() )
     ErrorMessage( "A database is required to be opened." )

   else
     dispbox(2,1,19,77,pDBAR)
     @ 2,2 say " Index Order for: " + alias() + " "
     @ 3,2 say " 0. " + if(nCount == indexord(), chr(16), chr(32) ) + chr(32) + "Natural Order (Record Number Order)"
     for nCount := 1 TO 15
        @ nCount+3, 2 say transform(nCount, "99. ") + ;
          if(nCount == indexord(), chr(16), chr(32) ) + chr(32) + ;
             indexkey( nCount )
     next
     @ 19, 2 say " Any key to return..."
     inkey(0)
   endif

   restscreen(,,,,cScreen )
   CLEARESC()

   VOID

/* Function Showdirectory
   --------------------------------------
   Syntax:  ShowDirectory()
   Returns: NIL
   Notes:   Shows contents of current directory
*/
function ShowDirectory()

   local aEnviron := ActiveArea()                     as array
   local aMembers := aEnviron[1]                      as array
   local cSearch  := DictAt(atail(aMembers),"Search") as char
   local cScreen  := savescreen()                     as logical
   local lTripped := pFALSE                           as array
   local aListing := directory(cSearch + "*.*")       as int
   local nCount

   asort(aListing,,,{|x,y| upper(x[F_NAME]) < upper(y[F_NAME])})
   dispbox( 2,0,maxrow()-1,maxcol(), pDBAR )

   for nCount := 1 to len( aListing )
     if !DisplayDir(aListing[nCount], @lTripped)
       exit
     endif
   next

   if !lTripped
     @ maxrow()-2, 3 say "Any key to return..."
     inkey(0)
   endif

   restscreen(,,,,cScreen )
   CLEARESC()

   VOID

/* Function Displaydir
   --------------------------------------
   Syntax:  DisplayDir(<aDir>,<lValue>)
   Returns: NIL
   Notes:   displays contents of aDIR, returning lValue
*/
function DisplayDir( aDir, lValue )

   devpos( row(), 3 )
   qqout( padr(aDir[1], 15) + padr(aDir[2], 21) + padr(aDir[3], 9) + ;
          padr(aDir[4], 9) + padr(aDir[5], 5) + pCRLF )
   if row() == maxrow() - 4
     devpos( row()+1, 3 )
     qqout( "Any key to continue or 'Q' to quit" )
     lValue := chr(inkey(0))$"Qq"
     dispbox( 2,0,maxrow()-1,maxcol(), pDBAR )
   endif

   return( !(lValue) )

/* Function Changedrive
   --------------------------------------
   Syntax:  Changedrive(<aEnviron>)
   Returns: NIL
   Notes:   Allows user to select logged drive
*/
function ChangeDrive

  local aEnviron := ActiveArea()                             as array
  local cScreen  := savescreen(maxrow(),0,maxrow(),maxcol()) as char
  local aMembers := aEnviron[1]                              as array
  local cDrive   := DictAt(atail(aMembers),"Drive")          as char
  local cSearch  := DictAt(atail(aMembers),"Search")         as char
  local cNewlogged                                           as char

  scroll(maxrow(),0,maxrow(),maxcol() )
  cNewlogged := cDrive

  @ maxrow(), 0 say "Enter new logged drive: " get cNewlogged ;
    picture "!:" valid ValidDrPath(cNewlogged)
  read
  if lastkey() != pESC
    cDrive  := cNewlogged
    cSearch := "\"
    DictPut(atail(aMembers),"Drive",cDrive)
    DictPut(atail(aMembers),"Search","\")
    DictPut(atail(aMembers),"Path",cDrive+"\")
    set( pPATH, cDrive + cSearch )
    // Build directory tree
    DosStru(,,pTRUE)
    ShowPath(cDrive,"\")
  endif
  restscreen(maxrow(),0,maxrow(),maxcol(),cScreen)

  VOID

/* Function Instoggle
   --------------------------------------
   Syntax:  Instoggle()
   Returns: NIL
   Notes:   Used to toggle setting of INS key
*/
function Instoggle()

  if readinsert()
    readinsert(pFALSE)
    setcursor(pCURSOR_ON)

  else
    readinsert(pTRUE)
    setcursor(pCURSOR_UPPER)

  endif

  VOID

/* Function ChkArea
   --------------------------------------
   Syntax:  ChkArea(<aMembers>)
   Returns: .T. if an area chosen, else .F.
   Notes:   Allows user to choose a work area

*/
static function ChkArea(aMembers)

  local lRetval := pTRUE     as logical
  local aArray               as array
  local oGet := getactive()  as object
  local nRow := oGet:row + 1 as int
  local nChoice              as int
  local cScreen              as char
  local nCount               as int

  if lastkey() == pTAB
    aArray := {}
    for nCount := 1 to (len(aMembers) - 1)
      if aMembers[nCount,pOBJ_TYPE] == "DBFFILE"
        aadd(aArray,str(nCount,3,0)+"  "+;
                    padr(aMembers[nCount,pALIAS_ELE],10))
      endif
    next

    cScreen := savescreen(nRow,8,nRow,31)
    @ nRow,8 say padr("Work areas/aliases:",24)
    nChoice := Alist(,aArray)
    restscreen(nRow,8,nRow,31,cScreen)

    // User can type within AList()
    if lastkey() != pESC
      // Update GET variable
      oGet:varput( val( substr( aArray[nChoice],1,3 ) ) )
    endif
    lRetval := pFALSE

  endif

  return( lRetval )

// End of File:DBPSets.prg

DBPOpen.prg

/* File              DBPOPEN.prg
   Notice            Copyright(c) 1991-1994 Sirius Software Development, Inc.
                     All Rights Reserved
   Author(s)         Steve Straley
*/
#define CLIPPER

#include "PTFuncs.ch"
#include "PTValue.ch"
#include "PTInkey.ch"
#include "PTColor.ch"
#include "PTVerbs.ch"

#include "FILEIO.ch"
#include "DBSTRUCT.ch"

#define  pOBJ_ELE   1          // TBROWSE element slot
#define  pALIAS_ELE 2          // Alias name slot
#define  pFILE_ELE  3          // Full path and file name slot
#define  pOBJ_TYPE  4          // Type of file slot
#define  pWIN_ELE   5          // Array of window coordinates
#define  pSELECT_BOX   1       // Code to select a box
#define  pUNSELECT_BOX 2       // Code to de-hilite a box

// Used to reference correct window given object
#xtranslate  pACTIVE_WIN(<nArea>) => if(<nArea> \< 5,<nArea>,;
                                        if(<nArea> % 4 == 0,4,<nArea> % 4))

memvar getlist

/* Function OpenDatabase
   --------------------------------------
   Module:  DBPOpen
   Syntax:  OpenDatabase()
   Returns: NIL
   Notes:   Opens a database file
*/
function OpenDatabase

  local aEnviron   := ActiveArea()                as array  
  local nActive    := aEnviron[2]                 as int    
  local aMembers   := aEnviron[1]                 as array  
  local aWin       := aMembers[nActive,pWIN_ELE]  as array  
  local cFilename  := space(50)                   as char
  local cAname     := space(10)                   as char
  local oTemp                                     as object
  local oColumn                                   as object
  local nCount                                    as int
  local cExtension := "dbf"                       as char
  local cNormal                                   as char
  local cMenu                                     as char
  local cMessage                                  as char
  local cDrive                                    as char
  local cSearch                                   as char
  local bOlderror                                 as block  
  local oError                                    as object

  static cNormColClr  as char           // Color for browse columns
  static cDateColClr  as char           // Color for columns with dates
  static cYearCelClr  as char           // Color for date cells prior to this year

  if cNormColClr == NIL
    // Fix colors for browse example
    cNormal  := ColorCentral("Normal")
    cMenu    := ColorCentral("Menu")
    cMessage := ColorCentral("Message")
    cNormColClr := substr(cNormal,1,at(",",cNormal))
    cNormColClr += substr(cNormal,len(cNormColClr)+1,;
                         at(",",substr(cNormal,len(cNormColClr)+1))-1)

    cDateColClr := substr(cMenu,1,at(",",cMenu))
    cDateColClr += substr(cMenu,len(cDateColClr)+1,;
                         at(",",substr(cMenu,len(cDateColClr)+1))-1)

    cYearCelClr := substr(cMessage,1,at(",",cMessage))
    cYearCelClr += substr(cMessage,len(cYearCelClr)+1,;
                         at(",",substr(cMessage,len(cYearCelClr)+1))-1)
  endif

  bOlderror := errorblock({|oError| break(oError)})
  begin sequence

  if (DictAt(atail(aMembers),"FullScreen"))
    // User is in full screen mode
    break
  endif

  select(nActive)
  if !empty( alias() )  // a .dbf is located here
    ErrorTone()
    if !YNMsg({{" Work area is active.  Shall I proceed? "}})
      break
    endif
  endif

  if empty(cExtension := GetExtension(cExtension))
    // User pressed ESC at extension field
    break
  endif

  // user must indicate a file extension to search for
  cDrive := DictAt(atail(aMembers),"Drive")
  cSearch := DictAt(atail(aMembers),"Search")

  scroll( maxrow() - 1, 0, maxrow(), maxcol() )
  @ maxrow(), 0 say "Enter File Name:   " get cFilename ;
    when FileList( @cFilename, cDrive + cSearch,"*."+cExtension ) ;
    valid Fileexist(cFilename)
  read
  if lastkey() != pESC
    cAname := padr( RootName(cFilename), 10 )
    DispMessage("")
    @ maxrow(), 0 say "Name of alias: " get cAname picture "@K@!" ;
      valid if( NewAlias( trim(cAname) ), pTRUE , ;
      (ErrorMessage("Alias previously used!"), pFALSE ) )
    read
    if lastkey() != pESC

      use ( trim(cFilename) ) alias &( trim(cAname) )
      oTemp := tbrowsedb(aWin[1], aWin[2],;
                         aWin[3], aWin[4])
      oColumn := tbcolumnnew( " ", ;
                 {|| if( deleted(), chr(16), chr(32) )} )
      oColumn:width := 1
      oTemp:addColumn( oColumn )
      oColumn := tbcolumnnew( "#", {|| str(recno(),5)} )
      oColumn:width := 5
      oTemp:addColumn( oColumn )
      // For demo purposes, make date field columns
      // in a different color, and highlite cells that
      // have a date in them prior to the current year.
      //
      oTemp:colorSpec := cNormColClr +","+cDateColClr +","+cYearCelClr

      for nCount := 1 TO fcount()
        // If a field is a MEMO field, do not display contents.
        // instead, display a "marker," so user knows it is a
        // memo field
        oColumn := tbcolumnnew(fieldname(nCount),;
           if( valtype( fieldget(nCount) ) == pMEMO, ;
           {|| "<<memo>>"},;
                 fieldwblock( fieldname(nCount), select() ) ;
              ) )
        oTemp:addColumn( oColumn )

        if valtype( fieldget(nCount) ) == pDATE
           // Change color for column, then individual
           // cells if date is prior to current year
           oColumn:defColor := {3,4}
           oColumn:colorBlock := ;
              {|dDate| iif(year(dDate) < year(date()),{5,6},{3,4})}
        endif
      next
      aMembers[nActive,pOBJ_ELE] := oTemp        // Add the object
      (aMembers[nActive,pOBJ_ELE]):freeze := 1   // Freeze col 1
      aMembers[nActive,pALIAS_ELE] := cAname     // Add alias name
      aMembers[nActive,pFILE_ELE] := cFilename   // Add full path
      aMembers[nActive,pOBJ_TYPE] := "DBFFILE"   // Add file type
    endif

  endif

  // Hilite the new area
  @ aWin[1]-1,aWin[2]+6 say " Alias: " ;
                        say if(empty(alias()), "Unknown ",padr(alias(),11) )
  BoxArea(pACTIVE_WIN(nActive),pSELECT_BOX)

  recover using oError
    if valtype(oError) == "O"
      PressKeyMsg({{" An error has occurred.  ",;
                    " Database Open cancelled. "}})
    endif
  end sequence
  errorblock(bOlderror)

  CLEARESC()
  scroll(maxrow()-1, 0, maxrow(),maxcol())

  VOID

/* Function OpenIndex
   --------------------------------------
   Module:  DBPOpen
   Syntax:  OpenIndex()
   Returns: NIL
   Notes:   Allows user to open an index file
*/
function OpenIndex()

   local cFilename  := space(50)     as char
   local cExtension := "ntx"         as char
   local aEnviron   := ActiveArea()  as array
   local aMembers   := aEnviron[1]   as array
   local nActive    := aEnviron[2]   as int
   local cDrive                      as char
   local cSearch                     as char
   local bOlderror                   as block
   local oError                      as object

   bOlderror := errorblock({|oError| break(oError)})
   begin sequence
   if empty( alias() )
     ErrorMessage( "No database is in use." )
   else
     cDrive := DictAt(atail(aMembers),"Drive")
     cSearch := DictAt(atail(aMembers),"Search")
     if !empty(cExtension := GetExtension(cExtension))
       @ maxrow(), 0 say "Enter File Name: " get cFilename ;
       when FileList( @cFilename, cDrive + cSearch,"*."+cExtension ) ;
       valid if( IndexActive(cFilename), ;
                 !ErrorMessage( "Index key is active. Try again!"), pTRUE )
       read
       if lastkey() != pESC
         if file( cFilename := trim( cFilename ) )
           // allow for an additve index!
           dbsetindex( cFilename )
           (aMembers[nActive,pOBJ_ELE]):refreshall()
         else
           ErrorMessage( "That file does not exist!" )
         endif
       endif
     endif
   endif
   recover using oError
     IF oError IS pOBJECT
       PressKeyMsg({{" An error has occurred.  ",;
                     " Index Open cancelled. "}})
     endif
   end sequence
   errorblock(bOlderror)

   CLEARESC()
   scroll(maxrow()-1, 0, maxrow(),maxcol())

   VOID

/* Function OpenVariables
   --------------------------------------
   Module:  DBPOpen
   Syntax:  OpenVariables()
   Returns: NIL
   Notes:   Reads a .mem file
            OpenVarsInFile() and AdjMem() are located in Genfunc.prg

*/
function OpenVariables()

  local cFilename := space(80)  as char   // Full path and file name
  local oTemp                   as object // Tbrowse var
  local oColumn                 as object // TBColumn var
  local aBuildVars              as array  // Array of values from .mem file
  local nVar                    as int    // Temp var to hold aBuildvars index
  local cExtension := "mem"     as char   // File extension for mem file
  local cType                   as char   // Scratch var to determine var
  local xVal                    as usual  // Scratch var holding a value edit

  local aEnviron := ActiveArea()               as array
  local nActive  := aEnviron[2]                as int
  local aMembers := aEnviron[1]                as array
  local aWin     := aMembers[nActive,pWIN_ELE] as array
  local cDrive                                 as char
  local cSearch                                as char
  local oError                                 as object
  local bOlderror                              as block

  private nSkipval   as int    // Number to skip

  bOlderror := errorblock({|oError| break(oError)})
  begin sequence
  if (DictAt(atail(aMembers),"FullScreen"))
    // User is in full screen mode
    break
  endif

  if !empty( aMembers[nActive,pALIAS_ELE])
    Errorbeep()
    PressKeyMsg({{" Area in use! "}})
    break
  endif

  if empty(cExtension := GetExtension(cExtension))
    // User pressed ESC at extension field
    break
  endif

  cDrive := DictAt(atail(aMembers),"Drive")
  cSearch := DictAt(atail(aMembers),"Search")
  scroll( maxrow() - 1, 0, maxrow(), maxcol() )
  @ maxrow(), 0 say "Enter File Name: " get cFilename ;
        pict "@S50" ;
        when FileList( @cFilename, cDrive + cSearch,"*."+cExtension ) ;
        valid Fileexist(cFilename)

  read
  if lastkey() != pESC

    Waitmsg(pTRUE)
    aBuildVars := GetVarsFromFile( trim(cFilename) )
    Waitmsg(pFALSE)
    oTemp := tbrowsenew(aWin[1], aWin[2],aWin[3], aWin[4])
    /* cargo has array of two elements:

         1  Array holding .mem file contents.  One element for
            each memory variable.  This element is itself an array
            with the following format:

            Element 1: Variable name - 12 characters
            Element 2: Variable type - 1 character
            Element 3: Variable value  as many characters as required

         2  A number representing the current line of the .mem
            file we are browsing.
    */
    oTemp:cargo := { aBuildVars, 1 }
    /* Skipblock works as:
       1) Assign current row value to 'nVar'
       2) Figure out where we skip to by processing keystroke pressed
          via Askip().
       3) Add the number actually skipped to nVar to update our
          current position.
       4) Assign that value back to place in cargo
       5) Return actual number skipped, as returned from Askip()
    */
    oTemp:skipblock     := {|n| nVar := (oTemp:cargo)[2], ;
                 nSkipval := Askip(n, nVar, len( (oTemp:cargo)[1] ) ),;
                 nVar += nSkipval, (oTemp:cargo)[2] := nVar, nSkipval }

    // 'Go Top' simply means assigning a '1' to the 'current row' holder
    oTemp:goTopBlock    := {|| (oTemp:cargo)[2] := 1}

    // 'Go Bottom' means assigning the last row in the array to the
    //   'current row' holder
    oTemp:goBottomBlock := {|| (oTemp:cargo)[2] := len( (oTemp:cargo)[1] ) }

    // Create columns.  For variable array, one col for name, one for
    // type, one for value.
    oColumn := tbcolumnnew( "Name", ;
               {|| (oTemp:cargo)[1, (oTemp:cargo)[2] ,1]} )
    oColumn:width := 11
    oTemp:addColumn( oColumn )

    oColumn := tbcolumnnew( "Type", ;
               {|| (oTemp:cargo)[1, (oTemp:cargo)[2] ,2]} )
    oColumn:width := 4
    oTemp:addColumn( oColumn )

    // The value block checks the data type element, and converts
    // appropriately.  Remember that "(oTemp:cargo)[2]" evaluates
    // the line of the cargo array we are on!
    oColumn := tbcolumnnew( "Value", ;
               {|| (oTemp:cargo)[1, (oTemp:cargo)[2] ,3]})
    oColumn:width := 17
    oTemp:addColumn( oColumn )

    aMembers[nActive,pOBJ_ELE] := oTemp
    (aMembers[nActive,pOBJ_ELE]):freeze := 1
    aMembers[nActive,pALIAS_ELE] := RootName( cFilename )
    aMembers[nActive,pFILE_ELE] := cFilename
    aMembers[nActive,pOBJ_TYPE] := "MEMFILE"
  endif

  // Hilite the new area
  @ aWin[1]-1,aWin[2]+6 say " Alias: "+;
    if(empty(aMembers[nActive,pALIAS_ELE]), "Unknown ",;
        padr(aMembers[nActive,pALIAS_ELE],11) )
  BoxArea(pACTIVE_WIN(nActive),pSELECT_BOX)

  recover using oError
    IF oError IS pOBJECT
      Waitmsg(pFALSE)
      PressKeyMsg({{" An error has occurred.  ",;
                    " Variable File Open cancelled. "}})
    endif
  end sequence
  errorblock(bOlderror)
  CLEARESC()
  scroll(maxrow()-1, 0, maxrow(),maxcol())

  VOID

/* Function OpenFlatfile
   Module:  DBPOpen
   --------------------------------------
   Syntax:  OpenFlatFile()
   Returns: NIL
   Notes:   Opens a text file for viewing.

*/
function OpenFlatFile()

  local cFilename := space(80)  as char   // Full path and file name
  local oTemp                   as object // Tbrowse var
  local oColumn                 as object // TBColumn var
  local aTextPtrs               as array  // Array of offsets into the text
  local nVar                    as int    // Temp var to hold aTextPtrs index
  local nSkipval                as int    // Number to skip
  local cExtension := "prg"     as char   // File extension for text file
  local aEnviron := ActiveArea()           as array
  local nActive := aEnviron[2]             as int
  local aMembers := aEnviron[1]            as array
  local aWin := aMembers[nActive,pWIN_ELE] as array
  local cDrive                             as char
  local cSearch                            as char
  local bOlderror                          as block
  local oError                             as object

  bOlderror := errorblock({|oError| break(oError)})
  begin sequence

  if (DictAt(atail(aMembers),"FullScreen"))
    // User is in full screen mode
    break
  endif

  if !empty( aMembers[nActive,pALIAS_ELE])
    Errorbeep()
    PressKeyMsg({{" Area in use! "}})
    break
  endif

  if empty(cExtension := GetExtension(cExtension))
    // User pressed ESC at extension field
    break
  endif

  cDrive := DictAt(atail(aMembers),"Drive")
  cSearch := DictAt(atail(aMembers),"Search")
  scroll( maxrow() - 1, 0, maxrow(), maxcol() )
  @ maxrow(), 0 say "Enter File Name: " get cFilename ;
    picture "@S50" ;
    when FileList( @cFilename, cDrive + cSearch,"*."+cExtension ) ;
    valid Fileexist(cFilename)
  read
  if lastkey() != pESC

    WaitMsg(pTRUE)
    aTextPtrs := AText( trim(cFilename))
    WaitMsg(pFALSE)
    if empty(aTextPtrs)
      oError := errornew()
      break
    endif
    // This is limited to one array that is 4096 in length
    // For a method by which to browse larger files, look
    // at TreeDos, in the ShowFile() function.

    oTemp := tbrowsenew(aWin[1], aWin[2], aWin[3], aWin[4])

    oTemp:cargo := { aTextPtrs, 1 }
    oTemp:skipblock     := {|n| nVar := (oTemp:cargo)[2], nSkipval := ;
        Askip(n, nVar, LEN( (oTemp:cargo)[1] ) ),;
         nVar += nSkipval,(oTemp:cargo)[2] := nVar, nSkipval }
    oTemp:goTopBlock    := {|| (oTemp:cargo)[2] := 1}
    oTemp:goBottomBlock := {|| (oTemp:cargo)[2] := len( (oTemp:cargo)[1] ) }

    oColumn := tbcolumnnew( "", {|| (oTemp:cargo)[1, (oTemp:cargo)[2] ]} )
    oColumn:width := 76

    oTemp:addcolumn( oColumn )

    aMembers[nActive,pOBJ_ELE] := oTemp
    (aMembers[nActive,pOBJ_ELE]):freeze := 1
    aMembers[nActive,pALIAS_ELE] := RootName( cFilename )
    aMembers[nActive,pFILE_ELE] := cFilename
    aMembers[nActive,pOBJ_TYPE] := "TXTFILE"
  endif

  // Hilite the new area
  @ aWin[1]-1,aWin[2]+6 say " Alias: "+;
    if(empty(aMembers[nActive,pALIAS_ELE]), "Unknown ",;
        padr(aMembers[nActive,pALIAS_ELE],11) )
  BoxArea(pACTIVE_WIN(nActive),pSELECT_BOX)

  recover using oError
    IF oError IS pOBJECT
      Waitmsg(pFALSE)
      PressKeyMsg({{" An error has occurred.  ",;
                    " Flat File Open cancelled. "}})
    endif
  end sequence
  errorblock(bOlderror)

  CLEARESC()
  scroll(maxrow()-1, 0, maxrow(),maxcol())

  VOID

/* Function FileExist
   --------------------------------------
   Syntax:  FileExist(cFilename)
   Returns: .t. if file exists, .f. otherwise
   Notes:   Checks for the existence of Cfilename

*/
function Fileexist(cFilename)

  local cBott            as char
  local lRetval := pTRUE as logical

  // If they pressed TAB, call the file list function again
  if !file(trim(cFilename))
    lRetval := pFALSE
    cBott := savescreen(maxrow(),0,maxrow(),maxcol())
    Errorbeep()
    DispMessage("File does not exist!")
    Inkey(2)
    restscreen(maxrow(),0,maxrow(),maxcol(),cBott)
  endif

  return( lRetval )

// End of File: DBPOpen.prg

DBPMake.prg

/* File              DBPMAKE.prg
   Notice            Copyright(c) 1991-1994 Sirius Software Development, Inc.
                     All rights reserved
   Author            Steve Straley
*/

#define CLIPPER

#include "PTVerbs.ch"
#include "PTFuncs.ch"
#include "PTValue.ch"
#include "PTInkey.ch"
#include "PTColor.ch"

#include "FILEIO.ch"
#include "DBSTRUCT.ch"

#define  pOBJ_ELE   1          // TBROWSE element slot
#define  pALIAS_ELE 2          // Alias name slot
#define  pFILE_ELE  3          // Full path and file name slot
#define  pOBJ_TYPE  4          // Type of file slot
#define  pWIN_ELE   5          // Array of window coordinates
#define  pSELECT_BOX   1       // Code to select a box
#define  pUNSELECT_BOX 2       // Code to de-hilite a box
field  FIELD_NAME              // Field in structure extended file
field  FIELD_TYPE              // ""
field  FIELD_LEN               // ""
field  FIELD_DEC               // ""
memvar getlist

/* Function MakeDatabase
   --------------------------------------
   Syntax:  MakeDatabase()
   Returns: NIL
   Notes:   Allows user to construct a .dbf file.
*/
function MakeDatabase()
  #define APPEND_MODE_ON(oObject)      (oObject:cargo := pTRUE)
  #define APPEND_MODE_OFF(oObject)     (oObject:cargo := pFALSE)
  #define APPEND_MODE_STATUS(oObject)  (oObject:cargo)

  local cFilename           as char    // database to create/modify
  local cScreen             as char    // Screen saver
  local oObject             as object  // Object we are using
  local oColumn             as object  // Column object
  local lRetval := pFALSE   as logical // Return value .t. if activite
  local nCount              as int     // for the FOR...NEXT loop
  local nCursor             as int     // Save cursor status as needed
  local nCurstat            as int     // Initial cursor status
  local nKey                as int     // User key
  local aStru               as array   // Structre of database
  local oTemp               as object  // Tmp object
  local lModified := pFALSE as logical // whether database structure modified
  local aEnviron := ActiveArea()           as array
  local nActive := aEnviron[2]             as int
  local aMembers := aEnviron[1]            as array
  local aWin := aMembers[nActive,pWIN_ELE] as array
  local cDrive                             as char
  local cSearch                            as char

  if !(DictAt(atail(aMembers),"FullScreen"))

    if valtype(aMembers[nActive,pOBJ_ELE]) <> "U"
      Errorbeep()
      PressKeyMsg({{" To create a database, use an empty area "}})

    else

     begin sequence
     cSearch := DictAt(atail(aMembers),"Search")
     cDrive  := DictAt(atail(aMembers),"Drive")

     cScreen := savescreen(aWin[1],aWin[2], aWin[3],aWin[4])
     nCurstat := setcursor()
     scroll(aWin[1],aWin[2], aWin[3],aWin[4])

     // here, we create an empty file
     dbcreate("NEW$$$",;
              { {"FIELD_NAME","C",10,0}, {"FIELD_TYPE","C",1,0},;
                {"FIELD_LEN","N",3,0}, {"FIELD_DEC","N",3,0}  })

     use NEW$$$ new ALIAS TEMP

     // create Tbrowse
     oObject := TBrowseDB(aWin[1],aWin[2],aWin[3],aWin[4])


     // Show record number, call it "Fld #"
     oColumn := tbcolumnnew( "Fld #", {|| transform(recno(),"999")} )
     oObject:addcolumn(oColumn)

     oColumn := tbcolumnnew("Name",fieldwblock("FIELD_NAME", select()))
     oColumn:width := 10
     oObject:addcolumn(oColumn)

     oColumn := tbcolumnnew("Type",fieldwblock("FIELD_TYPE", select()))
     oColumn:width := 4
     oObject:addcolumn(oColumn)

     oColumn := tbcolumnnew("Len",fieldwblock("FIELD_LEN", select()))
     oColumn:width := 3
     oObject:addcolumn(oColumn)

     oColumn := tbcolumnnew("Dec",fieldwblock("FIELD_DEC", select()))
     oColumn:width := 3
     oObject:addcolumn(oColumn)

     // Freeze left most (Field Number) column at the left
     oObject:freeze := 1

     // Set skip block
     oObject:skipblock := { |n| Dbmodskip(n, APPEND_MODE_STATUS(oObject)) }

     setcursor(pCURSOR_OFF)

     // Display keys
     scroll(maxrow()-1,0,maxrow(),maxcol())
     DispMessage("Arrow keys to move, RETURN edits, F10 Saves, ESC aborts")

     // Set cargo to hold that we are in APPEND mode
     APPEND_MODE_ON(oObject)

     // Set initial status
     keyboard(chr(pENTER))

     // Main loop
     PROCESS

       // Don't let the cursor move into the first col
       if oObject:colpos == 1
         do case
         case lastkey() == pLEFT_ARROW
           oObject:panend()
         case lastkey() == pRIGHT_ARROW
           oObject:right()
         otherwise
           oObject:colpos := oObject:freeze + 1
         endcase
       endif

       // stabilize the display until it's stable or a key is pressed
       nkey := 0
       while nkey == 0 .and. !(oObject:stable)

         oObject:stabilize()
         nkey := inkey()

       enddo

       if oObject:stable
         // Handle case where user at top/bottom, and pressed up/down

         if oObject:hitbottom .and. !(APPEND_MODE_STATUS(oObject))
           // banged against eof, not already in append
           // mode, so go into append mode
           clear typeahead
           APPEND_MODE_ON(oObject)
           oObject:home()
           oObject:down()
           nKey := pENTER
           oObject:forceStable()

         else
           do case
           case oObject:hittop .and. ISWRAP()
             oObject:gobottom()
             oObject:forceStable()

           case oObject:hitbottom .and. ISWRAP()
             // Here, we were at eof(), and user pressed a DOWN button
             // again.  Check to see if we were on phantom record, and
             // if so, refresh.
             oObject:gotop()
             if APPEND_MODE_STATUS(oObject)
                 APPEND_MODE_OFF(oObject)
                 oObject:refreshall()
             endif
             oObject:forceStable()

           endcase

           // everything's adjusted and stable, get another key
           nkey := inkey(0)

         endif

       endif

       do case
       case nkey == pESC
         exit
       case nKey == pF10
         exit
       case nKey == pDOWN_ARROW
         oObject:down()
       case nKey == pPGDN
         oObject:pageDown()
       case nKey == pCTRL_PGDN
         oObject:goBottom()
       case nKey == pUP_ARROW
         oObject:up()
       case nKey == pPGUP
         oObject:pageUp()
       case nKey == pCTRL_PGUP
         oObject:goTop()
       case nKey == pRIGHT_ARROW
         if oObject:colpos == 5
           oObject:panhome()
         else
           oObject:right()
         endif
       case nKey == pLEFT_ARROW
         oObject:left()
       case nKey == pHOME
         oObject:home()
       case nKey == pEND
         oObject:end()
       case nKey == pCTRL_LEFT_ARROW
         oObject:panleft()
       case nKey == pCTRL_RIGHT_ARROW
         oObject:panright()
       case nKey == pCTRL_HOME
         oObject:panhome()
       case nKey == pCTRL_END
         oObject:panend()
       case nKey == pENTER
         // Get the field, and set lModified
         lModified := if(Getval(oObject),pTRUE,lModified)
       otherwise
         // assume they want to enter, keyboard their key
         keyboard chr(nKey)
         lModified := if(Getval(oObject),pTRUE,lModified)

       endcase

     END PROCESS

     if lModified .and. lastkey() != pESC
       // Now get rid of the temp file, and create the file we need
       dbgotop()
       dbcommitall()
       aStru := {}
       for nCount := 1 to reccount()
         if !empty(FIELD_NAME) .and. ;
           !empty(FIELD_TYPE) .and. !empty(FIELD_LEN)
            aadd(aStru,{FIELD_NAME, FIELD_TYPE, FIELD_LEN, FIELD_DEC})
         endif
         skip
       next
       if empty(aStru)
         // oops - no fields!
         PressKeyMsg({{" Fields not properly defined! "}})
         dbclosearea()
         ferase("NEW$$$.dbf")
         break
       endif
       // Close the temporary structure extended file
       dbclosearea()
       // get the file name
       cFilename := space(8)
       DispMessage("Enter File name: ")
       @ row(), col() get cFilename pict "@!" ;
         valid Chkfile(cDrive+cSearch+trim(cFilename)+".dbf")
       read
       if lastkey() != pESC
          dbcreate( cDrive + cSearch + trim(cFilename), aStru )
       endif
       DispMessage( "" )
     else
       dbclosearea()
     endif
     end sequence

     if file("NEW$$$.dbf")
       ferase("NEW$$$.dbf")
     endif
     setcursor(nCurstat)
     restscreen(aWin[1],aWin[2],aWin[3],aWin[4],cScreen)
     select(nActive)
     scroll(maxrow()-1,0,maxrow(),maxcol())
    endif
  endif

  VOID

/* Function Getval
   --------------------------------------
   Syntax:  Getval(<oObject>)
   Returns: NIL
   Notes:   Used to get a value for a field

            oObject     Object we are browsing

            Design for this function is based on code by
            Nantucket.

*/
function Getval(oObject)

    local bIns                as block
    local lScore              as logical
    local lExit               as logical
    local nCol                as int
    local oCol                as object
    local xGet                as usual
    local nKey                as int
    local lAppend             as logical
    local lModified := pFALSE as logical
    local cScreen             as char

    // Make sure screen is fully updated, dbf position is correct, etc.
    oObject:forceStable()

    // Save global state
    lScore := set(pSCOREBOARD, pFALSE)
    lExit := set(pEXIT, pTRUE)
    bIns := setkey(pINS)
    cScreen := savescreen(maxrow()-1,0,maxrow(),maxcol())

    // Set insert key to toggle insert mode and cursor shape
    setkey( pINS, {|| Instoggle()} )

    // Set initial cursor shape
    setcursor( if(readinsert(), pCURSOR_BLOCK, pCURSOR_ON ) )

    // Get the current column object from the browse
    nCol := oObject:colPos
    oCol := oObject:getcolumn(nCol)

    // Create a corresponding var
    xGet := eval(oCol:block)

    lAppend := APPEND_MODE_STATUS(oObject)

    do case
    case nCol == 2  // Name
      @ row(), col() get xGet pict "!!!!!!!!!!" valid ChkName(xGet)
    case nCol == 3  // Type
      @ row(), col() get xGet pict "!" valid xGet $ "CDNLM"
    case nCol == 4  // Length
      @ row(), col() get xGet pict "999" valid xGet > 0 .and. xGet <= 999
    case nCol == 5  // Dec
      @ row(), col() get xGet pict "99" valid xGet >= 0 .and. xGet <= 15
    endcase

    scroll(maxrow()-1,0,maxrow(),maxcol())
    DispMessage("Enter field contents, ESC aborts")
    setcursor(pCURSOR_ON)
    read
    setcursor(pCURSOR_OFF)
    restscreen(maxrow()-1,0,maxrow(),maxcol(),cScreen)

    nKey := lastkey()  // Exit key from get
    if updated()
      lModified := pTRUE
      // If confirming a new record, do the physical append
      if lAppend .and. recno() == lastrec() + 1
        append blank
      endif
      // replace the value
      eval(oCol:block,xGet)
      oObject:refreshcurrent()
    else
      // Fields not updated.  If we are in append mode,
      // then force a key.  If first field created, then simply
      // cycle through again by forcing a DOWN.  Else, turn
      // off append mode by forcing UP
      if lAppend .and. (nKey == pENTER .or. nKey == pESC)
        if lastrec() > 0
          nKey := pUP_ARROW
        else
          nKey := pESC
          keyboard( chr(pESC) )
        endif
      endif
    endif

    set(pSCOREBOARD, lScore)
    set(pEXIT, lExit)
    setkey(pINS, bIns)

    // Handle certain keystrokes that leave the read here
    do case
    case nKey == pUP_ARROW
      oObject:up()
      oObject:refreshall()
    case nKey == pPGUP
      oObject:pageup()
      oObject:refreshall()
    case nKey == pDOWN_ARROW
      oObject:down()
    case nKey == pPGDN
      oObject:Pagedown()
    endcase

    // we turn append mode off after each new record
    APPEND_MODE_OFF(oObject)

    return( lModified )

/* Function ChkName
   --------------------------------------
   Syntax:  Chkname(<cName>)
   Returns: .t. if field name is ok, .f. if not
   Notes:   Used to check for duplicate field names when creating .dbf

*/
function ChkName(cName)

  local nRecno := recno() as int
  local lRetval := pTRUE  as logical

  if empty(cName)
    if !(lastkey() == pESC)
      Errorbeep()
      PressKeyMsg({{" Can't leave the field empty! "}})
      lRetval := pFALSE
    endif
  else
    // Appending new fields.  If first one, don't bother, else check
    // the name with existing fields
    if lastrec() > 0
      locate for FIELD_NAME == padr(cName,10)
      while !eof()
        if found()
          if recno() != nRecno
            errorbeep()
            PressKeyMsg({{" Field name already entered! "}})
            lRetval := pFALSE
            exit
          else
            continue
          endif
        endif
      enddo
      goto nRecno
    endif
  endif

  return( lRetval )

/* Function Dbmodskip
   --------------------------------------
   Syntax:  Dbmodskip(<nNum2skip>,<lStatus>)
   Returns: Number of rows skipped
   Notes:   Used to skip through object

            nNum2skip   The number of rows to skip
            lStatus     Whether we are in append mode

            Design for this function is based on code by
            Nantucket.
*/
function Dbmodskip(nNum2skip,lStatus)

  local i := 0  as int

  do case
  case nNum2skip == 0 .or. lastrec() == 0

    // opportunity to flush buffers
    skip 0

  case nNum2skip > 0 .and. (recno() != lastrec() + 1)
    // Not on ghost record - skip forward

    while i < nNum2skip
      skip 1
      if eof()
        // We can quit
        if lstatus
          // if in append mode, increase i so we are 1 past lastrec()
          // in internal counter
          i++
        else
          // if no append mode, don't activate ghost record
          skip -1
        endif
        exit
      endif

      i++
    enddo

  case nNum2skip < 0

    // Skip backward
    while i > nNum2skip
      skip -1
      if bof()
        exit
      endif

      i--
    enddo

  endcase

  return( i )

/* Function Chkfile
   --------------------------------------
   Syntax:  Chkfile(<cFile>)
   Returns: .t. if file not found, .f. if it is
   Notes:   Used to check for duplicate file names when creating .dbf

*/
function Chkfile(cFile)

  local lRetval := pTRUE as logical

  if file(cFile)
    Errorbeep()
    lRetval :=  YNMsg({{" File already exists.  Create anyway? "}})
  endif

  return(lRetval)

#undef APPEND_MODE_ON
#undef APPEND_MODE_OFF
#undef APPEND_MODE_STATUS

/* Function CreateIndex
   --------------------------------------
   Syntax:  CreateIndex()
   Returns: NIL
   Notes:   Creates a new index for the current area
*/
function CreateIndex()

   local cCondition := space(250)                                    as char
   local cScreen1   := savescreen( maxrow(), 0, maxrow(), maxcol() ) as char
   local cScreen2   := savescreen( maxrow()-1,0,maxrow()-1,maxcol()) as char
   local cFilename  := space(40)                                     as char
   local cTemp                                                       as char
   local aEnviron   := ActiveArea()                                  as array
   local aMembers   := aEnviron[1]                                   as array
   local nActive    := aEnviron[2]                                   as int
   local cDrive                                                      as char
   local cSearch                                                     as char
   local aFields    := {}                                            as array
   local oError                                                      as object
   local bOlderror                                                   as block

   // grab old error block, post new
   bOlderror := errorblock({|oError| break(oError)})
   begin sequence
   scroll( maxrow()-1, 0, maxrow()-1, maxcol() )
   if empty( alias(nActive) )
     ErrorMessage( "No database is open." )
     break
   endif
   cSearch := DictAt(atail(aMembers),"Search")
   cDrive  := DictAt(atail(aMembers),"Drive")

   // Get the fields
   aeval(dbstruct(),{|aEle| aadd(aFields,padr(aEle[DBS_NAME],12)+;
                                         padr(aEle[DBS_TYPE],3)+;
                                         padr(str(aEle[DBS_LEN],3),5)+;
                                         str(aEle[DBS_DEC],3)) })

   ShowTab(maxrow(),8,space(24))  // Sets up ShowTab() after entry
   @ maxrow()-1, 0 say "Enter index expression:" ;
                   get cCondition ;
               when ShowTab(maxrow(),8,padr("Press TAB to list fields",24)) ;
                   picture "@S50" ;
                   valid ( cTemp := trim(cCondition),;
                           CondChk(cTemp,aFields,pTRUE)  ) ;
                   send reader := {|oGet|DBPReader(oGet)}

   read
   if lastkey() != pESC
     ShowTab()
     scroll( maxrow()-1, 0, maxrow()-1, maxcol() )
     @ maxrow()-1, 0 say "Enter file name: " get cFilename ;
                                           pict "@!" ;
                                           valid !empty(cFilename)
     read
     if lastkey() != pESC
       cCondition := trim( cCondition )

       index on &( cCondition ) TO ( cDrive + cSearch + trim( cFilename ) )
       if !YNMsg({ {" Do you want this in use now? "}})
         dbclearindex()
       else
         (aMembers[nActive,pOBJ_ELE]):gotop()
         (aMembers[nActive,pOBJ_ELE]):refreshall()
       endif
     endif
   else
     ShowTab()
   endif

   recover using oError
     if valtype(oError) == "O"
       Errorbeep()
       ShowGenError(oError)
     endif
   end sequence
   errorblock(bOlderror)
   CLEARESC()

   restscreen( maxrow(),0,maxrow(),maxcol(), cScreen1 )
   restscreen( maxrow()-1,0,maxrow()-1,maxcol(), cScreen2 )

   VOID

// End of File: DBPMake.prg

DBPMod.prg

/* File              DBPMOD.prg
   Notice            Copyright(c) 1991-1994 Sirius Software Development, Inc. 
                     All Rights Reserved
   Author            Steve Straley

*/
#define CLIPPER

#include "PTFuncs.ch"
#include "PTValue.ch"
#include "PTInkey.ch"
#include "PTVerbs.ch"
#include "PTColor.ch"

#include "FILEIO.ch"
#include "DBSTRUCT.ch"
#include "DIRECTRY.ch"
#include "ERROR.ch"

#define  pOBJ_ELE   1          // TBROWSE element slot
#define  pALIAS_ELE 2          // Alias name slot
#define  pFILE_ELE  3          // Full path and file name slot
#define  pOBJ_TYPE  4          // Type of file slot
#define  pWIN_ELE   5          // Array of window coordinates
#define  pSELECT_BOX   1       // Code to select a box
#define  pUNSELECT_BOX 2       // Code to de-hilite a box
memvar getlist
/* Function AddRecord
   --------------------------------------
   Syntax:  AddRecord
   Returns: NIL
   Notes:   Appends a record to the database, allows entry

*/
function AddRecord()

  local cScreen := savescreen()  as char
  local nRow                     as int
  local nStart                   as int
  local nCount                   as int
  local nEnd                     as int
  local aValues                  as array  // Array for field values
  local aEnviron := ActiveArea() as array
  local aMembers := aEnviron[1]  as array
  local nActive  := aEnviron[2]  as int

  if empty( alias() )
    ErrorMessage( "No database is open!" )
  else
    cls
    aValues := GetRecord( 0 )  // init with blanks

    nStart := 1
    nRow   := 1

    REPEAT

      nEnd := if( (nStart + (maxrow() - 2)) > fcount(), ;
                  fcount(), (nStart + (maxrow() - 2)) )
      for nCount := nStart TO nEnd
        if dbstruct()[nCount, DBS_TYPE] != "M"
          @ nRow++, 1 say padl(field(nCount),10) + ": " ;
                      get aValues[nCount] picture "@S50"
        endif
      next
      read
      if lastkey() != pESC
        nStart := nCount
        cls
        nRow := 1
      endif

    UNTIL ( nStart > fcount() .or. lastkey() == pESC )

    if lastkey() != pESC
      dbappend()
      PutRecord( recno(), ,, aValues )
      (aMembers[nActive,pOBJ_ELE]):refreshall()
    endif

  endif

  restscreen(,,,, cScreen )
  CLEARESC()

  VOID

/* Function EditRecord
   --------------------------------------
   Syntax:  EditRecord()
   Returns: NIL
   Notes:   Allows full screen edit of a record
*/
function EditRecord()

  local cScreen := savescreen()  as char
  local nRow                     as int
  local nStart                   as int
  local nCount                   as int
  local nEnd                     as int
  local aValues                  as array  // Field values in current record
  local aEnviron := ActiveArea() as array
  local aMembers := aEnviron[1]  as array
  local nActive  := aEnviron[2]  as int

  if empty( alias() )
    ErrorMessage( "No database is open!" )
  else
    cls
    aValues := GetRecord( recno() )  // stuff values into array

    nStart := 1
    nRow   := 1

    REPEAT

      nEnd := if( (nStart + (maxrow() - 2)) > fcount(), ;
                  fcount(), (nStart + (maxrow() - 2)) )
      for nCount := nStart TO nEnd
        if dbstruct()[nCount, DBS_TYPE] != "M"
          @ nRow++, 1 say padl(field(nCount),10) say ": " ;
                      get aValues[nCount] picture "@S50"
        endif
      next
      read
      if lastkey() != pESC
        nStart := nCount
        cls
        nRow := 1
      endif

    UNTIL ( nStart > fcount() .or. lastkey() == pESC )

    if lastkey() != pESC
      // replace values into fields
      PutRecord( recno(),,,aValues )
      (aMembers[nActive,pOBJ_ELE]):refreshall()
    endif

  endif

  restscreen(,,,,cScreen )
  CLEARESC()

  VOID

/* Function DelRecord
   --------------------------------------
   Syntax:  DelRecord(<lDelete>)
   Returns: NIL
   Notes:   Deletes/undeletes record based on status of lDelete

*/
function DelRecord(lDelete)

  local aEnviron    as array
  local nActive     as int
  local oObject     as object
  local cTag        as char
  local cScreen     as char     // Screen save var
  local cScopecond  as char     // NEXT n records text
  local cOldScope   as char     // Holds current scope condition
  local nNextrec    as int      // Actual number
  local xWhilecond  as usual    // WHILE condition
  local xForcond    as usual    // FOR condition
  local xTemp       as usual    // Temp variable of varying types
  local cColor      as char     // Color for box
  local cInv        as char     // Color for inverse
  local cShadow     as char     // Shadow attribute
  local nPrompt     as int      // MENU.. TO
  local aFieldinfo  as array    // Holds fields info - this .dbf
  local aFields     as array    // Field info as one string
  local lRetval     as logical  // Return value
  local cOldcolor   as char     // Current color setting
  local nCount      as int
  local nCursor     as int
  local bOlderror   as block    // Posted error block
  local oError      as object

  DEFAULT lDelete TO pTRUE

  cTag := if(lDelete,"DELETE","RECALL")

  aEnviron  := ActiveArea()
  nActive   := aEnviron[2]
  oObject   := aEnviron[1,nActive,pOBJ_ELE]
  cScreen   := savescreen()
  nCursor   := setcursor()
  lRetval   := pTRUE
  cColor    := ColorCentral("Menu")
  cInv      := ColorCentral("Inverse")
  cShadow   := ColorCentral("Shadow")
  cOldcolor := setcolor()

  bOlderror := errorblock({|oError| break(oError)})
  begin sequence

  if empty( alias() )
    ErrorMessage( "No database is available." )
    break
  endif

  // Make sure file is not empty
  if eof() .or. bof()
    Errorbeep()
    PressKeyMsg({{" No records to "+cTag+"."}})
    break
  endif

  // If the delete key pressed, assume they want to delete the one
  // record
  if lastkey() == pDEL
    if( !deleted(), dbdelete(), dbrecall() )
    oObject:refreshCurrent()
    oObject:down()
    break
  endif

  // Get field info for constructing boolean phrases
  aFieldinfo := dbstruct()
  aFields    := {}
  aeval(aFieldinfo,{|aEle| ;
        aadd(aFields,padr(aEle[DBS_NAME],12)+padr(aEle[DBS_TYPE],3)+;
                     padr(str(aEle[DBS_LEN],3),5)+str(aEle[DBS_DEC],3)) })

  scroll( maxrow()-1, 0, maxrow(), maxcol() )
  setcolor(cColor)

  // Create BOX
  scroll(4,5,21,77)
  dispbox( 4,5,21,77, pSDBAR)
  Newcolor(22,6,22,78,cShadow)   // Shadow
  Newcolor(5,78,22,78,cShadow)   // Shadow
  @  5,8 say cTag

  @  9,8 say "Scope:"
  @ 11,8 say "While:"
  @ 13,8 say "For:"
  @ 18,8 say "Finished"

  cScopecond := "Next: 1"
  xWhilecond := space(240)
  xForcond   := space(240)

  nPrompt := 4
  setcursor(pCURSOR_ON)

  PROCESS
    @  9,15 say padr(cScopecond,60)
    @ 11,15 say substr(xWhilecond,1,60)
    @ 13,15 say substr(xForcond,1,60)
    @ 20,8 say "Up/Down arrow keys, Enter for choice, ESC aborts" color cInv
    @  9,8 prompt "Scope:"
    @ 11,8 prompt "While:"
    @ 13,8 prompt "For:"
    @ 18,8 prompt "Finished"
    menu to nPrompt
    ShowTab(10,8,space(24))  // Sets up ShowTab() after CASE construct
    do case

    case nPrompt == 0
      lRetval := pFALSE
      ShowTab()
      break

    case nPrompt == 1
      cOldScope := cScopecond
      if YNMsg({ {" Do you want ALL records? "},2 })
        cScopecond := "ALL"
      elseif lastkey() != pESC
        cScopecond := 1
        @ 9,15 say "Next:" get cScopecond ;
                           pict "9999999" ;
                           valid cScopecond > 0
        read
        if !(lastkey() == pESC)
          cScopecond := "Next: "+str(cScopecond)
        else
          cScopecond := cOldScope
        endif
      endif

    case nPrompt == 2
      @ 11,15 get xWhilecond ;
                  picture "@S60" ;
                  when ShowTab(12,8,padr("Press TAB to list fields",24)) ;
                  valid CondChk(xWhilecond,aFields) ;
                  send reader := {|oGet|DBPReader(oGet)}
      read

    case nPrompt == 3
      @ 13,15 get xForcond ;
                  picture "@S60" ;
                  when ShowTab(14,8,padr("Press TAB to list fields",24)) ;
                  valid CondChk(xForcond,aFields) ;
                  send reader := {|oGet|DBPReader(oGet)}
      read

    case nPrompt == 4
      ShowTab()
      exit

    endcase
    ShowTab()  // Gets rid of last tab setting

  END PROCESS
  setcursor(pCURSOR_OFF)

  @ 20,8 say "                                                "
  if lastkey() == pESC
    break
  endif
  // Create the WHILE block
  if empty(xWhilecond)
    xWhilecond := {||pTRUE}
  else
    xTemp := "{||"+xWhilecond+"}"
    xWhilecond := &(xTemp)
  endif

  // Create the FOR block
  if empty(xForcond)
    xForcond := {||pTRUE}
  else
    xTemp := "{||"+xForcond+"}"
    xForcond := &(xTemp)
  endif

  // store values
  WaitMsg(pTRUE)
  nNextrec := val(substr(cScopecond,7))
  @ 20,8 say "Records Processed: "
  nCount := 1
  if cScopecond == "ALL"
    dbeval({|| if( lDelete, dbdelete(), dbrecall() ),;
                            devpos(20,27),devout(nCount++)},;
                            xForcond,xWhilecond)
  else
    dbeval({|| if( lDelete, dbdelete(), dbrecall() ),;
                            devpos(20,27),devout(nCount++)},;
                            xForcond,xWhilecond,nNextrec)
  endif
  oObject:refreshall()
  oObject:down()
  WaitMsg(pFALSE)

  recover using oError
    WaitMsg(pFALSE)
    setcolor(cOldcolor)
    IF oError IS pOBJECT
      ShowGenError(oError)
    endif

  end sequence
  setcolor(cOldcolor)
  errorblock(bOlderror)

  restscreen(,,,,cScreen)
  CLEARESC()

  setcursor(nCursor)

  VOID

/* Function Packfiles
   --------------------------------------
   Syntax:  Packfiles()
   Returns: NIL
   Notes:   Packs the open database

*/
function PackFiles()

  local aEnviron := ActiveArea()                  as array
  local nActive  := aEnviron[2]                   as int
  local oObject  := aEnviron[1,nActive,pOBJ_ELE]  as object

  if empty( alias() )
    ErrorMessage( "You can only pack with a DATABASE open and active." )
  else
    if YNMsg({ {"Do you really want to pack the file? "}})
      WaitMsg(pTRUE)
      pack
      WaitMsg(pFALSE)
      Errorbeep()
      PressKeyMsg({ {" Operation completed! "}})
      oObject:refreshall()
      oObject:gotop()

    endif
  endif

  return( pTRUE )

/* Function ZapFiles
   --------------------------------------
   Syntax:  Zapfiles()
   Returns: NIL
   Notes:   Zaps the open database

*/
function ZapFiles()

  local aEnviron := ActiveArea()                 as array
  local nActive := aEnviron[2]                   as int
  local oObject := aEnviron[1,nActive,pOBJ_ELE]  as object

  if empty( alias() )
    ErrorMessage( "You can only zap with a DATABASE open and active." )
  else
    if YNMsg({ {"Do you really want to ZAP the file? "}})
      zap
      oObject:refreshall()
      oObject:gotop()
    endif
  endif

  return( pTRUE )

/* Function ModStru
   --------------------------------------
   Syntax:  ModStru()
   Returns: NIL
   Notes:   Allows structure of database to be modified

*/
function ModStru()

  local cScreen := savescreen() as char     // Screen save
  local oObject                 as object   // Object to browse
  local nPointer := 1           as int      // Current line we are on
  local nKey                    as int      // Keystroke
  local lModified := pFALSE     as logical  // Whether structure is modified
  local xVar                    as usual    // Value to edit
  local oTemp                   as object   // Temporary .dbf browser
  local oColumn                 as object   // TBColumn var
  local cSubscreen              as char     // Screen save var
  local aStru                   as array    // Array of database structure
  local cName                   as char     // Name of field
  local cType                   as char     // Type of field
  local cLength                 as char     // Length of field
  local nDecimals               as int      // Decimals in field
  local nSkipval                as int      // Holds skip qty
  local nCount                  as int
  local nBottrow := 18          as int      // Bottom row of browse window
  local aEnviron := ActiveArea()           as array
  local aMembers := aEnviron[1]            as array
  local nActive := aEnviron[2]             as int
  local aWin := aMembers[nActive,pWIN_ELE] as array

  if empty( alias() )
    ErrorMessage( "No database is open to MODIFY." )
  else
    aStru := dbstruct()
    dispbox(6,15,19,65, pDBAR)
    scroll(maxrow()-1,0,maxrow(),maxcol())
    DispMessage(" Modify Structure: " + trim(alias()) +;
                "   F10 Saves, INS Inserts, DEL Deletes")
    oObject := tbrowsenew(7,16,18,64)
    oObject:skipblock     := {|n| nSkipval := Askip(n, nPointer,;
                              len(aStru)), nPointer+= nSkipval, nSkipval }
    oObject:goTopBlock    := {|| nPointer := 1}
    oObject:goBottomBlock := {|| nPointer := len( aStru )}
    oObject:headSep := chr(205)
    oObject:colPos := 2
    oColumn := tbcolumnnew( "Fld", {|| transform(nPointer, "999") } )
    oObject:addColumn( oColumn )
    oColumn := tbcolumnnew( "Name",{|| aStru[nPointer,DBS_NAME]} )
    oColumn:width := 12
    oObject:addColumn( oColumn )
    oColumn := tbcolumnnew( "Type",{|| aStru[nPointer,DBS_TYPE]} )
    oColumn:width := 4
    oObject:addColumn( oColumn )
    oColumn := tbcolumnnew( "Len",;
               {|| transform(aStru[nPointer,DBS_LEN],"999")} )
    oColumn:width := 3
    oObject:addColumn( oColumn )
    oColumn := tbcolumnnew( "Dec",;
               {|| transform(aStru[nPointer,DBS_DEC],"99")} )
    oColumn:width := 3
    oObject:addColumn( oColumn )

    REPEAT

      oObject:forceStable()

      nKey := inkey(0)
      do case
      case ( nkey == pDOWN_ARROW ) .and. (nPointer <> len(aStru) )
        oObject:down()
      case ( nKey == pUP_ARROW )
        oObject:up()
      case ( nKey == pEND )
        oObject:gobottom()
      case ( nKey == pPGUP )
        oObject:pageUp()
      case ( nKey == pPGDN )
        oObject:pageDown()
      case ( nKey == pHOME )
        oObject:gotop()
      case nKey == pRIGHT_ARROW
        oObject:right()
      case nKey == pLEFT_ARROW
        if oObject:colPos != 2
           oObject:left()
        endif

      case nKey == pENTER
        xVar := aStru[nPointer,oObject:colPos-1]
        do case
        case oObject:colPos = 2
          // valid checks to see if name is present, and if so, is
          // NOT the row we are on.
          xVar := padr(xVar, 10)
          @ row(), col() get xVar picture "!!!!!!!!!!" ;
            valid !empty( xVar ) .and. ;
            if( ;
               (nCount:= ascan(aStru, {|x| trim(x[1]) == trim(xVar)})) >0,;
               nCount == nPointer,pTRUE )

        case oObject:colPos = 3
           xVar := padr(xVar, 1)
           @ row(), col() get xVar picture "!" valid xVar $ "CDNLM"

        case oObject:colPos = 4
          @ row(), col() get xVar picture "999" valid ;
                                  xVar > 0 .and. xVar <= 999

        otherwise
          @ row(), col() get xVar picture "99" valid ;
                                  xVar >= 0 .and. xVar <= 15

        endcase
        read
        if lastkey() != pESC
          lModified := pTRUE
          aStru[nPointer,oObject:colPos-1] := xVar
          oObject:refreshcurrent()
        else
          CLEARESC()
        endif

      case nKey == pDEL
        if len(aStru) == 1
          Errorbeep()
          PressKeyMsg({{" May not delete the last field! "}})
        else
          if YNMsg({ {"Are you sure you want to delete this field? "}})
            adel( aStru, nPointer )
            asize( aStru, len(aStru)-1 )
            oObject:refreshall()
            lModified := pTRUE
          endif
        endif
      case (nKey == pINS) .or. ;
           (nKey == pDOWN_ARROW .and. nPointer == len(aStru) )
        cSubscreen := savescreen( oObject:nTop, oObject:nLeft,;
                                  oObject:nBottom, oObject:nRight )
        oObject:dehilite()

        do case
        case nKey == pINS
          // We split the window
          scroll(row(), oObject:nleft, nBottrow, oObject:nright, -1)
        case row() == nBottrow
          scroll( 10, oObject:nleft, nBottrow, oObject:nright, 1 )
          nPointer++
        otherwise
          devpos(row() + 1,0)
        endcase

        cName := space(10)
        cType := space(1)
        cLength := nDecimals := 0

        @ row(), oObject:nLeft + 14 get cName ;    
          picture "@K !!!!!!!!!!" ;
          valid !empty( cName ) .and. ;
          empty( ascan(aStru, {|x| trim(x[1]) == trim(cName)}) )
        @ row(), oObject:nLeft + 27 get cType     ;
          picture "!" valid cType $ "CDNLM"
        @ row(), oObject:nLeft + 33 get cLength   ;
          picture "999" ;
          valid cLength > 0 .and. cLength <= 999
        @ row(), oObject:nLeft + 37 get nDecimals ;
          picture "99" ;
          valid nDecimals >= 0 .and. nDecimals <= 99
        read
        if lastkey() != pESC
          lModified := pTRUE
          asize( aStru, len(aStru)+1)
          // If the user pressed the down arrow and we are NOT at the
          // bottom row, we are adding to the bottom
          if nKey == pINS
            ains(aStru, nPointer)
            aStru[nPointer] := {cName, cType, cLength, nDecimals}
          else
            aStru[len(aStru)] := {cName, cType, cLength, nDecimals}
            oObject:down()
          endif
          oObject:refreshall()
        else
          restscreen( oObject:ntop, oObject:nleft,;
                      oObject:nbottom, oObject:nright, cSubscreen )
          CLEARESC()
          if nKey == pDOWN_ARROW
            nPointer--
          endif
        endif

      case nKey == pF1
        cSubscreen := savescreen( oObject:ntop-1, oObject:nleft-1,;
                               oObject:nbottom+1, oObject:nright+1 )
        dispbox( oObject:ntop-1, oObject:nleft-1,;
                 oObject:nbottom+1, oObject:nright+1 , pSBAR )
        @ oObject:ntop-1, oObject:nleft+1 ;
          say " Modify Structure Help Screen "

        @ oObject:ntop+1,  oObject:nleft+1 say "F1    - This screen"
        @ oObject:ntop+2,  oObject:nleft+1 ; 
          say "ENTER - Edit Field Information"
        @ oObject:ntop+3,  oObject:nleft+1 ; 
          say "DEL   - Delete a Field Deffinition"
        @ oObject:ntop+4,  oObject:nleft+1 ; 
          say "INS   - Insert a Field Deffinition"
        @ oObject:ntop+5,  oObject:nleft+1 ;
          say "F10   - Exit a save all changes"
        @ oObject:ntop+6,  oObject:nleft+1 ; 
          say "ESC   - Exit without saving changes"
        @ oObject:ntop+7,  oObject:nleft+1 ; 
          say "        All other cursor keys act"
        @ oObject:ntop+8,  oObject:nleft+1 ;
          say "        as expected."
        @ oObject:ntop+10, oObject:nleft+1 say "Any key to continue."
        inkey(0)
        CLEARESC()
        restscreen( oObject:ntop-1, oObject:nleft-1, ;
                    oObject:nbottom+1, oObject:nright+1, cSubscreen )

      case nKey == pF10
         exit

      endcase

    UNTIL (lastkey() = pESC)

    if lModified .and. lastkey() != pESC
      dbcommitall()
      DispMessage( " One Moment Please!!! " )
      dbcreate( "New$$$", aStru )
      dbclosearea()
      use new$$$ alias TEMP
      append from (aMembers[nActive,pFILE_ELE])
      ferase( aMembers[nActive,pFILE_ELE] )
      dbclosearea()
      CopyFile( "NEW$$$.DBF", aMembers[nActive,pFILE_ELE] )
      ferase("NEW$$$.DBF")
      if file("NEW$$$.DBT")
        COPYFILE( "NEW$$$.DBT", ;
                  RootName( aMembers[nActive,pFILE_ELE] )+".dbt" )
        ferase("NEW$$$.DBT")
      endif
      use ( aMembers[nActive,pFILE_ELE] ) ALIAS ;
         &( trim(aMembers[nActive,pALIAS_ELE]) )
      oTemp   := tbrowsedb(aWin[1], aWin[2], aWin[3], aWin[4])
      oColumn := tbcolumnnew( " ", {|| if( DELETED(), chr(16), chr(32) )} )
      oColumn:width := 1
      oTemp:addColumn( oColumn )
      oColumn := tbcolumnnew( "#", {|| str(recno(),5)} )
      oColumn:width := 5
      oTemp:addColumn( oColumn )
      for nCount := 1 to fcount()
         oTemp:addColumn( tbcolumnnew( field(nCount),;
         if( valtype( fieldget(nCount) ) == pMEMO, {|| "<<Memo>>"},;
         fieldwblock( fieldname(nCount), select() ) ) ) )
      next
      aMembers[nActive,pOBJ_ELE] := oTemp               // The object itself
      (aMembers[nActive,pOBJ_ELE]):refreshall()
      (aMembers[nActive,pOBJ_ELE]):gotop()
      (aMembers[nActive,pOBJ_ELE]):freeze := 1
      DispMessage( "" )
    endif
    scroll(maxrow()-1,0,maxrow(),maxcol())
  endif

  CLEARESC()
  restscreen(,,,,cScreen )

  VOID

/* Function Modfield
   --------------------------------------
   Syntax:  Modfield()
   Returns: NIL
   Notes:   Allows fields to be edited
*/
function ModField

  local xValue                      as usual  // Variable to edit
  local cScreen  := savescreen()    as char   // Screen save var
  local nPosition                   as int    // Position in Tbrowse for curs
  local cObjtype                    as char   // What kind of file?
  local aEnviron := ActiveArea()               as array
  local aMembers := aEnviron[1]                as array
  local nActive  := aEnviron[2]                as int
  local oObject  := aMembers[nActive,pOBJ_ELE] as object
  local aTemp                                  as array
  local bOlderror                              as block
  local oError                                 as object

  bOlderror := errorblock({|oError| break(oError)})
  begin sequence

  if (cObjtype := aMembers[nActive,pOBJ_TYPE]) == NIL
    ErrorMessage("No file open in area!")
    break
  endif

  if cObjtype == "DBFFILE" .or. cObjtype == "MEMFILE"
    if oObject:colpos < 3
      Errorbeep()
      PressKeyMsg({{" You can edit only data."}})
      break
    endif
  endif
  // Make sure file is not empty
  if cObjtype == "DBFFILE" .and. (eof() .or. bof())
    Errorbeep()
    PressKeyMsg({{" No record to edit."}})
    break
  endif

  xValue    := eval( (oObject:getcolumn(oObject:colpos)):block )
  nPosition := fieldpos( trim((oObject:getcolumn(oObject:colpos)):heading) )
  scroll( maxrow()-1, 0, maxrow(),maxcol() )

  do case
  case valtype( xValue ) == pCHARACTER
    do case
    case upper(xValue) == "<<MEMO>>" .and. cObjtype == "DBFFILE"
      setcursor( pCURSOR_ON )
      dispbox(5,10,maxrow()-5,maxcol()-5,pDBAR)
      @ 5, 12 say trim((oObject:getcolumn(oObject:colpos)):heading)
      @ maxrow()-5,11 say "Edit text ^W saves, ESC aborts"
      xValue := memoedit( fieldget( nPosition ),;
                          6, 11, maxrow()-6, maxcol()-6,pTRUE, "",;
                          (maxcol()-6) - 11 - 1 )
      setcursor( pCURSOR_OFF )
    case cObjtype == "MEMFILE"
      setcursor( pCURSOR_ON )
      dispbox(5,10,maxrow()-5,maxcol()-5,pDBAR)
      @ 5, 12 say trim((oObject:getcolumn(oObject:colpos)):heading)
      xValue := memoedit( xValue,;
                          6, 11, maxrow()-6, maxcol()-6,pTRUE, "",;
                          (maxcol()-6) - 11 - 1 ) + ""
      setcursor( pCURSOR_OFF )

    case cObjtype == "TXTFILE"
      // Do an edit on the text file, if it is small enough
      aTemp := directory(aMembers[nActive,pFILE_ELE])
      if aTemp[1,F_SIZE] < (memory(1) * 1024) .and. ;
         aTemp[1,F_SIZE] < ((memory(0) / 2) * 1024)
        setcursor( pCURSOR_ON )
        dispbox(5,1,maxrow()-5,maxcol()-1,pDBAR)
        @ 5, 12 say trim((oObject:getcolumn(oObject:colpos)):heading)
        @ maxrow()-5,11 say "Edit text ^W saves, ESC aborts"
        xValue := memoedit( memoread(aMembers[nActive,pFILE_ELE]),;
                            6, 2, maxrow()-6, maxcol()-2,pTRUE, "",;
                            100 )
        setcursor( pCURSOR_OFF )
      else
        Errorbeep()
        PressKeyMsg({{" File too large to edit - may only display "}})
        break
      endif

    otherwise
      @ maxrow(), 0 say "Enter Value " + field(nPosition) ;
                    get xValue picture "@S50"
    endcase

  case valtype( xValue ) = pNUMERIC
     @ maxrow(), 0 say "Enter number for " + field(nPosition) ;
       get xValue pict "99999999.99999999"
  case valtype( xValue ) = pLOGICAL
     @ maxrow(), 0 say "Enter logical 'Y' or 'N' for " + field(nPosition) ;
       get xValue picture "Y"
  case valtype( xValue ) = pDATE
     @ maxrow(), 0 say "Enter date for " + field(nPosition) ;
     get xValue picture "99/99/99"
  endcase

  read
  if lastkey() != pESC      // store values
    do case
    case cObjtype == "DBFFILE"
      fieldput( nPosition, xValue )
    case cObjtype == "MEMFILE"
      // Name of mem file including extension, name of variable
      // altered, and new value
      Adjmem(aMembers[nActive,pFILE_ELE],;
                       (oObject:cargo)[1, (oObject:cargo)[2] ,1],;
                       xValue)
      // Now update value in array.  Subscript is found by looking
      // in the first element of the array in cargo, which is an array.
      // The element we want for that array is held in the second
      // element of cargo.  THAT is an array, and the element we want of
      // it is in the 3rd element.
      (oObject:cargo)[1, (oObject:cargo)[2] ,3] := xValue
    case cObjtype == "TXTFILE"
      // save to disk - replace hard returns with hard returns, soft
      // with spaces
      memowrit(aMembers[nActive,pFILE_ELE],;
               strtran(xValue,chr(141)+chr(10)," "))
      // Update object cargo to hold reference to newly created array
      // of offsets, starting line 1
      oObject:cargo := { (AText(aMembers[nActive,pFILE_ELE])),1}
      oObject:refreshall()

    endcase
    oObject:refreshcurrent()
  endif
  recover using oError
    xValue := ""
    IF oError IS pOBJECT
      if oError:gencode == EG_MEM
        ErrorMessage(" Memory error while editing value ")
      else
        ShowGenError(oError)
      endif
    endif
  end sequence

  restscreen(,,,,cScreen)
  CLEARESC()
  errorblock(bOlderror)

  VOID

/* Function Replfield
   --------------------------------------
   Syntax:  Replfield()
   Returns: NIL
   Notes:   Allows fields to be replaced

*/
function Replfield()

  local xValue                          as usual   // Variable to edit
  local cScreen     := savescreen()     as char    // Screen save var
  local cEditSave                       as char    // Screen image of edit
  local nPosition                       as int     // Position in Tbrowse for cursor
  local cObjtype                        as char    // What kind of file?
  local aEnviron   := ActiveArea()                 as array
  local aMembers   := aEnviron[1]                  as array
  local nActive    := aEnviron[2]                  as int
  local oObject    := aMembers[nActive,pOBJ_ELE]   as object  // object
  local cScopecond        as char    // NEXT n records text
  local cOldScope         as char    // Holds current scope condition
  local nNextrec          as int     // Actual number
  local xWhilecond        as usual   // WHILE condition
  local xForcond          as usual   // FOR condition
  local xTemp             as usual   // Temp variable of varying types
  local cNumpict          as char    // Picture for numerics
  local cColor     := ColorCentral("Menu")    as char    // Color for box
  local cInv       := ColorCentral("Inverse") as char    // Color for inverse
  local cShadow    := ColorCentral("Shadow")  as char    // Shadow attribute
  local nPrompt                   as int     // MENU.. TO
  local aFieldinfo                as array   // Holds fields info - this .dbf
  local aFields                   as array   // Field info as one string
  local lRetval    := pTRUE       as logical // Return value
  local cOldcolor  := setcolor()  as char    // Current color setting
  local bOlderror                 as block   // Posted error block
  local oError                                     as object
  local nCount                                     as int
  local nCursor := setcursor()                     as int

  bOlderror := errorblock({|oError| break(oError)})

  begin sequence
  if !((cObjtype := aMembers[nActive,pOBJ_TYPE]) == "DBFFILE")
    ErrorMessage("No database open in area!")
    break
  endif

  // Make sure file is not empty
  if eof() .or. bof()
    Errorbeep()
    PressKeyMsg({{" No records to replace."}})
    break
  endif

  if oObject:colpos < 3
    Errorbeep()
    PressKeyMsg({{" You can replace only data fields."}})
    break
  endif

  xValue    := eval( (oObject:getcolumn(oObject:colpos)):block )
  nPosition := fieldpos( trim((oObject:getcolumn(oObject:colpos)):heading) )
  aFieldinfo := dbstruct()
  if aFieldinfo[nPosition,DBS_TYPE] == "N"
    if aFieldinfo[nPosition,DBS_DEC] > 0
      cNumpict := replicate("9",aFieldinfo[nPosition,DBS_LEN])
      cNumpict += "."
      cNumpict += replicate("9",aFieldinfo[nPosition,DBS_DEC])
    else
      cNumpict := replicate("9",aFieldinfo[nPosition,DBS_LEN])
    endif
  endif
  aFields    := {}
  aeval(aFieldinfo,{|aEle| aadd(aFields,padr(aEle[DBS_NAME],12)+;
                                        padr(aEle[DBS_TYPE],3)+;
                                        padr(str(aEle[DBS_LEN],3),5)+;
                                        str(aEle[DBS_DEC],3)) })

  scroll( maxrow()-1, 0, maxrow(), maxcol() )
  cOldcolor  := setcolor()

  do case
  case aFieldinfo[nPosition,DBS_TYPE] == "M"
    xValue := ""
  case aFieldinfo[nPosition,DBS_TYPE] == "C"
    xvalue := space(aFieldinfo[nPosition,DBS_LEN])
  case aFieldinfo[nPosition,DBS_TYPE] == "N"
    xValue := 0.00
  case aFieldinfo[nPosition,DBS_TYPE] == "L"
    xValue := pTRUE
  case aFieldinfo[nPosition,DBS_TYPE] == "D"
    xValue := date()
  endcase

  cScopecond := "ALL"
  xWhilecond := space(240)
  xForcond   := space(240)

  setcolor(cColor)

  scroll(4,5,21,77)
  dispbox( 4,5,21,77, pSDBAR)

  Newcolor(22,6,22,78,cShadow) // Shadow
  Newcolor(5,78,22,78,cShadow) // Shadow
  @  5,8 say "REPLACE " ;
         SAY trim((oObject:getcolumn(oObject:colpos)):heading) ;
         SAY "   type: "                                       ;
         SAY aFieldinfo[nPosition,DBS_TYPE]                    ;
         SAY "   len: "                                        ;
         SAY str(aFieldinfo[nPosition,DBS_LEN],3,0)            ;
         SAY "   dec: "                                        ;
         SAY str(aFieldinfo[nPosition,DBS_DEC],3,0)

  @  7,8 say "Value:"
  @  9,8 say "Scope:"
  @ 11,8 say "While:"
  @ 13,8 say "For:"
  @ 18,8 say "Finished"

  nPrompt := 1
  setcursor(pCURSOR_ON)
  PROCESS
    do case
    case aFieldinfo[nPosition,DBS_TYPE] $ "C.M"
      @ 7,15 say substr(xValue,1,60)
    case aFieldinfo[nPosition,DBS_TYPE] == "N"
      @ 7,15 say padr(transform(xValue,cNumpict),60)
    case aFieldinfo[nPosition,DBS_TYPE] == "L"
      @ 7,15 say if(xValue,"Y","N")
    case aFieldinfo[nPosition,DBS_TYPE] == "D"
      @ 7,15 say dtoc(xValue)
    endcase
    @  9,15 say padr(cScopecond,60)
    @ 11,15 say substr(xWhilecond,1,60)
    @ 13,15 say substr(xForcond,1,60)
    @ 20,8 say "Up/Down arrow keys, Enter for choice, ESC aborts" color cInv
    @  7,8 prompt "Value:"
    @  9,8 prompt "Scope:"
    @ 11,8 prompt "While:"
    @ 13,8 prompt "For:"
    @ 18,8 prompt "Finished"
    menu to nPrompt
    ShowTab(10,8,space(24))  // Sets up ShowTab() after CASE construct
    do case
    case nPrompt == 0
      lRetval := pFALSE
      ShowTab()
      break
    case nPrompt == 1
      do case
      case aFieldinfo[nPosition,DBS_TYPE] == "M"
        cEditSave := savescreen(5,10,maxrow()-5,maxcol()-5)
        setcursor( pCURSOR_ON )
        dispbox(5,10,maxrow()-5,maxcol()-5,pDBAR)
        @ 5, 12 say trim((oObject:getcolumn(oObject:colpos)):heading)
        @ maxrow()-5,11 say "Edit text ^W saves, ESC aborts"
        xValue := memoedit( fieldget( nPosition ),;
                            6, 11, maxrow()-6, maxcol()-6,pTRUE,;
                            "", (maxcol()-6) - 11 - 1 )
        setcursor( pCURSOR_OFF )
        restscreen(5,10,maxrow()-5,maxcol()-5,cEditSave)

      case aFieldinfo[nPosition,DBS_TYPE] == "C"
        @ 7, 15 get xValue
      case aFieldinfo[nPosition,DBS_TYPE] == "N"
        @ 7, 15 get xValue pict (cNumpict)
      case aFieldinfo[nPosition,DBS_TYPE] == "L"
        @ 7,15 get xValue picture "Y"
      case aFieldinfo[nPosition,DBS_TYPE] == "D"
         @ 7,15 get xValue picture "99/99/99"
      endcase
      read
    case nPrompt == 2
      cOldScope := cScopeCond
      do case
      case YNMsg({ {" Do you want ALL records? "} })
        cScopecond := "ALL"
      case lastkey() <> pESC
        cScopecond := 1
        @ 9,15 say "Next:" get cScopecond ;
                           pict "9999999" ;
                           valid cScopecond > 0
        read
        if !(lastkey() == pESC)
          cScopecond := "Next: "+str(cScopecond)
        else
          cScopecond := cOldScope
        endif
      endcase

    case nPrompt == 3
      @ 11,15 get xWhilecond ;
                  picture "@S60" ;
                  when ShowTab(12,8,padr("Press TAB to list fields",24)) ;
                  valid CondChk(xWhilecond,aFields) ;
                  send reader := {|oGet|DBPReader(oGet)}
      read
    case nPrompt == 4
      @ 13,15 get xForcond ;
                  picture "@S60" ;
                  when ShowTab(14,8,padr("Press TAB to list fields",24)) ;
                  valid CondChk(xForcond,aFields) ;
                  send reader := {|oGet|DBPReader(oGet)}
      read
    case nPrompt == 5
      ShowTab()
      exit
    endcase
    ShowTab()  // Gets rid of last tab setting

  END PROCESS

  setcursor(pCURSOR_OFF)
  @ 20,8 say "                                                "
  if lastkey() == pESC
    break
  endif
  // Create the WHILE block
  if empty(xWhilecond)
    xWhilecond := {||pTRUE}
  else
    xTemp := "{||"+xWhilecond+"}"
    xWhilecond := &(xTemp)
  endif
  // Create the FOR block
  if empty(xForcond)
    xForcond := {||pTRUE}
  else
    xTemp := "{||"+xForcond+"}"
    xForcond := &(xTemp)
  endif

  // store values
  WaitMsg(pTRUE)
  nNextrec := val(substr(cScopecond,7))
  @ 20,8 say "Records Processed: "
  nCount := 1
  if cScopecond == "ALL"
    dbeval({|| fieldput( nPosition, xValue ),;
                         devpos(20,27),devout(nCount++)},xForcond,xWhilecond)
  else
    dbeval({|| fieldput( nPosition, xValue ),;
                         devpos(20,27),devout(nCount++)},;
                         xForcond,xWhilecond,nNextrec)
  endif
  oObject:goTop()
  WaitMsg(pFALSE)

  recover using oError
    WaitMsg(pFALSE)
    setcolor(cOldcolor)
    xValue := ""
    IF oError IS pOBJECT
      ShowGenError(oError)
    endif

  end sequence
  setcolor(cOldcolor)
  errorblock(bOlderror)

  restscreen(,,,,cScreen)
  CLEARESC()
  setcursor(nCursor)

  VOID

// End of File: DBPMod.prg

DBPSrch.prg

/* File              DBPSRCH.PRG
   Notice            Copyright(c) 1991-1994 Sirius Software Development, Inc
                     All Rights Reserved
   Author            Steve Straley
*/

#define CLIPPER

#include "PTInkey.ch"
#include "PTValue.ch"
#include "PTFuncs.ch"
#include "PTVerbs.ch"
#include "PTColor.ch"
#include "DBPMenu.ch"

#include "DBSTRUCT.ch"

#define  pOBJ_ELE   1          // TBROWSE element slot
#define  pALIAS_ELE 2          // Alias name slot
#define  pFILE_ELE  3          // Full path and file name slot
#define  pOBJ_TYPE  4          // Type of file slot
#define  pWIN_ELE   5          // Array of window coordinates
#define  pSELECT_BOX   1       // Code to select a box
#define  pUNSELECT_BOX 2       // Code to de-hilite a box
memvar getlist

/* Function GotoRecord
   --------------------------------------
   Syntax:  GotoRecord()
   Returns: NIL
   Notes:   Allows user to jump to a record

*/
function GotoRecord

  local nRecord := recno()                                       as int
  local cScreen := savescreen( maxrow(), 0, maxrow(), maxcol() ) as char
  local aEnviron := ActiveArea()                                 as array
  local aMembers:= aEnviron[1]                                   as array
  local nActive := aEnviron[2]                                   as int

  if !empty( alias() )
    if lastrec() > 0
      @ maxrow(), 0 say "Enter Record Number: " get nRecord ;
        valid ( nRecord >= 1 .and. nRecord <= lastrec() )
      read
      if lastkey() != pESC
        dbgoto( nRecord )
        (aMembers[nActive,pOBJ_ELE]):refreshall()
      endif
    else
      ErrorMessage("Database is empty!")
    endif
  endif

  restscreen(maxrow(), 0, maxrow(),maxcol(), cScreen )
  CLEARESC()

  VOID

/* Function Seekitem
   --------------------------------------
   Syntax:  Seekitem()
   Returns: NIL
   Notes:   Allows user to seek an item

*/
function SeekItem()

  local cScreen := savescreen()    as char
  local xItem                      as usual
  local xKey                       as usual
  local nRetval := recno()         as int
  local aEnviron := ActiveArea()   as array
  local aMembers:= aEnviron[1]     as array
  local nActive := aEnviron[2]     as int

  begin sequence
  if empty( alias() )
    ErrorMessage( "No database is open to allow for a SEEK" )
    break
  endif
  // Find out if index is attached
  if indexord() == 0
    ErrorMessage( "No index is open to allow for a SEEK" )
    break
  endif
  scroll( maxrow()-1,0,maxrow(),maxcol() )
  xKey := &(indexkey())
  @ maxrow(), 0 say "Seek value: "
  do case
  case valtype(xKey) == "C"
    xItem := space(len(xKey))
    @ maxrow(),12 get xItem picture "@S40"
  case valtype(xKey) == "N"
    xItem := xKey
    @ maxrow(),12 get xItem
  case valtype(xKey) == "D"
    xItem := xKey
    @ maxrow(),12 get xItem picture "@D"
  endcase
  read
  if lastkey() != pESC
    IF xItem IS pCHARACTER
      xItem := alltrim(xItem)
    endif
    if !(dbseek( xItem ))
      ErrorMessage( "Item is not found!" )
      dbgoto( nRetval )
    else
      (aMembers[nActive,pOBJ_ELE]):refreshall()
    endif
  endif
  end sequence

  restscreen(,,,, cScreen )
  CLEARESC()

  VOID

/* Function Locateit
   --------------------------------------
   Syntax:  Locateit()
   Returns: NIL
   Notes:   Allows search via a condition

*/
function LocateIt()

  static cCondition     as char  // LOCATE FOR condition
  static cOldcond := "" as char  // Stores condition, so CONTINUE can be done

  local cScreen := savescreen()  as char
  local nRecordnumber            as int
  local aEnviron := ActiveArea() as array
  local aMembers:= aEnviron[1]   as array
  local nActive := aEnviron[2]   as int
  local aFields := {}            as array

  begin sequence
  if empty( alias() )
    ErrorMessage( "No database is open to search." )
    break
  endif

  cCondition := if( cCondition == NIL, space(100), padr(cCondition, 100) )
  aeval(dbstruct(),{|aEle| aadd(aFields,padr(aEle[DBS_NAME],12)+;
                                        padr(aEle[DBS_TYPE],3)+;
                                        padr(str(aEle[DBS_LEN],3),5)+;
                                        str(aEle[DBS_DEC],3)) })

  nRecordnumber := recno()
  @ maxrow(), 0 say "Expression (TAB lists fields):" get cCondition ;
     picture "@S40" valid Condchk(cCondition,aFields) ;
     send reader := {|oGet|DBPReader(oGet)}
  read
  if lastkey() == pESC
    break
  endif

  DispMessage( "" )
  DispMessage( "One moment to locate..." )
  // If this is the same condition, do a continue...
  if trim(cOldcond) == trim(cCondition)
    Errorbeep()
    if YNMsg({ {" Filter is already set.  Continue from ",;
                " current record?"}})
      continue
    else
      locate for &cCondition.
    endif
  else
    locate for &cCondition.
  endif
  if !found()
     ErrorMessage( "Condition not found.  Returning to original position." )
     dbgoto( nRecordNumber )
  endif
  DispMessage( "" )
  (aMembers[nActive,pOBJ_ELE]):refreshall()
  cOldcond := cCondition

  end sequence
  CLEARESC()
  restscreen(,,,,cScreen )

  VOID

// End of File: Dbpsrch.prg

DBPObj.prg

/* File              DBPOBJ.PRG
   Notice            Copyright(c) 1991-1994 Sirius Software Development, Inc
                     All Rights Reserved
   Author            Steve Straley

*/

#define CLIPPER

#include "PTInkey.ch"
#include "PTValue.ch"
#include "PTFuncs.ch"
#include "PTVerbs.ch"
#include "PTColor.ch"
#include "DBPMenu.ch"

#include "DBSTRUCT.ch"

#define  pOBJ_ELE   1          // TBROWSE element slot
#define  pALIAS_ELE 2          // Alias name slot
#define  pFILE_ELE  3          // Full path and file name slot
#define  pOBJ_TYPE  4          // Type of file slot
#define  pWIN_ELE   5          // Array of window coordinates
#define  pSELECT_BOX   1       // Code to select a box
#define  pUNSELECT_BOX 2       // Code to de-hilite a box

memvar getlist

/* Function Delcols
   --------------------------------------
   Syntax:  Delcols()
   Returns: NIL
   Notes:   Deletes columns from a Tbrowse object

*/
function DelCols

  local aEnviron := ActiveArea()                as array
  local nActive := aEnviron[2]                  as int
  local oObject := aEnviron[1,nActive,pOBJ_ELE] as object

  if empty( alias() )
    ErrorMessage( "No database is available." )
  else
    if oObject:colCount = 1
      ErrorMessage( "Cannot delete the last column" )
    else
      oObject:delColumn( oObject:colPos )
      oObject:configure()
      oObject:refreshall()
    endif
  endif

  VOID

/* Function Twiddle
   --------------------------------------
   Syntax:  Twiddle()
   Returns: NIL
   Notes:   Switches columns in a browse

*/
function Twiddle

  local aEnviron := ActiveArea()                as array
  local nActive := aEnviron[2]                  as int
  local oObject := aEnviron[1,nActive,pOBJ_ELE] as object
  local nColumn                                 as int

  if empty( alias() )
    ErrorMessage( "No database is available." )
  else
    nColumn := oObject:getColumn(oObject:colPos)
    if oObject:colPos = oObject:colcount
      // twiddle to the left
      oObject:setColumn(oObject:colPos,oObject:getColumn(oObject:colPos-1))
      oObject:setColumn(oObject:colPos-1, nColumn)
    else
      // twiddle to the right
      oObject:setColumn(oObject:colPos, oObject:getColumn(oObject:colPos+1))
      oObject:setColumn(oObject:colPos+1, nColumn)
    endif
    oObject:refreshall()
  endif

  VOID

/* Function Lockfield
   --------------------------------------
   Syntax:  LockField()
   Returns: NIL
   Notes:   Allows user to specify the columns to lock on screen

*/
function LockField()

  local aEnviron := ActiveArea()                as array
  local nActive := aEnviron[2]                  as int
  local oObject := aEnviron[1,nActive,pOBJ_ELE] as object
  local cScreen                                 as char
  local nValue                                  as int

  if empty( alias() )
    ErrorMessage( "No database is available." )
  else

    cScreen := savescreen( maxrow(), 0, maxrow(), maxcol() )
    nValue := oObject:freeze
    @ maxrow(), 0 say "Enter number of columns to lock: " ;
                  get nValue ;
                  valid nValue >= 0 .and. nValue <= oObject:colCount
    read
    if lastkey() != pESC
      oObject:freeze := nValue
      oObject:refreshall()
      oObject:colPos := oObject:freeze + 1
    endif
    restscreen(maxrow(), 0,maxrow(), maxcol(), cScreen )
    CLEARESC()

  endif

  VOID

// End of File: Dbpobj.prg

DBPScope.prg

/* File              DBPSRCH.PRG
   Notice            Copyright(c) 1991-1994 Sirius Software Development, Inc
                     All Rights Reserved
   Author            Steve Straley
*/

#define CLIPPER

#include "PTInkey.ch"
#include "PTValue.ch"
#include "PTFuncs.ch"
#include "PTVerbs.ch"
#include "PTColor.ch"
#include "DBPMenu.ch"

#include "DBSTRUCT.ch"

#define  pOBJ_ELE   1          // TBROWSE element slot
#define  pALIAS_ELE 2          // Alias name slot
#define  pFILE_ELE  3          // Full path and file name slot
#define  pOBJ_TYPE  4          // Type of file slot
#define  pWIN_ELE   5          // Array of window coordinates
#define  pSELECT_BOX   1       // Code to select a box
#define  pUNSELECT_BOX 2       // Code to de-hilite a box
memvar getlist

/* Function GotoRecord
   --------------------------------------
   Syntax:  GotoRecord()
   Returns: NIL
   Notes:   Allows user to jump to a record

*/
function GotoRecord

  local nRecord := recno()                                       as int
  local cScreen := savescreen( maxrow(), 0, maxrow(), maxcol() ) as char
  local aEnviron := ActiveArea()                                 as array
  local aMembers:= aEnviron[1]                                   as array
  local nActive := aEnviron[2]                                   as int

  if !empty( alias() )
    if lastrec() > 0
      @ maxrow(), 0 say "Enter Record Number: " get nRecord ;
        valid ( nRecord >= 1 .and. nRecord <= lastrec() )
      read
      if lastkey() != pESC
        dbgoto( nRecord )
        (aMembers[nActive,pOBJ_ELE]):refreshall()
      endif
    else
      ErrorMessage("Database is empty!")
    endif
  endif

  restscreen(maxrow(), 0, maxrow(),maxcol(), cScreen )
  CLEARESC()

  VOID

/* Function Seekitem
   --------------------------------------
   Syntax:  Seekitem()
   Returns: NIL
   Notes:   Allows user to seek an item

*/
function SeekItem()

  local cScreen := savescreen()    as char
  local xItem                      as usual
  local xKey                       as usual
  local nRetval := recno()         as int
  local aEnviron := ActiveArea()   as array
  local aMembers:= aEnviron[1]     as array
  local nActive := aEnviron[2]     as int

  begin sequence
  if empty( alias() )
    ErrorMessage( "No database is open to allow for a SEEK" )
    break
  endif
  // Find out if index is attached
  if indexord() == 0
    ErrorMessage( "No index is open to allow for a SEEK" )
    break
  endif
  scroll( maxrow()-1,0,maxrow(),maxcol() )
  xKey := &(indexkey())
  @ maxrow(), 0 say "Seek value: "
  do case
  case valtype(xKey) == "C"
    xItem := space(len(xKey))
    @ maxrow(),12 get xItem picture "@S40"
  case valtype(xKey) == "N"
    xItem := xKey
    @ maxrow(),12 get xItem
  case valtype(xKey) == "D"
    xItem := xKey
    @ maxrow(),12 get xItem picture "@D"
  endcase
  read
  if lastkey() != pESC
    IF xItem IS pCHARACTER
      xItem := alltrim(xItem)
    endif
    if !(dbseek( xItem ))
      ErrorMessage( "Item is not found!" )
      dbgoto( nRetval )
    else
      (aMembers[nActive,pOBJ_ELE]):refreshall()
    endif
  endif
  end sequence

  restscreen(,,,, cScreen )
  CLEARESC()

  VOID

/* Function Locateit
   --------------------------------------
   Syntax:  Locateit()
   Returns: NIL
   Notes:   Allows search via a condition

*/
function LocateIt()

  static cCondition     as char  // LOCATE FOR condition
  static cOldcond := "" as char  // Stores condition, so CONTINUE can be done

  local cScreen := savescreen()  as char
  local nRecordnumber            as int
  local aEnviron := ActiveArea() as array
  local aMembers:= aEnviron[1]   as array
  local nActive := aEnviron[2]   as int
  local aFields := {}            as array

  begin sequence
  if empty( alias() )
    ErrorMessage( "No database is open to search." )
    break
  endif

  cCondition := if( cCondition == NIL, space(100), padr(cCondition, 100) )
  aeval(dbstruct(),{|aEle| aadd(aFields,padr(aEle[DBS_NAME],12)+;
                                        padr(aEle[DBS_TYPE],3)+;
                                        padr(str(aEle[DBS_LEN],3),5)+;
                                        str(aEle[DBS_DEC],3)) })

  nRecordnumber := recno()
  @ maxrow(), 0 say "Expression (TAB lists fields):" get cCondition ;
     picture "@S40" valid Condchk(cCondition,aFields) ;
     send reader := {|oGet|DBPReader(oGet)}
  read
  if lastkey() == pESC
    break
  endif

  DispMessage( "" )
  DispMessage( "One moment to locate..." )
  // If this is the same condition, do a continue...
  if trim(cOldcond) == trim(cCondition)
    Errorbeep()
    if YNMsg({ {" Filter is already set.  Continue from ",;
                " current record?"}})
      continue
    else
      locate for &cCondition.
    endif
  else
    locate for &cCondition.
  endif
  if !found()
     ErrorMessage( "Condition not found.  Returning to original position." )
     dbgoto( nRecordNumber )
  endif
  DispMessage( "" )
  (aMembers[nActive,pOBJ_ELE]):refreshall()
  cOldcond := cCondition

  end sequence
  CLEARESC()
  restscreen(,,,,cScreen )

  VOID

// End of File: Dbpsrch.prg

DBPMFunc.prg

/* File              DBPMFUNC.prg
   Notice            Copyright(c) 1991-1994 Sirius Software Development, Inc
                     All Rights Reserved
*/

#define CLIPPER

#include "DBPMenu.ch"

#include "PTInkey.ch"
#include "PTColor.ch"
#include "PTVerbs.ch"
#include "PTValue.ch"

static nOffset as int // Keeps offset of last chosen menu array element
static nStack  as int // Keeps track of how many times Pulldown() has been
                      // called.  Used so we know how many times to `back out'
                      // and process a next movement key.
static nKeyflag              as int      
static cChr_norm             as char     
static cChr_menu             as char     
static cClr_norm             as char     
static cClr_menu             as char     
static cChr_shad             as char     
static cClr_inv              as char     
static cClr_nochx            as char     
static cHot_chx              as char     
static lNextbar := pFALSE    as logical  
static aChxstack := {}       as array    
static aNewstack := {}       as array    
static lUsingstack := pFALSE as logical  
static nNestdepth := 0       as int      
static nBoxrow               as int      
static nBoxcol := 2          as int      
static nLevel := 0           as int      

/* Function menu
   --------------------------------------
   Syntax:  menu(<aMenus_>,<cColor>) --> NIL
   Example: menu()
   Notes:   Simply a function that will call the main menuing action
            function Showmenu
*/
function Menu(aMenus_,cColor)

  local nClr_chx  as int    // Monitor type as a number
  local xRetval   as usual   // Array ref. to menus, or NIL
  local lOldwrap  as logical
  local nOldcurs  as int
  local cOldcolor as char

  // Monitor type
  do case
  case cColor == "B"
    nClr_chx := pMONO_MONITOR
  case cColor == "C"
    nClr_chx := pCOLOR_MONITOR
  endcase

  // Store environment
  lOldwrap := set(pWRAP,pTRUE)
  nOldcurs := setcursor()
  cOldcolor:= setcolor()

  cChr_norm  := GetColor(nClr_chx,pCHR_NORM)
  cChr_menu  := GetColor(nClr_chx,pCHR_MENU)
  cClr_norm  := GetColor(nClr_chx,pCLR_NORM)
  cClr_menu  := GetColor(nClr_chx,pCLR_MENU)
  cClr_inv   := GetColor(nClr_chx,pCLR_INV)
  cChr_shad  := GetColor(nClr_chx,pCHR_SHAD)
  cClr_nochx := GetColor(nClr_chx,pCLR_NOCHX)
  cHot_chx   := GetColor(nClr_chx,pHOT_CHX)

  setcolor(cClr_norm)
  nOffset  := 1    // in version 1.2 of Menu, offset is always 1, so
                   // menus can't 'scroll'
  aNewstack := {}
  setcursor(pCURSOR_OFF)

  xRetval := Showmenu(aMenus_)

  setcursor(nOldcurs)
  set(pWRAP,lOldwrap)
  setcolor(cOldcolor)

  return(xRetval)

/* Function Showmenu
   --------------------------------------
   Syntax:  Showmenu(<aMenus>[,cShadow]) --> NIL
   Example: Showmenu(aMenus,clr_shad)
   Notes:   Handles processing keystrokes and showing menus

*/
static function Showmenu(aMenus,cShadow)

  local cScr            as char       // Screen save
  local nNumchxs        as int        // Number of choices
  local nCount          as int        // Spacing across top
  local nMenusp         as int
  local nAdder          as int
  local aCols           as array  // Array of columns for main menu bar
  local nBoxchoice      as int    // Choice made by user
  local cBlankbox       as char   // Screen with report options across top
  local bBlock := NIL   as block  // Code Block associated with choice
  local nKey            as int    // Key pressed by the user
  local nOldchoice      as int    // Choice made last time
  local xRetval         as usual
  local lGetit := pTRUE as logical // .T. when we are to get a keystroke from the user

  nStack := 1
  if pcount() < 2
    cShadow := cChr_shad
  endif
  // Number of choices is the length of the choices array
  nNumchxs := len(aMenus[pCHX_ARR])

  // create an array that stores column position for top level menu
  aCols := array(nNumchxs)

  // Figure out where the cols should go.
  // 'nMenusp' holds the proper spacing betweem main menu choices
  // `aCols' is to hold the columns where main menu choices appear
  nMenusp := pMAIN_BAR_SPACE
  nAdder := aMenus[pNUM_ARR,pDISP_COL]
  aCols[1] := nAdder
  for nCount := 2 to nNumchxs
    // Add length of menu prompt + spacing between prompts the prior length
    nAdder := nAdder+len(aMenus[pCHX_ARR,nCount-1,pCHX_STRING])+nMenusp
    aCols[nCount] := nAdder
  next

  // save the bar area.
  cScr := savescreen(0,0,aMenus[pNUM_ARR,pDISP_ROW],maxcol())

  // paint it blank
  for nCount := 1 to nNumchxs
    @ aMenus[pNUM_ARR,pDISP_ROW],aCols[nCount] say ;
                                aMenus[pCHX_ARR,nCount,pCHX_STRING]
    // paint in the hot letters
    devpos(aMenus[pNUM_ARR,pDISP_ROW],aCols[nCount]+;
           aMenus[pCHX_ARR,nCount,pCHX_HOTLET]-1)
    devout(substr(aMenus[pCHX_ARR,nCount,pCHX_STRING],;
           aMenus[pCHX_ARR,nCount,pCHX_HOTLET],1),;
           if(aMenus[pLOGIC_ARR,nCount],cHot_chx,cClr_nochx))
  next
  nBoxchoice := 1

  // save the blank screen
  cBlankbox := savescreen()

  // Now, get choices!
  PROCESS
    setcursor(pCURSOR_OFF)
    // color choice
    @ aMenus[pNUM_ARR,pDISP_ROW],aCols[nBoxchoice] say ;
      aMenus[pCHX_ARR,nBoxchoice,pCHX_STRING] color cClr_inv
    nOldchoice := nBoxchoice
    if lGetit
      nKey := inkey(0)
    endif
    if nKey == pSLASH
      if nNestdepth > 0
        // the first element of aChxstack is the element of the top menu
        // bar they chose.  Thereafter, it is the letter they chose.
        // If the current choice is not the one they chose, dehighlite
        // it, and highlite the right one
        if nBoxchoice <> aChxstack[1]
          @ aMenus[pNUM_ARR,pDISP_ROW],aCols[nBoxchoice] say ;
            aMenus[pCHX_ARR,nBoxchoice,pCHX_STRING]
            // put back hot letter
          @ aMenus[pNUM_ARR,pDISP_ROW],aCols[nOldchoice] say ;
            substr(aMenus[pCHX_ARR,nOldchoice,pCHX_STRING],;
            aMenus[pCHX_ARR,nOldchoice,pCHX_HOTLET],1) color;
            if(aMenus[pLOGIC_ARR,nOldchoice],cHot_chx,cClr_nochx)
          // highlight new choice
          @ aMenus[pNUM_ARR,pDISP_ROW],aCols[aChxstack[1]] say ;
            aMenus[pCHX_ARR,aChxstack[1],pCHX_STRING] color cClr_inv
        endif
        nKey := pENTER
        nBoxchoice := aChxstack[1]
        lUsingstack := pTRUE
      endif
    endif
    do case
    case nKey == pESC
      exit
    case nKey == pRIGHT_ARROW
      nBoxchoice := if(nBoxchoice == nNumchxs,1,nBoxchoice+1)
      // un-highlite current choice, put back hot letter
      @ aMenus[pNUM_ARR,pDISP_ROW],aCols[nOldchoice] say ;
        aMenus[pCHX_ARR,nOldchoice,pCHX_STRING]
      @ aMenus[pNUM_ARR,pDISP_ROW],aCols[nOldchoice] say ;
        substr(aMenus[pCHX_ARR,nOldchoice,pCHX_STRING],;
        aMenus[pCHX_ARR,nOldchoice,pCHX_HOTLET],1) color ;
        if(aMenus[pLOGIC_ARR,nOldchoice],cHot_chx,cClr_nochx)
    case nKey == pLEFT_ARROW
      nBoxchoice := if(nBoxchoice == 1,nNumchxs,nBoxchoice-1)
      // dehighlite current choice, put back hot letter
      @ aMenus[pNUM_ARR,pDISP_ROW],aCols[nOldchoice] say ;
        aMenus[pCHX_ARR,nOldchoice,pCHX_STRING]
      @ aMenus[pNUM_ARR,pDISP_ROW],aCols[nOldchoice] say ;
        substr(aMenus[pCHX_ARR,nOldchoice,pCHX_STRING],;
        aMenus[pCHX_ARR,nOldchoice,pCHX_HOTLET],1) color ;
        if(aMenus[pLOGIC_ARR,nOldchoice],cHot_chx,cClr_nochx)
    case nKey == pENTER
      if valtype(aMenus[pFUNC_ARR,nBoxchoice]) =pARRAY
        // push the menu/choices stack
        nStack++
        // add to current session choices array
        aadd(aNewstack,nBoxchoice)
        // Do the pull-down sequence
        bBlock := Pulldown(aMenus[pFUNC_ARR,nBoxchoice],cShadow)
        // At the top level, restore `blank' box i.e. no pull-downs, and
        // issue horizontal prompts
        restscreen(,,,,cBlankbox)
        if bBlock <> NIL
          exit
        endif
      else
        // turn off stack choice
        lUsingstack := pFALSE
        bBlock := aMenus[pFUNC_ARR,nBoxchoice]
        exit
      endif
    otherwise
      // pressed a letter
      xRetval := ascan(aMenus[pCHX_ARR],;
               {|aEle| upper(substr(aEle[2],aEle[1],1)) == upper(chr(nKey))})
      if xRetval <> 0
        // Go ahead and highlight this area, in case there is a menu
        // underneath
        @ aMenus[pNUM_ARR,pDISP_ROW],aCols[nOldchoice] say ;
          aMenus[pCHX_ARR,nOldchoice,pCHX_STRING]
        @ aMenus[pNUM_ARR,pDISP_ROW],aCols[nOldchoice] say ;
          substr(aMenus[pCHX_ARR,nOldchoice,pCHX_STRING],;
          aMenus[pCHX_ARR,nOldchoice,pCHX_HOTLET],1) color ;
          if(aMenus[pLOGIC_ARR,nOldchoice],cHot_chx,cClr_nochx)
        nBoxchoice := xRetval
        lGetit := pFALSE
        nKey := pENTER
        loop
      endif
    endcase
    lGetit := pTRUE
  END PROCESS
  // restore the bar area
  restscreen(0,0,aMenus[pNUM_ARR,pDISP_ROW],maxcol(),cScr)
  // init this menu instance's choices
  aChxstack := aNewstack
  // init how many levels down we went
  nNestdepth := len(aChxstack)

  return(bBlock)

/* Function Pulldown
   --------------------------------------
   Syntax:  Pulldown(<aMenus>[,cShadow])
   Example: Pulldown(aMenus[pFUNC_ARR,nBoxchoice],cShadow)
   Returns: NIL
   Notes:   Handles displaying levels of pulldown menus

            aMenus    The menu array
            cShadow   Attribute byte for shadowing

            `stackflag' is used to signal to this function when we
            need to simply RETURN NIL.  It is necessitated b/c this
            is a recursive function, and it is possible for menus
            to `nest' several times.  Say a user is four levels deep, and
            presses the right arrow key.  We want the menu to wipe out
            all preceding menus, and position the highlight on the next
            menu bar option.  We COULD stuff a bunch of ESCAPES into the
            keyboard buffer, but  - nahhh...  Instead, we set the variable
            `stackflag' to .T., and it simply returns, decrementing the
            var nStack as it goes.  When nStack is at 0, it stuffs the
            pRIGHT_ARROW, and returns.
*/
static function Pulldown(aMenus,cShadow)

  local nBoxchoice          as int       // Choice of user
  local lIs_shown := pFALSE as logical   // Whether menu has been shown yet
  local bBlock := NIL       as block     // Block associated with choice

  static lStackflag := pFALSE as logical // Whether we are pulling down via the stack

  PROCESS
    if lStackflag
      // if nStack is at 2, this is the last decrement - return to above,
      // after stuffing the lateral movement key
      if nStack == 2
        nStack--
        lStackflag := pFALSE
        keyboard chr(nKeyflag) + chr(pENTER)
        exit
      else
        nStack--
        exit
      endif
    endif
    // Get their choice
    nBoxchoice := Dispmenu("SHOW",aMenus,cShadow,lIs_shown)
    do case
    case nKeyflag == pESC
      // ESC pressed by user - restore the screen
      Dispmenu("KILL",aMenus)
      // pop stack counter
      nStack--
      // make aNewstack one less
      asize(aNewstack,len(aNewstack) - 1)
      // init choice/rel pos at 1
      aMenus[pNUM_ARR,pINIT_ELE] := 1
      aMenus[pNUM_ARR,pREL_ELE] := 1
      exit

    case nKeyflag == pRIGHT_ARROW
      lStackflag := if(nStack>0,.t.,lStackflag)
      aMenus[pNUM_ARR,pINIT_ELE] := 1
      aMenus[pNUM_ARR,pREL_ELE] := 1
      aNewstack := {}

    case nKeyflag == pLEFT_ARROW
      lStackflag := if(nStack>0,.t.,lStackflag)
      aMenus[pNUM_ARR,pINIT_ELE] := 1
      aMenus[pNUM_ARR,pREL_ELE] := 1
      aNewstack := {}
    // -1 if they couldn't make a choice b/c the companion LOGIC array is
    // all false
    otherwise
      lIs_shown := pTRUE
      // record their choice for this level
      aadd(aNewstack,nBoxchoice)
      if valtype(aMenus[pFUNC_ARR,nBoxchoice]) == pARRAY
        // push stack counter
        nStack++
        bBlock := Pulldown(aMenus[pFUNC_ARR,nBoxchoice],cShadow)
        // if they chose one, exit out
        if bBlock <> NIL
          exit
        endif
      else
        // are at the bottom most level for this menu area
        bBlock := aMenus[pFUNC_ARR,nBoxchoice]
        exit
      endif
    endcase

  END PROCESS

  return(bBlock)

/* Function Dispmenu
   --------------------------------------
   Syntax:  Dispmenu(<cAction>,<aMa>[,cShadow][lIs_shown])
   Example: Dispmenu(menus)
   Returns: NIL
   Notes:   Frames the menu for the current array

            cAction    "Show" menu or "Kill" menu
            aMa        Menu Array
            cShadow    Character to use to create the cShadow effect
            lIs_shown  Whether menu image has been shown already
*/
static function Dispmenu(cAction,aMa,cShadow,lIs_shown)

  local nBoxlen  as int   // Vertical length of menu
  local nBoxwid  as int   // Width of longest item on menu
  local nBoxrow  as int   // Which row of the screen should menu appear on
  local nBoxcol  as int   // Which column of the screen should menu appear on
  local nAns     as int
  local nInit    as int

  nBoxlen := aMa[pNUM_ARR,pNUM_ELES]
  nBoxwid := aMa[pNUM_ARR,pWIDEST_ELE]
  nBoxrow := aMa[pNUM_ARR,pDISP_ROW]
  nBoxcol := aMa[pNUM_ARR,pDISP_COL]
  if pcount() < 4
    lIs_shown := pTRUE
  endif
  if upper(cAction) == "SHOW"
    if !lIs_shown
      // Save the preboxed screen image of what we are about to overwrite
      aMa[pSCREEN_ELE] := ;
        savescreen(nBoxrow-1,nBoxcol-1,nBoxrow+nBoxlen+1,nBoxcol+nBoxwid+1)
      setcolor(aMa[pCOLOR_ELE])
      // create a menu box
      dispbox( nBoxrow-1,nBoxcol-1,nBoxrow+nBoxlen,nBoxcol+nBoxwid,pSBAR)
      setcolor(cClr_norm)
      if pcount() > 2
        // print cShadow on bottom, side
        Newcolor(nBoxrow+nBoxlen+1,nBoxcol,;
                 nBoxrow+nBoxlen+1,nBoxcol+nBoxwid+1,cShadow)
        Newcolor(nBoxrow,nBoxcol+nBoxwid+1,;
                 nBoxrow+nBoxlen+1,nBoxcol+nBoxwid+1,cShadow)
      endif

    endif
    // Get their choice.
    // If using the menu stack, make the initial choice that stored in
    // the stack.  Else, that stored in the menu system
    if lUsingstack
      nInit := aChxstack[nStack]
      // If the user pressed a double slash, then we need to check to see
      // if we are at the deepest level where they were the last time.
      // If so, turn off the choice stack stuff
      if nNestdepth == nStack
        lUsingstack := pFALSE
      endif
    else
      nInit := aMa[pNUM_ARR,pINIT_ELE]
    endif
    //
    // Note the last parameter.  This is done b/c the
    // get menu function is called iteratively, so that we
    // need to keep track of what level we were at before.
    // The 8th parameter is the item chosen.
    setcolor(aMa[pCOLOR_ELE])
    nAns := GetChoice(nBoxrow,nBoxcol,nBoxrow+nBoxlen-1,nBoxcol+nBoxwid-1,;
     aMa[pCHX_ARR],aMa[pLOGIC_ARR],nInit,aMa[pNUM_ARR,pREL_ELE])
    setcolor(cClr_norm)
    // Store their choice if they had one to pick
    if ascan(aMa[pLOGIC_ARR],pTRUE) <> 0
      if nAns <> 0
        // ESC not pressed
        aMa[pNUM_ARR,pINIT_ELE] := nAns
        // grab offset from externally kept variable
        aMa[pNUM_ARR,pREL_ELE] := nOffset
      endif
    else
      // no choice available
      nAns := -1
    endif
    // Now return the choice
    return(nAns)
  else
    // Restore the screen as it was
    restscreen(nBoxrow-1,nBoxcol-1,nBoxrow+nBoxlen+1,nBoxcol+nBoxwid+1,;
               aMa[pSCREEN_ELE])
  endif

  VOID

/* Function Getchoice
   --------------------------------------
   Syntax:  Getchoice(<nT>,<nL>,<nB>,<nR>,<aChx_arr>,;
            <lLogic_arr>[nInitial[,nOffset])
   Example: Getchoice(5,5,10,15,aChoices,lLogics)
   Notes:   Handles processing menu choices - an 'Achoice()' replacement

            The array `aEle_chxs' holds 1 element for each AVAILABLE aChx_arr
            element.  It is used so that when the user presses an arrow
            movement key, we instantly know which element of aChx_arr to move
            to.
*/
static function Getchoice(nT,nL,nB,nR,aChx_arr,lLogic_arr,nInitial,nOffset)

  local nRow := nT as int
  local nCol := nL as int
  local i    := 1  as int
  local lHl        as logical  // Whether choice is available to user
  local cOldimage  as char     // image of text of old choice
  local nCurrline  as int      // Current line of menu we are on
  local nKey       as int      // Key pressed by user
  local xRetval    as usual    // Element on when user pressed ENTER
  local nBottline  as int      // Bottom element of menu

  if pcount() < 7
    nInitial := 1
  endif
  xRetval := 0
  nBottline := len(aChx_arr)
  nCurrline := nInitial
  // initial display - for each array element, print the text (normal menu
  //                   color if available, cClr_nochx if not).  Then print
  //                   the hot key (cClr_nochx if choice not available,
  //                   cHot_chx if available).
  //
  i := 1
  aeval(aChx_arr,{ |arr| ;
        lHl := lLogic_arr[i],;
        devpos(nRow,nCol),;
        devout(aChx_arr[i,pCHX_STRING],if(lHl,cClr_menu,cClr_nochx)),;
        devpos(nRow,nCol+aChx_arr[i,pCHX_HOTLET]-1),;
        devout(substr(aChx_arr[i,pCHX_STRING],aChx_arr[i,pCHX_HOTLET],1),;
               if(lHl,cHot_chx,cClr_nochx)),;
        i++,nRow++;
                };
        )

  nRow := nT + nInitial - 1

  PROCESS

    // now save the `old image' of the first text choice
    cOldimage := savescreen(nRow, nCol, nRow, ;
                            nCol + len(aChx_arr[nCurrline,pCHX_STRING]) - 1)
    // now hilite it
    devpos(nRow,nCol)
    devout(aChx_arr[nCurrline,pCHX_STRING],;
           if(lLogic_arr[nCurrline],cClr_inv,cClr_nochx))
    // if using the choice stack, don't allow a choice
    if lUsingstack
      nKey := pENTER
      nCurrline := nInitial
    else
      nKey := inkey(0)
    endif
    // Clear their choice if it is a movement keystroke.  Note that we
    // duplicate the restscreen code, depending on the case - this is for
    // speed purposes, so we don't have to do a substring search of keys
    do case
    case nKey == pESC
      nKeyflag := pESC
      exit
    case nKey == pRIGHT_ARROW
      nKeyflag := pRIGHT_ARROW
      exit
    case nKey == pLEFT_ARROW
      nKeyflag := pLEFT_ARROW
      exit
    case nKey == pUP_ARROW
      restscreen(nRow, nCol, nRow, ;
                 nCol + len(aChx_arr[nCurrline,pCHX_STRING]) - 1,cOldimage)
      if nRow == nT
        // go to bottom
        nCurrline := nBottline
        nRow := nT + nBottline - 1
      else
        nCurrline--
        nRow--
      endif
    case nKey == pDOWN_ARROW
      restscreen(nRow, nCol, nRow, ;
                 nCol + len(aChx_arr[nCurrline,pCHX_STRING]) - 1,cOldimage)
      if nRow == nB
        // back to top
        nRow := nT
        nCurrline := 1
      else
        nCurrline++
        nRow++
      endif
    case nKey == pPGUP
      restscreen(nRow, nCol, nRow, ;
                 nCol + len(aChx_arr[nCurrline,pCHX_STRING]) - 1,cOldimage)
      nRow := nT
      nCurrline := 1
    case nKey == pPGDN
      restscreen(nRow, nCol, nRow, ;
                 nCol + len(aChx_arr[nCurrline,pCHX_STRING]) - 1,cOldimage)
      nRow := nB
      nCurrline := nBottline
    case nKey == pENTER
      nKeyflag := pENTER
      xRetval := nCurrline
      // store offset - always 1 in this menu system
      nOffset := 1
      exit
    otherwise  // pressed a letter
      restscreen(nRow, nCol, nRow, ;
                 nCol + len(aChx_arr[nCurrline,pCHX_STRING]) - 1,cOldimage)
      xRetval := ascan(aChx_arr,{|x| upper(substr(x[2],x[1],1)) == ;
                                     upper(chr(nKey))})
      if xRetval <> 0
        nKeyflag := pENTER
        // highlight this area
        nCurrline := xRetval
        nRow := nT + nCurrline - 1
        devpos(nRow,nCol)
        devout(aChx_arr[nCurrline,pCHX_STRING],;
               if(lLogic_arr[nCurrline],cClr_inv,cClr_nochx))
        exit
      endif
    endcase

  END PROCESS

  return(xRetval)


/* Function Menumake
   --------------------------------------
   Syntax:  Menumake(<cMenustr>[,cMenuclr][,nBrow])
   Example: Menumake test.mnu
   Returns: NIL
   Notes:   This program creates an array of menu options to be
            processed by the Menu() function.

            cMenustr      Formatted menu script file
            cMenuclr      Color string to store with the menu
            nBrow         Row for the menu boxes to appear on
*/
function Menumake(cMenustr, cMenuclr, nBrow)

  local cTempmenu1  as char   // Memo read in of menu script
  local xTmp        as usual
  local cMmstxt     as char   // Menu script stripped of CR/LF
  local nCount      as int    // This is for the FOR...NEXT stuff
  local xRetval

  cMenuclr := if(valtype(cMenuclr) == "U",setcolor(),cMenuclr)
  cClr_menu := cMenuclr
  nBrow := if(valtype(nBrow) == "U",2,val(nBrow))
  nBoxrow := nBrow
  if pcount() == 0
    ?? chr(7)
    ? "No file to process!"
    xRetval := NIL
  else
    // did they pass a file name, or a menu string?
    if ".MNU" $ upper(cMenustr)
      if !file(cMenustr)
        ?? chr(7)
        ? "No file to process!"
        xRetval := NIL
      else
        cTempmenu1 := memoread(alltrim(cMenustr))
        * get rid of spaces
        xTmp := mlcount(cTempmenu1,80)
        cMmstxt := ""
        for nCount := 1 to xTmp
          cMmstxt= cMmstxt+alltrim(memoline(cTempmenu1,80,nCount))
        next
        cTempmenu1 := ""
        // Now translate CR/LF to ""
        cMmstxt= strtran(cMmstxt,chr(13)+chr(10),"")
        xRetval := Txt2menu(cMmstxt)
      endif
    else
      xRetval := Txt2menu(cMenustr)
    endif
  endif

  return(xRetval)

/* Function Txt2menu
   --------------------------------------
   Syntax:  Txt2menu(<cString>)
   Example: Txt2menu("SAMPLE.mnu")
   Returns: reference to a properly created array
   Notes:   Handles converting the menu script
            into the internal menu format

            This function DOES NOT support error checking!  The MENUS
            String is presumed syntactically correct

            Txt2Menu() follows the building rules set down in the chapter
            on MenuDemo in the User's Guide - for version 1.2, note that
            all choices on all menus are available

            Parameters
            ==========
            cString       Formatted menu script file, stripped of spaces
                          and carriage return/line feeds
*/
static function Txt2menu(cString)

  local x := 0               as int
  local y := 0               as int
  local z := 0               as int
  local i := 1               as int
  local aRetarray            as array // Menu array
  local cTextstr             as char
  local bAction              as block // The block to perform a choice made
  local nElecntr := 0        as int
  local nWidest := 0         as int
  local nStartcol := nBoxcol as int
  local nPrior               as int
  local aTmparr := {}        as array
  local nMarker              as int

  aRetarray := {}  // initialize the return array
  // For the level that we are on, add four arrays, and two nulls
  // see above for explanation of the elements
  aadd(aRetarray,{})
  aadd(aRetarray,{})
  aadd(aRetarray,{})
  aadd(aRetarray,{})
  // ele 5
  aadd(aRetarray,"")
  // ele 6
  aadd(aRetarray,"")
  // process all characters
  for i := 1 up to len(cString)

    // if a menu underneath, get the text, then the bBlock/array
    // i             z
    // ~*Transactions^\   - The `*' marks the NEXT letter to be the one
    //                      highlighted.  If not present, char 1 is assumed
    //
    // cTextstr := from i+1 through z-1
    z += at("^",substr(cString,i))
    cTextstr := substr(cString,i+1,z-(i+1))
    // see if they have a number inserted for the character of the
    // text string to be the `hot letter'
    nMarker := at("*",cTextstr)
    aTmparr := {}
    aadd(aTmparr,if(nMarker == 0,1,nMarker))
    // get rid of nMarker
    if nMarker > 0
      cTextstr := stuff(cTextstr,nMarker,1,"")
    endif
    aadd(aTmparr,cTextstr)
    // Now find start of the bBlock
    do while substr(cString,z+1,1) == " "
      ++z
    enddo
    // get counter to position of either a bBlock start (`{', or menu `\')
    //               zi
    // ~*Transactions^\[~Orders{||GETORD()}\
    //
    i := z + 1
    // Add to current menu array
    aadd(aRetarray[pCHX_ARR],aTmparr)

    nWidest := max(nWidest,len(cTextstr))
    if len(aRetarray[pCHX_ARR]) > 1
      // Keep the counter `nPrior' up to date with the col. position
      // of the previous array element.
      //
      // note the index - three elements, one for the choice array,
      // then one to get to the right choice, and the second element, which
      // is the text for that choice
      nPrior := len(aRetarray[pCHX_ARR,len(aRetarray[pCHX_ARR])-1,2])
    else
      nPrior := 0
    endif
    ++nElecntr
    // Now see if there is a bBlock, and if so, compile it.  Remember, i
    // is either at a code bBlock, or menu level
    if substr(cString,i,1) == "{"  // Start of a code block
      // Are we moving over to another main menu bar choice?
      if lNextbar
        lNextbar := pFALSE
        // If this is the next main menu bar choice, col is #defined and this
        // is used to initialize `nStartcol' on subsequent, recursive calls
        // to Txt2menu
        nBoxcol += nPrior + pMAIN_BAR_SPACE
      endif
      z += at("\",substr(cString,i))
      //                   i            z
      // ~Inventory Orders^{||ORDTRAN()}\
      //          1         2         3
      // 12345678901234567890123456789012
      bAction := &(substr(cString,i,z-(i+1)+1))
    else
      // start of another array - get to the beginning menu box character
      ++i
      //              z i
      // ~Transactions^\[~Choice^{||CHOICE()}\~Choice2^{||Choice2()}\]
      // 1234567890123456789012345678901234567890123456789012345678901
      //          1         2         3         4         5         6
      //
      // Where is the companion `]' character for THIS `['?
      // We add 2 to z, b/c z is currently 2 back from i
      z += GetArrEnd(substr(cString,i)) + 2
      //                i                                            z
      // ~Transactions^\[~Choice^{||CHOICE()}\~Choice2^{||Choice2()}\]
      // 1234567890123456789012345678901234567890123456789012345678901
      //          1         2         3         4         5         6
      if lNextbar
        lNextbar := pFALSE
        nBoxcol += nPrior + 3
      elseif nLevel == 0  // Leave the box col alone if coming from 0
      else
        nBoxcol += 2
      endif
      ++nLevel
      nBoxrow += 2
      cTextstr := substr(cString,i+1,z-i-1)
      bAction := Txt2menu(cTextstr)
    endif
    lNextbar := if(nLevel == 0,pTRUE,pFALSE)
    //
    aadd(aRetarray[pFUNC_ARR],bAction)
    // In version 1.2, all menu options are accessible to users
    aadd(aRetarray[pLOGIC_ARR],pTRUE)
    i := z
    // The NEXT loop will increase it one past z
    //                                      zi
    // ~Transactions^\[~Choice^{||CHOICE()}\]~Choice2^{||Choice2()}\

  next
  // Now set the color
  aRetarray[pCOLOR_ELE] := cClr_menu
  // Now create the array for the numbers
  aadd(aRetarray[pNUM_ARR],nElecntr)
  aadd(aRetarray[pNUM_ARR],nWidest)
  aadd(aRetarray[pNUM_ARR],nBoxrow)
  aadd(aRetarray[pNUM_ARR],nStartcol)
  aadd(aRetarray[pNUM_ARR],1) // Initial element
  aadd(aRetarray[pNUM_ARR],1) // Relative offset element
  nBoxrow -= 2
  if nLevel <> 1 // not going back to 0
    nBoxcol -= 2
  endif
  --nLevel

  return(aRetarray)

/* Function GetArrEnd
   --------------------------------------
   Syntax:  GetArrEnd(<cString>)
   Example: GetArrEnd(tmp)
   Returns: The end position in <cString> for the next array def.
   Notes:
*/
static function GetArrEnd(cString)

  local nRight := 0  as int    // nRight   => Locates `]' characters
  local nLeft  := 0  as int    // nLeft   => Locates `[' characters
  local nLc    := 0  as int    // lc  => Counts all `[' matches
  local nRc    := 0  as int    // rc  => Counts all `]' matches
  local nPos   := 0  as int    // pos => Master count of characters
  local nTemp        as int

  while pTRUE
    // Now check for another `[' before the `]'.  If there is one
    // there, then there must be a nested array
    nRight := at("]",cString)
    nLeft := at("[",substr(cString,1,nRight))
    nPos += nRight
    nRc += if(nRight>0,1,0)

    if nLeft > 0    // Keep looping through until all "['s" are found
      nTemp := nLeft
      while nTemp > 0
        nLc++  // increase b/c we hit a left character
        nTemp := at("[",substr(cString,nLeft+1,nRight-nLeft+1))
        nLeft += nTemp
      enddo
    endif

    if nRc == nLc         // At this point, if rc == lc, we are done!
      exit
    endif
    cString := substr(cString,nRight+1)
  end

  return(nPos-1)          // return less 1, b/c of 0 based

// End of File: DBPMFunc.prg
