liujianjun/tslediter
3
0
Fork 1
Code Issues Pull Requests Projects Releases Wiki Activity

设计器

Browse Source 
拆分代码
This commit is contained in:
JianjunLiu
2022-05-21 07:02:54 +08:00
parent df9c3b8dbc
commit 8cd45006e2
24 changed files with 9329 additions and 9780 deletions
Download Patch File Download Diff File Expand all files Collapse all files
designer/examples/action/e_action.tpj
+2 -2
View File
@@ -22,6 +22,6 @@ array(
),
"mainform":"e_actionmain",
"entryscript":"e_action",
"time":"2022-04-08 14:37:00",
"commandline":"\"$(TSL_EXE)\" \"$(FULL_CURRENT_PATH)\" -libpath \"$(SEARCH_PATH)\\;\""
"time":"2022-04-24 17:32:45",
"commandline":"\"$(TSL_EXE)\" \"$(FULL_CURRENT_PATH)\" -libpath \"$(SEARCH_PATH)\""
)
designer/examples/action/e_actionmain.tsf
+12
View File
@@ -14,6 +14,18 @@ type E_Actionmain=class(tdcreateform)
begin
inherited;
end
function action1_onexecute(o;e);
begin
{**
@explan(说明) onexecute消息回调 %
@param(e)(tuievent) 消息对象 %
@param(o)(tcomponent) 组件 %
**}
echo "\r\naction do ";
end
function btn5_clk(o;e);virtual; //修改caption
begin
action1.caption := datetimetostr(now());
designer/examples/action/resource.tfm/e_actionmain.tfm
+5
View File
@@ -18,9 +18,12 @@ object e_actionmain1:e_actionmain
object actionlist1:tactionlist
left=225
top=189
height=30
width=30
object action1:taction
caption="绑定action的控件"
enabled=true
onexecute=action1_onexecute
end
end
object btn2:tbtn
@@ -59,6 +62,8 @@ object e_actionmain1:e_actionmain
object popupmenu1:tpopupmenu
left=162
top=329
height=30
width=30
caption="popupmenu1"
object menu1:tmenu
action=action1
designer/gettslediterstart.tsf
+6 -1
View File
@@ -6,8 +6,13 @@ ops := "";
GLobal G_OpenHostory;
G_OpenHostory := true; //默认打开历史进程
hasinstance := true; //单独进程
isdebug := false;
for i:= 0 to sysparamcount() do
begin
if ("-DEBUGSERVER" = sysparamstr(i)) then
begin
isdebug := true;
end else
if (i<sysparamcount())and ("-f" = sysparamstr(i) ) then //打开文件
begin
ops := sysparamstr(i+1) ;
@@ -63,7 +68,7 @@ begin
end
end
end
if hasinstance then //实现一个编辑器进程
if not(isdebug) and hasinstance then //实现一个编辑器进程
begin
//判断
h := FindWindowA("tslediter_a_a_1",nil);
designer/gettslvcldesignerstart.tsf
+10 -1
View File
@@ -3,8 +3,17 @@
}
uses tslvcl,tslvclDesigner;
deletefuncacheini();
isdebug := false;
for i:= 0 to sysparamcount() do
begin
if ("-DEBUGSERVER" = sysparamstr(i)) then
begin
isdebug := true;
break;
end
end
h := FindWindowA("tsluidesigner_a_a_1",nil); //查找唯一窗口
if h then
if not(isdebug) and h then
begin
return PostMessageA(h,0x400,303,10);
end
designer/tslvcldesigner.tsf
+2784 -4198
View File
File diff suppressed because it is too large Load Diff
designer/udesignerproject.tsf
+28 -833
View File
@@ -1,6 +1,10 @@
Unit UDesignerProject;
interface
uses utslvclauxiliary,tslvcl,utslmemo,UTslSynMemo,UVCPropertyTypesPersistence,tslvclDesigner,UtslCodeEditor;
{**
@param(说明) 设计器工程相关工具,包括历史工程,工程目录管理,代码编辑器 %%
@date(20220518)
**}
uses utslvclauxiliary,tslvcl,utslmemo,UTslSynMemo,UVCPropertyTypesPersistence,UtslCodeEditor,utslvclsyntaxparser;
function SetWndPostWithMouse(wnd,lft);
type TProjectManagerForm = class(TVCForm) //工程管理 TCustomControl
function Create(AOwner);override;
@@ -361,7 +365,7 @@ type TProjectView = class(TVCForm) //
end
//FTslEditer.Parent := AOwner;
FTmfParser := new TTmfParser();
FTslParser := new tslparser();
FTslParser := new ttslscripparser();
FTreeTool := new TMyToolBar(self);
FTreeTool.parent := self;
imgs := New TControlImageList(self);
@@ -643,21 +647,29 @@ type TProjectView = class(TVCForm) //
end
function AddAFiled(n); //添加成员
begin
if ifstring(n)and FCurrentOpend and(FCurrentOpend["type"]in array("form","panel"))then
if ifstring(n)and FCurrentOpend and(FCurrentOpend["type"] in array("form","panel"))then
begin
FTslEditer.Addfiled(FOpendFormTSFfilename,n);
end
end
function adduses(lbs); //添加成员
begin
if (lbs) and FCurrentOpend and(FCurrentOpend["type"] in array("form","panel"))then
begin
FTslEditer.adduses(FOpendFormTSFfilename,lbs);
end
end
function DeleteAFiled(n,nn); //删除成员
begin
if ifstring(n)and FCurrentOpend and(FCurrentOpend["type"]in array("form","panel"))then
if ifstring(n) and FCurrentOpend and (FCurrentOpend["type"]in array("form","panel"))then
begin
FTslEditer.Delfiled(FOpendFormTSFfilename,n,nn);
end
end
function AddAFunction(ff); //添加函数
begin
if ifarray(ff)and ifstring(ff["name"])and FCurrentOpend and(FCurrentOpend["type"] in array("form","panel"))then
if ifarray(ff) and ifstring(ff["name"])and FCurrentOpend and(FCurrentOpend["type"] in array("form","panel"))then
begin
s := createtslfunction(ff);
r := FTslEditer.AddFunction(FOpendFormTSFfilename,ff["name"],s);
@@ -665,7 +677,7 @@ type TProjectView = class(TVCForm) //
return r;
end
end
function GoToAFunction(n);
function GoToAFunction(n); //跳转到函数
begin
r := FTslEditer.GoToFunction(FOpendFormTSFfilename,n);
ShowEditor();
@@ -1241,7 +1253,7 @@ type TProjectView = class(TVCForm) //
//FTslEditer.CloseEditor();
FDesigner.caption := "TVCL界面设计器 "+FprojName;
FDesigner.UnLoadTreeNode();
class(TDComponent).TemporaryNotName := array();
//class(TDComponent).TemporaryNotName := array();
FCurrentOpend := nil;
FOpendFormTSFfilename := nil;
FOpendScriptFileName := nil;
@@ -1577,6 +1589,14 @@ BD141CA912494F502D48D224F45050274A21E03806FF2C7CA7516022D7D000000
it.AddFiled(n);
end
end
function Adduses(fn,lbs);
begin
it := OpenAndGotoFileByName(fn);
if it then
begin
it.adduses(lbs);
end
end
function Delfiled(n,fld,nn);//删除成员变量
begin
it := OpenAndGotoFileByName(n);
@@ -1605,718 +1625,6 @@ BD141CA912494F502D48D224F45050274A21E03806FF2C7CA7516022D7D000000
end
end
type tsltoken = class(tslparserbase)
{**
@explan(说明) tsl语言分词 %%
**}
private
FTSLstr;
FTokens;
function SetTslStr(v);
begin
if v <> FTSLstr then
begin
FTSLstr := v;
FTokens := nil;
end
end
public
function create();
begin
inherited;
end
function tokens();
begin
if FTokens then return FTokens;
if not ifstring(FTSLstr)then return array();
str := binary(FTSLstr);
pos :=-1;
len := length(str);
FTokens := array();
nk := 0;
vs := "";
hh := 0;
while true do
begin
pos++;
if pos >= len then break;
v := str[pos];
if v="%" then
begin
kk := 1;
v1 := str[pos+kk];
if v1="%" then
begin
pls := "%%";
while true do
begin
kk++;
if pos+kk >= len then break;
if str[pos+kk]in array(" ","\t","\r","\n")then
begin
if str[pos+kk]="\n" then hh++;
break;
end else
pls += str[pos+kk];
end
pos += kk;
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
vs := findstringv2(str,pls,len,pos,hh);
//vs := findstringv(str,pls,len,pos,nil,hh); //str,f,len,pos,zy,hh
setdata(FTokens,nk,vs,"字符串",pos,hh);
vf := 0;
continue;
end
end
if v='"' then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
vs := findstringv(str,'"',len,pos,1,hh);
setdata(FTokens,nk,vs,"字符串",pos,hh);
vf := 0;
end else
if v="'" then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
vs := findstringv(str,"'",len,pos,1,hh);
setdata(FTokens,nk,vs,"字符串",pos,hh);
vf := 0;
end else
if v='{' then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
vs := findstringv(str,'}',len,pos,nil,hh);
lvs := length(vs);
flvs := true;
if lvs>5 then
begin
if vs[1:2]="**" and(vs[3]in array(" ","\t","\r","\n"))and vs[lvs-1:lvs]="**" and(vs[lvs-2]in array(" ","\t","\r","\n"))then
begin
flvs := false;
vv := trim(vs[3:lvs-2]);
if vs[3]="\n" then hh++;
setdata(FTokens,nk,vv,"说明",pos,hh);
if vs[lvs-2]="\n" then hh++;
vs := "";
end
end
if flvs then setdata(FTokens,nk,vs,"说明0",pos,hh);
vf := 0;
end else
if v="#" then
begin
pos++;
vi := str[pos];
if vi="!" then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
vs := findstringv(str,'\n',len,pos,nil,hh);
setdata(FTokens,nk,vs,"说明2",pos,hh);
vf := 0;
end else
begin
pos--;
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
setdata(FTokens,nk,v,"分割",pos,hh);
vf := 0;
end
end else
if v="/" then
begin
pos++;
vi := str[pos];
if vi="/" then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
vs := findstringv(str,'\n',len,pos,nil,hh);
setdata(FTokens,nk,vs,"说明2",pos,hh);
vf := 0;
end else
begin
vs += v;
pos--;
end
end else
if v='(' then
begin
pos++;
vi := str[pos];
if vi="*" then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
pos++;
while pos <= len do
begin
vi := str[pos];
if vi="\n" then hh++;
if pos<len and vi="*" and str[pos+1]=")" then
begin
pos += 1;
break;
end else
vs += vi;
pos++;
end
//*******************************************************
lvs := length(vs);
flvs := true;
if lvs>3 then
begin
if vs[1]="*" and(vs[2]in array(" ","\t","\r","\n"))and vs[lvs]="*" and(vs[lvs-1]in array(" ","\t","\r","\n"))then
begin
flvs := false;
vv := trim(vs[2:lvs-1]);
if vs[2]="\n" then hh++;
setdata(FTokens,nk,vv,"说明",pos,hh);
if vs[lvs-1]="\n" then hh++;
vs := "";
end
end
if flvs then setdata(FTokens,nk,vs,"说明1",pos,hh);
//*********************************************************
vf := 0;
end else
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos-1,hh);
setdata(FTokens,nk,v,"前括号",pos,hh);
pos--;
continue;
end
end else
if v=")" then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
setdata(FTokens,nk,v,"后括号",pos,hh);
end else
if v="\t" then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
if vf then continue;
vf := 1;
setdata(FTokens,nk,v,"空格",pos,hh);
end else
if v=" " then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
if vf then continue;
vf := 1;
setdata(FTokens,nk,v,"空格",pos,hh);
end else
if v='\n' then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
hh++;
if vf then continue;
vf := 1;
setdata(FTokens,nk,v,"换行",pos,hh);
end else
if v='\r' then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
if vf then continue;
vf := 1;
setdata(FTokens,nk,v,"回车",pos,hh);
end else
if v in array(",",";",".","]","[",":","=","!")then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
setdata(FTokens,nk,v,"分割",pos,hh);
end else
begin
vs += v;
end
end
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
return FTokens;
end
property tslstr read FTSLstr write SetTSLstr;
end
type tslparser = class(tslparserbase)
{**
@explan(说明) 解析tsl 类 %%
**}
private
FTokener;
FTokens;
FCurrentPos;
FTokenLen;
FScriptPath;
function SetScriptPath(v);
begin
size := filesize("",v); //获取文件大小
readFile(rwraw(),"",v,0,size,data);
SetScript(data);
end
function SetScript(v);
begin
if FTokener.tslstr <> v then
begin
FTokener.tslstr := v;
FTokens := FTokener.tokens();
if FTokens then FTokenLen := length(FTokens)-1;
FTokenLen :=-1;
end
end
function tkopok();
begin
return FCurrentPos>0 and FCurrentPos<FTokenLen;
end
function getTokenPos(ps);
begin
return FTokens[ps,2]+1;
end
function getTokenRow(ps);
begin
return FTokens[ps,3];
end
function ctoken(tk,tp,pos,r);
begin
if not FTokens then return 0;
r := tkopok(pos);
tk := FTokens[FCurrentPos,0];
tp := FTokens[FCurrentPos,1];
pos := FTokens[FCurrentPos,2]+1;
r := FTokens[FCurrentPos,3];
FCurrentPos++;
return tk;
end
function bpos(n);
begin
if n >= 0 then FCurrentPos -= n;
else FCurrentPos--;
end
function btoken(tk,tp,pos,n);
begin
bpos(n);
r := ctoken(tk,tp,pos);
return r;
end
function GetScript();
begin
return FTokener.tslstr;
end
public
function create();
begin
inherited;
FTokener := new tsltoken();
end
//type beg end name
function GetClassAbstract();
begin
{**
@explan(说明) 获得class 的基本信息 %%
@return(array) 包括"name","inherited","uses" 等信息 %%
**}
if not Tokens then array();
FCurrentPos := 0;
while true do
begin
ctoken(tk,tp,pos);
if ifnil(tk)then return array();
if tk="type" and tp <> TT_STR then
begin
r := array();
ctoken(tk,tp,pos);
if tp=TT_IDE then
begin
r["name"]:= tk;
ctoken(tk,tp,pos);
if tk <> "=" then return 0;
ctoken(tk,tp,pos);
if tk <> "class" then return 0;
ctoken(tk,tp,pos);
inh := array();
if tk="(" then
begin
while true do
begin
ctoken(tk,tp,pos);
if ifnil(tk)then break;
if tk=")" then break;
if tk="," then continue;
else inh[length(inh)]:= tk;
end
r["inherited"]:= inh;
end
while true do
begin
ctoken(tk,tp,pos);
if ifnil(tk)then break;
if tk="uses" and tp <> TT_STR then
begin
ru := array();
while true do
begin
ctoken(tk,tp,pos);
if ifnil(tk)then break;
if tk="," then continue;
if tk=";" then break;
ru[length(ru)]:= tk;
end
r["uses"]:= ru;
break;
end
end
return r;
end
end else
return array();
end
end
function GetClassInfo(fi);
begin
{**
@explan(说明) 获得class的详细信息 %%
@param(fi)(bool) 是否获得class成员的位置信息 %%
**}
r := array();
if not Tokens then return r;
FCurrentPos := 0;
while true do
begin
ctoken(tk,tp,pos);
if ifnil(tk)then exit;
if tk="type" and tp <> TT_STR then break;
end
if tk="type" and tp <> TT_STR then
begin
r["beg"]:= pos;
tr := parserclass(fi);
if ifarray(tr)then r union=tr;
r["end"]:= CurrentPos;
return r;
end
return r;
end
function parserclass(fi);
begin
{**
@explan(说明) 获得class详细 %%
@param(fi)(bool) 是否获得函数的信息 %%
**}
ctoken(tk,tp,pos);
r := array();
if tp=TT_IDE then
begin
r["name"]:= tk;
ctoken(tk,tp,pos);
if tk <> "=" then raise "解析错误";
ctoken(tk,tp,pos);
if tk <> "class" then raise "解析错误";
ctoken(tk,tp,pos);
if tk="(" then
begin
pa := array();
while true do
begin
ctoken(tk,tp,pos);
if tk=")" then break;
if tk <> "," then pa[length(pa)]:= tk;
end
r["inherited"]:= pa;
end else
begin
bpos();
end
props := array();
funcs := array();
funcsinfo := array();
filed := array();
priv := "public";
while true do
begin
ctoken(tk,tp,pos,row);
if ifnil(tk)then break;
if tk in array("private","public","protected")then
begin
priv := tk;
continue;
end
if tk="uses" and tp=TT_IDE then
begin
usb := pos;
pu := array();
while true do
begin
ctoken(tk,tp,pos);
if tp=TT_IDE then
begin
pu[length(pu)]:= tk;
end else
if tk=";" then break;
end
r["uses"]:= array("row":row,"beg":usb,"end":pos,"info":pu);
end else
if tk="static" and tp=TT_IDE then
begin
if not r["filed"]then r["filed"]:= array();
sf := parserfiled();
for i := 0 to length(sf)-1 do
begin
sf[i]["static"]:= true;
sf[i]["staticpos"]:= pos;
sf[i]["priv"]:= priv;
end
filed union=sf;
end else
if tk="function" or tk="procedure" then
begin
bpos();
bfpos := CurrentPos;
lenf := length(funcsinfo);
tfn := parserfunction();
if priv="public" then funcs[length(funcs)]:= tfn;
if fi then
begin
funcsinfo[lenf]["name"]:= tfn;
funcsinfo[lenf]["startpos"]:= getTokenPos(bfpos);
funcsinfo[lenf]["endpos"]:= getTokenPos(self.CurrentPos)-1;
funcsinfo[lenf]["row"]:= row;
end
end else
if tk="property" then
begin
props[length(props)]:= parserproperty();
end else
if tk="class" and tp=TT_IDE then
begin
if priv="public" then funcs[length(funcs)]:= parserfunction();
end else
if tk=";" then continue;
else if tk="end" and tp=TT_IDE then break;
else if tk="type" then
begin
cr := array();
cr["type"]:= "class";
cr["beg"]:= pos;
cr["info"]:= parserclass(fi);
cr["end"]:= CurrentPos;
end else
if tk="type" then break;
else
begin
bpos();
filed union=parserfiled(priv);
end
end
end
r["prop"]:= props;
r["funcs"]:= funcs;
r["filed"]:= filed;
r["funcsinfo"]:= funcsinfo;
prn := array();
if filed then prn := filed[:,"name"];
r["members"]:=(prn union2 funcs)union2 props;
return r;
end
function parsertype();
begin
ctoken(tk,tp,pos);
tarray := "";
if tk="array" then
begin
tarray := "array ";
ctoken(tk,tp,pos);
if tk=";" then
begin
return tarray;
end else
if tk="of" then
begin
tarray += "of ";
ctoken(tk,tp,pos);
end
end
return tarray+tk;
end
function parserfiled(priv);
begin
rcount := 0;
r := array();
while true do
begin
ctoken(tk,tp,pos);
if tk=";" then
begin
if rcount then
begin
r[rcount]["last"]:= true;
end
r[rcount]["end"]:= pos;
return r;
end else
if tk="," then
begin
if rcount>0 then
begin
r[rcount]["nextcomma"]:= pos;
end else
r[rcount]["first"]:= true;
rcount++;
r[rcount]["precomma"]:= pos;
end else
if tk=":" then
begin
tpv := parsertype();
for i := 0 to length(r)-1 do
begin
r[i]["type"]:= tpv;
end
continue;
ctoken(tk,tp,pos);
tarray := "";
if tk="array" then
begin
tarray := "array ";
ctoken(tk,tp,pos);
if tk=";" then
begin
for i := 0 to length(r) do
begin
r[i]["type"]:= "array";
end
return r;
end else
if tk="of" then
begin
tarray += "of ";
ctoken(tk,tp,pos);
end
end
end else
begin
r[rcount]["name"]:= tk;
r[rcount]["beg"]:= pos;
r[rcount]["id"]:= rcount;
r[rcount]["priv"]:= priv;
end
end
return r;
end
function parserproperty();
begin
r := "";
while true do
begin
ctoken(tk,tp,pos);
if not r then r := tk;
if tk=";" then return r;
end
return r;
end
function parserfunction();
begin
ctoken(tk,tp,pos);
ctoken(tk,tp,pos);
fn := "";
if tk <> "(" then fn := tk;
while true do
begin
if tk="begin" then
begin
//return parserstatement();
parserstatement();
break;
end else
if tk="(" then
begin
while true do
begin
ctoken(tk,tp,pos);
if tk=")" and tp <> TT_STR then
begin
break;
end
end
parserfunctionplus();
break;
end else
if tk=":" then
begin
bpos();
parserfunctionplus();
break;
end else
if tk="." then
begin
ctoken(tk,tp,pos);
fn := tk;
end else
if tk=";" then
begin
parserfunctionplus();
break;
end
ctoken(tk,tp,pos);
end
return fn;
end
function parserfunctionplus();
begin
ctoken(tk,tp,pos);
if ifnil(tk)then return;
if tk=";" then
begin
parserfunctionplus();
end else
if tk=":" then
begin
parsertype();
parserfunctionplus();
end else
if tk="begin" then
begin
return parserstatement();
end else
if tk="name" then
begin
ctoken(tk,tp,pos);
end else
if tk in array("virtual","cdecl","stdcall","external","override","overload")then
begin
ctoken(tk,tp,pos);
parserfunctionplus();
end else
begin
bpos();
end
end
function parserstatement();
begin
while true do
begin
ctoken(tk,tp,pos);
if ifnil(tk)then return;
if tk="end" and tp <> TT_STR then
begin
n := 0;
while true do
begin
n++;
ctoken(tk,tp,pos);
if ifnil(tk)then return;
if tk <> ";" then
begin
bpos(n);
return;
end
end
return array(pos+3);
end else
if tp <> TT_STR and(tk in array("begin","select","sselect",
"mselct","vselect","try","case","update"))then
begin
parserstatement();
end
end
end
property Script read GetScript write SetScript;
property ScriptPath read FScriptPath write SetScriptPath;
property Tokens read FTokens;
property CurrentPos read FCurrentPos write FCurrentPos;
end
//************************************
implementation
@@ -2357,120 +1665,7 @@ type TDesignerProjectsRecoder = class() //
end
//**********tsl parser token****************************
type tslparserbase= class
{**
@explan(说明) tsl语言解析基类 %%
**}
static TT_IDE; //标示符
static TT_STR; //字符串
static TT_SYM; //分隔符
static TT_OK;
function create();
begin
if not TT_OK then
begin
TT_IDE := "标示符";
TT_STR := "字符串";
TT_SYM := "分割符";
TT_OK := true;
end
end
function setdata(ret,nk,vs,tp,idx,hh) //解析
begin
{**
@explan(说明)保存数据
**}
if tp="空格" or tp="回车" or tp="换行" then return;
if tp in array("说明0","说明1","说明2","说明")then
begin
vs := "";
return;
end
if tp="语句" then //语句解析
begin
vs := lowercase(trim(vs));
end
//if vs in array("of","array") then tp := "关键字";
ret[nk,0]:= vs;
ret[nk,1]:= tp;
if ifnumber(idx)and tp="语句" then ret[nk,2]:= idx-length(vs);
else if ifnumber(idx)and tp <> "字符串" then ret[nk,2]:= idx;
case tp of
"语句":ret[nk,1]:= TT_IDE;
"字符串":ret[nk,1]:= TT_STR;
else ret[nk,1]:= TT_SYM;
end;
vs := "";
ret[nk,3]:= hh;
nk++;
end;
function findstringv2(str,fg,len,pos,hh);
begin
fgl := length(fg);
pfg := 0;
vs := "";
while pos<len do
begin
vi := str[pos];
if vi="\n" then
begin
hh++;
end
for i2 := 1 to fgl do
begin
vi := str[pos+i2];
if vi <> fg[i2]then break;
pfg := i2;
if pos=len then break;
end
if pfg=fgl then
begin
pos += fgl;
break;
end
vs += vi;
pos++;
end
return vs;
end
function findstringv(str,f,len,pos,zy,hh);
begin
{**
@explan(说明)查找以f结尾的字符串
**}
pos++;
vs := "";
if not(hh >= 0)then hh := 0;
while pos<len do
begin
vi := str[pos];
if vi="\n" then
begin
hh++;
//echo "\r\nfindh:",hh;
end
pos++;
if vi=f then break;
if zy and vi="\\" then
begin
if pos=len then break;
nvi := str[pos];
case nvi of
"r":vs += "\r";
"n":vs += "\n";
"t":vs += "\t";
"b":vs += "\b";
else vs += nvi;
end;
pos++;
continue;
end
vs += vi;
end
pos--;
return vs;
end;
end
type TFileTree = class(TTreeCtl)
type TTNode=class(TTreeNode) //TTreeCtlNode
designer/utslcodeeditor.tsf
+911 -4348
View File
File diff suppressed because it is too large Load Diff
designer/utslsynmemo.tsf
+6 -28
View File
@@ -3,8 +3,8 @@ interface
{**
@explan(说明) tsl语法编辑器库
**}
uses utslvclauxiliary,UTslMemo,TslVcl;
function FileSaveThreader(o,d);
uses utslvclauxiliary,UTslMemo;
function FileSaveThreader(o,d);
type TTSLCompletion= class(TSynCompletion)
{**
@explan(说明) tsl提示自动完成类
@@ -1548,14 +1548,12 @@ type TBBState =class //
end
type TTsfFileParser = class //文件解析
function Create();
begin
begin
FCacheDir :=TS_GetUserProfileHome()+"TslSynMemo"+ioFileseparator()+"cmpCaches";// d["value"];
//FCacheAbsFileName := FCacheDir+"\\cacheabstruct.stm";
//FFileWorker := new TThreadWorker("this.OnMessage :=findfunction('UTslSynMemo.FileSaveThreader') ;");
FFindDirs := array();
end
end
function DispatchMethod(o,d);//分发消息
begin
if not ifarray(d) then return ;
@@ -1898,7 +1896,7 @@ type TTsfFileParser = class //
end
function ParserFindDir(f); //解析缓存
begin
mtic;
//mtic;
if FCacheDir then
begin
FFileNames := array();
@@ -1918,7 +1916,7 @@ type TTsfFileParser = class //
for i,v in FFileNames do
begin
r[i[1:length(i)-4]] := v;
end
end
return r;
end
@@ -2081,24 +2079,4 @@ begin
end
end
type tparserdobject = class
function create(d);
begin
echo "\r\n create f object===";
if ifarray(d) then
FData := d;
end
function operator[](idx);
begin
if FData then
return FData[idx];
end
function operator[1](idx,v);
begin
if FData then
FData[idx] := v;
end
private
FData ;
end
end.
designer/utslvcldebuger.tsf
+3038
View File
File diff suppressed because it is too large Load Diff
designer/utslvcldesignerresource.tsf
+1225
View File
File diff suppressed because it is too large Load Diff
designer/utslvclsyntaxparser.tsf
+847
View File
@@ -0,0 +1,847 @@
unit utslvclsyntaxparser;
{**
@explan(说明) 设计器中tsl脚本解析相关 %%
@date(20220518)
**}
interface
type ttslscripparser = class(tslparser) //对外接口
{**
@explan(说明) 解析tsl 类 %%
**}
function create();
begin
inherited;
end
end
implementation
type tslparser = class(tslparserbase) //语法解析
private
FTokener;
FTokens;
FCurrentPos;
FTokenLen;
FScriptPath;
function SetScriptPath(v);
begin
size := filesize("",v); //获取文件大小
readFile(rwraw(),"",v,0,size,data);
SetScript(data);
end
function SetScript(v);
begin
if FTokener.tslstr <> v then
begin
FTokener.tslstr := v;
FTokens := FTokener.tokens();
if FTokens then FTokenLen := length(FTokens)-1;
FTokenLen :=-1;
end
end
function tkopok();
begin
return FCurrentPos>0 and FCurrentPos<FTokenLen;
end
function getTokenPos(ps);
begin
return FTokens[ps,2]+1;
end
function getTokenRow(ps);
begin
return FTokens[ps,3];
end
function ctoken(tk,tp,pos,r);
begin
if not FTokens then return 0;
r := tkopok(pos);
tk := FTokens[FCurrentPos,0];
tp := FTokens[FCurrentPos,1];
pos := FTokens[FCurrentPos,2]+1;
r := FTokens[FCurrentPos,3];
FCurrentPos++;
return tk;
end
function bpos(n);
begin
if n >= 0 then FCurrentPos -= n;
else FCurrentPos--;
end
function btoken(tk,tp,pos,n);
begin
bpos(n);
r := ctoken(tk,tp,pos);
return r;
end
function GetScript();
begin
return FTokener.tslstr;
end
public
function create();
begin
inherited;
FTokener := new tsltoken();
end
//type beg end name
function GetClassAbstract();
begin
{**
@explan(说明) 获得class 的基本信息 %%
@return(array) 包括"name","inherited","uses" 等信息 %%
**}
if not Tokens then array();
FCurrentPos := 0;
while true do
begin
ctoken(tk,tp,pos);
if ifnil(tk)then return array();
if tk="type" and tp <> TT_STR then
begin
r := array();
ctoken(tk,tp,pos);
if tp=TT_IDE then
begin
r["name"]:= tk;
ctoken(tk,tp,pos);
if tk <> "=" then return 0;
ctoken(tk,tp,pos);
if tk <> "class" then return 0;
ctoken(tk,tp,pos);
inh := array();
if tk="(" then
begin
while true do
begin
ctoken(tk,tp,pos);
if ifnil(tk)then break;
if tk=")" then break;
if tk="," then continue;
else inh[length(inh)]:= tk;
end
r["inherited"]:= inh;
end
while true do
begin
ctoken(tk,tp,pos);
if ifnil(tk)then break;
if tk="uses" and tp <> TT_STR then
begin
ru := array();
while true do
begin
ctoken(tk,tp,pos);
if ifnil(tk)then break;
if tk="," then continue;
if tk=";" then break;
ru[length(ru)]:= tk;
end
r["uses"]:= ru;
break;
end
end
return r;
end
end else
return array();
end
end
function GetClassInfo(fi);
begin
{**
@explan(说明) 获得class的详细信息 %%
@param(fi)(bool) 是否获得class成员的位置信息 %%
**}
r := array();
if not Tokens then return r;
FCurrentPos := 0;
while true do
begin
ctoken(tk,tp,pos);
if ifnil(tk)then exit;
if tk="type" and tp <> TT_STR then break;
end
if tk="type" and tp <> TT_STR then
begin
r["beg"]:= pos;
tr := parserclass(fi);
if ifarray(tr)then r union=tr;
r["end"]:= CurrentPos;
return r;
end
return r;
end
function parserclass(fi);
begin
{**
@explan(说明) 获得class详细 %%
@param(fi)(bool) 是否获得函数的信息 %%
**}
ctoken(tk,tp,pos);
r := array();
if tp=TT_IDE then
begin
r["name"]:= tk;
ctoken(tk,tp,pos);
if tk <> "=" then raise "解析错误";
ctoken(tk,tp,pos);
if tk <> "class" then raise "解析错误";
ctoken(tk,tp,pos);
if tk="(" then
begin
pa := array();
while true do
begin
ctoken(tk,tp,pos);
if tk=")" then
begin
r["inheritedendpos"] := pos;
break;
end
if tk <> "," then pa[length(pa)]:= tk;
end
r["inherited"]:= pa;
end else
begin
bpos();
end
props := array();
funcs := array();
funcsinfo := array();
filed := array();
priv := "public";
while true do
begin
ctoken(tk,tp,pos,row);
if ifnil(tk)then break;
if tk in array("private","public","protected")then
begin
priv := tk;
continue;
end
if tk="uses" and tp=TT_IDE then
begin
usb := pos;
pu := array();
while true do
begin
ctoken(tk,tp,pos);
if tp=TT_IDE then
begin
pu[length(pu)]:= tk;
end else
if tk=";" then break;
end
r["uses"]:= array("row":row,"beg":usb,"end":pos,"info":pu);
end else
if tk="static" and tp=TT_IDE then
begin
if not r["filed"]then r["filed"]:= array();
sf := parserfiled();
for i := 0 to length(sf)-1 do
begin
sf[i]["static"]:= true;
sf[i]["staticpos"]:= pos;
sf[i]["priv"]:= priv;
end
filed union=sf;
end else
if tk="function" or tk="procedure" then
begin
bpos();
bfpos := CurrentPos;
lenf := length(funcsinfo);
tfn := parserfunction();
if priv="public" then funcs[length(funcs)]:= tfn;
if fi then
begin
funcsinfo[lenf]["name"]:= tfn;
funcsinfo[lenf]["startpos"]:= getTokenPos(bfpos);
funcsinfo[lenf]["endpos"]:= getTokenPos(self.CurrentPos)-1;
funcsinfo[lenf]["row"]:= row;
end
end else
if tk="property" then
begin
props[length(props)]:= parserproperty();
end else
if tk="class" and tp=TT_IDE then
begin
if priv="public" then funcs[length(funcs)]:= parserfunction();
end else
if tk=";" then continue;
else if tk="end" and tp=TT_IDE then break;
else if tk="type" then
begin
cr := array();
cr["type"]:= "class";
cr["beg"]:= pos;
cr["info"]:= parserclass(fi);
cr["end"]:= CurrentPos;
end else
if tk="type" then break;
else
begin
bpos();
filed union=parserfiled(priv);
end
end
end
r["prop"]:= props;
r["funcs"]:= funcs;
r["filed"]:= filed;
r["funcsinfo"]:= funcsinfo;
prn := array();
if filed then prn := filed[:,"name"];
r["members"]:=(prn union2 funcs)union2 props;
return r;
end
function parsertype();
begin
ctoken(tk,tp,pos);
tarray := "";
if tk="array" then
begin
tarray := "array ";
ctoken(tk,tp,pos);
if tk=";" then
begin
return tarray;
end else
if tk="of" then
begin
tarray += "of ";
ctoken(tk,tp,pos);
end
end
return tarray+tk;
end
function parserfiled(priv);
begin
rcount := 0;
r := array();
while true do
begin
ctoken(tk,tp,pos);
if tk=";" then
begin
if rcount then
begin
r[rcount]["last"]:= true;
end
r[rcount]["end"]:= pos;
return r;
end else
if tk="," then
begin
if rcount>0 then
begin
r[rcount]["nextcomma"]:= pos;
end else
r[rcount]["first"]:= true;
rcount++;
r[rcount]["precomma"]:= pos;
end else
if tk=":" then
begin
tpv := parsertype();
for i := 0 to length(r)-1 do
begin
r[i]["type"]:= tpv;
end
continue;
ctoken(tk,tp,pos);
tarray := "";
if tk="array" then
begin
tarray := "array ";
ctoken(tk,tp,pos);
if tk=";" then
begin
for i := 0 to length(r) do
begin
r[i]["type"]:= "array";
end
return r;
end else
if tk="of" then
begin
tarray += "of ";
ctoken(tk,tp,pos);
end
end
end else
begin
r[rcount]["name"]:= tk;
r[rcount]["beg"]:= pos;
r[rcount]["id"]:= rcount;
r[rcount]["priv"]:= priv;
end
end
return r;
end
function parserproperty();
begin
r := "";
while true do
begin
ctoken(tk,tp,pos);
if not r then r := tk;
if tk=";" then return r;
end
return r;
end
function parserfunction();
begin
ctoken(tk,tp,pos);
ctoken(tk,tp,pos);
fn := "";
if tk <> "(" then fn := tk;
while true do
begin
if tk="begin" then
begin
//return parserstatement();
parserstatement();
break;
end else
if tk="(" then
begin
while true do
begin
ctoken(tk,tp,pos);
if tk=")" and tp <> TT_STR then
begin
break;
end
end
parserfunctionplus();
break;
end else
if tk=":" then
begin
bpos();
parserfunctionplus();
break;
end else
if tk="." then
begin
ctoken(tk,tp,pos);
fn := tk;
end else
if tk=";" then
begin
parserfunctionplus();
break;
end
ctoken(tk,tp,pos);
end
return fn;
end
function parserfunctionplus();
begin
ctoken(tk,tp,pos);
if ifnil(tk)then return;
if tk=";" then
begin
parserfunctionplus();
end else
if tk=":" then
begin
parsertype();
parserfunctionplus();
end else
if tk="begin" then
begin
return parserstatement();
end else
if tk="name" then
begin
ctoken(tk,tp,pos);
end else
if tk in array("virtual","cdecl","stdcall","external","override","overload")then
begin
ctoken(tk,tp,pos);
parserfunctionplus();
end else
begin
bpos();
end
end
function parserstatement();
begin
while true do
begin
ctoken(tk,tp,pos);
if ifnil(tk)then return;
if tk="end" and tp <> TT_STR then
begin
n := 0;
while true do
begin
n++;
ctoken(tk,tp,pos);
if ifnil(tk)then return;
if tk <> ";" then
begin
bpos(n);
return;
end
end
return array(pos+3);
end else
if tp <> TT_STR and(tk in array("begin","select","sselect",
"mselct","vselect","try","case","update"))then
begin
parserstatement();
end
end
end
property Script read GetScript write SetScript;
property ScriptPath read FScriptPath write SetScriptPath;
property Tokens read FTokens;
property CurrentPos read FCurrentPos write FCurrentPos;
end
type tslparserbase= class //基础变量
{**
@explan(说明) tsl语言解析基类 %%
**}
static TT_IDE; //标示符
static TT_STR; //字符串
static TT_SYM; //分隔符
static TT_OK;
function create();
begin
if not TT_OK then
begin
TT_IDE := "标示符";
TT_STR := "字符串";
TT_SYM := "分割符";
TT_OK := true;
end
end
function setdata(ret,nk,vs,tp,idx,hh) //解析
begin
{**
@explan(说明)保存数据
**}
if tp="空格" or tp="回车" or tp="换行" then return;
if tp in array("说明0","说明1","说明2","说明")then
begin
vs := "";
return;
end
if tp="语句" then //语句解析
begin
vs := lowercase(trim(vs));
end
//if vs in array("of","array") then tp := "关键字";
ret[nk,0]:= vs;
ret[nk,1]:= tp;
if ifnumber(idx)and tp="语句" then ret[nk,2]:= idx-length(vs);
else if ifnumber(idx)and tp <> "字符串" then ret[nk,2]:= idx;
case tp of
"语句":ret[nk,1]:= TT_IDE;
"字符串":ret[nk,1]:= TT_STR;
else ret[nk,1]:= TT_SYM;
end;
vs := "";
ret[nk,3]:= hh;
nk++;
end;
function findstringv2(str,fg,len,pos,hh);
begin
fgl := length(fg);
pfg := 0;
vs := "";
while pos<len do
begin
vi := str[pos];
if vi="\n" then
begin
hh++;
end
for i2 := 1 to fgl do
begin
vi := str[pos+i2];
if vi <> fg[i2]then break;
pfg := i2;
if pos=len then break;
end
if pfg=fgl then
begin
pos += fgl;
break;
end
vs += vi;
pos++;
end
return vs;
end
function findstringv(str,f,len,pos,zy,hh);
begin
{**
@explan(说明)查找以f结尾的字符串
**}
pos++;
vs := "";
if not(hh >= 0)then hh := 0;
while pos<len do
begin
vi := str[pos];
if vi="\n" then
begin
hh++;
//echo "\r\nfindh:",hh;
end
pos++;
if vi=f then break;
if zy and vi="\\" then
begin
if pos=len then break;
nvi := str[pos];
case nvi of
"r":vs += "\r";
"n":vs += "\n";
"t":vs += "\t";
"b":vs += "\b";
else vs += nvi;
end;
pos++;
continue;
end
vs += vi;
end
pos--;
return vs;
end;
end
type tsltoken = class(tslparserbase) //分词
{**
@explan(说明) tsl语言分词 %%
**}
private
FTSLstr;
FTokens;
function SetTslStr(v);
begin
if v <> FTSLstr then
begin
FTSLstr := v;
FTokens := nil;
end
end
public
function create();
begin
inherited;
end
function tokens();
begin
if FTokens then return FTokens;
if not ifstring(FTSLstr)then return array();
str := binary(FTSLstr);
pos :=-1;
len := length(str);
FTokens := array();
nk := 0;
vs := "";
hh := 0;
while true do
begin
pos++;
if pos >= len then break;
v := str[pos];
if v="%" then
begin
kk := 1;
v1 := str[pos+kk];
if v1="%" then
begin
pls := "%%";
while true do
begin
kk++;
if pos+kk >= len then break;
if str[pos+kk]in array(" ","\t","\r","\n")then
begin
if str[pos+kk]="\n" then hh++;
break;
end else
pls += str[pos+kk];
end
pos += kk;
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
vs := findstringv2(str,pls,len,pos,hh);
//vs := findstringv(str,pls,len,pos,nil,hh); //str,f,len,pos,zy,hh
setdata(FTokens,nk,vs,"字符串",pos,hh);
vf := 0;
continue;
end
end
if v='"' then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
vs := findstringv(str,'"',len,pos,1,hh);
setdata(FTokens,nk,vs,"字符串",pos,hh);
vf := 0;
end else
if v="'" then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
vs := findstringv(str,"'",len,pos,1,hh);
setdata(FTokens,nk,vs,"字符串",pos,hh);
vf := 0;
end else
if v='{' then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
vs := findstringv(str,'}',len,pos,nil,hh);
lvs := length(vs);
flvs := true;
if lvs>5 then
begin
if vs[1:2]="**" and(vs[3]in array(" ","\t","\r","\n"))and vs[lvs-1:lvs]="**" and(vs[lvs-2]in array(" ","\t","\r","\n"))then
begin
flvs := false;
vv := trim(vs[3:lvs-2]);
if vs[3]="\n" then hh++;
setdata(FTokens,nk,vv,"说明",pos,hh);
if vs[lvs-2]="\n" then hh++;
vs := "";
end
end
if flvs then setdata(FTokens,nk,vs,"说明0",pos,hh);
vf := 0;
end else
if v="#" then
begin
pos++;
vi := str[pos];
if vi="!" then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
vs := findstringv(str,'\n',len,pos,nil,hh);
setdata(FTokens,nk,vs,"说明2",pos,hh);
vf := 0;
end else
begin
pos--;
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
setdata(FTokens,nk,v,"分割",pos,hh);
vf := 0;
end
end else
if v="/" then
begin
pos++;
vi := str[pos];
if vi="/" then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
vs := findstringv(str,'\n',len,pos,nil,hh);
setdata(FTokens,nk,vs,"说明2",pos,hh);
vf := 0;
end else
begin
vs += v;
pos--;
end
end else
if v='(' then
begin
pos++;
vi := str[pos];
if vi="*" then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
pos++;
while pos <= len do
begin
vi := str[pos];
if vi="\n" then hh++;
if pos<len and vi="*" and str[pos+1]=")" then
begin
pos += 1;
break;
end else
vs += vi;
pos++;
end
//*******************************************************
lvs := length(vs);
flvs := true;
if lvs>3 then
begin
if vs[1]="*" and(vs[2]in array(" ","\t","\r","\n"))and vs[lvs]="*" and(vs[lvs-1]in array(" ","\t","\r","\n"))then
begin
flvs := false;
vv := trim(vs[2:lvs-1]);
if vs[2]="\n" then hh++;
setdata(FTokens,nk,vv,"说明",pos,hh);
if vs[lvs-1]="\n" then hh++;
vs := "";
end
end
if flvs then setdata(FTokens,nk,vs,"说明1",pos,hh);
//*********************************************************
vf := 0;
end else
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos-1,hh);
setdata(FTokens,nk,v,"前括号",pos,hh);
pos--;
continue;
end
end else
if v=")" then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
setdata(FTokens,nk,v,"后括号",pos,hh);
end else
if v="\t" then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
if vf then continue;
vf := 1;
setdata(FTokens,nk,v,"空格",pos,hh);
end else
if v=" " then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
if vf then continue;
vf := 1;
setdata(FTokens,nk,v,"空格",pos,hh);
end else
if v='\n' then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
hh++;
if vf then continue;
vf := 1;
setdata(FTokens,nk,v,"换行",pos,hh);
end else
if v='\r' then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
if vf then continue;
vf := 1;
setdata(FTokens,nk,v,"回车",pos,hh);
end else
if v in array(",",";",".","]","[",":","=","!")then
begin
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
setdata(FTokens,nk,v,"分割",pos,hh);
end else
begin
vs += v;
end
end
if length(vs)then setdata(FTokens,nk,vs,"语句",pos,hh);
return FTokens;
end
property tslstr read FTSLstr write SetTSLstr;
end
initialization
end.