CD Actual 13/CDA13.ISO/cdactual/demobin/share/program/Pascal/ADD10.ZIP/ADD.PAS

Pascal/Delphi Source File | 1988-07-15 | 11.7 KB | 546 lines

{ FreeWare - Just don't modify and re-distribute.

  Randy Crawford
  12 Taft Ct., Suite.110
  Rockville, MD  20850
  301-424-6892

  ADD - Alphabetized Double-wide Directory utility.
  Requires Turbo Pascal 4.0.
  Sort help displayed using '/' on command line }

Program ADD;

Uses CRT, DOS;

Const
    Numfiles = 300;

Type
    Filename = array [1..numfiles] of string [60];
    Filesize = string [40];
    Strng2   = string [2];

VAR
    Page:   integer;
    FileCount: integer;              { total # of files }
    Count2: integer;
    Srec:   SEARCHREC;
    Path:   STRING[40];
    FirstDir: String[40];
    Drive1: Strng2;
    Pfile1: string[60];
    Pfile2: string[60];
    ATTR:   BYTE;
    YEAR:   string[4];
    MONTH:  strng2;
    DAY:    strng2;
    dt:     datetime;
    hour:   strng2;
    min:    strng2;
    name:   filesize;
    size:   filesize;
    files:  filename;
    decpos: integer;
    tsize:  longint;
    tot:    boolean;
    ext:    boolean;
    dat:    boolean;
    siz:    boolean;
    help:   boolean;
    Reverse: boolean;
    REGS:   REGISTERS;
    diff:   integer;
    left:   integer;
    Lines:  integer;
    pivot:  integer;
    group:  integer;
    scan1:  integer;
    scan2:  integer;
    extend: string[3];
    parmstr: string;
    letter:  char;
    ScrollNum: integer;
    DiskLeft:  longint;
    DLeft:     filesize;
    DiskSpace: longint;
    DSpace:    filesize;
    RetKey:    char;
    Colour:    word;

Procedure Flip;      { reverse order of array }
Var
    Count: integer;
    Pivot: integer;
    Offset: integer;
    Hold : string[60];
    LastFile: integer;
Begin
    Pivot := FileCount DIV 2;
    LastFile := FileCount + 1;
    if (Pivot * 2) > FileCount then    { if Filecount=7, Pivot=3 }
        Pivot := Pivot - 1;

    For Count := 1 to Pivot DO
    BEGIN
        Hold := Files [Count];
        Offset := LastFile - Count;
        Files [Count] := Files [Offset];
        Files [Offset] := Hold;
    END;
End;

Procedure GetChar (VAR Key: char);
BEGIN
    gotoxy (80, 25);
    key := CHR(0);
    repeat
        Key := ReadKey;
    until key <> chr(0);
END;

Procedure Caps (VAR CAPS: STRING);    { set string to all caps }
VAR
    count: integer;
    long:  integer;
begin
    long := length (caps);
    for count := 1 to long do
        IF (ord (caps [count]) > 96) and (ord (caps [count]) < 123) then
            caps [count] := chr (ord (caps [count]) - 32);
end;

Procedure Comma (VAR numstr: filesize);
VAR
    dot   : integer;
    plc   : integer;
    tens  : real;
    number: real;
begin
    val (numstr, number, dot);
    dot  := pos ('.', numstr);
    if dot = 0 then
        dot := length (numstr) + 1;
    plc  := 3;
    tens := 1000;
    While (copy (numstr, 1, 1) = ' ') and (number >= tens) DO
        begin
            insert (',', numstr, dot - plc);
            delete (numstr, 1, 1);
            tens := tens * 1000;
            plc := plc + 4;
        end;
end;

Procedure Fpad (VAR strng : filesize);
VAR
    plc: integer;
BEGIN
    plc := pos ('.', strng);
    While (plc > 0) and (plc < 9) DO
    Begin
        insert (' ', strng, plc);
        plc := pos ('.', strng);
    End;
    plc := length (strng);
    While (plc < 12) DO
    Begin
        strng := strng + ' ';
        plc := length (strng);
    End;
    strng[9] := ' ';
END;

Procedure Npad (VAR strng : strng2);
BEGIN
    if copy (strng, 1, 1) = ' ' then
        begin
            strng := copy (strng, 2, 1);
            insert ('0', strng, 1)
        end;
END;

Procedure Attributes;   { check for DIR / set size }
BEGIN
    if ((srec.attr and 16) = 16) then
        size := chr(178)+chr(177)+' DIR '+chr(177)+chr(178)
    else
        BEGIN
            str (srec.SIZE:8, size);
            comma (size);
            size := ' ' + size;
        END;
END;    { attributes }

Procedure CheckParams;
Var
    spc : integer;
    count: integer;
    chekpath: string [12];
BEGIN
    path := '*.*';
    tot := false;
    ext := false;
    dat := false;
    siz := false;
    help:= false;
    Reverse:= False;

    if (paramcount > 0) then
    BEGIN
            { set path }
        chekpath := paramstr(1);

        if pos (':', chekpath) = 2 then
            drive1 := copy(chekpath,1,2)
        else
            drive1 := '';

        if pos('/',ChekPath) <> 0 then
            ChekPath := '*.*';

        if (paramstr (1) = '.') then
            chekpath := '*.*';

        if (paramstr (1) = '..') then
            chekpath := '..\*.*';

        if (paramstr (1) = '...') then
            chekpath := '...\*.*';

        if (pos (':', chekpath) <> 0) and (length (chekpath) = 2) then
            chekpath := chekpath + '*.*';      { A: to  A:*.*}

        if (pos ('*',chekpath) <> 0) and (pos ('.', chekpath) = 0) then
            chekpath := paramstr(1) + '.*';

        FindFirst (chekpath, attr, srec);  { file or subdirectory? }

        if (doserror = 0) then   { TRADE is file, \TRADE is DIR }
        BEGIN
            count := 2;
            if (pos ('.', chekpath) = 0) and ((srec.attr and 16) = 16) then
                    path := chekpath + '\*.*'  { entire directory }
            else
                path := chekpath             { a file mask found }
        END
        else
        begin
            if copy (paramstr (1), 1, 1) = '/' then
                count := 1                   { not a file mask }
            else
            begin
                count := paramcount + 1;     { a file mask not found }
                path := paramstr (1);
            end
        end;

            { parse sort order sub string }
        parmstr := '';    { concat sub-string }
        Count := 1;
        while (count <= paramcount) do
        begin
            parmstr := parmstr + paramstr (count);
            count := count + 1;
        end;

        caps (parmstr);

        if (POS ('/T', PARMSTR) <> 0) then
            TOT := TRUE;
        if (POS ('/S', PARMSTR) <> 0) then
            SIZ := TRUE;
        IF (POS ('/E', PARMSTR) <> 0) THEN
            EXT := TRUE;
        IF (POS ('/D', PARMSTR) <> 0) THEN
            DAT := TRUE;
        IF (POS ('/R', PARMSTR) <> 0) THEN
            Reverse := TRUE;

        if (pos ('/', PARMSTR) <> 0) AND (DAT = FALSE) AND
            (TOT = FALSE) AND (EXT = FALSE) AND (SIZ = FALSE)
                AND (REVERSE = FALSE) THEN
            HELP := TRUE;

    END;
END;     { path }

Procedure Quicksort (Lo, Hi: integer);
    Procedure Sort (L, R: integer);
    var
        I, J: integer;
        X, Y: STRING [50];
    begin
        I := L;
        J := R;
        X := files [(L+R) DIV 2];
        repeat
            while files [I] < X do
                I := I + 1;
                while X < files [J] do
                    J := J - 1;
                if I <= J then
                    begin
                        Y := files [I];
                        files [I] := files [J];
                        files [J] := Y;
                        I := I+1;
                        J := J-1;
                    end;
        until I > J;
        if L < J then sort (L, J);
        if I < R then sort (I, R);
    end;
BEGIN    { quicksort }
    Sort (Lo, Hi);
END;     { quicksort }

Procedure SetCurs (CURSCN : LONGINT);
Var
    regs : registers;
begin
    REGS.AX := $100;
    REGS.CX := CURSCN;  { $2020 elims cursor, $0607 restores for EGA amd mono }
    INTR ($10, REGS);
end;

Procedure Truncate;
VAR
    DelAmt: integer;
Begin
    Pfile1 := files [count2 + group];
    Pfile2 := files [count2 + group + diff];
    DelAmt := 1;
    if (SIZ = true) then
        DelAmt := DelAmt + 9;

    if (DAT = true) then
        DelAmt := DelAmt + 5;

    if (EXT = true) then
        DelAmt := DelAmt + 3;

    delete (pfile1, 1, DelAmt);
    delete (pfile2, 1, DelAmt);
End;

Procedure ScrollUp (ScLines: integer);
Begin
    If Page > 0 then
        ScLines := ScLines + 1;

    if ScLines >= 25 then
        ScLines := 25
    else
        ScLines := ScLines + 1;

    REGS.AX := $600 + ScLines;
    REGS.BX := Colour * 256; { BH is scroll attribute - prob 7 gray }
    REGS.CX := $0000;        { top row , left col }
    REGS.DX := $184F;        { bot row, right col }

    INTR ($10, REGS);

    If (Page > 0) and (ScLines > 1) then
        ScLines := ScLines - 1;

    ScLines := MEM [$0:$451] + 1 - ScLines;

    if Sclines < 1 then
        ScLines := 1;

    gotoxy (1, ScLines);

    If (Page > 0) and (ScLines > 1) then
        Writeln ('───────────────────────────────────────┼───────────────────────────────────────');
End;

Procedure ShowFiles;       { prints list of files }
BEGIN
        Lines := FileCount div 2;
        if Lines <> (FileCount / 2) then
            Lines := Lines + 1;
        diff := lines;

        if (diff > 25) then diff := 25;
        count2 := 1;
        left  := Lines;
        group := 0;
        pivot := count2 + 25;

        ScrollNum := (MEM [$0:$451] + Left) - 24;

        if (ScrollNum >= 0) then
            ScrollUp (ScrollNum);

        while (count2 <= Lines) and (RetKey <> Chr(27)) DO
        begin
            truncate;

            write (pfile1 + ' │ ' + pfile2);
            count2 := count2 + 1;

            if (count2 = pivot)  then
            begin
                GETCHAR (RetKey);
                if (RetKey <> chr(27)) then
                begin
                    Page := Page + 1;
                    left := left - 25;
                    diff := left;

                    if (left < 25) then
                        left := left + 1;
                    ScrollUp (Left);

                    if diff > 25 then diff := 25;
                    group := group + 25;
                    pivot := count2 + 25;
                end;
            end
            else
                Writeln;
        end;
    end;

Procedure Getfiles;
BEGIN
    for FileCount := 1 to numfiles do
        files [FileCount] := '';
    TSIZE := 0;

    FindFirst (path, attr, srec);
    FileCount := 0;

    while (DosError = 0) and (FileCount < numfiles) do
    begin
        if (copy (srec.name, 1, 1) <> '.') then
        BEGIN
            FileCount := FileCount + 1;
            if (srec.attr and 16) <> 16 then
                tsize := tsize + srec.size;

            if (TOT = False) then         { 17 long }
            Begin
                UNPACKTIME (srec.TIME, dt);
                str (DT.YEAR:4, year);
                year := copy (year, 3, 2);
                str (DT.MONTH:2, month);
                str (DT.DAY:2, day);
                npad (day);
                str (dt.min:2, min);
                npad (min);
                str (dt.hour:2, hour);
                name := srec.name;
                fpad (name);
                attributes;

                if (EXT = true) then      { +3 }
                begin
                    extend := copy (name, 10, 3);
                    if (srec.attr and 16) = 16 then
                        extend := chr(0)+chr(0)+chr(0);  { directory }
                    name := extend + name;
                end;

                if (DAT = true) then      { +5 }
                    name := chr(255 xor (dt.year-1900)) + chr(255 xor dt.month)
                     + chr(255 xor dt.day) + chr(255 xor dt.hour)
                     + chr(255 xor dt.min) + name;

                if (SIZ = true) then      { +9 }
                begin
                    if (srec.attr and 16) = 16 then
                        name := '         ' + name
                    else
                        name := size + name;
                end;

                if (srec.attr and 16) = 16 then    { +1 }
                    name := chr(0) + name  { directory }
                else
                    name := chr(32) + name;

                Files [FileCount] := name+size+'  '+MONTH+'.'+DAY+'.'+YEAR+'  '+hour+':'+min;
            End;
        END;
        FindNext (srec);
    end;
END;

Function Cut (letters: string): string;
begin
    while copy (letters,1,1) = ' ' DO
        letters := copy (letters, 2, 80);
    while copy (letters, length (letters), 1) = ' ' DO
        letters := copy (letters, 1, length (letters) - 1);
    Cut := letters;
end;

BEGIN        { main }
    RetKey := ' ';
    Page := 0;
    attr := $37;
    Drive1 := '';

    GetDir (0,FirstDir);        { set current directory }
    CheckParams;       { look for sort specs, file mask, drive and directory }

    if (help = true) then
    begin
        writeln;
        writeln ('      Flags are:');
        writeln;
        writeln ('          /D  Sort by date and time.');
        writeln ('          /E  Sort by extension.');
        writeln ('          /S  Sort by size.');
        Writeln ('          /R  Reverse sort order.');
        writeln;
        writeln ('          /T  No sort:  Total bytes on disk for matching files.');
    end
    else
    begin
        if Drive1 <> '' then
            Chdir (Drive1);

        DiskLeft  := DiskFree (0);
        DiskSpace := DiskSize (0);

        GetFiles;

        IF (TOT = False) and (FileCount <> 0) THEN
        BEGIN            { set color for scroll }
            Colour := MEM [0:$449];
            If (Colour <> 7) then
                Colour := MEM [$B800:3841];  { FROM BOTTOM LINE ON SCREEN }

            QuickSort (1, FileCount);
            If (Reverse = True) then   { reverse sorted order }
                Flip;
                ShowFiles;
        END;

        if (RetKey <> Chr(27)) then
        begin
            if (FileCount <> 0) then
            begin
                str (tsize:11, size);
                comma (size);
                str (diskleft:12, dleft);
                comma (dleft);
                str (diskspace:12, dspace);
                comma (dspace);
                WRITE ('        ',SIZE,' bytes in ',FileCount,' files ... ',Cut(DLeft),' free of ',Cut(DSpace),'.');
                { volume label ? }
            end
            else
                WRITE ('                      No files found using '+path+' mask.');

            if (count2 = (pivot - 1)) then
                GETCHAR (RetKey);

            Chdir (FirstDir);
        end;
    end;
END.