program HTML2Texy;
uses dos; {pouzito pro moznost zjisteni existence souboru}
{definice zacatku a koncu znacek}
const ZPZ = '<';
ZDZ = '</';
KZ = '>';
KZX = ' />';
MAXT = 0; {pripadna maximalni hloubka stromu}
{definice polozky stromu}
type PtrS = ^S;
S = record
name : string[20]; {jmeno znacky}
istext : boolean; {priznak pro innerText}
isattr : boolean; {priznak pro atribut}
value : string; {hodnota innerTextu}
child : PtrS; {ukazatel na potomka}
next : PtrS; {ukazatel na sourozence}
end;
{definice zasobniku pro pridavani do stromu}
type PtrL = ^Lifo;
Lifo = record
name : string[20]; {jmeno znacky}
ptr : PtrS; {ukazatel ve stromu}
next : PtrL; {ukazatel na dalsi polozku zasobniku}
end;
{definice promennych}
var f,g : text;
c : char;
buffer : string;
ground,prev,parent : PtrS;
eolf : PtrL;
ZRead : boolean;
ul : boolean;
cnt : longint;
Ssoubor: string;
Vsoubor: string;
UVOZ : 34..39;
{procedura pro smazani stromu HTML dokumentu}
procedure DisposeTree(var ptr: PtrS);
begin
if ptr^.child <> NIL then DisposeTree(ptr^.child); {zavolani funkce na potomky}
if ptr^.next <> NIL then DisposeTree(ptr^.next); {zavolani funkce na nasledovniky}
dispose(ptr); {odstraneni z pameti}
end;
{procedura pro odebrani znacky ze zasobniku}
procedure RemFromLifo;
var actual : PtrL;
begin
actual := eolf;
{writeln('odebiram ',actual^.name);{}
if (actual = NIL) then
begin
{pokud by melo dojit k odebrani NILu ze zasobniku, je uzavreno vice znacek nez otevreno}
{zpusobeno nevalidnim vstupem; doslo by k selhani programu}
writeln('Vstupni soubor nebyl validni');
DisposeTree(ground);
halt;
end;
eolf := actual^.next;
dispose(actual);
end;
{procedura predchazejici zacykleni cyklu cekajicich na urcity znak}
procedure NotValid;
begin
writeln('Zadany vstup neni validni.');
DisposeTree(ground);
while (eolf <> NIL) do
begin
RemFromLifo;
end;
halt;
end;
{V pripade, ze ukonci beh programu, vstup nebyl validni}
procedure CheckEof;
begin
if eof(f) then NotValid;
end;
{funkce zjistujici existenci souboru}
function FileExists(FN :string) :boolean;
var S : PathStr;
begin
S := FSearch(FN,''); {hledani v seznamu souboru}
if S = '' then FileExists := false else FileExists := true; {dosazeni do funkce}
end;
{procedura pro otevreni vstupniho souboru}
procedure OpenFile(var f: text; path : string);
begin
if FileExists(path) then {pokud soubor existuje, otevreme ho ke cteni}
begin
assign(f,path);
reset(f);
end
else {v opacnem pripade ohlasime chybu a skoncime}
begin
writeln('CHYBA: Soubor nenalezen!');
halt;
end;
end;
{procedura pro otevreni vystupniho souboru}
procedure OpenVFile(var g: text; path : string);
begin
assign(g,path);
rewrite(g);
end;
procedure CheckMem;
begin
{ochrana proti HEAP overflow, ktery je zapricinen prilis velkym vstupem}
if (MaxAvail < 300) then
begin
writeln('Vstupni soubor obsahuje prilis mnoho dat.');
writeln('Rozdelte jej na nekolik mensich.');
DisposeTree(ground);
while (eolf <> NIL) do
begin
RemFromLifo;
end;
halt;
end;
end;
{procedura pro pridani polozky do stromu}
procedure AddToTree(var ptr: PtrS; var name: string; istext: boolean; isattr: boolean;
value: string; var parent: PtrS; var prev: PtrS);
begin
{nastaveni vlastnosti polozky}
ptr^.name := name;
ptr^.istext := istext;
ptr^.isattr := isattr;
ptr^.value := value;
ptr^.child := NIL;
ptr^.next := NIL;
{pokud rodic jeste nema potomka, nastavi akt. prvek jako potomka}
if (parent^.child = NIL) AND (parent <> NIL) then
begin
parent^.child := ptr;
end;
{pokud existuje predchazejici sourozenec, zaradi akt. prvek za nej}
if (prev <> NIL) then
begin
prev^.next := ptr;{}
end;{}
{pokud je akt. prvek prvni polozkou stromu}
if ground = NIL then
begin
ground := ptr;
end;
CheckMem;
end;
{procedura hledajici pozici, kam se bude zarazovat dalsi prvek}
procedure GetTreePos(var rodic : PtrS; var sourozenec : PtrS);
var temp : PtrS;
begin
rodic := NIL;
sourozenec := NIL;
if (eolf <> NIL) AND (eolf^.ptr <> NIL) then
begin
rodic := eolf^.ptr; {rodicem je konec zasobniku}
{soourozencem je potomek rodice ukazujici na NIL}
if eolf^.ptr^.child <> NIL then
begin
temp := eolf^.ptr^.child;
while temp^.next <> NIL do
begin
temp := temp^.next;
end;
sourozenec := temp;
end;
end;
end;
{funkce, ktera ze stromu ziska hodnotu prislusneho atributu znacky}
function GetAttrVal(var ptr : PtrS; attrname : string): string;
var actual : PtrS;
begin
actual := ptr^.child;
{pokud ma prvek potomky (atributy jsou mezi nimi)}
while actual <> NIL do
begin
if (actual^.name = attrname) AND (actual^.isattr = true) then
begin
{hodnota atributu nalezena, dosadime do funkce a funkci ukoncime}
GetAttrVal := actual^.value;
exit;
end;
actual := actual^.next;
end;
GetAttrVal := '';{}
end;
{procedura pro rekurzivni prochazeni stromu a preklad do syntaxe Texy!}
procedure TranslateTree(var ptr: PtrS; level : longint);
var temp,temp2 : string;
begin
if MAXT > 0 then
begin
if level >= MAXT then
begin
writeln('CHYBA. Prilis velke zanoreni znacek.');
writeln('Rozdelte dokument do nekolika casti.');
DisposeTree(ground);
halt;
end;
end;
{znaky, ktere je treba vypsat pred innerTextem}
if ptr^.isattr = false then
begin
if ptr^.name = 'b' then write(g,'**');
if ptr^.name = 'strong' then write(g,'**');
if ptr^.name = 'i' then write(g,'*');
if ptr^.name = 'em' then write(g,'*');
if ptr^.name = 'p' then write(g,chr(10),chr(13));
if ptr^.name = 'br' then write(g,chr(10),' ');
if ptr^.name = 'hr' then write(g,chr(10),'--------');
if ptr^.name = 'h1' then write(g,chr(10),'=======');
if ptr^.name = 'h2' then write(g,chr(10),'======');
if ptr^.name = 'h3' then write(g,chr(10),'=====');
if ptr^.name = 'h4' then write(g,chr(10),'====');
if ptr^.name = 'h5' then write(g,chr(10),'===');
if ptr^.name = 'h6' then write(g,chr(10),'==');
if ptr^.name = 'title' then write(g,chr(10),chr(60),'!-- ');
if ptr^.name = 'dd' then write(g,chr(10),' -');
if ptr^.name = 'dt' then write(g,chr(10));
if ptr^.name = 'tr' then writeln(g);
if ptr^.name = 'td' then write(g,'| ');
if ptr^.name = 'th' then write(g,'|* ');
if ptr^.name = 'div' then
begin
write(g,chr(10),'/---div');
temp := GetAttrVal(ptr,'class');{}
if temp <> '' then write(g,' .[',temp,']');
write(g,chr(10));
end;
if ptr^.name = 'a' then write(g,' "');
if ptr^.name = 'img' then
begin
write(g,'[* ');
write(g,GetAttrVal(ptr,'src'));{}
end;
if ptr^.name = 'sup' then write(g,'^');
if ptr^.name = 'sub' then write(g,'_');
if ptr^.name = 'ul' then ul := true;
if ptr^.name = 'ol' then ul := false;
if ptr^.name = 'li' then
begin
if ul = true then write(g,chr(10),'- ') else
begin
write(g,chr(10),cnt+1,') ');
inc(cnt);
end;
end;
end;
{innerText}
if ptr^.istext = true then write(g,ptr^.value);
{zavolani funkce na potomky}
if (ptr^.child <> NIL) then
begin
if ptr^.name <> 'script' then
begin
TranslateTree(ptr^.child,level+1);
end;
end;
{znaky, ktere je treba vypsat za innerTextem}
if ptr^.isattr = false then
begin
if ptr^.name = 'b' then write(g,'**');
if ptr^.name = 'strong' then write(g,'**');
if ptr^.name = 'i' then write(g,'*');
if ptr^.name = 'em' then write(g,'*');
if ptr^.name = 'title' then write(g,' --',chr(62),chr(10));
if ptr^.name = 'acronym' then write(g,'((',GetAttrVal(ptr,'title'),'))');
if ptr^.name = 'div' then write(g,chr(10),'\--- ',chr(10));
if ptr^.name = 'dt' then write(g,':');
if (ptr^.name = 'td') OR (ptr^.name = 'th') then
begin
write(g,' ');
end;
if ptr^.name = 'a' then
begin
write(g,'":');
write(g,GetAttrVal(ptr,'href'),' ');
end;
if ptr^.name = 'img' then
begin
temp := GetAttrVal(ptr,'width');{}
temp2 := GetAttrVal(ptr,'height');{}
if (temp <> '') AND (temp2 <> '') then
begin
write(g,' ',temp,'x',temp2);
end;
write(g,' .(',GetAttrVal(ptr,'alt'),')');
temp := GetAttrVal(ptr,'class');
if temp <> '' then write(g,'[',temp,']');{}
temp := GetAttrVal(ptr,'align');{}
if temp = '' then write(g,' *] ');
if temp = 'left' then write(g,' <] ');
if temp = 'right' then write(g,' >] ');
end;
if ptr^.name = 'ul' then ul := false;
if ptr^.name = 'ol' then begin ul := false; cnt := 0; end;
if ptr^.name = 'p' then
begin
temp := GetAttrVal(ptr,'align');
if temp = 'left' then write(g,' .<');
if temp = 'right' then write(g,' .>');
if temp = 'center' then write(g,' .<>');
end;
end;
{zavolani funkce na sourozence}
if ptr^.next <> NIL then TranslateTree(ptr^.next,level);
end;
{procedura pro testovaci vypis struktury stromu}
procedure FetchTreeItem(var ptr: PtrS; level : longint);
var i : longint;
begin
for i := level downto 2 do
write(' ');
if level > 0 then write(chr(192));
write(ptr^.name);{}
if ptr^.isattr = true then write(' *atrr (',ptr^.value,')');
if ptr^.istext = true then write(' * (',ptr^.value,')');
writeln;
if ptr^.child <> NIL then FetchTreeItem(ptr^.child,level+1); {zavolani funkce na potomky}
if ptr^.next <> NIL then FetchTreeItem(ptr^.next,level); {zavolani funkce na sourozence}
end;
{procedura, ktera prida znacku do zasobniku a zavola jeji pridani do stromu}
procedure AddToLifo(var name : string; var ptrI: PtrS);
var actual : PtrL;
temp,sourozenec,rodic : PtrS;
begin
new(actual); {nove misto v pameti}
writeln('pridavam ',name);{}
rodic := NIL;
sourozenec := NIL;
GetTreePos(rodic,sourozenec); {ziskani pozice ve stromu}
if eolf <> NIL then rodic := eolf^.ptr else rodic := NIL;
{writeln(name,rodic^.name,sourozenec^.name);{}
AddToTree(ptrI,name,false,false,'',rodic,sourozenec);{}
actual^.name := name; {nastaveni vlastnosti}
actual^.ptr := ptrI;
actual^.next := eolf;
eolf := actual; {novy konec zasobniku}
end;
{procedura pro ziskani hodnoty atributu, ktera posleze zavola pridani atributu do stromu}
procedure ParseAttrs(var buffer: string);
var c,name,val : string;
index : integer;
sourozenec, rodic, item : PtrS;
begin
c := '';
name := '';
val := '';
index := 1;
sourozenec := NIL;
rodic := NIL;
{pokud dostaneme na vstpu validni znaky pro atributy}
if (buffer <> '/') AND (buffer <> '') then
begin
CheckMem;
new(item); {rezervujeme misto v pameti}
while (c <> '=') do {pred znakem = hledame jmeno atributu}
begin
name := name + c;
c := copy(buffer,index,1);
inc(index);
if index >= length(buffer) then
begin
NotValid;
end;
end;
inc (index);
val := copy(buffer,index,length(buffer)-index+1); {vsechno dalsi je hodnota atributu}
GetTreePos(rodic,sourozenec); {dosazeni pozice ve stromu}
AddToTree(item,name,false,true,val,rodic,sourozenec); {pridani do stromu}
{writeln('pridavam atribut ',name);{}
end;
buffer := '';
end;
{procedura, ktera hleda ve znacce atributy a predava je k rozparsovani}
procedure ReadAttrs(var f : text; var c : char; var eot: boolean);
var buffer : string;
openattr : boolean;
index : integer;
backslash: boolean;
begin
buffer := '';
index := 0;
openattr := false;
backslash := false;
while c <> KZ do {dokud nenarazime na konec znacky, hledame atributy}
begin
{write(c);{}
if ((c <> ' ') AND (openattr = false)) OR ((c <> chr(UVOZ)) AND (openattr = true)) then
begin
if (c <> chr(10)) AND (c <> chr(13)) AND (c <> chr(9)) then
buffer := buffer + c;
{pokud je atribut delsi nez 255 znaku, je treba jej rozdelit do vice polozek}
{takove atributy vsak nejsou prekladany, nebot je syntaxe texy nezna}
if index = 254 then
begin
ParseAttrs(buffer);
buffer := '='+chr(UVOZ);
index := 1;
end;
if ((c = chr(UVOZ)) AND (backslash = false)) then openattr := NOT openattr;
inc(index);
end
else
begin
if (backslash = false)
then
begin
ParseAttrs(buffer);
openattr := false;
end
else buffer := buffer+c;
end;
if c = '\' then backslash := true else backslash := false;
read(f,c);
CheckEof;
end;
ZRead := true;
if buffer = '/' then eot := true;
if buffer <> '' then ParseAttrs(buffer);
end;
{procedura pro precteni innerTextu - textu mezi znackami}
procedure ReadInner(var f : text; var c : char);
var buffer,name : string;
index : integer;
rodic, sourozenec,item : PtrS;
begin
buffer := '';
name := 'innerText';
ZRead := false;
index := 0;
read(f,c);
{writeln('jsem zavolan na ',eolf^.ptr^.name,'|');{}
{write(c);{}
{osetreni proti nezakomentovanemu script se znakem <}
if (eolf^.ptr^.name = 'script') then
begin
while (copy(buffer,index-9,9) <> '</script>') do
begin
buffer := buffer+c;
if index = 254 then
begin
index := 9;
buffer := copy(buffer,245,9); {v bufferu mohu mit cast hledaneho vyrazu}
end;
read(f,c);
inc(index);
end;
exit;
end;
{osetreni proti nezakomentovanemu style se znakem <}
if (eolf^.ptr^.name = 'style') then
begin
while (copy(buffer,index-8,8) <> '</style>') do
begin
buffer := buffer+c;
if index = 254 then
begin
index := 8;
buffer := copy(buffer,246,8);
end;
read(f,c);
inc(index);
end;
exit;
end;
{dokud nenarazim na dalsi znacku, ctu hodnotu innerTextu}
while ((c <> ZPZ) AND (NOT(eof(f)))) do
begin
if (c <> chr(10)) AND (c <> chr(13)) AND (c <> chr(9))
then buffer := buffer+c;
{pokud je innerText delsi nez 255 znaku, je treba ho rozdelit do vice polozek}
if index = 254 then
begin
CheckMem;
new(item);
GetTreePos(rodic,sourozenec);
AddToTree(item,name,true,false,buffer,rodic,sourozenec); {pridani polozky do stromu}
index := -1;
buffer := '';
end;
read(f,c);
{write(ord(c),' ');{}
inc(index);
end;
ZRead := true;
if (buffer <> ' ') AND (buffer <> '') then
begin
{writeln(buffer,' napsal inner');{}
new(item);
GetTreePos(rodic,sourozenec);
{writeln('~',name,rodic^.name,sourozenec^.name);{}
AddToTree(item,name,true,false,buffer,rodic,sourozenec);{}
end;
end;
{procedura, ktera hleda nazvy znacek a vola ReadInner a ReadAttrs}
procedure ParseHTML(var f : text);
var cbn,eot,added : boolean;
name : string;
treeItem : PtrS;
begin
buffer := '';
added := false;
while not eof(f) do {dokud nejsem na konci souboru}
begin
cbn := true;
eot := false;
{boolean ZRead je nastaven procedurou ReadInner, ktera precte zacatecni znak znacky}
if ZRead = false then read(f,c) else ZRead := false; {nacti znak}
{hromadeni ziskane hodnoty}
buffer := buffer + c;
added := false;
if c = ZPZ then {pokud je to zacatek znacky}
begin
{if (buffer <> '') AND (buffer <> ZPZ) then writeln(buffer);{}
buffer := '';
read(f,c); {cti znak}
if c = '/' then {pokud je znacka ukoncujici, nastav eot na true}
begin
eot := true;
read(f,c);
end;
CheckMem;
new(treeItem);
while c <> KZ do {precti celou znacku}
begin
if (c = ' ') then {pokud narazis na mezeru}
begin
if cbn = true then {pokud je to prvni mezera ve znacce}
begin
{writeln(name);{}
name := buffer; {aktualni sbirka znaku je nazev znacky}
cbn := false; {zname jmeno}
{DOCTYPE a poznamky jsou pro dokument nepodstatne a vymykaji se beznemu formatu}
if (name <> '!DOCTYPE') AND (copy(name,1,3) <> '!--')
AND (copy(name,1,1) <> '?')
then
begin
AddToLifo(name,treeItem); {pridej do zasobniku}
ReadAttrs(f,c,eot); {precti atributy znacky}
end;
added := true;
end;
end;
buffer := buffer + c; {cti dal}
{boolean ZRead nastavuje procedura ReadAttrs, ktera jako posledni precte znak}
{ktery je zde potrebny a jinak by doslo k jeho zahozeni}
if ZRead = false then read(f,c) else ZRead := false;
{CheckEof;{}
end;
if cbn = true then name := buffer; {pokud ve znacce nebyla mezera, je cely jeji obsah jmeno}
{writeln(buffer,' ',name);{}
{pokud nemame znacku odebrat, pridame ji...}
if NOT eot then
begin
{... pokud nebyla pridana vyse v kodu (obsahovala mezeru)}
if NOT added then AddToLifo(name,treeItem);
end;
{pokud je znacka ukoncujici nebo neparova, odebereme ze zasobniku}
if ((eot) OR (copy(buffer,length(buffer),1) = '/')) then
RemFromLifo;{} {odeber ze zasobniku}
{writeln('volam inner');{}
ReadInner(f,c);{}
buffer := '';
end;
end;
end;
{incializace programu}
begin
ul := false;
cnt := 0;
ZRead := false;
writeln('HTML2Texy! prevadec');{}
writeln;{}
{ziskani cesty ke vstupnimu souboru}
writeln('Zadejte cestu ke vstupnimu HTML souboru:');{}
readln(Ssoubor);
{Ssoubor := 'C:\Pascal\error.htm';{}
OpenFile(f,Ssoubor);{}
{ziskani cesty k vystupnimu souboru}
writeln('Zadejte cestu k vystupnimu HTML souboru:');{}
readln(Vsoubor);
{Vsoubor := 'C:\abcd.tex';{}
OpenVFile(g,Vsoubor);{}
{Nektere stranky chybne pouzivaji misto uvozovek apostrofy}
writeln('Zadejte format uvozovek:');
writeln(' 34 pro znak ',chr(34));
writeln(' 39 pro znak ',chr(39));{}
readln(UVOZ);{}
{snilovani ukazatelu}
ground := NIL;
parent := NIL;
prev := NIL;
eolf := NIL;
{spusteni hlavni procedury pro vytvoreni stromu}
ParseHTML(f);{}
{uzavreni vstupniho souboru}
close(f);
{FetchTreeItem(ground,0);{}
{vypis stromu do Texy!}
TranslateTree(ground,0);{}
{Uvolneni pameti}
DisposeTree(ground);{}
{uzavreni vystupniho souboru}
close(g);
end.