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
/
CPMV.INC
< prev
next >
Wrap
Text File
|
1992-05-10
|
38KB
|
1,058 lines
{-----------------------------------------------------}
{ 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) }
{-----------------------------------------------------}
{
This is a common include-file for cp.pas and mv.pas,
there are only slight differences, that can be easily
overcome by conditional compilation
}
{
Mark a special case: if there is only one file
to copy or move, we will treat the destination path as
the destination file (if this name isn't a directory)
}
{$V-,I-} { No fuzzy string-check, no io-errors }
CONST
BuffSize = $8000;
DAttr = Dos.Directory OR Dos.Hidden OR Dos.ReadOnly;
WAttr : BYTE = Dos.ReadOnly;
FAttr : BYTE = Dos.Archive OR Dos.ReadOnly OR Dos.Directory;
TYPE
Bfr = ARRAY [1..BuffSize] OF BYTE;
pBuf = ^Buffer;
Buffer = RECORD
Buf : Bfr;
next : pBuf
END;
FP = ^FL;
FL = RECORD
sRec : Dos.SearchRec;
{$IFDEF MV}
SourceDir : Dos.DirStr;
{$ENDIF}
numRecrd, { Num of read-Record }
numByte : WORD; { Num ov read-Byte }
WCount : LONGINT; { total written-byte }
sAdrBuf : POINTER; { start address of the Buffer }
eoFF, { input is EOF }
skip : BOOLEAN; { this file should be skipped }
nextP : FP
END;
dDisk = (source, dest);
CONST Bsize = SIZEOF (Buffer) + SIZEOF (FL);
VAR
progName : Dos.NameStr;
st : STRING [2];
CONST
psp : INTEGER = 1;
{$IFDEF CP}
tStamp : BOOLEAN = FALSE; { By default copy even newer files }
{$ENDIF}
{$IFDEF FORMAT}
FormatDrv : BOOLEAN = FALSE; { By default don't ask for format }
{$ENDIF}
recursion : BOOLEAN = FALSE; { No recursion by default }
force : BOOLEAN = FALSE; { By default don't overwrite }
{ ---------------------- general procedure/Functions ---------------------- }
PROCEDURE abort;
BEGIN
EndInfo;
HALT;
END;
{$IFDEF Format}
const
disksides = 2;
{Anzahl der zu formatierenden Seiten}
bootsek : array[1..108] of byte =
($eb,$34,$90,$56,$42,32,$2d,32,$63,$27,$54,
0,2,0,1,0,2,0,0,0,0,0,0,0,0,0,disksides,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,$fa,$b8,$30,0,$8e,$d0,$bc,$fc,
0,$fb,$e,$1f,$bb,7,0,$be,$6c,$7c,$90,$8a,
4,$46,$3c,0,$74,8,$b4,$e,$56,$cd,$10,$5e,
$eb,$f1,$b4,1,$cd,$16,$74,6,$b4,0,$cd,$16,
$eb,$f4,$b4,0,$cd,$16,$33,$d2,$cd,$19);
{$IFDEF German}
boottext1 : array[1..39] of char =
#13#10'Diskette hat keine Systemdateien !'#13#10#10;
boottext2 : array[1..83] of char =
'Um die Systemdateien zu übertragen muß die Diskette mit SYS A: behandelt werden.'#13#10#10;
boottext3 : array[1..59] of char =
'Bitte Diskette wechseln und weiter mit beliebiger Taste.'#13#10#10;
{$ELSE}
boottext1 : array[1..39] of char =
#13#10'This disk contains no systemfiles!'#13#10#10;
boottext2 : array[1..83] of char =
'To make disk bootable, you have transfer system-files with the command "SYS A:".'#13#10#10;
boottext3 : array[1..59] of char =
'Please change disks and continue by pressing any key... '#13#10#10;
{$ENDIF}
type
sector = array[1..512] of byte;
track = array[1..18,1..512] of byte;
secptr = ^track;
var
fmttyp : shortint; {Formatauswahl}
art : byte; {Art des Laufwerks (s. Formunit)}
verifyflag : boolean; {Verifizieren ?}
puffer : secptr; {Platz für max. 18 Sektoren}
{***********************Unterprogramme***********************}
procedure ExitFmt;
begin
laufwerkstabalt;
freemem(puffer, SizeOf(track));
end;
{************************************************************}
procedure diskprep(drive: byte; sekzahl : byte; anzsek : word);
var {Bootsektor, ROOT und FAT schreiben}
zaehler : byte;
anzahl : byte;
i : integer;
kopie : integer;
fehler : byte;
begin
anzahl:=formtab^[4]*2+round(formtab^[3]*32/512);
{Sektoren FAT und ROOT}
fillchar(puffer^, SizeOf(track), 0); {Puffer löschen}
for i:=1 to 108 do puffer^[1,i]:=bootsek[i];
puffer^[1,14]:=formtab^[2]; {Sektoren pro Cluster}
puffer^[1,18]:=formtab^[3];
puffer^[1,19]:=0; {Anzahl der Einträge im Hauptverzeichnis}
puffer^[1,20]:=lo(anzsek);
puffer^[1,21]:=hi(anzsek); {Anzahl der Sektoren total}
puffer^[1,22]:=formtab^[1]; {Mediabyte}
puffer^[1,23]:=formtab^[4];
puffer^[1,24]:=0; {Sektoren pro FAT}
puffer^[1,25]:=sekzahl; {Sektoren pro Seite einer Spur}
for i:=1 to 39 do puffer^[1,i+108]:=ord(boottext1[i]);
for i:=1 to 83 do puffer^[1,i+147]:=ord(boottext2[i]);
for i:=1 to 59 do puffer^[1,i+230]:=ord(boottext3[i]);
puffer^[1,511]:=$55;
puffer^[1,512]:=$aa; {Ende des Bootsektors}
fehler:=readwriteverify(3, 0, 0, 1, 1, drive, puffer^);
for i:=1 to 512 do puffer^[1,i]:=0;
{Bootsektor in Puffer löschen}
puffer^[1,1]:=formtab^[1]; {Mediabyte}
puffer^[1,2]:=$ff;
puffer^[1,3]:=$ff;
kopie:=formtab^[4]+1;
puffer^[kopie,1]:=formtab^[1];
puffer^[kopie,2]:=$ff;
puffer^[kopie,3]:=$ff;
fehler:=readwriteverify(3, 0, 0, 2, sekzahl-1, drive,
puffer^);
dec(anzahl,sekzahl-1);
fillchar(puffer^, SizeOf(track), 0); {Puffer löschen}
fehler:=readwriteverify(3, 0, 1, 1, anzahl, drive,
puffer^);
end;
{************************************************************}
procedure diskformat(drive, fmttyp, spurzahl, sekzahl : byte);
{Diskette formatieren}
var
spur : byte; {Aktuelle Spur}
sek : byte; {Aktueller Sektorpuffer}
seite : byte; {Aktuelle Seite}
anzsektor : word; {Sektoren auf Disk}
fehler : byte; {Fehler bei Diskoperationen}
begin
getmem(puffer, SizeOf(track));
schreibrate(art, fmttyp, drive);
{Schreibrate für Format setzen}
laufwerkstabneu; {DPB für Format setzen}
anzsektor:=spurzahl*sekzahl*disksides;
spur:=0;
repeat
if einzelschritt then einzelstep;
for seite:=0 to (disksides-1) do
begin
{$IFDEF German}
UpdateInfo (2, 'Formatiere...', spur*disksides+seite,
spurzahl*disksides);
{$ELSE}
UpdateInfo (2, 'Formatting...', spur*disksides+seite,
spurzahl*disksides);
{$ENDIF}
fehler:=spurformat(spur, seite, 1, sekzahl, drive);
if fehler=3 then
begin
{$IFDEF German}
fehler := Alert('Diskette ist schreibgeschützt !', 'Abbruch');
{$ELSE}
fehler := Alert('Disk is write protected !', 'Cancel');
{$ENDIF}
ExitFmt;
exit;
end;
if verifyflag then
fehler:=readwriteverify(4, spur, seite, 1,
sekzahl, drive, puffer^);
if fehler<>0 then
begin
{$IFDEF German}
fehler := Alert('Diskette für dieses Format unbrauchbar !', 'Abbruch');
{$ELSE}
fehler := Alert('Improper format for this disk!', 'Cancel');
{$ENDIF}
ExitFmt;
exit;
end;
end;
inc(spur); {Nächste Spur}
until (spur>=spurzahl);
diskprep(drive, sekzahl, anzsektor);
ExitFmt;
end;
PROCEDURE FormatDrive (drive : BYTE);
BEGIN
verifyflag:=true; {Verify : ON}
art:=laufwerka; {Art des Laufwerkes s. Unit Formunit}
if drive=0 then art:=laufwerka else art:=laufwerkb;
{$IFDEF German}
fmttyp := Alert('Disketten-Kapazität in kB', '360|720|1200|1440');
{$ELSE}
fmttyp := Alert('Disk-capacity in kB', '360|720|1200|1440');
{$ENDIF}
case fmttyp of
1 : diskformat(drive, fmttyp, 40, 9); {360 KB}
2 : diskformat(drive, fmttyp, 80, 9); {720 KB}
3 : diskformat(drive, fmttyp, 80, 15); {1,2 MB}
4 : diskformat(drive, fmttyp, 80, 18); {1,44 MB}
ELSE
end;
end;
{$ENDIF}
PROCEDURE CheckDrive(dst : STRING);
var regs : Registers;
drive, ans, stat : BYTE;
problem, options : STRING;
begin
IF Copy(dst, 2, 1) = ':' THEN
BEGIN
drive := ORD(Upcase(dst[1])) - ORD('A');
IF drive<2 THEN
BEGIN
REPEAT
with regs do
begin
ah := $00;
intr($13,regs);
ah := $03;
al := $01;
dh := $00;
dl := drive;
ch := $00;
cl := $FF;
intr($13,regs);
end;
case mem[$40:$41] of
$02,$04 : stat := 0; { OK }
$03 : stat := 1 { WriteProt }
else stat := 2; { Not ready }
end;
IF stat<>0 THEN
BEGIN
{$IFDEF German}
if stat=1 THEN problem := 'Diskette ist schreibgeschützt!'
ELSE problem := 'Laufwerk ist nicht bereit!';
if stat=1 THEN options := 'Nochmal|Abbruch'
{$IFDEF Format}
ELSE options := 'Nochmal|Abbruch|Format';
{$ELSE}
ELSE options := 'Nochmal|Abbruch';
{$ENDIF}
{$ELSE}
if stat=1 THEN problem := 'Disk is write-protected!'
ELSE problem := 'Drive is not ready!';
if stat=1 THEN options := 'Again|Cancel'
{$IFDEF Format}
ELSE options := 'Again|Cancel|Format';
{$ELSE}
ELSE options := 'Again|Cancel';
{$ENDIF}
{$ENDIF}
ans := Alert(problem, options);
IF ans = 2 THEN
abort;
{$IFDEF Format}
IF ans = 3 THEN
FormatDrive(drive); { drive = 0/1 }
{$ENDIF}
END;
UNTIL stat=0;
END;
END;
end;
PROCEDURE getCSize ( Drvnum : WORD; VAR CSize : WORD );
VAR reg : Dos.REGISTERS;
BEGIN
reg.AH := $1c; reg.DL := BYTE (Drvnum); MSDOS (reg);
CSize := reg.AL * reg.CX
END;
FUNCTION CLusterSIZE ( Size : LONGINT; CSize : WORD ) : WORD;
BEGIN
IF Size MOD Csize = 0 THEN ClusterSIZE := Size DIV Csize
ELSE ClusterSIZE := Size DIV Csize + 1
END;
PROCEDURE get_next (VAR sRec : Dos.SearchRec;
VAR dError : INTEGER;
VAR src_Fn : DOS.DirStr;
VAR param : WORD;
LastParam : WORD);
VAR st : STRING[1]; answer : WORD;
BEGIN
Dos.FINDNEXT (sRec); dError := DosError;
if dError<>0 THEN { Current pattern is finished }
BEGIN
REPEAT
INC(param);
IF (param<=LastParam) THEN
BEGIN
src_Fn := MSHParamStr (param);
src_fn := Dos.FExpand (src_Fn);
st := COPY (src_Fn, LENGTH (src_Fn), 1);
IF (st = '\') OR (st = ':') THEN src_Fn := src_Fn + '*.*';
system.FileMode := 0; { read only }
(*
answer := Alert ('FindFirst:'+ src_fn, 'OK');
*)
Dos.FINDFIRST ( src_Fn, FAttr, sRec );
dError := DosError;
WHILE (dError = 0) AND
( (sRec.attr AND Dos.Directory) <> 0) AND { skip ./.. }
( (sRec.name = '.') OR (sRec.Name = '..') ) DO
get_next (sRec, dError, src_fn, param, LastParam);
IF recursion = FALSE THEN
WHILE (dError = 0) AND ( (sRec.attr AND Dos.Directory) <> 0)
DO get_next (sRec, dError, src_fn, param, LastParam);
END;
UNTIL (dError=0) OR (param>LastParam);
{ Continue even if pattern not found }
END;
END;
PROCEDURE make_directory ( Dir : Dos.DirStr; dRec : Dos.SearchRec );
PROCEDURE cut_sub ( inDir : Dos.DirStr; VAR outDir : Dos.DirStr );
VAR po : WORD;
BEGIN
po := LENGTH (inDir);
WHILE (po > 0) AND (inDir [po] <> '\') DO DEC (po);
outDir := COPY (inDir, 1, po - 1)
END;
VAR dd : Dos.DirStr; i : INTEGER;
BEGIN
dd := Dir;
Dos.FINDFIRST ( dd, DAttr, dRec ); { check Dir exists? }
IF DosError <> 0 THEN BEGIN
MKDIR (dd);
IF IORESULT <> 0 THEN BEGIN
cut_sub ( dd, dd);
make_directory ( dd, dRec );
END;
END;
MKDIR (Dir); i := IORESULT; { reSet ioResult for later use of File }
END;
{ ---------------------- general procedure/Functions ---------------------- }
PROCEDURE Get_Param ( VAR Dst_path : STRING;
VAR First_src_Fn : WORD);
VAR
Dir : Dos.DirStr; Nam : Dos.NameStr; Ext : Dos.ExtStr;
pc : INTEGER;
PROCEDURE help;
BEGIN
WRITELN (progName, ' by nemossan/pirnay V.1.0');
{$IFDEF German}
{$IFDEF CP}
WRITELN ('Ex: ', progName, ' [/ifrt] [Dr:[Dir\]]*.pas [Dr:[Dir\]]');
WRITELN (' ', progName, ' [-ifrt] [Dr:[Dir\]]*.* [Dr:][Dir\]');
WRITELN (' ', progName, ' [-t /r ] [Dr:[Dir\]]s*.* [Dr:[Dir\]]');
WRITELN ('1.Parameter: Optionen Parameter.');
WRITELN (' Manuelles Verändern des Zielpfads, mit "i".');
WRITELN (' überschreiben existierender Dateien, mit "f".');
WRITELN (' REKURSIVES Kopieren, mit "r".');
WRITELN (' Kopieren nur von NEUEREN Dateien, mit "t".');
WRITELN (' (setzt automatisch "f")');
WRITELN (' erzwinge Formatieren von A:/B: mit "z".');
WRITELN ('Weitere Parameter: Quell-Datei(en)/Verzeichnis, Wildcards erlaubt.');
WRITELN (' Kopiert rekursiv Verzeichnisse mit Option "-r".');
WRITELN ('Letzter Parameter: Ziel-Verzeichnis');
WRITELN ('Spezialfall: Ist nur 1 Datei zu kopieren, und der letzte Parameter');
WRITELN ('kein Verzeichnis, so wird dies der Name der zu erzeugenden Kopie');
{$ELSE} {CP=MV}
WRITELN ('Ex: ', progName, ' [/ifr] [Dr:[Dir\]]*.pas [Dr:[Dir\]]');
WRITELN (' ', progName, ' [-ifr] [Dr:[Dir\]]*.* [Dr:][Dir\]');
WRITELN (' ', progName, ' [-t /r ] [Dr:[Dir\]]s*.* [Dr:[Dir\]]');
WRITELN ('1.Parameter: Optionen Parameter.');
WRITELN (' Manuelles Verändern des Zielpfads, mit "i".');
WRITELN (' überschreiben existierender Dateien, mit "f".');
WRITELN (' REKURSIVES Verschieben, mit "r".');
WRITELN (' erzwinge Formatieren von A:/B: mit "z".');
WRITELN ('Weitere Parameter: Quell-Datei(en)/Verzeichnis, Wildcards erlaubt.');
WRITELN (' Verschiebt rekursiv Verzeichnisse mit Option "-r".');
WRITELN ('Letzter Parameter: Ziel-Verzeichnis');
WRITELN ('Spezialfall: Ist nur 1 Datei zu verschieben, und der letzte Parameter');
WRITELN ('kein Verzeichnis, so wird dies der neue Name der Datei');
{$ENDIF} {CP}
{$ELSE} {German}
{$IFDEF CP}
WRITELN ('Ex: ', progName, ' [/iftr] [Dr:[Dir\]]*.pas [Dr:[Dir\]]');
WRITELN (' ', progName, ' [-iftr] [Dr:[Dir\]]*.* [Dr:][Dir\]');
WRITELN (' ', progName, ' [-t /r ] [Dr:[Dir\]]s*.* [Dr:[Dir\]]');
WRITELN ('1st-param(s): option parameters.');
WRITELN (' manual correction of dest.-path, when "i".');
WRITELN (' overwrites existing files, when "f".');
WRITELN (' RECURSIVEly copies, when "r".');
WRITELN (' copies only NEWER File(s) when "t".');
WRITELN (' (implicitly sets "f")');
WRITELN (' force formatting of drive a:/b: when "z".');
WRITELN ('next-param(s): input File(s)/Dir(s), wild-card allowed.');
WRITELN (' recursively copies if Dir-name matched and "-r".');
WRITELN ('last-param: Destination-path');
WRITELN ('N.B.: If there is just 1 file to copy, and the last param is no');
WRITELN ('directory, then this last param becomes the name of the copy');
{$ELSE} {CP=MV}
WRITELN ('Ex: ', progName, ' [/ifr] [Dr:[Dir\]]*.pas [Dr:[Dir\]]');
WRITELN (' ', progName, ' [-ifr] [Dr:[Dir\]]*.* [Dr:][Dir\]');
WRITELN (' ', progName, ' [-t /r ] [Dr:[Dir\]]s*.* [Dr:[Dir\]]');
WRITELN ('1st-param(s): option parameters.');
WRITELN (' manual correction of dest.-path, when "i".');
WRITELN (' overwrites existing files, when "f".');
WRITELN (' RECURSIVEly moves, when "r".');
WRITELN (' force formatting of drive a:/b: when "z".');
WRITELN ('next-param(s): input File(s)/Dir(s), wild-card allowed.');
WRITELN (' recursively moves if Dir-name matched and "-r".');
WRITELN ('last-param: Destination-path');
WRITELN ('N.B.: If there is just 1 file to move, and the last param is no');
WRITELN ('directory, then this last param becomes the new name of the file');
{$ENDIF} {CP}
{$ENDIF} {GERMAN}
HALT;
END;
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;
CONST psp : INTEGER = 1;
interactive : BOOLEAN = FALSE;
BEGIN {Get_Param}
Dos.FSplit (Dos.FExpand (MSHPARAMSTR (0) ), Dir, Nam, Ext);
progName := Nam;
pc := MSHParamCount;
IF pc = 0 THEN help
ELSE BEGIN
st := COPY (MSHParamStr (psp), 1, 1);
WHILE (st [1] = '/') OR (st [1] = '-') DO BEGIN
select ('i', MSHParamStr (psp), interactive);
{$IFDEF CP}
select ('t', MSHParamStr (psp), tStamp);
{$ENDIF}
select ('r', MSHParamStr (psp), recursion);
select ('f', MSHParamStr (psp), force);
{$IFDEF Format}
select ('z', MSHParamStr (psp), FormatDrv);
{$ENDIF}
INC (psp);
IF pc < psp THEN help;
st := COPY (MSHParamStr (psp), 1, 1);
END;
{$IFDEF CP}
IF tStamp = TRUE THEN
force := TRUE;
{$ENDIF}
First_src_Fn := psp;
END;
FAttr := FAttr OR Dos.Hidden; WAttr := WAttr OR Dos.Hidden;
FAttr := FAttr OR Dos.SysFile; WAttr := WAttr OR Dos.Sysfile;
Dst_path := MSHParamStr (MSHParamCount);
IF (COPY (Dst_path, LENGTH (Dst_path), 1) <> ':') AND
(COPY (Dst_path, LENGTH (Dst_path), 1) <> '\') THEN
dst_Path := dst_Path + '\';
dst_Path := Dos.FExpand (dst_Path);
IF interactive THEN
BEGIN
{$IFDEF German}
InputStr ('Geben Sie das Zielverzeichnis an:', FALSE, dst_Path);
{$ELSE}
InputStr ('Confirm the destination path:', FALSE, dst_Path);
{$ENDIF}
IF dst_path = '' THEN
Halt
ELSE
BEGIN
IF (COPY (Dst_path, LENGTH (Dst_path), 1) <> ':') AND
(COPY (Dst_path, LENGTH (Dst_path), 1) <> '\') THEN
dst_Path := dst_Path + '\';
dst_Path := Dos.FExpand (dst_Path);
END;
END;
IF (POS ('*', Dst_path) <> 0) OR (POS ('?', Dst_path) <> 0) THEN
help; { Destination has to be without wildcards! }
END; {Get_Param}
PROCEDURE readWrite ( VAR src_Fn : DOS.PathStr;
Dst_path : Dos.PathStr;
VAR Tnum, LCount : WORD;
SpecialCase : BOOLEAN;
FirstParam,
LastParam : WORD);
VAR
StorePath : DOS.PathStr;
sFn, dFn, oFn : Dos.PathStr;
sRc : Dos.SearchRec;
inF, otF : FILE;
sB, cB, oB : pBuf;
Finfo, Cinfo,
Oinfo : FP; { First/Current/Old File-info's }
iError,
dError : INTEGER;
param : WORD;
skipping : BOOLEAN;
{$IFDEF MV}
PROCEDURE TestRenaming ( src_fn, dst_fn : STRING;
VAR info : FP );
VAR possible, done : BOOLEAN;
F : FILE; rec : SearchRec;
i : INTEGER;
Dir : Dos.DirStr; Nam : Dos.NameStr; Ext : Dos.ExtStr;
dRec : Dos.SearchRec;
answer : BYTE;
BEGIN
done := FALSE;
possible := (Upcase(src_fn[1]) = Upcase(dst_fn[1])) AND
(src_fn[2]=':') AND (dst_fn[2]=':');
If possible THEN
BEGIN
{ Does file already exist ? }
answer := doserror; { reset doserror }
FindFirst(dst_fn, AnyFile, rec);
IF doserror = 0 THEN { found }
BEGIN
possible := FALSE;
IF rec.Attr AND DOS.Directory = 0 THEN { Normal file }
BEGIN
IF force = FALSE THEN { Ask first }
BEGIN
{$IFDEF German}
answer := Alert ('Warnung! Die Datei "' + info^.srec.name +
'" existiert schon im Zielverzeichnis!',
'Überschr.|Nächste|Alle|Abbruch');
{$ELSE}
answer := Alert ('Warning! File "' + info^.srec.name +
'" does already exist!',
'Write|Skip|All|Abort');
{$ENDIF}
IF (answer = 255) OR (answer = 4) THEN abort;
IF answer = 3 THEN force := TRUE;
possible := (answer=1) OR (answer=3);
END
ELSE
possible := TRUE;
IF possible THEN
BEGIN
ASSIGN(F, dst_fn);
Dos.SETFATTR ( F, DOS.Archive );
rewrite(F);
iError := IORESULT;
ERASE (F);
iError := ioresult;
possible := iError=0;
answer := doserror;
END;
END;
END
ELSE
possible := TRUE;
IF possible THEN
BEGIN
{ Rename file }
{$IFDEF German}
UpdateInfo (2, 'Verschiebe ' + info^.Srec.Name, 1, 1);
{$ELSE}
UpdateInfo (1, 'Moving ' + info^.Srec.Name, 1, 1);
{$ENDIF}
Dos.FSplit (dst_fn, Dir, Nam, Ext);
IF (LENGTH (Dir) > 3) AND (Dir [LENGTH (Dir) ] = '\') THEN
BEGIN
Dir := COPY (Dir, 1, LENGTH (Dir) - 1);
make_directory ( Dir, dRec );
END;
ASSIGN(F, src_fn);
RENAME(F, dst_fn);
iError := ioresult;
done := iError = 0;
END;
END;
info^.skip := done;
info^.eoff := done;
END;
{$ENDIF}
PROCEDURE READing (VAR dError : INTEGER; VAR Rnum : WORD);
PROCEDURE readF;
VAR s : LONGINT;
BEGIN
WHILE (NOT EOF (inF) ) AND (MAXAVAIL > Bsize) DO BEGIN
system.FileMode := 0; { read only }
BLOCKREAD ( inF, cB^.Buf, BuffSize, Cinfo^.numByte );
s := BuffSize;
s := s * Cinfo^.numRecrd;
s := s + Cinfo^.numbyte + Cinfo^.WCount;
{$IFDEF German}
UpdateInfo (1, 'Lese ' + Cinfo^.Srec.Name,
s, Cinfo^.Srec.Size);
{$ELSE}
UpdateInfo (1, 'Reading ' + Cinfo^.Srec.Name,
s, Cinfo^.Srec.Size);
{$ENDIF}
INC (Cinfo^.numRecrd);
oB := cB; NEW (cB); oB^.next := cB; cB^.next := NIL
END;
Cinfo^.eoFF := EOF (inF);
CLOSE (inF);
IF KeyPressed AND (ReadKey=#27) THEN abort;
END;
VAR Dir : Dos.DirStr; Nam : Dos.NameStr; Ext : Dos.ExtStr;
tmp : STRING;
BEGIN {READing}
NEW (sB); cB := sB; sB^.next := NIL; Cinfo^.numRecrd := 0;
Cinfo^.skip := FALSE; Cinfo^.eoFF := FALSE;
WHILE (dError = 0) AND (MAXAVAIL > Bsize) AND
( (sRc.Attr AND Directory) = 0) DO BEGIN
IF Cinfo^.WCount = 0 THEN BEGIN { read this File, first }
Cinfo^.sRec := sRc;
Dos.FSplit (Dos.FExpand (src_Fn), Dir, Nam, Ext);
sFn := Dir + Cinfo^.sRec.Name;
INC (Rnum);
{$IFDEF MV}
Cinfo^.SourceDir := Dir;
IF SpecialCase THEN
tmp := Dst_Path
ELSE
tmp := Dst_Path + Cinfo^.sRec.Name;
TestRenaming(sFn, tmp, CInfo);
{$ENDIF}
END;
IF NOT Cinfo^.skip THEN
BEGIN
ASSIGN (inF, sFn); RESET (inF, 1); SEEK (inF, Cinfo^.WCount);
iError := ioresult;
Cinfo^.sAdrBuf := cB;
readF; { read until EOF/memory-full }
END;
IF Cinfo^.eoFF THEN get_next (sRc, dError, src_Fn, param, LastParam);
Oinfo := Cinfo; { increase Current File info }
NEW (Cinfo);
Oinfo^.nextP := Cinfo;
Cinfo^.nextP := NIL; Cinfo^.numRecrd := 0; Cinfo^.eoFF := FALSE;
Cinfo^.skip := FALSE; Cinfo^.WCount := 0;
END;
END; { READing }
PROCEDURE WRITing (VAR Wnum : WORD);
VAR
Dir : Dos.DirStr; Nam : Dos.NameStr; Ext : Dos.ExtStr;
dRec : Dos.SearchRec; DNum : WORD; CSize : WORD;
answer : BYTE; DiskFull : BOOLEAN;
{$IFDEF MV} F : FILE; {$ENDIF}
PROCEDURE write1Block (VAR otF : FILE; Cinfo : FP; VAR cB : pBuf;
VAR DiskFull : BOOLEAN);
VAR size, written : WORD;
BEGIN
DiskFull := FALSE;
IF Cinfo^.numRecrd > 1 THEN size := Buffsize
ELSE size := Cinfo^.numByte;
written := size;
IF NOT Cinfo^.skip THEN
BLOCKWRITE (otF, cB^.Buf, size, written);
DiskFull := (written < size);
IF DiskFull THEN
BEGIN
WriteLn(written, '<', size); ReadLn;
END;
Cinfo^.WCount := Cinfo^.WCount + size;
{$IFDEF German}
UpdateInfo (2, 'Schreibe ' + Nam + ext,
Cinfo^.Wcount, Cinfo^.Srec.Size);
{$ELSE}
UpdateInfo (2, 'Writing ' + Nam + ext,
Cinfo^.Wcount, Cinfo^.Srec.Size);
{$ENDIF}
DEC (Cinfo^.numRecrd);
cB := cB^.next;
IF KeyPressed AND (ReadKey=#27) THEN
BEGIN
Close(otF);
abort;
END;
END;
VAR tmpSize : LONGINT;
BEGIN {WRITing}
Cinfo := Finfo; cB := sB; skipping := FALSE;
WHILE (Cinfo^.nextP <> NIL) DO BEGIN
oFn := dFn;
IF SpecialCase THEN
dFn := Dst_Path
ELSE
dFn := Dst_Path + Cinfo^.sRec.Name;
Dos.FSplit (Dos.FExpand (dFn), Dir, Nam, Ext);
IF (Cinfo^.WCount = 0) OR (oFn <> dFn) THEN
BEGIN { write first-time }
skipping := CInfo^.skip;
IF NOT skipping THEN
BEGIN
IF (LENGTH (Dir) > 3) AND (Dir [LENGTH (Dir) ] = '\') THEN
BEGIN
Dir := COPY (Dir, 1, LENGTH (Dir) - 1);
make_directory ( Dir, dRec );
END;
Dos.FINDFIRST ( dFn, FAttr, dRec );
tmpSize := -1;
IF DosError = 0 THEN BEGIN { same Fn Found in destination }
tmpSize := dRec.size; { Keep size of existing file in mind }
{$IFDEF CP}
IF force = FALSE THEN { Ask first }
BEGIN
{$IFDEF German}
answer := Alert ('Warnung! Die Datei "' + nam + ext +
'"| existiert schon im Zielverzeichnis!',
'Überschr.|Nächste|Alle|Alle neueren|Abbruch');
{$ELSE}
answer := Alert ('Warning! File "' + nam + ext +
'" does already exist!',
'Write|Skip|All|All Newer|Abort');
{$ENDIF} {German}
IF (answer = 255) OR (answer = 5) THEN abort;
IF answer = 4 THEN
BEGIN
force := TRUE;
tStamp := TRUE;
IF (Cinfo^.sRec.time <= dRec.time) THEN
skipping := TRUE;
END;
IF answer = 2 THEN skipping := TRUE;
IF answer = 3 THEN force := TRUE;
END
ELSE
BEGIN
{ Time-Check for newer files }
IF tStamp AND (Cinfo^.sRec.time <= dRec.time) THEN
skipping := TRUE;
END;
{$ELSE} {MV}
IF force = FALSE THEN { Ask first }
BEGIN
{$IFDEF German}
answer := Alert ('Warnung! Die Datei "' + nam + ext +
'" existiert schon im Zielverzeichnis!',
'Überschr.|Nächste|Alle|Abbruch');
{$ELSE}
answer := Alert ('Warning! File "' + nam + ext +
'" does already exist!',
'Write|Skip|All|Abort');
{$ENDIF}
IF (answer = 255) OR (answer = 4) THEN abort;
IF answer = 2 THEN skipping := TRUE;
IF answer = 3 THEN force := TRUE;
END;
{$ENDIF}
END;
END;
{$IFDEF SizeCheck}
IF NOT skipping THEN
BEGIN
st := COPY (Dir, 1, 2);
DNum := ORD (st [1]) - ORD ('@');
getCSize (Dnum, CSize);
IF tmpSize>=0 THEN
tmpSize := ClusterSIZE (tmpSize, Csize)
ELSE
tmpSize := 0;
REPEAT
answer := 0;
IF ClusterSIZE (Dos.DISKFREE (DNum), Csize) + { check Free-area }
tmpSize { add existing file-size }
< ClusterSIZE (Cinfo^.sRec.size, Csize) THEN
BEGIN
{$IFDEF German}
answer := Alert ('Datei "' + Cinfo^.sRec.Name + '" paßt nicht|' +
'mehr in "' + st + '".', 'Nächste Datei|Abbruch|Nochmal');
{$ELSE}
answer := Alert ('Size of "' + Cinfo^.sRec.Name + '" exceeds|' +
'free-area of "' + st + '".', 'Skip|Abort|Again');
{$ENDIF}
IF (answer = 255) OR (answer = 2) THEN
abort;
IF answer = 1 THEN
BEGIN
skipping := TRUE;
answer := 0;
END;
END;
UNTIL answer = 0;
END;
{$ENDIF} {SizeCheck}
ASSIGN (otF, dFn);
Cinfo^.skip := skipping;
IF NOT skipping THEN BEGIN
Dos.SETFATTR (otF, Dos.Archive);
REWRITE (otF, 1);
iError := ioresult;
INC (Tnum); INC (Wnum)
END
END ELSE IF NOT Cinfo^.skip THEN BEGIN { already writing }
ASSIGN (otF, dFn); RESET (otF, 1); SEEK (otF, Cinfo^.WCount);
iError := ioresult;
END;
IF NOT Cinfo^.skip THEN BEGIN
cB := Cinfo^.sAdrBuf;
DiskFull := FALSE;
WHILE (Cinfo^.numRecrd > 0) AND NOT DiskFull DO
write1Block (otF, Cinfo, cB, DiskFull);
Dos.SETFTIME (otF, Cinfo^.sRec.Time);
CLOSE (otF);
IF DiskFull THEN
BEGIN
ERASE (otF);
Cinfo^.Skip := TRUE;
{$IFDEF German}
answer := Alert ('Warnung! Die Datei "' + Cinfo^.sRec.Name +
'"|passt nicht mehr ins Zielverzeichnis!',
'Nächste Datei|Abbruch');
{$ELSE}
answer := Alert ('Warning! No space left for file "' +
Cinfo^.sRec.Name + '"!',
'Skip|Abort');
{$ENDIF}
IF (answer = 255) OR (answer = 2) THEN abort;
END
ELSE
BEGIN
IF Cinfo^.eoFF THEN
BEGIN
Dos.SETFATTR ( otF, Cinfo^.sRec.Attr );
{$IFDEF MV}
IF NOT Cinfo^.Skip THEN
BEGIN
{$IFDEF German}
UpdateInfo (2, 'Verschiebe: ' + CInfo^.SRec.Name, 1, 1);
{$ELSE}
UpdateInfo (2, 'Moving file: ' + CInfo^.SRec.Name, 1, 1);
{$ENDIF}
ASSIGN (F, Cinfo^.SourceDir + Cinfo^.sRec.Name);
Dos.SETFATTR ( F, DOS.Archive );
CLOSE (F);
IF IORESULT <> 0 THEN ;
ERASE (F);
IF IORESULT <> 0 THEN ;
END;
{$ENDIF}
END;
END;
END;
Cinfo := Cinfo^.nextP;
END;
END;
VAR
pp : POINTER;
Wnum, Rnum : WORD;
Dir : Dos.DirStr; Nam : Dos.NameStr; Ext : Dos.ExtStr;
{$IFDEF MV}
same : BOOLEAN; tmp : STRING; F : FILE; i : INTEGER;
ans : BYTE;
{$ENDIF}
BEGIN {ReadWrite}
NEW (Finfo);
Finfo^.WCount := 0; Finfo^.numRecrd := 0;
Finfo^.skip := FALSE; Finfo^.eoFF := FALSE;
Oinfo := Finfo;
param := FirstParam;
st := COPY (src_Fn, LENGTH (src_Fn), 1);
IF (st [1] = '\') OR (st [1] = ':') THEN src_Fn := src_Fn + '*.*';
system.FileMode := 0; { read only }
Dos.FINDFIRST ( src_Fn, FAttr, sRc );
dError := DosError;
WHILE (dError = 0) AND
( (sRc.attr AND Dos.Directory) <> 0) AND { skip ./.. }
( (sRc.name = '.') OR (sRc.Name = '..') ) DO
get_next (sRc, dError, src_Fn, param, LastParam);
IF recursion = FALSE THEN
WHILE (dError = 0) AND ( (sRc.attr AND Dos.Directory) <> 0)
DO get_next (sRc, dError, src_fn, param, LastParam);
Wnum := 0; Rnum := 0; dFn := ''; INC (LCount);
WHILE dError = 0 DO BEGIN
MARK (pp);
Cinfo := Finfo; Cinfo^.nextP := NIL;
IF (dError = 0) AND ( (sRc.Attr AND Directory) <> 0 ) AND
(recursion = TRUE)
THEN BEGIN { Dir name }
{$IFDEF MV}
Dos.FSplit (src_Fn, Dir, Nam, Ext);
Finfo^.WCount := 0;
StorePath := Dir + sRc.name + '\';
readWrite ( StorePath, Dos.FExpand (Dst_path) +
sRc.Name + '\',
Tnum, LCount, SpecialCase, 1, 1);
{ recursive call for sub-dir }
RMDIR (Dir + sRc.name);
IF IORESULT <> 0 THEN ;
{$ELSE} {CP}
Finfo^.WCount := 0;
Dos.FSplit (src_Fn, Dir, Nam, Ext);
StorePath := Dir + sRc.name + '\';
readWrite ( StorePath, Dos.FExpand (Dst_path) +
sRc.Name + '\',
Tnum, LCount, SpecialCase, 1, 1);
{ recursive call for sub-dir }
{$ENDIF}
get_next (sRc, dError, src_Fn, param, LastParam)
END;
system.FileMode := 0; { read only }
IF NOT Cinfo^.skip THEN
READing (dError, Rnum);
IF (Rnum > 0) THEN BEGIN
system.FileMode := 2; { read/write }
WRITing (Wnum);
END;
IF Oinfo^.skip AND (NOT Oinfo^.eoFF) THEN
get_next (sRc, dError, src_Fn, param, LastParam);
IF (Oinfo^.eoFF) OR (Oinfo^.skip) THEN BEGIN
Finfo^.WCount := 0; Finfo^.skip := FALSE; { this file is ENDed }
END ELSE Finfo^ := Oinfo^; { continue next READ/WRITE on the same File }
RELEASE (pp);
END;
END; { readWrite }
PROCEDURE DoIt;
VAR
src_Fn, Dst_path : DOS.PathStr;
dummy : BYTE;
Tnum, LCount : WORD;
Param, Pcount : WORD;
special, nodir : BOOLEAN;
Test : DOS.SearchRec;
BEGIN {doit}
{
WriteLn('Minimum-Heap-Size: ', sizeof(Buffer)+sizeof(FL)*2+sizeof(FL));
}
Get_Param ( Dst_path, Param );
{$IFDEF German}
StartInfo ('Lese ', 'Schreibe ');
{$ELSE}
StartInfo ('Reading ', 'Writing ');
{$ENDIF}
{$IFDEF Format}
IF (Copy(dst_path, 2, 1) = ':') AND FormatDrv THEN
BEGIN
dummy := ORD(Upcase(dst_path[1])) - ORD('A');
IF (dummy=0) OR (dummy=1) THEN
FormatDrive(dummy);
END;
{$ENDIF}
CheckDrive(Dst_path);
{
Now we check a special case: if there is only one file
to copy or move, we will treat the destination path as
the destination file (if this name isn't a directory)
}
special := FALSE;
nodir := Dst_path [LENGTH (Dst_path) ] <> ':'; { No simple drive }
IF nodir THEN
BEGIN
src_fn := Dst_path;
IF src_fn [LENGTH (src_fn) ] = '\' THEN
DELETE (src_fn, LENGTH (src_fn), 1); { remove trailing '\'}
nodir := src_fn [LENGTH (src_fn) ] <> ':'; { Still no simple drive }
IF nodir THEN
BEGIN
FINDFIRST (src_fn, DOS.AnyFile, test);
IF doserror = 0 THEN
nodir := (test.Attr AND DOS.Directory = 0)
ELSE
nodir := TRUE; { Not found }
END;
END;
src_Fn := MSHParamStr (Param);
src_fn := Dos.FExpand (src_Fn);
IF nodir AND { Dst_path=filename }
(MSHParamCount - 1 - Param = 0) AND { Just 1 Sourcefile }
(POS ('*', src_Fn) = 0) AND (POS ('*', src_Fn) = 0) THEN { No wildcards }
BEGIN
{$IFDEF CP}
FINDFIRST (src_fn, DOS.AnyFile, test); { Make sure that we }
IF doserror = 0 THEN { won't have a dir }
nodir := (test.Attr AND DOS.Directory = 0)
ELSE
nodir := TRUE; { Not found }
{$ELSE}
nodir := TRUE; { Not found }
{$ENDIF}
IF nodir THEN
BEGIN
IF COPY (Dst_path, LENGTH (Dst_path), 1) = '\' THEN
DELETE (Dst_path, LENGTH (Dst_path), 1);
Special := TRUE;
END;
END;
(*
STR(MSHParamCount, src_Fn);
TNum := Alert ('Parameter:'+ src_fn, 'OK');
*)
src_Fn := MSHParamStr (Param);
src_fn := Dos.FExpand (src_Fn);
Tnum := 0; LCount := 0;
readWrite (src_Fn, Dst_path,
TNum, LCount, special, Param, MSHParamCount - 1);
Abort;
END;