轉檔工具 *.PAS TO *.HTM

bruce0829 · 发表于 2010-9-21 20:55:21

以前用 Delphi 寫過一個把 *.pas 轉成 *.htm 的工具程式, 花了兩天改成 Lazarus 版, 不過 Lazarus 版還有一些 bug, 主要就是 Lazarus 中 Utf8 跟 Ansi String 混用的問題造成, 有空再修正, 或是留給讀者當作業 ...

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
  ExtCtrls, Menus, Buttons, inifiles, LCLProc, LazSub2010;

type

  { TForm1 }

  TForm1 = class(TForm)
MainMenu1: TMainMenu;
MenuItem1: TMenuItem;
MenuItem2: TMenuItem;
MenuItem3: TMenuItem;
MenuItem4: TMenuItem;
MenuItem5: TMenuItem;
MenuItem6: TMenuItem;
OpenDialog1: TOpenDialog;
Panel1: TPanel;
Panel2: TPanel;
SpeedButton1: TSpeedButton;
SpeedButton2: TSpeedButton;
procedure FormActivate(Sender: TObject);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
  private
{ private declarations }
procedure _ReadRecivedData;
procedure _Process;
function  _TranPas(Str: string):string;
function  _TagEncode(ATagStr: string): string;
function  _GetFuncName(AStr: string): string;
  public
{ public declarations }
  end;

var
  Form1: TForm1;

implementation

{ TForm1 }

var MyIni: TIniFile;
MyPath: string;

TmpList: TStringList;
TmpList2: TStringList;
TranDataList: TStringList;
TranType: string;
flag_marked: boolean;
flag_marked_type: string;
implement_flag: boolean;
LastOpenDir:string;

