Quelltext /~heha/hs/dos/dosmisc.zip/SRC/NCOPY.PAS

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.
Vorgefundene Kodierung: OEM (CP437)1
Umlaute falsch? - Datei sei ANSI-kodiert (CP1252)