Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/TP002.ZIP/PIKDIR.PQS/pikdir.pas

Pascal/Delphi Source File | 1986-08-27 | 14.6 KB | 517 lines

{$C-}

program dirtest;
  {-develop a popup directory picker}

const
  CRTcolumns = 80;
  MaxFiles = 200;
  TxtColor = 15;
  SaveCmdColor = 7;
  SaveBordColor = 112;
  CursorOff = $2000;          {Scan lines to make cursor invisible}

type
  WindowRec = record
                XSize : Byte;
                YSize : Byte;
                XPosn : Byte;
                YPosn : Byte;
                Contents : array[0..1999] of Integer;
              end;
  WindowPtr = ^WindowRec;
  registers = record
                case Integer of
                  1 : (ax, bx, cx, dx, bp, si, di, ds, es, flags : Integer);
                  2 : (al, ah, bl, bh, cl, ch, dl, dh : Byte);
              end;
  string80 = string[80];
  pathname = string[64];
  filename = string[12];
  filearray = array[1..MaxFiles] of filename;

var
  Screenadr : Integer;
  CursorType : Integer;
  Retracemode : Boolean;
  Reg : registers;
  Fname : filearray;
  Fnum, Totalfiles : Integer;
  W : WindowPtr;
  Mask, Pickname : pathname;

  procedure DetermineDisplay;
    { Set Screenadr to $B000 or $B800, depending on which display is in use. }

  begin
    {Determine screen type for screen updating procedure}
    Reg.ax := $0F00;
    {BIOS INT 10H call to get screen type}
    Intr($10, Reg);
    Retracemode := (Reg.al <> 7);
    if Retracemode then begin
      {Color card}
      Screenadr := $B800;
      CursorType := $0607;
    end else begin
      Screenadr := $B000;
      CursorType := $0B0C;
    end;
  end;

  procedure SetCursor(ScanLines : Integer);
    {-Change the scan lines of the hardware cursor}

  begin                       {SetCursor}
    with Reg do begin
      cx := ScanLines;
      ah := 1;
    end;
    Intr($10, Reg);
  end;                        {SetCursor}

  procedure MoveToScreen(var Source, Dest; Length : Integer);
    {-Put new text information on the screen, without snow}

  begin                       {MoveToScreen}
    if Retracemode then begin
      Length := Length shr 1;
      inline($1E/$55/$BA/$DA/$03/$C5/$B6/Source/$C4/$BE/Dest/$8B/$8E/
        Length/$FC/$AD/$89/$C5/$B4/$09/$EC/$D0/$D8/$72/$FB/$FA/$EC/
        $20/$E0/$74/$FB/$89/$E8/$AB/$FB/$E2/$EA/$5D/$1F);
    end else
      Move(Source, Dest, Length);
  end;                        {MoveToScreen}

  procedure MoveFromScreen(var Source, Dest; Length : Integer);
    {-Get text information from the screen, without snow}

  begin                       {MoveFromScreen}
    if Retracemode then begin
      Length := Length shr 1;
      inline($1E/$55/$BA/$DA/$03/$C5/$B6/Source/$C4/$BE/Dest/$8B/$8E/
        Length/$FC/$EC/$D0/$D8/$72/$FB/$FA/$EC/$D0/$D8/$73/$FB/$AD/
        $FB/$AB/$E2/$F0/$5D/$1F);
    end else
      Move(Source, Dest, Length);
  end;                        {MoveFromScreen}

  procedure FastWrite(St : string80; Row, Col, Attr : Byte);
    {-Write a string to the screen, without snow}

  begin                       {FastWrite}
    inline(
      $1E/$8B/$7E/< Row/$4F/$B9/$04/$00/$D3/$E7/$89/$F8/$D1/$E7/$D1/$E7/
      $01/$C7/$8B/$46/< Col/$48/$01/$C7/$D1/$E7/$8D/$76/< St/$8B/$16/
      > Screenadr/$8E/$C2/$A0/> Retracemode/$8C/$D2/$8E/$DA/$8A/
      $0C/$E3/$2B/$46/$8A/$66/< Attr/$FC/$D0/$D8/$73/$1E/$BA/$DA/$03/
      $AC/$89/$C3/$FA/$EC/$A8/$08/$75/$09/$D0/$D8/$72/$F7/$EC/$D0/$D8/
      $73/$FB/$89/$D8/$AB/$FB/$E2/$E8/$E9/$04/$00/$AC/$AB/$E2/$FC/$1F
      );
  end;                        {FastWrite}

  function SetupWindow(XLow, YLow, XHigh, YHigh, Attr : Byte) : WindowPtr;
    {-Save existing screen and set up a new text window}
  var
    W : WindowPtr;
    XS, YS : Byte;
    i : Byte;

    procedure DrawBox(x1, y1, x2, y2 : Integer; Attr : Byte);
      {-Draw a box}
    var
      i : Byte;
      tb, sid, tlc, trc, blc, brc : Char;

    begin                     {DrawBox}

      tb := #196;             {Top Border}
      sid := #179;            {Side Border}
      tlc := #218;            {Top Left Corner}
      trc := #191;            {Top Right Corner}
      blc := #192;            {Bottom Left Corner}
      brc := #217;            {Bottom Right Corner}

      {Corners}
      FastWrite(tlc, y1, x1, Attr);
      FastWrite(trc, y1, x2, Attr);
      FastWrite(blc, y2, x1, Attr);
      FastWrite(brc, y2, x2, Attr);

      {Horizontal}
      for i := Succ(x1) to Pred(x2) do begin
        FastWrite(tb, y1, i, Attr);
        FastWrite(tb, y2, i, Attr);
      end;

      {Vertical}
      for i := Succ(y1) to Pred(y2) do begin
        FastWrite(sid, i, x1, Attr);
        FastWrite(sid, i, x2, Attr);
      end;

    end;                      {DrawBox}

  begin                       {SetupWindow}

    XS := Succ(XHigh-XLow);
    YS := Succ(YHigh-YLow);
    {Allocate 2 bytes for each screen position, + 4 for size and position}
    GetMem(W, 2*XS*YS+4);

    with W^ do begin

      {Store the size}
      XSize := XS;
      YSize := YS;
      XPosn := XLow;
      YPosn := YLow;

      {Save the existing contents}
      for i := 0 to YSize-1 do
        MoveFromScreen(Mem[Screenadr:((YPosn+i-1)*CRTcolumns+XPosn-1) shl 1],
        Contents[i*XSize], XSize shl 1);

      {Draw box around window}
      DrawBox(XLow, YLow, XHigh, YHigh, Attr);

      {Set up Turbo window and clear it}
      Window(Succ(XLow), Succ(YLow), Pred(XHigh), Pred(YHigh));
      ClrScr;

      {Turn off cursor}
      SetCursor(CursorOff);

    end;

    {Return the pointer}
    SetupWindow := W;

  end;                        {SetupWindow}

  procedure RestoreWindow(var W : WindowPtr);
    {Given a pointer to a WindowRec, restore the contents of the window}
  var
    i : Integer;

  begin                       {RestoreWindow}
    with W^ do begin
      {Restore the contents}
      for i := 0 to YSize-1 do
        MoveToScreen(Contents[i*XSize],
        Mem[Screenadr:2*((YPosn+i-1)*CRTcolumns+XPosn-1)], XSize*2);
      {Free the memory}
      FreeMem(W, 2*XSize*YSize+4);
      W := nil;
    end;
    {Reset Turbo window}
    Window(1, 1, 80, 25);
    {Restore cursor}
    SetCursor(CursorType);
  end;                        {RestoreWindow}

  procedure GetDirectory(Mask : pathname; var Fname : filearray; var Totalfiles : Integer);
    {-Return an array filled with files matching mask}
  var
    MaskLen : Byte absolute Mask;
    Tmask : pathname;
    DTA : record
            dosuse : array[1..21] of Char;
            dosattr : Byte;
            dostime, dosdate, lsize, hsize : Integer;
            dosname : array[1..13] of Char;
          end;
    DTAseg, DTAofs : Integer;

    procedure GetDTA(var Segment, Offset : Integer);
      {-Return address of current DTA}

    begin                     {GetDTA}
      Reg.ax := $2F00;
      MsDos(Reg);
      Segment := Reg.es;
      Offset := Reg.bx;
    end;                      {GetDTA}

    procedure SetDTA(Segment, Offset : Integer);
      {-Set DTA to new address}

    begin                     {SetDTA}
      Reg.ax := $1A00;
      Reg.ds := Segment;
      Reg.dx := Offset;
      MsDos(Reg);
    end;                      {SetDTA}

    procedure SortDirectory(var Fname : filearray; Totalfiles : Integer);
      {-Shellsort the directory entries}
    var
      Offset, i, j, k : Integer;
      InOrder : Boolean;
      tmp : filename;

    begin                     {SortDirectory}
      Offset := Totalfiles;
      while Offset > 1 do begin
        Offset := Offset shr 1;
        repeat
          InOrder := True;
          k := Totalfiles-Offset;
          for j := 1 to k do begin
            i := j+Offset;
            if Fname[i] < Fname[j] then begin
              {Swap names}
              tmp := Fname[j];
              Fname[j] := Fname[i];
              Fname[i] := tmp;
              InOrder := False;
            end;
          end;
        until InOrder;
      end;
    end;                      {SortDirectory}

    function GetFileOK(GetFirst : Boolean; Attr : Byte) : Boolean;
      {-Read entry in DOS directory}

      function GetFileName : filename;
        {-return the next non-directory filename from the dta, empty if a dir}
      var
        name : filename;
        i : Byte;

      begin                   {GetFileName}
        with DTA do begin
          i := 0;
          while dosname[Succ(i)] <> #0 do
            i := Succ(i);
          Move(dosname, name[1], i);
          name[0] := Chr(i);
        end;
        GetFileName := name;
      end;                    {GetFileName}

    begin                     {GetFileOK}
      if GetFirst then begin
        Reg.ah := $4E;
        Reg.ds := Seg(Mask[1]);
        Reg.dx := Ofs(Mask[1]);
        Mask[Succ(MaskLen)] := #0;
      end else
        Reg.ah := $4F;
      Reg.cx := Attr;
      MsDos(Reg);
      if Odd(Reg.flags) or (Totalfiles >= MaxFiles) then
        GetFileOK := False
      else begin
        Totalfiles := Succ(Totalfiles);
        Fname[Totalfiles] := GetFileName;
        GetFileOK := True;
      end;
    end;                      {GetFileOK}

  begin                       {GetDirectory}

    {Save DTA and point it to our masked version}
    GetDTA(DTAseg, DTAofs);
    SetDTA(Seg(DTA), Ofs(DTA));

    {Initialize}
    Totalfiles := 0;

    if MaskLen <> 0 then begin
      {See if Mask is a subdirectory}
      Tmask := Mask;
      Mask := Mask+'\*.*';
      if not(GetFileOK(True, 0)) then
        Mask := Tmask;
    end;

    {Add default wildcard}
    if (MaskLen = 0) or (Mask[MaskLen] in ['\', ':']) then
      Mask := Mask+'*.*';

    {Reinitialize}
    Totalfiles := 0;

    {Read the directory}
    if GetFileOK(True, 0) then
      repeat until not GetFileOK(False, 0);

    {Restore original DTA}
    SetDTA(DTAseg, DTAofs);

    {Sort the directory}
    if Totalfiles > 0 then
      SortDirectory(Fname, Totalfiles);

  end;                        {GetDirectory}

  function PickDirectory(W : WindowPtr;
                         var Fname : filearray;
                         Totalfiles : Integer;
                         Mask : pathname) : pathname;
    {-Browse and return full pathname of selected file}
  var
    Num : Integer;
    Row, Top, Lines : Byte;
    ch : Char;
    Quitting : Boolean;

    function GetCursorCommand : Char;
      {-Return a legal cursor command, WordStar style}

    begin                     {GetCursorCommand}
      repeat
        Read(Kbd, ch);
        if (ch = #27) and KeyPressed then begin
          Read(Kbd, ch);
          case ch of
            #72 : ch := ^E;
            #80 : ch := ^X;
          else
            ch := #0;
          end;
        end;
      until ch in [^M, ^[, ^E, ^X];
      GetCursorCommand := ch;
    end;                      {GetCursorCommand}

    procedure WriteEntry(Num : Integer; Row, Attr : Byte);
      {-Write one directory entry to the screen}

    begin                     {WriteEntry}
      with W^ do
        FastWrite(Fname[Num], YPosn+Row, XPosn+2, Attr);
    end;                      {WriteEntry}

    procedure DrawFullPage(Num : Integer);
      {-Draw one full window full of entries, starting at entry num}
    var
      i, n : Integer;

    begin                     {DrawFullPage}
      if Lines > Totalfiles then
        n := Totalfiles
      else
        n := Lines;
      for i := 1 to n do
        WriteEntry(Pred(Num+i), i, SaveCmdColor);
    end;                      {DrawFullPage}

    function FullPathname(Mask : pathname; Fname : filename) : pathname;
      {-Return a pathname combining mask and fname}
    var
      wild, i : Byte;
      MaskLen : Byte absolute Mask;

    begin                     {FullPathname}
      wild := Pos('*', Mask)+Pos('?', Mask);
      if wild <> 0 then begin
        {remove trailing wildcard}
        i := MaskLen;
        while (MaskLen > 0) and not(Mask[MaskLen] in [':', '\']) do
          MaskLen := Pred(MaskLen);
      end;
      if (MaskLen > 0) and not(Mask[MaskLen] in [':', '\']) then
        Mask := Mask+'\';
      FullPathname := Mask+Fname;
    end;                      {FullPathname}

  begin                       {PickDirectory}
    with W^ do begin
      if Totalfiles <= 0 then begin

        FastWrite(' No files', YPosn+1, XPosn+2, SaveCmdColor);
        FastWrite('Press <Esc>', YPosn+2, XPosn+2, SaveCmdColor);
        FastWrite('to continue', YPosn+3, XPosn+2, SaveCmdColor);
        repeat
          Read(Kbd, ch);
          if (ch = #27) and KeyPressed then
            Read(Kbd, ch);
        until ch = #27;
        PickDirectory := '';

      end else begin

        Lines := YSize-2;
        Num := 1;
        Row := 1;
        Top := 1;
        DrawFullPage(Num);
        WriteEntry(Num, Row, SaveBordColor);
        Quitting := False;
        repeat
          case GetCursorCommand of

            ^M :              {select}
              Quitting := True;

            ^[ :              {escape}
              begin
                Num := 0;
                Quitting := True;
              end;

            ^E :              {scroll up}
              if Num > 1 then begin
                WriteEntry(Num, Row, SaveCmdColor);
                Num := Pred(Num);
                if Row = 1 then begin
                  Top := Num;
                  InsLine;
                end else
                  Row := Pred(Row);
                WriteEntry(Num, Row, SaveBordColor);
              end;

            ^X :              {scroll down}
              if Num < Totalfiles then begin
                WriteEntry(Num, Row, SaveCmdColor);
                Num := Succ(Num);
                if Row >= Lines then begin
                  GoToXY(1, 1);
                  DelLine;
                  Row := Lines;
                  Top := Succ(Top);
                end else
                  Row := Succ(Row);
                WriteEntry(Num, Row, SaveBordColor);
              end;

          end;
        until Quitting;
        if Num = 0 then
          PickDirectory := ''
        else
          PickDirectory := FullPathname(Mask, Fname[Num]);
      end;
    end;
  end;                        {PickDirectory}

begin

  {Set up display addresses}
  DetermineDisplay;
  ClrScr;

  {Get a dir mask}
  Write('Enter directory mask: ');
  ReadLn(Mask);

  {Setup a new window}
  W := SetupWindow(64, 4, 79, 24, TxtColor);

  {Read directory}
  GetDirectory(Mask, Fname, Totalfiles);

  {Browse directory and return the selected file name}
  Pickname := PickDirectory(W, Fname, Totalfiles, Mask);

  {Restore it}
  RestoreWindow(W);

  ClrScr;
  WriteLn('Selected file: ', Pickname);
end.
 Fname, Totalfiles,