HHM.PAS

< -->

Program Html_HREF_Maker;
{$D+,E-,N-,G+}
var
  f, ftmp, fr, fhtm : Text;
  S, S1 : String;
  fname, fresname : String;
  Title_On : Boolean;
const
  tmpName = 'hhm.tmp';
  head1 = '<html> <head> <title></title>';
  charset = '<meta http-equiv="Content-Type" content="text/html; charset=windows-1251">';
  StyBg   = '<STYLE type=text/css>';
  epi     = '.epigraph {TEXT-ALIGN: right; FONT-STYLE:ITALIC; FONT-SIZE: 8pt}';
  deflt   = '.default {FONT-SIZE: 12pt}';
  sm      = '.small {FONT-SIZE: 10pt}';
  smst    = '.smallest {FONT-SIZE: 8pt}';
  h1      = 'H1 {TEXT-ALIGN: center}';
  h2      = 'H2 {TEXT-ALIGN: center}';
  h3      = 'H3 {TEXT-ALIGN: left}';
  _P_     = 'P {TEXT-INDENT: 3em; TEXT-ALIGN: justify}';
  StyEnd  = '</STYLE>';
  meta_   = '<META http-equiv=Content-Type content="text/html"></head>';
  body    = '<body bgcolor=#614349 link=#6262FF vlink=#3CDBBF>';
  _div_   = '<div class=Section1><div align=center>';
  table   = '<table border=0 cellspacing=0 cellpadding=0 width=80%>';
  _tr_    = '<tr><td valign=top><br><font size=2 face="Courier" color=#00FF00>';

  Instr = '<a href="';
  Clstr = '">';
  ClTag = '</a>';
  _BR_  = '<br>';

  Cl1   = '</p><br><div align=right>Shyar 2003 / Shurik Okrugin - А.Округин<div align=justify><br>';
  Cl2   = '</td></tr></table></div></body></html>';

Function UpString(Sra : String) : String;
var
 i : Byte;
 Sr : String;
begin
  Sr := Sra;
  for i := 1 to Length(Sr) do
    Sr[i] := UpCase(Sr[i]);
  UpString := Sr
end;
Function GetTitle(S_ : String) : String;
var
  tmpS, Sr, S1_ : String;
  C  : Char;
  fl : Boolean;
  ps : Byte;
begin
  fl := false;
  Sr := '';
  Assign(fhtm, S_);
  {$I-}
  Reset(fhtm);
  {$I+}
  if IOResult = 0 then
  begin
  While not fl and not EOF(fhtm) do
   begin
    ReadLn(fhtm, tmpS);
    S1_ := UpString(tmpS);
    ps := Pos('<TITLE', S1_);
    if ps<>0 then
     begin
       fl := True;
       Delete(tmpS, 1, ps);
       Delete(tmpS, 1, Pos('>', tmpS));
       S1_ := UpString(tmpS);
       ps := Pos('</TITLE', S1_);
       if ps<>0 then
        Delete(tmpS, ps, Length(tmpS)-ps+1);
       Sr := tmpS;
     end;
    end;
  Close(fhtm);
  end;
  if Sr <> '' then
     GetTitle := Sr
  else
     GetTitle := S_;
end;
begin
  Title_On := False;
  if ParamCount<1 then
  begin
    WriteLn('====-===-=====-=============-===-=====-=========');
    WriteLn('HTML/HTM 2HREF Convertor');
    WriteLn('====-===-=====-=============-===-=====-=========');
    WriteLn(' Укажите имя txt/htm/html-файла, содержащего текстовые сноски в виде');
    WriteLn('<br>[сноска=только имя] или <BR>[сноска=только имя] в командной строке');
    WriteLn;
    WriteLn('Примечание: Тег <br> в htm/html-файле должен находиться в начале строки.');
    WriteLn('====-===-=====-=============-===-=====-=========');
    WriteLn('hhm [in] [<out>|</R>] </TITLE>');
    Halt($FFFF);
  end;
  fname := ParamStr(1);
  if ParamCount<2 then
  begin
    Write('Введите имя конечного файла: ');
    ReadLn(fresname);
  end else fresname := ParamStr(2);
  if UpString(fresname)='/R'{ewrite} then fresname := fname;
  if ParamCount>2 then Title_On := (UpString(ParamStr(3))='/TITLE') or (UpString(fresname)='/TITLE');
  Write('Обрабатывается файл '+fname+'>>'+fresname);
  if Title_On then WriteLn(' [Читать заголовки]') else WriteLn;
  Assign(f, fname);
  Assign(fr, fresname);
  Assign(ftmp, tmpName);
  Reset(f);
  Rewrite(ftmp);
  if UpString(Copy(fname, Pos('.', fname)+1, 3)) = 'HTM' then
   While not EOF(f) do
   begin
     ReadLn(f, S);
     if UpString(S[1]+S[2]+S[3]+S[4])='<BR>' then
     begin
       S1 := Copy(S, 1, 4);
       Delete(S, 1, 4);
       Write(ftmp, S1+Instr);
       Write(ftmp, S+Clstr);
       WriteLn(ftmp, S+ClTag);
     end else WriteLn(ftmp, S);
   end
  else
  begin
    WriteLn(ftmp, head1);
    WriteLn(ftmp, charset);
    WriteLn(ftmp, StyBg);
    WriteLn(ftmp, epi);
    WriteLn(ftmp, deflt);
    WriteLn(ftmp, sm);
    WriteLn(ftmp, smst);
    WriteLn(ftmp, h1);
    WriteLn(ftmp, h2);
    WriteLn(ftmp, h3);
    WriteLn(ftmp, _P_);
    WriteLn(ftmp, StyEnd);
    WriteLn(ftmp, meta_);
    WriteLn(ftmp, body);
    WriteLn(ftmp, _div_);
    WriteLn(ftmp, table);
    WriteLn(ftmp, _tr_);
    While not EOF(f) do
    begin
     ReadLn(f, S);
     Write(ftmp, _BR_);
     Write(ftmp, S1+Instr);
     Write(ftmp, S+Clstr);
     if Title_On then S := GetTitle(S);
     WriteLn(ftmp, S+ClTag);
    end;
    WriteLn(ftmp, Cl1);
    WriteLn(ftmp, Cl2);
  end;
  Close(ftmp);
  Close(f);
  {$I-}
  Rename(ftmp, fresname);
  {$I+}
  if IOResult<>0
  then
  begin
   {$I-}
     Erase(fr);
     Rename(ftmp, fresname);
   {$I+}
  end;
end.