diff --git a/LIBCURL-TSL.dll b/LIBCURL-TSL.dll index 410f690..dde2b2e 100644 Binary files a/LIBCURL-TSL.dll and b/LIBCURL-TSL.dll differ diff --git a/MathKrnl.dll b/MathKrnl.dll index 5635ef7..b82bf3d 100644 Binary files a/MathKrnl.dll and b/MathKrnl.dll differ diff --git a/Mod_TSL24.dll b/Mod_TSL24.dll index 9c4fb76..a05fddf 100644 Binary files a/Mod_TSL24.dll and b/Mod_TSL24.dll differ diff --git a/TSCrypt.dll b/TSCrypt.dll index a942919..a5d68a9 100644 Binary files a/TSCrypt.dll and b/TSCrypt.dll differ diff --git a/TSLDebugModule.dll b/TSLDebugModule.dll index 790e8ec..56c5cec 100644 Binary files a/TSLDebugModule.dll and b/TSLDebugModule.dll differ diff --git a/TSLInterp.dll b/TSLInterp.dll index 622ca4c..c4ea5cf 100644 Binary files a/TSLInterp.dll and b/TSLInterp.dll differ diff --git a/TSLPlugin.dll b/TSLPlugin.dll index f7945b1..fa518fb 100644 Binary files a/TSLPlugin.dll and b/TSLPlugin.dll differ diff --git a/designer/utslcodeeditor.tsf b/designer/utslcodeeditor.tsf index a3f77f7..ecc2b16 100644 --- a/designer/utslcodeeditor.tsf +++ b/designer/utslcodeeditor.tsf @@ -1523,20 +1523,6 @@ type TPageEditerItem=class(TPageItem) FEditer.ChangedFlag := false; if not FTslSynText then return; if not(s)then return; - {r := tsl_tokenizeex_2_(s,1); - cs := r["class"]; - if ifarray(cs)and cs[0]then - begin - lcs1 := lowercase(cs[0]); - if lcs1 in array("tdcreateform","tdcreatepanel")then - begin - try - if not FTslParser then FTslParser := new ttslscripparser(); #! end - except - end; - return; //返回 - end - end} if not FTslParser then FTslParser := new ttslscripparser(); #! end //FTslParser := nil; end @@ -1858,7 +1844,6 @@ type TEditer=class(TCustomcontrol) // "charset":0,"outprecision":0,"clipprecision":0,"quality":1,"pitchandfamily":1,"facename":"Courier New","color":0); FTslDebug := new TTslDebug(self); FFindListWnd := new TFindListWnd(self); - //FCodeMap := new TTslCodeMap(self); FFileopen := new TOpenFileADlg(self); FFileSave := new TSavefileADlg(self); FFileopen.WndOwner := self; @@ -1873,7 +1858,6 @@ type TEditer=class(TCustomcontrol) // FFindListWnd.OnDblClick := thisfunction(FindListChoosed); FGotoLineWnd.Visible := false; ///////////////////////// - //FCodeMap.visible := false; FFindWnd.Visible := false; FFileSave.Filter := array("any":"*.*","tsl文件":"*.tsl;*.tsf"); FFileSave.Caption := "另存为"; @@ -1965,7 +1949,6 @@ type TEditer=class(TCustomcontrol) // FinCodemap.Parent := self; fcoolbar.Parent := self; FPageEditer.Parent := self; - //FCodeMap.parent := self; FGotoLineWnd.Parent := self; FFindWnd.parent := self; FFileopen.parent := self; @@ -3321,8 +3304,6 @@ type TEditer=class(TCustomcontrol) // end "代码地图(alt+m)": begin - //InitShowWndPos(FCodeMap,"cm",250,100); - //FCodeMap.ShowMap(); if FinCodemap and not(FinCodemap.Visible) then begin FinCodemap.doshow(true); @@ -3566,8 +3547,6 @@ type TEditer=class(TCustomcontrol) // end ord("M"): begin - //InitShowWndPos(FCodeMap,"cm",250,100); - //FCodeMap.ShowMap(); if FinCodemap then begin FinCodemap.doshow(1); @@ -4254,7 +4233,6 @@ type TEditer=class(TCustomcontrol) // FToolbar; FStatus; FInfoShowWnd; - //FCodeMap; FinCodemap; FListPages; FFindWnd; @@ -5263,7 +5241,7 @@ type tfincodemap = class(tcustomcontrol) end else FString := s; flistv := getblocktypes(); - if s then r := tsl_tokenizeex_2_(s,flistv); + if s then r := unit(utssvr_tsltoken_c).get_tsl_tokenizeex(s,flistv);// tsl_tokenizeex_2_(s,flistv); else r := array(); fcaretya := -1; fcaretyb := -1; @@ -5433,145 +5411,7 @@ EA5E0BB7C5850E4063EDA83420076B5E10000000049454E44AE42608200"; public FTree; end -(* -type TTslCodeMap=class(TTreeView) //tsl代码地图 - function Create(AOwner); - begin - inherited; - caption := "代码树:支持[左/右/上/下/enter]键"; - width := 400; - height := 800; - WsPopUp := true; - WsSysMenu := true; - WsSizeBox := true; - OnClose := function(o,e) - begin - o.visible := false; - e.skip := true; - if not FTreeEditer then return; - FTreeEditer.SetFocus(); - end - OnActivate := function(o,e) - begin - if not e.wparam then CodeMapLive(o,e); - {o.Visible := false; - if not FTreeEditer then return; - FTreeEditer.SetFocus();} - end - onKeyPress := thisfunction(CodeMapLive); - //OnDblClick := thisfunction(SynNodeSelected); - OnSelChanged := thisfunction(SynNodeSelected); - end - function CodeMapLive(o,e); - begin - o.Visible := false; - if not FTreeEditer then return; - FTreeEditer.SetFocus(); - end - function SynNodeSelected(o,e); - begin - //双击 - if not FTreeEditer then return; - nd := CurrentNode; - if not nd then return ; - line := nd._tag; - if line>0 then - begin - FTreeEditer.ExecuteCommand(FTreeEditer.ecGoToXY,array(line,1)); - end - end - function hasFocus();override; - begin - return true; - end - function ShowMap(); - begin - FTreeEditer := nil; - it := Owner.GetCurrentItem(); - if not it then return; - //caption := "codemap:"+it.ScriptPath; - FTreeEditer := it.FEditer; - s := FTreeEditer.Text; - if FString <> s then - begin - FString := s; - LoadString(s,FTreeEditer.CaretY); - end else - GoToTheNode(FTreeEditer.CaretY); - end - function Recycling();override; - begin - inherited; - FTempNodes := nil; //节点 - FEditer := nil; - FString := nil; - FTreeEditer := nil; - end - private - function LoadString(s,line); - begin - { 代码块快类型 - #define Block_TypeClass 1 - #define Block_Function 2 - #define Block_Statements 4 - #define Block_If 8 - #define Block_Else 16 - #define Block_SubCase 32 - #define Block_Goto_Label 64 - #define Block_Empty_Begin_End 128 - #define Block_Try 256 - #define Block_NeedSql 512 - #define Block_UnitStruct 1024 - } - if s then r := tsl_tokenizeex_2_(s,1+2+4+8+16+32+256+1024+2048+4096); - else r := array(); - RootNode.RecyclingChildren(); - FTempNodes := array(); - ScriptDelBlocks(r["blcks"],str2array(s,"\r\n"),self.RootNode,0); - GoToTheNode(line); - end - function GoToTheNode(line); - begin - nd := FTempNodes[0]; - for i,v in FTempNodes do - begin - if v._tag <= line then - begin - nd := v; - end else - if v._tag >= Line then - begin - SetSel(nd); - break; - end - end - Show(); - if _wapi.GetFocus()<> Handle then - begin - SetFocus(); - end - end - function ScriptDelBlocks(blcks,strs,Node,ct); - begin - if not blcks then return; - for i,v in blcks do - begin - if v["mtype"]<> 1 then - begin - cnd := CreateTreeNode(); - cnd.Caption := trim(strs[v["mbeg"]-1]); - cnd._tag := v["mbeg"]; - FTempNodes[length(FTempNodes)]:= cnd; - cnd.parent := node; - end - if not cnd then cnd := node; - ScriptDelBlocks(v["msub"],strs,cnd,ct+1); - end - end - FTempNodes; //节点 - FString; //字符串 - FTreeEditer; //编辑框 -end *) + type TListPages=class(TListBox) function Create(AOwner);override; begin diff --git a/designer/utslsynmemo.tsf b/designer/utslsynmemo.tsf index 1ae7dbe..9b0b0be 100644 --- a/designer/utslsynmemo.tsf +++ b/designer/utslsynmemo.tsf @@ -339,7 +339,7 @@ type TTSLCompletion= class(TSynCompletion) r[idx]["order"] := 0; idx++; end - gjz := tslL_getfunctions_2_(); + gjz := unit(utssvr_tsltoken_c).get_sys_functions();//tslL_getfunctions_2_(); for i,v in gjz do begin c := v+" "; @@ -400,7 +400,7 @@ type TTslSynHighLighter = class(TSynHighLighter) FKeyWords[v] := v; end FBinFunc := array(); - for i,v in tslL_getfunctions_2_() do + for i,v in unit(utssvr_tsltoken_c).get_sys_functions() do begin FBinFunc[v]:=v; end @@ -1885,7 +1885,7 @@ type TTsfFileParser = class() // s := d["value"]; if not(s and ifstring(s)) then return rt ; if errtslcode(s) then return rt; - r := tsl_tokenizeex_2_(s,1); + r := unit(utssvr_tsltoken_c).get_tsl_tokenizeex(s,1);//tsl_tokenizeex_2_(s,1); if not( r and ifarray(r)) then return rt; cls := array(); ScriptDelBlocks(r["blcks"],str2array(s,"\n"),cls); @@ -2176,7 +2176,7 @@ type TTsfFileParser = class() // r := array(); rdd := ""; end else - r := tsl_tokenizeex_2_(rdd,1); + r := unit(utssvr_tsltoken_c).get_tsl_tokenizeex(rdd,1);//tsl_tokenizeex_2_(rdd,1); end else begin r := array(); diff --git a/designer/utslvcldebuger.tsf b/designer/utslvcldebuger.tsf index b99d5a0..69f1b9a 100644 --- a/designer/utslvcldebuger.tsf +++ b/designer/utslvcldebuger.tsf @@ -1549,7 +1549,7 @@ type TTslDebuga=class(TCustomControl) FRuningfile := item.OrigScriptPath; // %% E:\TSUIGROUP\script\tgdb.tsl%%; FDebugtsfs["__main__"]:= FRuningfile; ls := item.FEditer.lines; - d := tsl_tokenizeex_2_(item.FEditer.Text,0xffff); + d := unit(utssvr_tsltoken_c).get_tsl_tokenizeex(item.FEditer.Text,0xffff);//tsl_tokenizeex_2_(item.FEditer.Text,0xffff); for i,v in d["blcks"] do begin s := ls.GetStringByIndex(v["mbeg"]-1); diff --git a/designer/utslvcldesigner.tsf b/designer/utslvcldesigner.tsf index 37c1cea..06b4d56 100644 --- a/designer/utslvcldesigner.tsf +++ b/designer/utslvcldesigner.tsf @@ -2071,10 +2071,11 @@ end function staticInit(); begin global g_orig_lib_path; + unit(utssvr_api_c).get_tssvr_api_c(); np := getdesignerpath()+"dcmps"+ioFileseparator(); CreateDirWithFileName(np+"1.txt"); - g_orig_lib_path := tsl_getlibpath_()+";"+Getfuncextdir(); - tsl_setlibpath_( np+";"+g_orig_lib_path); + g_orig_lib_path := get_self_libpath()+";"+Getfuncextdir();//tsl_getlibpath_() + set_self_libpath( np+";"+g_orig_lib_path);//tsl_setlibpath_ ini := static getdesginerini(); //class(TDSocketServer),class(TDSocketClient), //注册的componet diff --git a/funcext/tvclib/cstructurelib.tsf b/funcext/tvclib/cstructurelib.tsf index 111ee3e..415c85e 100644 --- a/funcext/tvclib/cstructurelib.tsf +++ b/funcext/tvclib/cstructurelib.tsf @@ -1636,7 +1636,7 @@ type t_mem_mgr = class() begin if _tool then return _tool.writestr(p,v); - memcpy2(p,v,strlen1(v)); + memcpy2(p,v+"\0",strlen1(v)+1); return 1; end function writeshort(p,v); @@ -2143,7 +2143,7 @@ begin end function is_validate_type(tp); begin - return array("uint":1,"char":1,"float":1,"double":1,"int":1,"intptr":1,"pointer":1,"int64":1,"byte":1,"short":1,"char*":1,"user*":1)[tp]; + return array("uint":1,"char":1,"float":1,"double":1,"int":1,"intptr":1,"pointer":1,"int64":1,"byte":1,"short":1,"char*":1,"user*":1,"long":1)[tp]; end function tslarraytocstructcalc(data,alim,bsi,ssize); //计算对其长度 begin @@ -2190,7 +2190,7 @@ begin if not ifnumber(alim)then begin {$ifdef linux} - alim := 4; + alim := 8; {$else} alim := 8; {$endif} diff --git a/funcext/tvclib/tslvcl.tsf b/funcext/tvclib/tslvcl.tsf index fb24c72..739a62e 100644 --- a/funcext/tvclib/tslvcl.tsf +++ b/funcext/tvclib/tslvcl.tsf @@ -4868,14 +4868,9 @@ type TThreadWorker =class(TCustomThreadworker) @explan(说明) 工作线程 %% **} uses uvclthreadworker; - function create(s,libs,declaration); + function create(s); begin inherited; - end - protected - function Check_TslCode(FScript,err);override; - begin - return CheckTslCode(FScript,err); end end type tworkerctl =class(tcomponent) //工作线程封装 @@ -4894,7 +4889,7 @@ type tworkerctl =class(tcomponent) // if fworker then return true; if ifstring(FScript) and FScript then begin - fworker := new TThreadWorker(FScript,nil,nil); + fworker := new TThreadWorker(FScript); fworker.componet := self(true); fworker.OnMessage := FOnMessage; fworker.onerror := FOnError; @@ -5880,19 +5875,6 @@ type Ttfm2Component = class(TTmfParser) end return r; end - function GetExeScriptPath(); - begin - {$ifdef linux} - p := tsl_getcurrentdir_(); - return p+ioFileseparator()+SysParamstr(0); - {$endif} - pth2 := formatpath(sysparamstr(0)); - if pth2[2]=":" then return pth2; - s := ""; - setlength(s,1024); - N := GetCurrentDirectoryA(1023,s); - return s[1:N]+ioFileseparator()+SysParamstr(0); - end public class function RegisterComponentType(n,typ); begin @@ -6105,18 +6087,11 @@ type Ttfm2Component = class(TTmfParser) end function GetLibPaths(); //获得libpath begin - p := tsl_getlibpath_(); + unit(utssvr_api_c).get_tssvr_api_c(); + p := get_self_libpath(); if not p then return array(); - FCurrentp := ""; - {$ifdef linux} - FCurrentp := tsl_getcurrentdir_(); - {$else} - s := ""; - setlength(s,1024); wapi := gettswin32api(); - N := wapi.GetCurrentDirectoryA(1023,s); - FCurrentp := s[1:N]; - {$endif} + FCurrentp := wapi.get_current_directory(); FCurrentp1 := ""; iofp := ioFileseparator(); for i:= length(FCurrentp)-1 downto 1 do diff --git a/funcext/tvclib/ugtkinterface.tsf b/funcext/tvclib/ugtkinterface.tsf index b1b19ad..4852786 100644 --- a/funcext/tvclib/ugtkinterface.tsf +++ b/funcext/tvclib/ugtkinterface.tsf @@ -17,7 +17,40 @@ type tgtkeventobject =class(tgtk_ctl_object) //gtk inherited; end end - +type GSourceFuncs=class(tslcstructureobj) //gsourcefuncs + private + static SSTRUCT; + function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("prepare","intptr",0), + ("check","intptr",0), + ("dispatch","intptr",0), + ("finalize","intptr",0))); + return SSTRUCT; + end + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + function prepare(source:pointer;tout:integer):integer;cdecl; + begin + return 1; + end + function check(source:pointer):integer;cdecl; + begin + return true; + end + function dispatch(source:pointer;callback:pointer;user_data:integer):integer;cdecl; + begin + return true; + end + procedure finalize(source);cdecl; + begin + + end +end type tsgtkapi = class(tgtkapis) function AnsiToWidChar(c); begin @@ -403,6 +436,10 @@ type tsgtkapi = class(tgtkapis) end end end + function GetWindow(wd,t); //获得窗口,需要实现 + begin + return 0; + end function GetParent(h); //获得父窗口 begin if not IsGtkWidget(h) then return 0; @@ -2928,6 +2965,7 @@ type tsgtkapi = class(tgtkapis) g_object_set_data(h,"width_c",nWidth); g_object_set_data(h,"heigt_c",nHeight); gtk_widget_set_size_request(h,nWidth,nHeight); + gtk_window_resize(h,nWidth,nHeight); end gtk_window_set_transient_for(h,pw); return h; @@ -3672,18 +3710,23 @@ type tgtkapis = class() //gtk begin if fileexists("","/usr/bin/zenity") then begin - tsl_gtk_execsystem(format('zenity --file-selection --filename="%s" &',p)); + tsl_gtk_exec_system(format('zenity --file-selection --filename="%s" --file-selection --multiple &',p)); return 1;// end if fileexists("","/usr/bin/caja") then begin - tsl_gtk_execsystem(format('caja "%s" &',p)); + tsl_gtk_exec_system(format('caja "%s" &',p)); return 1; end - tsl_gtk_execsystem(format('nautilus "%s" &',p)); + tsl_gtk_exec_system(format('nautilus "%s" &',p)); return 1; end end + function tsl_gtk_exec_system(cmd) ; + begin + _f_ := static function(cmd:string):integer;external getfuncptrbyname("libc","system"); + return ##_f_(cmd); + end /////////////////////////////pipe process///////////执行程序相关///////////////////////////// //function tsl_gtk_closehandle(p:pointer):integer;cdecl;external "plugin/libTSLUIL.so"; //function tsl_gtk_pipread(p:pointer;var msg:string;ct:integer):integer;cdecl;external "plugin/libTSLUIL.so"; @@ -3850,11 +3893,16 @@ type tgtkapis = class() //gtk _f_ := static procedure(w:pointer;cf:integer);cdecl;external getfuncptrbyname(0,functionname()); return ##_f_(w,cf); end - function gtk_window_get_focus(w:pointer):pointer; + function gtk_window_get_focus(w:pointer):pointer; //GdkX11 – 3.0 begin _f_ := static function(w:pointer):pointer;cdecl;external getfuncptrbyname(0,functionname()); return ##_f_(w); end + function gdk_x11_window_get_xid(wd:pointer); // + begin + _f_ := static function(wd:pointer):pointer;cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(wd); + end procedure gtk_widget_grab_focus(w:pointer); begin _f_ := static procedure(w:pointer);cdecl;external getfuncptrbyname(0,functionname()); @@ -4110,6 +4158,11 @@ type tgtkapis = class() //gtk _f_ := static procedure(d:pointer; screen:string;var x :integer;var Y:integer;msk:string); cdecl;external getfuncptrbyname(0,functionname()); return ##_f_(d,screen,x,Y,msk); end + procedure gdk_set_allowed_backends(backends:string); + begin + _f_ := static procedure(backends:string); cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(backends); + end function gdk_display_get_default():pointer; begin _f_ := static function():pointer;cdecl;external getfuncptrbyname(0,functionname()); @@ -4188,11 +4241,26 @@ type tgtkapis = class() //gtk _f_ := static procedure(argc:string;argcv:string);cdecl;external getfuncptrbyname(0,functionname()); return ##_f_(argc,argcv); end + function gtk_get_current_event_time():integer; + begin + _f_ := static function():integer;cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(); + end + function gtk_get_binary_age():integer; + begin + _f_ := static function():integer;cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(); + end procedure gtk_main (); begin _f_ := static procedure();cdecl;external getfuncptrbyname(0,functionname()); return ##_f_(); end + procedure gtk_main_quit(); + begin + _f_ := static procedure();cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(); + end function gtk_mainidle(idledata); begin //idledata :=(new tcbytearray(4))._getptr_(); @@ -4201,18 +4269,97 @@ type tgtkapis = class() //gtk g_idle_remove_by_data(idledata); //删除idle return 1; end + function g_main_loop_new(ctx:pointer;is_running:integer):pointer; + begin + _f_ := static function(ctx:pointer;is_running:integer):pointer;cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(ctx,is_running); + end + function g_main_loop_quit(loop:pointer); + begin + _f_ := static procedure(loop:pointer);cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(loop); + end function g_idle_add(f:pointer;d:pointer):integer; begin _f_ := static function(f:pointer;d:pointer):integer;cdecl;external getfuncptrbyname(0,functionname()); return ##_f_(f,d); end - procedure gtk_main_quit(); + function g_idle_source_new(); begin - _f_ := static procedure();cdecl;external getfuncptrbyname(0,functionname()); + _f_ := static function():pointer;cdecl;external getfuncptrbyname(0,functionname()); return ##_f_(); + end + function g_timeout_source_new(interval); + begin + _f_ := static function(interval:integer):pointer;cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(interval); + end + function g_source_destroy(source); + begin + _f_ := static procedure(source:pointer);cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(source); + end + function g_source_unref(source); + begin + _f_ := static procedure(source:pointer);cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(source); + end + function g_source_ref(source); + begin + _f_ := static function(source:pointer):pointer;cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(source); + end + function g_source_set_can_recurse(source:pointer;cr:integer); + begin + _f_ := static procedure(source:pointer;cr:integer);cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(source,cr); + end + function g_source_attach(source:pointer;ctx:pointer):integer; + begin + _f_ := static procedure(source:pointer;func:pointer;data:pointer;notify:poiner);cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(source,func,data,notify); + end + function g_source_set_callback(source:pointer;ctx:pointer):integer; + begin + _f_ := static function(source:pointer;ctx:pointer):integer;cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(source,ctx); end - + function g_main_context_default():pointer; + begin + _f_ := static function():pointer;cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(); + end + function g_main_context_pending(gc:pointer):integer; + begin + _f_ := static function(gc:pointer):integer;cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(gc); + end + function g_main_context_iteration(gc:pointer;bk:integer):integer; + begin + _f_ := static function(gc:pointer;bk:integer):integer;cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(gc,bk); + end + function g_main_context_get_poll_func(d:pointer):pointer; + begin + _f_ := static function(d:pointer):pointer;cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(d); + end + function g_source_is_destroyed(source:pointer):integer; + begin + _f_ := static function(source:pointer):integer;cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(source); + end + function g_source_add_child_source(source:pointer;child_source:pointer); + begin + _f_ := static procedure(source:pointer;child_source:pointer);cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(source,child_source); + end + function g_source_add_poll(source:pointer;fd:pointer); + begin + _f_ := static procedure(source:pointer;fd:pointer);cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(source,fd); + end //////////////////////context/////////////////////////////// function gtk_widget_get_style_context(w:pointer):pointer; begin @@ -5773,36 +5920,7 @@ type tgtkapis = class() //gtk _f_ := static function():integer;cdecl;external getfuncptrbyname(0,functionname()); return ##_f_(); end - function gtk_get_current_event_time():integer; - begin - _f_ := static function():integer;cdecl;external getfuncptrbyname(0,functionname()); - return ##_f_(); - end - function gtk_get_binary_age():integer; - begin - _f_ := static function():integer;cdecl;external getfuncptrbyname(0,functionname()); - return ##_f_(); - end - function g_main_context_default():pointer; - begin - _f_ := static function():pointer;cdecl;external getfuncptrbyname(0,functionname()); - return ##_f_(); - end - function g_main_context_pending(gc:pointer):integer; - begin - _f_ := static function(gc:pointer):integer;cdecl;external getfuncptrbyname(0,functionname()); - return ##_f_(gc); - end - function g_main_context_iteration(gc:pointer;bk:integer):integer; - begin - _f_ := static function(gc:pointer;bk:integer):integer;cdecl;external getfuncptrbyname(0,functionname()); - return ##_f_(gc,bk); - end - function g_main_context_get_poll_func(d:pointer):pointer; - begin - _f_ := static function(d:pointer):pointer;cdecl;external getfuncptrbyname(0,functionname()); - return ##_f_(d); - end + function gtk_main_level():integer; begin _f_ := static function():integer;cdecl;external getfuncptrbyname(0,functionname()); @@ -5984,6 +6102,22 @@ type tgtkapis = class() //gtk _f_ := static function(var e:string;f:integer;ptr:pointer):pointer;cdecl;external getfuncptrbyname("libc",functionname()); return ##_f_(e,f,ptr); end + function getcwd(); + begin + s := ""; + n := 260; + setlength(s,n); + _f_ := static function(s : string ;len:integer):string;cdecl;external getdlsymaddress("libc.so.6",functionname()); + if ##_f_(s,n)=0 then return ""; + for i:= 1 to n do + begin + if s[i]="\0" then + begin + return s[1:(i-1)]; + end + end + return ""; + end function exec_command_line(cmd) //执行linux命令 begin len := 1024; @@ -9966,6 +10100,12 @@ begin _f_ := static function(argc:string;argcv:string):integer;cdecl;external getfuncptrbyname(0,functionname()); return ##_f_(argc,argcv); end +function gtk_disable_setlocale(); +begin + _f_ := static procedure();cdecl;external getfuncptrbyname(0,functionname()); + return ##_f_(); +end + function signal_connect_data(instance:pointer; detailed_signal:string; c_handler:pointer;data:pointer;dd:pointer;f:integer):pointer; begin _f_ := static function(instance:pointer; detailed_signal:string; c_handler:pointer;data:pointer;dd:pointer;f:integer):pointer;cdecl;external getfuncptrbyname(0,"g_signal_connect_data"); diff --git a/funcext/tvclib/utslvclbase.tsf b/funcext/tvclib/utslvclbase.tsf index 0e92d45..528b874 100644 --- a/funcext/tvclib/utslvclbase.tsf +++ b/funcext/tvclib/utslvclbase.tsf @@ -20,7 +20,19 @@ uses uwindowsinterface; 3. 添加了部分结构体定义到成员变量 4. 下面的external函数的win32api可以在msdn中查找具体用法 **} - public + public + function get_current_directory()//获取当前环境路径 + begin + {$ifdef linux} + return getcwd(); + {$else} + s := ""; + setlength(s,1024); + N := GetCurrentDirectoryA(1023,s); + if n>0 then return s[1:N]; + return ""; + {$endif} + end function GetScreenRect(p); begin {** diff --git a/funcext/tvclib/utslvclcef.tsf b/funcext/tvclib/utslvclcef.tsf index 72a1276..b206f9e 100644 --- a/funcext/tvclib/utslvclcef.tsf +++ b/funcext/tvclib/utslvclcef.tsf @@ -57,7 +57,7 @@ type tcefowner = class(tcustomcontrol) fcefapp := new cef_app_t(); fappsetting := new cef_settings_t(); tp := unit(utslvclauxiliary).gettemppath(); - fappsetting.log_file := tp+"ceflogfile-"+datetostr(date())+".log"; + fappsetting.log_file := tp+"-ceflogfile-"+datetostr(date())+".log"; //fappsetting.browser_subprocess_path := %% F:\cef_105.3.39\AnalyseNG.NET\cefclient.exe%%; fappsetting.browser_subprocess_path := tslpath()+"tsl_cef_main.exe"; fappsetting.cache_path := tp+"-cefcatche-";// %% F:\cef_105.3.39\tslcache%%; diff --git a/funcext/tvclib/utslvclcefinterface.tsf b/funcext/tvclib/utslvclcefinterface.tsf index ea02687..7cfd588 100644 --- a/funcext/tvclib/utslvclcefinterface.tsf +++ b/funcext/tvclib/utslvclcefinterface.tsf @@ -313,35 +313,32 @@ end type cef_string_t=class(t_cef_stc_base) + private fdest; + function isascii(s); + begin + for i:= 1 to length(s) do + begin + if ord(s[i])>127 then return 0; + end + return 1; + end function setansi(s); begin if ifstring(s) then begin - pr := _getptr_(); - cd := cef_string_ascii_to_utf16(s,length(s),pr); - //cd := cef_string_utf8_to_utf16(us,length(us),pr); + pr := _getptr_(); + if isascii(s) then + begin + cd := cef_string_ascii_to_utf16(s,length(s),pr); + end else + begin + s1 := ansitoutf8(s); + cd := cef_string_utf8_to_utf16(s1,length(s1),pr); //改用utf8; + end end end function getasansi(); - begin - e := _getvalue_("length"); - if e>0 then - begin - pr := _getvalue_("str"); - bts := _tool.readshorts(pr,e);//ReadBytesFromPtr(pr,e*2); - s := ""; - setlength(s,e); - for i, v in bts do - begin - s[i+1] := v; - end - return s; - //return unicodetomultibyte(s,936); - end - return ""; - end - function getasansi2(); begin e := _getvalue_("length"); if e>0 then @@ -386,7 +383,7 @@ type cef_string_t=class(t_cef_stc_base) inherited; end property len index "length" read _getvalue_; - property str read getasansi2 write setansi; + property str read getasansi write setansi; public class function memsize(); begin @@ -399,6 +396,7 @@ type cef_string_t=class(t_cef_stc_base) return 0; end + end type cef_string_userfree_t = class(cef_string_t) function create(ptr); @@ -1970,7 +1968,7 @@ type cef_frame_handler_t=class(cef_handler_base) return call(c,self(true), cef_object_get(browser,class(cef_browser_t)), (old_frame?cef_object_get(old_frame,class(cef_frame_t)):0), - cef_object_get(new_frame,class(cef_frame_t)) + (new_frame?cef_object_get(new_frame,class(cef_frame_t)):0) ); end end @@ -3033,7 +3031,132 @@ type cef_life_span_handler_t=class(cef_handler_base) end end -type cef_render_process_handler_t=class(cef_contain_base) //render +type cef_v8value_t = class(cef_contain_base) + private + function structdescribe();override; + begin + return array( + ("base","user",getbasestruct()), + ("is_valid" ,"intptr",0), + ("is_undefined" ,"intptr",0), + ("is_null" ,"intptr",0), + ("is_bool" ,"intptr",0), + ("is_int" ,"intptr",0), + ("is_uint" ,"intptr",0), + ("is_double" ,"intptr",0), + ("is_date" ,"intptr",0), + ("is_string" ,"intptr",0), + ("is_object" ,"intptr",0), + ("is_array" ,"intptr",0), + ("is_array_buffer" ,"intptr",0), + ("is_function" ,"intptr",0), + ("is_promise" ,"intptr",0), + ("is_same" ,"intptr",0), + ("get_bool_value" ,"intptr",0), + ("get_int_value" ,"intptr",0), + ("get_uint_value" ,"intptr",0), + ("get_double_value" ,"intptr",0), + ("get_date_value" ,"intptr",0), + ("get_string_value" ,"intptr",0), + ("is_user_created" ,"intptr",0), + ("has_exception" ,"intptr",0), + ("get_exception" ,"intptr",0), + ("clear_exception" ,"intptr",0), + ("will_rethrow_exceptions" ,"intptr",0), + ("set_rethrow_exceptions" ,"intptr",0), + ("has_value_bykey" ,"intptr",0), + ("has_value_byindex" ,"intptr",0), + ("delete_value_bykey" ,"intptr",0), + ("delete_value_byindex" ,"intptr",0), + ("get_value_bykey" ,"intptr",0), + ("get_value_byindex" ,"intptr",0), + ("set_value_bykey" ,"intptr",0), + ("set_value_byindex" ,"intptr",0), + ("set_value_byaccessor" ,"intptr",0), + ("get_keys","intptr",0), + ("set_user_data" ,"intptr",0), + ("get_user_data" ,"intptr",0), + ("get_externally_allocated_memory" ,"intptr",0), + ("adjust_externally_allocated_memory" ,"intptr",0), + ("get_array_length" ,"intptr",0), + ("get_array_buffer_release_callback" ,"intptr",0), + ("neuter_array_buffer" ,"intptr",0), + ("get_array_buffer_byte_length" ,"intptr",0), + ("get_array_buffer_data" ,"intptr",0), + ("get_function_name" ,"intptr",0), + ("get_function_handler" ,"intptr",0), + ("execute_function" ,"intptr",0), + ("execute_function_with_context" ,"intptr",0), + ("resolve_promise" ,"intptr",0), + ("reject_promise" ,"intptr",0) + ); + end + public + function create(ptr) + begin + inherited; + end +end +type cef_v8handler_t = class(cef_contain_base) + private + function structdescribe();override; + begin + return array( + ("base","user",getbasestruct()), + ("execute","intptr",0) + ); + end + public + function create(ptr) + begin + inherited; + end + property execute index "execute" read getcallpropertybyindex write setcallpropertybyindex; + function execute_i(sf:pointer;n:pointer;obj:pointer;argc:pointer;argv:pointer;var r:pointer;excp:pointer):integer;stdcall; ///////需要扩展 + begin + n1 := new cef_string_t(n); + c := getcallback(functionname()); + if c then + begin + return true; + end + end +end +type cef_v8context_t = class(cef_contain_base) + private + function structdescribe();override; + begin + return array( + ("base","user",getbasestruct()), + ("get_task_runner","intptr",0), //self =runer + ("is_valid","intptr",0), //self + ("get_browser","intptr",0), //self + ("get_frame","intptr",0), //self + ("get_global","intptr",0),//self =_cef_v8value_t + ("enter","intptr",0), //self =int + ("exit","intptr",0), //self = int + ("is_same","intptr",0), //self that =int + ("eval","intptr",0) //self,string ,string v8**,v8except + ); + end + public + function create(ptr) + begin + inherited; + end + function get_global(); + begin + fptr := _getvalue_(functionname()); + if fptr then + begin + _f_ := function(s:pointer):pointer;stdcall;external fptr; + r := ##_f_(_getptr_()); + if r then return cef_object_get(r,class(cef_v8context_t)); + end + return 0; + end +end +type cef_render_process_handler_t=class(cef_handler_base) //render private function structdescribe();override; begin @@ -3064,8 +3187,20 @@ type cef_render_process_handler_t=class(cef_contain_base) //render return call(c,self(true)); end end + property on_context_created index "on_context_created" read getcallpropertybyindex write setcallpropertybyindex; + function on_context_created_i(sf:pointer;browser:pointer;frame:pointer;ctx:pointer):integer;stdcall; + begin + c := getcallback(functionname()); + if c then + begin + return call(c,self(true),cef_object_get(browser,class(cef_browser_t)), + cef_object_get(frame,class(cef_frame_t)), + cef_object_get(ctx,class(cef_v8context_t)) + ); + end + end end -type cef_dialog_handler_t=class(cef_contain_base) +type cef_dialog_handler_t=class(cef_handler_base) private function structdescribe();override; begin @@ -3110,7 +3245,7 @@ type cef_dialog_handler_t=class(cef_contain_base) end end end -type cef_file_dialog_callback_t=class(cef_contain_base) +type cef_file_dialog_callback_t=class(cef_handler_base) private function structdescribe();override; begin @@ -3364,7 +3499,103 @@ type cef_post_data_t=class(cef_contain_base) //property add_element index "add_element" read _getvalue_ write _setvalue_; //property remove_elements index "remove_elements" read _getvalue_ write _setvalue_; end - +type cef_task_t=class(cef_contain_base) + private + function structdescribe();override; + begin + return array( + ("base","user",getbasestruct()), + ("execute","intptr",0) + ); + end + public + function create(ptr) + begin + inherited ; + if not (ptr>0 or ptr<0) then + begin + fexecinstance := makeinstance(thisfunction(execute)); + _setvalue_("execute",fexecinstance); + end + end + function execute(s:pointer); + begin + if fonexecute then call(fonexecute,self); + end + property onexecute read fonexecute write fonexecute; + function destroy();override; + begin + if fexecinstance then deleteinstance(fexecinstance); + fexecinstance := 0; + inherited; + end + private + [weakref]fonexecute; + fexecinstance; +end +type cef_task_runer_t=class(cef_contain_base) + private + function structdescribe();override; + begin + return array( + ("base","user",getbasestruct()), + ("is_same","intptr",0), + ("belongs_to_current_thread","intptr",0), + ("belongs_to_thread","intptr",0), + ("post_task","intptr",0), + ("post_delayed_task","intptr",0) + ); + end + public + function create(ptr) + begin + inherited ; + end + /// Returns true (1) if this object is pointing to the same task runner as + function is_same(that); + begin + ptr := _getptr_(); + fptr := _getvalue_(functionname()); + _f_ := function(s:pointer;t:pointer):integer;stdcall;external fptr; + return ##_f_(ptr,that); + end + /// Returns true (1) if this task runner belongs to the current thread. + function belongs_to_current_thread(); + begin + ptr := _getptr_(); + fptr := _getvalue_(functionname()); + _f_ := function(s:pointer):integer;stdcall;external fptr; + return ##_f_(ptr); + end + /// Returns true (1) if this task runner is for the specified CEF thread. + function belongs_to_thread(tid); + begin + ptr := _getptr_(); + fptr := _getvalue_(functionname()); + _f_ := function(s:pointer;tid:integer):integer;stdcall;external fptr; + return ##_f_(ptr,tid); + end + /// Post a task for execution on the thread associated with this task runner. + /// Execution will occur asynchronously. + function post_task(task); + begin + ptr := _getptr_(); + fptr := _getvalue_(functionname()); + _f_ := function(s:pointer;task:pointer):integer;stdcall;external fptr; + return ##_f_(ptr,task); + end + /// Post a task for delayed execution on the thread associated with this task + /// runner. Execution will occur asynchronously. Delayed tasks are not + /// supported on V8 WebWorker threads and will be executed without the + /// specified delay. + function post_delayed_task(task,delay_ms); + begin + ptr := _getptr_(); + fptr := _getvalue_(functionname()); + _f_ := function(s:pointer;task:pointer;delay_ms:int64):integer;stdcall;external fptr; + return ##_f_(ptr,task,delay_ms); + end +end type cef_request_t=class(cef_contain_base) //cef_request_capi.h private function structdescribe();override; @@ -3748,7 +3979,7 @@ type cef_command_line_t=class(cef_contain_base) return u.get_values(); end end -type cef_app_t=class(cef_contain_base) //cef_app_capi.h +type cef_app_t=class(cef_contain_hander) //cef_app_capi.h private function structdescribe();override; begin @@ -3785,15 +4016,12 @@ type cef_app_t=class(cef_contain_base) //cef_app_capi.h // property on_register_custom_schemes index "on_register_custom_schemes" read _getvalue_ write _setvalue_; // property get_resource_bundle_handler index "get_resource_bundle_handler" read _getvalue_ write _setvalue_; // property get_browser_process_handler index "get_browser_process_handler" read _getvalue_ write _setvalue_; - property get_render_process_handler index "get_render_process_handler" read getcallpropertybyindex write setcallpropertybyindex; - procedure get_render_process_handler_i(sf:pointer);stdcall; + property render_process_handler index "get_render_process_handler" read clientgethandler write clientsethandler; + function get_render_process_handler(s:pointer):pointer;stdcall; begin - c := getcallback(functionname()); - if c then - begin - return call(c,self(true)); - end - end + o := clientgethandler(functionname()); + if o then return o._getptr_(); + end end type cef_bounds_t = class(t_cef_stc_base) @@ -3825,26 +4053,30 @@ type cef_window_info_t=class(cef_contain_base) fboundsaddr; function structdescribe();override; begin +{$ifdef linux} + return array( + ("window_name","user",getcefstr16struct()), + ("bounds","user",getcefboundsstruct()), + ("parent_window","intptr",0), + ("windowless_rendering_enabled","int",0), + ("shared_texture_enabled","int",0), + ("external_begin_frame_enabled","int",0), + ("window","intptr",0) + ); + +{$else} return array( -{$ifdef linux} -{$else} ("ex_style","int",0), -{$endif} ("window_name","user",getcefstr16struct()), -{$ifdef linux} -{$else} ("style","int",1442906112), -{$endif} ("bounds","user",getcefboundsstruct()), ("parent_window","intptr",0), -{$ifdef linux} -{$else} ("menu","intptr",0), -{$endif} ("windowless_rendering_enabled","int",0), ("shared_texture_enabled","int",0), ("external_begin_frame_enabled","int",0), ("window","intptr",0)); +{$endif} end function getbounds(); @@ -4120,33 +4352,10 @@ type cef_browser_settings_t=class(cef_contain_base) //cef_types.h property chrome_status_bubble index "chrome_status_bubble" read _getvalue_ write _setvalue_; property chrome_zoom_bubble index "chrome_zoom_bubble" read _getvalue_ write _setvalue_; end -type cef_client_t=class(cef_contain_base) //cef_client_capi.h +type cef_contain_hander = class(cef_contain_base) private fclienthanders ; - function structdescribe();override; - begin - return array( - ("base","user",getbasestruct()), - ("get_audio_handler","intptr",0), - ("get_command_handler","intptr",0), - ("get_context_menu_handler","intptr",0), - ("get_dialog_handler","intptr",0), - ("get_display_handler","intptr",0), - ("get_download_handler","intptr",0), - ("get_drag_handler","intptr",0), - ("get_find_handler","intptr",0), - ("get_focus_handler","intptr",0), - ("get_frame_handler","intptr",0), - ("get_permission_handler","intptr",0), - ("get_jsdialog_handler","intptr",0), - ("get_keyboard_handler","intptr",0), - ("get_life_span_handler","intptr",0), - ("get_load_handler","intptr",0), - ("get_print_handler","intptr",0), - ("get_render_handler","intptr",0), - ("get_request_handler","intptr",0), - ("on_process_message_received","intptr",0)); - end + protected function clientgethandler(idx); begin return fclienthanders[idx]; @@ -4171,12 +4380,12 @@ type cef_client_t=class(cef_contain_base) //cef_client_capi.h if o.getcallcount() then begin fclienthanders[idx] := o; - f := findfunction(idx); + f := findfunction(idx,self(true)); _setvalue_(idx,getinstance(f)); end else begin fclienthanders[idx] := o; - _setvalue_(idx,getinstance(f)); + _setvalue_(idx,0); //getinstance(f) end end else //移除 begin @@ -4195,6 +4404,40 @@ type cef_client_t=class(cef_contain_base) //cef_client_capi.h begin return gethandler(n,c)._getptr_(); end + public + function create(ptr); + begin + fclienthanders := array(); + inherited; + end + +end +type cef_client_t=class(cef_contain_hander) //cef_client_capi.h + private + function structdescribe();override; + begin + return array( + ("base","user",getbasestruct()), + ("get_audio_handler","intptr",0), + ("get_command_handler","intptr",0), + ("get_context_menu_handler","intptr",0), + ("get_dialog_handler","intptr",0), + ("get_display_handler","intptr",0), + ("get_download_handler","intptr",0), + ("get_drag_handler","intptr",0), + ("get_find_handler","intptr",0), + ("get_focus_handler","intptr",0), + ("get_frame_handler","intptr",0), + ("get_permission_handler","intptr",0), + ("get_jsdialog_handler","intptr",0), + ("get_keyboard_handler","intptr",0), + ("get_life_span_handler","intptr",0), + ("get_load_handler","intptr",0), + ("get_print_handler","intptr",0), + ("get_render_handler","intptr",0), + ("get_request_handler","intptr",0), + ("on_process_message_received","intptr",0)); + end protected function aftercreate(flg);override; begin @@ -6014,44 +6257,94 @@ type cef_browser_host_t=class(cef_contain_base) return ##f(_getptr_()); end end +type cef_MainMessageLoopStd_t=class + function run(); + begin + _f_ := static procedure();stdcall;external getceffunction("cef_run_message_loop"); + return ##_f_(); + end + function quit(); + begin + _f_ := static procedure();stdcall;external getceffunction("cef_quit_message_loop"); + return ##_f_(); + end + function PostTask(task); + begin + _f_ := static function(id:integer;task:pointer):integer;stdcall;external getceffunction("cef_post_task"); + return ##_f_(0,task); + end + function RunsTasksOnCurrentThread(); + begin + _f_ := static function(id:integer):integer;stdcall;external getceffunction("cef_currently_on"); + return ##_f_(0); + end + +end implementation -type cef_log_severity_t = class - /// +type cef_thread_id_t = class + // BROWSER PROCESS THREADS -- Only available in the browser process. + /// The main thread in the browser. This will be the same as the main + /// application thread if CefInitialize() is called with a + /// CefSettings.multi_threaded_message_loop value of false. Do not perform + /// blocking tasks on this thread. All tasks posted after + /// CefBrowserProcessHandler::OnContextInitialized() and before CefShutdown() + /// are guaranteed to run. This thread will outlive all other CEF threads. + static const TID_UI =0; + /// Used for blocking tasks like file system access where the user won't + /// notice if the task takes an arbitrarily long time to complete. All tasks + /// posted after CefBrowserProcessHandler::OnContextInitialized() and before + /// CefShutdown() are guaranteed to run. + static const TID_FILE_BACKGROUND=1; + /// Used for blocking tasks like file system access that affect UI or + /// responsiveness of future user interactions. Do not use if an immediate + /// response to a user interaction is expected. All tasks posted after + /// CefBrowserProcessHandler::OnContextInitialized() and before CefShutdown() + /// are guaranteed to run. + /// Examples: + /// - Updating the UI to reflect progress on a long task. + /// - Loading data that might be shown in the UI after a future user + /// interaction. + static const TID_FILE_USER_VISIBLE=2; + /// Used for blocking tasks like file system access that affect UI + /// immediately after a user interaction. All tasks posted after + /// CefBrowserProcessHandler::OnContextInitialized() and before CefShutdown() + /// are guaranteed to run. + /// Example: Generating data shown in the UI immediately after a click. + static const TID_FILE_USER_BLOCKING=3; + /// Used to launch and terminate browser processes. + static const TID_PROCESS_LAUNCHER=4; + /// Used to process IPC and network messages. Do not perform blocking tasks on + /// this thread. All tasks posted after + /// CefBrowserProcessHandler::OnContextInitialized() and before CefShutdown() + /// are guaranteed to run. + static const TID_IO=5; + // RENDER PROCESS THREADS -- Only available in the render process. + /// The main thread in the renderer. Used for all WebKit and V8 interaction. + /// Tasks may be posted to this thread after + /// CefRenderProcessHandler::OnWebKitInitialized but are not guaranteed to + /// run before sub-process termination (sub-processes may be killed at any + /// time without warning). + static const TID_RENDERER=6; +end +type cef_log_severity_t = class() /// Default logging (currently INFO logging). - /// - //LOGSEVERITY_DEFAULT, 0 - /// + static const LOGSEVERITY_DEFAULT = 0; /// Verbose logging. - /// - //LOGSEVERITY_VERBOSE, 1 - /// + static const LOGSEVERITY_VERBOSE =1; /// DEBUG logging. - /// - //LOGSEVERITY_DEBUG = LOGSEVERITY_VERBOSE, 1 - - /// + static const LOGSEVERITY_DEBUG = 1; /// INFO logging. - /// - //LOGSEVERITY_INFO, - - /// + static const LOGSEVERITY_INFO =2; /// WARNING logging. - /// - //LOGSEVERITY_WARNING, - /// + static const LOGSEVERITY_WARNING = 3; /// ERROR logging. - /// - //LOGSEVERITY_ERROR, - /// + static const LOGSEVERITY_ERROR = 4; /// FATAL logging. - /// - //LOGSEVERITY_FATAL, - /// + static const LOGSEVERITY_FATAL = 5; /// Disable logging to file for all messages, and to stderr for messages with /// severity less than FATAL. - /// - //LOGSEVERITY_DISABLE = 99 + static const LOGSEVERITY_DISABLE = 99; end //function IsBadReadPtr(ptr:pointer;ucb:pointer):integer;stdcall;external "Kernel32.dll" name "IsBadReadPtr"; @@ -6185,6 +6478,48 @@ begin g_cef_objects_[sptr] := obj; end end +/// +/// Returns the task runner for the current thread. Only CEF threads will have +/// task runners. An NULL reference will be returned if this function is called +/// on an invalid thread. +/// +function cef_task_runner_get_for_current_thread(); +begin + _f_ := static function():pointer;stdcall;external getceffunction(functionname()); + return ##_f_(); +end + +/// +/// Returns the task runner for the specified CEF thread. +/// +function cef_task_runner_get_for_thread(threadId); +begin + _f_ := static function(threadId:integer):pointer;stdcall;external getceffunction(functionname()); + return ##_f_(threadId); +end +/// Returns true (1) if called on the specified thread. Equivalent to using +/// cef_task_runner_t::GetForThread(threadId)->belongs_to_current_thread(). +function cef_currently_on(threadId); +begin + _f_ := static function(threadId:integer):integer;stdcall;external getceffunction(functionname()); + return ##_f_(threadId); +end +/// Post a task for execution on the specified thread. Equivalent to using +/// cef_task_runner_t::GetForThread(threadId)->PostTask(task). +/// +function cef_post_task(threadId,task); +begin + _f_ := static function(threadId:integer;task:pointer):integer;stdcall;external getceffunction(functionname()); + return ##_f_(threadId,task); +end +/// Post a task for delayed execution on the specified thread. Equivalent to +/// using cef_task_runner_t::GetForThread(threadId)->PostDelayedTask(task, +/// delay_ms). +function cef_post_delayed_task(threadId,task,delay_ms); +begin + _f_ := static function(threadId:integer;task:pointer;delay_ms:int64):integer;stdcall;external getceffunction(functionname()); + return ##_f_(threadId,task,delay_ms); +end /// Create a new cef_drag_data_t object. //CEF_EXPORT cef_drag_data_t* cef_drag_data_create(void); function cef_drag_data_create():pointer; diff --git a/funcext/tvclib/utssvr_api_c.tsf b/funcext/tvclib/utssvr_api_c.tsf new file mode 100644 index 0000000..596ede0 --- /dev/null +++ b/funcext/tvclib/utssvr_api_c.tsf @@ -0,0 +1,260 @@ +unit utssvr_api_c; +interface +function get_tssvr_api_c(); +function get_func_finder_register(); +implementation +function get_tssvr_api_c(); +begin + return static new t_tssvr_api_c(); +end +function get_func_finder_register(); +begin + return static new t_func_finder_register(); +end +type tsl_c_api_const = class() + {$ifdef linux} + static const C_TSSVRAPI="libTSSVRAPI.so"; + static const C_PLUGIN="libTSLPlugin.so"; + static const C_TSLInterp="libTSLInterp.so"; + {$else} + static const C_TSSVRAPI="TSSVRAPI.dll"; + static const C_PLUGIN="TSLPlugin.dll"; + static const C_TSLInterp="TSLInterp.dll"; + {$endif} +end +type t_func_finder_register = class(tsl_c_api_const) //函数注册类型 + function create(); + begin + t := C_TSSVRAPI; + fhookseted := false; + fhooks := array(); + end + function add_hook(f); + begin + for i,v in fhooks do + begin + if v=f then return 0; + end + fhooks[length(fhooks)] := f; + if not fhookptr then fhookptr := makeinstance(thisfunction(find_HOOK)); + if not fhookseted then TSL_InterpSetFindFunctionHook(fhookptr); + end + function del_hook(f); + begin + len := length(fhooks)-1; + for i:= 0 to len do + begin + if f=fhooks[i] then + begin + if len=0 then + begin + TSL_InterpSetFindFunctionHook(0); + fhookseted := false; + end + return 1; + end + end + end + function find_HOOK(L:pointer;iUser:string;iName:string; oResult:object):integer;cdecl; + begin + for i,_f_ in fhooks do + begin + r := ##_f_(L,iUser,iName); + if ifstring(r) and r then + begin + oResult := array("body":r); + return 1; + end + end + end + function destroy(); + begin + if fhookptr then deleteinstance(fhookptr); + fhookptr := 0; + end + private + function TSL_InterpSetFindFunctionHook(hook); + begin + c := static function(hook:pointer);cdecl;external getdlsymaddress(C_TSLInterp,functionname(1)) ; + return call(c,hook) ; + end + private + fhookseted; + fhookptr; + fhooks; +end +type t_tssvr_api_c = class(tsl_c_api_const) + function create(); + begin + t := C_TSSVRAPI; + isok := 0; + if not getglobalcache("@@tsl_c_api@@",isok) then + begin + setglobalcache("@@tsl_c_api@@","tsl_c_api"); + reg_libpath_funcs(); + end + end + class function TSL_ObjToStr(L:pointer;v:pointer):string; + begin + _f_ := static function(L:pointer;v:pointer;Topest:integer):string;cdecl;external getdlsymaddress(C_TSSVRAPI,functionname(1)); + return ##_f_(L,v,1); + end + class function TSL_DelStrm(d:pointer); + begin + _f_ := static procedure(d:pointer);cdecl;external getdlsymaddress(C_TSSVRAPI,functionname(1)); + return ##_f_(d); + end + class function TSL_ObjToStrm(L:pointer;v:pointer); + begin + _f_ := static function(L:pointer;v:pointer;PackedTable:integer;precision:integer):pointer;cdecl;external getdlsymaddress(C_TSSVRAPI,functionname(1)); + return ##_f_(L,v,0,-1); + end + class function TSL_StrmToObj(L:pointer;v:pointer;ot:pointer); + begin + _f_ := static function(L:pointer;v:pointer;ot:pointer):integer;cdecl;external getdlsymaddress(C_TSSVRAPI,functionname(1)); + return ##_f_(L,v,ot); + end + class function TS_GetGlobalL(); + begin + _f_ := static function():pointer;cdecl;external getdlsymaddress(C_TSSVRAPI,functionname(1)); + return ##_f_(); + end + //注册函数相关 + class function TSL_SetIntPtr(l:pointer;o:pointer;i:pointer); + begin + _f_ := static procedure(l:pointer;o:pointer;i:pointer);cdecl;external getdlsymaddress(C_TSSVRAPI,functionname(1)); + return ##_f_(l,o,i); + end + class function TSL_StringCheck(O:pointer):integer; + begin + _f_ := static function(o:pointer):integer;cdecl;external getdlsymaddress(C_TSSVRAPI,functionname(1)); + return ##_f_(o); + end + + class function TSL_SetInt(l:pointer;o:pointer;i:integer); + begin + _f_ := static procedure(l:pointer;o:pointer;i:integer);cdecl;external getdlsymaddress(C_TSSVRAPI,functionname(1)); + return ##_f_(l,o,i); + end + class function get_self_l_i(L:pointer; iArgs:pointer;iNum:integer; oResult:pointer):integer;cdecl; + begin + TSL_SetIntPtr(L,oResult,L); + return 1; + end + class function set_self_libpath(L:pointer; iArgs:pointer;iNum:integer; oResult:pointer):integer;cdecl; + begin + IF iNum=1 and TSL_StringCheck(iArgs) then + begin + s := TSL_AsString(iArgs); + p := TSL_Strdup(s); + TSL_SetString(L,oResult,TSL_SetLibPath(L, p)); + return 1; + end + return 0; + end + class function get_self_libpath(L:pointer; iArgs:pointer;iNum:integer; oResult:pointer):integer;cdecl; + begin + TSL_SetString(L,oResult,TSL_GetLibPath(L)); + return 1; + end + class function tslL_register(l:pointer;n:string;f:pointer); + begin + _f_ := static procedure(l:pointer;n:string;f:pointer);cdecl;external getdlsymaddress(C_PLUGIN,functionname(1)); + return ##_f_(l,n,f); + end + class function TSL_SetString(L,O,S); + begin + _f_ := static function(l:pointer;o:pointer;s:string):integer;cdecl;external getdlsymaddress(C_TSSVRAPI,functionname(1)); + return ##_f_(L,O,S); + end + class function TSL_Strdup(s):string; + begin + _f_ := static function(s:string):pointer;cdecl;external getdlsymaddress(C_TSSVRAPI,functionname(1)); + return ##_f_(s); + end + class function TSL_GetLibPath(L); + begin + _f_ := static function(L:pointer):string;cdecl;external getdlsymaddress(C_TSLInterp,functionname(1)); + return ##_f_(L); + end + class function TSL_SetLibPath(L,p); + begin + _f_ := static function(L:pointer;p:pointer):string;cdecl;external getdlsymaddress(C_TSLInterp,functionname(1)); + return ##_f_(L,p); + end + class function TSL_AsInt(O); + begin + _f_ := static function(O:pointer):integer;cdecl;external getdlsymaddress(C_TSSVRAPI,functionname(1)); + return ##_f_(o); + end + class function TSL_AsIntPtr(O); + begin + _f_ := static function(O:pointer):pointer;cdecl;external getdlsymaddress(C_TSSVRAPI,functionname(1)); + return ##_f_(o); + end + class function TSL_NumberCheck(O); + begin + _f_ := static function(O:pointer):integer;cdecl;external getdlsymaddress(C_TSSVRAPI,functionname(1)); + return ##_f_(o); + end + + class function TSL_AsString(O); + begin + _f_ := static function(O:pointer):string;cdecl;external getdlsymaddress(C_TSSVRAPI,functionname(1)); + return ##_f_(o); + end + class function TSL_SetType(L,O,t); + begin + { + #define TSL_TINT 0 //32位整数 + #define TSL_TNUMBER 1 //64位浮点 + #define TSL_TSZSTRING 2 //字符串 + #define TSL_TTABLE 5 //数组 + #define TSL_TSTRING 6 //字符串下标,仅作为数组的下标 + #define TSL_TGRAPH 8 //图形 + #define TSL_TGRAPHGROUP 9 //图形组 + #define TSL_TNIL 10 //NIL类型 + #define TSL_TBINARY 11 //二进制类型 + #define TSL_TUNKNOWN 14 //COM类型IUNKNOWN + #define TSL_TDISPATCH 15 //COM类型IDISPATCH + #define TSL_TANY 16 //TSL面向对象类型 + #define TSL_TMatrix 17 //Matrix类型,MSelect返回 + #define TSL_TINT64 20 //64位整数 + #define TSL_TClassFieldRef 22 //类成员引用 + #define TSL_TFUNCTIONSELF 23 //用SELF获得的结果 + #define TSL_TWSTRING 24 //UnicodeString + #define TSL_TCFUNCTION 25 //二进制函数指针 + #define TSL_TNONE (-1) //无类型，此类型不会被使用，仅作为特殊用途 + } + _f_ := static procedure(L:pointer;o:pointer;t:integer);cdecl;external getdlsymaddress(C_TSSVRAPI,functionname(1)); + return ##_f_(L,O,t); + end + class function TSL_GetParamRef(L,idx); + begin + _f_ := static function(L:pointer;idx:integer):pointer;cdecl;external getdlsymaddress(C_TSSVRAPI,functionname(1)); + return ##_f_(L,idx); + end + class function TSL_ReadINTPtrFromPtr(p,idx); + begin + _f_ := static function(p:pointer;idx:integer):pointer;cdecl;external getdlsymaddress(C_TSSVRAPI,functionname(1)); + return ##_f_(p,idx); + end + class function TSL_ReadTObjectFromPtr(p,idx); + begin + _f_ := static function(p:pointer;idx:integer):pointer;cdecl;external getdlsymaddress(C_TSSVRAPI,functionname(1)); + return ##_f_(p,idx); + end + private + class function reg_libpath_funcs();//注册需要的函数 + begin + tslL_register(0,"get_self_libpath",makeinstance(thisfunction(get_self_libpath),"cdecl",0)); + tslL_register(0,"set_self_libpath",makeinstance(thisfunction(set_self_libpath),"cdecl",0)); + end + // +end + +initialization + + + +end. \ No newline at end of file diff --git a/funcext/tvclib/utssvr_tsltoken_c.tsf b/funcext/tvclib/utssvr_tsltoken_c.tsf new file mode 100644 index 0000000..f20ed67 --- /dev/null +++ b/funcext/tvclib/utssvr_tsltoken_c.tsf @@ -0,0 +1,227 @@ +unit utssvr_tsltoken_c; +interface +function get_sys_functions(); +function get_tsl_tokenizeex(s,flg); +implementation +uses cstructurelib; +function get_sys_functions(); +begin + return static get_tokener().tslL_getfunctions(); +end +function get_tsl_tokenizeex(s,flg); +begin + o := get_tokener(); + o.flags := flg; + o.source := s; + return o.result(); +end +function get_tokener(); +begin + return static new t_tsltokenex2(); +end + +type t_tsltokenex2 = class() //脚本解析 + {$ifdef linux} + static const C_TSSVRAPI="libTSSVRAPI.so"; + static const C_PLUGIN="libTSLPlugin.so"; + static const C_TSLInterp="libTSLInterp.so"; + {$else} + static const C_TSSVRAPI="TSSVRAPI.dll"; + static const C_PLUGIN="TSLPlugin.dll"; + static const C_TSLInterp="TSLInterp.dll"; + {$endif} + public + function create(); + begin + //TSL_TokenizeEx2(s,flg); + fsource := array(); + fresult := array(); + skiperror := true; + fflags := 2^13-1; + end + function tslL_getfunctions();//系统函数 + begin + //return array(); + fs := 0; + cnt := 0; + _f_ := static procedure(var fs:pointer;var cnt:integer);cdecl ;external getdlsymaddress(C_PLUGIN,functionname(1)); + ##_f_(fs,ct); + return strs_ptr_to_array(fs,ct-1,1); + end + property source read fsource write set_source; + property result read get_result; + property flags read fflags write set_lags; + private + function strs_ptr_to_array(ps,n,fr); //一维字符串数组 + begin + mt := get_mem_mgr(); + r := array(); + i := 0; + if ps=0 then return r; + while true do + begin + if n>0 and i>=n then break; + p := mt.readptr(ps+8*i); + if p=0 then + begin + n := i-1; + break; + end + r[i] := mt.readstr(p); + if not fr then + mt.tfree(p); + i++; + end + return r; + end + function strs_ptr_to_array2(ps,n);//二维字符串数组 + begin + mt := get_mem_mgr(); + r := array(); + if ps=0 then return r; + i := 0; + while true do + begin + if n>0 and i>=n then break; + p := mt.readptr(ps+8*i); + if p=0 then + begin + n := i; + break; + end + r[i] := strs_ptr_to_array(p); + i++; + end + mt.tfree(ps); + return r; + end + function ints_ptr_to_array(ps,n,flg); + begin + mt := get_mem_mgr(); + r := array(); + if ps=0 then return r; + i := 0; + while true do + begin + if i>=n then break; + t := mt.readint(ps+4*i); + if t=flg then break; + r[i] := t; + i++; + end + mt.tfree(ps); + return r; + end + function TSL_InterpNewErrorInfo(); + begin + _f_ := static function():pointer;cdecl;external getdlsymaddress(C_TSLInterp,functionname(1)); + return static ##_f_(); + end + + function TSL_TokenizeEx2(); + begin + oResult := TSL_InterpNewErrorInfo(); + _f_ := static function(sc:string;skiperror:integer; + var sWords:pointer; var sUnits:pointer; + var sClasses:pointer;var sFunctions:pointer; + var iLines:pointer;var iBeginEnds:pointer; + var Dependency:pointer;var retBlocks:pointer; + var retBlockCount:integer;fflags:integer; oResult:pointer):integer;cdecl;external getdlsymaddress(C_TSLInterp,functionname(1)); + //echo _f_; + ##_f_(fsource,true,sWords,sUnits,sClasses,sFunctions,iLines,iBeginEnds,sDependency,retBlocks,retBlockCount,fflags,oResult); + fresult := array(); + fresult["words"] :=strs_ptr_to_array(sWords); + fresult["units"] :=strs_ptr_to_array(sUnits); + fresult["class"] :=strs_ptr_to_array(sClasses); + n := 0; + fresult["functions"] := strs_ptr_to_array2(sFunctions,n); + fresult["lines"] := ints_ptr_to_array(iLines,n); + fresult["linebegend"] := ints_ptr_to_array(iBeginEnds,nil,-1); + fresult["dep"] := strs_ptr_to_array(sDependency); + fresult["blcks"] := getblicks(retBlocks,retBlockCount); + end + function getblicks(ptr,n); + begin + r := array(); + if ptr=0 then return r; + mt := get_mem_mgr(); + for i := 0 to n-1 do + begin + p := mt.readptr(ptr+i*8); + bki := new BlockForEditor(p); + r[i,"mtype"] := bki._getvalue_("mType"); + r[i,"mbeg"] := bki._getvalue_("mBeg"); + r[i,"mend"] := bki._getvalue_("mEnd"); + ct := bki._getvalue_("mSubs"); + r[i,"msubs"] := ct; + if ct>0 then + r[i,"msub"] := getblicks(bki._getvalue_("mSub"),ct); + end + return r; + end + function get_result(); + begin + if ifnil(fresult) then + begin + TSL_TokenizeEx2(); + end + return fresult; + end + function set_source(s); + begin + if fsource<>s and ifstring(s) then + begin + fsource := s; + fresult := nil; + end + end + function set_lags(f); + begin + if f>0 and f<>fflags then + begin + fflags := f; + fresult := nil; + end + end + private + fsource; + fflags; + fresult; + private + static const Block_TypeClass = 1; + static const Block_Function = 2; + static const Block_Statements = 4; + static const Block_If = 8; + static const Block_Else = 16; + static const Block_SubCase = 32; + static const Block_Goto_Label = 64; + static const Block_Empty_Begin_End = 128; + static const Block_Try = 256; + static const Block_NeedSql = 512; + static const Block_UnitStruct = 1024; + static const Block_Propertys = 2048; + static const Block_Fields = 4096; +end +type BlockForEditor=class(tslcstructureobj) + public + function create(ptr) + begin + inherited create(getstruct(),ptr); + end + private + static SSTRUCT; + class function getstruct() + begin + if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array( + ("mType","int",0), + ("mBeg","int",0), + ("mEnd","int",0), + ("mSubs","int",0), + ("mFolded","int",0), //这个字段什么意思 + ("mSub","intptr",0), + ("Clear","intptr",0) //cptr := _getvalue_("Clear"); f := procedure();cdecl;external cptr; + )); + return SSTRUCT; + end +end +end. \ No newline at end of file diff --git a/funcext/tvclib/uvclthreadworker.tsf b/funcext/tvclib/uvclthreadworker.tsf index c905c2a..e9c8307 100644 --- a/funcext/tvclib/uvclthreadworker.tsf +++ b/funcext/tvclib/uvclthreadworker.tsf @@ -1,320 +1,181 @@ unit uvclthreadworker; -{** - @explan(说明)支持工作线程 - 注意:工作线程中仅仅支持运算,不支持窗口的操作, -**} -//20210902 添加未初始化之前postmessage的缓存 interface uses cstructurelib; -function RunThreadWorkerClient(this); //运行子任务 -function RunThreadWorkerHost(); //分发worker消息 -type tworkerclient = class(TArray) -{** - @explan(说明) 工作线程 %% -**} - function Create(ph); - begin - inherited create(); - FConnectHandle := ph; - uisetthreadworkerdata(ph,0x30,self.handle); //构造 - end - function close(); //请求关闭 0x10 - begin - uisetthreadworkerdata(FConnectHandle,0x10,0); - end - function PostMessage(d); - begin - uisetthreadworkerdata(FConnectHandle,0x20,d); - end - function DoOnMessage(d); //执行onmessage 任务 - begin - if iffuncptr(FOnMessage) then - begin - try - return call(FOnMessage,self,d); - except - uisetthreadworkerdata(FConnectHandle,0x40,exceptobject.ErrInfo); - end; - end - end - property ConnectHandle read FConnectHandle; - property OnMessage read FOnMessage write FOnMessage; - {** - @param(OnMessage)(function[tworkerclient,data]) 消息回调 %% - **} - function destroy();override; - begin - FOnMessage := nil; - inherited; - end - private - [weakref] FOnMessage; //onpost message - FConnectHandle; //句柄 -end -type TCustomThreadworker = class() +function RunThreadWorkerHost(); + +type TCustomThreadworker = class(t_worker_host) {** @explan(说明) 工作线程宿主 %% **} - function Create(s,lib,declaration); + function create(sc); begin - if not ifarray(FThreaders) then FThreaders := array(); - FThreader := new tworkerHost(); - FThreaders[inttostr(FThreader.handle)] := FThreader; - if not (checkok(s,lib,declaration)) then raise "工作线程构造失败!"; - uibeginthreadworker(FScript); - end - function Operator [](idx); - begin - {** - @explan(说明) get数据 %% - **} - return FThreader[idx]; + init_workerhost(); + tarraycont++; + FHandle := tarraycont ; + FThreaders[FHandle] := self; + if not(sc and ifstring(sc)) then raise "工作线程构造失败!参数错误!"; + fn := get_true_script(sc,ns); + if fn=0 and ns then //给定函数 + begin + eg := unit(utssvr_api_c).get_func_finder_register(); + eg.add_hook(thisfunction(finder)); + //fn := "t_thread_call_back_"$tarraycont; + fn := add_thread_call(ns); + end + fp := findfunction(fn); + if fp then + begin + fps := sysgetfuncdepends(fp,2); + end + if not fp then raise ("工作线程构造失败!回调函数错误!" $fn); + set_heartbeat(); + p := format_thread_param(systhreadid(),fn); + b := static makeinstance(thisfunction(t_thread_worker),"stdcall",1); + cid :=create_thread(b,p); + inherited create(cid); + ////////////////// end - function Operator [1](idx,v); + class function finder(L,iUser,iName); begin - {** - @explan(说明) set数据 %% - **} - FThreader[idx] := v; + r := f_thread_call_backs[iName]; + return r; end - function Close(); //关闭 + function add_thread_call(body); begin - if FThreader then - begin - FThreader.close(); + for i,v in f_thread_call_backs do + begin + if v=body then return i; end + fn := "__t__thread__call__back__"$(length(f_thread_call_backs)+10); + + f_thread_call_backs[fn] := "function "+fn+body; + return fn; end - function terminate(); + function destroy();override; begin - Close(); + remove_self(); + inherited; end - function PostMessage(d); + class function set_heartbeat(); begin - {** - @expaln(说明) 发送数据给子线程 %% - @param(d)(any) 发送数据,基础数据,不能传送对象 %% - **} - FThreader.PostMessage(d); + setglobalcache("~~main~~threader~~",1,(now()+0.015)); end + static lenct; class function dispatch(); begin if not FThreaders then return ; - for idx,i in mrows( FThreaders,1) do + set_heartbeat(); + for idx,i in mrows(FThreaders,1) do begin o := FThreaders[i]; - try - oh := o.handle; - except - DeleteWorker(i); - uideleteworkerdata(oh); //删除数据 - end - if uifeachthreadworkerdata(oh,msg,data) then - begin + msg := o.fetch(data); + if msg then + begin case msg of - 0x30: //构成成功 + "s": //成功 begin - o.ClientReady(data); + o.ClientReady(1); end - 0x10: //请求关闭 + "se": //构造失败 begin - o.close(); + o.remove_self(); + o.ClientReady(-1); + raise "工作线程构造失败!"$data; end - 0x12: //成功关闭 + "qq": //关闭成功 begin - uideleteworkerdata(oh); //删除数据 - o.ClientReady(0); - DeleteWorker(i); - o.destroy(); + o.remove_self(); + o.ClientReady(0); + o.clear();// end - 0x40: //错误 + "q": //请求关闭 + begin + o.close(); + end + "e": //错误 begin o.DoOnError(data); end - 0x20 : //传输数据 + "d": //数据 begin o.DoOnMessage(data); end - end ; + end; break; - end + end end end - function destroy();override; + property handle read FHandle; + private + + class function init_workerhost(); + begin + if not ifarray(FThreaders) then + begin + f_thread_call_backs := array(); + tarraycont := 1; + FThreaders := array(); + end + end + function remove_self(); + begin + ClientReady(0); + reindex(FThreaders,array(FHandle:nil)); + end + static tarraycont; + static f_thread_call_backs; + [weakref] static FThreaders; + FHandle; +end +type t_worker_client = class(t_worker_base) + function create(id); begin - close(); inherited; end - property componet read getcomponet write setcomponet; - property OnMessage read GetOnMessage write SetOnMessage; - property OnError read GetOnError write SetOnError; - property OnStart read GetOnStart Write SetOnStart; - {** + function err(info); //错误 + begin + post_to_("e",info); + end +end +type t_worker_host = class(t_worker_base) + function create(id); + begin + fworkerstate :=0; + FCatcheData := array(); + inherited; + end + function destroy();override; + begin + if fworkerstate=1 then + begin + clear(); + post_to_("qq",1); + end + FCatcheData := array(); + inherited; + end + property OnStart read FOnStart write FOnStart; + property OnError read FOnError write FOnError; + property OnMessage read FOnMessage write FOnMessage; + property componet read Fcomponet write Fcomponet; + {** @param(OnMessage)(function[TThreadWorker,data]) 消息回调 %% @param(OnStart)(function[TThreadWorker]) 子线程启动 %% @param(OnError)(function[TThreadWorker,d]) 子线程启动 %% **} - protected - function Check_TslCode(FScript,err);virtual; + function terminate();override; begin - return true; - end - private - class function DeleteWorker(h); + if fworkerstate=1 then inherited; + end + function ClientReady(flg); //任务句柄改变 begin - if h then - reindex( FThreaders,array(h:nil)); - end - function checkok(s,libs,declaration); - begin - if ifstring(s) then - begin - lib := ""; - if ifarray(libs) and libs then - begin - lib := ","+array2str(libs,","); - end - dc := ""; - if ifstring(declaration) then - begin - dc := declaration; - end - FScript := format( %% - uses uvclthreadworker%s; - this := new unit(uvclthreadworker).tworkerclient(%s); - %s; - unit(uvclthreadworker).RunThreadWorkerClient(this); - %s; - - %%,lib,inttostr(FThreader.handle),s,dc); - r := Check_TslCode(FScript,err); - if not r then FScript := ""; - end - return r; - end - function GetOnMessage(); - begin - return FThreader.OnMessage; - end - function SetOnMessage(m); - begin - FThreader.OnMessage := m; - end - function GetOnError()begin - return FThreader.OnError ; - end - function SetOnError(e)begin - FThreader.OnError := e ; - end - function GetOnStart()begin - return FThreader.OnStart ; - end - function SetOnStart(e)begin - FThreader.OnStart := e ; - end - [weakref]static FThreaders; - FScript; //脚本 - FThreader;//host对象 - function setcomponet(v); - begin - FThreader.componet := v; - end - function getcomponet(); - begin - return FThreader.componet; - end -end -implementation -function RunThreadWorkerHost(); -begin - class(TCustomThreadworker).dispatch(); -end -function RunThreadWorkerClient(this); -begin -{** - @explan(说明) 工作线程主循环 %% -**} - h := this.handle; - ph := this.ConnectHandle; - while true do - begin - if uifeachthreadworkerdata(h,msg,d) then - begin - case msg of - 0x11 : //关闭 - begin - uisetthreadworkerdata(ph,0x12,0); //关闭完成 - uideleteworkerdata(h); //删除消息 - return; - end - 0x20 : //post - begin - this.DoOnMessage(d); - end - end ; - sleep(1); - end else - begin - sleep(10); - end - tslprocessmessages(false); //20230428添加tsl消息分发 - end -end -type TArray = class - function create(); - begin - FData := array(); - fobj := new tcbytearray(4); - FHandle := fobj._getptr_() ; - end - function Operator [](idx); - begin - return FData[idx]; - end - function Operator [1](idx,v); - begin - FData[idx] := v; - end - function destroy();virtual; - begin - FData := array(); - fobj := nil; - end - property handle read FHandle ; - private - FData; - FHandle; - fobj; -end - -type tworkerHost = class(TArray) - function Create(); - begin - inherited; - FConnectHandle := 0; - FCatcheData := array(); - end - property OnMessage read FOnMessage write FOnMessage; - property OnStart read FOnStart write FOnStart; - property OnError read FOnError write FOnError; - property componet read Fcomponet write Fcomponet; - function close(); //关闭命令 0x10 - begin - if FConnectHandle then - begin - uisetthreadworkerdata(FConnectHandle,0x11,0); - end - end - function ClientReady(h); //任务句柄改变 - begin - FConnectHandle := h; - if h then - begin + if flg=1 then + begin + fworkerstate := 1; if iffuncptr(FOnStart) then begin try - if Fcomponet then o := Fcomponet; - else o:= self; - call(FOnStart,o); + call(FOnStart,get_true_self()); except end; @@ -323,76 +184,538 @@ type tworkerHost = class(TArray) begin for i,v in FCatcheData do begin - uisetthreadworkerdata(FConnectHandle,0x20,v); + post_to_("d",v); end FCatcheData := array(); end - end - end - function PostMessage(d); //发送数据 - begin - if FConnectHandle then - begin - if FCatcheData then - begin - for i,v in FCatcheData do - begin - uisetthreadworkerdata(FConnectHandle,0x20,v); - end - FCatcheData := array(); - end - uisetthreadworkerdata(FConnectHandle,0x20,d); - end else - begin - FCatcheData[length(FCatcheData)] := d; + end else + if flg=0 then + begin + fworkerstate := -2; + end else + if flg=-1 then + begin + fworkerstate := -1; end + end + function PostMessage(d); override;//发送数据 + begin + case fworkerstate of + 1: + begin + if FCatcheData then + begin + for i,v in FCatcheData do + begin + post_to_("d",d); + end + FCatcheData := array(); + end + return inherited; + end + 0: + begin + FCatcheData[length(FCatcheData)] := d; + return 1; + end else + begin + return 0; + end + end; end function DoOnError(d);//处理错误 begin if iffuncptr(FOnError) then begin try - if Fcomponet then o := Fcomponet; - else o:= self; - return call(FOnError,o,d); + return call(FOnError,get_true_self(),d); except end; end end function DoOnMessage(d); //处理数据 begin - if iffuncptr(FOnMessage) then + if iffuncptr(fOnMessage) then begin try - if Fcomponet then o := Fcomponet; - else o:= self; - return call(FOnMessage,o,d); + return call(fOnMessage,get_true_self(),d); except end; end - end - function destroy();override; - begin - FOnMessage := nil; - FOnError := nil; - OnStart := nil; - FCatcheData := array(); - inherited; - end + end private + fworkerstate; FCatcheData; //构造数据 - weakref - FOnMessage; //onpost message + weakref FOnError; FOnStart; Fcomponet; + FOnMessage; autoref - FConnectHandle; //句柄 + private + function get_true_self(); + begin + if Fcomponet then return Fcomponet; + return self(true); + end +end +implementation +function RunThreadWorkerHost(); +begin + class(TCustomThreadworker).dispatch(); +end +type t_worker_base = class() + function Operator [](idx); + begin + return FData[idx]; + end + function Operator [1](idx,v); + begin + FData[idx] := v; + end + function create(id); + begin + FData := array(); + fmy_thread := systhreadid(); + fto_thread:=id; + fpostct := 0; + end + function close(); //关闭 + begin + terminate(); + end + function terminate();virtual; //停止 + begin + post_to_("q",1); + end + function postmessage(d);virtual; //发送数据 + begin + return post_to_("#d",d); + end + function fetch(d); //获取数据 + begin + ls := listglobalcache(); + myid := "#"$fmy_thread$"#"$fto_thread$"#"; + nw := now(); + for i,vd in ls do + begin + v := vd["name"]; + endm := vd["endtm"]; + if endm>0 and endm5 then + begin + this.post_to_("qq",1); + return ;//systerminate(2,mypid); + end + end + msg := this.fetch(d); + case msg of + "d":begin //数据 + if iffuncptr(fptr) then + begin + try + call(fptr,this,d); + except + this.err(exceptobject.errinfo); + end; + end + sleep(1); + end + "qq": + begin + this.clear(); + return 1;//systerminate(1,mypid); + end + "q":begin //退出 + + this.clear(); + this.post_to_("qq",1); + return ;//systerminate(1,mypid); + end + else + begin + sleep(10); + end + end ; + tslprocessmessages(false); //20230428添加tsl消息分发 + + end +end +function create_thread(f,p);//构造线程 +begin +{$ifdef linux} + return g_thread_new(f,p); +{$endif} + return CreateThread(f,p); +end +function g_thread_new(f:pointer;p:pointer):pointer; +begin + if not g_thread_get_initialized() then g_thread_init(); + _f_ := static function(n:string;f:pointer;p:pointer):pointer;cdecl; external getdlsymaddress( "libgtk-3.so.0" ,functionname(1)); + return ##_f_("",f,p); +end +function g_thread_get_initialized():Integer; +begin + _f_ := static function():Integer;cdecl; external getdlsymaddress( "libgtk-3.so.0" ,functionname(1)); + return ##_f_(); +end +function g_thread_init():Integer; +begin + _f_ := static function():Integer;cdecl; external getdlsymaddress( "libgtk-3.so.0" ,functionname(1)); + return ##_f_(); +end +function CreateThread(f:pointer;p:pointer):pointer; +begin + _f_ := static function(attr:pointer;size:pointer;addr:pointer;p:pointer;flag:Integer;var threadid:Integer):pointer;stdcall; external getdlsymaddress( "kernel32.dll" , functionname(1)); + id := 0; + h := ##_f_ (0,10240000,f,p,0,id); + return id; end function iffuncptr(fn); begin //return datatype(fn)=7; return ifobj(fn); end +function find_find_function(idx,len,tks);//findfunction 处理 +begin + state := -1; + fn := ""; + cn := ""; + while idx