Program BIOSCOPY Version 3
Delphi & Pascal (česká wiki)
Kategórie: Periférie
Program: Bioscopy.pas, U_disket.pas, A_rename.pas, P_bios.pas
Soubor exe: Bioscopy.exe
Potřebné: U_tokno.tpu
Program: Bioscopy.pas, U_disket.pas, A_rename.pas, P_bios.pas
Soubor exe: Bioscopy.exe
Potřebné: U_tokno.tpu
Program BIOSCOPY Version 3.1 na kopírovaní vadných souború z diskety do aktuálního adresáře.
{ U_DISKET.PAS } { } { Soucast programu BIOSCOPY na kopirovani vadnych souboru z diskety } { do aktualniho adresare. } { } { Datum:21.06.2002 http://www.trsek.com } {$D-,E-,G+,I-,L-,N-,P+,Q-,R-,S-,T-,V-,Y- exe} {B+,D+,L+,I+,Q+,R+,S+,T+,V+,Y+ ladici} {$G+,I-,T-} Unit U_Disket; Interface Const MaxSizeSektor = 1024; Type TypBuf = Array[1..MaxSizeSektor] of Byte; {Poznamky AbsSektor(0..2879 24-bit), optimalizovano na 16-bit BiosPar: Strana.....(0..1 8-bit) na disku Stopa......(0..79 10-bit) na strane, optimalizovano na 8-bit Sektor.....(1..18 6-bit) na stope, optimalizovano na 8-bit u Harddisku se Stopa jmenuje Cylindr a a vsechny hodnoty nemusi odpovidat skutecnosti, protoze nektere harddisky maji vetsi pocet Cylindru nez 1024 a pak se tvari Harddisk Stran:8 Cylindru:2048 jako Stran:16 Cylindru:1024 FatCluster(2..4095) 12-bit, optimalizovano na 16-bit} TypBoot = record JMP:Array[0..2] of Byte; {jmp integer nebo jmp short + byte} Sys:Array[0..7] of Char; {Kecy formatovaciho programu nebo vyrobce co ji formatoval (PC Tools,IBM 3.2)} Size:Word; {bajtu v sektoru} SizeCluster:Byte; {sektoru v clusteru} SizeBoot:Word; {pocet sektoru v bootu} SumFAT:Byte; {pocet tabulek} SizeRoot:Word; {32bajtovych zaznamu v Rootu} AllSektor:Word; {pocet sektoru na disku} ID:Byte; SizeFAT:Word; {sektoru v jedne FAT} SizeStopa:Word; {sektoru na stopu} SumStran:Word; {pocet povrchu} SumHide:Word; {pocet skrytych sektoru} (* 3 varianta *) x:array[30..511] of Byte; (* 1 varianta SpecHide:LongInt; {? pocet specialnich skrytych sektoru} BigAllSektor:LongInt;{? pocet skrytych sektoru} TypDisk:Byte; {cislo disku 0=floppy,80h hard disk} ExtSign:Byte; {signatura rozsireni boot-sektoru} NumDisk:LongInt; {Volume Serial No.,cislo diskety} VolLab:Array[0..10] of Char; {nazev diskety} (* 2 varianta AA55:Word; {= $aa55 kdyz dale nejsou jen nuly(od DOS 4.0)} ShortJMP:Byte; SSkok:Byte; NOP:Byte; Podpis:Array[0..7] of Char; {podpis systemu} Fil:Array[0..$18] of Byte; TypDisk:Byte; {cislo disku 0=floppy,80h hard disk} Rezerve1:Byte; Mark:Char; {= ')'} NumDisk:LongInt; {cislo diskety} VolLab:Array[0..10] of Char; {nazev diskety} Rezerve2:Array[0..7] of Byte; {a dal je kod ktery vypise ze disketa neni bootovaci...} *) End; TypFind = (_Prazdny, _Smazany, _SmazPom,{smazany pomocny} _Pomocny,{obsahuje cast dlouheho nazvu} _Normal {soubor}); TypRoot = Record Name: Array[0..7] of Char; Prip: Array[0..2] of Char; Attr: Byte; Fill: array[0..9] of Char; {Rezervovano MSDOS ma zde nuly,DRDOS ma zde heslo a prvni znak smazaneho souboru} Time: Word; Date: Word; FirstCluster: Word; Size: LongInt; End; TypSFile = Record TRoot:TypRoot; Smazany:Boolean; LName:String; Index:Word; End; TypCluster = (cPrazdny,cJednotkovy,cNormal,cRezervovany,cVadny,cPosledni); TypDisketa = record MaxFAT:Byte; {pocet FAT tabulek} SizeSektor:Word; {Byte} SizeStopa:Byte; {sektoru na stopu} SumStran:Byte; SumStop:Word; {stop na stranu} RootPolozek:Byte; {pocet 32bytovych polozek v Rootu} SumHide:Word; AllSektor:Word; FindBoot:Word; {AbsSektor} SizeBoot:Word; {SumSektor} FindFirstFAT:Word; {AbsSektor} SizeOneFAT:Word; {SumSektor} FindRoot:Word; {AbsSektor} SizeRoot:Word; {SumSektor} FindData:Word; {AbsSektor} SizeData:Word; {SumSektor} SizeCluster:Word; {SumSektor} { MaxCluster:Word;} End; Var DiskError:Byte; Disk:TypDisketa; TedFind:Integer; {0..aktualni cislo hledane polozky} Procedure ReadBuffer(Var Buffer;AbsSektor:Word;ErrorInfo:String); Function UnPackHour(Time:Word):Byte; Function UnPackMin(Time:Word):Byte; Function UnPackSec(Time:Word):Byte; Function UnPackYear(Date:Word):Word; Function UnPackMonth(Date:Word):Byte; Function UnPackDay(Date:Word):Byte; Function StringDate(Date:Word):String; Function StringTime(Time:Word):String; Function Otazka(Text:String):Boolean; Function DOSNameFiltr(S:String):String; Function ReadSektor(Strana,Stopa,Sektor:Byte;P:Pointer):Boolean; Function WriteSektor(Strana,Stopa,Sektor:Byte;P:Pointer):Boolean; procedure InfoMechanika; Function WritediskError(Text:String):Boolean; procedure InitDisk; {Poznamka Musi byt vzdy prvni!!! Neni nutna jen u InfoMechanika Nastavi DISK promenou hodnotami z Bootu a naplni FATWord pole} Procedure DiskInfo; {Poznamka Musi predchazet InitDisk} procedure InitRoot(ClusterRoot:Word;Smazany:Boolean); {Poznamka Musi byt druhy! Neni nutna jen u InfoMechanika Nahraje do ROOT prvni sektor a nastavi promnenou TetRoot na nulu} Function ReadRoot({Vstup:}Pozice:Word{0..?};{Vystup:}Var Search:TypRoot):TypFind; {Poznamka Musi predchazet InitDisk a pak InitRoot Udela Search := Root[Polozka]} Procedure ViewAndCopy(ClusterRoot:Word;Smazany:Boolean); {Poznamka Musi predchazet InitDisk Procedure prohlizi Root a nabizi soubory ke kopirovani do aktualniho adresare na disku} procedure FindFirst(ClusterRoot: Word; SmazanyAdr: Boolean; var F: TypSFile); {Pozn mky Musi predchazet InitDisk!!! (nebudu nacitat neustale BOOT a FATku..) Hled v zadan‚m (nebo aktu lnˇm) adres ri prvnˇ polozku, kter odpovˇd urcen‚mu jm‚nu souboru a sade atributu.} procedure FindNext(var F: TypSFile); {Pozn mky musi nasledovat az po FindFirst Chyby jsou hl seny v promenn‚ DosError; jediny mozny chybovy k˘d je 18 (z dn‚ dalsˇ soubory).} procedure FindBack(var F: TypSFile); {Pozn mky musi nasledovat az po FindFirst Chyby jsou hl seny v promenn‚ DosError; jediny mozny chybovy k˘d je 18 (z dn‚ dalsˇ soubory).} procedure CopyFile(Name:String;Smazany:Boolean;TRoot:TypRoot); {Poznamky Musi predchazet InitDisk Kopiruje(zapis je klasickymi PASCAL rutinami) soubor z Diskety do aktualniho adresare} Implementation Uses P_Bios,Dos{SetFTime,SetFAttr}; Var FATWord:Array[0..4095{12-bit}] of Word; {prvni FATka je v pameti kvuli rychlosti} {Aktualni ROOT} DirClustr:Word; DirMaxPol:Word; {pocet polozek} DirTedSek:Word; {aktualni relativni sektor; 0..(Disk.SizeRoot/SizeDir-1)} {ROOT ma sektory za sebou, ale DIRROOT je ma po clusterech ruznych velikosti} DirFATSek:Array[0..4095{12-bit * SizeSektor, u disket mensi jak 2880}] of Word; {Abs. sektory adresare} Root:Array[0..(MaxSizeSektor Div 32)-1] of TypRoot; Function DejHexByte(b:Byte):String; Const Hex:Array[0..15] of Char = ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'); Var S:String; Begin S := Hex[b Shr 4]; S := S + Hex[b And $F]; DejHexByte := S; End; Procedure HexString(Delka:Byte;Var CharArray); Var a:Byte; Pole:Array[1..255] of Byte Absolute CharArray; Begin _Locate(40,WhereY); Write('= $'); For a := 1 To Delka Do Begin Write(DejHexByte(Pole[a])); IF a < Delka Then Write(','); End; WriteLn; End; Function ErrorOtazka(Text:String):Boolean; {Poznamka Kdyz kurzor dorazi az dolu tak vznikne chyba :(, prepne to stranku???} Var Old:Byte; Begin Old := Stranka; Stranka := (Stranka + 1) Mod 2; _AktStr(Stranka); IF WhereX <> 0 Then WriteLn; ErrorOtazka := Otazka(Text); Stranka := Old; _AktStr(Stranka); End; Function Otazka(Text:String):Boolean; Var x:Byte; Begin Write(Text + ' [A/N/Esc]'); Repeat Case ReadKey Of #0: ReadKey; 'A','a': Begin Otazka := True; Break; End; 'N','n': Begin Otazka := False; Break; End; #27:Halt; End; Until False; x := 80; While x > 0 Do Begin Dec(x); _PisXYACode(x,WhereY,7,32); End; End; Function UnPackHour(Time:Word):Byte; Begin UnPackHour := (Time And $F800) Shr 11; End; Function UnPackMin(Time:Word):Byte; Begin UnPackMin := (Time And $07E0) Shr 5; End; Function UnPackSec(Time:Word):Byte; Begin UnPackSec := (Time And $001F) Shl 1; End; Function UnPackYear(Date:Word):Word; Begin UnPackYear := (Date And $FE00) Shr 9 + 1980; End; Function UnPackMonth(Date:Word):Byte; Begin UnPackMonth:= (Date And $01E0) Shr 5; End; Function UnPackDay(Date:Word):Byte; Begin UnPackDay := Date And $001F; End; Function StringDate(Date:Word):String; Var Year:String[4]; Month,Day:String[2]; Begin Str(UnPackDay(Date):2,Day); Str(UnPackMonth(Date),Month); IF Length(Month) = 1 Then Month := '0' + Month; Str(UnPackYear(Date),Year); StringDate := Day + '-' + Month + '/' + Year; End; Function StringTime(Time:Word):String; Var Hour,Min,Sec:String[2]; Begin Str(UnPackHour(Time):2,Hour); Str(UnPackMin(Time),Min); IF Length(Min) = 1 Then Min := '0' + Min; Str(UnPackSec(Time),Sec); IF Length(Sec) = 1 Then Sec := '0' + Sec; StringTime := Hour + ':' + Min + ':' + Sec; End; Function TestCluster(Cluster:Word):TypCluster; Begin Case FATWord[Cluster] of 0: TestCluster := cPrazdny; 1: TestCluster := cJednotkovy; $FF0..$FF6: TestCluster := cRezervovany; $FF7: TestCluster := cVadny; $FF8..$FFF: TestCluster := cPosledni; Else TestCluster := cNormal; End; End; Procedure NextCluster(Var Cluster:Word;Smazany:Boolean); {Poznamka Cluster musi byt na vstupu $2..$FEF tzn. normalni Na vystupu bude taky takovy, tzn. nebude obsahovat "stav" ale ukazatel} Label Xakru; Const Name:Array[TypCluster] of String = ('prazdny(smazany)','jednotkovy','normalni','rezervovany','vadny','posledni'); Var S:String; Old:Byte; Typ:TypCluster; Begin S := ''; Typ := TestCluster(Cluster); IF Smazany Then Begin IF Typ = cNormal Then Cluster := FATWord[Cluster] {nasleduji kratsi(doufejme) soubor ktery castecne prepsal delsi} Else Begin Inc(Cluster); Typ := TestCluster(Cluster); S := 'Chyba pri cteni smazaneho souboru: V ceste je '; Case Typ Of cPrazdny:; {v poradku} cJednotkovy,cRezervovany,cVadny: Begin Xakru: S := S + Name[Typ] + ' cluster!'#13#10; IF ErrorOtazka(S + 'Mam preskocit vsechny stejneho typu? (jinak se pouzije)') Then Begin While TestCluster(Cluster) = Typ Do Inc(Cluster); {nejblizsi dalsi nulovy} Dec(Cluster); NextCluster(Cluster,Smazany); End; End; cNormal,cPosledni{kratky soubor}: Begin {Ted by to chtelo prosmejdit celou FAT a najit pocatecni cluster a pak prosmejdit vsechny adresare a tak zjisit jak se ten soubor jmenuje, uff!} IF Typ = cPosledni Then S := S + 'maly '; S := S + 'nesmazany soubor!'#13#10; IF ErrorOtazka(S + 'Byl tu pred smazanim? Tzn. mam ho preskocit? (jinak prepsal cast dat)') Then Begin While Typ = cNormal Do {dokud neni konec nebo chyba} Begin Inc(Cluster); {nejblizsi dalsi nulovy} Typ := TestCluster(Cluster); End; IF Typ = cPosledni Then NextCluster(Cluster,Smazany) {muze prijit cokoliv} Else IF Typ <> cPrazdny Then Goto Xakru; {zbyva cPrazdny = ok, ale kde je cPosledni?} End; End; End;{Case} End; End {Smazany} Else IF Typ = cNormal Then Cluster := FATWord[Cluster] Else {...problemy, nemam odkaz} Begin S := 'Chyba! Aktualni cluster je ' + Name[Typ] + ', tzn. neznam pokracovani.'#13#10; Inc(Cluster); Typ := TypCluster(Cluster); S := S + 'Nasleduje ' + Name[Typ] + '. Pouzit? (jinak se hleda nejblizsi jiny)'; {Nasleduje prazdny(smazany). Pouzit? (jinak se hleda nejblizsi jiny) [A/N/Esc]} IF Not ErrorOtazka(S) Then Begin While TestCluster(Cluster) = Typ Do Inc(Cluster); {nejblizsi dalsi nulovy} Dec(Cluster); NextCluster(Cluster,Smazany); End; End; End; Function WriteDiskError(Text:String):Boolean; {Pozn mky True = opakovat} Var S:String; Begin Case DiskError of $00:S := 'pri posledni operaci nedoslo k zadne chybe'; $01:S := 'spatny prikaz: neplatny pozadavek na radic'; $02:S := 'spatne oznaceni adresy'; $03:S := 'pokus o zapis na disketu chranenou proti zapisu'; $04:S := 'spatna identifikace sektoru nebo sektor nenalezen'; $05:S := 'neuspesny reset (AT)'; $06:S := 'priznak vymeny diskety aktivni (floppy)'; $07:S := 'drive parametr activity failed (harddisk)'; $08:S := 'chyba DMA'; $09:S := 'preteceni DMA: pokus o zapis pres 64Kb hranici'; $0a:S := 'zjistena spatna sektorova vlajka (harddisk)'; $0b:S := 'spatny priznak stopy (AT)'; $0c:S := 'typ media nenalezen (floppy)'; $0d:S := 'spatny pocet sektoru pri formatu hardisku (harddisk)'; $0e:S := 'zjistena Control Address Mark'; $0f:S := 'DMA arbitration level out of range (harddisk)'; $10:S := 'spatny CRC'; $11:S := 'data opravena: byla nalezena chyba odstranitelna algoritmem ECC (AT)'; $20:S := 'chyba radice'; $40:S := 'spatne vystaveni: pozadovana stopa nebyla nalezena'; $80:S := 'prekroceni casu: drive neodpovida'; $bb:S := 'nedefinovana chyba (AT)'; $cc:S := 'chyba zapisu (AT)'; $e0:S := 'status error'; $ff:S := 'sence operation failed (AT, harddisk)'; Else S := 'neznama chyba!'; End; WriteDiskError := ErrorOtazka('Bios chyba: ' + DejHexByte(DiskError) + 'h; ' + S + #13#10 + Text); End; Procedure Konvert_AbsSektor_BiosPar(AbsSektor:Word;Var Strana,Stopa,Sektor:Byte); {Pozn mky Konvertuje AbsSektor(0..?) na Bios parametry: Strana(0..?),Stopa(0..?),Sektor(1..?)} Begin Sektor := AbsSektor Mod Disk.SizeStopa + 1; AbsSektor:= AbsSektor Div Disk.SizeStopa; Strana := AbsSektor Mod Disk.SumStran; Stopa := AbsSektor Div Disk.SumStran; End; Function Konvert_BiosPar_AbsSektor(Strana,Stopa,Sektor:Byte):Word; {Pozn mky Konvertuje Bios parametry: Strana(0..?),Stopa(0..?),Sektor(1..?) na AbsSektor(0..?)} Begin Konvert_BiosPar_AbsSektor := ((Stopa * Disk.SumStran) + Strana) * Disk.SizeStopa + Sektor - 1; End; Function Konvert_FatCluster_AbsSektor(Cluster:Word):Word; {Pozn mky Konvertuje FatCluster na AbsSektor(0..?)} Begin IF Cluster = 0 Then {odkaz na Root v ".. "} Konvert_FatCluster_AbsSektor := Disk.FindRoot Else Konvert_FatCluster_AbsSektor := (Cluster - 2) * Disk.SizeCluster + Disk.FindData; End; Function ReadSektor(Strana,Stopa,Sektor:Byte;P:Pointer):Boolean; Assembler; {optimalizovano na disketu; stopa=byte!} Asm mov ah,$02 {fce cti} mov dl,0 {drive a:} mov dh,Strana mov ch,Stopa mov cl,Sektor mov al,1 {pocet ctenych sektoru, ne vice nez sektoru na stopu} les bx,P int $13 mov DiskError,ah mov al,1 jnc @Exit mov al,0 @Exit: End; Function WriteSektor(Strana,Stopa,Sektor:Byte;P:Pointer):Boolean; Assembler; {optimalizovano na disketu; stopa=byte!} Asm mov ah,$03 {fce pis} mov dl,0 {drive a:} mov dh,Strana mov ch,Stopa mov cl,Sektor mov al,1 {pocet ctenych sektoru, ne vice nez sektoru na stopu} les bx,P int $13 mov DiskError,ah mov al,1 jnc @Exit mov al,0 @Exit: End; Procedure InitFATWord; Var FAT12bit:Array[0..(4096{12bit}*12{bit} Div 8{bit})-1] of Byte; Posun:Byte; Offset,Cluster:Word; Begin FillChar(FATWord,SizeOf(FATWord),0); FillChar(FAT12bit,SizeOf(FAT12bit),0); For Posun := 0 To Disk.SizeOneFAT - 1 Do ReadBuffer(Fat12bit[Posun * Disk.SizeSektor],Disk.FindFirstFAT + Posun,'Opakovat cteni FAT tabulky?'); For Cluster := 0 To (Disk.SizeData Div Disk.SizeCluster) - 1{aby to zacalo od nuly} + 2{prvni 2 jsou nevyuzity} Do Begin Offset:= (Cluster * 3) Div 2; IF Odd(Cluster) Then FATWord[Cluster] := (Fat12bit[Offset+1] Shl 4) + (Fat12bit[Offset] Shr 4) Else FATWord[Cluster] := ((Fat12bit[Offset+1] And $0F) Shl 8) + Fat12bit[Offset]; End; End; Procedure DiskInfo; Begin With Disk Do Begin { WriteLn(' +------+------------------+------+------+'); Writeln(' | BOOT | FAT(1) .. FAT(x) | ROOT | DATA |'); WriteLn(' +------+------------------+------+------+'); } Writeln('BOOT info:'); { WriteLn(' - Podpis format. programu: "',Boot.Sys,'"');} WriteLn(' - Pocet stran : ',SumStran); WriteLn(' - Pocet stop : ',SumStop); WriteLn(' - Pocet sektoru: ',SizeStopa); WriteLn(' - Sektor : ',SizeSektor,' bajtu'); WriteLn(' - Cluster : ',SizeCluster,' sekt.'); WriteLn(' - Struktura Zacatek Delka'); WriteLn(' Boot :', FindBoot:11, SizeBoot:7,' sekt.'); WriteLn(' FAT :',FindFirstFAT:11,SizeOneFat*MaxFAT:7,' sekt. (',SizeOneFAT,' sekt. * ',MaxFAT,' FAT tab.) '); WriteLn(' Root :', FindRoot:11, SizeRoot:7,' sekt. (',RootPolozek,' Polozek * 32 bajtu)'); WriteLn(' Data :', FindData:11, SizeData:7,' sekt. z toho: ',SumHide,' skrytych'); WriteLn(' Celkem:', AllSektor:7,' sekt.'); End; End; Procedure InitDisk; Var Buf:TypBuf; Boot:TypBoot Absolute Buf; Begin While Not ReadSektor(0,0,1,@Buf) Do IF Not WriteDiskError('Opakovat cteni BOOT tabulky?') Then Break; With Disk Do Begin MaxFAT := Boot.SumFAT; SizeSektor := Boot.Size; {Byte} SizeStopa := Boot.SizeStopa; SumStran := Boot.SumStran; SumStop := Boot.AllSektor Div (SumStran*SizeStopa); RootPolozek := Boot.SizeRoot; SumHide := Boot.SumHide; AllSektor := Boot.AllSektor; FindBoot := 0; {AbsSektor} SizeBoot := Boot.SizeBoot; {SumSektor} FindFirstFAT:= FindBoot + SizeBoot; {AbsSektor} SizeOneFAT := Boot.SizeFAT; {SumSektor} FindRoot := FindFirstFAT + SizeOneFAT * MaxFAT; {AbsSektor} SizeRoot := (32*RootPolozek + (SizeSektor-1)) Div SizeSektor; {SumSektor} FindData := FindRoot + SizeRoot; {AbsSektor} SizeData := Boot.AllSektor - FindData; {SumSektor} SizeCluster := Boot.SizeCluster; {SumSektor} IF SizeSektor > MaxSizeSektor Then Begin Writeln('Chyba programu, sektor je vetsi nez ',MaxSizeSektor,' bajtu!'); Halt; End; IF Boot.AllSektor Mod (SumStran*SizeStopa) > 0 Then Begin Writeln('Chyba programu, pocet vsech sektoru neni nasobkem Strany * SektoruNaStopu!'); Halt; End; End; InitFATWord; End; Procedure ReadBuffer(Var Buffer;AbsSektor:Word;ErrorInfo:String); {Poznamka Pouziva Fci Konvert_AbsSektor_BiosPar, tzn. musi byt uz inicializovan DISK = nejde pouzit na cteni BOOTu} Var Strana,Stopa,Sektor:Byte; Begin Konvert_AbsSektor_BiosPar(AbsSektor,Strana,Stopa,Sektor); While Not ReadSektor(Strana,Stopa,Sektor,@Buffer) Do IF Not WriteDiskError(ErrorInfo) Then Break; End; Function DOSNameFiltr(S:String):String; {Poznamka Bacha na '. ' nebo '.. '} Var a:Byte; Begin a := Length(S); While S[a] = ' ' Do Dec(a); For a := a DownTo 1 Do Case S[a] of '€'..'˙','A'..'Z','0'..'9','_','^','$','~','!','#','%','&','-','{','}','(',')','@','''','`':; 'a'..'z': S[a] := Chr(Ord(S[a]) + Ord('A') - Ord('a')); Else S[a] := '_'; End; DOSNameFiltr := S; End; Function TestDirCluster(Cluster:Word;First:Boolean):Word; Var a,b:Byte; Error:Word; MainRoot:Array[0..(MaxSizeSektor Div 32)-1] of TypRoot; Begin Error := 0; For a := 1 To Disk.SizeCluster Do Begin ReadBuffer(MainRoot,Konvert_FatCluster_AbsSektor(Cluster)+a-1,'Opakovat testovaci cteni ROOT?'); IF a = 1 Then Begin IF (MainRoot[0].Name = '. ') And (MainRoot[0].Attr = $10) And (MainRoot[1].Name = '.. ') And (MainRoot[1].Attr = $10) Then Begin IF Not First Then Inc(Error,100); End Else IF First Then Inc(Error,100); End; For b := 0 To Disk.SizeSektor Div 32 - 1 Do Begin IF (MainRoot[b].Attr <> $0F) Or (MainRoot[b].FirstCluster <> 0) Then IF MainRoot[b].Name[0] <> #0 Then Begin IF MainRoot[b].Name = ' ' Then Inc(Error,1) Else IF (a = 1) And (b = 0) And (MainRoot[b].Name = '. ') Then Else IF (a = 1) And (b = 1) And (MainRoot[b].Name = '.. ') Then Else IF MainRoot[b].Name <> DOSNameFiltr(MainRoot[b].Name) Then Inc(Error,1); IF MainRoot[b].Attr And $C0 <> 0 Then Inc(Error,1); End; End; End; TestDirCluster := Error; End; Procedure InitRoot(ClusterRoot:Word;Smazany:Boolean); Var Sum:Integer; Poskozen:Boolean; OldClustr:Word; Procedure MakeCluster; Var w:Word; Begin DirFATSek[Sum] := Konvert_FatCluster_AbsSektor(ClusterRoot); w := Disk.SizeCluster; While w > 1 Do Begin Dec(w); DirFATSek[Sum + 1] := DirFATSek[Sum] + 1; Inc(Sum) End; End; Begin OldClustr := DirClustr; DirClustr := ClusterRoot; DirTedSek := 0; ReadBuffer(Root,Konvert_FatCluster_AbsSektor(ClusterRoot),'Opakovat cteni ROOT zacatku?'); IF ClusterRoot = 0 Then Begin DirMaxPol := Disk.RootPolozek; For Sum := 0 To Disk.SizeRoot - 1 Do DirFATSek[Sum] := Disk.FindRoot + Sum; End Else IF Smazany Then Begin Sum := 0; Repeat MakeCluster; IF TestDirCluster(ClusterRoot,Sum = 0) > 0 Then Begin IF Sum = 0 Then Begin FillChar(Root,SizeOf(Root),0); Root[0].Name := '. '; Root[0].Prip := ' '; Root[0].Attr := $10; Root[0].FirstCluster := DirClustr; Root[1].Name := '.. '; Root[1].Prip := ' '; Root[1].Attr := $10; Root[1].FirstCluster := OldClustr; Root[2].Name := 'DESTROYE'; Root[2].Prip := 'D! '; Root[2].Attr := $08; End Else Dec(Sum); Break; End; IF TestCluster(ClusterRoot + 1) <> cPrazdny Then IF ErrorOtazka('Dalsi cluster neni smazany! Ukoncit cteni smazaneho adresare?') Then Break; NextCluster(ClusterRoot,Smazany); Inc(Sum); Until False; DirMaxPol := (Sum + 1) * (Disk.SizeSektor Div 32); End Else Begin Sum := 0; Poskozen := False; Repeat MakeCluster; Case TestCluster(ClusterRoot) of cPosledni: Break; cNormal:; Else Poskozen := True; End; {$B-} IF Poskozen And ErrorOtazka('Ukoncit cteni poskozeneho adresare?') Then Break; NextCluster(ClusterRoot,Smazany); Inc(Sum); Until False; DirMaxPol := (Sum + 1) * (Disk.SizeSektor Div 32); End; End; Function ReadRoot({Vstup:}Pozice:Word{0..?};{Vystup:}Var Search:TypRoot):TypFind; Var SubPoz,MaxRoot,Posun:Word; Begin MaxRoot := Disk.SizeSektor Div 32; SubPoz := Pozice Mod MaxRoot; Posun := Pozice Div MaxRoot; IF Posun <> DirTedSek Then Begin DirTedSek := Posun; ReadBuffer(Root,DirFATSek[Posun],'Opakovat cteni ROOT?'); End; Search := Root[SubPoz]; IF Search.Name[0] = #0 Then ReadRoot := _Prazdny Else IF (Search.Attr = $0F) And (Search.FirstCluster = 0) Then Begin IF Search.Name[0] = 'ĺ' Then ReadRoot := _SmazPom Else ReadRoot := _Pomocny; End Else IF Search.Name[0] = 'ĺ' Then ReadRoot := _Smazany Else ReadRoot := _Normal; End; Function LongName(TRoot:TypRoot):String; {Poznamka Nahraje 13 pismen z dlouheho nazvu a transformuje je z Unicode do Latin2 pokud to jde jinak je nahradi otaznikem} Const UniLatin2:Array[128..255] of Word = ( $00C7, {C, (LATIN CAPITAL LETTER C WITH CEDILLA)} $00FC, {u: (LATIN SMALL LETTER U WITH DIAERESIS)} $00E9, {e' (LATIN SMALL LETTER E WITH ACUTE)} $00E2, {a/> (LATIN SMALL LETTER A WITH CIRCUMFLEX)} $00E4, {a: (LATIN SMALL LETTER A WITH DIAERESIS)} $016F, {u0 (LATIN SMALL LETTER U WITH RING ABOVE)} $0107, {c' (LATIN SMALL LETTER C WITH ACUTE)} $00E7, {c, (LATIN SMALL LETTER C WITH CEDILLA)} $0142, {l// (LATIN SMALL LETTER L WITH STROKE)} $00EB, {e: (LATIN SMALL LETTER E WITH DIAERESIS)} $0150, {O" (LATIN CAPITAL LETTER O WITH DOUBLE ACUTE)} $0151, {o" (LATIN SMALL LETTER O WITH DOUBLE ACUTE)} $00EE, {i/> (LATIN SMALL LETTER I WITH CIRCUMFLEX)} $0179, {Z' (LATIN CAPITAL LETTER Z WITH ACUTE)} $00C4, {A: (LATIN CAPITAL LETTER A WITH DIAERESIS)} $0106, {C' (LATIN CAPITAL LETTER C WITH ACUTE)} $00C9, {E' (LATIN CAPITAL LETTER E WITH ACUTE)} $0139, {L' (LATIN CAPITAL LETTER L WITH ACUTE)} $013A, {l' (LATIN SMALL LETTER L WITH ACUTE)} $00F4, {o/> (LATIN SMALL LETTER O WITH CIRCUMFLEX)} $00F6, {o: (LATIN SMALL LETTER O WITH DIAERESIS)} $013D, {L< (LATIN CAPITAL LETTER L WITH CARON)} $013E, {l< (LATIN SMALL LETTER L WITH CARON)} $015A, {S' (LATIN CAPITAL LETTER S WITH ACUTE)} $015B, {s' (LATIN SMALL LETTER S WITH ACUTE)} $00D6, {O: (LATIN CAPITAL LETTER O WITH DIAERESIS)} $00DC, {U: (LATIN CAPITAL LETTER U WITH DIAERESIS)} $0164, {T< (LATIN CAPITAL LETTER T WITH CARON)} $0165, {t< (LATIN SMALL LETTER T WITH CARON)} $0141, {L// (LATIN CAPITAL LETTER L WITH STROKE)} $00D7, {*X (MULTIPLICATION SIGN)} $010D, {c< (LATIN SMALL LETTER C WITH CARON)} $00E1, {a' (LATIN SMALL LETTER A WITH ACUTE)} $00ED, {i' (LATIN SMALL LETTER I WITH ACUTE)} $00F3, {o' (LATIN SMALL LETTER O WITH ACUTE)} $00FA, {u' (LATIN SMALL LETTER U WITH ACUTE)} $0104, {A; (LATIN CAPITAL LETTER A WITH OGONEK)} $0105, {a; (LATIN SMALL LETTER A WITH OGONEK)} $017D, {Z< (LATIN CAPITAL LETTER Z WITH CARON)} $017E, {z< (LATIN SMALL LETTER Z WITH CARON)} $0118, {E; (LATIN CAPITAL LETTER E WITH OGONEK)} $0119, {e; (LATIN SMALL LETTER E WITH OGONEK)} $00AC, {NO (NOT SIGN)} $017A, {z' (LATIN SMALL LETTER Z WITH ACUTE)} $010C, {C< (LATIN CAPITAL LETTER C WITH CARON)} $015F, {s, (LATIN SMALL LETTER S WITH CEDILLA)} $00AB, {<< (LEFT-POINTING DOUBLE ANGLE QUOTATION MARK)} $00BB, {/>/> (RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK)} $2591, {.S (LIGHT SHADE)} $2592, {:S (MEDIUM SHADE)} $2593, {?S (DARK SHADE)} $2502, {vv (BOX DRAWINGS LIGHT VERTICAL)} $2524, {vl (BOX DRAWINGS LIGHT VERTICAL AND LEFT)} $00C1, {A' (LATIN CAPITAL LETTER A WITH ACUTE)} $00C2, {A/> (LATIN CAPITAL LETTER A WITH CIRCUMFLEX)} $011A, {E< (LATIN CAPITAL LETTER E WITH CARON)} $015E, {S, (LATIN CAPITAL LETTER S WITH CEDILLA)} $2563, {VL (BOX DRAWINGS DOUBLE VERTICAL AND LEFT)} $2551, {VV (BOX DRAWINGS DOUBLE VERTICAL)} $2557, {LD (BOX DRAWINGS DOUBLE DOWN AND LEFT)} $255D, {UL (BOX DRAWINGS DOUBLE UP AND LEFT)} $017B, {Z. (LATIN CAPITAL LETTER Z WITH DOT ABOVE)} $017C, {z. (LATIN SMALL LETTER Z WITH DOT ABOVE)} $2510, {dl (BOX DRAWINGS LIGHT DOWN AND LEFT)} $2514, {ur (BOX DRAWINGS LIGHT UP AND RIGHT)} $2534, {uh (BOX DRAWINGS LIGHT UP AND HORIZONTAL)} $252C, {dh (BOX DRAWINGS LIGHT DOWN AND HORIZONTAL)} $251C, {vr (BOX DRAWINGS LIGHT VERTICAL AND RIGHT)} $2500, {hh (BOX DRAWINGS LIGHT HORIZONTAL)} $253C, {vh (BOX DRAWINGS LIGHT VERTICAL AND HORIZONTAL)} $0102, {A( (LATIN CAPITAL LETTER A WITH BREVE)} $0103, {a( (LATIN SMALL LETTER A WITH BREVE)} $255A, {UR (BOX DRAWINGS DOUBLE UP AND RIGHT)} $2554, {DR (BOX DRAWINGS DOUBLE DOWN AND RIGHT)} $2569, {UH (BOX DRAWINGS DOUBLE UP AND HORIZONTAL)} $2566, {DH (BOX DRAWINGS DOUBLE DOWN AND HORIZONTAL)} $2560, {VR (BOX DRAWINGS DOUBLE VERTICAL AND RIGHT)} $2550, {HH (BOX DRAWINGS DOUBLE HORIZONTAL)} $256C, {VH (BOX DRAWINGS DOUBLE VERTICAL AND HORIZONTAL)} $00A4, {Cu (CURRENCY SIGN)} $0111, {d// (LATIN SMALL LETTER D WITH STROKE)} $0110, {D// (LATIN CAPITAL LETTER D WITH STROKE)} $010E, {D< (LATIN CAPITAL LETTER D WITH CARON)} $00CB, {E: (LATIN CAPITAL LETTER E WITH DIAERESIS)} $010F, {d< (LATIN SMALL LETTER D WITH CARON)} $0147, {N< (LATIN CAPITAL LETTER N WITH CARON)} $00CD, {I' (LATIN CAPITAL LETTER I WITH ACUTE)} $00CE, {I/> (LATIN CAPITAL LETTER I WITH CIRCUMFLEX)} $011B, {e< (LATIN SMALL LETTER E WITH CARON)} $2518, {ul (BOX DRAWINGS LIGHT UP AND LEFT)} $250C, {dr (BOX DRAWINGS LIGHT DOWN AND RIGHT)} $2588, {FB (FULL BLOCK)} $2584, {LB (LOWER HALF BLOCK)} $0162, {T, (LATIN CAPITAL LETTER T WITH CEDILLA)} $016E, {U0 (LATIN CAPITAL LETTER U WITH RING ABOVE)} $2580, {TB (UPPER HALF BLOCK)} $00D3, {O' (LATIN CAPITAL LETTER O WITH ACUTE)} $00DF, {ss (LATIN SMALL LETTER SHARP S (German))} $00D4, {O/> (LATIN CAPITAL LETTER O WITH CIRCUMFLEX)} $0143, {N' (LATIN CAPITAL LETTER N WITH ACUTE)} $0144, {n' (LATIN SMALL LETTER N WITH ACUTE)} $0148, {n< (LATIN SMALL LETTER N WITH CARON)} $0160, {S< (LATIN CAPITAL LETTER S WITH CARON)} $0161, {s< (LATIN SMALL LETTER S WITH CARON)} $0154, {R' (LATIN CAPITAL LETTER R WITH ACUTE)} $00DA, {U' (LATIN CAPITAL LETTER U WITH ACUTE)} $0155, {r' (LATIN SMALL LETTER R WITH ACUTE)} $0170, {U" (LATIN CAPITAL LETTER U WITH DOUBLE ACUTE)} $00FD, {y' (LATIN SMALL LETTER Y WITH ACUTE)} $00DD, {Y' (LATIN CAPITAL LETTER Y WITH ACUTE)} $0163, {t, (LATIN SMALL LETTER T WITH CEDILLA)} $00B4, {'' (ACUTE ACCENT)} $00AD, {-- (SOFT HYPHEN)} $02DD, {'" (DOUBLE ACUTE ACCENT)} $02DB, {'; (OGONEK)} $02C7, {'< (CARON (Mandarin Chinese third tone))} $02D8, {'( (BREVE)} $00A7, {SE (SECTION SIGN)} $00F7, {-: (DIVISION SIGN)} $00B8, {', (CEDILLA)} $00B0, {DG (DEGREE SIGN)} $00A8, {': (DIAERESIS)} $02D9, {'. (DOT ABOVE (Mandarin Chinese light tone))} $0171, {u" (LATIN SMALL LETTER U WITH DOUBLE ACUTE)} $0158, {R< (LATIN CAPITAL LETTER R WITH CARON)} $0159, {r< (LATIN SMALL LETTER R WITH CARON)} $25A0, {fS (BLACK SQUARE)} $00A0); {NS (NO-BREAK SPACE)} Var Pole:Array[0..31] of Char Absolute TRoot; i,a:Integer; PUni:^Word; S:String; Pis:Char; Begin i := 1; S := ''; Repeat PUni := @Pole[i]; IF PUni^ = 0 Then Break; { = konec pak nasleduji $FFFF (ASCIZ)} IF (PUni^ < $0080) Then Pis := Pole[i] Else Begin Pis := '?'; For a := 128 To 255 Do IF PUni^ = UniLatin2[a] Then Begin Pis := Char(a); Break; End; End; S := S + Pis; Inc(i,2); IF i = 11 Then i := 14; IF i = 26 Then i := 28; Until i > 30; LongName := S; End; Procedure ViewAndCopy(ClusterRoot:Word;Smazany:Boolean); Var Polozka:Word; F:TypRoot; LName:String; Ukaz,Pomoc:Boolean; a:Byte; Begin LName := ''; InitRoot(ClusterRoot,Smazany); Writeln('Soubory na diskete:'); For Polozka := 0 To DirMaxPol - 1 Do Begin _Locate(0,WhereY); Write(' - Polozka adresare: ',Polozka:3,' (0..',DirMaxPol-1,') '); Pomoc := False; Case ReadRoot(Polozka,F) Of _Normal: Ukaz := True; _Prazdny: Ukaz := Otazka('$00 = prazdna, zobrazit?'); _Smazany: Ukaz := Otazka('$E5 = smazana, zobrazit?'); _Pomocny,_SmazPom: Begin Pomoc := True; LName := LongName(F) + LName; Ukaz := Otazka('$'+DejHexByte(Ord(F.Name[0]))+' = pomocna, zobrazit?'); End; End; IF Ukaz Then With F Do Begin Writeln; IF LName <> '' Then Begin Write(' LongName: "'); {Soucasti jmena muze byt i znak #13!!!} For a := 1 To Length(LName) Do _PisXYACode(15+a,WhereY,2,Ord(LName[a])); _Locate(16+Length(LName),WhereY); WriteLn('"'); End; Write(' Jmeno: "'+Name+'"'); HexString( 8,Name); Write(' Pripona: "'+Prip+'"'); HexString( 3,Prip); Write(' Atribut: ', Attr); HexString( 1,Attr); Write(' Fill: "'+Fill+'"'); HexString(10,Fill); Write(' Cas: ', StringTime(Time)); HexString( 2,Time); Write(' Datum: ', StringDate(Date)); HexString( 2,Date); Write('Prvni Cluster: ', FirstCluster); HexString( 2,FirstCluster); Write(' Delka: ', Size); HexString( 4,Size); IF Size > 0 Then Begin IF Otazka('Kopirovat?') Then CopyFile(Name + '.' + Prip,F.Name[0] = 'ĺ',F); End Else IF (Attr And 16) > 0 Then Begin IF Otazka('Vstoupit?') Then ViewAndCopy(FirstCluster,F.Name[0] = 'ĺ'); {Re}InitRoot(ClusterRoot,Smazany); End End; IF Not Pomoc Then LName := ''; End; End; procedure FindFirst(ClusterRoot: Word; SmazanyAdr: Boolean; var F: TypSFile); Begin InitRoot(ClusterRoot,SmazanyAdr); TedFind := -1; FindNext(F); End; procedure FindNext(var F: TypSFile); Var S:String; Begin F.LName := ''; For TedFind := TedFind + 1 To DirMaxPol - 1 Do Case ReadRoot(TedFind,F.TRoot) of _Prazdny: F.LName := ''; _Normal,_Smazany: Begin F.Index := TedFind; F.Smazany:= F.TRoot.Name[0] = 'ĺ'; IF DiskError = 18 Then DiskError := 0; {!!! pri vnejsi modifikaci TedFind} Exit; End; _Pomocny,_SmazPom: Begin S := LongName(F.TRoot); IF Length(S) = 13 Then F.LName := S + F.LName Else F.LName := S; {nechci nabalit nejaky ztraceny Pomocny} End; End; DiskError := 18; {Zadne dalsi soubory} End; procedure FindBack(var F: TypSFile); Var Pomoc:TypRoot; S:String; Begin F.LName := ''; For TedFind := TedFind - 1 DownTo 0 Do Begin Case ReadRoot(TedFind,F.TRoot) of _Normal,_Smazany: Begin F.Index := TedFind; F.Smazany:= F.TRoot.Name[0] = 'ĺ'; For TedFind := TedFind - 1 DownTo 0 Do Case ReadRoot(TedFind,Pomoc) of _Pomocny,_SmazPom: Begin S := LongName(Pomoc); F.LName := F.LName + S; IF Length(S) < 13 Then Break; {nechci nabalit nejaky ztraceny Pomocny} End; Else Break; End; TedFind := F.Index; IF DiskError = 18 Then DiskError := 0; {!!! pri vnejsi modifikaci TedFind} Exit; End; End; End; DiskError := 18; {Zadne dalsi soubory} End; procedure CopyFile(Name:String;Smazany:Boolean;TRoot:TypRoot); Label Vyskoc; Var F:File; Cluster,AbsSektor,NumRead,NumWritten:Word; SizeCluster,Strana,Stopa,Sektor:Byte; Buf:TypBuf; Konec:Boolean; L:^LongInt; Nacteno:LongInt; Begin Cluster := TRoot.FirstCluster; IF Smazany And (FATWord[Cluster] <> 0) Then IF Not ErrorOtazka('Soubor byl prepsan! Pokracovat?') Then Exit; Filemode := 1; Assign(F,Name); { Otevri vystupnˇ soubor } Reset(F,1); IF IOResult = 0 Then { vse v poradku = uz existuje! } IF Not Otazka('Soubor uz existuje! Prepast?') Then Begin Close(F); Exit; End; ReWrite(F, 1); Nacteno := 0; While TRoot.Size > 0 Do Begin AbsSektor := Konvert_FatCluster_AbsSektor(Cluster); For SizeCluster := 0 To Disk.SizeCluster - 1 Do Begin Konvert_AbsSektor_BiosPar(AbsSektor + SizeCluster,Strana,Stopa,Sektor); _Locate(0,WhereY); Write('Abs. Sektor:',AbsSektor + SizeCluster:4,' <0,',Disk.AllSektor-1,'>'); Write(' { Stopa:',Stopa:2,' <0,',Disk.SumStop-1,'>'); Write('; Strana:',Strana:1,' <0,',Disk.SumStran-1,'>'); Write('; Sektor:',Sektor:2,' <1,',Disk.SizeStopa,'> }'); While Not ReadSektor(Strana,Stopa,Sektor,@Buf) Do IF Not WriteDiskError('Opakovat cteni sektoru?') Then Begin Write(#13#10' - Bios chyba Int 13h/Fce 02h: ' + DejHexByte(DiskError),'h'); Writeln('; Vadne bajty: ',Nacteno,'..',Nacteno + Disk.SizeSektor); Break; End; Inc(Nacteno,Disk.SizeSektor); Konec := TRoot.Size <= Disk.SizeSektor; IF Konec Then NumRead := TRoot.Size Else NumRead := Disk.SizeSektor; Dec(TRoot.Size,Disk.SizeSektor); BlockWrite(F, Buf, NumRead, NumWritten); IF IOResult <> 0 Then Begin IF WhereX <> 0 Then WriteLn; Writeln(' - Chyba pri zapisu na pozici: ',FilePos(F)); End; IF NumWritten < NumRead Then Begin IF WhereX <> 0 Then WriteLn; Writeln(' - Nelze zapisovat nebo plny disk'); Goto Vyskoc; End; IF Konec Then Goto Vyskoc; End; NextCluster(Cluster,Smazany); End; Vyskoc: IF WhereX <> 0 Then WriteLn; L := @TRoot.Time; SetFTime(F,L^); Close(F); SetFAttr(F,TRoot.Attr); End; procedure InfoMechanika; Var Buf:TypBuf; SumHardDisk:Byte; MaxStran:Byte; { 0+ 0,1 u Disk.mech; Alias Povrchu,Hlav(Head) } MaxStop:Byte; { 0+ 39,79 u Disk.mech; Alias Stopa(Track) u Disk.mech nebo Valec(Cylinder) u Hardisku } MaxSektoru:Byte; { 1+ 8,9,15,(18?) u Disk.mech } Mechanika:Byte; { 1+ 1,2,3,4 viz Disk.mech } {Function BiosReadInfo:Boolean; Assembler;} Const DiskMech:Array[1..4] of String[7] = ( '360 KB', '1.2 MB', '720 KB', '1.44 MB'); Begin Asm mov ah,$08 {fce} mov dl,0 {drive a:} int $13 mov SumHardDisk,dl mov MaxStran,dh mov MaxSektoru,cl mov MaxStop,ch mov Mechanika,bl End; Write(' - mechanika: '); IF (Mechanika >= 1) And (Mechanika <= 4) Then Writeln(diskMech[Mechanika]) Else Writeln('neznamy typ c. ',Mechanika); Writeln(' pocet stran: ',MaxStran+1); Writeln(' pocet stop (soustrednych kruznic): ',MaxStop+1); Writeln(' pocet sektoru (vyseci na stope): ',MaxSektoru); End; {------- navic, dodelat! ----------} Procedure ResetDrive; Assembler; Asm mov ah,$00 mov dl,0 {drive a:} int $13 End; Procedure ReadErrorSektor(AbsSektor:Word;Var Buf:TypBuf); Var Strana,Stopa,Sektor:Byte; MaxOpak,Opak,Celkem,Vaha:Word; Pole:Array[1..MaxSizeSektor,0..7,0..1] Of Byte; Procedure MakePole; Var a:Byte; i:Word; Begin Inc(Celkem); For i := 1 To Disk.SizeSektor Do For a := 0 To 7 do IF (Buf[i] And (1 shl a)) = 0 Then Inc(Pole[i,a,0]) Else Inc(Pole[i,a,1]) End; Function MakeByte(i:Word;Var Vysledek:Byte;Var Procenta:Real):Boolean; Var a:Byte; Bit:Array[0..7] Of Boolean; Begin MakeByte := True; Vysledek := 0; Procenta := 1; For a := 0 To 7 do Begin IF Pole[i,a,0] > Pole[i,a,1] Then {zero} Begin IF Pole[i,a,1] <> 0 Then Begin MakeByte := False; Procenta := Procenta * Pole[i,a,0]/Celkem; End; End Else Begin IF Pole[i,a,0] <> 0 Then Begin MakeByte := False; Procenta := Procenta * Pole[i,a,1]/Celkem; End; Vysledek := Vysledek Or (1 Shl a); End; End; End; Label Go; Var Procenta:Real; Begin FillChar(Pole,SizeOf(Pole),0); Celkem := 0; MakePole; Write('Vadny sektor, zadej pocet opakovani: '); ReadLn(MaxOpak); Konvert_AbsSektor_BiosPar(AbsSektor,Strana,Stopa,Sektor); For Opak := 1 To MaxOpak Do Begin _Locate(0,WhereY); Write('Opakuji:',Opak:4,'x '); IF Not ReadSektor(Strana,Stopa,Sektor,@Buf) Then Begin IF DiskError <> $10 {vadny crc} Then Begin Write(', Chybovy kod Int 13h/Fce 02h: ',DiskError); ResetDrive; End; End Else Begin Writeln(', Bez chyby! Pouzit pouze posledni cteni [A/N/Esc]'); Case ReadKey Of 'A','a':Exit; #27:Halt; End; Write('Vahu kolikati cteni mam mu priradit: '); ReadLn(Vaha); For Vaha := Vaha DownTo 2 Do MakePole; End; MakePole; End; IF Celkem >= 2 Then Begin Writeln; Writeln('Statistiky zmen z ',Celkem,' cteni:'); For Opak := 1 To Disk.SizeSektor Do Begin MakeByte(Opak,Buf[Opak],Procenta); Writeln('Bajt ',Opak:3,' = ',Buf[Opak]:3,' na ',100*Procenta:6:2,'% '); IF Opak Mod 23 = 0 Then Begin Write('Press any key...'); Pause; Writeln; End; End; End; End; Procedure CopyImage; {Poznamka Kopiruje obraz diskety do aktualniho adresare} Var ToF:File; Stopa,Strana,Sektor:Byte; NumRead,NumWritten:Word; Buf:TypBuf; Begin Filemode := 1; Assign(ToF,'disketa.img'); { Otevri vystupnˇ soubor } Rewrite(ToF, 1); InitDisk; For Stopa := 0 To Disk.SumStop - 1 Do {prehozeno aby se setrila hlavicka} For Strana := 0 To Disk.SumStran - 1 Do For Sektor := 1 To Disk.SizeStopa Do Begin _Locate(0,WhereY); Write('Stopa:',Stopa:3,', Strana:',Strana:2,', Sektor:',Sektor:3,' '); IF Not ReadSektor(Strana,Stopa,Sektor,@Buf) Then Begin Writeln(#13#10' - chyba pri cteni sektoru'); While WriteDiskError('Opakovat cteni?') Do ReadSektor(Strana,Stopa,Sektor,@Buf); End; NumRead := Disk.SizeSektor; BlockWrite(ToF, Buf, NumRead, NumWritten); IF IOResult <> 0 Then Writeln(#13#10' - Chyba pri zapisu na pozici: ',FilePos(ToF)); IF NumWritten < NumRead Then Begin Writeln(#13#10' - Nelze zapisovat nebo plny disk'); Close(ToF); Halt; End; End; Writeln; Close(ToF); End; Procedure SaveImage; {Poznamka Ulozi obraz z aktualniho adresare na disketu} Var FromF:File; Stopa,Strana,Sektor:Byte; NumRead:Word; Buf:TypBuf; Begin Filemode := 0; Assign(FromF,'disketa.img'); { Otevri vystupnˇ soubor } Reset(FromF, 1); InitDisk; For Stopa := 0 To Disk.SumStop - 1 Do {prehozeno aby se setrila hlavicka} For Strana := 0 To Disk.SumStran - 1 Do For Sektor := 1 To Disk.SizeStopa Do Begin BlockRead(FromF, Buf, Disk.SizeSektor, NumRead); IF IOResult <> 0 Then Writeln(#13#10' - Chyba pri cteni na pozici: ',FilePos(FromF)); IF NumRead < Disk.SizeSektor Then Begin Writeln(#13#10' - Nelze cist?'); Close(FromF); Halt; End; _Locate(0,WhereY); Write('Stopa:',Stopa:3,', Strana:',Strana:2,', Sektor:',Sektor:3,' '); IF Not WriteSektor(Strana,Stopa,Sektor,@Buf) Then Begin Writeln(#13#10' - chyba pri zapisu sektoru'); While WriteDiskError('Opakovat zapis?') Do WriteSektor(Strana,Stopa,Sektor,@Buf); End; End; Writeln; Close(FromF); End; End.