home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / GSDBASE.ZIP / GS_DB_FL.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-01-08  |  8.9 KB  |  374 lines
  1. unit GS_DB_FL;
  2.  
  3. {      GS_DB_FL Copyright (c)  Richard F. Griffin
  4.  
  5.        8 January 1990
  6.  
  7.        102 Molded Stone Pl
  8.        Warner Robins, GA  31088
  9.  
  10.        -------------------------------------------------------------
  11.        This unit handles the objects for all dBase III fields,
  12.        including memo (.DBT) fields.
  13.  
  14. }
  15.  
  16. interface
  17. uses GS_dBase, printer;
  18.  
  19. const
  20.    GS_dBase_MaxMemoBytes = 16384;
  21.    GS_dBase_MaxMemoRec   = 512;
  22.  
  23.  
  24. type
  25.    GS_dBase_FldPtr = ^ GS_dBase_Field;
  26.  
  27.    GS_dBase_FL = object
  28.       Loc_Field   : GS_dBase_FldPtr;
  29.       Loc_Record  : GS_dBase_dRec;
  30.       OffSet      : Integer;
  31.       procedure Init(LF, LR : pointer);
  32.       function FieldName : string;
  33.       function FieldSize : integer;
  34.       function FieldType : char;
  35.    end;
  36.  
  37.    GS_dBase_FL_C = object(GS_dBase_FL)
  38.       function GetField : string;
  39.       procedure PutField(Arg : string);
  40.    end;
  41.  
  42.    GS_dBase_FL_I = object(GS_dBase_FL)
  43.       function GetField : longint;
  44.       procedure PutField(Arg : longint);
  45.    end;
  46.  
  47.    GS_dBase_FL_R = object(GS_dBase_FL)
  48.       function GetField : real;
  49.       procedure PutField(Arg : real);
  50.       function Decimals : integer;
  51.    end;
  52.  
  53.    GS_dBase_FL_D = object(GS_dBase_FL)
  54.       function GetField : string;
  55.       procedure PutField(Arg : string);
  56.    end;
  57.  
  58.    GS_dBase_FL_L = object(GS_dBase_FL)
  59.       function GetField : boolean;
  60.       procedure PutField(Arg : boolean);
  61.    end;
  62.  
  63.    GS_dBase_dMemo = ^GS_dBase_MemoRecord;
  64.    GS_dBase_MemoRecord = array [0..GS_dBase_MaxMemoBytes] of byte;
  65.  
  66.    GS_dBase_FL_M = object(GS_dBase_FL)
  67.       File_ptr   : ^file;
  68.       dbtError   : integer;
  69.       dbtOK      : boolean;
  70.       Memo_Store : GS_dBase_MemoRecord;
  71.       Memo_Width : integer;
  72.       Memo_Lines : integer;
  73.       function GetField : string;
  74.       function GetMemo(linenum : integer) : string;
  75.       procedure Init(LF, LR : pointer);
  76. {      procedure PutField;}
  77.    end;
  78.  
  79. implementation
  80.  
  81. procedure GS_dBase_FL.Init(LF, LR : pointer);
  82. begin
  83.    Loc_Field := LF;
  84.    Loc_Record := LR;
  85. end;
  86.  
  87. procedure GS_dBase_FL_M.Init(LF, LR : pointer);
  88. begin
  89.    Memo_Width := 50;
  90.    Memo_Lines := 0;
  91.    GS_dBase_FL.Init(LF, LR);
  92. end;
  93.  
  94.  
  95. function GS_dBase_FL.FieldName : string;
  96. var
  97.    i,j : integer;
  98.    k   : byte;
  99.    data : string[32];
  100. begin
  101.    k := 0;
  102.    j := 11;
  103.    move(Loc_Field^.FieldName, data[1], j);
  104.    for i := 1 to j do
  105.       if data[i] <> #0 then k := i;
  106.    data[0] := char(k);
  107.    FieldName := data;
  108. end;
  109.  
  110. function GS_dBase_FL.FieldType : char;
  111. begin
  112.    FieldType := Loc_Field^.FieldType;
  113. end;
  114.  
  115. function GS_dBase_FL.FieldSize : integer;
  116. begin
  117.    FieldSize := Loc_Field^.FieldLen;
  118. end;
  119.  
  120.  
  121.  
  122. function GS_dBase_FL_C.GetField : string;
  123. var
  124.    i,j : integer;
  125.    data : string[255];
  126. begin
  127.    j := Loc_Field^.FieldLen;
  128.    move(Loc_Record^, data[1], j);
  129.    data[0] := char(j);
  130.    GetField := data;
  131. end;
  132.  
  133. function GS_dBase_FL_D.GetField : string;
  134. var
  135.    i,j : integer;
  136.    k   : byte;
  137.    data : string[10];
  138. begin
  139.    move(Loc_Record^[4], data[1], 2);
  140.    move(Loc_Record^[6], data[4], 2);
  141.    move(Loc_Record^[2], data[7], 2);
  142.    data[3] := '/';
  143.    data[6] := '/';
  144.    data[0] := #8;
  145.    GetField := data;
  146. end;
  147.  
  148. function GS_dBase_FL_L.GetField : boolean;
  149. var
  150.    data : char;
  151. begin
  152.    data := char(Loc_Record^[0]);
  153.    if data in ['T','t','Y','y'] then GetField := true
  154.       else GetField := false;
  155. end;
  156.  
  157. function GS_dBase_FL_I.GetField : longint;
  158. var
  159.    i,j : integer;
  160.    r   : longint;
  161.    data : string[32];
  162. begin
  163.    j := Loc_Field^.FieldLen;
  164.    move(Loc_Record^, data[1], j);
  165.    data[0] := char(j);
  166.    val(data, r, i);
  167.    GetField := r;
  168. end;
  169.  
  170. function GS_dBase_FL_R.GetField : real;
  171. var
  172.    i,j : integer;
  173.    r   : real;
  174.    data : string[32];
  175. begin
  176.    j := Loc_Field^.FieldLen;
  177.    move(Loc_Record^, data[1], j);
  178.    data[0] := char(j);
  179.    val(data, r, i);
  180.    GetField := r;
  181. end;
  182.  
  183. function GS_dBase_FL_R.Decimals : integer;
  184. begin
  185.    Decimals := Loc_Field^.FieldDec;
  186. end;
  187.  
  188.  
  189. Function GS_dBase_FL_M.GetField : string;
  190. const
  191.    EOFMark : byte = $1A;
  192.  
  193. var
  194.    cnt,
  195.    lCnt,
  196.    mCnt  :  longint;
  197.    Result    : integer;
  198.    done : boolean;
  199.    i,j : integer;
  200.    loc : longint;
  201.    data : string[32];
  202.    Mem_Block : array [0..512] of byte;
  203. BEGIN                       { Get Memo Field }
  204.    GetField := '   memo   ';
  205.    j := Loc_Field^.FieldLen;
  206.    move(Loc_Record^, data[1], j);
  207.    data[0] := char(j);
  208.    val(data, loc, i);
  209.    Memo_Lines := 0;
  210.    if (loc = 0) or (i <> 0) then
  211.    begin
  212.       Memo_Store[0] := EOFMark;
  213.       exit;
  214.    end;
  215.    done := false;
  216.    cnt := 0;
  217.    lCnt := 0;
  218.    {$I-} Seek(File_ptr^,loc); {$I+}
  219.    dbtError := IOResult;
  220.    dbtOK := (dbtError = 0);
  221.    IF dbtError = 0 THEN
  222.    BEGIN
  223.       while not done do
  224.       begin
  225.          {$I-} BlockRead(File_ptr^,Mem_Block,1, Result); {$I+}
  226.          dbtError := IOResult;
  227.          dbtOK := (dbtError = 0);
  228.          if not dbtOK then exit;
  229.          mCnt := 0;
  230.          while (mCnt < 512) and (done = false) do
  231.          begin
  232.             if lCnt > Memo_Width then
  233.             begin
  234.                i := cnt;
  235.                dec(cnt);
  236.                if (Mem_Block[mCnt] <> $20) and
  237.                   (Mem_Block[mCnt] <> $2D) then
  238.                       while (Memo_Store[cnt] <> $20) and
  239.                             (Memo_Store[cnt] <> $2D) and
  240.                             (lCnt > 0) do
  241.                          begin
  242.                             dec(cnt);
  243.                             dec(lCnt);
  244.                          end;
  245.                inc(cnt);
  246.                if (lCnt = 0) or (cnt > i) then cnt := i;
  247.                if cnt <> i then
  248.                   for j := i downto cnt do Memo_Store[j+1] := Memo_Store[j];
  249.                Memo_Store[cnt] := $8A;
  250.                inc(i);
  251.                lCnt := i - cnt;
  252.                cnt := i;
  253.                inc(Memo_Lines);
  254.             end;
  255.             case Mem_Block[mCnt] of
  256.                $1A : done := true;
  257.                $8D,
  258.                $0A : begin
  259.                      end;
  260.                $0D : begin
  261.                         if (cnt > 0) and
  262.                            (Memo_Store[cnt-1] = $8A) then dec(cnt);
  263.                         Memo_Store[cnt] := $0A;
  264.                         inc(cnt);
  265.                         lCnt := 0;
  266.                         inc(Memo_Lines);
  267.                      end;
  268.                $20 : begin
  269.                         if (cnt = 0) or
  270.                            (Memo_Store[cnt-1] <> $8A) then
  271.                         begin
  272.                            Memo_Store[cnt] := Mem_Block[mCnt];
  273.                            inc(cnt);
  274.                            inc(lCnt);
  275.                         end;
  276.                      end;
  277.                else
  278.                begin
  279.                   Memo_Store[cnt] := Mem_Block[mCnt];
  280.                   inc(cnt);
  281.                   inc(lCnt);
  282.                end;
  283.             end;
  284.             inc(mCnt);
  285.          end;
  286.       END;
  287.       if cnt > 0 then
  288.          if (Memo_Store[cnt-1] <> $0A) and
  289.             (Memo_Store[cnt-1] <> $8A) then inc(Memo_Lines);
  290.       Memo_Store[cnt] := EOFMark;
  291.    end;
  292.    dbtOK := (dbtError = 0);
  293. END;                        { Get Memo Field }
  294.  
  295. procedure GS_dBase_FL_C.PutField(Arg : string);
  296. var
  297.    i,j : integer;
  298. begin
  299.    j := Loc_Field^.FieldLen;
  300.    FillChar(Loc_Record^, j, ' ');
  301.    i := length(Arg);
  302.    Move(Arg[1], Loc_Record^, i);
  303. end;
  304.  
  305. procedure GS_dBase_FL_D.PutField(Arg : string);
  306. var
  307.    i,j : integer;
  308.    valu : string[2];
  309. begin
  310.    j := Loc_Field^.FieldLen;
  311.    FillChar(Loc_Record^, j, ' ');
  312.    Move(Arg[1], Loc_Record^[4], 2);
  313.    Move(Arg[4], Loc_Record^[6], 2);
  314.    Move(Arg[7], Loc_Record^[2], 2);
  315.    valu := '19';
  316.    Move(valu[1], Loc_Record^, 2);
  317. end;
  318.  
  319. procedure GS_dBase_FL_L.PutField(Arg : Boolean);
  320. var
  321.    valu : string[1];
  322. begin
  323.    if Arg then valu := 'T' else valu := 'F';
  324.    Move(valu[1], Loc_Record^, 1);
  325. end;
  326.  
  327. procedure GS_dBase_FL_I.PutField(Arg : LongInt);
  328. var
  329.    i,j : integer;
  330.    valu : string[64];
  331. begin
  332.    j := Loc_Field^.FieldLen;
  333.    Str(Arg:j, valu);
  334.    Move(valu[1], Loc_Record^, j);
  335. end;
  336.  
  337. procedure GS_dBase_FL_R.PutField(Arg : real);
  338. var
  339.    i,j : integer;
  340.    valu : string[64];
  341. begin
  342.    j := Loc_Field^.FieldLen;
  343.    Str(Arg:j:Decimals, valu);
  344.    Move(valu[1], Loc_Record^, j);
  345. end;
  346.  
  347.  
  348. function GS_dBase_FL_M.GetMemo(linenum : integer) : string;
  349. var
  350.   P_Line : string[255];
  351.   mCnt : longint;
  352.   Cnt,lcnt,
  353.   i, j, k, l : integer;
  354. begin
  355.    cnt := 0;
  356.    lCnt := 1;
  357.    P_Line := '';
  358.    while (lcnt <> linenum) and (memo_store[cnt] <> $1A) do
  359.    begin
  360.       if (Memo_Store[cnt] = $0A) or (Memo_Store[cnt] = $8A) then inc(lcnt);
  361.       if (memo_store[cnt] <> $1A) then inc(cnt);
  362.    end;
  363.    while (memo_store[cnt] <> $1A)  and
  364.          (Memo_Store[cnt] <> $0A) and
  365.          (Memo_Store[cnt] <> $8A) do
  366.    begin
  367.       P_Line := P_Line + chr(Memo_Store[cnt]);
  368.       inc(cnt);
  369.    end;
  370.    GetMemo := P_Line;
  371. end;
  372.  
  373. end.
  374.