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

设计器 

拆分代码
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored Normal file
View File

@ -0,0 +1,2 @@
FunCache.ini

4
designer/examples/action/e_action.tpj
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)\""
)

12
designer/examples/action/e_actionmain.tsf
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());

5
designer/examples/action/resource.tfm/e_actionmain.tfm
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

7
designer/gettslediterstart.tsf
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);

11
designer/gettslvcldesignerstart.tsf
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

6982
designer/tslvcldesigner.tsf
View File

File diff suppressed because it is too large Load Diff

861
designer/udesignerproject.tsf
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

5259
designer/utslcodeeditor.tsf
View File

File diff suppressed because it is too large Load Diff

34
designer/utslsynmemo.tsf
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.

3038
designer/utslvcldebuger.tsf Normal file
View File

File diff suppressed because it is too large Load Diff

1225
designer/utslvcldesignerresource.tsf Normal file
View File

File diff suppressed because it is too large Load Diff

847
designer/utslvclsyntaxparser.tsf Normal file
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.

20
funcext/tvclib/tcomponent.tsf
View File

@ -1,5 +1,5 @@
type tcomponent = class(TSLUIBASE)
uses utslvclauxiliary,utslvclbase;
uses utslvclauxiliary,UVCPropertyTypesPersistence,utslvclbase;
{**
@explan(说明) 可视化组件基类 %%
@date(20220505) 分离tcomponent基类
@ -31,9 +31,9 @@ uses utslvclauxiliary,utslvclbase;
#!begin //private methods
function GetLoader();
begin
global G_T_TTFM2COMPONET_;
if not G_T_TTFM2COMPONET_ then return 0;
if not FLoader then FLoader := createobject(G_T_TTFM2COMPONET_);
m2 := class(tUIglobalData).uigetdata("G_T_TTFM2COMPONET_");
if not m2 then return 0;
if not FLoader then FLoader := createobject(m2);
return FLoader;
end
function GetPropInfo();
@ -310,7 +310,7 @@ public
if cd=self then return true;
for i := 0 to FComponents.count()-1 do
begin
if FComponents[i].isDescendant(cd)then return true;
if FComponents[i].isDescendant(cd) then return true;
end
return false;
end
@ -320,7 +320,7 @@ public
@explan(说明) 设置所有者,注意只能成功设置一次,之后设置无效 %%
@param(AOwner)(tcomponent) 所有者 %%
**}
if ifnil(FOwner)and(AOwner is class(tcomponent))then
if (ifnil(FOwner)) and (AOwner is class(tcomponent))then
begin
if isDescendant(AOwner)then exit;
FOwner := AOwner;
@ -471,7 +471,7 @@ public
begin
typ := v["type"];
if typ="eventhandler" then continue;
otype := GetPropertyType(typ);
otype :=GetComponentPropertyType(typ);// GetPropertyType(typ);
if otype then
begin
n := v["name"];
@ -502,7 +502,7 @@ public
begin
typ := v["type"];
if typ <> "eventhandler" then continue;
otype := GetPropertyType(typ);
otype :=GetComponentPropertyType(typ);// GetPropertyType(typ);
if otype then
begin
n := v["name"];
@ -532,7 +532,7 @@ public
vv := FChangedProperties[n];
if ifnil(vv)then continue;
vit := vi["type"];
otype := GetPropertyType(vit);
otype := GetComponentPropertyType(vit);//GetPropertyType(vit);
if vi["write"]and otype then
begin
r[n]:= otype.FormatTMF(vv);
@ -570,7 +570,7 @@ public
if n=vi["name"]then
begin
vit := vi["type"];
otype := GetPropertyType(vit); //获得转换对象
otype := GetComponentPropertyType(vit);//GetPropertyType(vit); //»ñµÃת»»¶ÔÏó
if ifobj(otype)then
begin
iv := otype.UnformatEdit(v); //反转换

9
funcext/tvclib/tcontrol.tsf
View File

