AMIGA PD 1/AMIGA-PD-1.iso/Programme_zum_Heft/Programmieren/Kurztests/PascalPCQ/Examples/CheckDisk.p

Text File | 1991-04-17 | 5KB | 195 lines

Program CheckDisk;

{$I "Include:Utils/Break.i"}
{$I "Include:Libraries/DOS.i"}
{$I "Include:Utils/Parameters.i"}
{$I "Include:Utils/StringLib.i"}

{$O-}

type
{
    When I'm searching through a directory for files matching the
pattern, I also come across directories.  When I do I keep them in a
linked stack, using the record below, then print all the subdirectories
after I'm finished with the current directory.  That way the files from
the subdirectory aren't printed in the middle of files from the current
directory.
}
    DirRec = record
    Previous : ^DirRec;
    Name : Array [0..109] of Char;
    end;
    DirRecPtr = ^DirRec;

var
    FullPath : String;
    Directory : String;
    TestName : String;
    Errors   : Integer;

Function DirEnded(FName : String) : Boolean;
{
    returns false if you would want to append a '\' to the end
of FName before added a file name.
}
var
    l : Short;
begin
    l := strlen(FName);
    if l = 0 then
    DirEnded := True;
    DirEnded := (FName[l - 1] = ':') or (FName[l - 1] = '/');
end;

Procedure CheckFile(FileInfo : FileInfoBlockPtr);
{
    Displays whatever information you want from the FileInfoBlock
}
var
    l : Short;
    NameBuffer : Array [0..255] of Char;
    Name : String;
    F    : File of Char;
begin
    Name := Adr(NameBuffer);

    with FileInfo^ do begin
    StrCpy(Name, FullPath);
    l := strlen(FullPath);
    if not DirEnded(FullPath) then
        StrCat(Name, "/");
    StrCat(Name, String(Adr(fib_FileName)));
    Write('\r\e[KChecking ', Name);
    if reopen(Name, F, 10000) then begin
        while not eof(F) do begin
        Get(F);
        if IOResult <> 0 then begin
            Writeln('\e[KError Reading ', Name);
            Inc(Errors);
            Close(F);
            Return;
        end;
        end;
        Close(F);
        if IOResult <> 0 then begin
        Writeln('\e[KError Closing ', Name);
        Inc(Errors);
        end;
    end;
    end;
end;

Procedure UpCase(str : String);
{
    Converts a string to uppercase
}
var
    i : Integer;
begin
    i := 0;
    while str[i] <> '\0' do begin
    str[i] := toupper(str[i]);
    i := Succ(i);
    end;
end;

Procedure SearchDirectory(DirName : String);
{
    The big routine.  Runs through the named directory, printing
file names that match the global variable FileName, and making a list
of directories.  When it has finished looking through the directories,
it calls itself recursively to print its subdirectories.
}
var
    FL        : FileLock;
    FB        : FileInfoBlockPtr;
    Stay    : Boolean;
    LastPos    : Short;
    FirstDir,
    TempDir    : DirRecPtr;
    DOSError    : Integer;
begin
    if CheckBreak then
    return;
    LastPos := StrLen(FullPath);
    FirstDir := Nil;
    if not DirEnded(FullPath) then
    strcat(FullPath, "/");
    strcat(FullPath, DirName);
    FL := Lock(FullPath, ACCESS_READ);
    if FL = Nil then begin
    FullPath[LastPos] := '\0';
    return;
    end;
    New(FB);    { Since New() uses AllocMem, FB is longword aligned }
    if not Examine(FL, FB) then begin
    Unlock(FL);
    FullPath[LastPos] := '\0';
    return;
    end;
    if FB^.fib_DirEntryType < 0 then begin { means it's a file, not a dir }
    Unlock(FL);
    FullPath[LastPos] := '\0';
    return;
    end;
    repeat
    Stay := ExNext(FL, FB);
    if Stay then begin
        with FB^ do begin
        if fib_DirEntryType < 0 then begin { file }
            StrCpy(TestName, Adr(fib_FileName));
            UpCase(TestName);
            CheckFile(FB);
        end else begin            { a dir }
            new(TempDir);        { add it to the list }
            with TempDir^ do begin
            strcpy(Adr(Name), Adr(fib_FileName));
            Previous := FirstDir;
            end;
            FirstDir := TempDir;
        end;
        end;
    end else begin
        DOSError := IoErr;    { expect Error_No_More_Entries - not an error }
        if DOSError <> ERROR_NO_MORE_ENTRIES then
        Writeln('DOS Error number ', DOSError);
    end;
    if CheckBreak then begin        { user pressed Ctrl-C? }
        while FirstDir <> Nil do begin
        TempDir := FirstDir^.Previous;    { don't go through subs }
        Dispose(FirstDir);
        FirstDir := TempDir;
        end;
        Stay := False;
    end;
    until not Stay;
    Unlock(FL);
    while FirstDir <> Nil do begin        { print sub-directories }
    SearchDirectory(Adr(FirstDir^.Name));
    TempDir := FirstDir^.Previous;
    Dispose(FirstDir);
    FirstDir := TempDir;
    end;
    FullPath[LastPos] := '\0';            { restore global path name }
end;

Procedure Usage;
begin
    Writeln('Usage: CheckDisk BaseDirectory');
    Exit(20);
end;

begin
    Directory := AllocString(128);
    TestName := AllocString(110);
    FullPath := AllocString(300);    { allocate plenty of space }
    FullPath[0] := '\0';
    GetParam(1, Directory);
    if Directory^ = '\0' then
    Usage;
    Errors := 0;
    SearchDirectory(Directory);
    WriteLn('\r\e[KThere were ', Errors, ' errors.');
end.