Power-Programmierung/CD1.mdf/modula2/library/btrieve/mod2btrv.mod

Text File | 1988-08-26 | 6KB | 154 lines

(*                                          *)
(*  Module Name: Mod2Btrv.MOD                                  *)
(*                                          *)
(*  Description: This is the Btrieve interface for JPI TopSpeed Modula-2.     *)
(*        This routine sets up the parameter block expected by          *)
(*        Btrieve, and issues interrupt 7B. It was created from         *)
(*        the TURXBTRV interface.                                        *)
(*                                          *)
(*  Synopsis:    STAT := BTRV (OP, POS.START, DATA.START, DATALEN,          *)
(*                 KBUF.START, KEY);                  *)
(*                  where                          *)
(*            OP is an integer,                      *)
(*            POS is a 128 byte array,                  *)
(*            DATA is an untyped parameter for the data buffer,     *)
(*            DATALEN is the integer length of the data buffer,     *)
(*            KBUF is the untyped parameter for the key buffer,     *)
(*            and KEY is an integer.                      *)
(*                                          *)
(*  Returns:    Btrieve status code (see Appendix B of the Btrieve Manual).   *)
(*                                          *)

IMPLEMENTATION MODULE Mod2BTRV;

  FROM SYSTEM IMPORT Registers, Ofs, Seg;
  FROM AsmLib IMPORT Intr;

  PROCEDURE BTRV(OP: INTEGER;
                 VAR POS, DATA: ARRAY OF BYTE;
                 VAR DATALEN: INTEGER;
                 VAR KBUF: ARRAY OF BYTE;
                 KEY: INTEGER): INTEGER;


    CONST
      PASCALID = 0AAAAH; (*Pascal language id*)

      VARID = 06176H; (*id for variable length records - 'va'*)

      BTRINT = 07BH;
      BTR2INT = 02FH;
      BTROFFSET = 00033H;
      MULTIFUNCTION = 0ABH;
      (*  ProcId is used for communicating with the Multi Tasking Version of          *)
      (*  Btrieve. It contains the process id returned from BMulti and should          *)
      (*  not be changed once it has been set.                               *)
      (*                                          *)

    VAR
      ProcId: INTEGER; (* initialize to no process id *)
      MULTI: BOOLEAN; (* set to true if BMulti is loaded *)
      VSet: BOOLEAN; (* set to true if we have checked for BMulti *)



    TYPE

      ADDR32 = RECORD (*32 bit address*)
                 OFFSET: INTEGER;
                 SEGMENT: INTEGER;
               END;

      BTRPARMS = RECORD
                   USERBUFADDR: ADDR32;         (*data buffer address*)
                   USERBUFLEN: INTEGER;         (*data buffer length*)
                   USERCURADDR: ADDR32;         (*currency block address*)
                   USERFCBADDR: ADDR32;         (*file control block address*)
                   USERFUNCTION: INTEGER;       (*Btrieve operation*)
                   USERKEYADDR: ADDR32;         (*key buffer address*)
                   USERKEYLENGTH: BYTE;         (*key buffer length*)
                   USERKEYNUMBER: BYTE;         (*key number*)
                   USERSTATADDR: ADDR32;        (*return status address*)
                   XFACEID: INTEGER;            (*language interface id*)
                 END;

      Result = Registers;

    VAR
      STAT: INTEGER; (*Btrieve status code*)
      XDATA: BTRPARMS; (*Btrieve parameter block*)
      REGS: Result; (*register structure used on interrrupt call*)
      DONE: BOOLEAN;
      BTRVResult: INTEGER;

  BEGIN
    VSet := FALSE;
    MULTI := FALSE;
    ProcId := 0;
    REGS.AX := 03500H+BTRINT;
    Intr(REGS,021H);
    IF (REGS.BX <> BTROFFSET) THEN (*make sure Btrieve is installed*)
       STAT := 20
    ELSE
      IF (NOT VSet) THEN (*if we haven't checked for Multi-User version*)
         REGS.AX := 03000H;
         Intr(REGS,021H);
         IF (CARDINAL(BITSET(REGS.AX) * BITSET(000FFH)) >= 3) THEN
            VSet := TRUE;
            REGS.AX := MULTIFUNCTION*256;
            Intr(REGS, BTR2INT);
            MULTI := (CARDINAL(BITSET(REGS.AX) * BITSET(000FFH)) = 0004DH);
         ELSE
            MULTI := FALSE
         END;
      END; (*make normal btrieve call*)
      WITH XDATA DO
        USERBUFADDR.SEGMENT := Seg(DATA);
        USERBUFADDR.OFFSET := Ofs(DATA); (*set data buffer address*)
        USERBUFLEN := DATALEN;
        USERFCBADDR.SEGMENT := Seg(POS);
        USERFCBADDR.OFFSET := Ofs(POS); (*set FCB address*)
        USERCURADDR.SEGMENT := USERFCBADDR.SEGMENT; (*set cur seg*)
        USERCURADDR.OFFSET := USERFCBADDR.OFFSET+38; (*set cur ofs*)
        USERFUNCTION := OP; (*set Btrieve operation code*)
        USERKEYADDR.SEGMENT := Seg(KBUF);
        USERKEYADDR.OFFSET := Ofs(KBUF); (*set key buffer address*)
        USERKEYLENGTH := BYTE(255); (*assume its large enough*)
        USERKEYNUMBER := BYTE(KEY); (*set key number*)
        USERSTATADDR.SEGMENT := Seg(STAT);
        USERSTATADDR.OFFSET := Ofs(STAT); (*set status address*)
        XFACEID := VARID; (*set language id*)
      END;
      REGS.DX := Ofs(XDATA);
      REGS.DS := Seg(XDATA);
      IF ( NOT MULTI) THEN (*MultiUser version not installed*)
         Intr(REGS, BTRINT)
      ELSE
         DONE := FALSE;
         REPEAT
              REGS.BX := ProcId;
              REGS.AX := 1;
              IF (REGS.BX <> 0) THEN
                 REGS.AX := 2
              END;
              INC(REGS.AX, (MULTIFUNCTION*256));
              Intr(REGS, BTRINT);
              IF (CARDINAL(BITSET(REGS.AX) * BITSET(000FFH)) = 0) THEN
                 DONE := TRUE
              ELSE
                 REGS.AX := 00200H;
                 Intr(REGS, 07FH);
                 DONE := FALSE;
              END;
        UNTIL (DONE);
        IF (ProcId = 0) THEN
           ProcId := REGS.BX
        END;
      END;
      DATALEN := XDATA.USERBUFLEN;
    END;
    BTRVResult := STAT;
    RETURN BTRVResult
  END BTRV;
END Mod2BTRV.