home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / GSDB25.ZIP / GS_FILEH.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-08-03  |  12.8 KB  |  484 lines
  1. unit GS_FileH;
  2.  
  3. {-----------------------------------------------------------------------------
  4. Changes:
  5.  
  6.       5 Jan 91 -  Corrected GS_FileWrite error in processing memo files
  7.                   greater than 64K.  Changed variable MovLth from type
  8.                   word to type longint.
  9.  
  10.       8 Apr 91 -  Removed GS_FileWrite code that attempted to append data
  11.                   to the cache buffer -- there are more opportunities for
  12.                   error than the benefits provided.
  13.  
  14.       5 May 91 -  Added GS_FileFindFiles routine to provide a user interface
  15.                   to select files that match the wildcard options passed.
  16.                   This will also allow the user to go to different drives
  17.                   or directories in search of a file.  Requires the calling
  18.                   routine to set a window prior to the call for the file
  19.                   selection to display in.  Also the caller must pass the
  20.                   wildcard string to match against, and a boolean argument
  21.                   to determine whether other drives/directories may be
  22.                   selected.
  23.  
  24.                   Added a drive table as GS_FileDrvTab.  This is a 26-element
  25.                   array (0-127) for each potential drive.  A 'P' is inserted
  26.                   for each actual drive.
  27.  
  28. ------------------------------------------------------------------------------}
  29.  
  30. interface
  31. uses
  32.    CRT,
  33.    Dos,
  34.    GS_Strng,
  35.    GS_Error;
  36.  
  37. var
  38.    GS_FileDrvTab      : array[0..127] of char;
  39.    GS_FileDrvCnt      : byte;
  40.  
  41.    BRCmd,
  42.    BWCmd,
  43.    IOAsk,
  44.    IORed,
  45.    IOWri,
  46.    IOPhy  : word;
  47.  
  48. Procedure GS_FileAssign(var dF : file; Fname : string; BufSize : longint);
  49. Procedure GS_FileClose(var dF : file);
  50. Procedure GS_FileErase(var dF : file);
  51. Function  GS_FileExists(var dF : file; Fname : string) : boolean;
  52. Procedure GS_FileRead(var dF : file; blk : longint; var dat; len : longint;
  53.                        var RtnRslt : word);
  54. Procedure GS_FileRename(var dF : file; FName : string);
  55. Procedure GS_FileReset(var dF : file; len : longint);
  56. Procedure GS_FileRewrite(var dF : file; len : longint);
  57. Function  GS_FileSize(var dF : file) : longint;
  58. Procedure GS_FileTruncate(var dF : file; loc : longint);
  59. Procedure GS_FileWrite(var dF : file; blk : longint; var dat; len : longint;
  60.                        var RtnRslt : word);
  61. function GS_FileFindFiles(pth, fname : string; LookElseWhere : boolean)
  62.                                                                    : string;
  63.  
  64. implementation
  65.  
  66. uses
  67.    GS_Pick,
  68.    GS_Winfc;
  69.  
  70. type
  71.    BufferPointer = ^BufferArray;
  72.    BufferArray   = array[0..32767] of char;
  73.    BufrRec = record
  74.                 Size   : word;        {Size of buffer}
  75.                 CntByt : word;        {Bytes stores in buffer}
  76.                 Posn   : longint;     {Beginning byte of file in buffer}
  77.                 FPosn  : longint;     {Last byte read + 1 in buffer}
  78.                 BufPtr : BufferPointer;
  79.              end;
  80.  
  81. var
  82.    Bufr  : BufrRec;
  83.    dbfErr : integer;
  84.    Blok,
  85.    TPosS,
  86.    TPosE  : longint;
  87.    StrFil : string[80];
  88.    istrue : boolean;
  89.  
  90.    cdriv   : byte;
  91.    tdrv    : byte;
  92.    regs    : Registers;
  93.  
  94.    ShoWin  : GS_Wind_Objt;
  95.  
  96. Function InRam(var dF : file; blk, len : longint; rf : boolean) : boolean;
  97. var
  98.    dFa    : FileRec absolute dF;
  99.    RorW   : string[4];
  100. begin
  101.    istrue := false;
  102.    inc(IOAsk);
  103.    if rf then RorW := 'Read' else RorW := 'Writ';
  104.    move(dFa.UserData, Bufr, sizeof(Bufr));
  105.    if blk > -1 then TPosS := dFa.RecSize * blk
  106.       else TPosS := Bufr.FPosn;
  107.    Blok := TPosS div dFa.RecSize;
  108.    Bufr.FPosn := TPosS + dFa.RecSize * len;
  109.    if Bufr.CntByt > 0 then
  110.    begin
  111.       TPosS := TPosS - Bufr.Posn;
  112.       if (TPosS >= 0) and (TPosS < Bufr.CntByt) then
  113.       begin
  114.          TPosE := (TPosS + dFa.RecSize * len) - 1;
  115.          if TPosE <= Bufr.CntByt then istrue := true;
  116.       end;
  117.    end;
  118.    if not istrue then inc(IOPhy);
  119.    if rf then inc(IORed) else inc(IOWri);
  120.    InRam := istrue;
  121. end;
  122.  
  123. Procedure GS_FileAssign(var dF : file; Fname : string; BufSize : longint);
  124. var
  125.    dFa    : FileRec absolute dF;
  126. begin
  127.    Assign(df, FName);
  128.    Bufr.Posn  := 0;
  129.    Bufr.FPosn := 0;
  130.    Bufr.CntByt := 0;
  131.    Bufr.Size  := BufSize;
  132.    GetMem(Bufr.BufPtr, BufSize);
  133.    move(Bufr, dFa.UserData, sizeof(Bufr));
  134. end;
  135.  
  136. Procedure GS_FileClose(var dF : file);
  137. var
  138.    dFa    : FileRec absolute dF;
  139. begin
  140.    Close(df);
  141.    move(dFa.UserData, Bufr, sizeof(Bufr));
  142.    FreeMem(Bufr.BufPtr, Bufr.Size);
  143. end;
  144.  
  145. Procedure GS_FileErase(var dF : file);
  146. begin
  147.    Erase(df);
  148. end;
  149.  
  150. Function  GS_FileExists(var dF : file; Fname : string) : boolean;
  151. begin
  152.    if (FName <> '') then
  153.    begin
  154.       {$I-}
  155.       Assign(dF, FName);
  156.       Reset(dF);
  157.       Close(dF);
  158.       {$I+}
  159.       GS_FileExists := (IOResult = 0);
  160.    end else GS_FileExists := false;
  161. end;
  162.  
  163. Procedure GS_FileRead(var dF : file; blk : longint; var dat; len : longint;
  164.                       var RtnRslt : word);
  165. var
  166.    dFa    : FileRec absolute dF;
  167.    Result,
  168.    LthHld : word;
  169.  
  170.    StrFil : string[80];
  171. begin
  172.    if InRam(dF, blk, len, true) then
  173.    begin
  174.       move(Bufr.BufPtr^[TPosS],dat,dFa.RecSize * len);
  175.       move(Bufr, dFa.UserData, sizeof(Bufr));
  176.       RtnRslt := len;
  177.       exit;
  178.    end;
  179.    dbfErr := 0;
  180.    begin
  181.       (*$I-*) Seek(dF, Blok); (*$I+*)
  182.       dbfErr := IOResult;
  183.    end;
  184.    IF dbfErr = 0 THEN               {If seek ok, read the record}
  185.    BEGIN
  186.       inc(BRCmd);
  187.       LthHld := dFa.RecSize;
  188.       dFa.RecSize := 1;
  189.       (*$I-*)
  190.       BlockRead(dF, Bufr.BufPtr^, Bufr.Size, Result);
  191.       (*$I+*)
  192.       RtnRslt := Result div LthHld;
  193.       if RtnRslt > len then RtnRslt := len;
  194.       dbfErr := IOResult;
  195.       if dbfErr = 0 then
  196.       begin
  197.          move(Bufr.BufPtr^,dat,LthHld * len);
  198.          Bufr.CntByt := Result;
  199.          Bufr.Posn := Blok * LthHld;
  200.          Bufr.FPosn := (Blok * LthHld)+(LthHld * len);
  201.          move(Bufr, dFa.UserData, sizeof(Bufr));
  202.       end;
  203.       dFa.RecSize := LthHld;
  204.    end;
  205.    if dbfErr <> 0 then
  206.    begin
  207.       CnvAscToStr(dFa.Name,StrFil,64);
  208.       ShowError(dbfErr,StrFil);
  209.    end;
  210. end;
  211.  
  212. Procedure GS_FileRename(var dF : file; Fname : string);
  213. begin
  214.    Rename(df, FName);
  215. end;
  216.  
  217. Procedure GS_FileReset(var dF : file; len : longint);
  218. var
  219.    dFa    : FileRec absolute dF;
  220.    i      : integer;
  221.    StrFil : string[80];
  222. begin
  223.    (*$I-*) Reset(dF, len); (*$I+*)
  224.    dbfErr := IOResult;
  225.    if dbfErr <> 0 then
  226.    begin
  227.       CnvAscToStr(dFa.Name,StrFil,64);
  228.       ShowError(dbfErr,StrFil);
  229.    end;
  230. end;
  231.  
  232. Procedure GS_FileRewrite(var dF : file; len : longint);
  233. var
  234.    dFa    : FileRec absolute dF;
  235.    i      : integer;
  236.    StrFil : string[80];
  237. begin
  238.    (*$I-*) Rewrite(dF, len); (*$I+*)
  239.    dbfErr := IOResult;
  240.    if dbfErr <> 0 then
  241.    begin
  242.       CnvAscToStr(dFa.Name,StrFil,64);
  243.       ShowError(dbfErr,StrFil);
  244.    end;
  245. end;
  246.  
  247. Function GS_FileSize(var dF : file) : longint;
  248. begin
  249.    GS_FileSize := FileSize(df);
  250. end;
  251.  
  252.  
  253. Procedure GS_FileTruncate(var dF : file; loc : longint);
  254. var
  255.    dFa    : FileRec absolute dF;
  256. begin
  257.    dbfErr := 0;
  258.    if loc <> -1 then
  259.    begin
  260.       (*$I-*) Seek(dF, loc); (*$I+*)
  261.       dbfErr := IOResult;
  262.    end;
  263.    IF dbfErr <> 0 THEN
  264.    begin
  265.       CnvAscToStr(dFa.Name,StrFil,64);
  266.       ShowError(dbfErr,StrFil);
  267.    end;
  268.    Truncate(df);
  269. end;
  270.  
  271.  
  272. Procedure GS_FileWrite(var dF : file; blk : longint; var dat; len : longint;
  273.                        var RtnRslt : word);
  274. var
  275.    dFa    : FileRec absolute dF;
  276.    i      : integer;
  277.    Result : word;
  278.    MovLth : longint;
  279.    StrFil : string[80];
  280. begin
  281.    if InRam(dF, blk, len, false) then
  282.          move(dat,Bufr.BufPtr^[TPosS],dFa.RecSize * len);
  283. {
  284.       else
  285.       begin
  286.          MovLth := (dFa.RecSize * len) + (dFa.RecSize *  Blok);
  287.          if Bufr.Size >= MovLth then
  288.          begin
  289.             move(dat,Bufr.BufPtr^[dFa.RecSize * Blok],dFa.RecSize * len);
  290.             Bufr.CntByt := MovLth;
  291.             Bufr.Posn := 0;
  292.             Bufr.FPosn := MovLth;
  293.          end;
  294.       end;
  295.       move(Bufr, dFa.UserData, sizeof(Bufr));
  296. }
  297.    dbfErr := 0;
  298.    if blk > -1 then
  299.    begin
  300.       (*$I-*) Seek(dF, blk); (*$I+*)
  301.       dbfErr := IOResult;
  302.    end;
  303.    IF dbfErr = 0 THEN               {If seek ok, read the record}
  304.    BEGIN
  305.       inc(BWCmd);
  306.       (*$I-*) BlockWrite(dF, dat, len, Result); (*$I+*)
  307.       RtnRslt := Result;
  308.       dbfErr := IOResult;
  309.    end;
  310.    if dbfErr <> 0 then
  311.    begin
  312.       CnvAscToStr(dFa.Name,StrFil,64);
  313.       ShowError(dbfErr,StrFil);
  314.    end;
  315. end;
  316.  
  317. function GS_FileFindFiles(pth, fname : string; LookElseWhere : boolean)
  318.                                                                   : string;
  319. var
  320.    DirInfo : SearchRec;
  321.    FilTabl : array[1..512] of string[12];
  322.    Labl    : string;
  323.    DirNow,
  324.    DirNam,
  325.    DirCur  : PathStr;
  326.    DSt     : DirStr;
  327.    NSt     : NameStr;
  328.    ESt     : ExtStr;
  329.    itms    : integer;
  330.    rfil    : integer;
  331.    rdir    : integer;
  332.    slct    : integer;
  333.    lctn    : integer;
  334.    wtx,
  335.    wbg,
  336.    wfg,
  337.    wti,
  338.    wbi     : byte;
  339.    wx1,
  340.    wy1,
  341.    wx2,
  342.    wy2     : integer;
  343.  
  344.   procedure MakeFileTable;
  345.   var
  346.      i : integer;
  347.      d : string;
  348.      v : char;
  349.      u : byte absolute v;
  350.      b : byte;
  351.    begin
  352.       itms := 0;
  353.       FindFirst(Labl, Archive, DirInfo);
  354.       while DosError = 0 do
  355.       begin
  356.          inc(itms);
  357.          FilTabl[itms] := DirInfo.Name;
  358.          FindNext(DirInfo);
  359.       end;
  360.       rfil := itms;
  361.       if itms > 0 then
  362.          GS_Pick_Item_Sort(FilTabl[1],sizeof(FilTabl[1]),itms,true);
  363.       if LookElseWhere then
  364.       begin
  365.          FindFirst('*.', Directory, DirInfo);
  366.          while DosError = 0 do
  367.          begin
  368.             if (DirInfo.Attr = directory) and (DirInfo.Name <> '.') then
  369.             begin
  370.                inc(itms);
  371.                for i := 1 to length(DirInfo.Name) do
  372.                begin
  373.                   v := DirInfo.Name[i];
  374.                   if v in ['A'..'Z'] then u := u + 32;
  375.                   DirInfo.Name[i] := v;
  376.                end;
  377.                FilTabl[itms] := DirInfo.Name+'\';
  378.             end;
  379.             FindNext(DirInfo);
  380.          end;
  381.          rdir := itms;
  382.          if itms-rfil > 0 then
  383.             GS_Pick_Item_Sort(FilTabl[succ(rfil)],sizeof(FilTabl[1]),
  384.                               itms-rfil,true);
  385.          for i := 0 to pred(GS_FileDrvCnt) do
  386.          begin
  387.             if GS_FileDrvTab[i] = 'P' then
  388.             begin
  389.                inc(itms);
  390.                FilTabl[itms] := chr(i+65)+':\';
  391.             end;
  392.          end;
  393.       end;
  394.    end;
  395.  
  396. begin
  397.    GS_Wind_GetWinSize(wx1,wy1,wx2,wy2);
  398.    if (wx2-wx1 < 16) or (wy2-wy1 < 7) then
  399.    begin
  400.       ShowError(777,'Window too small for file display');
  401.       GS_FileFindFiles := '';
  402.       exit;
  403.    end;
  404.    GS_Wind_GetColors(wtx,wbg,wfg,wti,wbi);
  405.    ShoWin.InitWin(wx1+1,wy1+1,wx1+15,wy2-3,wti,wbi,wfg,wtx,wbg,true,'',true);
  406.    GetDir(0,DirNow);
  407.    if pth <> '' then
  408.    begin
  409.       FSplit(pth, DSt, NSt, ESt);
  410.       DSt[0] := pred(DSt[0]);
  411.       (*$I-*) ChDir(DSt) (*$I+*);
  412.    end;
  413.    GetDir(0,DirNam);
  414.    DirCur := DirNam;
  415.    repeat
  416.       if DirNam[length(DirNam)] <> '\' then DirNam := DirNam + '\';
  417.       GoToXY(2,(wy2-wy1)-1);
  418.       Write('Dir = ',DirNam);
  419.       Labl := DirNam+fname;
  420.       MakeFileTable;
  421.       if itms > 0 then
  422.       begin
  423.          ShoWin.SetWin;
  424.          slct := GS_Pick_Row_Item(FilTabl, 13, itms, 1);
  425.          ShoWin.RelWin;
  426.          ClrScr;
  427.       end else slct := 0;
  428.       if slct > rfil then
  429.       begin
  430.          if slct > rdir then (*$I-*) ChDir(DirCur) (*$I+*);
  431.          DirNam := FilTabl[slct];
  432.          DirNam[0] := pred(DirNam[0]);
  433.          (*$I-*) ChDir(DirNam) (*$I+*);
  434.          GetDir(0,DirNam);
  435.          if slct > rdir then DirCur := DirNam;
  436.       end;
  437.       if (slct > 0) and (slct <= rfil) then
  438.          Labl := FilTabl[slct] else Labl := '';
  439.       lctn := pos('.',Labl);
  440.       if lctn > 0 then delete(Labl,lctn,4);
  441.    until slct <= rfil;
  442.    if DirNam[length(DirNam)] <> '\' then DirNam := DirNam + '\';
  443.    if Labl <> '' then GS_FileFindFiles := DirNam+Labl
  444.       else GS_FileFindFiles := '';
  445.    if slct = 0 then GS_FileFindFiles := '-';
  446.    ChDir(DirNow);
  447. end;
  448.  
  449.  
  450. begin
  451.    IOAsk := 0;
  452.    IOPhy := 0;
  453.    IORed := 0;
  454.    IOWri := 0;
  455.    BRCmd := 0;
  456.    BWCmd := 0;
  457.                     {Build Drive Table}
  458.    regs.ah := 25;
  459.    MsDos(regs);
  460.    cdriv := regs.al;
  461.    regs.dl := cdriv;
  462.    regs.ah := 14;
  463.    MsDos(regs);
  464.    GS_FileDrvCnt := regs.al;
  465.    tdrv := 0;
  466.    while tdrv < GS_FileDrvCnt do
  467.    begin
  468.       regs.dl := tdrv;
  469.       regs.ah := 14;
  470.       MsDos(regs);
  471.       regs.ah := 25;
  472.       MsDos(regs);
  473.       if tdrv = regs.al then GS_FileDrvTab[tdrv] := 'P'
  474.          else GS_FileDrvTab[tdrv] := ' ';
  475.       inc(tdrv);
  476.    end;
  477.    regs.dl := cdriv;
  478.    regs.ah := 14;
  479.    MsDos(regs);
  480. end.
  481.  
  482.  
  483.  
  484.