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

{$A+,B-,D+,E+,F-,G+,I+,L+,N-,O-,P-,Q-,R-,S-,T-,V-,X+,Y+}
{$M 16384,0,655360}

USES DOS,Crt;

   TYPE

   { Define action type MOVE or COPY }
   cTYPE = (cMOVE,cCOPY);

   { Define the special structure of a DOS Disk Transfer Area (DTA) }
   DTARec      =  RECORD
                     Filler   :  ARRAY [1..21] OF BYTE;
                     Attr     :  BYTE;
                     Time     :  WORD;
                     Date     :  WORD;
                     Size     :  LONGINT;
                     Name     :  STRING [12];
                  END {DtaRec};

VAR
    OK : Integer;
    IP,OP : PathStr;  { input,output file names }

   FUNCTION Copier (cWhat : cTYPE; VAR orig: STRING;VAR nName: STRING) : Integer;

   { Copy or Move file through DOS if not on same disk. Retain original date,
     time and size and delete the original on Move.  The beauty here is that
     we can move files across different drives.  Also, we can rename file if
     we choose.     If error, function returns error number }


      CONST bufsize = $C000;            { About 48 KB - 49152 }

      TYPE
       fileBuffer = ARRAY [1..bufsize] OF BYTE;

      VAR   Regs: registers;
            src,dst: INTEGER;
            bsize,osize: LONGINT;
            buffer : ^fileBuffer;
            DTABlk : DTARec;
            fError : BOOLEAN;

      FUNCTION CheckError(err : Integer) : BOOLEAN;
      BEGIN
      CheckError := (Err <> 0);
      fError     := (Err <> 0);
      Copier     := err;
      END;

      PROCEDURE delfile (VAR fName: STRING);

         VAR   Regs: registers;

         BEGIN
            WITH Regs do BEGIN
               ah := $43;             { Make file R/W for delete }
               al := 1;
               cx := 0;               { Normal file }
               ds := Seg(fName[1]);   { fName is the fully qualified }
               dx := Ofs(fName[1]);   { pathname of file, 0 terminated }
               MsDos (Regs);
               IF CheckError(Flags AND 1) THEN EXIT
               ELSE BEGIN
                  ah := $41;            { Delete file through fName }
                  { ds:dx stil valid from set-attributes }
                  MsDos (Regs);
                  IF CheckError(Flags AND 1) THEN EXIT;
                  END
               END
         END;

      BEGIN

         Copier := 0;  { Assume Success }
         FindFirst(Orig,Anyfile,SearchRec(DTABlk));
         IF CheckError(DosError) THEN EXIT;

         WITH Regs DO BEGIN
            ah := $3D;                  { Open existing file }
            al := 0;                    { Read-only }
            ds := Seg(orig[1]);         { Original filename (from) }
            dx := Ofs(orig[1]);
            MsDos (Regs);
            IF CheckError(Flags AND 1) THEN Exit
            ELSE BEGIN
               src := ax;               { Handle of the file }

               ah := $3C;               { Create a new file }
               cx := 0;                 { Start as normal file }
               ds := Seg(nName[1]);     { Pathname to move TO }
               dx := Ofs(nName[1]);
               MsDos (Regs);
               IF CheckError(Flags AND 1) THEN Exit
               ELSE
                  dst := ax
               END
            END;

         osize := DTABlk.size;       { Size of file, from "findfirst" }
         WHILE (osize > 0) AND NOT ferror DO BEGIN

            IF osize > bufsize THEN
               bsize := bufsize        { Too big for buffer, use buffer size }
            ELSE
               bsize := osize;

            IF BSize > MAXAVAIL THEN BSize := MAXAVAIL;

            GETMEM (buffer, BSize);    { Grap some HEAP memory }

            WITH Regs DO BEGIN
               ah := $3F;               { Read block from file }
               bx := src;
               cx := bsize;
               ds := Seg(buffer^);
               dx := Ofs(buffer^);
               MsDos (Regs);
               IF CheckError(Flags AND 1) THEN {}
               ELSE BEGIN
                  ah := $40;            { Write block to file }
                  bx := dst;
                  { cx and ds:dx still valid from Read }
                  MsDos (Regs);
                  IF CheckError(Flags AND 1) THEN {}
                  ELSE IF ax < bsize THEN
                     BEGIN
                     CheckError(98); { disk full }
                     END
                  ELSE
                     osize := osize - bsize
                  END;
               END;

            FREEMEM (buffer, BSize);   { Give back the memory }
            END;

         IF NOT ferror AND (cWHAT = cMOVE) THEN
         WITH Regs DO
            BEGIN
            ah := $57;                  { Adjust date and time of file }
            al := 1;                    { Set date }
            bx := dst;
            cx := DTABlk.time;          { Out of the "find" }
            dx := DTABlk.date;
            MsDos (Regs);
            CheckError(Flags AND 1);
            END;

         WITH Regs DO
            BEGIN
            ah := $3E;                  { Close all files, even with errors! }
            bx := src;
            MsDos (Regs);
            ferror := ferror OR ((flags AND 1) <> 0);
            ah := $3E;
            bx := dst;
            MsDos (Regs);
            ferror := ferror OR ((flags AND 1) <> 0)
            END;

         IF ferror THEN EXIT            { we had an error somewhere }
         ELSE WITH Regs DO
            BEGIN
            ah := $43;                  { Set correct attributes to new file }
            al := 1;                    { Change attributes }
            cx := DTABlk.attr;          { Attribute out of "find" }
            ds := Seg(nName[1]);
            dx := Ofs(nName[1]);
            MsDos (Regs);
            IF CheckError(Flags AND 1) THEN EXIT
            ELSE
               If (cWHAT = cMOVE) THEN DelFile (orig) { Now delete the original }
            END                                       { if we are moving file }
      END;

BEGIN
clrscr;
IP := 'queen1.PAS';
OP := 'd:\temp\queen1.pas';
OK := Copier(cCOPY,IP,OP);
WriteLn(OK);
END.

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