@ -3,6 +3,13 @@ type tcontrol = class(tcomponent)
@explan(说明) 界面控件基类 %%
@date(20220509) %%
**}
///////////ƽ̨ÅжÏ////////
{$ifdef linux}
{$define gtkpaint}
{$define linuxgtk}
{$else}
{$define gdipaint}
{$endif}
uses utslvclauxiliary,utslvclmemstruct,utslvclevent,utslvclgdi,utslvclaction,utslvclmenu;
private //计量处数据
#!begin //members
@ -815,7 +822,7 @@ type tcontrol = class(tcomponent)
begin
CallMessgeFunction(FOnDblClick,o,e);
end
end
end
function WMRButtonDBLCLK(o,e):LM_RBUTTONDBLCLK;virtual;
begin
{

118
funcext/tvclib/tslvcl.tsf
View File

@ -23,7 +23,7 @@ unit tslvcl;
interface
uses utslvclconstant,utslvclbase,utslvclauxiliary,cstructurelib,utslvclmemstruct,utslvclevent,UVCPropertyTypesPersistence,utslvclgdi,utslvclaction,utslvclmenu,utslvclstdctl,utslvclgrid,utslvcltree;
function initializeapplication(); //获得app对象
function RegisterComponentType(n,typ); //设计器中注册控件
function RegisterComponentType(n,typ); //注册控件,便于通过控件名称构造控件
function GetAndDispatchMessageA(hwnd,minm,maxm); //win32 分发消息
function ExitMessageLoop(); //退出主循环
//function gettswin32api(); //win32 api
@ -59,7 +59,6 @@ function TslToHexFormatStr(tsl);
function HexFormatStrToTsl(D);
function GetTextWidthAndHeightWidthFont(s,f,mul);
//**********操作系统相关函数*********************
function initlib();
////////////////////////////////////
@ -133,8 +132,7 @@ type Ttfm2Component = class(TTmfParser)
nn := lowercase(n);
r := FComponentTypes[nn];
if r then return r;
global G_F_TSLVCL_FINDCLASS;
if G_F_TSLVCL_FINDCLASS then return call(G_F_TSLVCL_FINDCLASS,nn);
return findclass(nn);
end
end
function SetTfmData(owner,obj,data,lazydata);
@ -156,7 +154,7 @@ type Ttfm2Component = class(TTmfParser)
ddpv := ddp[n];
if not ifarray(ddpv)then continue;
cls := v["class"];
et := owner.GetPropertyType(cls);
et := GetComponentPropertyType(cls);//owner.GetPropertyType(cls);
if not et then continue;
td := SampleValue(ddpv);
if et.LazyProperty()then
@ -2097,7 +2095,6 @@ type tmemo = class(TSynMemoNorm)
begin
inherited;
end
function MouseUp(o,e);override;
begin
if csDesigning in ComponentState then return ;
@ -10450,8 +10447,6 @@ begin
**}
class(Ttfm2Component).RegisterComponentType(n,typ);
end
function initializeapplication();
begin
{**
@ -10579,31 +10574,12 @@ begin
**}
return class(ttimer)._timeproc_(hwnd,message,wparam,lparam);
end
type tglobalabc=class
function create();
begin
global xxxx;
xxxx++;
echo "\r\nin:",xxxx;
end
function destroy();
begin
global xxxx;
xxxx--;
echo "\r\nout:",xxxx;
end
end
function controlisCustomPaint(id);
begin
wd := class(tUIglobalData).uigetdata("TGlobalValues").getvalue(id);
if wd then return wd.isCustomPaint();
return false;
end
function tslvclfindclass(n);
begin
r := findclass(n);
return r;
end
function _twinproc_(hwnd,message,wparam,lparam); //消息分发
begin
{**
@ -10701,29 +10677,7 @@ begin
end
end
function initallib();
begin
//ClearScriptCache();
//global tuiapplication;
//tuiapplication := getapplication();
global G_F_CONTROL_IS_CUSTOMPAINT;
global G_F_TSLVCL_FINDCLASS;
global G_F_TWIN_PROC_;
global G_F_TIME_PROC_;
global G_T_TTFM2COMPONET_;
global G_T_TVCFORM_;
G_F_CONTROL_IS_CUSTOMPAINT := thisfunction(controlisCustomPaint);
G_F_TSLVCL_FINDCLASS := thisfunction(tslvclfindclass);
G_F_TWIN_PROC_ := thisfunction(_twinproc_);
G_F_TIME_PROC_ := thisfunction(_timeproc_);
G_T_TTFM2COMPONET_ := class(Ttfm2Component);
G_T_TVCFORM_ := class(TVCForm);
class(tUIglobalData).uisetdata("TGlobalComponentcache",class(TGlobalComponentcache));
class(tUIglobalData).uisetdata("TGlobalValues",class(TGlobalValues));
class(TRegKey).sinit(); //初始化reg注册表
end
//function GetModuleFileNameA(m:pointer;var buf:string;len:integer):integer;stdcall;external "Kernel32.dll" name "GetModuleFileNameA";
//function CallWindowProcA(lpPrevWndFunc:pointer;hWnd:pointer;Msg:integer;wParam:pointer;lParam:pointer):pointer;stdcall;external "User32.dll" name "CallWindowProcA";
@ -10743,23 +10697,22 @@ function TSL_FreeObj(L:pointer;v:pointer);cdecl;external {$ifdef linux}"libTSSVR
//function TS_ModulePath():string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_ModulePath";
//function TS_ExecPath():string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_ExecPath";
//function TS_GetAppPath():string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_ExecPath";
function TS_GetUserProfileHome():string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_GetUserProfileHome";
//function TS_GetIniPath(hometype:integer; var IniName:string):string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_GetIniPath";
function TSL_Check(func:string;funclen:integer;oResult:pointer):integer;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TSL_Check";
procedure tslprocessmessages();begin {echo "\r\n processmessage";}end;
function TS_GetUserProfileHome();
begin
return unit(utslvclauxiliary).TS_GetUserProfileHome();
end
function RunWorkerThreadLoop();
begin
sleep(10);
class(TThreadWorker).dispatch();
end
//procedure ClearScriptCache();cdecl;external "TSLInterp.dll" name "ClearScriptCache";
function initlib();
begin
{**
@explan(说明) 初始化lib %%
**}
a := static initallib();
end
function CreateDirWithFileName(fname);
begin
return unit(utslvclauxiliary).CreateDirWithFileName(fname);
@ -11000,6 +10953,7 @@ begin
**}
return(a and not(b))or(b and not(a));
end
////////////////////封装已经移动到其他库的接口为了兼容///////////
function TslToHexFormatStr(tsl);
begin
return unit(utslvclauxiliary).TslToHexFormatStr(tsl);
@ -11016,7 +10970,55 @@ function CallMessgeFunction(f,o,e);
begin
return unit(utslvclauxiliary).CallMessgeFunction(f,o,e);
end
/////////////////////////初始化////////////////////////////////////
function initallib();
begin
class(tUIglobalData).uisetdata("G_F_CONTROL_IS_CUSTOMPAINT",thisfunction(controlisCustomPaint));
class(tUIglobalData).uisetdata("G_F_TWIN_PROC_",thisfunction(_twinproc_));
class(tUIglobalData).uisetdata("G_F_TIME_PROC_",thisfunction(_timeproc_));
class(tUIglobalData).uisetdata("G_T_TVCFORM_",class(TVCForm));
class(tUIglobalData).uisetdata("G_T_TTFM2COMPONET_",class(Ttfm2Component));
class(tUIglobalData).uisetdata("TGlobalComponentcache",class(TGlobalComponentcache));
class(tUIglobalData).uisetdata("TGlobalValues",class(TGlobalValues));
class(TRegKey).sinit(); //初始化reg注册表
//导入注册的componet
vclini := pluginpath()+"tslvcl.ini";
if fileexists("",vclini) then
begin
ini := new TIniFileExta("",vclini);
ini.LowerKey := true;
for i,v in ini.ReadSectionValues("components") do //控件
begin
if v then
begin
cv := findclass(v);
if cv then
begin
RegisterComponentType(i,cv);
end
end
end
for i,v in ini.ReadSectionValues("propertys") do //属性
begin
if v then
begin
cv := findclass(v);
if cv then
begin
RegComponentPropertyType(createobject(cv));
end
end
end
end
end
function initlib();
begin
{**
@explan(说明) 初始化lib %%
**}
a := static initallib();
end
Initialization
initlib();

