ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/UTILITY/DIR/TDIR92.ZIP/TD.PAS

Pascal/Delphi Source File | 1992-03-05 | 19.0 KB | 500 lines

Program TreeDir;

{ ─────────────────────────────────────────────────────────────────── }
{ Name:      TD.PAS -> TD.EXE                                         }
{ Date:      12/10/90                                                 }
{ By:        J. Rockford Cogar, 119 Oklahoma Ave, Oak Ridge, TN 37830 }
{ Compiler:  Borland Turbo Pascal 6.0                                 }
{ Purpose:   Show File Storage on a Subdirectory Basis                }
{ ─────────────────────────────────────────────────────────────────── }

USES
  Dos;

CONST
  carry      = 1;
  directory  = $10;    { directory attribute }
  NumberDirs = 1024;   { 1024 records should be enough room for directory data }
  ActiveCol  = 23;     { output column during 'explore' }

  PROGNAME : string[52] = 'TreeDir. Shows File Storage on a Subdirectory Basis.';
  PROGBY   : string[39] = 'By: J. Rockford Cogar, Oak Ridge TN USA';
  PROMPT1  : string[23] = 'Processing Directory: \';
  CRLF     : string[2]  = #13#10;
  PROMPT2  : string[12] = 'Subdirectory';
  PROMPT3  : string[13] = 'Storage in KB';

TYPE
   fname = array[1..80] of char;
   str80 = string[80];            { generic string }

   DTransA_ = record
          filler    : array[1..21] of byte;
          attribute : byte;
          file_time : word;
          file_date : word;
          file_size : array[1..2] of word;
          file_name : fname;
          end;

   SubDir_ = record
           Size  : longint;    { bytes in the subdir           4 }
           Index : integer;    { index of the previous record  2 }
           Level : integer;    { depth in the tree             2 }
           Name  : string[13]; { name of a subdirectory       13 }
          end;                 { Total bytes:                 21 }

VAR
  SubDir        : array[0..NumberDirs] of SubDir_;  { array of recs to store dir info in }
  filestorage   : longint;                          { temp var to store bytes in a subdir }
  pattern       : string[70];                       { directory search pattern }
  sdir          : str80;                            { scaler string for filenames }
  OldDir        : str80;                            { current subdirectory at startup }
  fir           : integer;                          { index for subdirectories }
  CurDir        : str80;                            { explore time current directory }
  by            : byte;                             { generic byte }
  level         : integer;                          { level in the dir tree }
  prev          : integer;                          { previous subdirectory index }
  next          : integer;                          { next subdirectory index }
  curr          : integer;                          { current subdirectory index }
  ostr          : str80;                            { final output string }
  spstr         : str80;                            { string of space chars }
  maxlen        : integer;                          { max filename length }
  maxlevel      : integer;                          { max level reached }
  padlen        : integer;                          { numb spaces to padd with }
  maxsize       : longint;                          { largest amount storage in a dir }
  CurNumbLen    : integer;                          { length of the current number string }
  NumbPad       : integer;                          { length of the largest number string }
  vmode         : byte;                             { video mode at startup }
  color         : integer;                          { text color }
  clrstr        : str80;                            { clear string }
  curtype       : integer;                          { cursor size }

