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

编辑器 

优化安装
This commit is contained in:
tslediter 2023-11-22 09:39:48 +08:00
parent c7d8491b45
commit bd8664d429
8 changed files with 436 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
designer/ctl_mgr/resource.tfm/t_compile_config.tfm
View File

@ -282,7 +282,6 @@ object ed_script:t_compile_config
end
object ck_s_rp:tcheckbtn
caption="资源文件保留相对路径"
enabled=false
height=25
left=253
top=25

4
designer/ctl_mgr/t_compile_config.tsf
View File

@ -100,6 +100,7 @@ type t_compile_config=class(tdcreateform)
else
cb_type.ItemIndex := 0;
end
flibpath := r["libpath"];
e_script.text := r["buildfile"];
ed_output.text := r["output"];
ed_out_f.text := r["exports"] ;
@ -125,6 +126,7 @@ type t_compile_config=class(tdcreateform)
end
r["buildfile"] := e_script.text;
r["output"] := ed_output.text;
r["libpath"] := flibpath;
r["exports"] := ed_out_f.text;
r["dependsdir"]:=ed_f_dirs.text;
r["depends"]:=ed_include_f.text;
@ -154,6 +156,7 @@ type t_compile_config=class(tdcreateform)
ck_gui.Checked := "";
ed_ico.text := "";
ck_s_rp.Checked := "";
flibpath := "";
end
function bt_outputname_clk(o;e);virtual;
begin
@ -446,4 +449,5 @@ type t_compile_config=class(tdcreateform)
return r;
end
fcmd_shower;
flibpath;
end

70
designer/gettsleditorstart.tsf
View File

@ -36,14 +36,14 @@ begin
//return sleep(5000); //Í£Áô5Ãë
echo "\r\n press enter exit";
sleep(5000);
return readln();
return ;
end else
if (i<=sysparamcount())and ("-uninstall" = sysparamstr(i) ) then //жÔØÓÒ¼ü´ò¿ª
begin
UnInStallToMenu();
echo "\r\n press enter exit";
sleep(5000); //Í£Áô5Ãë
return readln();
return ;
end
end
@ -155,8 +155,25 @@ type TRunEditorForm = class(TEditorForm)
end
function InStallToMenu(); //×¢²á
begin
k1 := new TRegKey(class(TRegKey).HKEY_CLASSES_ROOT);
tek := k1.openKeyA("*\\shell\\tslediter");
uses utslvclinstall;
o := new t_tsl_window_reg();
o.installforall := true;
if o.has_reg_authority() then
begin
reg := 0;
if o.install_info_set()=0 then echo "\r\nset install info ok!!";
if o.install_backmenuopen()=0 then echo "\r\nset open menu ok!!";
if o.install_backmenu()=0 then echo "\r\nset back menu ok!!";
end else
begin
return echo "\r\nPlease run with administrator rights!!";
end
return ;
//k1 := new TRegKey(class(TRegKey).HKEY_CLASSES_ROOT);
k := class(TRegKey).GetRegKeyMachine();
k1 := k.openKeyA("SOFTWARE\\Classes");
tek := k1.openKeyA("*\\shell\\tsleditor");
if not ifobj(tek) then
begin
return echo "Please run with administrator rights!!";
@ -170,17 +187,42 @@ begin
end else
begin
tc.SetValueStringA(nil,SysExecName()+ ' "%1"');
bkcl := k1.openKeyA("Directory\\Background\\shell\\tslediter\\command");
bkcl := k1.openKeyA("Directory\\Background\\shell\\tsleditor\\command");
if bkcl then bkcl.SetValueStringA(nil,SysExecName());
bkcl := k1.openKeyA("Directory\\Background\\shell\\tslediter");
bkcl := k1.openKeyA("Directory\\Background\\shell\\tsleditor");
bkcl.SetValueStringA(nil,"TSL Editor");
if bkcl then bkcl.SetValueStringA("Icon",SysExecName());
echo "register tslediter ok ~~";
echo "register tsleditor ok ~~";
end
end
function UnInStallToMenu(); //жÔØ
begin
k1 := new TRegKey(class(TRegKey).HKEY_CLASSES_ROOT);
uses utslvclinstall;
o := new t_tsl_window_reg();
o.installforall := true;
if o.has_reg_authority() then
begin
reg := o.get_uninstall_reg(1);
if ifobj(reg) then
begin
reg := nil;
if 0=o.uninstall_backmenu() then echo "\r\ndelete back menu ok ";
if 0=o.uninstall_backmenuopen() then echo "\r\ndelete open menu ok ";
if 0=o.install_info_remove() then echo "\r\ndelete install info ok ";
end else
begin
return echo "\r\nnot installed!!";
end
end else
begin
return echo "\r\n try run with administrator rights!!";
end
return ;
//k1 := new TRegKey(class(TRegKey).HKEY_CLASSES_ROOT);
k := class(TRegKey).GetRegKeyMachine();
k1 := k.openKeyA("SOFTWARE\\Classes");
tc := k1.openKeyA("*\\shell");
if not ifobj(tc) then
begin
@ -188,26 +230,26 @@ begin
return;
end else
begin
if 0=tc.DeleteKeyA("tslediter\\command") then
if 0=tc.DeleteKeyA("tsleditor\\command") then
begin
if 0=tc.DeleteKeyA("tslediter") then
if 0=tc.DeleteKeyA("tsleditor") then
begin
bkcl := k1.openKeyA("Directory\\Background\\shell");
if ifobj(bkcl) then
begin
if 0=bkcl.DeleteKeyA("tslediter\\command") then
if 0=bkcl.DeleteKeyA("tsleditor\\command") then
begin
if 0=bkcl.DeleteKeyA("tslediter") then
if 0=bkcl.DeleteKeyA("tsleditor") then
begin
end
end
end
echo "unregister tslediter ok~~";
echo "unregister tsleditor ok~~";
return ;
end
end
echo "tslediter not installed~~";
echo "tsleditor not installed~~";
return ;
end
end