4
funcext/tvclib/twincontrol.tsf
View File

@ -2432,8 +2432,8 @@ end
if dispatchmenushortcut(o.Action,st) then return "havedoshortcut";
if dispatchmenushortcut(o.PopupMenu,st) then return "havedoshortcut";
end
global G_T_TVCFORM_;
if G_T_TVCFORM_ and (o is G_T_TVCFORM_ ) then
w := class(tUIglobalData).uigetdata("G_T_TVCFORM_");
if w and (o is w ) then
begin
if dispatchmenushortcut(o.MainMenu,st) then return "havedoshortcut";
end

50
funcext/tvclib/ugtkinterface.tsf
View File

@ -455,7 +455,7 @@ type tsgtkapi = class(tgtkapis)
// class(tUIglobalData).uigetdata("TGlobalComponentcache").getwndbyhwnd(hwnd);
function Gtk_TrigMoveSizeEvent(h,aleft,atop,AWidth,AHeight,flg);
begin
global G_F_TWIN_PROC_;
gfw := class(tUIglobalData).uigetdata("G_F_TWIN_PROC_");
SWP_NOMOVE := 2;
SWP_NOSIZE := 1;
WM_WINDOWPOSCHANGED := 0x47;
@ -479,14 +479,14 @@ type tsgtkapi = class(tgtkapis)
else
d.cy := AHeight;
D.flags := SWP_NOMOVE;
if G_F_TWIN_PROC_ then call(G_F_TWIN_PROC_,h,WM_WINDOWPOSCHANGED,0,d._getptr_);
if gfw then call(gfw,h,WM_WINDOWPOSCHANGED,0,d._getptr_);
end
if PosChanged then
begin
d.x := ALeft;
d.y := ATop;
d.flags := SWP_NOSIZE;
if G_F_TWIN_PROC_ then call(G_F_TWIN_PROC_,h,WM_WINDOWPOSCHANGED,0,d._getptr_);
if gfw then call(gfw,h,WM_WINDOWPOSCHANGED,0,d._getptr_);
end
if SizeChanged then //这个是不是应该放前面
begin
@ -498,9 +498,9 @@ type tsgtkapi = class(tgtkapis)
end}
if PosChanged then
begin
if G_F_TWIN_PROC_ then
if gfw then
begin
call(G_F_TWIN_PROC_,h,0x3,0,makeposition(ALeft,ATop));
call(gfw,h,0x3,0,makeposition(ALeft,ATop));
end
end
@ -1894,10 +1894,10 @@ type tsgtkapi = class(tgtkapis)
obj := g_image_list_caches[sptr,"imglist"] ;
if not obj then return ;
class(TGdiplusflat).GdipCreateBitmapFromHBITMAP(hbmImage,r1,0);
global G_T_BITMAP_;
if G_T_BITMAP_ then
cbmp := class(tUIglobalData).uigetdata("G_T_BITMAP_");
if cbmp then
begin
bmp := createobject(G_T_BITMAP_);
bmp := createobject(cbmp);
bmp.Handle := r1;
obj.Push(bmp);
end
@ -2007,11 +2007,11 @@ type tsgtkapi = class(tgtkapis)
if not ifarray(g_image_list_caches) then return 0;
obj := g_image_list_caches[inttostr(himl),"imglist"];
if not obj then return ;
global G_T_BITMAP_;
if not G_T_BITMAP_ then return 0;
cbmp := class(tUIglobalData).uigetdata("G_T_BITMAP_");
if not cbmp then return 0;
class(TGdiplusflat).GdipCreateBitmapFromHBITMAP(hbmImage,0,r1);
bmp := createobject(G_T_BITMAP_);
bmp := createobject(cbmp);
bmp.Handle := r1;
if id=-1 then obj.Push(bmp);
else
@ -2445,9 +2445,9 @@ type tsgtkapi = class(tgtkapis)
global g_gtk_caret_cache_timer; //缓存
if not g_gtk_caret_cache_timer then
begin
global G_T_TTIMER_;
if not G_T_TTIMER_ then return 0;
g_gtk_caret_cache_timer := createobject(G_T_TTIMER_,nil);
ctm := class(tUIglobalData).uigetdata("G_T_TTIMER_");
if not ctm then return 0;
g_gtk_caret_cache_timer := createobject(ctm,nil);
g_gtk_caret_cache_timer.Interval := 680;
g_gtk_caret_cache_timer.Ontimer := function(o,e)begin
global g_current_get_focus_widget;
@ -4426,14 +4426,14 @@ type tenterouterlist = class
end
function create(api);
begin
global G_T_TTIMER_;
if not G_T_TTIMER_ then return ;
ctm := class(tUIglobalData).uigetdata("G_T_TTIMER_");
if not ctm then return ;
_wapi := api;
FCpos := array(0,0);
_wapi.GetCursorPos(FCpos);
FList := array();
FIndex := -1;
FTimer := createobject(G_T_TTIMER_,nil);
FTimer := createobject(ctm,nil);
FTimer.interval := 30; //30毫秒
FTimer.Ontimer := thisfunction(MouseIsMoved);
FTimer.start();
@ -4536,10 +4536,10 @@ type tgtk_ctl_object = class(_gtkeventtype)
return AddMessageToGtkMessageQueue(FHandle,msg,w,l,p);
end else
begin
global G_F_TWIN_PROC_;
if G_F_TWIN_PROC_ then
gfw := class(tUIglobalData).uigetdata("G_F_TWIN_PROC_");
if gfw then
begin
r := call(G_F_TWIN_PROC_,FHandle,msg,w,l);
r := call(gfw,FHandle,msg,w,l);
end
if msg = CM_CURSORCHANGED then
begin
@ -5877,12 +5877,12 @@ type tgtk_ctl_scroll_window = class(tgtk_ctl_object)
end;
function CreateWnd(dwExStyle,lpClassName,lpWindowName,dwStyle,x,y,nwidth,nheight,hwndparent,hmenu,hinstance,lpParam);override;
begin
global G_F_CONTROL_IS_CUSTOMPAINT;
fispaint := class(tUIglobalData).uigetdata("G_F_CONTROL_IS_CUSTOMPAINT");
//echo "\r\nctl:",tostn(params),tostn(__stack_frame),datetimetostr(now());
d := new tslcstructureobj(MemoryAlignmentCalculate( array(("lpcreateparams","intptr",0))),lpParam);
if G_F_CONTROL_IS_CUSTOMPAINT then
if fispaint then
begin
isp := call(G_F_CONTROL_IS_CUSTOMPAINT,d._getvalue_("lpcreateparams"));
isp := call(fispaint,d._getvalue_("lpcreateparams"));
end
h := self.handle;
{if (_const.WS_BORDER .& dwStyle)=_const.WS_BORDER then
@ -6697,8 +6697,8 @@ begin
end }
if d[4]=0x113 and d[0]=0 then //定时
begin
global G_F_TIME_PROC_;
if G_F_TIME_PROC_ then call(G_F_TIME_PROC_,d[0],d[1],d[2],d[3]);
fgt := class(tUIglobalData).uigetdata("G_F_TIME_PROC_");
if fgt then call(fgt,d[0],d[1],d[2],d[3]);
end else
if d[0] then
begin

