[Back to COPYMOVE SWAG index] [Back to Main SWAG index] [Original]

    {$A+,B-,D-,E+,F-,I+,L-,N-,O-,R+,S+,V-}
    {$M 16384,65536,655360}

    Program scopy;

    Uses
      Dos,
      tpDos,
      sundry,
      Strings;

    Type
      buffer_Type = Array[0..65519] of Byte;
      buffptr     = ^buffer_Type;

    Var
      f1,f2       : File;
      fname1,
      fname2,
      NewFName,
      OldDir      : PathStr;
      SRec        : SearchRec;
      errorcode   : Integer;
      buffer      : buffptr;
    Const
      MakeNewName : Boolean = False;
      FilesCopied : Word = 0;
      MaxHeapSize = 65520;

    Function IOCheck(stop : Boolean; msg : String): Boolean;
      Var
        error : Integer;
      begin
        error := Ioresult;
        IOCheck := (error = 0);
        if error <> 0 then begin
          Writeln(msg);
          if stop then begin
            ChDir(OldDir);
            halt(error);
          end;
        end;
      end;

    Procedure Initialise;
      Var
        temp  : String;
        dir   : DirStr;
        name  : NameStr;
        ext   : ExtStr;
      begin
        if MaxAvail < MaxHeapSize then begin
          Writeln('Insufficient memory');
          halt;
        end
        else
          new(buffer);
        {I-} GetDir(0,OldDir); {$I+} if IOCheck(True,'') then;
        Case ParamCount of
          0: begin
               Writeln('No parameters provided');
               halt;
             end;
          1: begin
               TempStr := ParamStr(1);
               if not ParsePath(TempStr,fname1,fname2) then begin
                 Writeln('Invalid parameter');
                 halt;
               end;
               {$I-} ChDir(fname2); {$I+} if IOCheck(True,'') then;
             end;
          2: begin
               TempStr := ParamStr(1);
               if not ParsePath(TempStr,fname1,fname2) then begin
                 Writeln('Invalid parameter');
                 halt;
               end
               else
                 {$I-} ChDir(fname2); {$I+} if IOCheck(True,'') then;

               TempStr := ParamStr(2);
               if not ParsePath(TempStr,fname2,temp) then begin
                 Writeln('Invalid parameter');
                 halt;
               end;
               FSplit(fname2,dir,name,ext);
               if length(name) <> 0 then
                 MakeNewName := True;
             end;
        else begin
               Writeln('too many parameters');
               halt;
             end;
        end; { Case }
      end; { Initialise }

    Procedure CopyFiles;
      Var
        result : Word;

      Function MakeNewFileName(fn : String): String;
        Var
          temp  : String;
          dir   : DirStr;
          name  : NameStr;
          ext   : ExtStr;
          numb  : Word;
        begin
          numb := 0;
          FSplit(fn,dir,name,ext);
          Repeat
            inc(numb);
            if numb > 255 then begin
              Writeln('Invalid File name');
              halt(255);
            end;
            ext := copy(Numb2Hex(numb),2,3);
            temp := dir + name + ext;
            Writeln(temp);
          Until not ExistFile(temp);
          MakeNewFileName := temp;
        end; { MakeNewFileName }

      begin
        FindFirst(fname1,AnyFile,Srec);
        While Doserror = 0 do begin
          if (SRec.attr and $19) = 0 then begin
            if MakeNewName then
              NewFName := fname2
            else
              NewFName := SRec.name;
            if ExistFile(NewFName) then
              NewFName := MakeNewFileName(NewFName);
            {$I-}
            Writeln('Copying ',SRec.name,' > ',NewFName);
            assign(f1,SRec.name);
            reset(f1,1);
            if { =1= } IOCheck(False,'1. Cannot copy '+fname1) then begin
              assign(f2,fname2);
              reWrite(f2,1);
              if IOCheck(False,'2. Cannot copy '+SRec.name) then
                Repeat
                  BlockRead(f1,buffer^,MaxHeapSize);
                  if IOCheck(False,'3. Cannot copy '+SRec.name) then
                    result := 0
                  else begin
                    BlockWrite(f2,buffer^,result);
                    if IOCheck(False,'4. Cannot copy '+NewFName) then
                      result := 0;
                  end;
                Until result < MaxHeapSize;
              close(f1); close(f2);
              if IOCheck(False,'Error While copying '+SRec.name) then;
            end; { =1= }
          end;  { if SRec.attr }
          FindNext(Srec);
        end; { While Doserror = 0 }
      end; { CopyFiles }

    begin
      Initialise;
      CopyFiles;
      ChDir(OldDir);
    end.

[Back to COPYMOVE SWAG index] [Back to Main SWAG index] [Original]