home *** CD-ROM | disk | FTP | other *** search
/ The CIA World Factbook 1992 / k3bimage.iso / sel / 12 / 0147 / vtree2.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-12-02  |  11.3 KB  |  347 lines
  1. PROGRAM ReadFile;
  2.  
  3. {$B-,D+,R-,S-,T+,V-}
  4. {
  5.    ┌────────────────────────────────────────────────────┐
  6.    │ USES AND GLOBAL VARIABLES & CONSTANTS              │
  7.    └────────────────────────────────────────────────────┘
  8. }
  9.  
  10. USES Crt,Dos;
  11.  
  12. TYPE
  13.  
  14.   FPtr      = ^Dir_Rec;
  15.  
  16.   Dir_Rec   = record                             { Double pointer record    }
  17.     DirName : string;
  18.     DirNum  : integer;
  19.     Next    : Fptr;
  20.     Prev    : Fptr;
  21.   END;
  22.  
  23.   Str_type  = string[65];
  24.  
  25. VAR
  26.  
  27.   Dir       : string;
  28.   Loop      : boolean;
  29.   Level     : integer;
  30.   Flag      : array[1..5] of string;
  31.   Tree      : boolean;
  32.  
  33. {
  34.    ┌────────────────────────────────────────────────────┐
  35.    │ PROCEDURE Beepit                                   │
  36.    └────────────────────────────────────────────────────┘
  37. }
  38.  
  39. PROCEDURE Beepit;
  40.  
  41. BEGIN
  42.   SOUND (760);                                          { Beep the speaker }
  43.   DELAY (80);
  44.   NOSOUND;
  45.   ClrScr;
  46. END;
  47.  
  48. {
  49.    ┌────────────────────────────────────────────────────┐
  50.    │ PROCEDURE Format_Num                               │
  51.    └────────────────────────────────────────────────────┘
  52. }
  53.  
  54. PROCEDURE Format_Num (Number : longint; VAR NumStr : string);
  55.  
  56. BEGIN
  57.   STR(Number,NumStr);
  58.  
  59.   IF (LENGTH (NumStr) > 6) THEN                  { Insert millions comma    }
  60.     INSERT (',',NumStr,(LENGTH(NumStr) - 5));
  61.  
  62.   IF (LENGTH (NumStr) > 3) THEN                  { Insert thousands comma   }
  63.     INSERT (',',NumStr,(LENGTH(NumStr) - 2));
  64.  
  65. END;
  66.  
  67. {
  68.    ┌────────────────────────────────────────────────────┐
  69.    │ PROCEDURE DisplayDir                               │
  70.    └────────────────────────────────────────────────────┘
  71. }
  72.  
  73. PROCEDURE DisplayDir (DirP : str_type; DirN : str_type; Levl : integer;
  74.                      NumSubsVar2 : integer; SubNumVar2 : integer;
  75.                      NumSubsVar3 : integer;
  76.                      NmbrFil : integer; FilLen : longint);
  77.  
  78. {NumSubsVar2 is the # of subdirs. in previous level;
  79.  NumSumsVar3 is the # of subdirs. in the current level.
  80.  DirN is the current subdir.; DirP is the previous path}
  81.  
  82. VAR
  83.   BegLine : string;
  84.   MidLine : string;
  85.   Blank   : string;
  86.   WrtStr  : string;
  87.   NumFil  : string;
  88.   FilByte : string;
  89.  
  90. BEGIN
  91.  
  92.   IF Levl > 5 THEN
  93.     BEGIN
  94.       BEEPIT;
  95.       WRITELN;
  96.       WRITELN ('CANNOT DISPLAY MORE THAN 5 LEVELS.');
  97.       WRITELN;
  98.       EXIT;
  99.     END;
  100.  
  101.   Blank   := '               ';                  { Init. variables          }
  102.   BegLine := '';
  103.   MidLine := ' ──────────────────';
  104.  
  105.   IF Levl = 0 THEN                               { Special handling for     }
  106.     IF Dir = '' THEN                             { initial (0) dir. level   }
  107.       IF Tree = False THEN
  108.         WrtStr := 'ROOT ──'
  109.       ELSE
  110.         WrtStr := 'ROOT'
  111.     ELSE
  112.       IF Tree = False THEN
  113.         WrtStr := DirP + ' ──'
  114.       ELSE
  115.         WrtStr := DirP
  116.   ELSE
  117.     BEGIN                                        { Level 1+ routines        }
  118.       IF SubNumVar2 = NumSubsVar2 THEN           { If last node in subtree, }
  119.         BEGIN                                    { use └─ symbol & set flag }
  120.           BegLine  := '└─';                      { padded with blanks       }
  121.           Flag[Levl] := ' ' + Blank;
  122.         END
  123.       ELSE                                       { Otherwise, use ├─ symbol }
  124.         BEGIN                                    { & set flag padded with   }
  125.           BegLine    := '├─';                    { blanks                   }
  126.           Flag[Levl] := '│' + Blank;
  127.         END;
  128.  
  129.       CASE Levl OF                               { Insert │ & blanks as     }
  130.          1: BegLine := BegLine;                  { needed, based on level   }
  131.          2: Begline := Flag[1] + BegLine;
  132.          3: Begline := Flag[1] + Flag[2] + BegLine;
  133.          4: Begline := Flag[1] + Flag[2] + Flag[3] + BegLine;
  134.          5: Begline := Flag[1] + Flag[2] + Flag[3] + Flag[4] + BegLine;
  135.       END; {end case}
  136.  
  137.       IF (NumSubsVar3 = 0) THEN                  { If cur. level has no     }
  138.         WrtStr := BegLine + DirN                 { subdirs., leave end blank}
  139.       ELSE
  140.         IF Tree = False THEN
  141.           WrtStr := BegLine + DirN + COPY(Midline,1,(13-LENGTH(DirN))) + '─┬─'
  142.         ELSE
  143.           WrtStr := BegLine + DirN + COPY(Midline,1,(13-LENGTH(DirN))) + '─┐ ';
  144.     END;                                         { End level 1+ routines    }
  145.  
  146.   Format_Num(NmbrFil,NumFil);
  147.   Format_Num(FilLen,FilByte);
  148.  
  149.   IF ((Levl < 4) OR ((Levl = 4) AND (NumSubsVar3=0))) AND (Tree = False) THEN
  150.     WRITELN (WrtStr,'':(65 - LENGTH(WrtStr)),NumFil:3,FilByte:11)
  151.   ELSE
  152.     WRITELN (WrtStr);                            { Write # of files & bytes  }
  153.                                                  { only if it fits, else     }
  154. END;                                             { write only tree outline   }
  155.  
  156. {
  157.    ┌────────────────────────────────────────────────────┐
  158.    │ PROCEDURE ReadFiles                                │
  159.    └────────────────────────────────────────────────────┘
  160. }
  161.  
  162. PROCEDURE ReadFiles (DirPrev : str_type; DirNext : str_type;
  163.                      SubNumVar1 : integer; NumSubsVar1 : integer);
  164.  
  165. VAR
  166.   FileInfo  : SearchRec;
  167.   FileBytes : longint;
  168.   NumFiles  : integer;
  169.   NumSubs   : integer;
  170.   Dir_Ptr   : FPtr;
  171.   CurPtr    : FPtr;
  172.   FirstPtr  : FPtr;
  173.  
  174. BEGIN
  175.   FileBytes := 0;
  176.   Numfiles  := 0;
  177.   NumSubs   := 0;
  178.   Dir_Ptr   := nil;
  179.   CurPtr    := nil;
  180.   FirstPtr  := nil;
  181.  
  182.   IF Loop THEN FindFirst (DirPrev + DirNext + '\*.*', AnyFile, FileInfo);
  183.   Loop      := False;                            { Get 1st file             }
  184.  
  185.   WHILE DosError = 0 DO                          { Loop until no more files }
  186.     BEGIN
  187.       IF (FileInfo.Name <> '.') AND (FileInfo.Name <> '..') THEN
  188.         BEGIN
  189.           IF (FileInfo.attr = directory) THEN    { If fetched file is dir., }
  190.             BEGIN                                { store a record with dir. }
  191.               NEW (Dir_Ptr);                     { name & occurence number, }
  192.               Dir_Ptr^.DirName  := FileInfo.name;{ and set links to         }
  193.               INC (NumSubs);                     { other records if any     }
  194.               Dir_Ptr^.DirNum   := NumSubs;
  195.               IF CurPtr = nil THEN
  196.                 BEGIN
  197.                   Dir_Ptr^.Prev := nil;
  198.                   Dir_Ptr^.Next := nil;
  199.                   CurPtr        := Dir_Ptr;
  200.                   FirstPtr      := Dir_Ptr;
  201.                 END
  202.               ELSE
  203.                 BEGIN
  204.                   Dir_Ptr^.Prev := CurPtr;
  205.                   Dir_Ptr^.Next := nil;
  206.                   CurPtr^.Next  := Dir_Ptr;
  207.                   CurPtr        := Dir_Ptr;
  208.                  END;
  209.                END
  210.           ELSE
  211.             BEGIN                                { Tally # of bytes in file }
  212.               FileBytes := FileBytes + FileInfo.size;
  213.               INC (NumFiles);                    { Increment # of files,    }
  214.             END;                                 { excluding # of subdirs.  }
  215.         END;
  216.       FindNext (FileInfo);                       { Get next file            }
  217.     END;    {end WHILE}
  218.  
  219.  
  220.     DisplayDir (DirPrev, DirNext, Level, NumSubsVar1, SubNumVar1, NumSubs,
  221.                 NumFiles, FileBytes);            { Pass info to & call      }
  222.     INC (Level);                                 { display routine, & inc.  }
  223.                                                  { level number             }
  224.  
  225.  
  226.     WHILE (FirstPtr <> nil) DO                   { If any subdirs., then    }
  227.       BEGIN                                      { recursively loop thru    }
  228.         Loop     := True;                        { ReadFiles proc. til done }
  229.         ReadFiles ((DirPrev + DirNext + '\'),FirstPtr^.DirName,
  230.                     FirstPtr^.DirNum, NumSubs);
  231.         FirstPtr := FirstPtr^.Next;
  232.       END;
  233.  
  234.  
  235.     DEC (Level);                                 { Decrement level when     }
  236.                                                  { finish a recursive loop  }
  237.                                                  { call to lower level of   }
  238.                                                  { subdir.                  }
  239. END;
  240.  
  241. {
  242.    ┌────────────────────────────────────────────────────┐
  243.    │ PROCEDURE Read_Parm                                │
  244.    └────────────────────────────────────────────────────┘
  245. }
  246.  
  247. PROCEDURE Read_Parm;
  248.  
  249. VAR
  250.   Cur_Dir : string;
  251.   Param   : string;
  252.   i       : integer;
  253.  
  254. BEGIN
  255.  
  256.   IF ParamCount > 3 THEN
  257.     BEGIN
  258.       BEEPIT;
  259.       WRITELN ('Too many parameters -- only starting path and/or "tree"');
  260.       WRITELN ('option (/t or /T) and/or "redirect" option (/r or /R)');
  261.       WRITELN ('allowed.');
  262.       HALT;
  263.     END;
  264.  
  265.   Param := '';
  266.  
  267.   FOR i := 1 TO ParamCount DO                    { If either param. is a T, }
  268.     BEGIN                                        { set Tree flag            }
  269.       Param := ParamStr(i);
  270.       IF Param[1] = '/' THEN
  271.         CASE Param[2] OF
  272.           't','T': BEGIN
  273.                      Tree := True;
  274.                      IF ParamCount = 1 THEN EXIT;
  275.                    END;                          { Exit if only one param   }
  276.  
  277.           'r','R': BEGIN
  278.                      ASSIGN (Input,'');          { Override CRT unit, &     }
  279.                      RESET (Input);              { make input & output      }
  280.                      ASSIGN (Output,'');         { redirectable             }
  281.                      REWRITE (Output);
  282.                      IF ParamCount = 1 THEN EXIT;
  283.                    END;                          { Exit if only one param   }
  284.         ELSE
  285.           BEGIN
  286.             BEEPIT;
  287.             WRITELN ('Invalid parameter -- only /t, /T, /r, or / R allowed.');
  288.             HALT;
  289.           END;
  290.         END; {case}
  291.     END;
  292.  
  293.  
  294.   GETDIR (0,Cur_Dir);                            { Save current dir         }
  295.   FOR i := 1 TO ParamCount DO
  296.     BEGIN
  297.       Param := ParamStr(i);                        { Set var to param. string }
  298.       IF (POS ('/',Param) = 0) THEN
  299.         BEGIN
  300.           Dir := Param;
  301. {$I-}     CHDIR (Dir);                           { Try to change to input   }
  302.           IF IOResult = 0 THEN                   { dir.; if it exists, go   }
  303.             BEGIN                                { back to orig. dir.       }
  304. {$I+}        CHDIR (Cur_Dir);
  305.              IF (POS ('\',Dir) = LENGTH (Dir)) THEN
  306.                DELETE (Dir,LENGTH(Dir),1);       { Change root symbol back  }
  307.              EXIT                                { to null, 'cause \ added  }
  308.             END                                  { in later                 }
  309.           ELSE
  310.             BEGIN
  311.               BEEPIT;
  312.               WRITELN ('No such directory -- please try again.');
  313.               HALT;
  314.             END;
  315.         END;
  316.     END;
  317.  
  318. END;
  319.  
  320. {
  321.    ┌────────────────────────────────────────────────────┐
  322.    │ MAIN PROGRAM                                       │
  323.    └────────────────────────────────────────────────────┘
  324. }
  325.  
  326. VAR
  327.  
  328.   Version : string;
  329.  
  330. BEGIN
  331.  
  332.   Version := 'Ver. 1.0, 4-3-88';                 { Sticks in EXE file      }
  333.  
  334.   Dir     := '';                                 { Init. global vars.      }
  335.   Loop    := True;
  336.   Level   := 0;
  337.   Tree    := False;
  338.  
  339.   ClrScr;
  340.  
  341.   IF ParamCount > 0 THEN Read_Parm;              { Deal with any params.   }
  342.  
  343.   ReadFiles (Dir,'',0,0);                        { Do main read routine    }
  344.  
  345. END.
  346.  
  347.