9
funcext/tvclib/utslmemo.tsf
View File

@ -454,7 +454,7 @@ type TCustomMemoCmd=class()
static ecColumnSelect;
static ecLineSelect;
static ecMatchBracket;
static ecGotoMarker0;
{static ecGotoMarker0;
static ecGotoMarker1;
static ecGotoMarker2;
static ecGotoMarker3;
@ -473,7 +473,7 @@ type TCustomMemoCmd=class()
static ecSetMarker6;
static ecSetMarker7;
static ecSetMarker8;
static ecSetMarker9;
static ecSetMarker9;}
static ecDeleteLastChar;
static ecDeleteChar;
static ecDeleteWord;
@ -571,7 +571,7 @@ type TCustomMemoCmd=class()
ecColumnSelect := 232; // Column selection mode
ecLineSelect := 233; // Line selection mode
ecMatchBracket := 250; // Go to matching bracket
ecGotoMarker0 := 301; // Goto marker
{ecGotoMarker0 := 301; // Goto marker
ecGotoMarker1 := 302; // Goto marker
ecGotoMarker2 := 303; // Goto marker
ecGotoMarker3 := 304; // Goto marker
@ -591,6 +591,7 @@ type TCustomMemoCmd=class()
ecSetMarker7 := 358; // Set marker, Data := PPoint - X, Y Pos
ecSetMarker8 := 359; // Set marker, Data := PPoint - X, Y Pos
ecSetMarker9 := 360; // Set marker, Data := PPoint - X, Y Pos
}
ecDeleteLastChar := 501; // Delete last char (i.e. backspace key)
ecDeleteChar := 502; // Delete char at cursor (i.e. delete key)
ecDeleteWord := 503; // Delete from cursor to end of word
@ -2360,6 +2361,7 @@ type TSynCompletion = class(TSynCompletionList)
function SetJumpData(s);
begin
FJumpData := s;
FFilter :="";
end
function Recycling();override;
begin
@ -2713,6 +2715,7 @@ type TSynCompletion = class(TSynCompletionList)
begin
SetMemo(nil);
inherited;
FCompData := array();
end
function TryJump(s); //Ìøת

285
funcext/tvclib/utslvclauxiliary.tsf
View File

