dBase programming!

I’m stoked! Looking through some old hard drives, I found some dBase IV code from the 1990s!

After college, I wrote database programs for Ashton Tate’s dBase IV (https://en.wikipedia.org/wiki/DBase), then acquired by Borland, using Borland’s dBase Compiler 2.0 for DOS to create standalone executable applications for healthcare. Unfortunately, the particular programs were too specialized to sustain the fledgling company.

Below are some routines written in the dBase language. As I recall, dBase IV also introduced limited SQL capability, but the applications I wrote continued to use the ISAM-style direct access methods (seek, skip, prev record access).


*-----------------------------------------------------------------------
*-- Name........: - MsgRow -
*-- Programmer..: Hanna Goodbar
*-- Date........: 06/12/1994
*-- Notes.......: Centers user-defined message on a row of the screen,
*--               fills in letter/highlights on demand. Optional:
*--               keys/highlights, color of message & keys/highlights,
*--               row of the screen to display.
*--                 The message is centered on the specified row. If
*--               none is specified, the bottom row of the screen is
*--               used. This shades out the bottom row so the message
*--               stands out.
*--                 The four parameters may specified in any order. The
*--               first character of each parameter must be one of
*--               the following: m = message to center
*--                              k = keypresses or highlight
*--                              c = color to use: message,key
*--                              r = row to display on (bottom def.)
*--                 The "m" parameter is the message. You can insert
*--               a highlight or keypress by inserting the degree
*--               symbol {CHR(248)}. For each degree symbol in the
*--               message, there should be a corresponding key in the
*--               "k" parameter. The color of the message and keys are
*--               determined by the optional "c" parameter. The message
*--               color comes first, followed by the key color. Tell
*--               which row to display on with the "r" parameter, but
*--               keep in mind that dBase screens are 0-based (0-24,
*--               0-42, 0-49 for VGA screens).
*--                 The "m|k|c|r" may be in upper or lower case. There
*--               is no space between "m|k|c|r" and the rest of the
*--               message; see the below examples for more info.
*--                 If no "c" parameter is specified, MsgRow uses
*--               default colors.
*--                 Assumes a color monitor. Assumes screen width
*--               of 80.
*-- Written for.: dBASE IV, 2.0
*-- Rev. History: 06/12/1994 - initial programming
*--               06/14/1994 - rewrite for optional parameters & color
*--               07/17/1994 - added optional row parameter
*-- Calls.......: ATCOUNT2() - counts number of times a string appears
*--                            in another string
*--               ATRIM()    - full string trimming
*--               SHEIGHT()  - gets screen height
*-- Called by...: Any
*-- Usage.......: do MsgRow with "cParm1"[, ["cParm{2..4}"]]
*-- Example.....: do MsgRow with "mPress ° to continue", "kany key", ;
*--                              "cgr+/b,g+/b", "r20"
*--               do MsgRow with "mPress ° to move on", "k&cMovKey."
*-- Returns.....: String centered on a row, with keys inserted
*-- Parameters..: cParam{1..4} - chrarcter parameters in any order:
*--               "m" + text of message using {248} "°" as placeholders
*--                     for keys to insert ("mPress ° or ° to go on");
*--               "k" + text to insert into each ° symbol, seperated by
*--                     a comma ("kEnter,Esc");
*--               "c" + text for colors to use for message and key
*--                     areas, given in standard color format
*--                     ("cw+/b,gr+/b") [optional];
*--               "r" + text numbers representing row to display on,
*--                     defaults to bottom row ("r10" for row 10)
*--                     [optional]
*-----------------------------------------------------------------------
PROCEDURE MsgRow
   parameters cParam1, cParam2, cParam3, cParam4
   private aKeys, cClr, cKTst, cKeys, cMTst, cMess, ckClr, cmClr, ;
           coClr, cpCode, cpTst, csn, n, nCen, nPCount, nRep, nRow, ;
           nScrHt

   *-- Define variables
   *-- aKeys array declared dynamically
   m->cClr    = ""
   m->cKTst   = ""
   m->cKeys   = ""
   m->nMTst   = ""
   m->cMess   = ""
   m->ckClr   = ""
   m->cmClr   = ""
   m->coClr   = set( "ATTRIBUTES" )  && old colors
   m->cpCode  = ""
   m->cpTst   = ""
   m->n       = 1
   m->nCen    = 0
   m->nPCount = pcount()
   m->nRep    = 0
   m->nRow    = -1
   m->nScrHt  = SHeight()  && screen height
   m->csn     = atrim( str( m->n ))

   *-- User-configurable constants
   m->cRep    = chr(248)  && replacement char (degree: °)
   *-- Original options --> keep
   m->cBakCol = "b"  && background color def -  blue
   m->cMsgCol = "gb+"  && message color def - bri cyan
   m->cKeyCol = "g+"  && key color def - bright green
   m->cOldCol = "n"  && old message line def - black

   *-- Gather supplied parameters
   do while m->n <= m->nPCount
      m->cpTst  = cParam&csn.
      m->cpCode = upper( left( cParam&csn., 1 ))
      do case
         case m->cpCode = "M"
              m->cMess  = substr( cParam&csn., 2 )
         case m->cpCode = "K"
              m->cKeys  = substr( cParam&csn., 2 )
         case m->cpCode = "C"
              if at( ",", cParam&csn. ) = 0
                 m->cmClr = substr( cParam&csn., 2 )
              else
                 m->cmClr = substr( cParam&csn., 2, ;
                            at( ",", cParam&csn.) - 2 )
                 m->ckClr = substr( cParam&csn., ;
                            at( ",", cParam&csn. ) + 1 )
              endif
         case m->cpCode = "R"
              m->nRow = val( substr( cParam&csn., 2 ))
      endcase
      m->n   = m->n + 1
      m->csn = atrim( str( m->n ))
   enddo
   m->nScrHt = iif( m->nRow = -1, m->nScrHt, m->nRow )
   m->cClr = iif( "" # m->cmClr, "&cmClr.", "&cMsgCol./&cBakCol." )
   set color to &cClr.
   @ m->nScrHt, 0 fill to m->nScrHt, 79 color &cOldCol./&cBakCol.
   if "" # m->cMess
      m->cMTst = m->cMess
   endif
   if "" # m->cKeys
      m->cKTst = m->cKeys
      m->nRep  = atcount2( "°", m->cMTst )
      m->nCen  = ( 80 - ( len( m->cMTst ) + 2 - m->nRep + len( m->cKTst ) - ;
                 atcount2( ",", m->cKTst ))) / 2
      m->n     = 1
      declare    aKeys[ m->nRep, 2 ]
      do while m->n <= m->nRep
         if len( m->cKTst ) > 0
            aKeys[ m->n, 1 ] = at( "°", m->cMTst ) - 1
            if at( ",", m->cKTst ) > 0
               aKeys[ m->n, 2 ] = substr( m->cKTst, 1, ;
                                  at( ",", m->cKTst ) - 1 )
            else
               aKeys[ m->n, 2] = m->cKTst
            endif
            m->cKTst = substr( m->cKTst, at( ",", m->cKTst ) + 1 )
            m->cMTst = stuff( m->cMTst, at( "°", m->cMTst ), 1, ;
                       replicate( " ", len( aKeys[ m->n, 2 ] )))
         endif
         m->n = m->n + 1
      enddo
   else
      if type( "cMTst" ) = "C"
         m->nCen  = (80 - ( len( m->cMTst ) + 2 ))/2
      endif
   endif
   if type( "cMTst" ) = "C"
      @ m->nScrHt, m->nCen say " " + m->cMTst + " "
   endif
   m->cClr = iif( "" # m->ckClr, "&ckClr.", "&cKeyCol./&cBakCol." )
   set color to &cClr.
   if type( "cKeys" ) = "C"
      m->n = 1
      do while m->n <= m->nRep
         @ m->nScrHt, m->nCen + 1 + aKeys[ m->n, 1 ] say aKeys[ m->n, 2 ]
         m->n = m->n + 1
      enddo
   endif
   set color to &coClr.

RETURN
*-- EoP: MsgRow


*------------------------------------------------------------------------------
*--                               - AtCount2 -
*------------------------------------------------------------------------------
*-- Counts the occurences of one string inside another
*--
*-- PARAMETERS
*--    CFINDSTR = string to look for   "SS"
*--    CBIGSTR  = in this string       in "MISSISSIPPI"
*--
*-- VARIABLES
*--    local copies of CFINDSTR, CBIGSTR
*--    NCOUNT = number of times CFINDSTR is in CBIGSTR
*--    NX     = counter
*--
*-- 11 Jan 1995    Initial programming, based on ATCOUNT(), but doesn't use
*--                string function SUBSTR(), which made my error handler pop up
*--                (error 62, SUBSTR() start point out of range)
*------------------------------------------------------------------------------
FUNCTION   AtCount2
PARAMETERS cFindStr, cBigStr
PRIVATE    cFindStr, cBigStr, nCount, nX
   m->nX = 1
   m->nCount = 0
   do while m->nX <= 254
      if at( m->cFindStr, m->cBigStr, m->nX ) # 0
         m->nCount = m->nCount + 1
         m->nX = m->nX + 1
      else
         exit
      endif
   enddo
RETURN m->nCount


*------------------------------------------------------------------------------
*-- NAME..: - ATrim -
*-- BY....: Hanna Goodbar
*-- ACTION: Completely trims edges of a character string
*-- PARAMS: CATRSTRNG = string to be trimmed
*-- VARS..: CATSTRNG
*--         CATTRIMMED = copy of CATRSTRING
*-- RETS..: CATTRIMMED, trimmed string
*-- DATE..: 12 Jun 1994  Initial programming
*--         12 Jul 1994  Oops, changed to reflect private vars, not parameters
*-- NOTE..: Public domain.
*------------------------------------------------------------------------------
FUNCTION   ATrim
PARAMETERS cATRStrng
PRIVATE    cATTrimmed, cATRStrng
   m->cATTrimmed = m->cATRStrng
   m->cATTrimmed = ltrim( rtrim( m->cATTrimmed ))
RETURN m->cATTrimmed


*------------------------------------------------------------------------------
*-- NAME..: - SHeight -
*-- BY....: Hanna Goodbar
*-- ACTION: Find the height of the screen (number of rows)
*-- RETS..: nSHSHt = actual screen height - 1 (since dBase screens are 0 to
*--                  X); mono monitors have 25 rows (0-24)
*-- VARS..: cSHSType = type of display
*--         nSHSHt = height of screen, 0 based
*-- DATE..: 12 Jun 1994  Extracted from a screen background function
*--         21 Jun 1994  Changed to IIF to execute faster
*-- NOTE..: Public domain. Donated to the DUFLP library.
*------------------------------------------------------------------------------
FUNCTION SHeight
PRIVATE  cSHSType, nSHSHt
   m->cSHSType = set( "DISPLAY" )
   m->nSHSHt = iif( m->cSHSType="MONO", 25, val( right( m->cSHSType, 2 )))
   m->nSHSHt = m->nSHSHt - 1
RETURN m->nSHSHt

Finally, here is a preliminary Prism highlighter for dbase and prg files. The prg was a widely used extension for dBase program source code. The keywords may be incomplete. As I examine my dBase sources, the language file will be updated accordingly.

Prism.languages.dbase = {
  // dBase language definition. v0.3, 20170115, Hanna Goodbar
  // Related extensions: prg (dBase program), prs (dBase SQL program)
  'comment': [
    {
      'pattern': /(&&.+)/
    },
    {
      // Comments: at the beginning of a line or on a line preceded by whitespace only.
      // Thanks dBase for making the asterisk both the multiplication symbol and a comment marker.
      'pattern': /(^|^\s+?)\*.+/,
      lookbehind: true
    },
    {
      // Oh yeah, a line beginning with NOTE is also a comment.
      'pattern': /(^|^s+?)NOTE.+/i,
      lookbehind: true
    }
  ],
  'directive': {
    'pattern': /(#\s*)\b(define|else|endif|if|ifdef|ifndef|include|undef)\b/i,
    lookbehind: true,
    alias: 'keyword'
  },
  'string': /"(?:""|[!#$%&'()*,\/:;<=>?^_ +\-.A-Z\d])*"/i,
  'function': /\b\w+(?=\()/,
  'variable': [
    {
      // Variables: m->blah
      'pattern': /(m->\w+)/i
    },
    {
      // Arrays: blah[x]
      'pattern': /\b\w+(?=\[)/
    }
  ],
  'keyword': /\b(\?\??\??|\@|(de)?activate|all|append|application|array|assist|average|bar|begin|bottom|box|browse|calculate|call|cancel|case|change|clear|color|close|command|compile|continue|convert|copy|create|cursor|debug|declare|define|deleted?|dir|display|do|end(case|do|if)|edit|eject|else|end|environment|erase|error|escape|except|exit|export|extended|file|find|for|from|function|gets?|goto|go|help|history|if|import|(re)?index(es)?|input|insert|join|key|keyboard|label|list|load|locate|(un)?lock|logout|loop|macros?|memo|memory|menus?|modify|off?|on|order|otherwise|pack|pad|page|parameters|popups?|(end)?printjob|private|procedure|prompt|protect|public|query|quit|read|readerror|recall|record|release|rename|replace|report|reset|restore|resume|retry|return|rollback|run|save|say|(end)?scan|seek|select(ion)?|set|save|screens?|show|skip|sort|status|store|structure|sum|suspend|tag|talk|text|to|top|total|transaction|type|typeahead|update|use|users|view|wait|when|while|windows?|with|zap)\b/i,
  'number': /\b([\d]+)\b/i,
  'symbol': [
    /(&\w+[.])/
  ],
  'boolean': /(\.[t|f]\.)/i,
  'operator': [
    /\.and\.|\.or\.|\.not\./i,
    /[<>+-\/#\$=^\*\*?]/
  ],
  'punctuation': /[()\[\]{}.,;]/
};
Prism.languages.prg = Prism.languages.dbase;
Prism.languages.prs = Prism.languages.dbase;