home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-387-Vol-3of3.iso
/
m
/
msh_ut11.zip
/
RM.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-05-09
|
5KB
|
171 lines
PROGRAM RM;
{$V-,I-,S-,A+,R-}
{ A file-remove-program for use with the Mi-Shell }
{ You can always cancel the process by pressing }
{ escape-key at (nearly) any time. }
{ Written by Jens Pirnay in 1992 }
{-----------------------------------------------------}
{ Jens Pirnay <pirnay@rphs1.physik.uni-regensburg.de> }
{ This file is subject to the copyleft-regulations }
{ of the Free Software Foundation (the guys from GNU) }
{-----------------------------------------------------}
{ DEFINE German} { For german messages instead of english }
USES DOS, CRT, MSHSupport, MiniWindow;
VAR i, j : WORD;
Tmp : STRING;
CONST doall : BOOLEAN = FALSE;
recursion : BOOLEAN = FALSE;
PROCEDURE KillFiles (files : STRING; askdir : BOOLEAN);
VAR S : SearchRec;
F : FILE;
BaseDir : STRING [127];
doit : BOOLEAN;
Name : STRING [8];
Ext : STRING [4];
answer : BYTE;
doserr : INTEGER;
BEGIN
FSplit (Files, BaseDir, Name, Ext);
FINDFIRST (Files, AnyFile, S);
doserr := DOSError;
WHILE doserr = 0 DO
BEGIN
IF KEYPRESSED THEN
BEGIN
IF READKEY = #27 THEN
HALT;
END;
WITH S DO
BEGIN
doit := TRUE;
IF (S.Attr AND Directory <> 0) AND
(S.Name <> '.') AND (S.Name <> '..')
AND recursion THEN
BEGIN
IF askdir THEN
BEGIN
{$IFDEF German}
answer := Alert ('Wollen Sie das Verzeichnis:||>> ' + S.Name +
' <<||wirklich löschen', ' Ja |Nein|Rekursiv');
{$ELSE}
answer := Alert ('Do you really want to delete|this directory:||>> '
+ S.Name + ' <<', 'Yes| No |Recursive');
{$ENDIF}
IF answer = 255 THEN HALT;
END
ELSE
answer := 3;
IF (answer = 1) OR (answer = 3) THEN
BEGIN
IF answer = 3 THEN
KillFiles (BaseDir + S.Name + '\*.*', FALSE);
RMDIR (BaseDir + S.Name);
IF IORESULT <> 0 THEN ;
END;
END
ELSE
BEGIN
IF (S.Attr AND ReadOnly <> 0) THEN
BEGIN
IF doall THEN
BEGIN
answer := 3;
END
ELSE
BEGIN
{$IFDEF German}
answer :=
Alert ('Folgende Datei ist schreibgeschützt:||>> ' +
S.Name + ' <<||Trotzdem löschen?', ' Ja | Nein | Alle ');
{$ELSE}
answer :=
Alert ('File is write-protected:||>> ' +
S.Name + ' <<||Delete anyway?', ' Yes | No | All ');
{$ENDIF}
END;
IF answer = 255 THEN HALT; { Escape }
IF answer = 3 THEN
doall := TRUE;
IF answer = 2 THEN
BEGIN
doit := FALSE;
END
ELSE
BEGIN
ASSIGN (F, BaseDir + S.Name);
SETFATTR (F, Archive);
CLOSE (F);
IF IORESULT = 0 THEN ;
END;
END;
IF doit THEN
BEGIN
ASSIGN (F, BaseDir + S.Name);
ERASE (F);
IF IORESULT = 0 THEN ;
END;
END;
END;
FINDNEXT (S);
doserr := DOSError;
END;
END;
PROCEDURE help;
begin
{$IFDEF German}
WRITELN ('Aufruf: rm [-rf] Datei(en)');
WRITELN (' löscht auch Unterverzeichnisse, falls "-r"');
WRITELN (' fragt nicht bei Verzeichnissen oder');
WRITELN (' schreibgeschützten Dateien nach, falls "-f"');
{$ELSE}
WRITELN ('Usage: rm [-rf] file(s)');
WRITELN (' deletes even subdirectories, if "-r"');
WRITELN (' does not confirm deletion for');
WRITELN (' directories or read-only files, if "-f"');
{$ENDIF}
end;
PROCEDURE Get_Param (VAR First_Param : WORD);
VAR pc, psp : INTEGER;
st : STRING;
PROCEDURE select ( ch : CHAR; st : STRING; VAR action : BOOLEAN );
BEGIN
IF (POS (ch, st) > 1) OR (POS (UPCASE (ch), st) > 1)
THEN action := TRUE;
END;
BEGIN {Get_Param}
pc := MSHParamCount;
psp := 1;
st := COPY (MSHParamStr (psp), 1, 1);
WHILE (st [1] = '/') OR (st [1] = '-') DO BEGIN
select ('r', MSHParamStr (psp), recursion);
select ('f', MSHParamStr (psp), doall);
INC (psp);
IF pc < psp THEN help;
st := COPY (MSHParamStr (psp), 1, 1);
END;
First_Param := psp;
END; {Get_Param}
BEGIN
IF MSHParamCount > 0 THEN
BEGIN
Get_param(j);
FOR i := j TO MSHParamCount DO
BEGIN
tmp := MSHParamStr (i);
KillFiles (tmp, NOT doall); { ask if directory }
END;
END
ELSE
help;
END.