Power-Programmierung/CD1.mdf/pascal/library/dos/tug__002/tpdir.pas

Pascal/Delphi Source File | 1988-08-14 | 11.6 KB | 391 lines

{TUG PDS CERT 1.01 (Pascal)

==========================================================================

                  TUG PUBLIC DOMAIN SOFTWARE CERTIFICATION

The Turbo User Group (TUG) is recognized by Borland International as the
official support organization for Turbo languages.  This file has been
compiled and verified by the TUG library staff.  We are reasonably certain
that the information contained in this file is public domain material, but
it is also subject to any restrictions applied by its author.

This diskette contains PROGRAMS and/or DATA determined to be in the PUBLIC
DOMAIN, provided as a service of TUG for the use of its members.  The
Turbo User Group will not be liable for any damages, including any lost
profits, lost savings or other incidental or consequential damages arising
out of the use of or inability to use the contents, even if TUG has been
advised of the possibility of such damages, or for any claim by any
other party.

To the best of our knowledge, the routines in this file compile and function
properly in accordance with the information described below.

If you discover an error in this file, we would appreciate it if you would
report it to us.  To report bugs, or to request information on membership
in TUG, please contact us at:

             Turbo User Group
             PO Box 1510
             Poulsbo, Washington USA  98370

--------------------------------------------------------------------------
                       F i l e    I n f o r m a t i o n

* DESCRIPTION
This program requires the use of units from the commercial product Turbo
Professional 4.0, by TurboPower Software. It demonstrates two new units.
The TPPICK unit offers general-purpose scrolling "pick" windows, which
allow the user to scroll through a list of strings and select one to
return to the calling program. The TPDIR unit offers a popup directory
unit, useful wherever user entry of filenames is required.
(DEMO1.PAS and DEMO1.EXE need to renamed to DEMO.PAS and DEMO.EXE. They
were renamed due to like filenames on the same disk).

* ASSOCIATED FILES
TPDIR.PAS
DEMO1.PAS
DEMO1.EXE
TPDIR.TPU
TPPICK.PAS
TPPICK.TPU

* CHECKED BY
DRM - 08/14/88

* KEYWORDS
TURBO PASCAL V4.0 PROGRAM DIRECTORY DEMO MENU

==========================================================================
}
{
Copyright (c) 1987 by TurboPower Software. May be freely used by and
distributed to owners of Turbo Professional 4.0.
}

{$R-,I-,S-,V-}

unit TPDir;
  {-Use a pick window to select a filename}

interface

uses
  Dos,
  TPString,
  TPCrt,
  TPWindow,
  TPPick;

type
  DirColorType = (WindowAttr, FrameAttr, HeaderAttr, SelectAttr);
  DirColorArray = array[DirColorType] of Byte;

const
  {Programs can modify these constants to change TPDIR behavior}
  DirMonocColors : DirColorArray = ($07, $07, $0F, $70);
  DirColorColors : DirColorArray = ($1B, $17, $30, $7E);
  XLow : Byte = 60;          {Position of pick window}
  YLow : Byte = 2;
  YHigh : Byte = 25;
  {XHigh is determined automatically}
  FileAttr : Byte = Directory; {File selection attribute}

function GetFileName(Mask : string; var FileName : string) : Word;
  {-Given a mask (which may or may not contain wildcards),
    popup a directory window, let user choose, and return pathname.
    Returns zero for success, non-zero for error.
    Error codes:
      0 = Success
      1 = Path not found
      2 = No matching files
      3 = Attempt to use popup in unsupported video mode
      4 = Insufficient memory
    else  Turbo critical error code
  }

  {=========================================================================}

implementation

const
  MaxFiles = 500; {Absolute maximum number of files found in one directory}
type
  FileString = string[13]; {Has space for \ following subdirectory names}
  FileArray = array[1..MaxFiles] of FileString;
