program update;
{[optionen] <netz_dir[\dateien]> <lokal_dir> [optionen]
Optionen: -r (rekursiv), -a (Rückfrage) -t (Test-Datei)
-d (Löschen von auf netz_dir nicht (mehr) vorhandenen Dateien)
-w (Schreibschutzattribut der Zieldatei "wegbügeln")}
uses DOS;
{$I-}
procedure FindClose(var SR: SearchRec);
{Dummy-Funktion für lange Dateinamen}
begin
end;
function AppendBS(const S:DirStr):DirStr;
begin
if not (S[Length(S)] in ['\','/',':']) then AppendBS:=S+'\'
else AppendBS:=S;
end;
function RemoveBS(const S:DirStr):DirStr;
begin
if S[Length(S)] in ['\','/'] then RemoveBS:=Copy(S,1,Length(S)-1)
else RemoveBS:=S;
end;
procedure MkDirHier(S:PathStr);
{Verzeichnis und ggf. alle übergeordneten Verzeichnisse erstellen}
var
P: DirStr; N: NameStr; E: ExtStr;
begin
MkDir(RemoveBS(S)); {Erst mal gucken, ob's klappt}
case IOResult of
0: ; {okay}
5: ; {Verzeichnis existiert bereits}
3: begin {Pfad nicht gefunden? - Rekursion!}
FSplit(RemoveBS(S),P,N,E);
MkDirHier(P);
MkDirHier(S); {Jetzt müßte es klappen}
end;
else begin
WriteLn('Kann Verzeichnis (',S,') nicht erstellen!');
halt(127);
end;
end;
end;
const
ForceWrite: Boolean=false;
procedure CopyFile(const src,dest:PathStr);
{Datei binär von Name src zu Name dest kopieren; dest wird entschreibschützt
und bekommt das Dateidatum von src}
label l1;
var
fs,fd:File;
SP: PChar;
w: Word;
time:LongInt;
begin
Assign(fs,src); Reset(fs,1);
if IOResult<>0 then WriteLn('Fehler beim Öffnen (',src,')')
else begin
GetFTime(fs,time);
Assign(fd,dest);
if ForceWrite then SetFAttr(fd,0)
else begin
GetFAttr(fd,w);
if w and ReadOnly <>0 then begin
WriteLn(' Datei (',dest,') schreibgeschützt - wird belassen');
goto l1;
end;
end;
ReWrite(fd,1);
if IOResult<>0 then WriteLn('Fehler beim Erstellen (',dest,')')
else begin
GetMem(SP,$FFF0);
repeat
BlockRead(fs,SP^,$FFF0,w);
if w=0 then break;
BlockWrite(fd,SP^,w);
if IOResult<>0 then begin
WriteLn('Zieldatenträger voll oder Schreibfehler (',dest,')!');
halt(126);
end;
until false;
FreeMem(SP,$FFF0);
SetFTime(fd,time);
Close(fd);
end;
l1:Close(fs);
end;
end;
function GetFileTime(const name:String):LongInt;
{Datei-LMT beschaffen, ohne Datei zu öffnen!}
var
SR:SearchRec;
begin
FindFirst(name,0,SR);
if DosError=0 then GetFileTime:=SR.Time
else GetFileTime:=0; {auf 01.01.1980 stellen}
FindClose(SR);
end;
type
TFileStr=String[12];
const
DelFlag: Boolean=false;{Standard: Überzählige Dateien nicht löschen}
OutFlag: Boolean=true; {Standard: Ausgaben auf Bildschirm}
procedure FSplit2(const From:PathStr; var P:DirStr; var F:TFileStr);
var
N: NameStr; E: ExtStr;
begin
FSplit(From,P,N,E);
Dec(P[0]); {Backslash entfernen}
F:=N+E;
end;
function IsDirectory(S:DirStr):Boolean;
var
SR: SearchRec;
begin
IsDirectory:=false;
if Pos('*',S)<>0 then exit;
if Pos('?',S)<>0 then exit;
FindFirst(S,Directory,SR); {Vrz. muß selbst enthalten sein!}
IsDirectory:=SR.Attr and Directory <>0;
FindClose(SR);
end;
procedure CopyNewerFiles(const From: DirStr; const Match: PathStr;
const ToDir: DirStr; RecursCount: Integer);
{Neuere Dateien kopieren und Rekursion bis RecursCount=0, From und ToDir
müssen Backslash am Ende haben (oder "C:" oder leer sein),
Match muß '*.*' enthalten, falls alle Dateien gewünscht}
var
SAttr: Word;
SR: SearchRec;
f: File;
begin
SAttr:=0; if RecursCount>0 then SAttr:=SAttr or Directory;
MkDirHier(ToDir); {Zielverzeichnis erstellen}
FindFirst(From+Match,SAttr,SR);
while DosError=0 do begin
if (SR.Attr and Directory <>0) then begin
if (SR.Name[1]<>'.') then begin
if OutFlag then Write('>>',SR.Name,' '); {Rekursion Start}
CopyNewerFiles(From+SR.Name+'\',Match,ToDir+SR.Name+'\',
RecursCount-1);
if OutFlag then Write(SR.Name,'<< '); {Rekursion Ende}
end;
end else if GetFileTime(ToDir+SR.Name)<SR.Time then begin
if OutFlag then Write(SR.Name); {Kopieren Start}
CopyFile(From+SR.Name,ToDir+SR.Name);
if OutFlag then Write(' '); {als Fertigmeldung Cursor rücken}
end;
FindNext(SR);
end{while};
FindClose(SR);
if DelFlag then begin
FindFirst(ToDir+Match,0,SR);
while DosError=0 do begin
if GetFileTime(From+SR.Name)=0 then begin
if OutFlag then Write('!',SR.Name);
Assign(f,ToDir+SR.Name);
if SR.Attr and ReadOnly <>0 then SetFAttr(f,0);
Erase(f);
if OutFlag then Write('! ');
if IOResult<>0 then WriteLn('Kann nicht löschen (',FileRec(f).Name,')!');
end;
FindNext(SR);
end{while};
FindClose(SR);
end;
end;
procedure Usage;
begin
WriteLn('Automatisches Update eines Vrz. von Netzlaufwerk (h#s) 02/98');
WriteLn('Parameter: [optionen] <netz_dir[\filter]> <lokal_dir> [optionen]');
WriteLn('Optionen: -r<n> (rekursiv), -a (Rückfrage) -t<name> (Test-Datei)');
WriteLn(' -d (Löschen von auf netz_dir nicht (mehr) vorhandenen Dateien)');
WriteLn(' -w (Schreibschutzattribut der Zieldatei ignorieren)');
halt(100);
end;
var
T: LongInt;
SPath: DirStr; SFilter: TFileStr; DPath: DirStr; TestFile:PathStr;
S: PathStr;
I,EC: Integer;
c: Char;
const
RecursCount: Integer=0;
AskFlag: Boolean=false;
begin
{$IFOPT D+} asm int 3 end; {$ENDIF}
FileMode:=0;
if ParamCount<2 then Usage;
SPath:='';
SFilter:='*.*';
DPath:='';
TestFile:='';
for I:=1 to ParamCount do begin
S:=ParamStr(I);
if S[1] in ['-','/'] then begin
if Length(S)>=2 then begin
case Upcase(S[2]) of
'R': begin
Val(Copy(S,3,255),RecursCount,EC);{Rekursionstiefe angegeben?}
if EC<>0 then RecursCount:=16; {praktisch unendlich}
end;
'A': AskFlag:=true; {Vorher fragen (nur bei Datei!)}
'T': TestFile:=Copy(S,3,255); {Dateiname zum Testen}
'D': DelFlag:=true; {Lösch-Modus}
'Q': OutFlag:=false; {Quiet-Modus}
'W': ForceWrite:=true; {Schreibschutz ignorieren}
else begin
WriteLn('Unbekannte Option ',S[2],'!');
halt(101);
end;
end{case};
end;
end else begin
if SPath='' then begin
if IsDirectory(S) then SPath:=AppendBS(S)
else FSplit2(RemoveBS(S),SPath,SFilter);
end else if DPath='' then DPath:=AppendBS(S)
else begin
WriteLn('Überflüssiger Parameter "',S,'"!');
halt(101);
end;
end{if};
end{for};
if DPath='' then begin
WriteLn('Zu wenig Parameter!');
halt(101);
end;
if TestFile<>'' then begin
T:=GetFileTime(SPath+TestFile);
if T=0 then begin
WriteLn('Testdatei (',TestFile,') existiert nicht!');
halt(101);
end;
if T<=GetFileTime(DPath+TestFile) then halt(0); {nichts tun!}
if AskFlag then begin
WriteLn('Update von ',SPath,' nach ',DPath,' erforderlich!');
Write('Jetzt durchführen? [-/N] :'); ReadLn(c);
if c in ['n','N'] then halt(2); {nichts wegen User}
end;
Write('Kopiere Dateien ');
end else begin
Write('Teste auf Update und kopiere folgende Dateien: ');
end;
CopyNewerFiles(SPath,SFilter,DPath,RecursCount);
WriteLn;
halt(1);
end.
| Detected encoding: OEM (CP437) | 1
|
|
|