@ -24,6 +24,9 @@ function pointinrect(p,rec);
function intersectrect(rec1,rec2,irec);
function bitcombination(s,v,f);
function IsTextUTF8(str);
function exportjsonformat(d,tbw,ct);
//****************************
///////////////////
function ParserCommandLine(s); //解析命令行参数
@ -34,6 +37,8 @@ function TslToHexFormatStr(tsl);
function HexFormatStrToTsl(D);
function DeleteAllFiles(path);
function CreateDirWithFileName(fname);
function TS_GetUserProfileHome();
function gettslexefullpath();
type tuiglobaldata=class
static UIData;
@ -997,6 +1002,103 @@ type tnumindexarray = Class
@param(Data)(array) 数据 %%
**}
end
//ifdef newgetop
type trefarray = class
function create(d,bidxs); //构造函数
begin
if ifarray(d) or (d is class(trefarray)) then
begin
FData := d;
end else
begin
FData := array();
end
if ifarray(bidxs) then
begin
FBindexs := bidxs;
end else
begin
FBindexs := array();
end
end
function mgset(idxs,v); //根据下标设置值
begin
if not ifarray(idxs) then return nil;
if ifarray(FData) then
begin
return magicsetarray(FData,FBindexs union idxs,v);
end
return FData.mgset(FBindexs union idxs,v);
end
function mgget(idxs); //根据获得值
begin
if not ifarray(idxs) then return nil;
if ifarray(FData) then
begin
return magicgetarray(FData,idxs);
end
return FData.mgget(FBindexs union idxs,v);
end
function operator[0](idx,v); //获取值
begin
if v<0 then //一级直接返回
begin
return mgget(array(idx));
end
return new trefgetter(self,idx);//多级的时候构建一个中间对象
end
function operator[1](idx,v); //设置值
begin
if ifnone(v) then //多级构建一个中间对象
begin
return new trefsetter(self,idx);
end
return mgset(array(idx),v); //一级直接返回
end
private //成员变量
FData;
FBindexs;
private //中间对象
type trefsgter = class()
function create(a,idx);
begin
FA := a;
FIndexs := array(idx);
FIndexsidx := 1;
end
protected
FA;
FIndexs;
FIndexsidx;
end
type trefgetter = class(trefsgter) //getter 对象
function operator[0](idx,v);
begin
FIndexs[FIndexsidx++] := idx;
if v<0 then
begin
return fa.mgget(FIndexs);
end
return self;
end
function create(a,idx);
begin
inherited;
end
end
type trefsetter = class(trefsgter) //setter 对象
function operator[1](idx,v);
begin
FIndexs[FIndexsidx++] := idx;
if ifnone(v) then return self;
return fa.mgset(FIndexs,v);
end
function create(a,idx);
begin
inherited;
end
end
end;
type TGlobalValues=class
private
static FValues;
@ -2194,6 +2296,189 @@ begin
ph += vi;
end
end
function TS_GetUserProfileHome():string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_GetUserProfileHome";
function IsTextUTF8(str)
begin
{utf8规则
单字节: 0xxxxxxx
二字节 110xxxxx 10xxxxxx
三字节 1110xxxx 10xxxxxx 10xxxxxx
四字节 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
五字节 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
刘字节 1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
}
// 0 为ansi 编码,1 为utf8编码 -1 不能确定什么编码
nBytes := 0; //UFT8可用1-6个字节编码,ASCII用一个字节
DY := 0;
chr := "";
bAllAscii := TRUE; //如果全部都是ASCII, 说明不是UTF-8
for i := 1 to length(str) do
begin
chr := ord(str[i]);
if((chr .& 0x80)<> 0)then
begin // 判断是否ASCII编码,如果不是,说明有可能是UTF-8,ASCII用7位编码,但用一个字节存,最高位标记为0,o0xxxxxxx
bAllAscii := FALSE;
end
if(nBytes=0)then //如果不是ASCII码,应该是多字节符,计算字节数
begin
if(chr >= 0x80)then
begin
if(chr >= 0xFC and chr <= 0xFD)then nBytes := 6;
else if(chr >= 0xF8)then nBytes := 5;
else if(chr >= 0xF0)then nBytes := 4;
else if(chr >= 0xE0)then nBytes := 3;
else if(chr >= 0xC0)then nBytes := 2;
else return 0;
DY := MAX(nBytes,DY);
nBytes--;
end
end else //多字节符的非首字节,应为 10xxxxxx
begin
if((chr .& 0xC0)<> 0x80)then return-1;
nBytes--;
end
end;
//违返规则
if(nBytes>0)then
return -1;
//如果全部都是ASCII, 说明不是UTF-8
if(bAllAscii)then
return 0;
//return 1;
return DY>2;
end
function exportjsonformat(d,tbw,ct);
begin
//d:天软数据
//tbw : 字符串,tab 宽度
//ct 递归深度,忽略
case datatype(d)of
0,20:return inttostr(d);
1:return floattostr(d);
2:return tostn(d);
8,10,11,12:return "null";
end;
if not(ct>0)then ct := 0;
if not ifstring(tbw)then tbw := " ";
tbstr := "";
tbstra := "";
for i := 0 to ct do
begin
tbstr += tbw;
if i>0 then tbstra += tbw
end
if ifarray(d)then
begin
if not d then return "[]";
idx := 0;
for i,v in d do
begin
if idx <> i then
begin
fobj := true;
break;
end
idx++;
end
if fobj then
begin
r := "{";
for i,v in d do
begin
if ifstring(i)then ii := tostn(i);
else ii := tostn(tostn(i));
r += "\r\n"+tbstr+ii+":";
if ifarray(v)and v then
begin
r += "\r\n"+tbstr;
end
r += exportjsonformat(v,tbw,ct+1)+",";
end
lr := length(r);
r[lr:]:= "\r\n"+tbstra+"}";
end else
begin
r := "[";
for i,v in d do
begin
r += "\r\n"+(tbstr)+exportjsonformat(v,tbw,ct+1)+",";
end
lr := length(r);
r[lr:]:= "\r\n"+tbstra+"]";
end
return r;
end else
if ifobj(d)then
begin
try
//return "{}";
//此处可以遍历对象信息
tslobjtoarray(d,dinfo);
for i,v in mrows(dinfo,1) do
begin
nv := invoke(d,v);
if ifobj(nv)then nv := nil; //避免死循环
dinfo[v]:= nv;
end
return exportjsonformat(dinfo,tbw,ct);
except
return "{}";
end
end else
return "null";
end
function tslobjtoarray(o,r);
begin
d := o.classinfo();
if not ifarray(r)then r := array();
for i,v in d["inherited"] do
begin
tslobjtoarray(findclass(v,o),r);
end
for i,v in d["members"] do
begin
n := v["name"];
if v["access"]in array(0,1)then
begin
r[n]:= 0;
end else
begin
reindex(r,array(n:nil));
end
end
for i,v in d["properties"] do
begin
n := v["name"];
if v["read"]and(v["access"]in array(0,1))then
begin
r[n]:= 0;
end else
begin
reindex(r,array(n:nil));
end
end
end
function gettslexefullpath();
begin
plg := pluginpath();
sp := ioFileseparator();
for i:= length(plg)-1 downto 1 do
begin
if plg[i]=sp then
begin
if sp="/" then
begin
return plg[1:i]+"TSL";
end else
begin
return plg[1:i]+"tsl.exe";
end
end
end
return "";
end
initialization

