liujianjun
/
tslediter
3
0
Fork 1
Code Issues Pull Requests Projects Releases Wiki Activity
tslediter/funcext/tvclib/utslvclauxiliary.tsf

4990 lines
126 KiB
Plaintext
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

unit utslvclauxiliary;
{**
@explan(说明) tslvcl 辅助库 %%
**}
//20221118 抽象计数锁定对象
//20220914 移入tire树
interface
function iffuncptr(fn);
function includestate(u,s);
function excludestate(u,s);
function makelong(low,high,ptrl);
function makeposition(x,y);
function getbitsfrominteger(n,b,e);
function unsignedtosigned(v,n);
function signedtounsigned(v,n);
function lowuperdword(value_,lvalue,uvalue,ptrl);
function FormatTslData(d,sj,tn);
function gettemppath();
function TSL_ReservedKeys2(); //保留关键字
function parsershortcutstr(s_); //快捷键解析
function lineintersect(xx1,xx2,xx);
function formatshortcut(d);
function getmonthdates(y,m);
function CallMessgeFunction(f,o,e);
////////////////////点区域操作//////////////////
function pointinrect(p,rec);
function intersectrect(rec1,rec2,irec);
function bitcombination(s,v,f);
function istextascii(s); //ansi编码
function isTextGBK(str);
function IsTextUTF8(str);
function exportjsonformat(d,tbw,ct);
function get_resource_by_name(n,full);
//****************************
///////////////////
function ParserCommandLine(s); //解析命令行参数
//function FormatTslData(d,sj,tn);
//function HexStrToTsl(hex);
//function TslToHexStr(d);
function TslToHexFormatStr(tsl);
function HexFormatStrToTsl(D);
function DeleteAllFiles(path);
function CreateDirWithFileName(fname);
function TS_GetUserProfileHome();
function TS_GetUserProfileHomeInstance(t:integer):string;
function TS_GetUserConfigHome(t:integer):string;
function TS_GetHomePath(t:integer):string;
function TS_ModulePath():string;
function TS_ExecPath():string;
function TS_GetAppPath():string;
function TS_GetIniPath(t:integer;iname:string):string;
function gettslexefullpath();
function int_to_binary(d,n); //整数转换成字符串
//function tsl_str_head_at(s,n);
function get_tsl_mem_ptr(s,n);
type tuiglobaldata=class() //全局对象存储
static UIData;
class Function uisetdata(n,d);
begin
InitUiData();
UIData[n]:= d;
end
class function uigetdata(n);
begin
InitUiData();
return UIData[n];
end
private
class function InitUiData();
begin
if not ifarray(UIData)then UIData := array();
end
end
type TCharDiscrimi=class() //字符判断
private
static const CD_SMA = 97;
static const CD_BGA = 65;
static const CD_SMZ = 122;
static const CD_BGZ = 90;
static const CD_UDL =95;
static const CD_NIN = 57;
static const CD_ZER =48 ;
public
function IsLetter(cc);
begin
return IsUppercaseLetter(CC)OR IsLowercaseLetter(cc);
end
function IsLowercaseLetter(cc);
begin
return(cc >= CD_SMA)and(cc <= CD_SMZ);
end
function IsUppercaseLetter(cc);
begin
return(cc >= CD_BGA)and(cc <= CD_BGZ);
end
function IsNumber(cc);
begin
return(cc >= CD_ZER)and(cc <= CD_NIN);
end
function IsVariableName(s);
begin
if ifstring(s)and length(s)>= 1 then
begin
cc := ord(s[1]);
if IsLetter(cc)or cc=CD_UDL then
begin
for i := 2 To length(s) do
begin
cc := ord(s[i]);
if not(IsLetter(cc)or IsNumber(cc)or(cc=CD_UDL))then
begin
return false;
end
end
return true;
end
end
return 0;
end
function IsLowercaseVariableName(s);
begin
if ifstring(s)and length(s)>= 1 then
begin
cc := ord(s[1]);
if IsLowercaseLetter(cc)or cc=CD_UDL then
begin
for i := 2 To length(s) do
begin
cc := ord(s[i]);
if not(IsLowercaseLetter(cc)or IsNumber(cc)or(cc=CD_UDL))then
begin
return false;
end
end
return true;
end
end
return 0;
end
end
type tidcreater=class() //id生成
{**
@ignore(忽略)
**}
private
__sid;
cid;
Reuseids;
usedids;
//protected
{**
@explan(说明) 不重复整数id 生成类 %%
@param(cid)(integer) 当前id值 %%
@param(Reuseids) (array) 已经回收的id %%
**}
public
function clean();
begin
Reuseids := array();
cid := __sid;
end
function create(sid);
begin
{**
@explan(说明) 构造函数 %%
@param(sid)(integer) 初始化的id值
**}
if ifnumber(sid)then cid := sid;
else cid := 0;
__sid := cid;
usedids := Reuseids := array();
end
function createid();
begin
{**
@explan(说明) 构造id %%
@return(integer) id值 %%
**}
ret := nil;
for i in Reuseids do
begin
if ifnumber(i)then
begin
ret := i;
break;
end
end
if ifnumber(ret)then
begin
reindex(Reuseids,array(ret:nil));
usedids[ret]:= ret;
return ret;
end
cid += 1;
usedids[cid]:= cid;
return cid;
end
function deleteid(id);
begin
{**
@explan(说明) 不重复整数id 生成类 %%
@param(id)(integer) 需要回收的id值 %%
@return(bool) 是否成功
**}
if ifnumber(id)then
begin
Reuseids[integer(id)]:= id;
reindex(usedids,array(integer(id):nil));
return 1;
end
return 0;
end
function addid(id);
begin
if ifnumber(id)and id>0 then
begin
cid := max(cid,id);
usedids[id]:= id;
end
end
end
type TByteDataOP=class() //位操作类
{**
@explan(说明) 位操作封装
**}
{**
@example(范例:byte数组转整数)
oa := new TByteDataOP();
echo tostn(oa.bytesasint(array(1,1,1,1)));
**}
{**
@example(范例:整数转byte数组)
oa := new TByteDataOP();
echo tostn(oa.intasbytes(235);
**}
class function BytesAsInt(a);
begin
{**
@explan(说明) 四个byte转换为integer %%
@param(a)(array) 正式表示的四字节 %%
@return(integer) 组装好的整数 %%
**}
uu := a[0];
ul := a[1];
lu := a[2];
ll := a[3];
l := makelong(ll,lu,8);
u := makelong(ul,uu,8);
return makelong(l,u);
end
class function IntAsBytes(v);
begin
{**
@explan(说明) 整数转换为byte 数组(整数数组模拟) %%
@param(v)(integer) %%
@return(array) 模拟的byte数组 %%
**}
lowuperdword(v,l,u);
lowuperdword(l,ll,lu);
lowuperdword(u,ul,uu);
return array(uu,ul,lu,ll);
end
class function ShortsToInt(a);
begin
{**
@explan(说明) 两个short转换为一个int %%
@param(a)(array) 两个元素的数组 %%
@return(integer) 整数 %%
**}
l := a[1];
u := a[0];
return makelong(l,u);
end
class function IntToShorts(v);
begin
{**
@explan(说明) 整数转换为两个short 数组(整数数组模拟) %%
@param(v)(integer) %%
@return(array) 模拟的short数组 %%
**}
lowuperdword(v,l,u);
return array(l,u);
end
class function StrAsBytes(s);
begin
{**
@explan(说明) 字符串转换为byte数组 %%
@param(s)(string) 字符串 %%
@return(array) 模拟的byte数组 %%
**}
r := array();
for i := 0 to length(s) do r[i]:= ord(s[i]);
return r;
end
class function BytesAsStr(b);
begin
{**
@explan(说明) byte数组转字符串 %%
@param(b)(array) byte数组 %%
@return(string) 字符串
**}
r := "";
for i := 0 to length(b)-1 do r += chr(b[i]);
return r;
end
end
//**************************数组链表类******************************************
type tarray1dlk=class //从0开始
private
_len;
[weakref]FCompareValue;
protected _data; //数据
public
{**
@explan(说明) 一维链表类 %%
@param(_len)(integer) 长度 %%
@param(_data)(array) 数据 %%
@param(CompareValue)(fpointer) 回调函数 function(v1,v2)begin return v1 = v2 ; end %%
**}
function setdata(data);
begin
{**
@explan(说明) 一次性设置数据 %%
@param(data)(array) 数据 %%
**}
_data := data;
_len := length(data);
end
function clean();
begin
{**
@explan(说明) 清空 %%
**}
_data := array();
_len := 0;
end
function create(); //构造
begin
{**
@explan(说明) 构造 %%
**}
_data := array();
_len := 0;
onchangelock := true;
end
function CallCompare(v1,v2,f);
begin
if iffuncptr(f) then return call(f,v1,v2);
if iffuncptr(FCompareValue)then return call(FCompareValue,v1,v2);
return v1=v2;
end
function append(v) //追加
begin
{**
@explan(说明) 追加 %%
@param(v)() tsl数据 %%
**}
_data[_len++]:= v;
dochanged("append");
end;
function geti(i); //获取
begin
{**
@explan(说明) 获得 %%
@param(i)(integer) id %%
**}
return _data[i];
end
function seti(i,v); //设置值
begin
{**
@explan(说明) 设置值 %%
@param(i)(integer) id %%
@param(v)() tsl数据 %%
**}
if i >= 0 and i<_len then
begin
_data[i]:= v;
dochanged("set");
end
end
function deli(i); //删除
begin
{**
@explan(说明) 删除 %%
@param(i)(integer) id %%
**}
if i<0 or i >= _len then return 0;
_len -= 1;
r := deleteindex(_data,i,1);
dochanged("del");
return r;
end
function delis(i);
begin
{**
@explan(说明) 批量删除 %%
@param(i)(array) 删除的id %%
**}
dels := getdels(i);
bkonchangelock := onchangelock;
onchangelock := true;
for ii,v in dels do deli(v);
onchangelock := bkonchangelock;
dochanged("dels");
end
function getdels(i); //删除多行
begin
{**
@ignore (忽略) %%
@explan(说明) 批量删除 %%
@param(i)(array) 删除的id %%
**}
ii := sselect thisrow from(i union2 array())where(thisrow >= 0 and thisrow<_len)order by thisrow end;
dels := array();
ix := 0;
for iv in ii do
begin
dels[iv]:= ii[iv]-ix;
ix++;
end
return dels;
end
function insertbefor(v,i); //之前插入
begin
{**
@explan(说明) 在i之前插入 %%
@param(v)() 插入数据 %%
@param(i)(integer) id %%
**}
if not ifnumber(i)then return;
if i >= _len then return append(v);
else if i <= 0 then
begin
_data := array(v)union _data;
end else
begin
_data := _data[0:(i-1)]union array(v)union _data[i:];
end
_len++;
end
function insertafter(v,i); //之后插入
begin
{**
@explan(说明) 在i之后插入 %%
@param(v)() 插入数据 %%
@param(i)(integer) id %%
**}
if not ifnumber(i)then return;
if i >= _len then return append(v);
else if i<0 then
begin
_data := array(v)union _data;
end else
begin
_data := _data[0:i]union array(v)union _data[i+1:];
end
_len++;
dochanged("insert");
end
function findvid(v1,func,lx); //查找序号,func通过送入的比较函数
begin
{**
@explan(说明) 查找序号和v1 匹配的id %%
@param(v1)(any) tsl数据 %%
@param(lx)(bool) 逆序查找 %%
@param(func)(fpointer) 比较函数 第一个参数为 数组中对象,第二个参数为输入判断条件 %%
**}
ret :=-1;
if lx then
begin
for i := length(_data) downto 0 do
begin
if CallCompare(_data[i],v1,func)then return i;
end
return ret;
end
for i,v in _data do
begin
if CallCompare(v,v1,func)then
begin
return i;
end
end
return ret;
end
function getprev(v1); //获得上一个
begin
{**
@explan(说明) 获得上一个 匹配的id %%
@param(v1)() tsl数据 %%
**}
if _len<2 then return nil;
id :=-1;
for i,v in _data do
begin
if CallCompare(v,v1)then
begin
id := i;
break;
end
end
return _data[id-1];
end
function getnext(v1); //获得下一个
begin
{**
@explan(说明) 获得下一个 匹配的id %%
@param(v1)() tsl数据 %%
**}
if _len<2 then return nil;
id := _len;
for i,v in _data do
begin
if CallCompare(v,v1)then
begin
id := i;
break;
end
end
return _data[id+1];
end
function ergodic(f); //循环处理
begin
{**
@explan(说明) 循环所有数据 %%
@param(f)(fpointer) 处理函数 function(id,v) begin end %%
**}
if not iffuncptr(f)then return nil;
for i,v in _data do
begin
ret := call(f,i,v); //## f(i,v);
if ret=-1 then break;
end
return 1;
end
function data(); //数组数据
begin
{**
@explan(说明) 返回所有数据 %%
**}
return _data;
end
function replace(i,v) //替换
begin
{**
@explan(说明) 替换 %%
@param(i)(integer) 序号 %%
@param(v)() tsl数据 %%
**}
if i >= 0 and i<_len then
begin
ret := _data[i];
_data[i]:= v;
dochanged("replace");
return ret;
end else
return nil;
end
function len(); //大小
begin
{**
@explan(说明) 长度 %%
**}
//return length(_data);
return _len;
end
function setorder(i,j);
begin
{**
@explan(说明) 设置元素位置 %%
@param(i)(integer)原始位置 %%
@param(j)(integer) 移动后的位置
**}
if j>_len-1 then j := _len-1;
if j<0 then j := 0;
if i=j or(i<0 or i>_len)then exit; //修改
sl := createserial(i,j);
for ii := 0 to length(sl)-2 do
begin
SwapNoCheck(sl[ii],sl[ii+1]);
end
dochanged("order");
end
function swap(i,j); //交换
begin
{**
@explan(说明) 交换 %%
@param(i)(integer) 序号 %%
@param(j)(integer) 序号 %%
**}
if ifnumber(i)and ifnumber(j)and i <> j and i >= 0 and j >= 0 and i<_len and j<_len then
begin
SwapNoCheck(i,j);
//vi := _data[i];
//_data[i]:=_data[j];
//_data[j] := vi;
end
dochanged("order");
end
property CompareValue read FCompareValue write FCompareValue;
property onchanged read fonchanged write fonchanged;
onchangelock;
private
function dochanged(info);
begin
if onchangelock then return ;
if fonchanged then CallMessgeFunction(fonchanged,self(true),info);
end
function SwapNoCheck(i,j);
begin
vi := _data[i];
_data[i]:= _data[j];
_data[j]:= vi;
end
function createserial(i,j);
begin
if j>i then return i -> j;
r := array();
kk := 0;
for ii := i downto j do r[kk++]:= ii;
return r;
end
function moveto(i,j); //将i移动到j前面
begin
{**
@ignore 忽略%%
@explan(说明) 将i移动到j前面 %%
@param(i)(integer) 序号 %%
@param(j)(integer) 序号 %%
**}
if not(ifnumber(i)and i >= 0 and i<_len)then return-1;
if ifnil(j)then j := 0;
if i=j then return-1;
vi := geti(i);
insertbefor(vi,j);
if i>j then
begin
deli(i+1);
end else
begin
deli(i);
end
end
fonchanged;
end
type TFpList=class(tarray1dlk)
{**
@explan(说明) list类 %%
**}
function create();
begin
inherited;
end
function indexof(v,f,lx);
begin
{**
@explan(说明) 查找值v在序列中的位置 %%
@param(v)(any) 任何类型 %%
@return(integer) 位置 ,等于-1 表示没查找到 %%
**}
return findvid(v,f,lx);
end
function operator[](index);
begin
{**
@explan(说明)获取序号为index的值 %%
@return(any) 数据 %%
**}
return geti(index);
end
function add(v);
begin
{**
@explan(说明)追加数据到链表 %%
@param(v)(any) 数据 %%
**}
return append(v);
end
function Remove(v);
begin
{**
@explan(说明)删除数据V %%
@param(v)(any) 数据 %%
**}
return deli(indexof(v));
end
function last();
begin
{**
@explan(说明)获取最后一个数据 %%
@return(any) 数据 %%
**}
return geti(self.Count()-1);
end
function Count();
begin
{**
@explan(说明)获取数据个数 %%
@return(integer) %%
**}
return len();
end
end
type tmy_map = class() //map对象
function create();
begin
clear();
fignorecase := true;
end
function operator[](idx);//get data
begin
k := get_true_key(idx);
return fkvs[k,1];
end
function operator[1](idx,v);//设置数据
begin
set_key_val(idx,v);
end
function operator length();
begin
return ::length(fkvs);
end
function operator for(idx); //for循环
begin
init := (idx .& 1)=0;
if init then
begin
formatkvs2();
fforpos := -1;
fforcount := ::length(fkvs2);
end
iv := (idx .& 2)=2;
if iv then //
begin
if fforpos<fforcount then
begin
fforpos++;
return array(fkvs2[fforpos,0],fkvs2[fforpos,1]);
end
end else
begin
if fforpos<fforcount then
begin
fforpos++;
return fkvs2[fforpos,0];
end
end
return nil;
end
function operator deleteindex(idx,flg);
begin
k := get_true_key(idx);
if ::deleteindex(fkvs,k,false) then
begin
fchanged := true;
end
end
function operator mrows(flg)
begin
if flg then
begin
formatkvs2();
return fkvs2[:,0];
end
return length(fkvs);
end
function clear(); //清理
begin
fkvs := array();
fkvs2 := array();
fchanged := false;
end
property ignorecase read fignorecase write setignorecase; //忽略大小写
private
function get_true_key(k);
begin
if fignorecase and ifstring(k) then return lowercase(k);
return k;
end
function setignorecase(flg);
begin
nv := flg?true:false;
if nv<>fignorecase then
begin
reset := not fignorecase ;
fignorecase := nv;
if reset then
begin
fchanged := true;
tp := fkvs;
fkvs := array();
for i,v in tp do
begin
set_key_val(v[0],v[1]);
end
end
end
end
function set_key_val(idx,v);
begin
k := get_true_key(idx);
fchanged := true;
if ifnil(v) then
begin
reindex(fkvs,array(k:v));
end else
begin
fkvs[k] := array(idx,v);
end
end
function formatkvs2(); //格式化
begin
if fchanged then
begin
fchanged := false;
fkvs2 := array();
ct := 0;
for i,v in fkvs do
begin
fkvs2[ct++] := v;
end
end
end
fignorecase;
fforcount;
fforpos;
fchanged;
fkvs2; //for 处理
fkvs;
end
type tstrindexarray = class() //字符串大小写无关下标数组
{**
@explan(数组类型) 忽略字符串下标的大小写%%
**}
function create();
begin
FData := array();
FRows := array();
end
function DeleteIndex(idx);
begin
{**
@explan(说明) 删除指定下标 %%
**}
if ifnil(idx) or ifobj(idx)then return 0;
if ifstring(idx)then
begin
lidx := lowercase(idx);
::deleteindex(FData,lidx,0);
return ::deleteindex(FRows,lidx,0);
end
::deleteindex(FData,idx,0);
return ::deleteindex(FRows,idx,0);
end
function Operator[1](index,value);
begin
if ifstring(index)then
begin
li := lowercase(index);
end else
li := index;
if ifnone(value)then
begin
r := FData[li];
if r then return r;
r := new tstrindexarray();
FData[li]:= r;
FRows[li]:= index;
return r;
end
FRows[li]:= index;
if ifarray(value)and value then
begin
r := new tstrindexarray();
FData[li]:= r;
for i,v in value do
begin
r[i]:= v;
end
return;
end
FData[li]:= value;
end
function Operator[](index);
begin
if ifstring(index)then r := FData[lowercase(index)];
else r := FData[index];
//if ifnil(r) then return NeW tstrindexarray();
return r;
end
function Size();
begin
{**
@explan(说明) 获得长度 %%
**}
return Length(FData);
end
function toarray(n);
begin
{**
@explan(说明) 获得tsl array %%
@param(n)(bool) false 返回小写下标，true 返回原始下标 %%
**}
r := array();
for i,v in FData do
begin
if v is class(tstrindexarray)then
begin
r[n?i:FRows[i]]:= v.toarray(n);
end else
r[n?i:FRows[i]]:= v;
end
return r;
end
function IndexNames();
begin
{**
@explan(说明) 获得 所有下标 %%
**}
return FRows;
end
function HaveIndex();
begin
{**
@explan(说明) 判断是否有某个下标 %%
**}
o := self(true);
for i := 1 to Paramcount do
begin
if not(o is class(tstrindexarray))then return false;
id := params[i];
if ifnil(o.TrueIndex(id))then return false;
o := o[id];
end
return true;
end
function TrueIndex(n);
begin
{**
@explan(说明) 获得对应下标 %%
**}
if ifstring(n)then idx := lowercase(n);
else idx := n;
return FRows[idx];
end
property Data write SetData;
function destroy();
begin
FData := nil;
FRows := nil;
end
private
function SetData(d);
begin
if not ifarray(d)then return false;
FRows := array();
FData := array();
si := self(true);
for i,v in d do
begin
si[i]:= v;
end
return true;
end
FData;
FRows;
end
type tnumindexarray = Class() //栈模拟
{**
@explan(说明) 数字下标数组对象 %%
**}
private
FData;
fdlength;
public
function Create();virtual;
begin
{**
@explan(说明) 构造函数 %%
**}
FData := array();
fdlength := 0;
end
function Operator[1](idx,v);
begin
{**
@explan(说明)通过下标设置元素 %%
**}
return SetValueByIndex(idx,v);
end
function Operator[](idx);
begin
{**
@explan(说明) 通过下标获取元素 %%
**}
return GetValueByIndex(idx);
end
function operator length();
begin
{**
@explan(说明) 获得数据长度 %%
@return(integer) 长度 %%
**}
return fdlength;
end
function Push({value1,value2,....});
begin
{**
@explan(说明) 在末尾追加元素,参数个数不定 %%
**}
return pushs(params);
end
function Pop();
begin
{**
@explan(说明) 弹出末尾的元素 %%
**}
if FData then
begin
id := fdlength-1;
r := FData[id];
deleteindex(FData,id);
fdlength--;
LengthChanged(-1);
return r;
end
return nil;
end
function IndexOf(v);
begin
for i,vi in FData do
begin
if vi=v then return i;
end
return -1;
end
function LastIndexOf(v);
begin
len := fdlength;
for i := len-1 downto 0 do
begin
if v=FData[i] then return i;
end
return -1;
end
function GetValueByIndex(idx);virtual;
begin
return FData[idx];
end
function SetValueByIndex(idx,v);virtual;
begin
len := fdlength;
if not(idx>=0) then return nil;
if idx <= len then
begin
FData[idx]:= v;
end else
begin
for i := len to idx do FData[i]:= nil;
FData[idx]:= v;
end
fdlength := ::length(FData);
return v;
end
function splice({startid,sellength,value1,valfue2,....});
begin
p := params;
return splices(p[0],p[1],p[2:]);
end
function shift();
begin
{**
@explan(说明) 弹出头部元素 %%
**}
r := nil;
len := fdlength;
if len>0 then
begin
deleteindex(FData,0);
fdlength--;
LengthChanged(-1);
end
return len<1?(len):(len-1);
end
function unshift({value1,value2,....});
begin
{**
@explan(说明) 在数据头部加入元素,个数待定 %%
**}
return unshifts(params);
end
function swap(i,j);
begin
{**
@explan(说明) 交换下标中的值 %%
**}
if i=j then return false;
len := fdlength;
if i >= 0 and i<len and j >= 0 and j<len then
begin
t := FData[i];
FData[i]:= FData[j];
FData[j]:= t;
return true;
end
return false;
end
function pushs(vs);
begin
if not(vs) and length(vs) then return r;
r := fdlength;
r1 := r;
FData union=vs;
r := length(FData);
//for i,v in vs do //20230724 修改 减少循环
//begin
// FData[r]:= v;
// r++;
//end
fdlength := r;
if r1 <> r then LengthChanged(r1-r);
return r;
end
function unshifts(vs);
begin
if ifarray(vs) and vs then
begin
FData := vs union FData;
fdlength := ::length(FData);
LengthChanged(1);
end
return fdlength;
end
function splices(startid,sellength,vs);
begin
{**
@explan(说明) 替换元素,第一个参数为开始位置,第二个为替换的个数,以后的参数为用来替换的值,返回被替换的值%%
**}
st := startid;
if not(st>=0) then st := 0;
sl := sellength;
sl := ifnil(sl)?inf:sl;
sl := (sl>=0)?sl:0;
len := fdlength;
st := st<0?0:st;
st := st >= len?(len):st;
et := st+sl;
et := et >= len?(len):et;
r := array();
r := FData[st:(et-1)];
r1 := FData[0:st-1];
r2 := FData[et:len-1];
if ifarray(vs) and vs then
begin
FData := r1 union vs union r2;
end else
begin
FData := r1 union r2;
end
fdlength := ::length(FData);
if len <> fdlength then LengthChanged(fdlength-len);
return r;
end
function set_len(n); //设置长度
begin
if fdlength<>n and n>=0 then
begin
ol := fdlength;
fdlength := n;
FData := nils(n);
LengthChanged(n-ol);
end
end
function LengthChanged(n);virtual;
begin
end
property Data read FData;
{**
@param(Data)(array) 数据 %%
**}
end
type tnumindexarrayex = class(tnumindexarray)
{**
@explan(说明) 扩展模拟数组 %%
**}
function create();
begin
inherited;
end
function Deli(idx);
begin
r := splice(idx,1);
return r?true:false;
end
function geti(i);
begin
return GetValueByIndex(i);
end
function InsertBefor(it,idx);
begin
splice(idx,0,it);
end
function clean();
begin
splice(nil,nil);
end
function setorder(i,j);
begin
{**
@explan(说明) 设置元素位置 %%
@param(i)(integer)原始位置 %%
@param(j)(integer) 移动后的位置
**}
len := count-1;
if j>len then j := len;
if j<0 then j := 0;
if i=j or(i<0 or i>len)then exit;
d := splice(i,1);
splice(j,0,d[0]);
end
function append(v);
begin
Push(v);
end
function add(v) ;
begin
Push(v);
end
function Remove(v);
begin
return deli(indexof(v));
end
property count read length;
end
//ifdef newgetop
type trefarray = class() //数组成员引用模拟
function create(d); //构造函数
begin
FData := d;
end
function mgset(idxs,v); //根据下标设置值
begin
return domgset(FData,idxs,v);
end
function mgget(idxs); //根据获得值
begin
return domgget(fdata,idxs);
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
published
property data read FData write setdata;
protected
function setdata(d);virtual;
begin
if FData<>d then
begin
FData := d;
return true;
end
end
function domgget(d,idxs);virtual; //根据获得值
begin
if not ifarray(idxs) then return nil;
if ifarray(d) then
begin
if ifarrayidx(idxs) then
begin
return eval(&("d"+formatarrayidx(idxs)));
end
return magicgetarray(d,idxs);
end
if d is class(trefarray) then return d.mgget(idxs,v);
end
function domgset(d,idxs,v);virtual; //根据下标设置值
begin
if not ifarray(idxs) then return nil;
if ifarray(d) then
begin
if ifarrayidx(idxs) then
begin
fsettemp := v;
s := "d"+formatarrayidx(idxs)+":=fsettemp;";
r := eval(&(s));
fsettemp := nil;
return r;
end
return magicsetarray(d, idxs,v);
end
if d is class(trefarray) then return d.mgset(idxs,v);
return nil;
end
function ifarrayidx(idx);
begin
for i,v in idx do
begin
if ifarray(v) then return true;
end
end
function formatarrayidx(idx);
begin
r := "[";
len := length(idx)-1;
for i ,v in idx do
begin
if ifarray(v) then r+=tostn(v);
else r+=tostn(v);
if i<len then
begin
r+=",";
end
end
r+="]";
return r;
end
FData; //原始数据
private //成员变量
fsettemp;
private
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;
FId;
class function sinit();
begin
if not ifarray(FValues)then FValues := array();
end
public
class function getvalue(id);
begin
sinit();
r := FValues[inttostr(id)];
//if r then reindex(FValues,id);
return r;
end
function Create(id,value);
begin
sinit();
tid := inttostr(id);
FOld := FValues[tid];
if not ifnil(FOld)then raise "全局变量冲突!";
FId := tid;
FValues[tid]:= value;
end
function destroy();
begin
reindex(FValues,array(FId:nil));
end
end
type TArrayTreeClass = class() //数组到树的转换
{**
@explan(说明) 树形类 %%
@param(FIdName)(integer | string) id名称 %%
@param(FPIdName)(integer | string) 父节点名称 %%
**}
{**
@example(转换范例) %%
d := array(("id":1,"pid":5,"caption":"jd1"),
("id":4,"pid":2,"caption":"jd2"),
("id":2,"pid":1,"caption":"jd3"),
("id":3,"pid":2,"caption":"jd4"),
("id":5,"pid":7,"caption":"jd5"),
);
dt := class(TArrayTreeClass).ToTreeArray(d,array("id":"id","pid":"pid","sub":"sub"));
return dt;
**}
private
class function ClumnNameOk(id);
begin
return ifnumber(id) or ifstring(id) ;
end
static FCounter;
static FIdName;
Static FPIdName;
static FSubName;
static FSInToArray;
FRecyce;
FInToArray;
FComponents; //节点
FId; //id
FValue; //数据
class function initconter();
begin
FCounter := 1;
end
class function GetCounter();
begin
return FCounter++;
end
public
class function SetIdName(id,pid,sub);
begin
if(id <> pid)and(ifstring(id)or ifnumber(id))and(ifstring(pid)or ifnumber(pid))and(ifstring(sub)or ifnumber(sub))then
begin
FIdName := id;
FPIdName := pid;
FSubName := sub;
end
end
function create(v);
begin
{**
@explan(说明) 构造节点 %%
**}
FId := v[FIdName];
FValue := v;
FComponents := array();
end
function addcomponent(o);
begin
{**
@explan(说明) 添加节点 %%
**}
len := length(FComponents);
for i := 0 to len-1 do if o=FComponents[i]then exit;
FComponents[len]:= o;
end
function Recycle();
begin
{**
@explan(说明) 出现死循环的时候的处理 %%
**}
if FRecyce then return;
FRecyce := true;
for i,v in FComponents do
begin
v.Recycle();
end
FComponents := array();
end
function toarray();
begin
{**
@explan(说明) 转换为array %%
**}
if FInToArray=FSInToArray then
begin
Recycle();
raise "节点关系出现循环";
end
FInToArray := FSInToArray;
ret := array();
sub := array();
for i := 0 to length(FComponents)-1 do
begin
ret[FSubName,i]:= FComponents[i].toarray();
end
for i,v in FValue do
begin
if i=FSubName then continue;
ret[i]:= v;
end
return ret;
end
class function SetColumnName(info);
begin
if not ifarray(info)then info := array("id":"id","pid":"pid","sub":"sub");
if not ClumnNameOk(info["id"])then info["id"]:= "id";
if not ClumnNameOk(info["pid"])then info["pid"]:= "pid";
if not ClumnNameOk(info["sub"])then info["sub"]:= "sub";
SetIdName(info["id"],info["pid"],info["sub"]);
end
class function ToTree(d,info);
begin
{**
@explan(说明) 二维表转换为树结构 %%
@param(d)(array) 数据包含 信息 %%
@param(info)(array) 字段信息 "id" 当前节点的字段,"pid" 当前节点的父节点字段,"sub" ,返回子节点的字段
默认值 array("id":"id","pid":"pid","sub":"sub"); %%
@return(TArrayTreeClass)
**}
SetColumnName(info);
root := new TArrayTreeClass(array(FIdName:nil,FPIdName:nil));
oarray := array();
oarray[-inf]:= root;
for i,v in d do //构建id
begin
id := v[FIdName];
ido := oarray[id];
if ifnil(ido)then
begin
ido := new TArrayTreeClass(v);
oarray[id]:= ido;
end
end
ifcycle := true;
for i,v in d do
begin
id := v[FIdName];
ido := oarray[id];
pid := v[FPIdName];
pdo := oarray[pid];
if not pdo then
begin
pdo := oarray[-inf];
ifcycle := false;
end
pdo.addcomponent(ido);
end
if ifcycle and oarray then
begin
for i,v in oarray do
begin
v.Recycle();
raise "节点关系出现循环";
break;
end
end
return root;
end
class function CreateRow(d,id,r);
begin
for i,v in d do
begin
ri := array();
if not v then continue;
ri[FIdName]:= GetCounter();
ri[FPIdName]:= id;
for j,vi in v do
begin
if j=FSubName then
begin
call(thisfunction,vi,ri[FIdName],r);
end
{else if j=FIdName or j = FPIdName then
begin
end}else
begin
ri[j]:= vi;
end
end
if ri then
begin
r[length(r)]:= ri;
end
end
end
class function TreeArrayToArray(d,info);
begin
{**
@explan(说明) 树结构转换为二维表 %%
@param(d)(array) 数据包含 信息 %%
@param(info)(array) 字段信息 "id" 当前节点的字段,"pid" 当前节点的父节点字段,"sub" ,返回子节点的字段
默认值 array("id":"id","pid":"pid","sub":"sub"); %%
@return(array)
**}
if not ifarray(d)then exit;
SetColumnName(info);
r := array();
initconter();
CreateRow(d,GetCounter(),r);
return r;
end
class function ToTreeArray(d,info);
begin
{**
@explan(说明) 二维表转换为树结构 %%
@param(d)(array) 数据包含 信息 %%
@param(info)(array) 字段信息 "id" 当前节点的字段,"pid" 当前节点的父节点字段,"sub" ,返回子节点的字段
默认值 array("id":"id","pid":"pid","sub":"sub"); %%
@return(array) 树形结构的array
**}
root := ToTree(d,info);
if not root then return;
FSInToArray := tostn(now());
r :=(root.toarray());
return r;
end
end
type TNode = class() //树节点
{**
@explan(说明) 树结点 %%
**}
private
FItems; //子项
[weakref]FParent; //父节点
public
function Create();virtual;
begin
inherited;
FExpanded := true;
FItems := new TFpList(); //子项
end
function CreateNode();virtual;
begin
return CreateObject(self(true).Classinfo(1));
end
function CreateNodeAndAppend();virtual; //构造并追加
begin
nd := CreateNode();
AppendNode(nd);
return nd;
end
function GetNodeByIndex(idx);
begin
{**
@explan(说明) 通过序号获得子节点%%
@param(idx)(TNode) %%
**}
if idx >= 0 then return FItems[idx];
return nil;
end
function set_node_index(nd,idx); //设置子项次序
begin
if not(idx>=0) then return -1;
oidx := FItems.indexof(v);
if oidx>=0 and idx<>oidx then
begin
setorder(oidx,idx);
end else return 0;
return 1;
end
function indexof(v); //获得序号
begin
return FItems.indexof(v);
end
function GetIndex();virtual;
begin
{**
@explan(说明) 获得在父节点中的序号 %%
@return(integer) 序号 %%
**}
if Parent then return Parent.indexof(self);
return -1;
end
function AppendNode(it);virtual;
begin
{**
@explan(说明) 插入一个节点 %%
@param(it)(TNode) 节点 %%
@return(bool) 是否成功 %%
**}
return InsertNode(it,FItems.Count);
end
function HasNode(nd);virtual;
begin
{**
@explan(说明) 是否为某个节点的祖先节点 %%
@param(nd)(TNode) 子节点 %%
@return(TNode|0) 如果为祖先节点,就返回查询节点的父节点 %%
**}
if not(nd is class(TNode))then return 0;
p1 := nd.Parent;
p := p1;
while p do
begin
if p=self then return p1;
if p is class(TNode)then p := p.Parent;
end
return 0;
end
function DeleteNode(nd);virtual;
begin
{**
@explan(说明) 删除节点 %%
@param(nd)(TNode) 待删除节点 %%
**}
if nd=self then return 0;
pn := HasNode(nd);
if not pn then return;
return pn.DeleteChildNode(nd);
end
function DeleteChildNode(nd);
begin
{**
@explan(说明) 删除子节点%%
@param(nd)(TNode) 节点 %%
**}
idx :=-1;
idx := indexof(nd);
if idx=-1 then return 0;
return DeleteNodeByIndex(idx);
end
function DeleteNodeByIndex(idx);
begin
{**
@explan(说明) 根据位置删除节点%%
@param(idx)(integer) 序号 %%
**}
nd := FItems[idx];
if not nd then return;
//是否显示处理
FItems.Deli(idx);
FCurrentDeleteNode := nd;
nd.parent := self(true);
FCurrentDeleteNode := nil;
return true;
end
function DeleteChildren();virtual; //
begin
{**
@explan(说明) 删除所有的子节点%%
**}
while NodeCount>0 do
begin
idx := 0;
it := FItems[idx];
FCurrentDeleteNode := it;
it.parent := self(true);
FCurrentDeleteNode := nil;
FItems.Deli(idx);
end
end
function InsertNodes(its,idx);virtual;
begin
{**
@explan(说明) 插入一个节点 %%
@param(it)( array of TNode) 字符串 %%
@param(idx)(integer) 序号 默认为0 %%
**}
idx0 := idx;
if idx<0 then idx0 := 0;
if idx>FItems.Count then idx0 := FItems.Count;
bidx := idx0;
for i,it in its do
begin
if node_insert_check(it) then
begin
FItems.InsertBefor(it,idx0);
FCurrentAddNode := it;
it.Parent := self(true);
FCurrentAddNode := nil;
idx0++;
end
end
end
function InsertNode(it,idx);virtual;
begin
{**
@explan(说明) 插入一个节点 %%
@param(it)(TNode) 字符串 %%
@param(idx)(integer) 序号 默认为0 %%
**}
if node_insert_check(it) then
begin
if idx<0 then idx := 0;
if idx>FItems.Count then idx := FItems.Count;
if not(idx >= 0)then idx := 0;
FItems.InsertBefor(it,idx);
FCurrentAddNode := it;
it.Parent := self(true);
FCurrentAddNode := nil;
return true;
end
end
function node_insert_check(it);virtual;
begin
return (it is class(TNode))and(not it.Parent);
end
function Expand();virtual; //展开
begin
FExpanded := true;
end
function UnExpand();virtual; //折叠
begin
FExpanded := false;
end
function RecyclingChildren();virtual;
begin
while NodeCount>0 do
begin
it := FItems[0];
it.Recycling();
end
end
function Recycling();virtual;
begin
p := FParent;
if p then
begin
p.DeleteNode(self);
end
while NodeCount>0 do
begin
it := FItems[0];
it.Recycling();
end
//inherited;
end
property NodeCount read GetNodeCount; //节点数
property Expanded read FExpanded write SetExpand; //展开
property Parent read FParent write SetParent; //父节点
property LastChild read GetLstChild;
{**
@param(NodeCount)(integer) 子节点数量 %%
@param(Expanded)(bool) 是否展开 %%
@param(Parent)(TNode) 父节点 %%
**}
protected
property CurrentDeleteNode read FCurrentDeleteNode;
property CurrentAddNode read FCurrentAddNode;
{**
@ignoremembers(CurrentDeleteNode,CurrentAddNode)
**}
function SetParent(V);virtual;
begin
tp := Parent;
if tp and (v=tp) and( v.CurrentDeleteNode=self ) then
begin
FParent := nil;
return;
end
if (v=tp) then return;
if(v is class(TNode))then
begin
if v.CurrentAddNode=self then
begin
FParent := v; //新节点
end else
if v.CurrentDeleteNode=self then //从节点移除
begin
FParent := nil;
end else
begin
if tp=v then return;
if tp then
begin
tp.DeleteNode(self(true));
end
v.InsertNode(self(true),v.NodeCount);
end
end else
begin
if tp then tp.DeleteNode(self(true));
end
end
private
fwilldelete;
fwilladd;
function GetLstChild();
begin
return FItems[FItems.Count-1];
end
FCurrentDeleteNode;
FCurrentAddNode;
FExpanded;
function SetExpand(v);virtual; //已经展开
begin
if v then Expanded();
else UnExpand();
end
function GetNodeCount(); //子节点数
begin
return FItems.Count;
end
end
type TTire = class()
{**
@explan(说明) tire树
**}
type TTireNode = class()
FChar;
FSub;
FEnd;
Ficase;
_tag;
function Create(v);
begin
FChar := v;
FSub := array();
FEnd := false;
Ficase := false;
end
function Add(s);
begin
v0 := s[1];
if Ficase then v0 := lowercase(v0);
vsub := FSub[v0];
if not vsub then
begin
vsub := new TTireNode(v0);
vsub.Ficase := Ficase;
FSub[v0] := vsub;
end
ls := length(s);
if ls>1 then
return vsub.Add(s[2:]);
else
begin
vsub.FEnd := true;
return vsub;
end
end
function Find(s,slen,idx);
begin
if idx>slen then return FEnd;
v0 := s[idx];
if Ficase then v0 := lowercase(v0);
vsub := FSub[v0];
if vsub then
begin
idx++;
return vsub.Find(s,slen,idx);
end
return FEnd ;
end
function find_node(s,slen,idx);
begin
if idx>slen then return (FEnd?self:0);
v0 := s[idx];
if Ficase then v0 := lowercase(v0);
vsub := FSub[v0];
if vsub then
begin
idx++;
return vsub.find_node(s,slen,idx);
end
return (FEnd?self:0);
end
function seticase(i);
begin
ni := i?true:false;
if ni<>Ficase then
begin
Ficase := ni;
for i,v in mrows(FSub,1) do
begin
vi := FSub[v];
if ni then //忽略大小写
begin
reindex(FSub,array(v:nil));
FSub[lowercase(vi.FChar)] := vi;
end else //区分大小写
begin
reindex(FSub,array(v:nil));
FSub[vi.FChar] := vi;
end
vi.seticase(i);
end
end
end
end
function Add(s);
begin
return FRoot.Add(s);
end
function Create();
begin
fignorecase := false;
FRoot := new TTireNode();
FRoot.Ficase := false;
end
function find_node(s,oidx);
begin
oidx := 1;
return FRoot.find_node(s,length(s),oidx);
end
function Find(s,slen,idx,outidx,ostr);
begin
tid := idx;
r := FRoot.Find(s,slen,idx);
if r then
begin
ostr := s[tid:idx-1];
outidx := idx;
end
idx := tid;
return r;
end
FRoot;
property ignorecase read fignorecase write setignorecase;
private
function setignorecase(i);
begin
ni := i?true :false;
if ni<>fignorecase then
begin
FRoot.seticase(ni);
end
end
fignorecase;
end
type tpairstate =class //括号状态
function Create(t);
begin
FType := ifstring(t)?t:"";
FCJ := 0;
FState := 0;
FIndexs := array(0);
FIndex := 0;
FCstate := false;
FSubcount := array(0);
end
function subitemadd();
begin
FSubcount[FIndex]++;
end
function subitemcount();
begin
return FSubcount[FIndex];
end
function GetLeft();
begin
FCstate := true;
if FState then // 上一个是左括号
begin
FCJ++;
FIndex++;
FIndexs[FIndex]:=0;
end else //上一个非左括号
begin
FIndexs[FIndex]++;
FSubcount[FIndex]:=0;
end
FState := true;
end
function GetRight();
begin
FCstate := true;
//if FCJ=0 then return ;
if FState then // 上一个是左括号
begin
//FIndexs[FIndex]++;
end else //上一个非左括号
begin
if FCJ>0 then
begin
FCJ--;
DeleteIndex(FIndexs,FIndex);
FIndex--;
end else
begin
FCstate := false;
end
end
FState := false;
end
function GetSate();
begin
if FCstate then
begin
//return inttostr(FIndexs[FCJ])+FType;
return tostn(FIndexs)+FType;// inttostr(FCJ)+"+"+inttostr(FIndexs[FIndex])+FType; length(FIndexs)+FType ;//
end
end
function Show();
begin
echo "层级:",FCJ," 序号:",FIndexs[FIndex],"状态:", FCstate;
end
property state read FState;
function Clone();
begin
r := new tpairstate(FType);
r.FCstate := FCstate;
r.FState := FState;
r.FCJ := FCJ;
r.FIndexs := FIndexs;
r.FIndex := FIndex;
r.FSubcount := FSubcount;
return r;
end
protected
FCstate;
FState;
FCJ;
FIndexs;
FSubcount;
FIndex;
FType;
end
type TIniFileExter=class()
{**
@explan(说明) ini文件读写封装 %%
**}
private
FTStringa;
FVtype;
FLowerKey;
FLowerValue;
function CheckSK(s,k);
begin
return ifstring(s) and s and ifstring(k) and k;
end
function ChangeV(V);
begin
vv := v;
case Vtype of
1:vv := vv="0"?false:true;
2:vv := StrToIntDef(vv,0);
else
begin
if FLowerValue then vv := lowercase(vv);
end
end
return vv;
end
function STNVA();
begin
{**
@explan(说明) 转换为name,value 列的二维数组 %%
**}
r := array();
for i := 0 to FTStringa.Count-1 do
begin
n := FTStringa.Names(i);
if n then
begin
if FLowerKey then n := lowercase(n);
vv := FTStringa.Values(n);
r[length(r)]:= array("name":n,"value":ChangeV(vv));
end
end
FTStringa.Clear();
return r;
end
function STNV();
begin
{**
@explan(说明) 转换为name:value 一维数组 %%
**}
nr := STNVA();
r := array();
for i,v in nr do
begin
r[v["name"]]:= v["value"];
end
return r;
end
function STA();
begin
{**
@explan(说明) 转换为一维数组 %%
**}
r := array();
for i := 0 to FTStringa.Count-1 do
begin
vi := FTStringa.Strings(i);
r[i]:= FLowerKey?lowercase(vi):vi;
end
FTStringa.Clear();
return r;
end
public
function create();
begin
{**
@explan(说明) 构造函数 %%
@param(al)(string) 别名 %%
@param(name)(string) 文件名 %%
**}
FTStringa := new TStringlist();
FAlias := "";
ffilename := "";
end
function readSection(sn);virtual;
begin
{**
@explan(说明) 读取section 下面key %%
**}
if ifstring(sn)and sn then Fini.readSection(sn,FTStringa);
return STA();
end
function ReadSections();virtual;
begin
{**
@explan(说明) 读取所有section名字 %%
**}
FIni.ReadSections(FTStringa);
return STA();
end
function ReadSectionValues(sn);virtual;
begin
{**
@explan(说明) 读取section下面的所有key:value %%
**}
if ifstring(sn)and sn then FIni.ReadSectionValues(sn,FTStringa);
return STNV();
end
function RenameSection(sn1,sn2);virtual;
begin
{**
@explan(说明) 重命名section %%
@param(sn1)(string) 旧名字 %%
@param(sn2)(string) 新名字 %%
**}
if not(sn1 and sn2 and ifstring(sn1))and ifstring(sn2)then exit;
vs1 := ReadSectionValues(sn1);
EraseSection(sn1);
for i,v in vs1 do
begin
WriteKey(sn2,i,v);
end
end
function RenameKey(sec,k1,k2);virtual;
begin
{**
@explan(说明) 重命名key %%
@param(sec)(string) section名称 %%
@param(k1)(string) 旧名字 %%
@param(k2)(string) 新名字 %%
**}
if(sec and k2 and k1 and ifstring(sec)and ifstring(k1)and ifstring(k2))then exit;
v := ReadKey(sec,k1);
DeleteKey(sec,k1);
WriteKey(sec,k2,v);
end
function ReadSectionValues2(sn);
begin
{**
@explan(说明) 获得section 数据,二维表,name,value 列
**}
if ifstring(sn)and sn then FIni.ReadSectionValues(sn,FTStringa);
return STNVA();
end
function ReadSectionValues3(sn);
begin
{**
@explan(说明) 获得section 数据,二维表,0列为key,1列为value
**}
d := ReadSectionValues2(sn);
r := array();
for i,v in d do
begin
r[length(r)]:= array(v["name"],v["value"]);
end
return r;
end
function ReadKey(sn,key,def);virtual;
begin
{**
@explan(说明) 读取key %%
**}
if CheckSK(sn,key)then return FIni.ReadString(sn,key,ifstring(def)?def:"");
return nil;
end
function WriteKey(sn,key,v);virtual;
begin
{**
@explan(说明) 写入key %%
**}
if ifnil(v)then v := "";
if CheckSK(sn,key)then return FIni.WriteString(sn,key,ifstring(v)?v:tostn(v));
return 0;
end
function DeleteKey(sn,key);virtual;
begin
if CheckSK(sn,key)then return FIni.DeleteKey(sn,key);
end
function EraseSection(sn);virtual;
begin
{**
@explan(说明)删除section %%
**}
if ifstring(sn)and sn then return FIni.EraseSection(sn);
end
function Destroy();virtual;
begin
finiobj := nil;
FTStringa := nil;
end
property VType read FVtype write FVtype;
property LowerKey read FLowerKey write FLowerKey;
property LowerValue read FLowerValue write FLowerValue;
property Alias read FAlias write setalias; //目录别名
property filename read ffilename write setfilename; //文件名
_tag;
private
property Fini read getiniobj write finiobj;
private
function getiniobj();
begin
if not(finiobj) then
begin
if ifstring(FAlias) and ifstring(ffilename) then
begin
finiobj := new TIniFile(FAlias,ffilename);
end else
begin
raise "ini读写文件错误";
end
end
return finiobj;
end
function setfilename(v);
begin
if ifstring(v) and v<>ffilename then
begin
ffilename := v;
finiobj := nil;
end
end
function setalias(v);
begin
if ifstring(v) and v<>FAlias then
begin
FAlias := v;
finiobj := nil;
end
end
FAlias;
ffilename;
finiobj;
end
type TCanvsRgnClipAutoSave=class()
{**
@expan(说明) 裁剪canvas区域,销毁时还原 %%
**}
function Create(cvs,rec);
begin
{**
@explan(说明)构造裁剪对象 %%
@param(cvs)(tcustomcanvas) canvas 对象 %%
@param(rec)(array(左上右下))区域 %%
**}
if(ifobj(cvs))and cvs.HandleAllocated()and ifarray(rec)then
begin
FW32api := cvs._wapi;
FCvsHandle := cvs.Handle;
FCrg := FW32api.CreateRectRgn(rec[0],rec[1],rec[2],rec[3]);
FBKrg := FW32api.SelectClipRgn(FCvsHandle,FCrg); //裁剪区域
FBKrg := nil;
end
end
function Destroy();
begin
if FW32api and FCvsHandle {and FBKrg} and FCrg then
begin
FW32api.SelectClipRgn(FCvsHandle,FBKrg); //恢复区域
FW32api.DeleteObject(FCrg); //销毁区域
end
FW32api := nil;
end
private
FBKrg;
FCrg;
FCvsHandle;
FW32api;
end
type tcountkernel = class() //锁计数对象
function create();
begin
Flocked := 0;
end
function add();
begin
Flocked++;
end
function del();
begin
Flocked--;
end
property locked read Flocked;
private
Flocked;
end
type tcountlocker = class() //锁对象
function create(v);
begin
if v is class(tcountkernel) then
begin
fkernel := v;
fkernel.add();
end
end
function destroy();
begin
if fkernel then fkernel.del();
end
private
fkernel;
end
//////////////////////字符串文件读取累//////////////////////////////////
type tfileer_rwraw = class() //字符串文件类型
{**
@explan(说明)字符串文件类型,load save,local_changed_check,data %%
**}
function create();
begin
ffilename := "";
fAlias := "";
fdatachanged := false;
inputchanged();
end
function load();//加载
begin
if not(ifstring(ffilename) and fileexists("",ffilename)) then return 0; //文件名不存在
p := 0;
len := filesize(fAlias,ffilename);
tm := filetime(fAlias,ffilename);
if not fdatachanged then //对象数据修改了
begin
if (len=flen) and (tm=floadtime) then return 1; //大小时间没变
end
if 1 = readfile(rwraw(),fAlias,ffilename,p,len,d) then //读文件
begin
fdata := d;
flen := len;
floadtime := tm;
floaded := true;
fdatachanged := false;
return 1;
end
end
function del();//删除
begin
if not(ifstring(ffilename) and ffilename) then return 0;
if fileexists(fAlias,ffilename) then return true;
return filedelete(fAlias,ffilename)<>1;
end
function save(); //保存
begin
if not(ifstring(ffilename) and ffilename) then return 0;
if fileexists(fAlias,ffilename) then
begin
tm := filetime(fAlias,ffilename);
if tm=floadtime then return 1;
sz := filesize(fAlias,ffilename);
if sz>length(fdata) then
begin
if filedelete(fAlias,ffilename)<>1 then return 0;
if length(fdata)=0 then
begin
return true;
end
end else
begin
p := 0;
if 1 = readfile(rwraw(),fAlias,ffilename,p,sz,d) then
begin
if fdata=d then
begin
return 1;
end
end
end
end else
begin
exportfile(ftstring(),fAlias,ffilename,"");
end
if 1=writefile(rwraw(),fAlias,ffilename,0,length(fdata),fdata) then
begin
floadtime := filetime(fAlias,ffilename);
flen := length(fdata);
floaded := true;
fdatachanged := false;
return true;
end
return false;
end
function local_changed_check(); //本地文件是否从修改后发生改变
begin
if floaded then
begin
if fileexists(fAlias,ffilename) then
begin
if floadtime<>filetime(fAlias,ffilename) then
begin
return 1; //改变
end
end else
begin
return 2; //删除
end
end
end
property fname read ffilename write setfilename;//文件名
property Alias read fAlias write fAlias; //目录别名
property data read getdata write setdata; //数据集
property ftime read floadtime;//
private
fAlias;
floadtime;
ffilename;
flen;
fdata;
fleadload;
fdatachanged;
private
function getdata();
begin
return fdata;
end
function setdata(s);//设置数据
begin
if ifstring(s) and s<>fdata then
begin
inputchanged();
fdata := s;
fdatachanged := true;
end
end
function setalias(s);
begin
if ifstring(s) and s<>fAlias then
begin
fAlias := s;
inputchanged();
end
end
function setfilename(f); //修改文件名
begin
if f<>ffilename then //文件改变
begin
ffilename := f;
inputchanged();
end
end
function inputchanged();//输入改变
begin
fdata := "";
flen := "";
floadtime := 0;
floaded := false;
end
end
type tinstancemanager = class()
{**
@explan(说明)函数c语言指针管理器 %%
**}
function create();
begin
fhandles := array();
end
function destroy();
begin
for i,v in fhandles do
begin
deleteinstance(v);
end
fhandles := array();
end
function get(f); //获得
begin
{**
@explan(说明)通过函数句柄获取c回调指针 %%
@param(f)(handler) tsl函数对象 %%
@return(pointer) c函数回调 %%
**}
id := inttostr(int64(f));
r := fhandles[id];
if r then return r;
r := makeinstance(f);
if r then
begin
fhandles[id] := r;
return r;
end
end
function del(f);
begin
{**
@explan(说明)通过函数句柄删除c回调指针 %%
@param(f)(handler) tsl函数对象 %%
@return(bool) 是否成功 %%
**}
id := inttostr(int64(f));
h := fhandles[id];
if h then
begin
r := deleteinstance(h);
reindex(fhandles,array(id:nil));
return r;
end
end
private
fhandles;
end
type tstr_step_match=class()
{**
@explan(说明)字符串数组匹配 %%
**}
private
const find_end="end";
public
function create(its); //送入匹配的字符串数组
begin
fits := array();
fcaches := array();
fcaches[""] := array();
set_items(its);
end
function step_find_idx(s:string); //匹配的序号
begin
{**
@explan(说明)匹配字符串 %%
@param(s)(string) 匹配的目标 %%
@return(array of integer) 成功的位置 %%
**}
if fcaches[s] then return fcaches[s]; //完全
osi := fcaches[""];
for i:= 1 to length(s) do
begin
si := s[1:i];
if fcaches[si] then
begin
osi := fcaches[si];
continue;
end
osi := get_same_idexs(si,osi);
if not ifarray(osi) then osi := array();
fcaches[si] := osi;
end
return fcaches[s];
end
function step_find(s); //查找匹配的字符
begin
return fits[step_find_idx(s)];
end
function set_items(its); //设置查找数据
begin
if fits<> its and check_legal(its) then
begin
fits := its;
fcaches := array();
fcaches[""] := mrows(fits,1);
end
end
private
function get_same_idexs(si,idxs);virtual; //直接判断全部
begin
asi := array();
asidx := 0;
for ii,v in idxs do
begin
if checksame(si,v) then
begin
asi[asidx++] := v;
end
end
return asi;
end
function checksame(a,b);virtual;//判断相等
begin
return pos(a,fits[ b]);
end
function check_legal(its);virtual; //合法检查
begin
return ifarray(its);
end
protected
fits; //原始数据
fcaches;
fcacheslen;
private
end
type t_ini_format_operator=class()
static const type_section=1;
static const type_skey=2;
static const type_value=3;
function create();
begin
fscript := "";
factidx := 0;
fscriptlen := 0;
fdata := array();
ffirstchar := true;
fformatdata := array();
end
function read_sections();
begin
formatini();
r := array();
idx := 0;
for i,v in fformatdata do
begin
r[idx++] := v['n'];
end
return r;
end
function read_section_values(sn);
begin
formatini();
d := fformatdata[lowercase(sn),"d"];
r := array();
if d then
begin
idx := 0;
for i,v in d do
begin
r[idx++] := v[array('k',"v")];//array("name":v['k'],"value":v["v"]);
end
end
return r;
end
function read_key(sn,key);
begin
formatini();
d := fformatdata[lowercase(sn),"d",lowercase(key),"v"];
return d;
end
function write_key(sn,key,v);
begin
formatini();
d := fformatdata[lowercase(sn)];
if d then
begin
info := fformatdata[lowercase(sn),"d",lowercase(key)] ;
if info then
begin
s := fscript;
s[info["b"]:info["e"]] := formatkv(key,v);
//script := s;
setscript(s);
end else
begin
s := fscript;
s[d["e"]:-1] := "\r\n"+formatkv(key,v);
//script := s;
setscript(s);
end
end else
begin
s := "["+sn+"]\r\n"+formatkv(key,v)+"\r\n"+fscript;
//script := s;
setscript(s);
end
end
function delete_key(sn,key);
begin
formatini();
info := fformatdata[lowercase(sn),"d",lowercase(key)] ;
if info then
begin
s := fscript;
s[info["b"]:info["e"]] := "";
setscript(s);
end
end
function delete_section(sn); //移除
begin
formatini();
d := fformatdata[lowercase(sn)];
if d then
begin
b := d["b"];
e := d["e"];
s := fscript;
s[b:e]:="";
setscript(s);
end
end
function rename_section(sn1,sn2);
begin
formatini();
d := fformatdata[lowercase(sn1)];
if d then
begin
s := fscript;
s[d["b"]:d["e2"]]:= "["+sn2+"]";
setscript(s);
end
end
function rename_key(sn,key,nkey);
begin
formatini();
info := fformatdata[lowercase(sn),"d",lowercase(key)] ;
if info then
begin
s := fscript;
s[info["b"]:info["e"]] := formatkv(nkey,info["v"]);
setscript(s);
end
end
published
property script read fscript write setscript;
private
function formatkv(key,v);
begin
return formatstr(key)+"="+formatstr(v);
end
function formatstr(s);
begin
if ifstring(s) then s1 := s;
else s1 := tostn(s);
s1 := replacetext(s1,"\r","");
return replacetext(s1,"\n","");
end
function formatini();//获取格式数据
begin
parser_ini();
if not fdata then return ;
fformatdata := array();
for i,v in fdata do
begin
d := array();
for k,kv in v.fdata do
begin
kk := kv[0];
kkv := kv[1];
if kk.fb<=kk.fe then
begin
ks := trim(fscript[kk.fb:kk.fe]);
end else ks := "";
if kkv.fb<=kkv.fe then
begin
ksv := trim(fscript[kkv.fb:kkv.fe]);
end else ksv := "";
d[lowercase(ks)] := array("k":ks,"v":ksv,"b":kk.fb,"e":kkv.fe);
end
fformatdata[lowercase(v.fv)] := array("n":v.fv,"d":d,"b":v.fb,"e":v.fe,"e2":v.fe2);
end
fdata := array();
end
function parser_v();
begin
v := new tobjv(type_value,factidx+1);
while factidx<fscriptlen do
begin
factidx++;
vi := fscript[factidx];
if vi="\r" or vi="\n" then
begin
v.fe := factidx-1;
ffirstchar := true;
return v;
end
end
v.fe := factidx;
return v;
end
function parser_ini();
begin
if factidx>=fscriptlen then return ;
k := new tobjv(type_skey,factidx+1);
while factidx<fscriptlen do
begin
factidx++;
vi := fscript[factidx];
if ffirstchar then
begin
case vi of
"[":
begin
if fcsection.fv or fcsection.fdata then
begin
fdata[length(fdata)] := fcsection;
fcsection.fe := factidx-1;
end
fcsection := new tobjv(type_section,factidx);
parser_section();
end
"=":
begin
k.fe := factidx-1;
fcsection.add(k,parser_v());
k := new tobjv(type_skey,factidx);
end
";","#": //走到下一行
begin
gotonextline();
end
"\r","\n":
begin
end else
begin
ffirstchar := false;
k.fb := factidx;
end
end ;
end else
begin
case vi of
"\r","\n":
begin
ffirstchar := true;
parser_ini();
end
"=":
begin
k.fe := factidx-1;
fcsection.add(k,parser_v());
k := new tobjv(type_skey,factidx);
end
end
end
end
if fdata[length(fdata)-1]<>fcsection then
fdata[length(fdata)] := fcsection;
fcsection.fe := fscriptlen;
end
function parser_section();
begin
sn := "";
while factidx<fscriptlen do
begin
factidx++;
vi := fscript[factidx];
if vi="\r" or vi="\n" then
begin
ffirstchar := true;
break;
end
if vi="]" then //section 关闭
begin
fcsection.fv := trim(sn);
fcsection.fe2 := factidx;
ffirstchar := false;
return parser_ini();
end
sn+=vi;
end
end
function gotonextline(); //到达下一行
begin
while factidx<fscriptlen do
begin
factidx++;
vi := fscript[factidx] ;
if vi="\n" then
begin
ffirstchar := true;
break;
end
end
end
function setscript(s);
begin
if ifstring(s) and s<>fscript then
begin
fscript := s;
script_init();
end
end
function script_init();
begin
fscriptlen := length(fscript);
factidx := 0;
fdata := array();
ffirstchar := true;
fcsection := new tobjv(type_section,1);
end
fscript;
fscriptlen;
factidx;
fcsection;
fdata;
fformatdata;
ffirstchar;
type tobjv = class()
function create(t,b);
begin
fb := b;
fe := -1;
fv := "";
ft := t;
fdata := array();
end
function add(k,v);
begin
fdata[length(fdata)] := array(k,v);
end
fdata;
fb;
fe;
fe2;
fv;
ft;
end
end
type t_gbk_text_finder = class() //查找对象
function create();
begin
ffindstr:="";
fstr := "";
Fismline := true;
findflag := false;
FisReg := false;
fiswrap := false;
fiscase := false;
fiscycle := true;
fisprev := false;
frc := array(1,1);
end
function set_text(s); //文本
begin
if fstr<>s then
begin
fstr := s;
ftextrows := text_2_array(fstr);
findflag := true;
end
end
function set_replace_str(s);
begin
if frstr<>s then
begin
frstr := s;
frstrflag := true;
end
end
function set_find_str(s);
begin
if ffindstr <> s then
begin
ffindstr := s;
findflag := true;
end
end
function set_rc(rc); //设置当前行列 1,1 为初始位置
begin
if ifarray(rc) and rc[0]>0 and rc[1]>0 then
begin
frc := rc;
end
end
function find_one(); //查找下一个
begin
if fisprev then return find_prev();
return find_next();
end
function format_rep_Str(info); //构造替换
begin
ms :=get_rep_str_info();
if ifarray(ms) then
begin
fr :=frstr;
for j := length(ms)-1 downto 0 do
begin
si := fmachs[i,ms[j,3],0];
if not ifstring(si) then return false;
fr[ms[j,1]:ms[j,2]] := si;
end
return fr;
end
return ms;
end
function find_all(); //全部查找
begin
do_find();
r := array();
for i,v in fmachs do
begin
//array(vj,p,pe,array(r1,c1),array(r2,c2),row_text(r1))
r[i] := format_find_return(v);
end
return r; //返回信息
end
function replace_all(var r);//全部替换,为变参返回,返回结果是行列信息
begin
do_find();
if not fmachs then return 0;
ms := get_rep_str_info();
r := fstr;
rinfo := array();
for i := length(fmachs)-1 downto 0 do
begin
info := fmachs[i];
rs := format_rep_Str(info);
if rs=0 then return false;
p1 := info[0,1] ;
p2 := info[0,2];
r[p1:p2] := rs;
rinfo[i] := format_find_return(info);
end
if r=fstr then return 0;
return rinfo;
end
function find_next();//下一个
begin
do_find();
label findtwo;
for i,v in fmachs do
begin
if frc[0]<v[0,3,0] or(frc[0]=v[0,3,0] and frc[1]<=v[0,3,1]) then
begin
frc := v[0,4];
return v;
end
end
if not fiscycle then return array();
if two then return array();
two := true;
frc := array(1,1);
goto findtwo;
end
function find_prev();//上一个
begin
do_find();
label findtwo;
for i:= length(fmachs)-1 downto 0 do
begin
v := fmachs[i];
if frc[0]>v[0,3,0] or(frc[0]=v[0,3,0] and frc[1]>=v[0,4,1]) then
begin
frc := v[0,3];
return v;
end
end
if not fiscycle then return array();
if two then return array();
two := true;
ls := length(ftextrows);
frc := array(ftextrows[ls-1,0],ftextrows[ls-1,1]);
goto findtwo;
end
property isReg read FisReg write set_reg;//正则
property iscase read fiscase write set_case;//大小写
property iswrap read fiswrap write set_wrap;//全词匹配
property iscycle read fiscycle write set_cycle;//循环查找
property isprev read fisprev write set_prev;//朝前
property ismline read Fismline write set_mline;//朝前
private
function set_mline(v);
begin
nv := v?true:false;
if nv<>Fismline then
begin
Fismline := nv;
findflag := true;
end
end
function set_prev(v);
begin
nv := v?true:false;
if nv<>fisprev then
begin
fisprev := nv;
end
end
function set_cycle(v);
begin
nv := v?true:false;
if nv<>fiscycle then
begin
fiscycle := nv;
end
end
function set_reg(v);
begin
nv := v?true:false;
if nv<>fisreg then
begin
fisreg := nv;
findflag := true;
frstrflag := true;
end
end
function set_case(v);
begin
nv := v?true:false;
if nv<>fiscase then
begin
fiscase := nv;
findflag := true;
end
end
function set_wrap(v);
begin
nv := v?true:false;
if nv<>fiswrap then
begin
fiswrap := nv;
findflag := true;
end
end
function row_text(i);//获得行文本
begin
return ftextrows[i-1,2];
end
function p_to_rc(p,r,c);//位置到行列
begin
r := -1;
c := -1;
for i,v in ftextrows do
begin
if p>=v[0] and p<=(v[1]) then
begin
r := i+1;c := p-v[0]+1;
return ;
end
end
end
function fmt_unreg_ctl(tg,rg,wr);//正则控制串
begin
if not tg then return "";
ctl := tg;
if not rg then
begin
ctl := "";
ltg := length(tg);
for i := 1 to length(tg) do
begin
vi := tg[i];
cvi := ord(vi);
if cvi>=9 and cvi<=13 then
begin
ctl +="\\s";
if i=1 then wrp :=1;
if i=ltg then wrp .|= 2;
end else
if (cvi>=0x21 and cvi<=0x2f) or
(cvi>=0x3a and cvi<=0x40) or
(cvi>=0x5b and cvi<=0x60) or
(cvi>=0x7b and cvi<=0x7e) then
begin
ctl +="\\"+vi;
if i=1 then wrp :=1;
if i=ltg then wrp .|= 2;
end else
begin
ctl+=vi;
end
end
if wr then
begin
if not((wrp .& 1) >0) and not((ord(ctl[1]) .& 0x80 )>0) then ctl := "\\b"+ctl;
if not((wrp .& 2) >0) and not((ord(ctl[length(ctl)]) .& 0x80 )>0) then ctl := ctl+"\\b";
end
end
return ctl;
end
function text_2_array(s); //获得行位置
begin
r := array();
fgf := "\n";
if pos("\r\n",s) or pos("\n",s) then
begin
fgf := "\n";
end else
if pos("\r",s) then
fgf := "\r";
r[0,0] := 1;
idx := 0;
for i := 1 to length(s)-1 do
begin
vi := s[i];
if vi=fgf then
begin
r[idx,1]:=i;
r[idx,2]:=s[r[idx,0]:(i-1)];
idx++;
r[idx,0] := i+1;
end
end
r[idx,1]:=length(s)+1;
r[idx,2]:=s[r[idx,0]:];
return r;
end
function do_find();//查找
begin
if not findflag then return ;
findflag := false;
fs := fmt_unreg_ctl(ffindstr,FisReg,fiswrap);
ctl2 := "";
if Fismline then ctl2 += "m";
if fiscase then ctl2+="i";
fmachs := array();
frows := array();
if 1= ParseRegExpr(fs,fstr,ctl2,m,mp,ml) then
begin
for i ,v in m do
begin
for j,vj in v do
begin
p := mp[i,j];
pe := p+ml[i,j]-1;
p_to_rc(p,r1,c1);
p_to_rc(pe+1,r2,c2);
if j=0 and not(frows[r1]) then
begin
frows[r1] := true;
fmachs[i,j] := array(vj,p,pe,array(r1,c1),array(r2,c2),row_text(r1));
end else fmachs[i,j] := array(vj,p,pe,array(r1,c1),array(r2,c2));
end
end
end
end
function get_rep_str_info(); //替换字符串信息
begin
if frstrflag then
begin
frstrflag := false;
if frstr then //
begin
if FisReg then //正则表达式
begin
if 1= ParseRegExpr("\\$(\\d+)",frstr,"",m,mp,ml) then //占位符计算
begin
ms := array();
for i:= 0 to length(m)-1 do
begin
ms[i,0] := m[i,0];
ms[i,1] := mp[i,0];
ms[i,2] := mp[i,0]+ml[i,0]-1;
ms[i,3] := strtointdef(m[i,1],0);
end
end else
begin
ms := frstr;
end
end else
begin
ms := frstr;
end
end else
begin
ms := "";
end
freginfo := ms;
end else
begin
ms := freginfo;
end
return ms;
end
function format_find_return(v); //格式化一个匹配结果
begin
r := array();
r[0] := v[0,0];//匹配结果
r[1] := v[0,3];//配合开始的行列
r[2] := v[0,4];//截止的行列
r[3] := v[0,5];//行内容
return r;
end
private
frstr;
ffindstr;
fstr;
Fismline;
findflag;
frstrflag;
freginfo;
fisprev;
fiscycle;
FisReg;
fiscase;
fiswrap;
ftextrows;
fmachs;
frc;
end
implementation
function iffuncptr(fn);
begin
//return datatype(fn)=7;
return fn and ifobj(fn);
end
function includestate(u,s);
begin
{**
@explan(说明) 状态扩展 %%
**}
if not ifarray(u)then u := array();
if ifarray(s)then u union2= s;
else u union2= array(s);
return u;
end
function excludestate(u,s);
begin
{**
@explan(说明) 状态缩减%%
**}
if not ifarray(u)then u := array();
if ifarray(s)then u minus= s;
else u minus= array(s);
return u;
end
//*************makelong*****************************
function makelong(low,high,ptrl);
begin
{**
@explan(说明) 合并高低为 %%
@return(integer) 整数 %%
@param(low)(integer) 低位 %%
@param(high)(integer) 高位 %%
@param(ptrl)(integer) 长度 默认为 8 %%
**}
if not ifnumber(ptrl)then ptrl := 16;
mask := 2^(ptrl)-1;
low1 := low .& mask;
high1 := high .& mask;
return _shl(high1,ptrl).| low1;
end
function makeposition(x,y);
begin
{**
@explan(说明)将x,y构造为一个int类型 %%
@return(integer)
**}
if ifnumber(x)and ifnumber(y)then return makelong(signedtounsigned(x),signedtounsigned(y));
return 0;
end
function lowuperdword(value_,lvalue,uvalue,ptrl);
begin
{**
@explan(说明) 高低位获取 %%
@param(value_)(integer) 整数 %%
@param(lvalue)(integer) 低位 %%
@param(uvalue)(integer) 高位 %%
@param(ptrl)(integer) 长度 默认为 8 %%
**}
lvalue := uvalue := 0;
if not ifnumber(value_)then return array(0,0);
if not ifnumber(ptrl)then ptrl := 16;
value :=(value_);
mask := 2^(ptrl)-1;
uvalue := _shr(value,ptrl).& mask;
//t := _shl(value,ptrl);
//lvalue := _shr(t,ptrl) .& mask;
lvalue := value .& mask;
return array(lvalue,uvalue);
end
function signedtounsigned(v,n);
begin
{**
@explan(说明) 符号数转换为无符号数 %%
@param(v)(integer) 数字 %%
@param(n)(integer) 有效位数 %%
@return(integer)
**}
if not ifnumber(n)then n := 16;
if n>64 then n := 64;
mkv2 := 1;
ret := mkv2 .& v;
for i := 1 to n-1 do
begin
mkv2 := _shl(mkv2,1);
ret +=(mkv2 .& v);
end
mkv2 := _shl(mkv2,1);
if v<0 then
begin
ret .|= mkv2;
end else
begin
ret .&=(.! mkv2);
end
return ret;
end
function getbitsfrominteger(n,b,e);
begin
{**
@explan(说明) 获取数字的位数并转换为整数 %%
@param(b)(integer) 开始位 %%
@param(e)(integer) 截止位 %%
@param(n)(integer) 数字 %%
@return(integer)
**}
r := 0;
if b<0 then return 0;
mk := 2^(b);
for i := b to e do
begin
if(mk .& n)>0 then r += _shr(mk,b);
mk := _shl(mk,1);
end
return r;
end
function unsignedtosigned(v,n);
begin
{**
@explan(说明) 无符号数转换为符号数 %%
@param(v)(integer) 数字 %%
@param(n)(integer) 有效位数 %%
@return(integer)
**}
if not ifnumber(n)then n := 16;
if n>64 then n := 64;
mkv := 0;
mkv := _shl(1,n-1);
mkv2 := 1;
for i := 1 to n-1 do
begin
mkv2 := _shl(mkv2,1);
mkv2 += 1;
end
vv := v .& mkv2;
if(v .& mkv)then
begin
return 0-((_not(vv) .& mkv2)+1);
end
return vv;
end
function bitcombination(s,v,f);
begin
{**
@explan(说明)bit位组合 %%
@param(s)(integer) 原有值 %%
@param(v)(integer) 追加或者删除 %%
@param(f)(integer) 0 为 or ,1 为 and ;2 表示 删除 v的值 %%
**}
if not(ifnumber(s)and ifnumber(v))then return 0;
case f of
0:return s .| v;
1:return s .& v;
2:return(.!v).& s;
else return s;
end
hv :=((s .& v)=v);
if(hv)and f=2 then
begin
return(.!v).& s;
end else
if(f=0)and not(hv)then
begin
return s .| v;
end else
if(f=1)and not(hv)then
begin
return s .& v;
end else
return s;
end
function formatshortcut(d);
begin
r := "";
if d then
begin
if d["c"] then r +=(r)?"+Ctrl":"Ctrl";
if d["s"] then r +=(r)?"+Shift":"Shift";
if d["a"] then r +=(r)?"+Alt":"Alt";
if d["f"] then r +=(r)?("+"+d["f"]):d["f"];
if d["w"] then r +=(r)?("+"+d["w"]):d["w"];
end
return r;
end
function parsershortcutstr(s_); //快捷键解析
begin
s := uppercase(s_);
ls := length(s);
zmb := array();
fb := array();
for i := 65 to 90 do zmb[chr(i)] := true;
for i:= 1 to 12 do fb["F"+inttostr(i)] := true;
cword :="";
i := 1;
r := array();
while(i<=ls) do
begin
vi := s[i];
vio := ord(vi);
case vio of
65 to 90 ,48 to 57:
begin
cword +=vi;
end
else
begin
if cword then
begin
case cword of
"SHIFT":
begin
r["s"] := true;
end
"CTRL":
begin
r["c"] := true;
end
"ALT":
begin
r["a"] := true;
end
else
begin
if fb[cword] and not(r["w"]) then
begin
r["f"] := cword;
end else
if r and not(r["f"]) then
begin
if zmb[cword] then r["w"] := cword;
end
end
end ;
end
cword := "";
end
end;
i++;
end
if cword then
begin
case cword of
"SHIFT":
begin
r["s"] := true;
end
"CTRL":
begin
r["c"] := true;
end
"ALT":
begin
r["a"] := true;
end
else
begin
if fb[cword] and not(r["w"]) then
begin
r["f"] := cword;
end else
if r and not(r["f"]) then
begin
if zmb[cword] then r["w"] := cword;
end
end
end ;
end
if not(r["w"] or r["f"]) then r := array();
return r;
end
function FormatTslData(d,sj,tn);
begin
{**
@explan(说明) 格式化tsl数据 %%
@param(d)(any) tsl数据 %%
@param(sj)(string) 空格距离 %%
@param(tn)(nil) 空参数 %%
@return(string) 格式化后的字符串 %%
**}
r := "";
if not(sj and ifstring(sj))then sj := " ";
if ifarray(d)then
begin
r := "(\r\n";
if ifnil(tn)then
begin
tn := 0;
r := "array(\r\n";
end
di := 0;
len := length(d);
for i,v in d do
begin
bt := sj;
if di <> i then
begin
bt += tostn(i)+":";
end
di++;
vr := FormatTslData(v,sj,1);
if len>di then vr += ",";
r += bt;
if ifarray(v)then
begin
vrs := str2array(vr,"\r\n");
dii := 0;
for j,vj in vrs do
begin
if dii<1 then r += vj;
else r += sj+vj;
r += "\r\n";
dii++;
end
end else
r += vr+"\r\n";
end
r += ")";
return r;
end else
return tostn(d);
end
function DeleteItemsByIndexs(r,dxs);
begin
{**
@explan(说明) 删除数组下标, %%
@param(r)(array) 待删除下标的数组,采用字符串下标的数组,变参返回%%;
**}
if not ifarray(r)then exit;
rdx := array();
for i,v in dxs do rdx[v]:= nil;
return reindex(r,rdx);
end
function HexHash();
begin
c := array("A","B","C","D","E","F");
idxs := inttostr(0 -> 9)union c union lowercase(c);
r := array();
for i,v in idxs do
begin
if i<16 then r[v]:= i;
else r[v]:= i-6;
end
return r;
end
function TslToHexStr(t);
begin
{**
@explan(说明) 将tsl数据转换为16进制字符串 %%
@param(t)(any) 任意的tsl数据 %%;
@return(string) 16进制字符串 %%
**}
r := "";
str := tostm(t,0,1);
ky := static(inttostr(0 -> 9)union array("A","B","C","D","E","F"));
idx := 1;
setlength(r,length(str)* 2);
for i := 0 to length(str)-1 do
begin
vi := ord(str[i]);
//r += ky[_shr(vi,4) .& 0xf];
//r += ky[vi .& 0xf] ;
r[idx]:= ky[_shr(vi,4).& 0xf];
r[idx+1]:= ky[vi .& 0xf];
idx += 2;
end
return r;
end
function HexFormatStrToTsl(hex);
begin
{**
@explan(说明)将带有换行符的16进制字符串转换为tsl数据 %%
@param(hex)(string) 16进制字符串 %%
@return(any) tsl数据类型 %%
**}
r := "";
hs := static HexHash();
//rs := inttostr(0 -> 9)union array("A","B","C","D","E","F","a","b","c","d","e","f");
for i := 1 to length(hex) do
begin
ri := hex[i];
if hs[ri]>=0 then
begin
r += ri;
end
end
return HexStrToTsl(r);
end
function TslToHexFormatStr(tsl);
begin
{**
@explan(说明) 将tsl类型转换为16进制字符串,每行长度为64,用\r\n分割 %%
@param(tsl)(any) tsl基础类型%%
@return(string) 字符串形式的16进制 %%
**}
s := TslToHexStr(tsl);
r := "";
n := length(s);
i := 1;
bc := 64;
while true do
begin
if i>n then break;
ij := i+bc;
if ij>n and i <= n then
begin
r += s[i:n];
break;
end else
r += s[i:ij];
if ij>n then break;
r += "\r\n";
i := ij+1;
end
return r;
end
function HexStrToTsl(hex);
begin
{**
@explan(说明)16进制字符串转换为tsl数据 %%
@param(hex)(string) 16进制字符串 %%
@return(any) tsl数据类型 %%
**}
if not(hex and ifstring(hex)) then return nil;
r := tostm(nil);
setlength(r,Integer(length(hex)/2));
hs := static HexHash();
idx := 0;
for i := 1 to length(hex)-1 step 2 do
begin
vi := hs[hex[i]];
vi1 := hs[hex[i+1]];
r[idx]:= _shl(vi,4).| vi1;
idx++;
end
return stm(r);
end
function gettemppath();
begin
{**
@explan(说明)获取windows临时目录 %%
@return(string) 目录;
**}
{$ifdef linux}
return "/var/tmp/";
{$endif}
s := "";
n := 1024;
setlength(s,n);
s1 := s;
GetTempPathA(n,s);
GetLongPathNameA(s,s1,n);
r := "";
for i := 1 to n do
begin
vi := s1[i];
if vi="\0" then
begin
return s1[1:(i-1)];
end
end
return "";
end
function TSL_ReservedKeys(var buf:string;buflen:integer):integer;cdecl;external{$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TSL_ReservedKeys";
function TSL_ReservedKeys2();
begin
ks := "";
setlength(ks,1024 * 10);
TSL_ReservedKeys(ks,length(ks)-1);
r := array();
rl := 0;
ki := "";
for i := 1 to length(ks)-1 do
begin
vi := ks[i];
if vi="\0" then break;
if vi="\n" then
begin
if ki then
begin
r[rl++]:= ki;
ki := "";
end
end else
ki += vi;
end
return r union2 array("read","write"); //添加read write 关键字
end
function GetLongPathNameA(var s1:string;var s:string;L:integer):integer;stdcall;external "Kernel32.dll" name "GetLongPathNameA";
function GetTempPathA(L:integer;var s:string):integer;stdcall;external "Kernel32.dll" name "GetTempPathA";
function ParserCommandLine(s); //解析命令行参数
begin
r := array();
if not ifstring(s) then return r;
len := length(s);
p := "";
while idx<len do
begin
idx ++;
vi := s[idx];
if vi = '"' then
begin
if p then r[length(r)] := p;
p := "";
while idx<len do
begin
idx++;
vi := s[idx];
if vi = '"' then
begin
r[length(r)] := p;
p := "";
break;
end
p+=vi;
end
end else
if vi=" " or vi="\t" then
begin
if p then r[length(r)] := p;
p := "";
end else
p+=vi;
end
if p then r[length(r)] := p;
return r;
end
function intersectrect(rec1,rec2,irec);
begin
{**
@explan(说明) 计算矩形的交集 %%
@param(rec1)(array of integer) 矩形区域 %%
@param(rec2)(array of integer) 矩形区域 %%
@param(irec)(var array of integer) 重叠的区域 %%
@return(bool)
**}
if lineintersect(array(rec1[0],rec1[2]),array(rec2[0],rec2[2]),d1)and lineintersect(array(rec1[1],rec1[3]),array(rec2[1],rec2[3]),d2)then
begin
irec := array(d1[0],d2[0],d1[1],d2[1]);
return true;
end
return 0;
end
function pointinrect(p,rec);
begin
{**
@explan(说明) 判断点是否在矩形中 %%
@param(rec)(array of integer) 矩形区域 %%
@param(p)(array of integer) 点 array(x,y) %%
@return(bool)
**}
x := p[0];
y := p[1];
return x>rec[0]and y>rec[1]and x<rec[2]and y<rec[3];
end
function lineintersect(xx1,xx2,xx);
begin
if(xx1[0]>xx2[0]and xx1[0]>xx2[1])or(xx2[0]>xx1[1]and xx2[1]>xx1[0])then return 0;
xx := array(max(xx1[0],xx2[0]),min(xx1[1],xx2[1]));
return 1;
end
function leapyear(y); //闰年判断
begin
if not(y mod 4) then
begin
if not(y mod 100) then
begin
return not(y mod 400);
end
return 1;
end
return 0;
end
function getmonthdates(y,m); //获得所在月的天数
begin
if m = 2 then return leapyear(y)+ 28;
if m in array(1,3,5,7,8,10,12) then return 31;
return 30;
end
function CallMessgeFunction(f,o,e);
begin
{**
@ignore(忽略)
**}
if iffuncptr(f) then return call(f,o,e);
end
function CheckArrayIsNumbers(Value,n);
begin
if not(ifnumber(n)and n >= 1)then n := 4;
if ifarray(Value)then
begin
for i := 0 to n-1 do
begin
if not(ifnumber(Value[i]))then return 1;
end
return 0;
end
return 1;
end
function CheckArrayIsControlRect(Value);
begin
{**
@explan(说明) 检查数组是否可以作为control的rect %%;
**}
if not(CheckArrayIsNumbers(Value,4))then
begin
return Value[3]>0 and Value[2]>0;
end
end
function CheckArrayIsControlBounds(Value);
begin
{**
@explan(说明) 检查数组是否可以作为control 的 bounds
**}
if not(CheckArrayIsNumbers(Value,4))then
begin
return(Value[3]>Value[1])and(Value[2]>Value[0]);
end
end
function intasposition(i);
begin
if ifnumber(i)then
begin
return lowuperdword(i);
end
return array(0,0);
end
function DeleteAllFiles(path);
begin
{**
@explan(说明) 删除指定路径的文件或者文件夹 %%
**}
if not ifstring(path)then return 0;
if not path then return 0;
iofp := ioFileseparator();
if path[length(path)]=iofp then return call(thisfunction,path[1:(length(path)-1)]);
info := FileList("",path); //"A"
if info then
begin
if pos("D",info[0]["Attr"])then
begin
fs := FileList("",path+iofp+"*");
for i,v in fs do
begin
n := v["FileName"];
if n in array(".","..")then continue;
call(thisfunction,path+iofp+n);
end
return RemoveDir("",path);
end else
begin
return FileDelete("",path);
end
return 0;
end
end
function CreateDirWithFileName(fname);
begin
{**
@explan(说明) 根据文件全名构造目录 %%
**}
if not(ifstring(fname)and(length(fname)>4))then exit;
info := FileList("",fname);
if info then exit;
len := length(fname);
iofp := ioFileseparator();
for i := len downto 1 do
begin
vi := fname[i];
if vi=iofp then
begin
ffname := fname[1:i];
break;
end
end
if not ffname then exit;
ffL := length(ffname);
{$ifdef linux}
nct := 1;
if ffL<1 then exit;
{$else}
nct := 4;
if ffL<4 then exit;
{$endif}
ph := ffname[1:nct];
for i := nct+1 to ffL do
begin
vi := ffname[i];
if vi=iofp then
begin
if not FileList("",ph)then
begin
CreateDir("",ph);
end
end
ph += vi;
end
end
{$ifdef linux}
function TS_GetUserProfileHome();
begin
home := sysgetenv("HOME");
if home then bpath := home+"/.vcl/";
else
bpath := ".vcl/";
return bpath;
end
{$else}
function TS_GetUserProfileHome():string;cdecl;external "TSSVRAPI.dll" name "TS_GetUserProfileHome";
{$endif}
function TS_GetUserProfileHomeInstance(t:integer):string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_GetUserProfileHomeInstance";
function TS_GetUserConfigHome(t:integer):string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_GetUserConfigHome";
function TS_GetHomePath(t:integer):string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_GetHomePath";
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_GetAppPath";
function TS_GetIniPath(t:integer;iname:string):string;cdecl;external {$ifdef linux}"libTSSVRAPI.so"{$else}"TSSVRAPI.dll"{$endif} name "TS_GetIniPath";
function int_to_binary(d,n); //整数转换成字符串
begin
r := "";
x := d;
ct := 0;
if not(n>1)then n := 8;
while x>0 do
begin
divmod(x,2,a,b);
r := inttostr(b)+r;
x := a;
ct++;
if ct >= n then break;
end
if ct=0 then
begin
ct := 1;
r := "0";
end
for i := ct to n-1 do
begin
r := "0"+r;
end
return r;
end
function istextascii(s); //ansi编码
begin
len := length(s);
//m := new TMemoryStream();
//dp := get_tsl_mem_ptr(s);
//m.setmemory(dp,len);
//ci := 0;
i := 1;
for i:= 1 to len do
begin
ci := ord(s[i]);
//m.read(ci,1);
if((ci .& 0x80)<> 0) then return false;
end
return true;
end
function isTextGBK(data) //gbk编码
begin
if not ifstring(data) then return 0;
i := 1;
len := length(data);
while (i <= len) do
begin
ordi := ord(data[i]);
if (ordi <= 0x7f) then
begin
//编码小于等于127,只有一个字节的编码，兼容ASCII
i++;
continue;
end else
begin
ordi2 := ord(data[i + 1]);
//大于127的使用双字节编码
if (ordi >= 0x81 and
ordi <= 0xfe and
ordi2 >= 0x40 and
ordi2 <= 0xfe and
ordi2 <> 0x7f) then
begin
i += 2;
continue;
end else
begin
return false;
end
end
end
return true;
end
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
function get_resource_by_name(n,full);
begin
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,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
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
end
end
function get_tsl_mem_ptr(s,n);
begin
ptr := static makeinstance(thisfunction(get_tsl_ptr_drift));
if ifwstring(s) then
begin
_f_ := static function(var v:widestring;n:integer):pointer;cdecl;external ptr;
end else
if ifstring(s) then
begin
_f_ := static function(var v:string;n:integer):pointer;cdecl;external ptr;
end else
if ifint(s) then
begin
_f_ := static function(var v:integer;n:integer):pointer;cdecl;external ptr;
end else
if ifint64(s) then
begin
_f_ := static function(var v:int64;n:integer):pointer;cdecl;external ptr;
end else
if ifnumber(s) then
begin
_f_ := static function(var v:double;n:integer):pointer;cdecl;external ptr;
end else
if ifobj(s) then
begin
_f_ := static function(var v:TObject;n:integer):pointer;cdecl;external ptr;
end
return call(_f_,s,((n>0)?n:0));
end
{function tsl_str_head_at(s,n);
begin
_f_ := static function(var v:string;n:integer):string;cdecl;external makeinstance(thisfunction(get_tsl_ptr_drift));
return ##_f_(s,n);
end }
function get_tsl_ptr_drift(v:pointer;n:integer):pointer;cdecl;
begin
if n>0 then return v+n;
return v;
end
initialization
uinit();
end.
//////////////////////暂时没用到的类型///////////////////////////////////////
(*
type TFileLocker=class()
{**
@ignore(忽略) %%
@explan(说明) 文件锁定 %%
**}
private
FHandle;
FLocked;
FApi;
function GetFileOpen();
begin
return FHandle <> 0;
end
function GetFileLocked();
begin
return FLocked <> 0;
end
public
function Create(F);
begin
{**
@explan(说明)对文件加锁,防止其他进程读写 %%
@param(f)(string) 文件名 %%
**}
FHandle := 0;
FLocked := 0;
if not FileExists("",f)then exit;
FApi := gettswin32api();
FHandle := FApi.CreateFileA(F,0x40000000L,0,0,3,0x00000080,0);
if not FHandle then exit;
FLocked := FApi.LockFile(FHandle,0,0,0,0);
end
function Destroy();
begin
if FLocked then
begin
FApi.UnlockFile(FHandle,0,0,0,0);
end
if FHandle then
begin
FApi.CloseHandle(FHandle);
end
end
property FileOpend read GetFileOpen;
property FileLocked read GetFileLocked;
{**
@param(FileOpend)(bool) 是否有效%%
@param(FileLocked)(bool) 是否已经锁定%%
**}
end
type Ttagaccel=class(tslcstructureobj)
private
static SSTRUCT;
class function getstruct()
begin
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
("fvirt","byte",0),
("key","short",0),
("cmd","short",0)));
return SSTRUCT;
end
public
function create(ptr)
begin
inherited create(getstruct(),ptr);
end
property fvirt index "fvirt" read _getvalue_ write _setvalue_;
property key index "key" read _getvalue_ write _setvalue_;
property cmd index "cmd" read _getvalue_ write _setvalue_;
end
type TBITMAPINFOHEADER=class(tslcstructureobj)
private
static SSTRUCT;
class function getstruct()
begin
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
("bisize","int",40),
("biwidth","int",0),
("biheight","int",0),
("biplanes","short",0),
("bibitcount","short",0),
("bicompression","int",0),
("bisizeimage","int",0),
("bixpelspermeter","int",0),
("biypelspermeter","int",0),
("biclrused","int",0),
("biclrimportant","int",0)
));
return SSTRUCT;
end
public
function create(ptr)
begin
inherited create(getstruct(),ptr);
bisize := _size_();
end
property bisize index "bisize" read _getvalue_ write _setvalue_;
property biwidth index "biwidth" read _getvalue_ write _setvalue_;
property biheight index "biheight" read _getvalue_ write _setvalue_;
property biplanes index "biplanes" read _getvalue_ write _setvalue_;
property bibitcount index "bibitcount" read _getvalue_ write _setvalue_;
property bicompression index "bicompression" read _getvalue_ write _setvalue_;
property bisizeimage index "bisizeimage" read _getvalue_ write _setvalue_;
property bixpelspermeter index "bixpelspermeter" read _getvalue_ write _setvalue_;
property biypelspermeter index "biypelspermeter" read _getvalue_ write _setvalue_;
property biclrused index "biclrused" read _getvalue_ write _setvalue_;
property biclrimportant index "biclrimportant" read _getvalue_ write _setvalue_;
end
type TTBBUTTONINFOA=class(tcstructwithcharptr)
{**
@explan(说明) 工具条项内存对象 %%
**}
private
static SSTRUCT;
function getstruct()
begin
if not SSTRUCT then SSTRUCT := array(
("cbsize","int",0),
("dwmask","int",0),
("idcommand","int",0),
("iimage","int",0),
("fsstate","byte",0),
("fsstyle","byte",0),
("cx","short",0),
("lparam","intptr",0),
("psztext","char*",0),
("cchtext","int",100));
return SSTRUCT;
end
public
function create();override;
begin
inherited create(getstruct(),array("psztext":"cchtext"),nil);
cbsize := _size_();
end
property cbsize index "cbsize" read _getvalue_ write _setvalue_;
property dwmask index "dwmask" read _getvalue_ write _setvalue_;
property idcommand index "idcommand" read _getvalue_ write _setvalue_;
property iimage index "iimage" read _getvalue_ write _setvalue_;
property fsstate index "fsstate" read _getvalue_ write _setvalue_;
property fsstyle index "fsstyle" read _getvalue_ write _setvalue_;
property cx index "cx" read _getvalue_ write _setvalue_;
property lparam index "lparam" read _getvalue_ write _setvalue_;
property psztext index "psztext" read _getvalue_ write _setvalue_;
property cchtext index "cchtext" read _getvalue_ write _setvalue_;
end
type TTBBUTTON=class(tslcstructureobj)
{**
@explan(说明) 工具栏按钮内存对象 %%
**}
private
static SSTRUCT;
function getstruct()
begin
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(array(
("ibitmap","int",0),
("idcommand","int",0),
("fsstate","byte",0),
("fsstyle","byte",0),
("dwdata","intptr",0),
("istring","char*",128)));
return SSTRUCT;
end
public
function create(ptr)
begin
inherited create(getstruct(),ptr);
end
function _setvalue_(id,v);
begin
if id="istring" then
begin
if ifstring(v)and length(v)<127 then
begin
return inherited;
end
return;
end
return inherited;
end
property ibitmap index "ibitmap" read _getvalue_ write _setvalue_;
property idcommand index "idcommand" read _getvalue_ write _setvalue_;
property fsstate index "fsstate" read _getvalue_ write _setvalue_;
property fsstyle index "fsstyle" read _getvalue_ write _setvalue_;
property dwdata index "dwdata" read _getvalue_ write _setvalue_;
property istring index "istring" read _getvalue_ write _setvalue_;
end
type TScrollBarKind=class(tenumeration)
static sbHorizontal;
static sbVertical;
end
type TToolTipsFlags=class
{**
@ignore(忽略) %%
@explan() tooltips flags 常量 %%
**}
static TTF_IDISHWND;
static TTF_CENTERTIP;
static TTF_RTLREADING;
static TTF_SUBCLASS;
static TTF_TRACK;
static TTF_ABSOLUTE;
static TTF_TRANSPARENT;
static TTF_PARSELINKS;
static TTF_DI_SETITEM;
end
type TIMAGEINFO = class(tslcstructureobj)
{**
@ignore 忽略 %%
@explan(说明) imgelist中image的信息 %%
**}
private
static SSTRUCT;
function getstruct()
begin
if not SSTRUCT then SSTRUCT := MemoryAlignmentCalculate(
array(
("hbmimage","intptr",0),
("hbmmask","intptr",0),
("unused1","int",0),
("unused2","int",0),
("rcimage","int[4]",
(0,0,0,0))));
return SSTRUCT;
end
function getbmp(v);
begin
{**
@explan(说明)构造tbitmap对象 %%
**}
hm := _getvalue_(v);
if hm then
begin
r := new tbitmap();
r.handle := hm;
r.AutoDestroy := false;
return r;
end
end
public
function create(ptr)
begin
inherited create(getstruct(),ptr);
end
property bmimage:tbitmap index "hbmimage" read getbmp write getbmp;
property bmmask:tbitmap index "hbmmask" read getbmp write getbmp;
property hbmimage index "hbmimage" read _getvalue_ write _setvalue_;
property hbmmask index "hbmmask" read _getvalue_ write _setvalue_;
property unused1 index "unused1" read _getvalue_ write _setvalue_;
property unused2 index "unused2" read _getvalue_ write _setvalue_;
property rcimage index "rcimage" read _getvalue_ write _setvalue_;
{**
@param(bmimage)(tbitmap) 位图 %%
@param(bmmask)(tbitmap) mask %%
@param(rcimage)(array) 左上右下 %%
**}
end
*)
//////////////twincontrol 中移除的函数
(*
function CreateDrawItemEvent();virtual;
begin
{**
@explan(说明) 主动构造drawitem消息,可以自行填写信息在DoDrawItem中使用,与DestroyDrawItemEvent成对出现 %%
@return(TMDRAWITEM|nil) item绘制对象 %%
**}
e := nil;
if HandleAllocated() then
begin
hd := self.Handle;
itptr := FTtageDrawItem._getptr_;
e := new TMDRAWITEM(WM_DRAWITEM,0,itptr,hd);
e.canvas := canvas;
canvas.handle := _wapi.GetDC(self.Handle);
end
return e;
end
function DestroyDrawItemEvent(e);virtual;
begin
{**
@explan(说明) 与CreateDrawItemEvent配合使用 %%
@param(e)(TMDRAWITEM) CreateDrawItemEvent 构造的消息对象 %%
**}
if HandleAllocated() and ( e is class(TMDRAWITEM)) and (e.lparam = FTtageDrawItem._getptr_()) then
begin
dc := canvas.Handle;
if dc then
begin
canvas.handle := 0;
return _wapi.ReleaseDC(self.Handle,dc);
end
end
end
*)
(*
//tcontrol 移除代码
function GetDeviceContext(var WindowHandle:HWND);virtual; //type_tcontrol
begin
{**
@explan(说明) 获取设备hdc %%
@param(WindowHandle)(pointer) 窗口句柄 %%
@return(pointer) dc 句柄 %%
**}
if Parent is class(TWinControl)then
begin
Result := Parent.GetDeviceContext(WindowHandle);
MoveWindowOrgEx(Result,Left,Top);
IntersectClipRect(Result,0,0,Width,Height);
end else
raise "错误";
return Result;
end;
function IntersectClipRect(hdc, x0, y0, x1, y1);virtual; //type_tcontrol
begin
_wapi.IntersectClipRect(hdc, x0, y0, x1, y1);
end
function MoveWindowOrgEx(hdc;x:integer;y:integer);virtual; //type_tcontrol
begin
{**
@explan(说明) 移动dc原点 %%
@param(hdc)(pointer) dc 句柄 %%
**}
return _wapi.SetViewportOrgEx(hdc,x,y,nil);
end
function WMXButtonDown(o,e): LM_XBUTTONDOWN;virtual;
begin
end
function WMMButtonDBLCLK(o,e): LM_MBUTTONDBLCLK;virtual;
begin
end
function WMXButtonDBLCLK(o,e): LM_XBUTTONDBLCLK;virtual;
begin
end
function WMLButtonTripleCLK(o,e): LM_LBUTTONTRIPLECLK;virtual;
begin
end
function WMRButtonTripleCLK(o,e): LM_RBUTTONTRIPLECLK;virtual;
begin
end
function WMMButtonTripleCLK(o,e): LM_MBUTTONTRIPLECLK;virtual;
begin
end
function WMXButtonTripleCLK(o,e): LM_XBUTTONTRIPLECLK;virtual;
begin
end
function WMXButtonUp(o,e): LM_XBUTTONUP;virtual;
begin
end
function WMLButtonQuadCLK(): LM_LBUTTONQUADCLK;virtual;
function WMRButtonQuadCLK(): LM_RBUTTONQUADCLK;virtual;
function WMMButtonQuadCLK(): LM_MBUTTONQUADCLK;virtual;
function WMXButtonQuadCLK(): LM_XBUTTONQUADCLK;virtual;
*)
(*
function SetMainMenubk(mu);
begin
if csDesigning in ComponentState then
begin
if FMainMenu and mu then //已经存在 %%
begin
return ;
end
if (not FMainMenu) and mu then
begin
mu := new TMainmenu(self); //构造一个假的菜单
tm := new TMenu(mu);
tm.caption := "menu";
tm.parent := mu;
end
end
if FMainMenu<>mu then
begin
OM := FMainMenu;
if OM is class(tmainmenu) then
begin
OM.DestroyHandle(); //删除句柄 %%
OM.Hwnd := 0;
//if HandleAllocated() then _wapi.SetMenu(self.Handle,0); //删除窗口上面的菜单句柄
end
if (mu is class(tmainmenu)) then
begin
if HandleAllocated() then
begin
mu.Hwnd := handle;
//_wapi.SetMenu(self.Handle,mu.handle);
end
end
FMainMenu := mu;
end
end
type TTempFile = class
function Create(dt);
begin
if not ifarray(FFiles) then FFiles := array();
bp :=gettemppath()+"tinysoft"+ioFileseparator()+"tslvcl"+ioFileseparator();
{if not fileexists("",bp) then
begin
for i:=2 to length(bp) do
begin
if bp[i]=ioFileseparator() then
begin
if fileexists("",bp[1:i-1]) then
begin
createdir("",bp[1:i-1])
end
end
end
end }
for i,v in mrows( FFiles,1) do
begin
if not(FFiles[v]) then
begin
FFiles[v] := true;
FPath := v;
break;
end
end
while not FPath do
begin
i := 0;
while true do
begin
subdir := tostn( rand(3)[1]);
p := bp+subdir[3]+ioFileseparator()+subdir[4]+".png";
echo p,"\r\n";
if not(FFiles[p]) then
begin
FFiles[p] := true;
FPath := p;
//writefile(rwraw(),"",FPath,0,1,"0") ;
break;
end
end
end
if ifstring(dt) then
begin
//if FileExists("",FPath) then filedelete("",FPath);
writefile(rwraw(),"",FPath,0,length(dt),dt) ;
end
end
function GetData(buf);//获得数据
begin
if FPath then
begin
sz := filesize("",FPath);
return readfile(rwraw(),"",FPath,0,sz,buf);
end
end
function Destroy();
begin
//FFiles[FPath] := false;
if FileExists("",FPath) then echo "\r\ndeletefile:",filedelete("",FPath);
FPath := "";
end
property path read FPath ;
private
FPath;
static FFiles;
end
*)
//暂时不用的函数
{function chartoint(c);
begin
v := ord(c);
case v of
48 to 57:vk := v-48;
65 to 70:vk := v-65+10;
97 to 102:vk := v-97+10;
else raise "非16进制字符串";
end
return vk;
end}
Reference in New Issue View Git Blame Copy Permalink