var
  F : ^FileArray;     {Pointer to file array}
  MaxNumFiles : Word; {Maximum number of files we have memory space for}
  NumFiles : Word;    {Actual number of files found}
  Frec : SearchRec;   {Used in directory operations}

  function StUpcase(S : string) : string;
    {-Uppercase a string}
  var
    i:integer;
  begin
    for i:=1 to length(s) do
      s[i] := upcase(s[i]);
    StUpcase := s;
  end;

  function HasWildCards(Mask : string) : Boolean;
    {-Return true if Mask has DOS wildcards}
  begin
    HasWildCards := (pos('*', Mask) <> 0) or (pos('?', Mask) <> 0);
  end;

  function EndsPathDelim(Mask : string) : Boolean;
    {-Return true if Mask ends in a DOS path delimiter}
  begin
    case Mask[Length(Mask)] of
      #0, ':', '\' : EndsPathDelim := True;
    else
      EndsPathDelim := False;
    end;
  end;

  function AddFilePath(Mask : string; Fname : FileString) : string;
    {-Concatenate a filemask and filename}
  var
    Mlen : byte absolute Mask;
    Flen : byte absolute Fname;
  begin
    if EndsPathDelim(Mask) then begin
      if ((Fname = '..\') and (Mlen > 2) and
         (Mask[Mlen] = '\') and (Mask[Mlen-1] <> '.')) then begin
        {Remove last subdirectory}
        repeat
          dec(Mlen);
        until EndsPathDelim(Mask);
        AddFilePath := Mask;
      end else
        AddFilePath := Mask+Fname
    end else
      AddFilePath := Mask+'\'+Fname;
  end;

  function AddWildCard(Mask : string) : string;
    {-Add a default wild card to Mask if it needs it}
  begin
    if HasWildCards(Mask) then
      AddWildCard := Mask
    else
      AddWildCard := AddFilePath(Mask, '*.*');
  end;

  function FindFiles(SearchMask : string; FileAttr : Byte) : Word;
    {-Add any matched files to File arrays}
  begin
    FindFirst(SearchMask, FileAttr, Frec);
    while (DosError = 0) and (NumFiles < MaxNumFiles) do begin
      with Frec do
        if (Attr and Directory) = (FileAttr and Directory) then
          {Matches directory type}
          if Name <> '.' then begin
            Inc(NumFiles);
            if Attr and Directory <> 0 then
              F^[NumFiles] := Name+'\'
            else
              F^[NumFiles] := Name;
          end;
      FindNext(Frec);
    end;
    case DosError of
      3, 18 : FindFiles := 0;
    else
      FindFiles := DosError;
    end;
  end;

  procedure SwapItem(I, J : Word);
    {-Swap two sort items}
  var
    TmpF : FileString;
  begin
    TmpF := F^[J];
    F^[J] := F^[I];
    F^[I] := TmpF;
  end;

  procedure ShellSort(NumFiles : Word);
    {-Shellsort the directory entries}
  var
    Offset, I, J, K : Word;
    InOrder : Boolean;
  begin
    Offset := NumFiles;
    while Offset > 1 do begin
      Offset := Offset shr 1;
      K := NumFiles-Offset;
      repeat
        InOrder := True;
        for J := 1 to K do begin
          I := J+Offset;
          if F^[I] < F^[J] then begin
            SwapItem(I, J);
            InOrder := False;
          end;
        end;
      until InOrder;
    end;
  end;

  {$F+}
  function SendFileName(Item : word) : string;
    {-Pass each file name to the pick unit}
  begin
    SendFileName := F^[Item];
  end;
  {$F-}

  function GetFileName(Mask : string; var FileName : string) : Word;
    {-Get a filename from a user mask}
  label
    ExitPoint;
  var
    PickChar : Char;
    Done : Boolean;
    XHigh : Byte;
    Choice : Word;
    Status : Word;
    Memory : LongInt;
    VA : DirColorArray;
    SearchMask : string;
    PathName : string;
    WildCard : FileString;
  begin

    {Assume success}
    GetFileName := 0;
    FileName := '';

    {Get the default searchmask}
    Mask := StUpcase(Mask);
    SearchMask := AddWildCard(Mask);

    {See if mask specifies a subdirectory}
    if (Length(Mask) <> 0) and not HasWildCards(Mask) then begin
      FindFirst(SearchMask, FileAttr, Frec);
      case DosError of
        0 : ;                {Files found, it is a subdirectory}
        3 :                  {Path not found, invalid subdirectory}
          begin
            {See if Mask itself is a valid path}
            FindFirst(Mask, FileAttr, Frec);
            case DosError of
              3 : GetFileName := 1; {Path not found}
            else
              FileName := Mask; {New or existing file}
            end;
            exit;
          end;
        18 :                 {No more files, not a subdirectory}
          begin
            case Mask[Length(Mask)] of
              ':', '\' : GetFileName := 2; {No matching files}
            else
              FileName := Mask; {New or existing file}
            end;
            Exit;
          end;
      else
        GetFileName := DosError; {DOS critical error}
        Exit;
      end;
    end;

    {Initialize display colors}
    case LastMode and $FF of
      0, 2, 7 : VA := DirMonocColors;
      1, 3 : VA := DirColorColors;
    else
      {Unsupported video mode}
      GetFileName := 3;
      Exit;
    end;

    {Get space for file array - reserve 2000 bytes for popup window}
    Memory := MaxAvail-2000;
    if Memory > MaxFiles*SizeOf(FileString) then
      {Room for MaxFiles}
      MaxNumFiles := MaxFiles
    else begin
      {Limited space available}
      MaxNumFiles := Memory div SizeOf(FileString);
      if MaxFiles < 2 then begin
        GetFileName := 4; {Insufficient memory}
        Exit;
      end;
    end;
    GetMem(F, MaxNumFiles*SizeOf(FileString));

    Done := False;
    repeat

      {Separate wildcard from pathname}
      WildCard := JustFilename(SearchMask);
      PathName := copy(SearchMask, 1, length(SearchMask)-length(WildCard));

      {Build the file array}
      NumFiles := 0;
      {Find non-subdirectories}
      Status := FindFiles(SearchMask, FileAttr and not Directory);
      {Find subdirectories}
      if Status = 0 then
        if (FileAttr and Directory) <> 0 then
          Status := FindFiles(AddWildCard(PathName), FileAttr);
      if Status <> 0 then begin
        GetFileName := Status;
        goto ExitPoint;
      end;

      if NumFiles = 0 then begin
        {No files found}
        Done := True;
        GetFileName := 2; {No matching files}

      end else begin
        {Sort the directory}
        ShellSort(NumFiles);

        {Choose the window width}
        if SizeOf(FileString) >= Length(SearchMask)+3 then
          XHigh := XLow+SizeOf(FileString)+2
        else
          XHigh := XLow+Length(SearchMask)+5;

        {Pick from the directory}
        if PickWindow(@SendFileName, NumFiles, XLow, YLow, XHigh, YHigh, True,
                      VA[WindowAttr], VA[FrameAttr], VA[HeaderAttr], VA[SelectAttr],
                      ' '+SearchMask+' ', [#13, #27], Choice, PickChar) then
        begin
          case PickChar of
            #27 :          {User pressed Escape - return empty file name}
              Done := True;
            #13 :          {User pressed Enter}
              if F^[Choice][length(F^[Choice])] = '\' then begin
                {Selected a subdirectory}
                Mask := AddFilePath(PathName, F^[Choice]);
                SearchMask := AddFilePath(Mask, WildCard);
              end else begin
                {Not a directory}
                FileName := AddFilePath(PathName, F^[Choice]);
                Done := True;
              end;
          end;
        end else begin
          {Error occurred in PickWindow - most likely insufficient memory}
          GetFileName := 4;
          Done := True;
        end;
      end;
    until Done;

ExitPoint:
    {Free the memory space used for file array}
    FreeMem(F, MaxNumFiles*SizeOf(FileString));
  end;

end.