home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / 1989 / 08 / tricks / mv.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-05-24  |  7.5 KB  |  261 lines
  1. (* ------------------------------------------------------ *)
  2. (*                       MV.PAS                           *)
  3. (*          (c) 1989 Thomas Kellerer & TOOLBOX            *)
  4. (* ------------------------------------------------------ *)
  5. PROGRAM Move;
  6.  
  7. USES Dos, Crt;
  8.  
  9. VAR Error  : Word;
  10.  
  11.   FUNCTION DError : Word;
  12.   BEGIN
  13.     DError := Error;
  14.     Error := 0;
  15.   END;
  16.  
  17.   PROCEDURE DeleteFile(s : STRING);
  18.   VAR  r : Registers;
  19.   BEGIN
  20.     s    := s + #0;
  21.     r.AH := $41;
  22.     r.DS := Seg(s);
  23.     r.DX := Ofs(s) + 1;
  24.     MsDos(r);
  25.     IF ((r.Flags AND FCarry) = FCarry) THEN Error := r.AX
  26.                                        ELSE Error := 0;
  27.   END;
  28.  
  29.   FUNCTION GetName(s : STRING) : STRING;
  30.                 (* Nur den Eigentlichen Namen extrahieren *)
  31.   VAR k    : BYTE;
  32.       Name : STRING;
  33.   BEGIN
  34.     Name := '';
  35.     k := Length(s);
  36.     WHILE ((s[k]<>'\') AND (s[k]<>':') AND (k>0)) DO BEGIN
  37.       Name := s[k] + Name;
  38.       Dec(k);
  39.     END;
  40.     GetName := Name;
  41.   END;
  42.  
  43.   FUNCTION GetPath(s : String) : String;
  44.                    (* Hole den Pfad der kompletten Angabe *)
  45.   VAR k    : BYTE;
  46.       Pfad : STRING;
  47.   BEGIN
  48.     Pfad := '';
  49.     k := Length(s);
  50.     WHILE ((s[k]<>'\') AND (s[k]<>':') AND (k>0)) DO
  51.       Dec(k);
  52.     IF k = 0 THEN Pfad := ''
  53.     ELSE
  54.       IF k = 1 THEN Pfad := s[1]
  55.       ELSE BEGIN
  56.         Pfad := Copy(s, 1, k);
  57.         IF (Pfad[Length(Pfad)] = '\') THEN BEGIN
  58.           IF Pfad[Length(Pfad) - 1] <> ':' THEN
  59.             Pfad:=Copy(Pfad,1,Length(Pfad)-1);
  60.         END;
  61.       END;
  62.     GetPath:=Pfad;
  63.   END;
  64.  
  65.   FUNCTION GetFullName(s : String) : String;
  66.   VAR r    : Registers;
  67.       t    : STRING;
  68.       p    : POINTER;
  69.       AltP : POINTER;
  70.       l    : LongInt;
  71.   BEGIN
  72.     r.AH := $60;
  73.  
  74.   { undokumentierte DOS-Funktion: }
  75.   { erweitert eine Namensangabe um aktuellen Pfad          }
  76.   { (falls nötig) expandiert evtl vorhandene '*'           }
  77.   { z.b.: aktuelles Verzeichnis: c:\turbo                  }
  78.   { GetFullName('*.PAS') liefert C:\TURBO\????????.PAS'    }
  79.   { GetFullName('C:\DOS\COMMAND.COM') liefert das gleiche  }
  80.  
  81.     s    := s + #0;
  82.     r.DS := Seg(s);
  83.     r.SI := Ofs(s) + 1;
  84.               { Vorsicht, auf Maxlänge wird nicht geprüft! }
  85.     GetMem(p, 128);
  86.     AltP := p;             { Speicher anfordern            }
  87.                            { DOS schreibt in diesen Puffer }
  88.     r.ES := Seg(p^);
  89.     r.DI := Ofs(p^);
  90.     MsDos(r);
  91.     t := '';
  92.     l := LongInt(r.ES) * 16 + r.DI;
  93.     p := Ptr(l DIV 16, l MOD 16);
  94.        { Zeiger normalisieren: Offset ≤ 16                 }
  95.        { -> Offset inkrementieren ungefährlich!!           }
  96.        {    (Kein Segmentsprung möglich bei max. 128 Byte) }
  97.  
  98.     WHILE Char(p^)<>#0 DO BEGIN          { Puffer auslesen }
  99.       t := t + Char(p^);
  100.       p := Ptr(Seg(p^), Ofs(p^)+1); { 'entspricht' Inc(p^) }
  101.     END;
  102.     GetFullName := t;
  103.     FreeMem(AltP, 128);               { Speicher freigeben }
  104.   END;
  105.  
  106.   FUNCTION GetAttrib(s : STRING) : BYTE;
  107.   VAR r : Registers;
  108.   BEGIN
  109.     s    := s + #0;
  110.     r.DS := Seg(s);
  111.     r.DX := Ofs(s) + 1;
  112.     r.AH := $43;
  113.     r.AL := 0;
  114.     MsDos(r);
  115.     IF (r.Flags AND FCarry) = FCarry THEN GetAttrib := $FF
  116.                                      ELSE GetAttrib := r.CX;
  117.   END;
  118.  
  119.   FUNCTION Wildcard(s : STRING) : BOOLEAN;
  120.   BEGIN
  121.     Wildcard := ((Pos('?', s) <> 0) OR (Pos('*', s) <> 0));
  122.   END;
  123.  
  124.   PROCEDURE RenameFile(Alt, Neu : STRING);
  125.   VAR Regs : Registers;
  126.   BEGIN
  127.     Alt := Alt + #0;
  128.     Neu := Neu + #0;
  129.     WITH Regs DO BEGIN
  130.       AH := $56;
  131.       DS := Seg(Alt);
  132.       DX := Ofs(Alt) + 1;
  133.       ES := Seg(Neu);
  134.       DI := Ofs(Neu) + 1;
  135.       MsDos(Regs);
  136.       IF ((Flags AND FCarry) = FCarry) THEN Error := AX
  137.                                        ELSE Error := 0;
  138.     END;
  139.   END;
  140.  
  141.   FUNCTION UpperCase(s : STRING) : STRING;
  142.   VAR k : BYTE;
  143.   BEGIN
  144.     FOR k := 1 TO Length(s) DO s[k] := UpCase(s[k]);
  145.     UpperCase := s;
  146.   END;
  147.  
  148.   FUNCTION ParseNames(alt, neu : STRING) : STRING;
  149.   VAR k, l  : BYTE;
  150.       s, t  : STRING;
  151.       p     : BYTE;
  152.   BEGIN
  153.     k := Pos('.', Alt);
  154.     IF k = 0 THEN t := Alt
  155.              ELSE t := Copy(Alt, 1, k-1);
  156.     WHILE Length(t) < 9 DO t := t + ' ';
  157.                               { auf acht zeichen erweitern }
  158.     s := '';
  159.     p := Pos('.', Neu);
  160.     IF p = 0 THEN p := Length(Neu)
  161.              ELSE Dec(p);
  162.     FOR l := 1 TO p DO BEGIN  { zuerst den Namen behandeln }
  163.       IF Neu[l] = '?' THEN s := s + t[l]
  164.                       ELSE s := s + neu[l];
  165.     END;
  166.     l := Length(s);
  167.     WHILE s[l] = ' ' DO BEGIN
  168.       Delete(s, l, 1);
  169.       Dec(l);
  170.     END;                             { Leerzeichen löschen }
  171.     { Extensiomn behandeln }
  172.     IF k = 0 THEN t := '.   '
  173.              ELSE t := Copy(Alt, k, Length(Alt) - k + 1);
  174.     WHILE Length(t) < 4 DO t := t + ' ';       { auffüllen }
  175.     IF Pos('.', Neu) = 0 THEN Neu := Neu + '.   ';
  176.     FOR l := 1 TO 4 DO BEGIN
  177.       IF Neu[p+l] = '?' THEN s := s + t[l]
  178.                         ELSE s := s + neu[p+l];
  179.     END;
  180.     ParseNames := s;
  181.   END;
  182.  
  183.   PROCEDURE Abbruch(Fehler : Word);
  184.   BEGIN
  185.     CASE Fehler OF
  186.       2 : WriteLn('Datei nicht gefunden');
  187.       3 : WriteLn('Pfad nicht gefunden');
  188.       5 : WriteLn('Zugriff verweigert');
  189.      11 : WriteLn('Quell/Ziellaufwerk nicht identisch');
  190.     ELSE
  191.       WriteLn('Fehler: ', Fehler);
  192.     END;
  193.     Halt(3);
  194.   END;
  195.  
  196. VAR DirInfo                    : SearchRec;
  197.     Fehler                     : WORD;
  198.     AltName, NeuName, Alt, Neu : STRING;
  199.     ch                         : Char;
  200.     OverWrite                  : BOOLEAN;
  201.  
  202. BEGIN
  203.   Error := 0;
  204.   Overwrite := TRUE;
  205.   IF ParamCount <> 2 THEN BEGIN
  206.     WriteLn('mv - Verschiebt oder benennt Dateien um');
  207.     WriteLn;
  208.     WriteLn('Aufruf mit: mv AlterName NeuerName');
  209.     WriteLn('            Gebrauch wie rename');
  210.     WriteLn('            z.B.: mv *.BAT *.BAK');
  211.     WriteLn('                  mv \bat\*.bat \bin\*.*');
  212.     WriteLn;
  213.     WriteLn('Auch Verzeichnisse können umbenannt werden');
  214.     Halt(2);
  215.   END;
  216.   AltName := GetFullName(ParamStr(1));
  217.   NeuName := ParamStr(2);
  218.   IF (GetAttrib(NeuName) = Directory) THEN
  219.     NeuName := NeuName + '\*.*';
  220.   IF NeuName[Length(NeuName)] = '\' THEN
  221.     NeuName := NeuName + '*.*';
  222.   NeuName := GetFullName(NeuName);
  223.   FindFirst(AltName, AnyFile, DirInfo);
  224.   WHILE DOSError = 0 DO BEGIN
  225.     Alt := GetPath(AltName);
  226.     IF Alt[Length(alt)] <> '\' THEN
  227.       Alt := Alt + '\' + DirInfo.Name
  228.     ELSE
  229.       Alt := Alt + DirInfo.Name;
  230.     Neu := GetPath(NeuName);
  231.     IF Neu[Length(Neu)] <> '\' THEN
  232.       Neu:=Neu+'\'+ParseNames(DirInfo.Name,GetName(NeuName))
  233.     ELSE
  234.       Neu:=Neu+ParseNames(DirInfo.Name,GetName(NeuName));
  235.     IF GetAttrib(Neu) <> 255 THEN BEGIN
  236.                                     { Ziel existiert schon }
  237.       Write('Zieldatei: ', Neu, ' überschreiben? (J/N)');
  238.       REPEAT
  239.         ch := UpCase(ReadKey);
  240.       UNTIL ch IN ['J', 'N'];
  241.       Write(#13);
  242.       ClrEOL;
  243.       IF ch = 'J' THEN BEGIN
  244.         Overwrite := TRUE;
  245.         DeleteFile(Neu);
  246.       END ELSE
  247.         Overwrite := FALSE;
  248.     END;
  249.     IF Overwrite THEN BEGIN
  250.       WriteLn('Verschiebe: ', Alt, '  nach:  ', Neu);
  251.       RenameFile(Alt, Neu);
  252.     END ELSE
  253.       WriteLn('Datei ', alt, ' nicht verschoben!');
  254.     Overwrite := TRUE;
  255.     Fehler := DError;
  256.     IF Fehler <> 0 THEN Abbruch(Fehler);
  257.     FindNext(DirInfo);
  258.   END;
  259. END.
  260. (* ------------------------------------------------------ *)
  261. (*                  Ende von MV.PAS                       *)