10
funcext/tvclib/utslvclbase.tsf
View File

@ -6,7 +6,7 @@ interface
{$else}
{$define gdipaint}
{$endif}
uses utslvclconstant,utslvclmemstruct,utslvclauxiliary,UVCPropertyTypesPersistence;
uses utslvclconstant,utslvclmemstruct,utslvclauxiliary;
type tswin32api = class({$ifdef linuxgtk}tsgtkapi {$else} twindowsapi {$endif} ) //windows½Ó¿Ú
{$ifdef linuxgtk}
uses ugtkinterface;
@ -303,14 +303,6 @@ type TSLUIBASE=class(TSLUICONST) //ͼ
if not(ifstring(_temppath)and _temppath)then _temppath := gettemppath()+"tinysoft";
return _temppath;
end
class function RegPropertyType(v); //注册设计器编辑
begin
RegComponentPropertyType(v);
end
class function GetPropertyType(n); //获得设计器编辑
begin
return GetComponentPropertyType(n);
end
property happ read Gethapp write SetHapp;
property ReCycleState read FReCycleState; //write FReCycleState;
_Tag; //±êÇ©

6
funcext/tvclib/utslvclgdi.tsf
View File

@ -2981,10 +2981,8 @@ end
initialization
sinitgidplus();
class(tcustomimage).sinit();
global G_T_BITMAP_;
global G_T_ICON_;
G_T_BITMAP_ := class(TcustomBitmap);
G_T_ICON_ := class(TcustomIcon);
class(tUIglobalData).uisetdata("G_T_BITMAP_",class(TcustomBitmap));
class(tUIglobalData).uisetdata("G_T_ICON_",class(TcustomIcon));
finalization
end.

217
funcext/tvclib/utslvclstdctl.tsf
View File