{ init global data }
{ ─────────────────────────────────────────────────────────────────────────── }
procedure init;
begin { procedure init() }
  fillchar(SubDir,sizeof(SubDir_) * NumberDirs, #0);
  SubDir[0].Name:='ROOT'#0;
  pattern:='*.*'#0;
  fillchar(clrstr[1],79 - ActiveCol,' ');
  clrstr[0]:=chr(79 - ActiveCol);

   asm
     xor ax,ax              { zero a register }
     mov word ptr level,ax  { zero out: level }
     mov word ptr prev,ax   { zero out: prev  }
     mov word ptr next,ax   { zero out: next  }
     mov word ptr curr,ax   { zero out: curr  }
     mov word ptr fir,ax    { zero out: fir   }
   end;

 end; { procedure init() }
{ ─────────────────────────────────────────────────────────────────────────── }

{ start of a bunch of small procs that are used to avoid the use of }
{ writeln() and the CRT unit. This makes TD.EXE 2KB smaller.        }

{ move the cursor }
{ ─────────────────────────────────────────────────────────────────────────── }
procedure tgotoxy(x, y: integer);
begin
 asm
  mov ah,2           { move cursor function }
  mov bh,0           { video page zero      }
  mov dl,byte ptr x  { fetch col number     }
  mov dh,byte ptr y  { fetch row number     }
  int 10h            { call VIDEO BIOS      }
 end;
end;
{ ─────────────────────────────────────────────────────────────────────────── }

{ write text to STDOUT }
{ ──────────────────────────────────────────────────────────────────────── }
procedure putln(VAR strg: str80);
begin
 ASM
  push ds
  lds  si,dword ptr [bp+4]
  mov  cl,byte ptr ds:[si]
  mov  ch,0
  mov  bx,1
  inc  si
  mov  dx,si
  mov  ah,040h
  int  21h
  pop  ds
  end;
end;
{ ──────────────────────────────────────────────────────────────────────── }

{ BIOS version of 'C' putchar() }
{ ─────────────────────────────────────────────────────────────────────────── }
procedure PutCh(cha : char);
begin
 asm
  mov ah,0eh          { Write tty function            }
  mov bl,0fh          { white color for graphics mode }
  mov al,byte ptr cha { fetch char to output          }
  int 10h             { call VIDEO BIOS               }
 end;
end;
{ ─────────────────────────────────────────────────────────────────────────── }

{ Get Cursor Position. High byte is Row, low byte is column }
{ ─────────────────────────────────────────────────────────────────────────── }
function GetXY: integer;
VAR
  retv: integer;
begin
 asm
  mov ah,03h               { read cursor position function }
  mov bh,00h               { video page zero               }
  int 10h                  { call VIDEO BIOS               }
  mov word ptr retv,dx     { copy to a temp VAR            }
 end;
 GetXY:=retv;
end;
{ ─────────────────────────────────────────────────────────────────────────── }

{ Get Cursor type }
{ ─────────────────────────────────────────────────────────────────────────── }
function GetCurType: integer;
VAR
  retv: integer;
begin
 asm
  mov ah,03h               { read cursor position function }
  mov bh,00h               { video page zero               }
  int 10h                  { call VIDEO BIOS               }
  mov word ptr retv,cx     { copy to a temp VAR            }
 end;
 GetCurType:=retv;
end;
{ ─────────────────────────────────────────────────────────────────────────── }

{ Set Cursor type }
{ ─────────────────────────────────────────────────────────────────────────── }
procedure SetCurType(ctype: integer);
begin
 asm
  mov ah,01h               { set cursor type function }
  mov cx,word ptr ctype    { fetch cursor type        }
  int 10h                  { call VIDEO BIOS          }
 end;
end;
{ ─────────────────────────────────────────────────────────────────────────── }

{ a BIOS 'C' Puts() }
{ ─────────────────────────────────────────────────────────────────────────── }
procedure Puts(VAR outstr: str80);
VAR
  x     : integer; { glyph column index }
  y     : integer; { glyph row index    }
  len   : integer; { string length      }
  i     : integer; { output byte index  }
begin
  len:=length(outstr); { get string length   }
  x:=lo(GetXY);        { get glyph col index }
  y:=hi(GetXY);        { get glyph row index }

  for i:=1 to len do     { loop through the string }
    begin
      PutCh(outstr[i]);  { out a char      }
      inc(x);            { next column     }
      tgotoxy(x,y);      { move the cursor }
    end;

end;
{ ─────────────────────────────────────────────────────────────────────────── }

{ position cursor then output a string }
{ ─────────────────────────────────────────────────────────────────────────── }
procedure PutsXY(x,y: integer; VAR outstr: str80);
begin
  tgotoxy(x,y);  { set cursor }
  Puts(outstr);  { write the string with BIOS }
end;
{ ─────────────────────────────────────────────────────────────────────────── }

{ a simple clear screen proc }
{ ─────────────────────────────────────────────────────────────────────────── }
procedure ClearScrn(color : integer);
begin
 asm
  mov ah,06h            { Scroll Up function  }
  mov al,0h             { clear whole window  }
  mov bh,byte ptr color { fetch output color  }
  xor cx,cx             { start at 'home'     }
  mov dx,01950h         { bot right corner    }
  int 10h               { call VIDEO BIOS     }
 end;
end;
{ ─────────────────────────────────────────────────────────────────────────── }

{ initialize the video }
{ ─────────────────────────────────────────────────────────────────────────── }
procedure VideoInit;
begin

  asm
    mov bh,0              { video page number                          }
    mov ah,8              { Video BIOS call to attribute at the cursor }
    int 10h               { call video BIOS                            }
    mov bl,ah             { copy to operate on                         }
    and bh,00h            { get rid of the high byte                   }
    mov word ptr color,bx { save away the color                        }
  end;

  curtype:=GetCurType; { cursor type        }
  ClearScrn(color);    { clear whole screen }
  tgotoxy(0,0);        { home the cursor    }
end;
{ ─────────────────────────────────────────────────────────────────────────── }

{ 'make' a long string of spaces have 'numb' length }
{ ─────────────────────────────────────────────────────────────────────────── }
procedure padstr(numb : integer; VAR ostr : str80);
begin
  if (numb < 0) then exit;   { range check      }
  if (numb > 0) then fillchar(ostr,numb + 1,' ');
  ostr[0]:=chr(numb);        { init length byte }
end;
{ ─────────────────────────────────────────────────────────────────────────── }

{ get the current directory string. Without the volume letter }
{ ─────────────────────────────────────────────────────────────────────────── }
function GetCurDir(VAR DirStr : str80): integer;
VAR
  rg : registers;
  i  : integer;
begin { function GetCurDir() }

  rg.dx := 0;              {get current directory -- default drive}
  rg.ds := seg(DirStr[1]);
  rg.si := ofs(DirStr[1]);
  rg.ax := $4700;
  msdos(rg);

  i:=0;

  while (DirStr[i+1] <> #0) do inc(i);  { calc 'C' string length }

  DirStr[0]:=chr(i);  { insert the string length }
  GetCurDir:=i;       { ret string length        }
end;                  { function GetCurDir       }
{ ─────────────────────────────────────────────────────────────────────────── }

{ convert a 'C' string into a Turbo Pascal string }
{ ─────────────────────────────────────────────────────────────────────────── }
function BuildString(VAR instr: fname; size : integer) : str80;
VAR
 i      : integer;  { loop index    }
 outstr : str80;    { output string }
begin
  i := 1;     { start at offset of 1 }

  while (instr[i] <> #0) and (i <= size) do
    begin
      outstr[i]:=instr[i];  { copy the byte }
      Inc(i);               { inc the loop counter }
    end;

  outstr[0]:=chr(i - 1);   { set the length byte }
  BuildString := outstr;   { 'return' the result }
end;
{ ─────────────────────────────────────────────────────────────────────────── }

{ explore all directories on this volume. fill the record(s) SubDir[] with data for all subdirectories }
{ ─────────────────────────────────────────────────────────────────────────── }
procedure explore;
VAR
   DTransA    : DTransA_;                 { data transfer record        }
   Regs       : registers;                { standard interrupt 'union'  }
   SubDirStr  : string[70];               { current subdirectory string }
   dta_save   : array[1..2] of integer;   { DTA address                 }
   LowWord    : word;                     { low word of the file size   }
   HighWord   : word;                     { high word of the file size  }
   fbytes     : longint;                  { bytes in a subdirectory     }
{ ─────────────────────────────────────────────────────────────────────────── }
begin

   with Regs,DTransA do
     begin
      ax := $2F00;          { get DTA }
      msdos(Dos.Registers(Regs));
      dta_save[1] := es;
      dta_save[2] := bx;

      ax := $1A00;          { set DTA }
      ds := seg(DTransA);
      dx := ofs(DTransA);
      msdos(Regs);

      ds := seg(pattern[1]);
      dx := ofs(pattern[1]);
      ax := $4E00;          { find 1st file }
      cx := $FF;
      msdos(Regs);

      while (flags and carry) = 0 do          { loop through everything }
        begin
         SubDirStr:= BuildString(file_name, sizeof(file_name) );

         if ((attribute and directory) <> 0) and (SubDirStr <> '.') and ( SubDirStr <> '..') then
          begin  { -------------- if the filename has a directory attribute -------------- }
            SubDirStr := SubDirStr+chr(0);  { makes the string 'extra long' }
            ax := $3B00;    { CHDIR }
            ds := seg(SubDirStr[1]);
            dx := ofs(SubDirStr[1]);
            msdos(Regs);     { drop down into that directory }
            inc(fir);
            inc(level);

            prev:=curr;               { save this subdir index       }
            curr:=next + 1;           { bump down to the next subdir }
            SubDir[curr].Index:=prev; { save index for later }
            next:=curr;
            SubDir[curr].Level:=Level; { save tree level }

            if (curr > NumberDirs) then exit; { range check }

            SubDir[curr].Name:=SubDirStr;   { setup to update the status line }
            PutsXY(ActiveCol,2,clrstr);     { clear to end of line }
            LowWord:=GetCurDir(CurDir);
            PutsXY(ActiveCol,2,CurDir);     { write new dir name }

            explore;  { call this proc to dig down into the next subdir }

            ax := $3B00;    { back up to parent subdir }
            SubDirStr := '..'#0;
            ds := seg(SubDirStr[1]);
            dx := ofs(SubDirStr[1]);
            msdos(Regs);

            LowWord:=GetCurDir(CurDir);
            if (CurDir[0] = #0) then CurDir:='ROOT';
            PutsXY(ActiveCol,2,clrstr);  { clear to end of line }
            PutsXY(ActiveCol,2,CurDir);  { write new dir name }

            dec(level);  { we are now one level higher }
            curr:=prev;  { set index to the previous subdir }
            prev:=SubDir[curr].Index

           end   { -------------- if the filename has a directory attribute -------------- }
         else
           begin { -------------- For regular filenames  -------------- }
            LowWord:= file_size[1];
            HighWord:= file_size[2];

            fbytes:=(HighWord * 65536) + LowWord;

            if (GetCurDir(CurDir) > 0) then  { not root dir }
              begin
                SubDir[curr].Size:= SubDir[curr].Size + fbytes; { sum used storage }
              end
            else                             { root dir     }
              begin
                SubDir[0].Size:= SubDir[0].Size + fbytes; { sum used storage }
              end;

            end;  { -------------- For regular filenames  -------------- }

         ax := $4F00;       { get next file }
         msdos(Regs);
        end;                { end of the WHILE loop }

      ax := $1A00;          { reset DTA }
      ds := dta_save[1];
      dx := dta_save[2];
      msdos(Regs);

     end;             { end of the WITH block }

end;
{ ─────────────────────────────────────────────────────────────────────────── }

{ ─────────────────────────────────────────────────────────────────────────── }
begin  { main() }
  init;        { initialize global data  }
  VideoInit;   { initialize the video    }

  PutsXY(0,0,PROGNAME);
  PutsXY(0,1,PROGBY);
  PutsXY(0,2,PROMPT1);

  getdir(0,OldDir);  { save the current directory }

  if (paramcount > 0) then  { if there was a parameter string }
    begin
      chdir(paramstr(1) );  { assume it was a drive:\subdir string }
    end;

  chdir('\');        { switch to the root directory }

  SetCurType($3800);   { off the cursor }
  explore;             { explore all directories on the current volume }
  SetCurType(curtype); { restore the cursor }

  chdir(OldDir);  { restore the old directory }

  ClearScrn(color);  { clear whole screen }
  tgotoxy(0,0);      { home cursor        }

  prev:=0;      { init some counters }
  maxlevel:=0;
  maxlen:=0;
  maxsize:=0;

  for fir:=0 to next do  { find max level and name length }
    begin
      if (SubDir[fir].Level > maxlevel) then maxlevel:=SubDir[fir].Level;
      if (length(SubDir[fir].Name) > maxlen) then maxlen:=length(SubDir[fir].Name);
      if (SubDir[fir].Size > maxsize) then maxsize:=SubDir[fir].Size;
    end;

  maxsize:=maxsize div 1024;
  str(maxsize, pattern);         { int to string }
  NumbPad:=length(pattern) + 1;  { length of the largest number string }

  putln(PROMPT2);                { send header text to STDOUT }
  clrstr[0]:=#3;
  putln(clrstr);
  putln(PROMPT3);
  putln(CRLF);

  fillchar(clrstr[1],28,#196);   { make a divider bar }
  clrstr[29]:=#13;
  clrstr[30]:=#10;
  clrstr[0]:=#30;
  putln(clrstr);                 { send divider to STDOUT }

  for fir:=0 to next do                           { loop through the whole list }
    begin
      ostr[0]:=#0;
      filestorage:= SubDir[fir].Size div 1024;    { bytes to KiloBytes }
      padstr(SubDir[fir].Level * 2, ostr);        { init string to 'level' spaces Times 2 }
      sdir:=SubDir[fir].Name;                     { copy name to a scaler }
      by:=byte(sdir[0]);                          { adjust for trailing }
      sdir[0]:=chr(by - 1);                       { nulls }
      ostr:= ostr + '\' + sdir;                   { add the filename }

      str(filestorage,pattern);                   { int to string }
      CurNumbLen:=length(pattern);                { length of the current number string }

      padlen:= (maxlen + (2 * maxlevel)) - length(ostr); { calc pad length }
      padlen:=padlen + (NumbPad - CurNumbLen);           { to right justify the numbers }

      padstr(padlen,spstr);                       { build a pad string }
      ostr:=ostr + spstr;                         { add the pad string }

      ostr:=ostr + pattern;                       { add number string }
      ostr:=ostr + CRLF;                          { add EOL }
      putln(ostr);                                { write the data to STDOUT }
    end;                                          { loop end }

end.  { main() }
{ ─────────────────────────────────────────────────────────────────────────── }