procedure TForm1.FormCreate(Sender: TObject);
begin
  MyIni := TIniFile.Create(ChangeFileExt(Application.ExeName,'.ini'));
  MyPath := ExtractFilePath(Application.ExeName);
  MyPath:=AnsiToUtf8(MyPath); //改為 UT

  LastOpenDir:=MyIni.ReadString(&#39

arameter','LastOpenDir',MyPath);

  TmpList := TStringList.Create;
  TmpList.Clear;

  TmpList2 := TStringList.Create;
  TmpList2.Clear;

  TranDataList := TStringList.Create;
  TranDataList.Clear;

  _ReadRecivedData;

end;

procedure TForm1.FormActivate(Sender: TObject);
begin

end;

procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
  TmpList.Free;
  TmpList2.Free;
  TranDataList.Free;

  MyIni.WriteString(&#39

arameter','LastOpenDir',LastOpenDir);
  MyIni.Free;

end;

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  if (OpenDialog1.Execute) then
  begin
LastOpenDir:=AnsiToUtf8(ExtractFilePath(OpenDialog1.FileName));
TmpList.LoadFromFile(Utf8ToAnsi(OpenDialog1.FileName));

Panel2.Caption:=&#39

rocess...';
Refresh;
_Process;
Panel2.Caption:='';
 end;
end;

procedure TForm1._ReadRecivedData;
begin
 TranDataList.Clear();
 TranDataList.Add('and=and');
 TranDataList.Add('as=as');
 TranDataList.Add('begin=begin');
 TranDataList.Add('case=case');
 TranDataList.Add('class=class');
 TranDataList.Add('constructor=constructor');
 TranDataList.Add('destructor=destructor');
 TranDataList.Add('do=do');
 TranDataList.Add('downto=downto');
 TranDataList.Add('else=else');
 TranDataList.Add('end=end');
 TranDataList.Add('except=except');
 TranDataList.Add('finally=finally');
 TranDataList.Add('for=for');
 TranDataList.Add('function=function');
 TranDataList.Add('if=if');
 TranDataList.Add('implementation=implementation');
 TranDataList.Add('in=in');
 TranDataList.Add('inherited=inherited');
 TranDataList.Add('interface=interface');
 TranDataList.Add('is=is');
 TranDataList.Add('mod=mod');
 TranDataList.Add('nil=nil');
 TranDataList.Add('not=not');
 TranDataList.Add('of=of');
 TranDataList.Add('or=or');
 TranDataList.Add('overload=overload');
 TranDataList.Add('override=override');
 TranDataList.Add('private=private');
 TranDataList.Add('procedure=procedure');
 TranDataList.Add('property=property');
 TranDataList.Add('protected=protected');
 TranDataList.Add('public=public');
 TranDataList.Add('published=published');
 TranDataList.Add('repeat=repeat');
 TranDataList.Add('resourcestring=resourcestring');
 TranDataList.Add('string=string');
 TranDataList.Add('then=then');
 TranDataList.Add('to=to');
 TranDataList.Add('try=try');
 TranDataList.Add('type=type');
 TranDataList.Add('unit=unit');
 TranDataList.Add('until=until');
 TranDataList.Add('uses=uses');
 TranDataList.Add('var=var');
 TranDataList.Add('while=while');
 //TranDataList.Add('<=<');
 //TranDataList.Add('>=>');

end;

procedure TForm1._Process;
var i:integer;
www: string;
pre_str:string;
flo_str:string;
lnk_str:string;
begin
 flag_marked:=false;
 implement_flag:=false; //2003/12/17

 TmpList2.Clear();
 TmpList2.Add('<html>');
 TmpList2.Add('<head>');
 TmpList2.Add('<meta http-equiv="Content-Type" content="text/html; charset=utf-8">');
 TmpList2.Add('<title>'+ChangeFileExt(ExtractFileName(OpenDialog1.FileName),'.html')+'</title>');
 TmpList2.Add('</head>');
 TmpList2.Add('');
 TmpList2.Add('<body text="#000000" bgcolor="#FFFFFF" link="#FF00FF" vlink="#FF00FF" alink="#FF00FF">'); //#0000FF(藍色), #FF00FF(桃紅), #008000(綠色) //2003
 TmpList2.Add('<pre><code>');
 TmpList2.Add('');

 for i:=0 to TmpList.Count-1 do
 begin

 if (_Left(TmpList.Strings,14)='implementation') then
 implement_flag:=true;

 //if (PureOutput1.Checked=false) and (implement_flag) and (flag_marked_type<>'{') and ((_Left(TmpList.Strings,8)='function') or (_Left(TmpList.Strings,9)='procedure') or (_Left(TmpList.Strings,11)='constructor') or (_Left(TmpList.Strings,10)='destructor') ) then
 // pre_str:='<a name="'+_GetFuncName(TmpList.Strings)+'">Content</a> , (<a href="#0">Go Header</a>) '+
 // '<table border="1" width="100%" bgcolor="#F7F7FF"><tr><td><pre>' //#F7F7FF(淡藍), #E1F5FF(藍), #EFEFEF(灰), #FFFFD7(黃), #E8FFE
 //else
 pre_str:='';

 //if (PureOutput1.Checked=false) and (implement_flag) and (flag_marked_type<>'{') and (_Left(TmpList.Strings,4)='end;') then
 // flo_str:='</pre></td></tr></table>　
 //else
 flo_str:='';

 //if (PureOutput1.Checked=false) and (_Left(TmpList.Strings,9)='interface') then
 // begin
 // pre_str:='<a name="#0">';
 // flo_str:='</a">';
 // end;

 //if (PureOutput1.Checked=false) and (implement_flag=false) and (flag_marked_type<>'{') and (_GetFuncName(TmpList.Strings)<>'') then
 // lnk_str:=' (<a href="#'+_GetFuncName(TmpList.Strings)+'">Content</a>)'
 //else
 lnk_str:='';

 TmpList2.Add(pre_str+_TranPas(TmpList.Strings)+flo_str+lnk_str);

 end;

 TmpList2.Add('');
 TmpList2.Add('</code></pre>');
 TmpList2.Add('</body>');
 TmpList2.Add('</html>');

 TmpList2.SaveToFile(Utf8ToAnsi(ChangeFileExt(OpenDialog1.FileName,'.htm')));

 www:=ChangeFileExt(OpenDialog1.FileName,'.htm');
 //ShellExecute(0, nil, pchar(www), nil, nil, sw_showdefault);
 _ShellExecute(www);

end;

function TForm1._TranPas(Str: string):string;
var r,tmp,tran_str,test,comp_str,Seg: string;
i,p,index1,index2: integer;
c,s:integer; //for bug_fix

begin

 s:=1; //for bug_fix

 if (flag_marked_type='//') or (flag_marked_type='''') then
 begin
 flag_marked:=false;
 flag_marked_type:='';
 end;

 if (Trim(Str)='') then
 begin
 result:='';
 exit;
 end;

 r:=_LeftSpace(Str); //保留字串左邊所�
 tmp:=Trim(Str);

 Seg:='';

 while tmp<>'' do
 begin

 if (flag_marked) then //進入被 marked 的區塊 , 都�
 begin
 if (flag_marked_type='//') then //後面通通��
 begin
 r:=r+_TagEncode(tmp)+'';
 tmp:='';
 continue;
 end;

 if (flag_marked_type='(*') then
 begin
 p:=_Pos('*)',tmp);
 if (p=0) then
 begin
 r:=r+_TagEncode(tmp);
 tmp:='';
 continue;
 end
 else
 begin
 r:=r+_TagEncode(_Left(tmp,p-1))+'*)'; //較特殊
 tmp:=_CutLeft(tmp,p+1);
 flag_marked:=false;
 flag_marked_type:=''; //2003/12/17
 continue;
 end;
 end;

 if (flag_marked_type='{') then
 begin
 p:=Pos('}',tmp);
 if (p=0) then
 begin
 r:=r+_TagEncode(tmp);
 tmp:='';
 continue;
 end
 else
 begin
 r:=r+_TagEncode(_Left(tmp,p-1))+'}'; //較特殊
 tmp:=_CutLeft(tmp,p); //由 p+1 改為 p , 2003/12
 flag_marked:=false;
 flag_marked_type:=''; //2003/12/17
 continue;
 end;
 end;

 if (flag_marked_type='''') then
 begin
 p:=Pos('''',tmp);
 if (p=0) then
 begin
 r:=r+_TagEncode(tmp);
 tmp:='';
 continue;
 end
 else
 begin
 r:=r+_TagEncode(_Left(tmp,p-1))+''''; //較特殊
 tmp:=_CutLeft(tmp,p);
 flag_marked:=false;
 flag_marked_type:=''; //2003/12/17
 continue;
 end;
 end;

 end;

 {
 //片語��
 comp_str="TObject *Sender";
 if (_Left(tmp,comp_str.Length())=comp_str) then
 begin
 Result=Result+"Sender: TObject";
 tmp=_CutLeft(tmp,comp_str.Length());
 continue;
 end;

 comp_str="void __fastcall";
 if (_Left(tmp,comp_str.Length())==comp_str)
 begin
 Result=Result+"procedure";
 tmp=_CutLeft(tmp,comp_str.Length());
 continue;
 end;

 comp_str="int __fastcall";
 if (_Left(tmp,comp_str.Length())==comp_str)
 begin
 Result=Result+"function(:int)";
 tmp=_CutLeft(tmp,comp_str.Length());
 continue;
 end;

 comp_str="String __fastcall";
 if (_Left(tmp,comp_str.Length())==comp_str)
 begin
 Result=Result+"function(:String)";
 tmp=_CutLeft(tmp,comp_str.Length());
 continue;
 end;
 }

 //預先��
 if (_Left(tmp,2)='//') then
 begin
 r:=r+'//'; //#0000FF(藍), #000080(深藍), #008000(綠) 2003/1
 tmp:=_CutLeft(tmp,2);
 if tmp='' then r:=r+''; //2003/12/09
 flag_marked:=true; //進入被 marked 的
 flag_marked_type:='//';
 continue;
 end;

 if (_Left(tmp,2)='(*') then
 begin
 r:=r+'(*'; //#0000FF(藍), #000080(深藍), #008000(綠) 2003/1
 tmp:=_CutLeft(tmp,2);
 if tmp='' then r:=r+''; //2003/12/09
 flag_marked:=true; //進入被 marked 的
 flag_marked_type:='(*';
 continue;
 end;

 if (_Left(tmp,1)='{') then
 begin
 r:=r+'{'; //#0000FF(藍), #000080(深藍), #008000(綠) 2003/1
 tmp:=_CutLeft(tmp,1);
 flag_marked:=true; //進入被 marked 的
 flag_marked_type:='{';
 continue;
 end;

 if (_Left(tmp,1)='''') then
 begin
 r:=r+'''';
 tmp:=_CutLeft(tmp,1);
 flag_marked:=true; //進入被 marked 的
 flag_marked_type:='''';
 continue;
 end;

 if (_Left(tmp,1)=' ') then
 begin
 r:=r+' ';
 s:=1; //for bug_fix
 tmp:=_CutLeft(tmp,1);
 continue;
 end;

 {在 <pre> tag 中就不需要轉換了,
 if (_Left(tmp,1)='<') then
 begin
 r:=r+'<';
 tmp:=_CutLeft(tmp,1);
 continue;
 end;

 if (_Left(tmp,1)='>') then
 begin
 r:=r+'>';
 tmp:=_CutLeft(tmp,1);
 continue;
 end;
 }

 //擷取適合的字
 index1:=1;
 c:=0; //for bug_fix
 for i:=1 to Length(tmp) do
 begin
 index2:=i;

 //因為經過預先比對過濾過 , 此處找到的應該
 //if (tmp in ['''',' ',';',':','/','{','(',',',';','=','+','-','*','<','>','.',')']) then
 if (tmp='''') or (tmp=' ') or (tmp=';') or (tmp=':') or (tmp='/') or (tmp='{') or (tmp='(')
 or (tmp=',') or (tmp=';') or (tmp='=') or (tmp='+') or (tmp='-') or (tmp='*') or (tmp='<')
 or (tmp='>') or (tmp='.') or (tmp=')')
 then
 begin
 c:=1; //for bug_fix
 break;
 end;
 end;

 if (index2=Length(tmp)) and (c=0) then index2:=index2+1;//用來騙字典比對程序 //2

 //字典��
 {
 for i:=index2 downto 1 do
 begin
 tran_str:=TranDataList.Values[_Left(tmp,i)];
 if (tran_str<>'') then
 begin
 r:=r+tran_str;
 tmp:=_CutLeft(tmp,i);
 break;
 end
 end;
 }

 tran_str:=TranDataList.Values[_Left(tmp,index2-1)];
 //if (tran_str<>'') then
 if (tran_str<>'') and (s=1) then
 begin
 r:=r+tran_str;
 tmp:=_CutLeft(tmp,index2-1);
 continue;
 end;

 s:=0; //for bug_fix

 //剩下沒人要的,只有一個一個��
 r:=r+_Left(tmp,1);

 //空白已在前面被攔掉,所以此��
 if (tmp[1] in [' ',';',',',':','=']) then
 begin
 s:=1;
 end
 else
 begin
 s:=0;
 end;

 tmp:=_CutLeft(tmp,1);

 end;

 result:=r;
end;

function TForm1._TagEncode(ATagStr: string): string;
var i:integer;
r:string;
begin
 r:='';
 for i:=1 to _Length(ATagStr) do
 begin
 if ATagStr='<' then
 begin
 r:=r+'<';
 continue;
 end;
 if ATagStr='>' then
 begin
 r:=r+'>';
 continue;
 end;
 r:=r+ATagStr;
 end;
 result:=r;
end;

function TForm1._GetFuncName(AStr: string): string;
var n,i:integer;
tmp,r:string;
begin
 r:='';
 tmp:=Trim(AStr);
 if (_Copy(LowerCase(tmp),1,8) <> 'function') and
 (_Copy(LowerCase(tmp),1,9) <> 'procedure') and
 (_Copy(LowerCase(tmp),1,11) <> 'constructor') and
 (_Copy(LowerCase(tmp),1,10) <> 'destructor') then
 begin
 result:=r;
 exit;
 end;

 if (_Copy(LowerCase(tmp),1,8) = 'function') then n:=9;
 if (_Copy(LowerCase(tmp),1,9) = 'procedure') then n:=10;
 if (_Copy(LowerCase(tmp),1,11) = 'constructor') then n:=12;
 if (_Copy(LowerCase(tmp),1,10) = 'destructor') then n:=11;

 for i:=n to _Length(tmp) do
 begin
 if (tmp='(') or (tmp=';') or ((r<>'') and (tmp=' ')) then break;
 if (tmp='.') then
 begin
 r:='';
 continue;
 end;
 r:=r+Trim(String(tmp));
 end;

 result:=r;
end;

initialization
 {$I Unit1.lrs}

end.

--------------------------------------------------------------------------------------------------------------------------------------

■ 後註
1. 程式下載 (含 source code) http://digitraveler.homelinux.com/down_load/LazPasToHtm.zip

xiaohhys · 发表于 2010-10-25 17:54:09

谢谢，可是楼主提供的好几个例子我都下载不下来呀。

bruce0829 · 发表于 2010-10-25 21:02:15

今天偶放文檔的 web server 好像掛掉了(放在公司)
明天到公司看看 ...

xusonglie · 发表于 2010-11-24 20:39:17

谢谢！学习中！想用它写个中间层

		自动登录	找回密码
密码			立即注册（注册审核可向QQ群索取）

轉檔工具 .PAS TO .HTM

评分

回楼主(bruce0829) 的帖子

轉檔工具 *.PAS TO *.HTM

评分

回 楼主(bruce0829) 的帖子

轉檔工具 .PAS TO .HTM

回楼主(bruce0829) 的帖子