@ -331,204 +331,6 @@ type TCustomTimer = class(tcomponent)//
@param(Enabled)(bool) 是否已经启动 %%
**}
end
type TCustomTimer = class(tcomponent)//定时器类
{**
@explan(说明)定时器类,间隔是以毫秒为最小单位 %%
**}
{**
@example(范例--定时器)
//构造计算器,第一个参数为间隔(毫秒),第二个为函数指针
tm := new TCustomTimer(1000,function(o,e)begin echo now(); end );
tm.start();//启动定时器
tm.stop();//停止
**}
private
static _STIMERS; //TIMER对象
static FSIDC; //id 构造器
class function Sgettimer(id);
begin
{**
@explan(说明) 通过id获得定时器对象 %%
@param(id)(integer) 定时器id %%
**}
return _STIMERS[id];
end
class function Ssettimer(tm);
begin
{**
@explan(说明)存储定时器 %%
@param(tm)(TCustomTimer) 定时器对象%%
**}
_STIMERS[tm.id]:= tm;
end
class function Sdeltimer(tid);
begin
{**
@explan(说明) 删除定时器 %%
@param(tid)(integer) id%%
**}
if tid and(ifnumber(tid))then reindex(_STIMERS,array(tid:nil));
end
protected FOntimeout;
private
FOntimer;
Fid;
FInterval;
FStart;
_kill0; //标记
function SetEnabled(f);
begin
if f then start();
else stop();
end
function SetInterval(intv); //设置间隔
begin
{**
@explan(说明)设置间隔 %%
@param(intv)(integer) 间隔,毫秒 %%
**}
if not(ifnumber(intv))then return FInterval;
if FStart then
begin
ndstart := 1;
stop();
end
if intv <> FInterval and ifnumber(intv)and intv>0 then //时间不等
begin
FInterval := intv;
end
if ndstart then start();
end
public
{**
@param(FSIDC)(tidcreater) id构造器%%
@param(_STIMERS)(array) 全局存储%%
@param(FOntimer)(fpointer) timeout执行对象%%
@param(_kill0)(bool) 标记%%
**}
function create(AOwner);override;
begin
inherited;
FID := FSIDC.createid();
FStart := false;
FInterval := 1000;
end
function timeout(cmd,t); //一次性事件
begin
{**
@explan(说明) 一次性事件 %%
@param(cmd)(fpointer) 执行回调 %%
@param(t)(integer) t毫秒后执行 %%
**}
FOntimeout := cmd;
if ifnumber(t)then SetInterval(t);
FOntimer := function(o,e)
begin
try
stop();
CallMessgeFunction(FOntimeout,o,e);
finally
FOntimeout := nil;
end;
end;
start();
end
function start(); //开始
begin
{**
@explan(说明)启动 %%
**}
if not((datatype(FOntimer) = 7 )and FInterval)>0 then return-1;
if FStart then return FStart;
ret := _wapi.SetTimer(nil,Fid,FInterval,getwinprocptr(2));
_kill0 := ret;
Ssettimer(self(true));
FStart := ret <> 0;
return FStart;
end
function stop(); //停止
begin
{**
@explan(说明)停止 %%
**}
if FStart then
begin
if _kill0 then
begin
FStart := not((_wapi.KillTimer(nil,_kill0))<> 0);
if FStart=false then _kill0 := 0;
end
Sdeltimer(FID);
end
return not FStart;
end
function Recycling();override;
begin
{**
@explan(说明)析构预备 %%
**}
stop();
FSIDC.deleteid(FID);
FOntimer := nil;
FOntimeout := nil;
FTimerStrc := nil;
inherited;
end
function destroy();override;
begin
inherited;
end
class function _timeproc_(hwnd,message,wparam,lparam);
begin
{**
@explan(说明) 定时回调入接口 %%
@param(hwnd)(integer) 窗口句柄 %%
@param(message)(integer) 消息id %%
@param(lparam)(integer) 消息参数2 %%
@param(wparam)(integer) 消息参数1 %%
**}
e := new tuieventbase(message,wparam,lparam,hwnd);
for i,iv in mrows(_STIMERS,1) do
begin
v := _STIMERS[iv];
if v is class(TCustomTimer)then if v.tproc(e)then return;
end
//return _twinproc_(hwnd,message,wparam,lparam);
end
class function Sinit();override;
begin
{**
@explan(说明)初始化定时器全局 %%
**}
if not FSIDC then
begin
_STIMERS := array();
FSIDC := new tidcreater();
end
inherited;
end
function tproc(e);virtual;
begin
if e.wparam and(e.wparam=_kill0)then
begin
CallMessgeFunction(FOntimer,self(true),e);
return 1;
end
end
property Interval:integer read FInterval write SetInterval;
property Ontimer:eventhandler read FOntimer write FOntimer;
property Enabled:bool read FStart Write SetEnabled;
property id read FID;
function publishs();override;
begin
return array("name","interval","ontimer");
end
{**
@param(Interval)(integer) 设置运行间隔 %%
@param(Ontimer)(funtion[self,tuieventbase]) 定时调度 %%
@param(Enabled)(bool) 是否已经启动 %%
**}
end
type teditable=class(TSLUIBASE)
private
FInsertState;
@ -2579,8 +2381,9 @@ type TCustomListBoxbase=class(TCustomScrollControl)
if e.Button()=mbLeft then
begin
CallMessgeFunction(onclick,o,e);
e.skip := true;
end
e.skip := true;
end
function MouseDown(o,e);override;
begin
@ -3976,13 +3779,9 @@ type TcustomToolBar=class(TCustomControl)
FBtnRects := array();
FTipWnd := new TTipWnd(self);
FTipWnd.Parent := self;
global G_T_TTIMER_;
if G_T_TTIMER_ then
begin
FTimer := createobject(G_T_TTIMER_,self);
FTimer.Interval := 200;
FTimer.Ontimer := thisfunction(DoTimerShowTip);
end
FTimer := new TCustomTimer(self);
FTimer.Interval := 200;
FTimer.Ontimer := thisfunction(DoTimerShowTip);
end
function MouseDown(o,e);override;
begin
@ -4851,6 +4650,8 @@ type TTipWnd=class(TCustomControl) //tip
FSize;
end
initialization
global G_T_TTIMER_;
G_T_TTIMER_ := class(TCustomTimer);
{$ifdef linux}
class(tUIglobalData).uisetdata("G_T_TTIMER_",class(TCustomTimer));
{$endif}
end.

94
funcext/tvclib/uvcpropertytypespersistence.tsf
View File

