You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
RnQ/RnQ/SciterLib.pas

1324 lines
38 KiB
Plaintext

{
This file is part of R&Q.
Under same license
}
unit SciterLib;
{$I RnQConfig.inc}
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, System.StrUtils, System.Threading, System.Variants, System.TypInfo,
Generics.Collections, Vcl.Graphics, Vcl.Forms, Vcl.Imaging.PNGImage, Vcl.Imaging.GIFImg,
RDGlobal, ICQCommon, ICQContacts, Nodes, Sciter, SciterApi;
{$I PubRTTI.inc}
type
TParams = array of Variant;
TSprite = record
name: String;
x, y, width, height: Integer;
end;
TMessageStatus = record
when, msgid: String;
eventimg: Variant;
end;
TMessageHeader = record
when, caption, text, img: String;
end;
TContactStatus = record
code: Byte;
desc: String;
official, deleted: Boolean;
statusimg, eventimg: Variant;
end;
TCommonSettings = record
animateWindows, avatarShowInHint, supportAvatars: Boolean;
end;
TNodeData = record
kind, group, divisor, order: Integer;
uid, uid2show: TUID;
hash, displayed, nick, first, last, birth, birthLocal, lastActivity,
clientClosed, clientDesc, onlineSince, lastTimeSeenOnline: String;
status, clientimg, bdimg: Variant;
expanded, local, needAuth, hasAvatar, noClient: Boolean;
end;
TNativeProc = procedure(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
PNativeProc = ^TNativeProc;
TNativeData = record
Method: TNativeProc;
UseTag: Boolean
end;
TNativeMethods = class
Box: Pointer;
Methods: TDictionary;
public
constructor Create(Owner: Pointer);
destructor Destroy;
procedure AddMethod(Name: String; Proc: TNativeProc; UseTag: Boolean = False);
procedure RegisterMethods(var ReturnValue: TSciterValue);
end;
TSciterEx = class(TSciter)
private
ContactStatus: TContactStatus;
StatusSprite, EventSprite, ClientSprite, BDSprite: TSprite;
public
procedure MessageDialog(Msg: String; Kind: TMsgDlgType; const UID: String = '');
function MakeSprite(const Pic: TPicName): TSprite;
function GetNodeData(var Node: TNode; Lite: Boolean = False): TNodeData;
constructor Create(AOwner: TComponent);
end;
TSciterHelper = class helper for TSciter
function LoadTemplate(const Doc, Filename: String; Debug: Boolean = True): Boolean;
procedure InitRequest(ASender: TObject; const url: WideString; resType: SciterResourceType; requestId: Pointer; out discard: Boolean; out delay: Boolean);
end;
TRequestHandler = class
private
FBox: TSciter;
FDataStream: TMemoryStream;
protected
procedure ProcessRequest(ASender: TObject; const URL: WideString; ResType: SciterResourceType; RequestId: Pointer; out Discard: Boolean; out Delay: Boolean);
procedure CheckAnimatedGifSize(var ms: TMemoryStream);
public
constructor Create(Sender: TSciter);
destructor Destroy; override;
end;
TCommonMethods = class(TSciterEx)
private
NativeMethods: TNativeMethods;
public
function GetImageColors(var str: TMemoryStream): TParams;
function EnterPassword(Title: String; MaxLength: Integer = 0): String;
procedure EnterLockPassword(Title: String; Hint: String; MaxLength: Integer = 0);
function CreateDialog(const Msg: String; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; Seconds: Integer): Integer;
function SwitchUser: TUID;
procedure InitSettings;
procedure ReloadUsers;
procedure LoadData(ASender: TObject; const url: WideString; resType: SciterResourceType; requestId: Pointer; out discard: Boolean; out delay: Boolean);
procedure ScriptingCall(ASender: TObject; const Args: TElementOnScriptingCallArgs);
constructor Create(AOwner: TComponent);
destructor Destroy; override;
end;
procedure GetTrans(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
procedure GetTranslations(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
procedure GetSpriteData(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
procedure GetGroups(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
procedure CheckOnline(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
procedure SetFormIcon(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
procedure CheckUIN(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
procedure GetMaxPasswordLength(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
procedure GetPwd(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
procedure GetCurrentUserName(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
procedure GetCurrentUserAcc(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
procedure GetAccountPassword(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
procedure SaveAccountPassword(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
procedure IsAIM(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
procedure ActivateWindow(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
implementation
uses
GlobalLib, UtilLib, GroupsLib, RoasterLib, INILib, RQUtil, RDUtils, Murmur2,
RnQNet, RnQLangs, RnQGlobal, RnQGraphics32, RQThemes, RnQPics, RnQDialogs, RnQ_Avatars, Stickers, ChatBox,
ICQConsts, events, mainDlg, chatDlg, usersDlg;
constructor TNativeMethods.Create(Owner: Pointer);
begin
Box := Owner;
Methods := TDictionary.Create;
end;
destructor TNativeMethods.Destroy;
begin
Methods.Free
end;
procedure TNativeMethods.AddMethod(Name: String; Proc: TNativeProc; UseTag: Boolean = False);
var
MethodData: TNativeData;
begin
MethodData.Method := Proc;
MethodData.UseTag := UseTag;
Methods.Add(Name, MethodData);
end;
procedure TNativeMethods.RegisterMethods(var ReturnValue: TSciterValue);
var
Method: TPair;
begin
for Method in Methods do
TSciter.RegisterNativeFunctor(ReturnValue, PWideChar(Method.Key), @Method.Value.Method, THelpers.IfThen(Method.Value.UseTag, Box, nil));
end;
function LooksLikeALink(const link: String): Boolean;
begin
Result := StartsText('http://', link) or StartsText('https://', link) or StartsText('www.', link);
end;
{ TRequestHandler }
constructor TRequestHandler.Create(Sender: TSciter);
begin
FBox := Sender;
FDataStream := nil;
end;
destructor TRequestHandler.Destroy;
begin
FreeAndNil(FDataStream);
inherited;
end;
procedure TRequestHandler.CheckAnimatedGifSize(var ms: TMemoryStream);
var
aGif: TGIFImage;
sz: Single;
FStreamFormat: TPAFormat;
begin
FStreamFormat := DetectFileFormatStream(ms);
if (FStreamFormat = PA_FORMAT_GIF) then
begin
ms.Seek(0, soFromBeginning);
aGif := TGIFImage.Create;
try
aGif.LoadFromStream(ms);
with aGif do
if Images.Count > 1 then
begin
sz := 4.85 * Images.Count * Width * Height / 1048576;
if sz > 50 then
try
ms.Clear;
aGif.Images[0].Bitmap.SaveToStream(ms);
ms.Seek(0, soFromBeginning);
except end;
end;
finally
aGif.Free;
end;
end;
end;
procedure TRequestHandler.ProcessRequest(ASender: TObject; const url: WideString; resType: SciterResourceType; requestId: Pointer; out discard: Boolean; out delay: Boolean);
var
Hash: LongWord;
Img: TBytes;
PNG: TPNGImage;
Ico: TIcon;
RealURL, FileURL, FileName, MurmurStr: String;
Mini: Boolean;
Pic: TPicName;
ResStream: TResourceStream;
StrStream: TStringStream;
Cached, IsImg, Check, Ignore, Async, HasAoP: Boolean;
TmpBox: TSciter;
Contact: TICQContact;
FileInfo: TICQFileInfo;
begin
Ignore := False;
Async := False;
if StartsText('file://', url) or StartsText('sciter:', url) then
Exit;
FDataStream := nil;
if StartsText('template:', url) then
begin
FDataStream := TMemoryStream.Create;
RealURL := Copy(url, 10, Length(url));
FBox.GetPackedItem('template', PWideChar(RealURL), FDataStream);
end else if StartsText('themeicon:', url) then
begin
RealURL := Copy(url, 11, Length(url));
Ico := TIcon.Create;
if theme.pic2ico(RQteDefault, RealURL, Ico) then
begin
FDataStream := TMemoryStream.Create;
Ico.SaveToStream(FDataStream)
end else
Ignore := True;
Ico.Free;
end else if StartsText('themepic:', url) then
begin
Pic := Copy(url, 10, Length(url));
if not theme.GetOrigPic(Pic, FDataStream) then
Ignore := True;
end else if StartsText('themepicsingle:', url) then
begin
RealURL := Copy(url, 16, Length(url));
if theme.Pic2PNG(RealURL, PNG) then
begin
FDataStream := TMemoryStream.Create;
PNG.SaveToStream(FDataStream)
end else
Ignore := True;
FreeAndNil(PNG);
end else if StartsText('pluginpic:', url) then
begin
Pic := Copy(url, 11, Length(url));
if theme.Pic2PNG(Pic, PNG) then
begin
FDataStream := TMemoryStream.Create;
PNG.SaveToStream(FDataStream)
end else
Ignore := True;
FreeAndNil(PNG);
end else if StartsText('contactpic:', url) and UseContactThemes and Assigned(ContactsTheme) then
begin
Pic := Copy(url, 12, Length(url));
if not ContactsTheme.GetOrigPic(Pic, FDataStream) then
Ignore := True;
end else if StartsText('smile:', url) then
begin
Pic := Copy(url, 7 + 1, Length(url));
if not theme.GetOrigSmile(Pic, FDataStream) then
Ignore := True;
end else if StartsText('sticker:', url) then
begin
RealURL := Copy(url, 9 + 1, Length(url));
TmpBox := FBox;
TTask.Create(procedure
var
fs: TMemoryStream;
begin
fs := TMemoryStream.Create;
GetSticker(Copy(RealURL, 1, pos('_', RealURL) - 1), Copy(RealURL, pos('_', RealURL) + 1, Length(RealURL)), fs, 'small');
if Assigned(TmpBox) and Running then
TmpBox.DataReadyAsync(url, fs.Memory, fs.Size, requestId);
FreeAndNil(fs);
end, TThreadPool.Default).Start;
delay := true;
Exit;
end else if StartsText('picker:', url) then
begin
RealURL := Copy(url, 8 + 1, Length(url));
TmpBox := FBox;
TTask.Create(procedure
var
fs: TMemoryStream;
begin
fs := TMemoryStream.Create;
GetSticker(RealURL, '', fs);
if Assigned(TmpBox) and Running then
TmpBox.DataReadyAsync(url, fs.Memory, fs.Size, requestId);
FreeAndNil(fs);
end, TThreadPool.Default).Start;
delay := true;
Exit;
end else if StartsText('avatar:', url) or StartsText('miniavatar:', url) then
begin
Mini := StartsText('miniavatar:', url);
RealURL := Copy(url, IfThen(Mini, 12, 8), Length(url));
Contact := Account.AccProto.GetContact(RealURL);
if Contact.icon.ToShow = IS_AVATAR then
begin
FDataStream := TMemoryStream.Create;
LoadAoPStreamByUIN(Contact.UID2cmp, FDataStream, HasAoP, FileName, 0);
if Assigned(FDataStream) and (FDataStream.Size = 0) then
begin
FreeAndNil(FDataStream);
Ignore := True;
end;
if Mini and not Ignore then
ResampleProportional(FDataStream, 32, 32);
end else if Contact.icon.ToShow = IS_PHOTO then
begin
FDataStream := TMemoryStream.Create;
LoadAoPStreamByUIN(Contact.UID2cmp, FDataStream, HasAoP, FileName, 1);
if Assigned(FDataStream) and (FDataStream.Size = 0) then
begin
FreeAndNil(FDataStream);
Ignore := True;
end;
end else Ignore := True;
end else if StartsText('resource:', url) then
begin
RealURL := Copy(url, 10, Length(url));
ResStream := TResourceStream.Create(HInstance, UpperCase(RealURL), RT_RCDATA);
try
FDataStream := TMemoryStream.Create;
ResStream.SaveToStream(FDataStream);
finally
ResStream.Free;
end;
end else if StartsText('link:', url) then
begin
RealURL := Copy(url, 6, Length(url));
if not StartsText('http://', RealURL) and not StartsText('https://', RealURL) then
RealURL := 'http://' + RealURL;
if ContainsText(RealURL, 'files.icq.net/') then
begin
FileInfo := GetICQFileLinkInfo(RealURL);
//if FileInfo.mime.startsWith('image/') or FileInfo.mime.startsWith('video/') then
if FileInfo.is_previewable then
FileURL := FileInfo.dlink
else
FileURL := FileInfo.jsonlink;
if not (FileURL = '') then
RealURL := FileURL;
end;
OpenURL(RealURL);
Ignore := True;
end else if StartsText('mailto:', url) then
begin
openURL(url);
Ignore := True;
end else if StartsText('embedded:', url) then
begin
if TryStrToLongWord(Copy(url, 10, Length(url)), Hash) and Assigned(embeddedImgs) and embeddedImgs.TryGetValue(Hash, Img) then
begin
FDataStream := TMemoryStream.Create;
FDataStream.Write(Img, Length(Img));
CheckAnimatedGifSize(FDataStream);
end;
end else if StartsText('tabicon:', url) then
begin
PNG := nil;
if TryStrToLongWord(Copy(url, 9, Length(url)), Hash) and Assigned(tabsIconCache) and tabsIconCache.TryGetValue(Hash, PNG) then
if Assigned(PNG) then
begin
FDataStream := TMemoryStream.Create;
PNG.SaveToStream(FDataStream)
end else
Ignore := True;
end else if StartsText('check:', url) or StartsText('download:', url) then
begin
if StartsText('check:', url) then
begin
Check := True;
RealURL := Copy(url, 7, Length(url));
end
else
begin
Check := False;
RealURL := Copy(url, 10, Length(url))
end;
if LooksLikeALink(RealURL) then
begin
MurmurStr := ImgCacheInfo.ReadString(RealURL, 'hash', '0');
FileName := myPath + 'Cache\Images\' + MurmurStr + '.' + ImgCacheInfo.ReadString(RealURL, 'ext', 'jpg');
if MurmurStr = '0' then
Cached := False
else
Cached := FileExists(FileName);
if not Check then
Async := True
else if Cached then
begin
IsImg := True;
Async := False;
end else if ImgCacheInfo.ValueExists(RealURL, 'mime') and not MatchText(ImgCacheInfo.ReadString(RealURL, 'mime', ''), ImageContentTypes) then
begin
IsImg := False;
Async := False;
end else
Async := True;
if not Async then
begin
StrStream := TStringStream.Create('{ isImg: ' + IfThen(IsImg, '1', '0') + ', link: "' + RealURL + '" }', TEncoding.UTF8);
FDataStream := TMemoryStream.Create;
FDataStream.CopyFrom(StrStream, 0);
StrStream.Free;
end;
end else
Ignore := True;
end else
begin
discard := False;
delay := False;
Exit;
end;
if not Ignore then
begin
if not Async then
begin
delay := False;
FDataStream.Seek(0, soFromBeginning);
FBox.DataReady(url, FDataStream.Memory, FDataStream.Size);
end
else
begin
delay := True;
TmpBox := FBox;
TTask.Run(procedure()
var
ms: TMemoryStream;
fs: TFileStream;
ss: TStringStream;
begin
if Check then
begin
ss := TStringStream.Create('{ isImg: ' + IfThen(CheckType(RealURL), '1', '0') + ', link: "' + RealURL + '" }', TEncoding.UTF8);
TThread.Synchronize(nil, procedure begin
if Assigned(TmpBox) and Running then
TmpBox.DataReadyAsync(url, ss.Memory, ss.Size, requestId);
end);
FreeAndNil(ss);
Exit;
end;
fs := nil;
ms := nil;
if not Cached then
Cached := DownloadAndCache(RealURL);
if Cached then
try
FileName := myPath + 'Cache\Images\' + ImgCacheInfo.ReadString(RealURL, 'hash', '0') + '.' + ImgCacheInfo.ReadString(RealURL, 'ext', 'jpg');
fs := TFileStream.Create(FileName, fmOpenRead);
ms := TMemoryStream.Create;
ms.LoadFromStream(fs);
CheckAnimatedGifSize(ms);
TThread.Synchronize(nil, procedure begin
if Assigned(TmpBox) and Running then
begin
TmpBox.DataReadyAsync(url, ms.Memory, ms.Size, requestId);
TChatBox(TmpBox).FinishImage(url);
end;
end);
except end;
FreeAndNil(fs);
FreeAndNil(ms);
end);
end;
discard := False;
end else
discard := True;
FreeAndNil(FDataStream);
end;
{ TSciterEx }
procedure TSciterEx.MessageDialog(Msg: String; Kind: TMsgDlgType; const UID: String = '');
begin
Call('showAlert', [Kind, Msg, False]);
end;
function TSciterEx.MakeSprite(const Pic: TPicName): TSprite;
var
Rect: TGPRect;
begin
Rect := theme.GetPicRect(RQteDefault, Pic);
Result.name := theme.GetPicSprite(RQteDefault, Pic);
Result.x := -rect.X;
Result.y := -rect.Y;
Result.width := rect.Width;
Result.height := rect.Height;
end;
function TSciterEx.GetNodeData(var Node: TNode; Lite: Boolean = False): TNodeData;
var
LastActivity: TDateTime;
Group: TGroup;
Pic: String;
Event: Thevent;
begin
Result := Default(TNodeData);
if not Assigned(Node) then
Exit;
Result.divisor := Integer(Node.divisor);
Result.group := Node.groupId;
Result.kind := Node.kind;
Result.order := Node.order;
if Node.kind = NODE_DIV then
begin
case Node.divisor of
d_online: Result.order := 1;
d_nil: Result.order := 2;
d_recent: Result.order := 3;
d_offline: Result.order := 4;
d_contacts: Result.order := 5;
end;
end else if Node.kind = NODE_GROUP then
begin
Group := groups.Get(Node.groupId);
Result.displayed := Group.Name;
Result.expanded := Group.Expanded[Node.divisor];
Result.local := Group.IsLocal;
end else if Node.kind = NODE_CONTACT then
if Assigned(Node.contact) then
begin
Result.displayed := Node.contact.Displayed;
Result.uid := Node.contact.UID;
Result.uid2show := Node.contact.UIN2Show;
Result.nick := Node.contact.Nick;
Result.first := Node.contact.First;
Result.last := Node.contact.Last;
Result.birth := THelpers.IfThen(Node.contact.Birth = 0, '', DateToStr(Node.contact.Birth));
Result.birthLocal := THelpers.IfThen(Node.contact.BirthL = 0, '', DateToStr(Node.contact.BirthL));
Result.needAuth := not Node.contact.Authorized and not Node.contact.CntIsLocal;
Result.local := Node.contact.CntIsLocal;
Result.noClient := Node.contact.NoClient;
Result.clientClosed := TimeToString(Node.contact.ClientClosed);
Result.clientDesc := Node.contact.ClientDesc;
Result.onlineSince := TimeToString(Node.contact.OnlineSince);
Result.lastTimeSeenOnline := TimeToString(Node.contact.LastTimeSeenOnline);
if Lite then
Exit;
LastActivity := TCE(Node.contact.data^).lastMsgTime;
if LastActivity < startTime then
// if not Node.contact.IsOnline then
begin
LastActivity := TCE(Node.contact.data^).lastEventTime;
if LastActivity < startTime then
LastActivity := 0;
end;
Result.lastActivity := FloatToStr(LastActivity);
Result.hasAvatar := CheckAvatar(Node.contact);
// Status
Pic := RosterImgNameFor(Node.contact);
if Pic = '' then
Exit;
ContactStatus.official := Node.contact.Official;
ContactStatus.deleted := Node.contact.Deleted;
ContactStatus.code := Node.contact.GetStatus;
ContactStatus.desc := Node.contact.XStatusStr;
StatusSprite := MakeSprite(Pic);
ContactStatus.statusimg := RecordToVar(StatusSprite);
Event := eventQ.firstEventFor(Node.contact);
if Assigned(Event) and not (Event.pic = '') then
begin
EventSprite := MakeSprite(Event.pic);
ContactStatus.eventimg := RecordToVar(EventSprite);
end else
ContactStatus.eventimg := False;
Result.status := RecordToVar(ContactStatus);
// Client
if not (Node.contact.ClientPic = '') then
begin
ClientSprite := MakeSprite(Node.contact.ClientPic);
Result.clientimg := RecordToVar(ClientSprite);
end else
Result.clientimg := False;
// Birthday
case Node.contact.Days2Bd of
0: Pic := PIC_BIRTH;
1: Pic := PIC_BIRTH1;
2: Pic := PIC_BIRTH2;
else
Pic := '';
end;
if not (Pic = '') then
begin
BDSprite := MakeSprite(Pic);
Result.bdimg := RecordToVar(BDSprite);
end else
Result.bdimg := False;
end;
Result.hash := IntToStr(CalcMurmur2(TEncoding.UTF8.GetBytes(IntToStr(Result.kind) + '_' + IntToStr(Result.divisor) + '_' + IntToStr(Result.group) + '_' + String(Result.uid))));
end;
constructor TSciterEx.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
OnLoadData := InitRequest;
end;
{ TSciterHelper }
function TSciterHelper.LoadTemplate(const Doc, Filename: String; Debug: Boolean = True): Boolean;
begin
SetOption(SCITER_SET_SCRIPT_RUNTIME_FEATURES, UINT_PTR(ALLOW_FILE_IO) or UINT_PTR(ALLOW_SOCKET_IO) or UINT_PTR(ALLOW_EVAL) or UINT_PTR(ALLOW_SYSINFO));
SetOption(SCITER_SET_DEBUG_MODE, UINT_PTR(DevMode and Debug));
if DevMode then
Result := LoadURL(FilePathToURL(myPath + Doc + '\' + Filename))
else if FileExists(myPath + Doc + '.zip') then
Result := LoadURL(FilePathToURL(myPath + Doc + '.zip#' + Filename))
else
begin
LoadPackedResource(Doc, RT_RCDATA);
Result := LoadURL(Doc + ':' + Filename);
end;
end;
procedure TSciterHelper.InitRequest(ASender: TObject; const url: WideString; resType: SciterResourceType; requestId: Pointer; out discard: Boolean; out delay: Boolean);
var
handler: TRequestHandler;
begin
handler := TRequestHandler.Create(Self);
handler.ProcessRequest(ASender, url, resType, requestId, discard, delay);
handler.Free;
end;
// Native methods
procedure GetSpriteData(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
str: PWideChar;
strLen: Cardinal;
Sprite: TSprite;
begin
if (tag = nil) or (argc = 0) then
Exit;
str := '';
API.ValueStringData(argv, str, strLen);
if str = '' then
Exit;
with TSciterEx(tag) do
begin
Sprite := MakeSprite(str);
V2S(RecordToVar(Sprite), retval);
end;
end;
procedure GetTrans(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
strData: PWideChar;
strLen: UINT;
begin
if argc = 0 then
Exit;
strData := '';
API.ValueStringData(argv, strData, strLen);
strData := PWideChar(GetTranslation(strData));
API.ValueStringDataSet(retval, strData, Length(strData), 0);
end;
function EnumParams(param: Pointer; const pkey: PSciterValue; const pval: PSciterValue): BOOL; cdecl;
var
key, val: PWideChar;
newval: TSciterValue;
strLen: UINT;
begin
Result := True;
key := '';
API.ValueStringData(pkey, key, strLen);
if key = '' then
Exit;
val := '';
API.ValueStringData(pval, val, strLen);
val := PWideChar(GetTranslation(val));
API.ValueInit(@newval);
API.ValueStringDataSet(@newval, val, Length(val), 0);
API.ValueSetValueToKey(param, pkey, @newval);
API.ValueClear(@newval);
end;
procedure GetTranslations(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
arrSize, i: UINT;
strData, tmp: PWideChar;
strLen: UINT;
key: TSciterValue;
val: TSciterValue;
begin
if argc = 0 then
Exit;
if argv.t = UINT(T_OBJECT) then
if argv.u = UINT(UT_OBJECT_OBJECT) then
API.ValueEnumElements(argv, @EnumParams, retval)
else if argv.u = UINT(UT_OBJECT_ARRAY) then
begin
arrSize := 0;
API.ValueIsolate(argv);
API.ValueElementsCount(argv, arrSize);
for i := 0 to arrSize - 1 do
begin
API.ValueInit(@val);
if API.ValueNthElementValue(argv, i, val) = HV_OK then
begin
API.ValueStringData(@val, strData, strLen);
strData := PWideChar(GetTranslation(strData));
API.ValueStringDataSet(@val, strData, Length(strData), 0);
API.ValueNthElementValueSet(retval, i, @val)
end;
API.ValueClear(@val);
end;
end;
end;
procedure GetGroups(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
I, Tmp: Integer;
AddOut: Boolean;
GroupItems: TArray;
MenuItems: TParams;
begin
if tag = nil then
Exit;
Tmp := 0;
API.ValueIntData(argv, Tmp);
AddOut := Tmp = 1;
GroupItems := groups.GetGroups(AddOut);
SetLength(MenuItems, Length(GroupItems));
for I := 0 to Length(MenuItems) - 1 do
MenuItems[I] := TSciter(tag).RecordToVar(GroupItems[I]);
V2S(MenuItems, retval);
end;
procedure CheckOnline(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
res: Boolean;
begin
res := OnlFeature(Account.AccProto);
API.ValueIntDataSet(retval, RDUtils.IfThen(res, 1), T_BOOL, 0);
end;
procedure SetFormIcon(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
HIco: HIcon;
Icon: TIcon;
Pic: PWideChar;
b: PByte;
pb: Cardinal;
hndl: HWND;
begin
b := nil;
hndl := 0;
if (argc > 0) and (argv.t = UINT(T_OBJECT)) and (argv.u = UINT(UT_OBJECT_NATIVE)) then
API.ValueBinaryData(argv, b, pb);
if Assigned(b) then
API.SciterGetElementHwnd(b, hndl, true);
if hndl = 0 then
Exit;
if argc > 1 then
begin
Inc(argv);
API.ValueStringData(argv, Pic, pb);
end;
Icon := TIcon.Create;
try
if not (Pic = '') then
begin
theme.pic2ico(RQteFormIcon, Pic, Icon);
HIco := Icon.Handle;
end else
HIco := Application.Icon.Handle;
SendMessage(hndl, WM_SETICON, 0, HIco);
SendMessage(hndl, WM_SETICON, 1, HIco);
except
Icon.Free;
end;
end;
procedure CheckUIN(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
UIN: PWideChar;
UID: TUID;
StrLen: Cardinal;
Contact: TICQContact;
Res: Boolean;
Box: TSciterEx;
begin
Res := False;
if argc < 1 then
Exit;
API.ValueStringData(argv, UIN, StrLen);
Box := TSciterEx(tag);
UID := Trim(UIN);
if not Account.AccProto.ValidICQ(UID) then
begin
if Assigned(Box) then
MsgDlg('Invalid UIN', True, mtError)
end
else
begin
Contact := Account.AccProto.GetContact(UID);
if not Assigned(Contact) then
begin
if Assigned(Box) then
MsgDlg('Couldn''t create contact!', True, mtError);
end else if Contact.IsInRoster then
begin
roasterLib.focus(Contact);
if Assigned(Box) then
MsgDlg(GetTranslation('%s already exists', [uid]), False, mtWarning)
end else
Res := True;
end;
V2S(Res, retval);
end;
procedure GetMaxPasswordLength(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
begin
V2S(Account.AccProto._MaxPwdLen, retval);
end;
procedure GetPwd(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
begin
V2S(Account.AccProto.Pwd, retval);
end;
procedure GetContactIdle(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
UIN: PWideChar;
StrLen: Cardinal;
IdleTime: Integer;
Contact: TICQContact;
begin
IdleTime := 0;
UIN := '';
API.ValueStringData(argv, UIN, StrLen);
if not (UIN = '') then
Contact := Account.AccProto.GetContact(UIN);
if Assigned(Contact) then
IdleTime := Contact.IdleTime;
V2S(IdleTime, retval);
end;
procedure GetContactImportant(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
UIN: PWideChar;
StrLen: Cardinal;
Important: String;
Tmp: Integer;
GetLocal: Boolean;
Contact: TICQContact;
begin
Important := '';
UIN := '';
API.ValueStringData(argv, UIN, StrLen);
if not (UIN = '') then
Contact := Account.AccProto.GetContact(UIN);
Inc(argv);
Tmp := 0;
API.ValueIntData(argv, Tmp);
GetLocal := Tmp = 1;
if Assigned(Contact) then
Important := THelpers.IfThen(GetLocal, Contact.lclImportant, Contact.ssImportant);
V2S(Important, retval);
end;
procedure GetContactIgnored(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
UIN: PWideChar;
StrLen: Cardinal;
Contact: TICQContact;
Ignored: Boolean;
begin
Ignored := False;
UIN := '';
API.ValueStringData(argv, UIN, StrLen);
if not (UIN = '') then
Contact := Account.AccProto.GetContact(UIN);
if Assigned(Contact) then
Ignored := Contact.IsInList(LT_SPAM) or IgnoreList.exists(Contact);
V2S(Ignored, retval);
end;
procedure GetCurrentUserName(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
begin
V2S(RnQUser, retval);
end;
procedure GetStatusName(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
Code: Integer;
begin
Code := 0;
API.ValueIntData(argv, Code);
V2S(GetTranslation(Status2ShowStr[TICQStatus(Code)]), retval);
end;
procedure GetGroupName(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
Group: Integer;
begin
Group := 0;
API.ValueIntData(argv, Group);
if Group = 0 then
V2S('', retval)
else
V2S(groups.ID2Name(Group), retval);
end;
procedure GetContactData(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
UIN: PWideChar;
StrLen: Cardinal;
Contact: TICQContact;
Node: TNode;
NodeData: TNodeData;
begin
UIN := '';
API.ValueStringData(argv, UIN, StrLen);
if not (UIN = '') then
Contact := Account.AccProto.GetContact(UIN);
if not Assigned(Contact) then
begin
V2S(varNull, retval);
Exit;
end;
with TSciterEx(tag) do
begin
Node := GetContactNode(UIN);
if Node = nil then
V2S(varNull, retval)
else
begin
NodeData := GetNodeData(Node);
V2S(RecordToVar(NodeData), retval);
end;
end;
end;
procedure GetCurrentUserAcc(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
begin
V2S(Account.AccProto.MyAccNum, retval);
end;
procedure GetAccountPassword(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
begin
V2S(AccPass, retval);
end;
procedure SaveAccountPassword(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
Pwd: PWideChar;
StrLen: Cardinal;
begin
if argc = 0 then
Exit;
Pwd := '';
API.ValueStringData(argv, Pwd, StrLen);
AccPass := Pwd;
SaveCfgDelayed := True;
end;
procedure SaveNewAccountPassword(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
Pwd: PWideChar;
StrLen: Cardinal;
begin
if argc = 0 then
Exit;
Pwd := '';
API.ValueStringData(argv, Pwd, StrLen);
NewAccPass := Pwd;
end;
procedure CheckLockPassword(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
Pwd: PWideChar;
StrLen: Cardinal;
begin
if argc = 0 then
Exit;
Pwd := '';
API.ValueStringData(argv, Pwd, StrLen);
if not (AccPass = '') then
V2S(CompareText(AccPass, Pwd) = 0, retval)
else
V2S(Account.AccProto.PwdEqual(Pwd), retval);
end;
procedure OpenLink(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
URL: PWideChar;
StrLen: Cardinal;
begin
URL := '';
API.ValueStringData(argv, URL, StrLen);
if not (URL = '') then
OpenURL(URL);
end;
procedure OpenPortal(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
begin
OpenURL(rnqSite)
end;
procedure IsOnline(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
begin
V2S(Assigned(Account.AccProto) and Account.AccProto.IsOnline, retval)
end;
procedure IsAIM(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
MyInf: TICQContact;
IsAIM: Boolean;
begin
IsAIM := False;
if not Assigned(Account.AccProto) then
Exit;
MyInf := Account.AccProto.GetMyInfo;
if Assigned(MyInf) then
IsAIM := MyInf.isAIM;
V2S(IsAIM, retval);
end;
procedure ActivateWindow(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
b: PByte;
pb: Cardinal;
hndl: HWND;
begin
b := nil;
hndl := 0;
if (argc > 0) and (argv.t = UINT(T_OBJECT)) and (argv.u = UINT(UT_OBJECT_NATIVE)) then
API.ValueBinaryData(argv, b, pb);
if Assigned(b) then
API.SciterGetElementHwnd(b, hndl, True);
if hndl > 0 then
SetForegroundWindow(hndl);
end;
procedure IsWindowActive(tag: Pointer; argc: UINT; argv: PSciterValue; retval: PSciterValue); cdecl;
var
b: PByte;
pb: Cardinal;
forg, hndl: HWND;
begin
b := nil;
hndl := 0;
if (argc > 0) and (argv.t = UINT(T_OBJECT)) and (argv.u = UINT(UT_OBJECT_NATIVE)) then
API.ValueBinaryData(argv, b, pb);
if Assigned(b) then
API.SciterGetElementHwnd(b, hndl, True);
forg := GetForegroundWindow;
if hndl > 0 then
V2S((forg = hndl) or (forg = GetParent(hndl)), retval)
else
V2S(False, retval)
end;
// TCommonMethods
constructor TCommonMethods.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
SetParentComponent(AOwner);
NativeMethods := TNativeMethods.Create(Self);
OnLoadData := LoadData;
OnScriptingCall := ScriptingCall;
end;
destructor TCommonMethods.Destroy;
begin
NativeMethods.Free;
inherited;
end;
function TCommonMethods.GetImageColors(var str: TMemoryStream): TParams;
var
img: Variant;
buf: Pointer;
Freq, StartCount, StopCount: Int64;
TimingSeconds: real;
begin
img := VarArrayCreate([0, str.Size - 1], varByte);
buf := VarArrayLock(img);
str.Seek(0, soFromBeginning);
str.ReadBuffer(buf^, str.Size);
VarArrayUnlock(img);
QueryPerformanceFrequency(Freq);
QueryPerformanceCounter(StartCount);
Result := Call('getImageColors', [img]);
QueryPerformanceCounter(StopCount);
TimingSeconds := (StopCount - StartCount) / Freq;
ODS('Vibrant run: ' + floattostr(TimingSeconds));
end;
function TCommonMethods.EnterPassword(Title: String; MaxLength: Integer = 0): String;
begin
Result := Call('enterPassword', [Title, Hint, MaxLength]);
end;
procedure TCommonMethods.EnterLockPassword(Title: String; Hint: String; MaxLength: Integer = 0);
begin
Call('enterLockPassword', [Title, Hint, MaxLength]);
end;
function TCommonMethods.SwitchUser: TUID;
begin
Result := Call('switchUser', []);
end;
procedure TCommonMethods.ReloadUsers;
begin
Call('reloadUsers', []);
end;
function TCommonMethods.CreateDialog(const Msg: String; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; Seconds: Integer): Integer;
var
Button, DefaultButton, CancelButton: TMsgDlgBtn;
DefaultButtonVar, CancelButtonVar: Variant;
ButtonsVar: TParams;
I: Integer;
Title, Icon: String;
begin
case DlgType of
mtWarning:
Icon := PIC_EXCLAMATION;
mtError:
Icon := PIC_HAND;
mtInformation:
Icon := PIC_ASTERISK;
mtConfirmation:
Icon := PIC_QUEST;
mtBuzz:
Icon := PIC_BUZZ;
mtCustom:
Icon := '';
end;
if DlgType <> mtCustom then
Title := GetTranslation(LoadResString(Captions[DlgType]))
else
Title := Application.Title;
if RnQUser > '' then
Title := Title + ' (' + RnQUser + ')';
I := 0;
for Button in Buttons do
begin
SetLength(ButtonsVar, I + 1);
ButtonsVar[I] := SymbolToVar(GetEnumName(TypeInfo(TMsgDlgBtn), Ord(Button)));
Inc(I);
end;
if mbOk in Buttons then
DefaultButton := mbOk
else if mbYes in Buttons then
DefaultButton := mbYes
else
DefaultButton := mbRetry;
if mbCancel in Buttons then
CancelButton := mbCancel
else if mbNo in Buttons then
CancelButton := mbNo
else
CancelButton := mbOk;
DefaultButtonVar := SymbolToVar(GetEnumName(TypeInfo(TMsgDlgBtn), Ord(DefaultButton)));
CancelButtonVar := SymbolToVar(GetEnumName(TypeInfo(TMsgDlgBtn), Ord(CancelButton)));
Result := Call('createDialog', [Icon, Title, Msg, ButtonsVar, DefaultButtonVar, CancelButtonVar, Seconds]);
end;
procedure TCommonMethods.InitSettings;
var
Settings: TCommonSettings;
begin
Settings.animateWindows := AnimateWindows;
Settings.avatarShowInHint := AvatarShowInHint;
Settings.supportAvatars := Account.AccProto.AvatarsSupport;
Call('initCommonSettings', [RecordToVar(Settings)]);
end;
procedure TCommonMethods.LoadData(ASender: TObject; const url: WideString; resType: SciterResourceType; requestId: Pointer; out discard: Boolean; out delay: Boolean);
begin
if (theme.token = 101) and (StartsText('themepic', url) or StartsText('pluginpic:', url) or StartsText('smile:', url)) then
discard := True // Theme is not loaded yet
else
InitRequest(ASender, url, resType, requestId, discard, delay);
end;
procedure TCommonMethods.ScriptingCall(ASender: TObject; const Args: TElementOnScriptingCallArgs);
begin
if Args.Method = 'getNativeApi' then
with NativeMethods do
begin
// Common
AddMethod('GetTranslation', GetTrans);
AddMethod('GetTranslations', GetTranslations);
AddMethod('GetSpriteData', GetSpriteData, True);
AddMethod('ActivateWindow', ActivateWindow);
AddMethod('IsWindowActive', IsWindowActive);
AddMethod('GetContactIdle', GetContactIdle);
AddMethod('GetContactImportant', GetContactImportant);
AddMethod('GetContactIgnored', GetContactIgnored);
AddMethod('GetCurrentUserName', GetCurrentUserName);
AddMethod('GetStatusName', GetStatusName);
AddMethod('GetGroupName', GetGroupName);
AddMethod('GetContactData', GetContactData, True);
AddMethod('GetAccountPassword', GetAccountPassword);
AddMethod('SaveAccountPassword', SaveAccountPassword);
AddMethod('SaveNewAccountPassword', SaveNewAccountPassword);
AddMethod('CheckLockPassword', CheckLockPassword);
AddMethod('OpenLink', OpenLink);
AddMethod('OpenPortal', OpenPortal);
AddMethod('IsOnline', IsOnline);
AddMethod('IsAIM', IsAIM);
// Users
AddMethod('GetUsersData', GetUsersData, True);
AddMethod('OpenICQReg', OpenICQReg);
AddMethod('ChangeOrAddUser', ChangeOrAddUser);
AddMethod('CheckAccountPass', CheckAccountPass);
AddMethod('CreateAccount', CreateAccount);
AddMethod('DeleteAccount', DeleteAccount);
RegisterMethods(Args.ReturnSciterValue);
Args.Handled := True;
end;
end;
end.