Upload

Digital Research

CONTRIBUTIONS/z80em86/support/cpmtodos.pas

@@ -0,0 +1,556 @@
+(*************************************************************************)
+(*                                                                       *)
+(*        CPM-TO-DOS v1.00 (c) Copyright S.J.Kay  18th April 1995        *)
+(*                                                                       *)
+(*                       Copys CP/M files to DOS                         *)
+(*                                                                       *)
+(*************************************************************************)
+
+{    WARNING - Make sure the END address is lowered to say about $8000    }
+{    before compiling to disk otherwise it will crash when used from      }
+{    within a SUBMIT file.  This happens to any TURBO v2.00a compiled     }
+{    program because it does not check the TPA size !.                    }
+
+{    As TURBO v2.00a compiled programs overwrite part of the command      }
+{    line parameters (only 1st 31 characters are intact) make sure that   }
+{    FIXTURBO.COM is run on this compiled program to allow full access    }
+{    to command line parameters.                                          }
+
+{$C-}                                       { turn off ^C and ^S checking }
+
+const
+   ComLne : string[127] = 'PARAMETERS';         { filled in by patch code }
+
+   ENDBUF = $3FFF;                                     { 16 K copy buffer }
+   ENDDIR = $1F;                           { 32 filename directory buffer }
+   TMPFLE = 'CPMTODOS.$$$';
+
+type
+   String12  = string[12];
+   String127 = string[127];
+
+   registers = record
+                  case boolean of
+                     true  : (AL, AH, BL, BH, CL, CH, DL, DH : byte);
+                     false : (AX,     BX,     CX,     DX,
+                              BP, SI, DI, DS, ES, FLAGS      : integer)
+               end;
+
+var
+   R      : registers;
+   F      : file;
+   Buffer : array [0..ENDBUF] of byte;
+   DirBuf : array [0..ENDDIR] of String12;
+   DMA    : array [0..3, 0..31] of char;
+   FCB    : array [0..35] of byte;
+
+   CPMdrv : byte;
+   DirMsk : String127;
+   DOSPth : String127;
+   CPMPth : String127;
+
+   Quiet  : boolean;
+   ChkWrt : boolean;
+   OvrWrt : boolean;
+   Error  : integer;
+
+
+procedure ProcZ80 (Fn, Ax : byte; BCx, DEx, HLx : integer);
+begin
+   inline
+      (
+       $3A/Fn/          { ld      a,(Fn)     }
+       $32/* + 17/      { ld      (FNCNMB),a }
+       $3A/Ax/          { ld      a,(Ax)     }
+       $ED/$4B/BCx/     { ld      bc,(BCx)   }
+       $ED/$5B/DEx/     { ld      de,(DEx)   }
+       $2A/HLx/         { ld      hl,(HLx)   }
+       $D3/$FF          { out     (FNCNMB),a }
+      )
+end;
+
+
+procedure Intr (Int : byte; var R : registers);
+begin
+   ProcZ80($A1, Int, $AA55, $55AA, addr(R))
+end;
+
+
+procedure Msdos (var R : registers);
+begin
+   Intr($21, R)
+end;
+
+
+function Seg (var Dummy) : integer;
+const
+   SegAdr : integer = 0;
+begin
+   ProcZ80($A0, 0, 0, 0, addr(SegAdr));
+   Seg := SegAdr
+end;
+
+
+function Ofs (var VarTyp) : integer;
+begin
+   Ofs := addr(VarTyp)
+end;
+
+
+type
+   DOSFle = record
+                 Path : array [0..127] of byte;
+               Handle : integer
+            end;
+
+var
+   ioresultDOS : integer;
+   D           : DOSFle;
+
+
+procedure AssignDOS (var F : DOSFle; Name : String127);
+begin
+   move(Name[1], F.Path, length(Name));
+   F.Path[length(Name)] := 0
+end;
+
+
+procedure ResetDOS (var F : DOSFle);
+begin
+   R.AH := $3D;                               { open file handle function }
+   R.AL := $02;                                       { read/write access }
+   R.DS := seg(F.Path);
+   R.DX := ofs(F.Path);
+   Msdos(R);                                              { open DOS file }
+   if odd(R.FLAGS) then
+      ioresultDOS := R.AX
+   else
+      begin
+         ioresultDOS := 0;
+         F.Handle := R.AX                                   { file handle }
+      end
+end;
+
+
+procedure RewriteDOS (var F : DOSFle);
+begin
+   R.AH := $3C;                                    { create file function }
+   R.CX := $00;                                 { file attribute (normal) }
+   R.DS := seg(F.Path);
+   R.DX := ofs(F.Path);
+   Msdos(R);                                            { create DOS file }
+   if odd(R.FLAGS) then
+      ioresultDOS := R.AX
+   else
+      begin
+         ioresultDOS := 0;
+         F.Handle := R.AX                                   { file handle }
+      end
+end;
+
+
+procedure CloseDOS (var F : DOSFle);
+begin
+   R.AH := $3E;                              { close file handle function }
+   R.BX := F.Handle;                                        { file handle }
+   Msdos(R);                                             { close DOS file }
+   if odd(R.FLAGS) then
+      ioresultDOS := R.AX
+   else
+      ioresultDOS := 0
+end;
+
+
+procedure EraseDOS (var F : DOSFle);
+begin
+   R.AH := $41;                                    { delete file function }
+   R.DS := seg(F.Path);
+   R.DX := ofs(F.Path);
+   Msdos(R);                                            { delete DOS file }
+   if odd(R.FLAGS) then
+      ioresultDOS := R.AX
+   else
+      ioresultDOS := 0
+end;
+
+
+procedure RenameDOS (var F : DOSFle; Name : String127);
+var
+   X : DOSFle;
+begin
+   move(Name[1], X.Path, length(Name));
+   X.Path[length(Name)] := 0;
+   R.AH := $56;                                    { rename file function }
+   R.DS := seg(F.Path);
+   R.DX := ofs(F.Path);
+   R.ES := seg(X.Path);
+   R.DI := ofs(X.Path);
+   Msdos(R);                                            { rename DOS file }
+   if odd(R.FLAGS) then
+      ioresultDOS := R.AX
+   else
+      ioresultDOS := 0
+end;
+
+
+procedure BlockWriteDOS (var F : DOSFle; var Source; RecCnt : integer);
+begin
+   R.AH := $40;                        { write to file or device function }
+   R.BX := F.Handle;                                        { file handle }
+   R.CX := 128 * RecCnt;
+   R.DS := seg(Source);
+   R.DX := ofs(Source);
+   Msdos(R);                                              { open DOS file }
+   if odd(R.FLAGS) then
+      ioresultDOS := $FF
+   else
+      ioresultDOS := 0
+end;
+
+
+procedure SetupFCB;
+var
+   PosGet, PosPut : integer;
+begin
+   PosGet := 1;
+   PosPut := 1;
+   fillchar(FCB, sizeof(FCB), 0);
+   fillchar(FCB[1], 11, ' ');
+   FCB[0] := CPMdrv;
+   repeat
+      while (PosGet <= length(DirMsk)) and
+      (DirMsk[PosGet] <> '.') and (PosPut < 12) do
+         begin
+            if DirMsk[PosGet] = '*' then
+               repeat
+                  FCB[PosPut] := ord('?');
+                  PosPut := PosPut + 1
+               until PosPut in [9, 12]
+            else
+               begin
+                  FCB[PosPut] := ord(upcase(DirMsk[PosGet]));
+                  PosPut := PosPut + 1
+               end;
+            PosGet := PosGet + 1
+         end;
+      if DirMsk[PosGet] = '.' then
+         begin
+            PosGet := PosGet + 1;
+            PosPut := 9
+         end
+   until (PosGet > length(DirMsk)) or (PosPut = 12)
+end;
+
+
+procedure LoadDirectoryBuffer (var DirTot : integer);
+var
+   DirPos, x, i : integer;
+   SchDir       : byte;
+   FleNme       : String12;
+begin
+   bdos(26, addr(DMA));
+   i := DirTot;
+   SchDir := 17;                              { search for first function }
+   while i <> 0 do                   { move to correct directory position }
+      begin
+         bdos(SchDir, addr(FCB));                      { search directory }
+         i := i - 1;
+         SchDir := 18
+      end;
+   DirPos := 0;
+   repeat
+      x := bdos(SchDir, addr(FCB));
+      if x <> $FF then
+         begin
+            FleNme := '';
+            for i := 1 to 11 do
+               begin
+                  if DMA[x, i] <> ' ' then
+                     FleNme := FleNme + DMA[x, i];
+                  if i = 8 then
+                     FleNme := FleNme + '.'
+               end;
+            DirBuf[DirPos] := FleNme;
+            DirPos := DirPos + 1;
+            DirTot := DirTot + 1
+         end;
+      SchDir := 18                             { search for next function }
+   until (x = $FF) or (DirPos > ENDDIR)
+end;
+
+
+function FileFound (FstDir : boolean; var FleNme : String12) : boolean;
+const
+   DirTot : integer = 0;
+   DirNmb : integer = 0;
+   GetPos : integer = 0;
+begin
+   if FstDir then
+      begin
+         DirNmb := 0;
+         DirTot := 0;
+         SetupFCB;
+      end;
+   if DirNmb = DirTot then
+      begin
+         LoadDirectoryBuffer(DirTot);
+         GetPos := 0
+      end;
+   FileFound := DirNmb < DirTot;
+   if DirNmb < DirTot then
+      begin
+         FleNme := DirBuf[GetPos];
+         GetPos := GetPos + 1;
+         DirNmb := DirNmb + 1
+      end;
+   if DirTot = 0 then
+      writeln('No files found to match: ', CPMPth, DirMsk)
+end;
+
+
+procedure OpenFiles (FleNme : String12);
+var
+   TmpStr : String127;
+   UsrRes : string[1];
+   Result : integer;
+begin
+   if not Quiet then
+      writeln('Copying: ', FleNme);
+{$I-}
+   assign(F, CPMPth + FleNme);
+   reset(F);
+   Error := ioresult;
+{$I+}
+   if Error = 0 then
+      begin
+         OvrWrt := true;
+         if ChkWrt then
+            begin
+               AssignDOS(D, DOSPth + FleNme);
+               ResetDOS(D);                           { does file exist ? }
+               if ioresultDOS = 0 then
+                  begin
+                     CloseDOS(D);
+                     Result := ioresultDOS;
+                     write('Overwrite ', DOSPth, FleNme, ' ? (y/n): ');
+                     readln(UsrRes);
+                     OvrWrt := (UsrRes = 'y') or (UsrRes = 'Y')
+                  end
+            end;
+         if OvrWrt then
+            begin
+               AssignDOS(D, DOSPth + TMPFLE);
+               RewriteDOS(D);       { open temporary DOS file for writing }
+               Error := ioresultDOS;
+               if Error <> 0 then
+                  writeln('Error can not create DOS file')
+            end
+      end
+   else
+      writeln('Error opening CP/M file for reading')
+end;
+
+
+procedure CloseFiles (FleNme : String12);
+var
+   Result : integer;
+begin
+{$I-}
+   close(F);                                            { close CP/M file }
+   Error := ioresult;
+{$I+}
+   if Error <> 0 then
+      writeln('Error closing CP/M source file');
+   if OvrWrt and (Error = 0) then
+      begin
+         CloseDOS(D);                          { close temporary DOS file }
+         Error := ioresultDOS;
+         if Error = 0 then
+            begin
+               AssignDOS(D, DOSPth + FleNme);
+               EraseDOS(D);
+               Result := ioresultDOS;
+               AssignDOS(D, DOSPth + TMPFLE);
+               RenameDOS(D, DOSPth + FleNme);
+               Error := ioresultDOS;
+               if Error <> 0 then
+                  writeln('Error renaming temporary DOS file')
+            end
+         else
+            writeln('Error closing temporary DOS file')
+      end
+end;
+
+
+procedure CopyFile (FleNme : String12);
+var
+   BufPos : integer;
+begin
+   repeat
+      BufPos := 0;
+{$I-}
+      while (not eof(F)) and (BufPos < ENDBUF) and (Error = 0) do
+         begin
+            blockread(F, Buffer[BufPos], 1);   { read data from CP/M file }
+            Error := ioresult;
+            BufPos := BufPos + 128
+         end;
+{$I+}
+      if Error = 0 then
+         begin
+            BlockwriteDOS(D, Buffer, BufPos div 128); { write to DOS file }
+            Error := ioresultDOS;
+            if Error <> 0 then
+               writeln('Error DOS disk full')
+         end
+      else
+         writeln('Error reading CP/M file')
+   until eof(F) or (Error <> 0)
+end;
+
+
+procedure TransferFiles;
+var
+   FstDir, Found : boolean;
+   FleNme        : String12;
+begin
+   if pos(':', DirMsk) = 2 then
+      begin
+         CPMPth := DirMsk;
+         CPMPth[0] := #2;
+         CPMdrv := (ord(DirMsk[1]) - ord('A')) + 1;
+         delete(DirMsk, 1, 2)
+      end
+   else
+      begin
+         CPMPth := '';
+         CPMdrv := 0                                 { default CP/M drive }
+      end;
+   if not (DOSPth[length(DOSPth)] in [':', '\']) then
+      DOSPth := DOSPth + '\';
+   FstDir := true;
+   while FileFound(FstDir, FleNme) and (Error = 0) do
+      begin
+         FstDir := false;
+         OpenFiles(FleNme);
+         if OvrWrt and (Error = 0) then
+            CopyFile(FleNme);
+         if Error = 0 then
+            CloseFiles(FleNme)
+      end
+end;
+
+
+function ParmCount : integer;
+var
+   i, PrmCnt, PrmLen : integer;
+begin
+   i := 1;
+   PrmCnt := 0;
+   PrmLen := length(ComLne);
+   while i <= PrmLen do
+      begin
+         while (i <= PrmLen) and (ComLne[i] = ' ') do
+            i := i + 1;
+         if i <= PrmLen then
+            PrmCnt := PrmCnt + 1;
+         if ComLne[i] = '/' then
+            i := i + 1;
+         while (i <= PrmLen) and (not(ComLne[i] in [' ', '/'])) do
+            i := i + 1
+      end;
+   ParmCount := PrmCnt
+end;
+
+
+function ParamStr (PrmNmb : integer) : String127;
+var
+   i, PrmCnt, PrmLen : integer;
+   PrmStr            : string[127];
+begin
+   i := 1;
+   PrmCnt := 0;
+   PrmStr := '';
+   PrmLen := length(ComLne);
+   while (i <= PrmLen) and (PrmCnt < PrmNmb) do
+      begin
+         while (i <= PrmLen) AND (ComLne[i] = ' ') do
+            i := i + 1;
+         if i <= PrmLen then
+            PrmCnt := PrmCnt + 1;
+         if ComLne[i] = '/' then
+            begin
+               PrmStr := '/';
+               i := i + 1
+            end
+         else
+            PrmStr := '';
+         while (i <= PrmLen) and (not (ComLne[i] in [' ', '/'])) do
+            begin
+               PrmStr := PrmStr + ComLne[i];
+               i := i + 1
+            end
+      end;
+   ParamStr := PrmStr
+end;
+
+
+function ScanForSwitches (PrmNmb : integer) : integer;
+var
+   SwtStr    : String127;
+   SwtPos, i : integer;
+begin
+   repeat
+      SwtStr := ParamStr(PrmNmb);
+      SwtPos := pos('/', SwtStr);
+      if Swtpos <> 0 then
+         begin
+            PrmNmb := PrmNmb - 1;
+            delete(SwtStr, 1, 1);
+            for i := 1 to length(SwtStr) do
+               SwtStr[i] := upcase(SwtStr[i]);
+            if SwtStr = 'Q' then
+               Quiet := true;
+            if SwtStr = 'F' then
+               ChkWrt := false
+         end
+   until SwtPos = 0;
+   ScanForSwitches := PrmNmb
+end;
+
+
+procedure ShowUsage;
+begin
+   writeln;
+   writeln('CPM-TO-DOS v1.00  (c) Copyright  S.J.Kay  18th April 1995');
+   writeln;
+   writeln('Use:- cpmtodos (c:files) (c:files)... d:\path [/f/q]');
+   writeln;
+   writeln('c:files = CP/M drive and files');
+   writeln('d:\path = DOS destination drive and path');
+   writeln('     /f = force overwriting of existing file(s)');
+   writeln('     /q = quiet, no display of file names')
+end;
+
+
+var
+   PrmTot, PrmNmb : integer;
+   SwtStr         : String127;
+begin
+   Quiet := false;
+   ChkWrt := true;
+   Error := 0;
+   PrmNmb := 1;
+   PrmTot := ScanForSwitches(ParmCount);
+   DOSPth := ParamStr(PrmTot);
+   if PrmTot > 1 then
+      begin
+         repeat
+            DirMsk := ParamStr(PrmNmb);
+            PrmNmb := PrmNmb + 1;
+            TransferFiles
+         until (PrmNmb >= PrmTot) or (Error <> 0)
+      end
+   else
+      ShowUsage
+end.