@ -1,6 +1,6 @@
Unit UVCPropertyTypesPersistence;
interface
uses utslvclauxiliary;
uses utslvclauxiliary;//,utslvclgdi;
{**
@explan(说明) 可视控件属性处理库 %%
**}
@ -926,7 +926,7 @@ type TPropertyType=class
function FormatTMF(d);virtual;
begin
{**
@explan(说明)修改表格数据转换为tfm文件数据 %%
@explan(说明)修改表格数据转换为tmf文件数据 %%
**}
return d;
end
@ -1182,7 +1182,7 @@ type TPropertyaction=class(TPropertyVarible) //action
begin
return "taction";
end
function IfComponent();virtual;
function IfComponent();override;
begin
{**
@explan(说明) 是否为控件%%
@ -1190,19 +1190,19 @@ type TPropertyaction=class(TPropertyVarible) //action
return true;
end
end
type TPropertyTray=class(TPropertyaction) //action
type TPropertyTray=class(TPropertyaction) //托盘
Function EditType();override;
begin
return "ttray";
end
end
type TPropertyPopupMenu=class(TPropertyaction) //action
type TPropertyPopupMenu=class(TPropertyaction) //右键菜单
Function EditType();override;
begin
return "tpopupmenu";
end
end
type TPropertyMainMenu=class(TPropertyaction) //action
type TPropertyMainMenu=class(TPropertyaction) //主菜单
Function EditType();override;
begin
return "tmainmenu";
@ -1216,21 +1216,21 @@ type TPropertyMainMenu=class(TPropertyaction) //action
return false;
end
end
type TPropertyImagelist=class(TPropertyaction) //action
type TPropertyImagelist=class(TPropertyaction) //imagelist
Function EditType();override;
begin
return "tcontrolimagelist";
end
end
type TPropertyImagesData=class(TPropertyType)
type TPropertyImagesData=class(TPropertyType) //imagedata,作为imagelist的数据
Function EditType();override;
begin
return "imagesdata";
end
function TmfToNode(d);override;
begin
global G_T_BITMAP_;
if not G_T_BITMAP_ then return ;
cbmp := class(tUIglobalData).uigetdata("G_T_BITMAP_");
if not cbmp then return ;
if ifstring(d)then
begin
r := HexFormatStrToTsl(d);
@ -1239,7 +1239,7 @@ type TPropertyImagesData=class(TPropertyType)
ret := array();
for i,v in r["items"] do
begin
bmp := createobject(G_T_BITMAP_);
bmp := createobject(cbmp);
bmp.Readvcon(v);
ret[i]:= bmp;
end
@ -1276,8 +1276,8 @@ type TPropertyImagesData=class(TPropertyType)
end
function ReadTMF(d,o);override;
begin
global G_T_BITMAP_;
if not G_T_BITMAP_ then return ;
cbmp := class(tUIglobalData).uigetdata("G_T_BITMAP_");
if not cbmp then return ;
if ifstring(d)then
begin
r := HexFormatStrToTsl(d);
@ -1286,7 +1286,7 @@ type TPropertyImagesData=class(TPropertyType)
ret := array("type":"bmps");
for i,v in r["items"] do
begin
bmp := createobject(G_T_BITMAP_);
bmp := createobject(cbmp);
bmp.Readvcon(v);
ret["items"][i]:= bmp;
end
@ -1302,12 +1302,12 @@ type TPropertyBitmap=class(TPropertyType)
end
function TmfToNode(d);override;
begin
global G_T_BITMAP_;
if not G_T_BITMAP_ then return ;
cbmp := class(tUIglobalData).uigetdata("G_T_BITMAP_");
if not cbmp then return ;
if ifstring(d)and d then
begin
tar := HexFormatStrToTsl(d);
bmp := createobject(G_T_BITMAP_);
bmp := createobject(cbmp);
bmp.Readvcon(tar);
return bmp;
end
@ -1319,11 +1319,9 @@ type TPropertyBitmap=class(TPropertyType)
@explan(说明)修改表格数据转换为tmf文件数据 %%
**}
reti := "";
global G_T_BITMAP_;
if d is G_T_BITMAP_ then
cbmp := class(tUIglobalData).uigetdata("G_T_BITMAP_");
if d is cbmp then
begin
echo " \r\nglob bitmap===";
reti := TSlToHexFormatStr(d.tovcon);
end
ret := "{ ";
@ -1343,14 +1341,14 @@ type TPropertyIcon=class(TPropertyType)
end
function TmfToNode(d);override;
begin
global G_T_ICON_;
if not G_T_ICON_ then return ;
cico := class(tUIglobalData).uigetdata("G_T_ICON_");
if not cico then return ;
if ifstring(d)and d then
begin
dd := HexFormatStrToTsl(d);
if ifarray(dd)then
begin
r := createobject(G_T_ICON_);
r := createobject(cico);
r.Readvcon(dd);
return r;
end
@ -1362,8 +1360,8 @@ type TPropertyIcon=class(TPropertyType)
@explan(说明)修改表格数据转换为tmf文件数据 %%
**}
reti := "";
global G_T_ICON_;
if G_T_ICON_ and (d is G_T_ICON_) then
cico := class(tUIglobalData).uigetdata("G_T_ICON_");
if cico and (d is cico) then
begin
reti := TSlToHexFormatStr(d.tovcon());
end
@ -1563,7 +1561,7 @@ type TPropertyAnchors=class(UniObjectMember)
function create();
begin
akTop := 0;
akTop := 1;
akLeft := 1;
akRight := 2;
akBottom := 3;
end
@ -1995,6 +1993,25 @@ begin
end
return r;
end
function RegComponentPropertyType(v);
begin
//return ;
global g_ComponentPropertyType_a;
if not ifarray(g_ComponentPropertyType_a)then g_ComponentPropertyType_a := array();
if v is class(TPropertyType) then
begin
n := v.EditType();
if n and ifstring(n)then
begin
g_ComponentPropertyType_a[n]:= v; //createobject(v,0);
end
end
end
function GetComponentPropertyType(n);
begin
global g_ComponentPropertyType_a;
if ifstring(n)and ifarray(g_ComponentPropertyType_a)then return g_ComponentPropertyType_a[n];
end
function Sinitlib();
begin
types := array( //"tpropertytype",
@ -2049,28 +2066,7 @@ begin
end
//注册属性编辑
end
function RegComponentPropertyType(v);
begin
//return ;
global g_ComponentPropertyType_a;
if not ifarray(g_ComponentPropertyType_a)then g_ComponentPropertyType_a := array();
if ifobj(v)then
begin
try
n := v.EditType();
if n and ifstring(n)then
begin
g_ComponentPropertyType_a[n]:= v; //createobject(v,0);
end
except
end;
end
end
function GetComponentPropertyType(n);
begin
global g_ComponentPropertyType_a;
if ifstring(n)and ifarray(g_ComponentPropertyType_a)then return g_ComponentPropertyType_a[n];
end
function InitLib();
begin
static Sinitlib();