1
designer/utslcodeeditor.tsf
View File

@ -2232,7 +2232,6 @@ type TEditer=class(TCustomcontrol) //
end
end
ds := getlibpathstr();
r["libpath"] := ds;
if ot then r["output"] := ot;
r["dependsdir"] := replacetext(ds,";",",");

129
funcext/tvclib/tslvcl.tsf
View File

@ -4947,6 +4947,54 @@ type TRegKey = class
static const HKEY_PERFORMANCE_NLSTEXT = 0x80000060;
static const KEY_WOW64_32KEY = 0x0200;
static const KEY_WOW64_64KEY = 0x0100;
static const REG_NONE = 0;// No value type
static const REG_SZ = 1;// Unicode nul terminated string
static const REG_EXPAND_SZ = 2;// Unicode nul terminated string(with environment variable references)
static const REG_BINARY = 3;// Free form binary
static const REG_DWORD = 4;// 32-bit number
static const REG_DWORD_LITTLE_ENDIAN = 4;// 32-bit number (same as REG_DWORD)
static const REG_DWORD_BIG_ENDIAN = 5;// 32-bit number
static const REG_LINK = 6;// Symbolic Link (unicode)
static const REG_MULTI_SZ = 7;// Multiple Unicode strings
static const REG_RESOURCE_LIST = 8;// Resource list in the resource map
static const REG_FULL_RESOURCE_DESCRIPTOR = 9;// Resource list in the hardware description
static const REG_RESOURCE_REQUIREMENTS_LIST = 10;// Multiple Unicode strings
static const REG_QWORD = 11;// 64-bit number
static const REG_QWORD_LITTLE_ENDIAN = 11;// 64-bit number (same as REG_QWORD)
static const KEY_ALL_ACCESS = 0xF003F;
static const KEY_CREATE_LINK = 0x0020;
static const KEY_CREATE_SUB_KEY = 0x0004;
static const KEY_ENUMERATE_SUB_KEYS =0x0008;
static const KEY_EXECUTE = 0x20019;
static const KEY_NOTIFY = 0x0010;
static const KEY_QUERY_VALUE = 0x0001;
static const KEY_READ = 0x20019;
static const KEY_SET_VALUE = 0x0002;
static const KEY_WRITE = 0x20006;
static const ERROR_MORE_DATA = 234L ; // dderror
static const REG_OPTION_RESERVED = (0x00000000L) ; // Parameter is reserved
static const REG_OPTION_NON_VOLATILE =0x00000000L; // Key is preserved
// when system is rebooted
static const REG_OPTION_VOLATILE = (0x00000001L); // Key is not preserved
// when system is rebooted
static const REG_OPTION_CREATE_LINK=(0x00000002L) ; // Created key is a
// symbolic link
static const REG_OPTION_BACKUP_RESTORE=(0x00000004L); // open for backup or restore
// special access rules
// privilege required
static const REG_OPTION_OPEN_LINK=(0x00000008L); // Open symbolic link
static const REG_OPTION_DONT_VIRTUALIZE=(0x00000010L) ; // Disable Open/Read/Write
// virtualization for this
// open and the resulting
// handle.
{$ifdef linux}
class function RegEnumValueA(hKey:pointer;dwIndex:integer;var lpValueName:string;var lpcchValueName:integer;lpReserved:pointer;lpType:pointer;lpData:pointer;lpcbData:pointer):integer;
class function RegEnumKeyA(hKey:pointer;dwindex:integer;var lpName:string;ccname:integer):integer;
@ -5053,29 +5101,54 @@ type TRegKey = class
begin
CloseRegKey();
end
function openKeyA(vn);
function openKeyA(vn,exist);
begin
{**
@explan(说明) 打开或者新建 key%%
@param(vn)(string) value 名字 %%
@param(exist)(bool) 只打开存在的 %%
@return(TRegKey) 值 %%
**}
if not FHandle then return-1;
if not(ifstring(vn)and vn)then return-1;
if not FHandle then return -1;
if not(ifstring(vn)and vn)then return -1;
if exist>0 then
begin
ac := 0;
if (exist .& 2) then //写
begin
ac .|=KEY_CREATE_LINK;
ac .|=KEY_CREATE_SUB_KEY;
ac .|=KEY_SET_VALUE;
ac .|=KEY_WRITE;
end
if (exist .& 1) then //读
begin
ac .|= KEY_QUERY_VALUE;
ac .|= KEY_ENUMERATE_SUB_KEYS;
ac .|= KEY_READ;
end
end else
begin
ac := KEY_ALL_ACCESS;
end
h2 := 0;
rr := RegOpenKeyExA(FHandle,vn,0,0xF003F,h2);
if 0=rr then
rr := RegOpenKeyExA(FHandle,vn,REG_OPTION_OPEN_LINK,ac,h2);
if 0=rr then
begin
r := new TRegKey(h2);
return r;
end
if exist then return rr;
state := 0;
hk2 := 0;
rr := RegCreateKeyExA(FHandle,vn,0,"",0,0,0,hk2,state);
rr := RegCreateKeyExA(FHandle,vn,0,"",REG_OPTION_NON_VOLATILE,0,0,hk2,state);
if rr=0 then
begin
r := openKeyA(vn); //new TRegKey(hk2);
return r;
RegCloseKey(hk2);
//r := new TRegKey(hk2); //openKeyA(vn,exist); //
//return r;
return openKeyA(vn,3);
end
return rr;
end
@ -5085,15 +5158,23 @@ type TRegKey = class
@explan(说明) 获得value值%%
@param(vn)(string) value 名字 %%
@param(vt)(integer) 类型 %%
@return(string) ֵ %%
@return(string|number) 值 | err %%
**}
if not FHandle then return-1;
if not(ifstring(vn)or ifnil(vn))then return-1;
if not ifnumber(vt)then vt := 0;
if not ifnumber(vt)then vt := 0;
n := 512;
d := "";
setlength(d,2064);
len := 2063;
setlength(d,n);
len := n-1;
rr := RegQueryValueExA(FHandle,vn,0,vt,d,len);
while rr=ERROR_MORE_DATA do
begin
n+=512;
setlength(d,n);
len := n-1;
rr := RegQueryValueExA(FHandle,vn,0,vt,d,len);
end
if 0=rr then
begin
return d[1:len-1];
@ -5113,6 +5194,20 @@ type TRegKey = class
tp := 1;
return RegSetValueExA(FHandle,vn,rs,tp,v,length(v));
end
function setvalueA(vn,v,tp);
begin
{**
@explan(说明) 设置value值%%
@param(vn)(string) value 名字,nil为默认值%%
@param(v)(string) 值 %%
@param(tp)(Number) 类型 默认字符串类型 %%
**}
if not FHandle then return -1;
if not(ifstring(vn)or ifnil(vn))then return -1;
rs := 0;
if not(tp>=0 ) then tp := 1;
return RegSetValueExA(FHandle,vn,rs,tp,v,length(v));
end
function DeleteValueA(vn);
begin
@ -5161,7 +5256,7 @@ type TRegKey = class
begin
ls := 1024;
sc := RegEnumValueA(FHandle,idx,s,ls,0,0,0,0);
if sc=0 then
if sc=0 and (ls>0) then
begin
r[idx]:= s[1:ls];
idx++;
@ -5191,7 +5286,7 @@ type TRegKey = class
begin
for i := 1 to 1024 do
begin
if s[i]="\0" then
if (s[i]="\0") and (i>2) then
begin
r[idx]:= s[1:(i-1)];
break;
@ -5199,7 +5294,7 @@ type TRegKey = class
end
idx++;
end else
break;
break;
end
end
return r;
@ -5208,6 +5303,7 @@ type TRegKey = class
{**
@param(Handle)(pointer) regkey句柄 %%
**}
private
end
type TWinEnviroment=class()
{**
@ -5933,8 +6029,7 @@ type Ttfm2Component = class(TTmfParser)
end
function hastfmresource(o,cn);
begin
global g_w_tfm_resource;
data := g_w_tfm_resource[cn+".tfm"];
data := get_resource_by_name(cn+".tfm");
if data then
begin
LoadFromTfmScript(o,data);

58
funcext/tvclib/utslvclauxiliary.tsf
View File

@ -29,7 +29,7 @@ function intersectrect(rec1,rec2,irec);
function bitcombination(s,v,f);
function IsTextUTF8(str);
function exportjsonformat(d,tbw,ct);
function get_resource_by_name(n);
function get_resource_by_name(n,full);
//****************************
///////////////////
function ParserCommandLine(s); //解析命令行参数
@ -3788,23 +3788,65 @@ begin
end
end
return "";
end
function get_resource_by_name(n);
end
function get_resource_by_name(n,full);
begin
global g_w_tfm_resource;
return g_w_tfm_resource[n];
return static get_resource_by_name_sub(n,full) name (n$":"$full);
end
function get_resource_by_name_sub(n,full);
begin
global g_w_tfm_resource,g_w_tfm_resource_withdir,g_w_tfm_resource_names;
if n=1 then return g_w_tfm_resource;
if n=2 then return g_w_tfm_resource_withdir;
if n=3 then return (g_w_tfm_resource union g_w_tfm_resource_withdir);
if n=4 then return g_w_tfm_resource_names;
p := filesize("","d:\\test\\get_source.txt");
r := g_w_tfm_resource[n];
if r then return r;
if full then
begin
return g_w_tfm_resource_withdir[n];
end
if not(ifstring(n) and n) then return 0;
for i,v in g_w_tfm_resource_withdir do
begin
nn := replacetext(n,".","\\.");
{$ifdef linux}
ctl := "/"+nn+"$|^"+nn+"$";
{$else}
ctl := "\\\\"+nn+"$|^"+nn+"$";
{$endif}
if 1= parseregexpr(ctl,i,"i",m,mp,ml) then
begin
return v;
end
end
end
function uinit();
begin
global g_w_tfm_resource;
global g_w_tfm_resource,g_w_tfm_resource_withdir,g_w_tfm_resource_names;
sep := ioFileseparator();
g_w_tfm_resource := array();
g_w_tfm_resource_withdir := array();
g_w_tfm_resource_names := array();
idx := 0;
try
getglobalcache("@@tsl-resource@@",rs);
for i,v in rs do
begin
if ifstring(i) and ifstring(v) then
begin
g_w_tfm_resource[lowercase(i)] := v;
begin
li := lowercase(i);
g_w_tfm_resource_names[i] := li;
if pos(sep,li) then
begin
g_w_tfm_resource_withdir[li] := v;
end else
begin
g_w_tfm_resource[li] := v;
end
end
end
except

213
funcext/tvclib/utslvclinstall.tsf Normal file
View File

@ -0,0 +1,213 @@
unit utslvclinstall;
interface
uses tslvcl;
type t_tsl_window_reg = class()
function create();
begin
exe := sysexecname();
end
///////////////安装uninstall//////////////////////////
function get_install_values();
begin
reg := getuninstallregkey(fexename,1);
if ifobj(reg) then
begin
r := array();
for i,v in reg.GetValueNames() do
begin
r[v] := reg.GetValueA(v,vt);
end
return r;
end else return reg;
end
function set_install_values(vs);
begin
reg := getuninstallregkey(fexename,2);
if ifobj(reg) then
begin
for i,v in vs do
begin
reg.SetValueStringA(i,v);
end
return r;
end else return reg;
end
function install_info_set(); //设置默认的value
begin
reg := getuninstallregkey(fexename);
if not ifobj(reg) then return reg; //打开注册表错误
reg.SetValueStringA("DisplayIcon",fexe);
reg.SetValueStringA("DisplayName",getdisplayname());
reg.SetValueStringA("DisplayVersion",getdisplayversion());
reg.SetValueStringA("Publisher",getpublisher());
reg.SetValueStringA("UninstallString",getuninstallstring());
reg.SetValueStringA("InstallLocation",fdefaultexedir);
reg.SetValueStringA("InstallTime",datetimetostr(now()));
return install_info_setex(reg);
end
function install_info_setex(reg);virtual; //写入额外信息
begin
return 0;
end
function install_info_remove();virtual; //移除安装信息
begin
reg := getuninstallregkey();
if not ifobj(reg) then return reg; //打开注册表错误
return reg.DeleteKeyA(fexename);
end
function has_reg_authority();
begin
return ifobj(getuninstallregkey(nil,rw));
end
function get_uninstall_reg(rw);
begin
return getuninstallregkey(fexename,rw);
end
///////////////安装右键菜单//////////////////////////////////////
function install_backmenu(); //背景菜单
begin
if not fexe then return -1; //软件错误
////////////////////////写入背景菜单////////////////////////////////////
reg := getbackregkey(fexename);
if not ifobj(reg) then return -2; //打开注册表错误
reg.SetValueStringA(nil,fexename);
reg.SetValueStringA("Icon",fexe);
regcmd := reg.openKeyA("command");
regcmd.SetValueStringA(nil,backmenuparam());
end
function uninstall_backmenu(); //卸载
begin
reg := getbackregkey(nil,2);
if not ifobj(reg) then return reg; //打开注册表错误
return reg.DeleteTreeA(fexename);
end
///////////////////安装右键打开菜单/////////////////////////////////
function install_backmenuopen();//右键打开菜单
begin
if not fexe then return -1; //软件错误
////////////////////////写入到打开菜单//////////////////////////////////////////////
reg := getshellkey(fexename);
if not ifobj(reg) then return reg; //打开注册表错误
reg.SetValueStringA(nil,fexename);
reg.SetValueStringA("Icon",fexe);
regcmd := reg.openKeyA("command");
regcmd.SetValueStringA(nil,(backmenuopenparam()));
return 0;
end
function uninstall_backmenuopen();//卸载
begin
reg := getshellkey(nil,2);
if not ifobj(reg) then return reg; //打开注册表错误
return reg.DeleteTreeA(fexename);
end
//////////////////////////重写函数///////////////////////////////////////////
function getdisplayname();virtual; //显示
begin
return fexename;
end
function getdisplayversion();virtual; //版本
begin
return "1.0.0";
end
function getpublisher();virtual; //开发者
begin
return "tinysoft";
end
function getuninstallstring();virtual; //卸载字符串
begin
return format('"%s" "%s"',funexe,"-uninstall");
end
function backmenuparam();virtual; //背景菜单参数
begin
return format('"%s"',fexe);
end
function backmenuopenparam();virtual; //
begin
return format('"%s" "%s"',fexe,"%1");
end
property installforall read finstallforall write finstallforall;
property exe read fexe write setexe;
property unexe read funexe write setunexe;
property exename read fexename write setexename;
private
fexe;
funexe;
fexename;
fdefaultexedir;
finstallforall;
private
function setexename(s);
begin
if ifstring(s) and s and (s<>fexename) and not(pos("\\",s)) then
begin
fexename := s;
end
end
function setunexe(e);
begin
if (funexe<> e) and (ifstring(e) and fileexists("",e)) then
begin
funexe := e;
end
end
function setexe(e);
begin
if (fexe<>e) and (ifstring(e) and fileexists("",e)) then
begin
fexe := e;
funexe := e;
fexename := "";
for i:= length(fexe) downto 1 do
begin
vi := fexe[i];
if vi="\\" then
begin
fdefaultexedir := fexe[1:i];
for j := i+1 to length(fexe) do
begin
vj := fexe[j];
if vj ="." then break;
fexename+=vj;
end
break;
end
end
end
end
///////////////////////常量/////////////////////
{$ifdef win32}
const c_uninstall_regkey = "SOFTWARE\\Wow6432Node\\Microsoft\\Windows\\CurrentVersion\\Uninstall";
{$else}
const c_uninstall_regkey = "SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Uninstall";
{$endif}
const c_install_backshell = "SOFTWARE\\Classes\\Directory\\background\\shell";
const c_install_Starshell = "SOFTWARE\\Classes\\*\\shell";
function getbasereg(); //基准
begin
if finstallforall then return class(TRegKey).GetRegKeyMachine(); ;
return class(TRegKey).GetRegKeyUser();
end
function getuninstallregkey(n,rw);//
begin
o := getbasereg();
if n then return o.openKeyA((c_uninstall_regkey+"\\"+n),rw);
return o.openKeyA(c_uninstall_regkey,rw);
end
function getshellkey(n,rw) ; //右键打开菜单
begin
o := getbasereg();
if n then return o.openKeyA((c_install_Starshell+"\\"+n),rw);
return o.openKeyA(c_install_Starshell,rw);
end
function getbackregkey(n,rw); //右键菜单
begin
o := getbasereg(flg);
if n then return o.openKeyA((c_install_backshell+"\\"+n),rw);
return o.openKeyA(c_install_backshell,rw);
end
end
end.

3
funcext/tvclib/uvcpropertytypespersistence.tsf
View File

@ -2154,10 +2154,9 @@ type ttfmnode = class()
function initinherited();
begin
s := finheritedname;
global g_w_tfm_resource;
if s and ifstring(s) then
begin
data := g_w_tfm_resource[s+".tfm"];
data := get_resource_by_name( s+".tfm");
if data then
begin
return get_inherited(data);