$CPU 8086          ' make compatible with XT systems
$LIB ALL OFF       ' turn off all PowerBASIC libraries
$ERROR ALL OFF     ' turn off all PowerBASIC error checking
$OPTIMIZE SIZE     ' optimize for smaller code
 $COMPILE UNIT      ' compile to a UNIT (.PBU)
'$COMPILE EXE       ' compile to a UNIT (.PBU)

DEFINT A-Z         ' Required for all numeric functions, forces PB to not
                   ' include floating point in UNIT (makes it smaller)
'/*------------------------------------------------------------------*/
$CODE SEG "MLIB1"
'/*------------------------------------------------------------------*/
DECLARE FUNCTION FORMAT(BYVAL NUM AS EXT, BYVAL BEF AS INTEGER, BYVAL AFT AS INTEGER) AS STRING
'/*------------------------------------------------------------------*/
'/* Written By Mark McDonald - From MLIB.PBL
'/* Always use Double Precision var# variables for record addressing
'/*------------------------------------------------------------------*/
' DBSEEK FB,RNBR#,LRECL,OFFSET
'     dBase record Seek.
'     Positions file pointer for subsequent GET$ or PUT$ operation.
'     You need to pass the file buffer (FB), desired record number (RNBR#),
'     Logical Record Length (LRECL) and offset (OFFSET).
'     EXAMPLE:  DBSEEK 1,238,61,289
'/*------------------------------------------------------------------*/
    SUB DBSEEK(BYVAL FB,BYVAL RNBR#,BYVAL LRECL,BYVAL OFFSET) PUBLIC
'/*   --- Calculate Relative Byte Address ---*/
      RBA# = OFFSET + (RNBR#*LRECL) - LRECL
'/*   --- Position File Pointer ---*/
      SEEK #FB, RBA#
    END SUB
'/*------------------------------------------------------------------*/
' DBOPEN FB,FILENAME$,LRECL,NRECS#,OFFSET,DFD$()
'     dBASE Open.
'     Opens a dBASE III data file returning the size of each record (LRECL),
'     the number of records (NRECS#), the header offset (OFFSET) and
'     the field definitions in array DFD$() with the number of definitions
'     in DFD$(0).
'       FB        = pass the file buffer to be used.
'       FILENAME$ = pass the dBASE file name typically "dbname.DBF".
'       LRECL     = Returned Logical Record Length or size of each data record.
'       NRECS#    = Returned number of records stored in file.  Always use
'                   DBUPDATE routine after adding a record via PUT$.
'       OFFSET    = Returned size of the dBASE file header.  This is used to
'                   along with LRECL to calculate the proper relative
'                   Byte Address (RBA) for use with GET$ and PUT$.
'       DFD$()    = Returned array containing Data Record Format.
'                   Format:      Columns
'                                 1 - 11  = Field name
'                                12 - 12  = Field Type
'                                13 - 15  = Field Size
'                                16 - 18  = Number of Decimals.
'     EXAMPLE:  DBOPEN 1,"C:\CODE\DBASE.DBF",LRECL,NRECS#,OFFSET,FA$()
'               IF OFFSET > 1 THEN ...
'     If there is a problem with the open then offset will be set to
'     a negative number.
'/*------------------------------------------------------------------*/
    SUB DBOPEN(FB,FILENAME$,LRECL,NRECS#,OFFSET,FD$()) PUBLIC
      OFFSET = 0
'/*   --- Build File Name ---
      FILENAME$ = UCASE$(FILENAME$)
      IF INSTR(FILENAME$, ".") = 0 THEN FILENAME$ = FILENAME$ + ".DBF"
'/*    --- Does File Exist? ---
       IF DIR$(FILENAME$) = "" THEN
         OFFSET = -100
         EXIT SUB
       END IF
'/*   --- Open File ---
      OPEN FILENAME$ FOR BINARY ACCESS READ WRITE SHARED AS #FB
'/*   --- If Empty File Return Error Code 101 ---
      IF LOF(FB) = 0 THEN
        CLOSE #FB
        OFFSET = -101
        EXIT SUB
      END IF
'/*   --- Get Header ---
      GET$ #FB, 32, DBH$
'/*   --- Determine Version ---
      T = ASC(LEFT$(DBH$,1))
'/*   --- dBASE II File ---*/
      IF T = 2 THEN
        OFFSET = 520
        LRECL = CVI(MID$(DBH$,7,2))
        NRECS# = CVWRD(MID$(DBH$,2,2))
      END IF
'/*   --- dBASE III File ---*/
      IF T > 2 THEN
        OFFSET = CVWRD(MID$(DBH$,9,2))
        LRECL = CVWRD(MID$(DBH$,11,2))
        NRECS# = CVDWD(MID$(DBH$,5,4))
      END IF
    DBGETFD FB,LRECL,NRECS#,OFFSET,FD$()
    END SUB
'/*------------------------------------------------------------------*/
    SUB DBGETFD(FB,LRECL,NRECS#,OFFSET,FD$()) PUBLIC
'/*   --- Get Header ---
      SEEK #FB, 0
      GET$ #FB, 32, DBH$
'/*   --- Determine Data Base Type ---*/
      T = ASC(LEFT$(DBH$,1))
'/*   --- Calculate Size of Field Descriptions ---
'/*   --- dBASE II Format? ---
      IF T = 2 THEN
        SEEK #FB, 0
        GET$ #FB, 8, DBH$
        FDSIZE = OFFSET - 8
        GET$ #FB, FDSIZE, FD$
      END IF
'/*   --- dBASE III Format? ---*/
      IF T > 2 THEN
        FDNBR = ((OFFSET - 32) \32)
        FDSIZE = OFFSET - 32
        GET$ #FB, FDSIZE, FD$
      END IF
'/*   --- Put Field Data into Array --*/
      SP = 1
      FOR CNT = 1 TO FDNBR
        CT$ = ""
'/*     --- dBASE II? ---*/
        IF T = 2 THEN
'/*       --- Extract Record String ---*/
          TT$ = MID$(FD$,SP,16)
'/*       --- Get Field Name ---*/
          CT$ = CT$ + MID$(TT$,1,11)
'/*       --- Get Field Type ---*/
          CT$ = CT$ + MID$(TT$,12,1)
'/*       --- Get Field Size ---/*
          TD$ = MID$(TT$,13,1)
          CT$ = CT$ + FORMAT(CVBYT(TD$),3,0)
'/*       --- Get Decimal Count ---*/
          TD$ = MID$(TT$,16,1)
          SP = SP + 32
          CT$ = CT$ + FORMAT(CVBYT(TD$),3,0)
        END IF
'/*     --- dBASE III? ---*/
        IF T > 2 THEN
'/*       --- Extract Record String ---*/
          TT$ = MID$(FD$,SP,32)
'/*       --- Get Field Name ---*/
          CT$ = CT$ + MID$(TT$,1,11)
'/*       --- Get Field Type ---*/
          CT$ = CT$ + MID$(TT$,12,1)
'/*       --- Get Field Size ---/*
          TD$ = MID$(TT$,17,1)
          CT$ = CT$ + FORMAT(CVBYT(TD$),3,0)
'/*       --- Get Decimal Count ---*/
          TD$ = MID$(TT$,18,1)
          SP = SP + 32
          CT$ = CT$ + FORMAT(CVBYT(TD$),3,0)
        END IF
'/*     --- Put Into Array ---*/
        FD$(CNT) = CT$
      NEXT CNT
      FD$(0) = STR$(FDNBR)
    END SUB
'/*------------------------------------------------------------------*/
' DBUPDATE FB,NRECS#
'     dBase Update.
'     Updates the Number of Records field using NRECS# and updates the
'     last date updated fields in the header using the current system
'     date.
'     You should use this everytime you add a record to the data base
'     file or update a record.  If you don't you risk loosing your data.
'     EXAMPLE:  DBSEEK 1,10,LRECL,OFFSET
'               PUT$ 1,LRECL,T$
'               DBUPDATE 1,NRECS#
'
'               NRECS# = NRECS# + 1
'               PUT$ 1,LRECL,T$
'               DBUPDATE 1,NRECS#
'     NOTE:  dBASE header date YYMMDD is Year 2000 (Y2K) compliant.  Here's
'            why:  The first of Febuary 1997 is stored in the header as
'            61h02h01h.  The first of Febuary 2001 is stored as 64h02h01.
'            This means the valid range for the last updated field in the
'            header is 1900 through 2155 (00h-FFh + plus 1900).  This MLIB
'            sub-routine will correctly subtract 1900 before storing the
'            date.
'/*------------------------------------------------------------------*/
    SUB DBUPDATE(FB,NRECS#) PUBLIC
      SEEK #FB, 0
      GET$ #FB, 32, DBH$
      N$ = MKDWD$(NRECS#)
      Y = VAL(RIGHT$(DATE$,4))
      Y = Y - 1900
      M = VAL(LEFT$(DATE$,2))
      D = VAL(MID$(DATE$,4,2))
      D$ = CHR$(Y,M,D)
      MID$(DBH$,5,4) = N$
      MID$(DBH$,2,3) = D$
      SEEK #FB, 0
      PUT$ #FB, DBH$
    END SUB
'/*------------------------------------------------------------------*/
'   $INCLUDE "C:\CODE\MLIB\MLIB.INC"
'/* --- Correctly Open dBASE file and get needed info ---*/
'/*        +- Pass the file buffer you want to use
'/*        '         +- Pass the dos file name
'/*        '         '             +- Returns the record length
'/*        '         '             '     +- Returns the number of records
'/*        '         '             '     '      +- Returns the header offset needed for dbseek
'/*        '         '             '     '      '
'   DBOPEN 1,"C:\CODE\DBASE.DBF",LRECL,NRECS#,OFFSET
'   IF OFFSET < 1 THEN
'     PRINT "ERROR ERROR"
'   ELSE
'/*   --- Calculate offset and seek position ---*/
'     DBSEEK 1,NRECS#,LRECL,OFFSET
'/*   --- Use PowerBASIC's normal GET$ command to get data ---*/
'     GET$ #1,LRECL,T$
'     MID$(T$,1,5) = " MARK2"
'/*   --- Seek to NRECS#+1 to add a new record ---*/
'     DBSEEK 1,NRECS#+1,LRECL,OFFSET
'/*   --- Use PowerBASIC's normal PUT$ command to write data ---*/
'     PUT$ #1,T$
'   END IF
'/* --- Correctly update header with number of records & last update date ---*/
'   DBUPDATE 1, NRECS#+1
'/* --- Use Power BASIC's close command to close file.
'   CLOSE#1
'   PRINT T$
'   Y$ = GETKEY
'/*------------------------------------------------------------------*/