home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / LANGUAGS / PASCAL / CPMCOP.PAS < prev    next >
Pascal/Delphi Source File  |  2000-06-30  |  7KB  |  262 lines
  1. PROGRAM cpmcopy;
  2.  
  3. (*Written by J. M. Wierda
  4.  
  5.      This program will transfer a CP/M file from a disk in unit 5 to a Pascal
  6. disk in unit 4. Note that when the filename is requested, it must be 11
  7. characters long and include all spaces. This program does not remove the LFs
  8. from the CP/M file as the transfer is made, so a replace command in the Pascal
  9. editor should be used to delete the LFs. During successful file transfers the
  10. program prints an expanded CP/M directory of the file being tranferred.
  11. Attempts to transfer empty or non-existent files are ignored.*)
  12.  
  13. CONST 
  14.       blkslip = 2;
  15.       quadsperblk = 4;
  16.       trkslip = 6;
  17.       blkspertrk = 6.5;
  18.       secpergrp = 8;
  19.       lastsec = 26;
  20.       lasttrk = 76;
  21.  
  22. TYPE
  23.     groupbuffer = packed array[0..1023] of char;
  24.     
  25. VAR 
  26.     sectortbl : ARRAY[1..lastsec] OF integer;
  27.     grptrk : ARRAY[1..secpergrp] OF integer;
  28.     grpsec : ARRAY[1..secpergrp] OF integer;
  29.     quadmap : ARRAY[1..lastsec] OF integer;
  30.     blockmap : ARRAY[1..lastsec] OF integer;
  31.     blockbuffer : PACKED ARRAY[0..511] OF char;
  32.     directbuffer : groupbuffer;
  33.     transferbuffer : groupbuffer;
  34.     prevtrk, filectr : integer;
  35.     currfile, filename : string;
  36.     outfile : string;
  37.     file2 : text;
  38.  
  39. PROCEDURE trackmap(track : integer);
  40.  
  41. VAR 
  42.     sector,sect,blk,quad,firstsect : integer;
  43.     firstblkquad : real;
  44.  
  45. BEGIN
  46.   IF track <> prevtrk
  47.   THEN
  48.     BEGIN
  49.       firstblkquad := (track-1)*blkspertrk;
  50.       blk := trunc(firstblkquad);
  51.       firstsect := (((track-1)*trkslip)+1) MOD lastsec;
  52.       quad := trunc((firstblkquad-blk)*quadsperblk);
  53.       sect := firstsect;
  54.       FOR sector := 1 TO lastsec DO
  55.         BEGIN
  56.           blockmap[sect] := blk;
  57.           quadmap[sect] := quad;
  58.           sect := (sect + blkslip) MOD lastsec;
  59.           IF sect = 0
  60.           THEN
  61.             sect := lastsec;
  62.           IF sect = firstsect
  63.           THEN
  64.             sect := sect + 1;
  65.           quad := (quad+1) MOD quadsperblk;
  66.           IF quad = 0
  67.           THEN
  68.             blk := blk + 1
  69.         END
  70.     END
  71. END;
  72.  
  73. PROCEDURE initsectbl;
  74. BEGIN
  75.   sectortbl[1] := 1;
  76.   sectortbl[2] := 7;
  77.   sectortbl[3] := 13;
  78.   sectortbl[4] := 19;
  79.   sectortbl[5] := 25;
  80.   sectortbl[6] := 5;
  81.   sectortbl[7] := 11;
  82.   sectortbl[8] := 17;
  83.   sectortbl[9] := 23;
  84.   sectortbl[10] := 3;
  85.   sectortbl[11] := 9;
  86.   sectortbl[12] := 15;
  87.   sectortbl[13] := 21;
  88.   sectortbl[14] := 2;
  89.   sectortbl[15] := 8;
  90.   sectortbl[16] := 14;
  91.   sectortbl[17] := 20;
  92.   sectortbl[18] := lastsec;
  93.   sectortbl[19] := 6;
  94.   sectortbl[20] := 12;
  95.   sectortbl[21] := 18;
  96.   sectortbl[22] := 24;
  97.   sectortbl[23] := 4;
  98.   sectortbl[24] := 10;
  99.   sectortbl[25] := 16;
  100.   sectortbl[lastsec] := 22
  101. END;
  102.  
  103. PROCEDURE cpmgrp(group : integer);
  104.  
  105. VAR 
  106.     j, track, sector : integer;
  107.  
  108. BEGIN
  109.   track := ((group * 8) DIV lastsec) + 2;
  110.   sector := ((group * 8) MOD lastsec) + 1;
  111.   FOR j := 1 TO secpergrp DO
  112.     BEGIN
  113.       grptrk[j] := track;
  114.       grpsec[j] := sectortbl[sector];
  115.       sector := sector + 1;
  116.       IF sector > lastsec
  117.       THEN
  118.         BEGIN
  119.           sector := 1;
  120.           track := track + 1
  121.         END
  122.     END
  123. END;
  124.  
  125. procedure readgroup(group : integer; VAR buffer : groupbuffer);
  126. var
  127.    j, k, l : integer;
  128. begin
  129.   cpmgrp(group);
  130.   l := 0;
  131.   for j := 1 to secpergrp do
  132.     begin
  133.       trackmap(grptrk[j]);
  134.       unitread(10,blockbuffer,512,blockmap[grpsec[j]],0);
  135.       for k := ((quadmap[grpsec[j]])*128) to k+127 do
  136.         begin
  137.           buffer[l] := blockbuffer[k];
  138.           l := l+1
  139.         end
  140.     end
  141. end;
  142.  
  143. PROCEDURE printentries;
  144.  
  145. VAR 
  146.     j, k : integer;
  147.  
  148. begin
  149.   j := 0;
  150.   while j < 1024 do
  151.     BEGIN
  152.       IF (ord(directbuffer[j]) = 0) AND (ord(directbuffer[j+12]) = 0)
  153.          AND (directbuffer[j+1] IN [' '..'Z'])
  154.       THEN
  155.         BEGIN
  156.           FOR k := j+1 TO j+11 DO
  157.             write(directbuffer[k]);
  158.           filectr := filectr + 1;
  159.           IF (filectr MOD 4) = 0
  160.           THEN
  161.             writeln
  162.           ELSE
  163.             write('        ')
  164.         END;
  165.       j := j+32
  166.     END
  167. end;
  168.  
  169. PROCEDURE findentry;
  170.  
  171. VAR 
  172.     extent, sectors, j, k, l : integer;
  173.     eoffound : boolean;
  174. BEGIN
  175.   j := 0;
  176.   WHILE j < 1024  DO
  177.     BEGIN
  178.       IF ord(directbuffer[j]) = 0
  179.       THEN
  180.         BEGIN
  181.           currfile := '           ';
  182.           extent := ord(directbuffer[j+12]);
  183.           sectors := ord(directbuffer[j+15]);
  184.           FOR k := j+1 TO j+11 DO
  185.             currfile[k-j] := directbuffer[k];
  186.           IF (currfile = filename) AND (sectors > 0)
  187.           THEN
  188.             BEGIN
  189.               IF extent = 0
  190.               THEN
  191.                 BEGIN
  192.                   write('Output Filename.Ext ? ');
  193.                   readln(outfile);
  194.                   rewrite(file2, outfile);
  195.                   writeln(currfile);
  196.                   writeln('Ex Sec Groups')
  197.                 END;
  198.               write(extent: 2,sectors: 4);
  199.               FOR k := j+16 TO (k+((sectors-1) DIV 8)) DO
  200.                 begin
  201.                   write(ord(directbuffer[k]): 4);
  202.                   readgroup(ord(directbuffer[k]), transferbuffer);
  203.                   l := 0;
  204.                   eoffound := false;
  205.                   WHILE l <= 1023 DO
  206.                     begin
  207.                       IF (ord(transferbuffer[l]) <> 26) and (not eoffound)
  208.                       then
  209.                         write(file2, transferbuffer[l])
  210.                       else
  211.                         begin
  212.                           eoffound := true;
  213.                           write(file2, chr(0))
  214.                         end;
  215.                       l := l + 1
  216.                     end;
  217.                 end;
  218.               IF sectors < 128
  219.               THEN
  220.                 close(file2,lock);
  221.               writeln
  222.             END
  223.         END;
  224.       j := j+32
  225.     END
  226. END;
  227.  
  228. BEGIN
  229.   filectr := 0;
  230.   prevtrk := 0;
  231.   initsectbl;
  232.   writeln('CP/M File Transfer, 7-Jun-79');
  233.   readgroup(0, directbuffer);
  234.   printentries;
  235.   readgroup(1, directbuffer);
  236.   printentries;
  237.   writeln;
  238.   writeln(filectr,' Files');
  239.   REPEAT
  240.     REPEAT
  241.       writeln;
  242.       write('Transfer which file ? ');
  243.       readln(filename);
  244.       IF NOT (length(filename) IN [0,11])
  245.       THEN
  246.         BEGIN
  247.           write('Enter 11 character filename exactly as listed');
  248.           writeln(', including spaces,');
  249.           writeln('or CR to exit program.')
  250.         END
  251.     UNTIL length(filename) IN [0,11];
  252.     IF length(filename) = 11
  253.     THEN
  254.       BEGIN
  255.         readgroup(0, directbuffer);
  256.         findentry;
  257.         readgroup(1, directbuffer);
  258.         findentry
  259.       END;
  260.   UNTIL length(filename) = 0;
  261. END