home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / dskutl / transf18.ark / TRANS-02.INC < prev    next >
Encoding:
Text File  |  1989-09-27  |  8.6 KB  |  363 lines
  1.  
  2.  
  3. procedure ConvertName(Str: Str20; var N: NameAry; var T: TypeAry);
  4. var
  5.   I,J: integer;
  6. begin
  7. for I:= 1 to NameSize do N[I]:= ' ';
  8. for I:= 1 to TypeSize do T[I]:= ' ';
  9. if (Str = '') then Str:= '*.*';
  10. if (pos('.',Str) = 0) then Str:= concat(Str,'.');
  11. if not (pos('.',Str)-1 > NameSize) then
  12.   for I:= 1 to pos('.',Str)-1 do
  13.     N[I]:= upcase(Str[I]);
  14. if not (length(copy(Str,pos('.',Str)+1,20)) > TypeSize) then
  15.   for I:= pos('.',Str)+1 to length(Str) do
  16.     T[I-pos('.',Str)]:= upcase(Str[I]);
  17. for I:= 1 to NameSize do
  18.   if (N[I] = '*') then
  19.     for J:= I to NameSize do
  20.       N[J]:= '?';
  21. for I:= 1 to TypeSize do
  22.   if (T[I] = '*') then
  23.     for J:= I to TypeSize do
  24.       T[J]:= '?';
  25. end;
  26.  
  27.  
  28.  
  29. function SameName(S: Str20; FN: NameAry; FT: TypeAry): boolean;
  30. var
  31.   N: NameAry;
  32.   T: TypeAry;
  33.   I,J: integer;
  34.   Match: boolean;
  35. begin
  36. ConvertName(S,N,T);
  37. Match:= true;
  38. for I:= 1 to NameSize do
  39.   if ((N[I] <> FN[I]) and (N[I] <> '?')) then
  40.     Match:= False;
  41. for I:= 1 to TypeSize do
  42.   if ((T[I] <> FT[I]) and (T[I] <> '?')) then
  43.     Match:= False;
  44. SameName:= Match;
  45. end;
  46.  
  47.  
  48.  
  49. procedure dirClLoc;     {firstDirSector enthaellt die ClusterNr des naechsten}
  50. {  Directory Clusters. dirClLoc berechnet dirTrack, dirSector & dirsecs}
  51.  
  52. begin
  53.  
  54.   dirTrack := ((firstDirSector{cluster}-2) * secsPerCluster) div NSectors;
  55.   dirSector := ((firstDirSector{cluster}-2) * secsPerCluster) mod NSectors;
  56.   dirSector := dirSector+firstDataSector;
  57.   dirTrack := dirTrack+firstDataTrack+(dirSector div NSectors);
  58.   dirSector := dirSector mod NSectors;
  59.  
  60.   if dirSector = 0 then begin
  61.     dirSector := NSectors-1;
  62.     dirTrack := dirTrack-1
  63.   end
  64.   else
  65.     dirSector := dirSector-1;
  66.   dirsecs := secsPerCluster
  67.  
  68. end;
  69.  
  70.  
  71.  
  72. procedure SearchNextAll(FileName: Str20; var Error: integer);
  73. const
  74.   SizePC_FCB = 32;
  75. var
  76.   I,FCBsPerSector: integer;
  77.  
  78. begin
  79.   repeat
  80.     Error:= FoundDir;  { default }
  81.     FCBsPerSector:= (SectorSize div SizePC_FCB);
  82.  
  83.     if ((DirOffset mod FCBsPerSector) = 0) then begin
  84.       DirOffset:= 0;
  85.       NextSector(DirSector,DirTrack);
  86.       ReadSector(DirSector,DirTrack,Addr(DirBuffer));
  87.       DirSectorCount:= DirSectorCount +1;
  88.     end;
  89.  
  90.     if (dirSectorCount = dirSecs) and (not rootSearch) then begin
  91.       firstDirSector := FATPointer (firstDirSector);
  92.       if firstDirSector < $ff8 then
  93.         dirClLoc
  94.     end;
  95.  
  96.     if (DirSectorCount < DirSecs) then begin
  97.       DOS_FCB:= ptr(addr(DirBuffer) + (DirOffset * SizePC_FCB));
  98.       if (DOS_FCB^.Name[1] in [#0,#$F6,#$E5]) then
  99.         Error:= MTDirectory;
  100.     end
  101.     else
  102.       Error:= EODirectory;
  103.  
  104.     DirOffset:= DirOffset +1;
  105.  
  106.   until ((Error = EODirectory)
  107.       or (Error = MTDirectory)
  108.       or (SameName(FileName,DOS_FCB^.Name,DOS_FCB^.Extention)));
  109.  
  110.   If (Error = EODirectory) Then Begin
  111.     VolumeName:= False;
  112.     SubDirName:= False;
  113.   End
  114.   Else Begin
  115.     VolumeName:= (DOS_FCB^.Attribute and $08) <> 0;
  116.     SubDirName:= (DOS_FCB^.Attribute and $10) <> 0;
  117.   End
  118. end;    {searchNextAll}
  119.  
  120.  
  121.  
  122. procedure SearchNext(FN: Str20; var Err: integer);
  123. begin
  124. repeat
  125.   SearchNextAll(FN,Err);
  126.   if (DOS_FCB^.Name[1] = #0) then { "high water" mark }
  127.     Err:= EODirectory;
  128.   until ((Err = EODirectory) or (Err = FoundDir));
  129. end;
  130.  
  131.  
  132.  
  133. procedure SearchFirstAll( FileName: Str20; var Error: integer );
  134. const
  135.   SizePC_FCB = 32;
  136. var
  137.   I: integer;
  138. begin
  139.   DirOffset := 0;
  140.   DirSectorCount := -1;
  141.   if rootSearch then begin
  142.     DirTrack:= (firstdirsector-1) div nsectors;
  143.     DirSector:= (FirstDirSector -1) mod nsectors
  144.   end
  145.   else begin
  146.     firstDirSector := dirCluster;
  147.     dirClLoc
  148.   end;
  149.   SearchNextAll(FileName,Error);
  150. end;
  151.  
  152.  
  153.  
  154.  
  155. procedure SearchFirst(FN: Str20; var Err: integer);
  156. begin
  157. SearchFirstAll(FN,Err);
  158. if (Err = MTDirectory) then
  159.   SearchNext(FN,Err);
  160. end;
  161.  
  162.  
  163.  
  164. procedure openSubDir (dirName: str20);
  165.  
  166. var
  167.   err: integer;
  168.  
  169. begin
  170.   searchFirst (dirName, err);
  171.   while (not subDirName) and (err <> EODirectory) do
  172.     searchNext (dirName, err);
  173.   if (err = EODirectory) then begin
  174.     writeln;
  175.     writeln ('Directory not found: "', dirName, '"');
  176.     continue
  177.   end
  178.   else begin    {gefundenes Subdirectory oeffnen}
  179.     dirCluster := DOS_FCB^.clusterNo;
  180.     rootSearch := false
  181.   end
  182. end;
  183.  
  184.  
  185.  
  186. procedure goPath;
  187.  
  188. var
  189.   subDirName: str20;            {Name eines Unterverzeichnisses}
  190.   pathPos: integer;             {Position in pathStr}
  191.   pathEnd: boolean;             {Ende des Pfadnamens erreicht}
  192.  
  193. begin
  194.   rootSearch := true;
  195.   pathPos := 1;
  196.   while pathPos <= length (pathStr) do
  197.     if pathStr [pathPos] = '\' then
  198.       pathPos := pathPos+1
  199.     else begin
  200.       subDirName := '';
  201.       repeat
  202.         subDirName := subDirName+pathStr [pathPos];
  203.         pathPos := succ (pathPos);
  204.         if pathPos <= length (pathStr) then
  205.           pathEnd := (pathStr [pathPos] = '\')
  206.         else
  207.           pathEnd := true
  208.       until pathEnd;
  209.       openSubDir (subDirName)
  210.     end {while}
  211. end;
  212.  
  213.  
  214.  
  215. procedure IdentifyMS_DOS;
  216.  
  217. var
  218.   boot: record
  219.     dummy1: array [0..10] of byte;
  220.     bps: integer;
  221.     cls: byte;
  222.     rsv: integer;
  223.     fas: byte;
  224.     dis: integer;
  225.     sec: integer;
  226.     med: byte;
  227.     spf: integer;
  228.     spt: integer;
  229.     hds: integer;
  230.     hid: integer;
  231.     dummy2: array [30..511] of byte
  232.   end;
  233.  
  234. begin
  235.  
  236.   bdos (13);                        { Disk Reset }
  237.   bdos(14, CPM_Drive);              { CPM_Drive zum Bezugslaufwerk machen }
  238.   dosnew:=true;
  239.  
  240.   RecordsPerSector:= SectorSize div 128;
  241.   FirstFATSector:= 1;
  242.  
  243.   readsector (0, 0, addr (boot));
  244.   with boot do begin
  245.     identity := ds8spt;
  246.     fatsize := spf;
  247.     fatnum := fas;
  248.     IF (sectorsize > 0) AND (dis > 0) AND (dis < 1000) THEN
  249.        dirsecs := (dis*32) div sectorsize
  250.     ELSE
  251.        identity := unidentified;
  252.     nsectors := spt;
  253.     SecsPerCluster := cls;
  254.     IF nsectors > 0 THEN
  255.        ntracks := sec div nsectors
  256.     ELSE
  257.        identity := unidentified;
  258.     singlesided := true;
  259.   end;
  260.   IF sectorSize * fatSize <= MaxFATSize THEN BEGIN
  261.      GetFAT;
  262.      IF fat[1] <> boot.med THEN BEGIN
  263.         writeln('ERR: Media Bytes in Boot Sector and FAT don',
  264.                       chr (39), 't match.');
  265.         Identity := Unidentified;
  266.      END;
  267.   END ELSE BEGIN
  268.      writeln('ERR: FAT too big or disk has no valid BOOT Sector');
  269.      writeln;
  270.      Identity := Unidentified;
  271.   END;
  272.   if not (Identity = Unidentified) then begin
  273.     FirstDirSector:=   FatSize * 2 + FirstFATSector;
  274.     FirstDataSector:=  (FirstDirSector + DirSecs) mod NSectors;
  275.     FirstDataTrack:=   (FirstDirSector + DirSecs) div NSectors;
  276.     NClusters:= (NTracks * NSectors div SecsPerCluster)
  277.                 - (((FATSize * 2) + DirSecs + 1) div SecsPerCluster);
  278.     goPath      {Pfad bis zum gewuenschten Subdir entlanggehen}
  279.   end ELSE
  280.     continue;
  281. end;
  282.  
  283.  
  284.  
  285. procedure showboot;
  286.  
  287. type
  288.  
  289.   sector = array [0..511] of byte;
  290.  
  291.   word = integer;
  292.  
  293.  
  294. var
  295.  
  296.   boot: record
  297.     case dummy: boolean of
  298.      true: (
  299.       dummy1: array [0..10] of byte;
  300.       bps: integer;
  301.       cls: byte;
  302.       rsv: integer;
  303.       fas: byte;
  304.       dis: integer;
  305.       sec: integer;
  306.       med: byte;
  307.       spf: integer;
  308.       spt: integer;
  309.       hds: integer;
  310.       hid: integer;
  311.       dummy2: array [30..511] of byte);
  312.      false: (
  313.       all: sector)
  314.   end;
  315.  
  316.   check: word;          {TOS Pruefsumme des Bootsektors}
  317.  
  318.   i: integer;
  319.  
  320.  
  321. begin   {showboot}
  322.  
  323.   bdos (13);                        { Disk Reset }
  324.   bdos(14, CPM_Drive);              { CPM_Drive zum Bezugslaufwerk machen }
  325.  
  326.   writeln;
  327.   if addr (boot.dummy1) <> addr (boot.all) then
  328.     writeln ('Prg Fehler: Boot Record falsch definiert.');
  329.   readsector (0, 0, addr (boot.all));
  330.   with boot do begin
  331.     if spt <> 0 then
  332.       writeln ('Number of tracks   ', sec div spt)
  333.     else
  334.       writeln ('-- Error in this Boot Sector');
  335.     writeln ('bytes / sector     ', bps);
  336.     writeln ('cluster size       ', cls);
  337.     writeln ('reserved sectors   ', rsv);
  338.     writeln ('# FATs             ', fas);
  339.     writeln ('# Dir entries      ', dis);
  340.     writeln ('# sectors          ', sec);
  341.     writeln ('media              ', med);
  342.     writeln ('sectors / FAT      ', spf);
  343.     writeln ('sectors / track    ', spt);
  344.     writeln ('# heads            ', hds);
  345.     writeln ('hidden sectors     ', hid);
  346.     writeln;
  347.  
  348.     check := 0;
  349.     for i := 0 to 255 do
  350.       check := check+((all[2*i] shl 8)+all[2*i+1]);
  351.     if check = $1234 then begin
  352.       writeln ('This Disk has an executable TOS Boot record');
  353.       writeln
  354.     end
  355.  
  356.   end;
  357.  
  358.   continue
  359. end;
  360.  
  361.  
  362.  
  363.