diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..4c92c19 --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +__history/ +*.dcu +*.~pas +*.~* +Thumbs.db \ No newline at end of file diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 index 0000000..6241ed5 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,2 @@ +Syhunt and Sandcat are registered trademarks of Syhunt Informatica. +Other brands and trademarks are the property of their respective owners. \ No newline at end of file diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..67c8f7e --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2003-2014, Syhunt Informatica +Portions copyright (c) 2003-2014, Felipe Daragon +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name, trademarks or logos of Syhunt nor the names of its + contributors may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 0000000..7bb7bb4 --- /dev/null +++ b/README.md @@ -0,0 +1,48 @@ +# Catarinka + +Catarinka is a set of visual and non-visual components, and methods for Pascal/Delphi, developed as part of the [Sandcat Browser](https://github.com/felipedaragon/sandcat) project. This kit includes the following components: + +* `TCatChromium` - A web browser component built on top of DCEF3. +* `TCatConsole` - Console component built on top of a modified version of the Console component by Michael Elsdörfer. +* `TCatHighlighters` - Provides quick access to multiple SynEdit highlighters with a color scheme adapted from the CodeRay project. +* `TCatHTMLParser` - HTML Parser based on a component by Przemyslaw Jankowski +* `TCatJSON` - JSON Manipulation component built on top of the SuperObject. +* `TCatListEditor` - A list editor based on SuperList by David Koretzky. +* `TCatPreferences` - JSON-Based settings management component +* `TCatStorage` - VFS/Cache component that uses the Structured Storage library by Primoz Gabrijelcic. +* `TCatSynEdit` - Enhanced SynEdit with popup menu and improved scrolling. +* `TJIniList` - INIList-Like component using JSON +* `TStringLoop` - A simple component for looping through a string list +* Several libraries with string manipulation functions, file system functions and more. + +## Compatibility + +All components here work with the latest Delphi releases (for both 32-bit and 64-bit compilation) and the older D7. Most of them may work with FPC and Lazarus. + +### Before Compiling + +CatPrefs: Rename the `src\CatDCPKey.pas` file, edit it and add your own encryption keys or key generators. + +## Dependencies + +* All included in the `src` directory, except the following which you need to download separately: +* [DCPcrypt 2](https://bitbucket.org/wpostma/dcpcrypt2010) - needed by CatDCP. +* [SynWeb 1.5](https://code.google.com/p/synweb/) and [SynEdit](http://sourceforge.net/projects/synedit/) - needed by CatSynEdit. +* [Structured Storage](https://code.google.com/p/gpdelphiunits/) - need by CatStorage. +* [Abbrevia 5.0](http://sourceforge.net/projects/tpabbrevia/) - needed by CatZIP. + +## License & Credits + +Catarinka was developed by Felipe Daragon, [Syhunt](http://www.syhunt.com/). + +This project is licensed under a 3-clause BSD license - see the LICENSE file for details. + +Some libraries and third-party code included with Catarinka use different licenses, such as MIT and MPL. You can find them in the comments of the source code files. + +## Contact + +Twitter: [@felipedaragon](https://twitter.com/felipedaragon), [@syhunt](https://twitter.com/syhunt) + +Email: felipe _at_ syhunt.com + +If you want to report a security bug, please see the `docs\SECURITY.md` file. \ No newline at end of file diff --git a/docs/SECURITY.md b/docs/SECURITY.md new file mode 100644 index 0000000..c18c38c --- /dev/null +++ b/docs/SECURITY.md @@ -0,0 +1,3 @@ +# Security + +Security bugs should be reported directly to security@syhunt.com. Low risk security bugs can be reported by opening an issue here. If you are unsure about the risk level, please report it via email. \ No newline at end of file diff --git a/src/CatCEFCache.pas b/src/CatCEFCache.pas new file mode 100644 index 0000000..c6b9fef --- /dev/null +++ b/src/CatCEFCache.pas @@ -0,0 +1,199 @@ +unit CatCEFCache; + +{ + Catarinka - Chromium Cache Reader functions + Copyright (c) 2013-2014 Syhunt Informatica + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + Winapi.Windows, System.Classes, System.SysUtils, Vcl.Dialogs; +{$ELSE} + Windows, Classes, SysUtils, Dialogs; +{$IFEND} + +function ChromeCacheToString(const HTML: string): string; +function GetChromeCacheResponseHeaders(const HTML: string): string; +function GetChromeCacheRawData(const HTML: string): string; +function IsContentGzipped(const HTML: string): boolean; +procedure ChromeCacheExtract(const HTML, OutFilename: string); + +implementation + +uses + CatHTTP, CatStringLoop, CatStrings, CatZIP; + +const + cHexPos = '00000000:'; + +procedure SaveHexStringToFile(HexStr: string; DestFileName: string; + gunzip: boolean = false); +var + BinaryStream: TMemoryStream; +begin + BinaryStream := TMemoryStream.Create; + try + BinaryStream.Size := Length(HexStr) div 2; + if BinaryStream.Size > 0 then + begin + HexToBin({$IFDEF UNICODE}PAnsiChar{$ELSE}PChar{$ENDIF}(ansistring(HexStr)), BinaryStream.Memory, + BinaryStream.Size); + if gunzip then + GUnZipStream(BinaryStream); + BinaryStream.SaveToFile(DestFileName) + end; + finally + BinaryStream.Free; + end; +end; + +function GUnzipHexStr(HexStr: string): string; +var + BinaryStream: TMemoryStream; + res: TStringList; +begin + result := emptystr; + res := TStringList.Create; + BinaryStream := TMemoryStream.Create; + try + BinaryStream.Size := Length(HexStr) div 2; + if BinaryStream.Size > 0 then + begin + HexToBin({$IFDEF UNICODE}PAnsiChar{$ELSE}PChar{$ENDIF}(ansistring(HexStr)), BinaryStream.Memory, + BinaryStream.Size); + GUnZipStream(BinaryStream); + res.LoadFromStream(BinaryStream); + result := res.Text; + end; + finally + BinaryStream.Free; + res.Free; + end; +end; + +function GetChromeCacheRawData(const HTML: string): string; +var + slp: TStringLoop; + foundheader, foundcontent: boolean; + hline, resstr: string; +begin + foundcontent := false; + foundheader := false; + slp := TStringLoop.Create; + slp.LoadFromString(HTML); + while slp.Found do + begin + if beginswith(slp.current, cHexPos) then + begin + if foundheader = true then + foundcontent := true; // starts with second occurrence + foundheader := true; + end; + if foundcontent then + begin + hline := slp.current; + if resstr = emptystr then + resstr := hline + else + resstr := resstr + crlf + hline; + end; + end; + result := resstr; + slp.Free; +end; + +function ChromeCacheToHexStr(HTML: string): string; +var + slp: TStringLoop; + foundheader, foundcontent: boolean; + hline, resstr: string; +begin + foundcontent := false; + foundheader := false; + slp := TStringLoop.Create; + slp.LoadFromString(HTML); + while slp.Found do + begin + if beginswith(slp.current, cHexPos) then + begin + if foundheader = true then + foundcontent := true; // starts with second occurrence + foundheader := true; + end; + if foundcontent then + begin + hline := slp.current; + hline := after(hline, ':'); + hline := trim(hline); + hline := copy(hline, 1, 47); // previous CEF lib was col 62 + hline := replacestr(hline, ' ', emptystr); + resstr := resstr + hline; + end; + end; + resstr := replacestr(resstr, crlf, emptystr); + result := resstr; + slp.Free; +end; + +function IsContentGzipped(const HTML: string): boolean; +begin + result := false; + if trim(getfield('Content-Encoding', HTML)) = 'gzip' then + result := true; +end; + +function GetChromeCacheResponseHeaders(const HTML: string): string; +var + slp: TStringLoop; + hdr: string; + isheader: boolean; +begin + hdr := emptystr; + isheader := false; + slp := TStringLoop.Create; + slp.LoadFromString(HTML); + while slp.Found do + begin + if beginswith(slp.current, 'HTTP/') then + isheader := true; + if beginswith(slp.current, cHexPos) then + begin + slp.Stop; + end + else + begin + if isheader then + begin + if hdr = emptystr then + hdr := slp.current + else + hdr := hdr + crlf + slp.current; + end; + end; + end; + slp.Free; + result := hdr; +end; + +function ChromeCacheToString(const HTML: string): string; +var + h: string; +begin + h := ChromeCacheToHexStr(HTML); + if IsContentGzipped(HTML) = false then + result := hextostr(h) + else + result := GUnzipHexStr(h); +end; + +procedure ChromeCacheExtract(const HTML, OutFilename: string); +begin + SaveHexStringToFile(ChromeCacheToHexStr(HTML), OutFilename, + IsContentGzipped(HTML)); +end; + +end. diff --git a/src/CatCLUtils.pas b/src/CatCLUtils.pas new file mode 100644 index 0000000..af51fdc --- /dev/null +++ b/src/CatCLUtils.pas @@ -0,0 +1,102 @@ +unit CatCLUtils; +{ + Catarinka - Command-line parameters related functions + + Copyright (c) 2003-2014 Felipe Daragon + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + System.SysUtils; +{$ELSE} + SysUtils; +{$IFEND} +function GetCmdLine: string; +function GetCmdParam(const param: string; const def_value: string = ''): string; +function GetCmdParamQuoted(const param: string; + const def_value: string = ''): string; +function HasCmdParam(const param: string): boolean; + +implementation + +uses + CatStrings; + +function GetCmdLine: string; +var + i: integer; +begin + result := emptystr; + if ParamCount > 0 then + for i := 1 to ParamCount do + result := result + ' ' + (ParamStr(i)); +end; + +// eg: if hascmdparam('-test') then ... +function HasCmdParam(const param: string): boolean; +var + i: integer; +begin + result := false; + if ParamCount = 0 then + exit; + for i := 1 to ParamCount do + begin + if lowercase(ParamStr(i)) = lowercase(param) then + result := true; + end; +end; + +// if paramstr is: name:somestring +// eg: getCmdParam('name') will return "somestring" +function GetCmdParam(const param: string; const def_value: string = ''): string; +var + i: integer; + params: string; +begin + result := emptystr; + if ParamCount = 0 then + exit; + for i := 1 to ParamCount do + params := params + ' ' + (ParamStr(i)); + params := params + ' '; + result := after(params, param + ':'); + + result := before(result, ' '); + if result = emptystr then + result := def_value; +end; + +function GetCmdParamQuoted(const param: string; + const def_value: string = ''): string; +var + i: integer; + params: string; +const + quote = '"'; +begin + result := emptystr; + if ParamCount = 0 then + exit; + for i := 1 to ParamCount do + params := params + ' ' + (ParamStr(i)); + params := params + ' '; + result := after(params, param + ':'); + + if beginswith(result, quote) then + begin + result := after(result, quote); + result := before(result, quote); + end + else + result := before(result, ' '); + if result = emptystr then + result := def_value; +end; + +// ------------------------------------------------------------------------// +end. diff --git a/src/CatChromium.pas b/src/CatChromium.pas new file mode 100644 index 0000000..6ed22ab --- /dev/null +++ b/src/CatChromium.pas @@ -0,0 +1,2010 @@ +unit CatChromium; + +{ + Catarinka Browser Component + Copyright (c) 2011-2014 Syhunt Informatica + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + System.Classes, Winapi.Windows, Winapi.Messages, Vcl.Controls, Vcl.Graphics, + Vcl.Forms, System.SysUtils, System.SyncObjs, Vcl.Dialogs, Vcl.Clipbrd, +{$ELSE} + Classes, Windows, Messages, Controls, Graphics, Forms, SysUtils, SyncObjs, + Dialogs, Clipbrd, +{$IFEND} + cefvcl, ceflib, superobject, CatJSON; + +type + TCatChromiumOnBrowserMessage = procedure(const msg: integer; + const str: string) of object; + TCatChromiumOnAfterSetSource = procedure(const s: string) of object; + TCatChromiumOnTitleChange = procedure(Sender: TObject; const title: string) + of object; + TCatChromiumOnLoadEnd = procedure(Sender: TObject; httpStatusCode: integer) + of object; + TCatChromiumOnLoadStart = procedure(Sender: TObject) of object; + TCatChromiumOnAddressChange = procedure(Sender: TObject; const url: string) + of object; + TCatChromiumOnStatusMessage = procedure(Sender: TObject; const value: string) + of object; + // TCatChromiumOnRequestComplete = procedure(const s:string) of object; + TCatChromiumOnBeforePopup = procedure(Sender: TObject; var url: string; + out Result: Boolean) of object; + TCatChromiumOnConsoleMessage = procedure(Sender: TObject; + const message, source: string; line: integer) of object; + TCatChromiumOnBeforeResourceLoad = procedure(Sender: TObject; + const request: ICefRequest; out Result: Boolean) of object; + TCatChromiumOnBeforeDownload = procedure(Sender: TObject; const id: integer; + const suggestedName: string) of object; + TCatChromiumOnDownloadUpdated = procedure(Sender: TObject; + var cancel: Boolean; const id, state, percentcomplete: integer; + const fullPath: string) of object; + TCatChromiumOnLoadingStateChange = procedure(Sender: TObject; + const isLoading, canGoBack, canGoForward: Boolean) of object; + TCatChromiumOnLoadError = procedure(Sender: TObject; const errorCode: integer; + const errorText, failedUrl: string) of object; + +type + TCatSourceVisitorOwn = class(TCefStringVisitorOwn) + private + fCriticalSection: TCriticalSection; + protected + procedure Visit(const str: ustring); override; + public + Browser: TCustomControl; + constructor Create; override; + destructor Destroy; override; + end; + +type + TCatRequestHeaders = record + StatusCode: string; + SentHead: string; + RcvdHead: string; + end; + +type + TCatChromiumRequest = record + Method: string; + url: string; + PostData: string; + Headers: string; + IgnoreCache: Boolean; + UseCachedCredentials: Boolean; + UseCookies: Boolean; + Details: string; + end; + +type + TCatChromium = class(TCustomControl) + private + fAdjustSourceDisplayMethod: Boolean; + fAutoGetSource: Boolean; + fCriticalSection: TCriticalSection; + fCrm: TChromium; + fEnableDownloads: Boolean; + fHeaders: TCatRequestHeaders; + fInterceptRequests: Boolean; + fLastStatusCode: integer; + fLastTitle: string; + fLogJavaScriptErrors: Boolean; + fLogURLs: Boolean; + fMsgHandle: HWND; + fNeedRecreate: Boolean; + fOnBrowserMessage: TCatChromiumOnBrowserMessage; + fOnAfterSetSource: TCatChromiumOnAfterSetSource; + fOnTitleChange: TCatChromiumOnTitleChange; + fOnLoadEnd: TCatChromiumOnLoadEnd; + fOnLoadStart: TCatChromiumOnLoadStart; + fOnAddressChange: TCatChromiumOnAddressChange; + fOnStatusMessage: TCatChromiumOnStatusMessage; + // fOnRequestComplete:TCatChromiumOnRequestComplete; + fOnBeforePopup: TCatChromiumOnBeforePopup; + fOnConsoleMessage: TCatChromiumOnConsoleMessage; + fOnBeforeResourceLoad: TCatChromiumOnBeforeResourceLoad; + fOnBeforeDownload: TCatChromiumOnBeforeDownload; + fOnDownloadUpdated: TCatChromiumOnDownloadUpdated; + fOnLoadingStateChange: TCatChromiumOnLoadingStateChange; + fOnLoadError: TCatChromiumOnLoadError; + fPreventPopup: Boolean; + fResourceList: TStringList; + fSentRequests: integer; + fSource: string; + fSourceVisitor: TCatSourceVisitorOwn; + fURLLog: TStringList; + procedure ClearRequestData; + procedure ClearEvents; + procedure crmTitleChange(Sender: TObject; const Browser: ICefBrowser; + const title: ustring); + procedure crmLoadEnd(Sender: TObject; const Browser: ICefBrowser; + const frame: ICefFrame; httpStatusCode: integer); + procedure crmLoadStart(Sender: TObject; const Browser: ICefBrowser; + const frame: ICefFrame); + procedure crmAddressChange(Sender: TObject; const Browser: ICefBrowser; + const frame: ICefFrame; const url: ustring); + procedure crmStatusMessage(Sender: TObject; const Browser: ICefBrowser; + const value: ustring); + procedure crmBeforeContextMenu(Sender: TObject; const Browser: ICefBrowser; + const frame: ICefFrame; const params: ICefContextMenuParams; + const model: ICefMenuModel); + procedure crmContextMenuCommand(Sender: TObject; const Browser: ICefBrowser; + const frame: ICefFrame; const params: ICefContextMenuParams; + commandId: integer; eventFlags: TCefEventFlags; out Result: Boolean); + procedure crmBeforeResourceLoad(Sender: TObject; const Browser: ICefBrowser; + const frame: ICefFrame; const request: ICefRequest; out Result: Boolean); + procedure crmBeforePopup(Sender: TObject; const Browser: ICefBrowser; + const frame: ICefFrame; const targetUrl, targetFrameName: ustring; + var popupFeatures: TCefPopupFeatures; var windowInfo: TCefWindowInfo; + var client: ICefClient; var settings: TCefBrowserSettings; + var noJavascriptAccess: Boolean; out Result: Boolean); + procedure crmConsoleMessage(Sender: TObject; const Browser: ICefBrowser; + const message, source: ustring; line: integer; out Result: Boolean); + procedure crmJsdialog(Sender: TObject; const Browser: ICefBrowser; + const originUrl, acceptLang: ustring; dialogType: TCefJsDialogType; + const messageText, defaultPromptText: ustring; + Callback: ICefJsDialogCallback; out suppressMessage, Result: Boolean); + procedure crmProcessMessageReceived(Sender: TObject; + const Browser: ICefBrowser; sourceProcess: TCefProcessId; + const message: ICefProcessMessage; out Result: Boolean); + procedure crmBeforeDownload(Sender: TObject; const Browser: ICefBrowser; + const downloadItem: ICefDownloadItem; const suggestedName: ustring; + const Callback: ICefBeforeDownloadCallback); + procedure crmDownloadUpdated(Sender: TObject; const Browser: ICefBrowser; + const downloadItem: ICefDownloadItem; + const Callback: ICefDownloadItemCallback); + procedure crmGetResourceHandler(Sender: TObject; const Browser: ICefBrowser; + const frame: ICefFrame; const request: ICefRequest; + out Result: ICefResourceHandler); + procedure crmLoadError(Sender: TObject; const Browser: ICefBrowser; + const frame: ICefFrame; errorCode: integer; + const errorText, failedUrl: ustring); + procedure crmLoadingStateChange(Sender: TObject; const Browser: ICefBrowser; + isLoading, canGoBack, canGoForward: Boolean); + procedure crmPluginCrashed(Sender: TObject; const Browser: ICefBrowser; + const pluginPath: ustring); + procedure crmGetAuthCredentials(Sender: TObject; const Browser: ICefBrowser; + const frame: ICefFrame; isProxy: Boolean; const host: ustring; + port: integer; const realm, scheme: ustring; + const Callback: ICefAuthCallback; out Result: Boolean); + procedure crmMessage(var AMsg: TMessage); + procedure crmRenderProcessTerminated(Sender: TObject; + const Browser: ICefBrowser; status: TCefTerminationStatus); + procedure LogURL(const url: string); + procedure SendMessageToTab(const id: integer; const s: string); + procedure SetZoomLevel(const zl: double); + function GetZoomLevel: double; + function GetURLShort: string; + function GetDevToolsURL: string; + procedure StopLoadBlank; + procedure WMCopyData(var message: TMessage); + public + constructor Create(AOwner: TComponent); + destructor Destroy; override; + function EvalJavaScript(const Script: string): variant; + function GetURL: string; + function IsMain(const b: ICefBrowser; const f: ICefFrame = nil): Boolean; + function IsFrameNil: Boolean; + procedure AddToResourceList(const url: string); + procedure GoBack; + procedure GoForward; + procedure Load(const url: string); + procedure LoadBlank(const WaitLoad: Boolean = false); + procedure LoadFromString(const s, url: string); + procedure LoadSettings(settings, DefaultSettings: TCatJSON); + procedure RunJavaScript(const Script: string); overload; + procedure RunJavaScript(const Script: string; const ScriptURL: string; + const StartLine: integer; const ReportErrors: Boolean = false); overload; + procedure RegisterNewV8Extension(const v8js: string); + procedure Reload(const IgnoreCache: Boolean = false); + procedure SendMessage(const msg: integer; const msgstr: string); + procedure SendRequest(const req: TCatChromiumRequest; + const Load: Boolean = false); + procedure SetV8MsgHandle(const handle: integer); + procedure Stop(const waitstop:boolean=false); + procedure GetSource; // callback + procedure GetSourceAsText; // callback + procedure SetSource(const s: string); + function isLoading: Boolean; + procedure ShowAuthDialog(const Username: string = ''; + const Password: string = ''); + procedure ViewSourceExternalEditor; + // properties + property AdjustSourceDisplayMethod: Boolean read fAdjustSourceDisplayMethod + write fAdjustSourceDisplayMethod; + property Crm: TChromium read fCrm; + property DevToolsURL: string read GetDevToolsURL; + property EnableDownloads: Boolean read fEnableDownloads + write fEnableDownloads; + property Headers: TCatRequestHeaders read fHeaders; + property InterceptRequests: Boolean read fInterceptRequests + write fInterceptRequests; + property LogURLs: Boolean read fLogURLs write fLogURLs; + property LogJavaScriptErrors: Boolean read fLogJavaScriptErrors + write fLogJavaScriptErrors; + property ResourceList: TStringList read fResourceList; + property title: string read fLastTitle; + property URLLog: TStringList read fURLLog; + property URLShort: string read GetURLShort; + property ZoomLevel: double read GetZoomLevel write SetZoomLevel; + published + property OnAfterSetSource: TCatChromiumOnAfterSetSource + read fOnAfterSetSource write fOnAfterSetSource; + property OnBrowserMessage: TCatChromiumOnBrowserMessage + read fOnBrowserMessage write fOnBrowserMessage; + property OnLoadEnd: TCatChromiumOnLoadEnd read fOnLoadEnd write fOnLoadEnd; + property OnLoadStart: TCatChromiumOnLoadStart read fOnLoadStart + write fOnLoadStart; + property OnTitleChange: TCatChromiumOnTitleChange read fOnTitleChange + write fOnTitleChange; + property OnAddressChange: TCatChromiumOnAddressChange read fOnAddressChange + write fOnAddressChange; + property OnStatusMessage: TCatChromiumOnStatusMessage read fOnStatusMessage + write fOnStatusMessage; + // property OnRequestComplete:TCatChromiumOnRequestComplete read FOnRequestComplete write FOnRequestComplete; + property OnBeforePopup: TCatChromiumOnBeforePopup read fOnBeforePopup + write fOnBeforePopup; + property OnConsoleMessage: TCatChromiumOnConsoleMessage + read fOnConsoleMessage write fOnConsoleMessage; + property OnBeforeResourceLoad: TCatChromiumOnBeforeResourceLoad + read fOnBeforeResourceLoad write fOnBeforeResourceLoad; + property OnBeforeDownload: TCatChromiumOnBeforeDownload + read fOnBeforeDownload write fOnBeforeDownload; + property OnDownloadUpdated: TCatChromiumOnDownloadUpdated + read fOnDownloadUpdated write fOnDownloadUpdated; + property OnLoadingStateChange: TCatChromiumOnLoadingStateChange + read fOnLoadingStateChange write fOnLoadingStateChange; + property OnLoadError: TCatChromiumOnLoadError read fOnLoadError + write fOnLoadError; + end; + +type + TSpecialCEFReq = class(TCefUrlRequestClientOwn) + private + fr: ISuperObject; + fCriticalSection: TCriticalSection; + fLogged: Boolean; + fResponseText: string; + fResponseStream: TMemoryStream; + function CEF_GetPostData(request: ICefRequest): string; + function CEF_GetSentHeader(request: ICefRequest; + IncludePostData: Boolean = true): string; + function CEF_GetRcvdHeader(Response: ICefResponse): string; + protected + procedure OnRequestComplete(const request: ICefUrlRequest); override; + procedure OnDownloadData(const request: ICefUrlRequest; data: Pointer; + dataLength: NativeUInt); override; + public + MsgHandle: HWND; + Details: string; + constructor Create; override; + destructor Destroy; override; + end; + + TSandcatV8Extension = class(TCefv8HandlerOwn) + private + fV8MsgHandle: integer; + protected + function Execute(const name: ustring; const obj: ICefv8Value; + const arguments: TCefv8ValueArray; var retval: ICefv8Value; + var exception: ustring): Boolean; override; + public + constructor Create; override; + end; + + TCustomRenderProcessHandler = class(TCefRenderProcessHandlerOwn) + private + fSandcatV8Extension: TSandcatV8Extension; + protected + function OnProcessMessageReceived(const Browser: ICefBrowser; + sourceProcess: TCefProcessId; const message: ICefProcessMessage) + : Boolean; override; + procedure OnWebKitInitialized; override; + end; + +type + TCatChromiumXHR = record + Details: string; + Method: string; + url: string; + Headers: string; + PostData: string; + Filters: string; + Username: string; + Password: string; + Callback: string; + Tab: string; + end; + +const + cABOUTBLANK = 'about:blank'; + cHOMEURL = 'sandcat:home'; + +const // Chromium settings + cOptions = 'chrome.options.'; + CRMO_ACCELERATED_COMPOSITING = cOptions + 'accelerated_compositing'; + CRMO_APPLICATION_CACHE = cOptions + 'application_cache'; + CRMO_AUTHOR_AND_USER_STYLES = cOptions + 'author_and_user_styles'; + CRMO_CARET_BROWSING = cOptions + 'caret_browsing'; + CRMO_DATABASES = cOptions + 'databases'; + CRMO_DEVELOPER_TOOLS = cOptions + 'developer_tools'; + CRMO_FILE_ACCESS_FROM_FILE_URLS = cOptions + 'fileurl.access'; + CRMO_IMAGE_LOADING = cOptions + 'image.loading'; + CRMO_IMAGE_SHRINK_STANDALONE_TO_FIT = cOptions + + 'image.shrink_stand_alone_to_fit'; + CRMO_JAVA = cOptions + 'java'; + CRMO_JAVASCRIPT = cOptions + 'javascript.enabled'; + CRMO_JAVASCRIPT_ACCESS_CLIPBOARD = cOptions + 'javascript.access_clipboard'; + CRMO_JAVASCRIPT_CLOSE_WINDOWS = cOptions + 'javascript.close_windows'; + CRMO_JAVASCRIPT_DOM_PASTE = cOptions + 'javascript.dom_paste'; + CRMO_JAVASCRIPT_OPEN_WINDOWS = cOptions + 'javascript.open_windows'; + CRMO_LOCAL_STORAGE = cOptions + 'local_storage'; + CRMO_PAGE_CACHE = cOptions + 'page_cache'; + CRMO_PLUGINS = cOptions + 'plugins'; + CRMO_TAB_TO_LINKS = cOptions + 'tab_to_links'; + CRMO_TEXT_AREA_RESIZE = cOptions + 'text_area_resize'; + CRMO_UNIVERSAL_ACCESS_FROM_FILE_URLS = cOptions + 'fileurl.universal_access'; + CRMO_WEBGL = cOptions + 'webgl'; + CRMO_WEBSECURITY = cOptions + 'websecurity'; + +const // Messages from the Chromium renderer to the Sandcat Tab object + CRM_LOG_REQUEST_JSON = 1; + CRM_CONSOLE_ENDEXTERNALOUTPUT = 2; + CRM_RENDER_PROCESSTERMINATED = 3; + CRM_NEWTAB = 4; + CRM_XHR_LOG = 5; + CRM_JS_RUN_WHITELISTED_LUA = 6; + CRM_JS_WRITELN = 7; + CRM_JS_WRITE = 8; + CRM_JS_WRITEVALUE = 9; + CRM_JS_ALERT = 10; + CRM_NEWPAGERESOURCE = 11; + CRM_SAVECACHEDRESOURCE = 12; + CRM_SEARCHWITHENGINE = 13; + CRM_SEARCHWITHENGINE_INNEWTAB = 14; + CRM_NEWTAB_INBACKGROUND = 15; + CRM_SAVECLOUDRESOURCE = 16; + CRM_BOOKMARKURL = 17; + +const // Messages from the Sandcat tab to the Chromium renderer object + SCTM_SET_V8_MSGHANDLE = 1; + SCTM_V8_REGISTEREXTENSION = 2; + +const // Download related + SCD_UNKNOWN = 0; + SCD_INPROGRESS = 1; + SCD_COMPLETE = 2; + SCD_CANCELED = 3; + +function GetCEFUserAgent: string; +function GetCEFDefaults(settings: TCatJSON): string; +function CEFV8ValueToStr(v: ICefv8Value): string; +function BuildRequest(Method, url: string; PostData: string = '') + : TCatChromiumRequest; +procedure CatCEFShutdown(force: Boolean = false); +procedure SendCDMessage(desthandle, msgid: integer; l: string); +procedure Send_WriteValue(desthandle: integer; key, value: string); + +implementation + +uses uAuthentication, CatJINI, CatStringLoop, CatTasks, CatUI, CatFiles, CatStrings, + CatHTTP, CatUtils, CatTime, CatPointer; + +var + TempFileCount: integer = 0; + +function BuildRequest(Method, url: string; PostData: string = '') + : TCatChromiumRequest; +begin + Result.Method := Method; + Result.url := url; + Result.PostData := PostData; + Result.Headers := emptystr; + Result.IgnoreCache := true; + Result.UseCookies := true; + Result.UseCachedCredentials := true; + Result.Details := emptystr; +end; + +procedure CatCEFShutdown(force: Boolean = false); +begin + if force = true then + KillProcessbyPID(GetCurrentProcessId) + else begin + ceflib.CefShutDown; + ExitProcess(0); + end; +end; + +function GetCEFDefaults(settings: TCatJSON): string; +var + list: TStringList; + procedure s(CID: string; DefaultValue: Boolean); + begin + settings[CID] := DefaultValue; + list.Add(CID); + end; + +begin + list := TStringList.Create; + s(CRMO_ACCELERATED_COMPOSITING, true); + s(CRMO_APPLICATION_CACHE, true); + s(CRMO_AUTHOR_AND_USER_STYLES, true); + s(CRMO_CARET_BROWSING, true); + s(CRMO_DATABASES, true); + s(CRMO_DEVELOPER_TOOLS, true); + s(CRMO_FILE_ACCESS_FROM_FILE_URLS, true); + s(CRMO_IMAGE_LOADING, true); + s(CRMO_IMAGE_SHRINK_STANDALONE_TO_FIT, true); + s(CRMO_JAVA, true); + s(CRMO_JAVASCRIPT, true); + s(CRMO_JAVASCRIPT_ACCESS_CLIPBOARD, true); + s(CRMO_JAVASCRIPT_CLOSE_WINDOWS, true); + s(CRMO_JAVASCRIPT_DOM_PASTE, true); + s(CRMO_JAVASCRIPT_OPEN_WINDOWS, true); + s(CRMO_LOCAL_STORAGE, true); + s(CRMO_PAGE_CACHE, true); + s(CRMO_PLUGINS, true); + s(CRMO_TAB_TO_LINKS, true); + s(CRMO_TEXT_AREA_RESIZE, true); + s(CRMO_UNIVERSAL_ACCESS_FROM_FILE_URLS, true); + s(CRMO_WEBGL, true); + s(CRMO_WEBSECURITY, true); + Result := list.text; + list.free; +end; + +function GetCEFUserAgent: string; +begin + Result := CefUserAgent; +end; + +function GetTempFile: string; +var + f: string; +begin + TempFileCount := TempFileCount + 1; + f := inttostr(GetCurrentProcessId) + ' - ' + inttostr(DateTimeToUnix(now)) + + '-' + inttostr(TempFileCount) + '.tmp'; + Result := CefCache + 'Headers\' + f; +end; + +function SaveResponseToFile(s: string): string; +var + sl: TStringList; +begin + Result := GetTempFile; + if CefCache = emptystr then + exit; + sl := TStringList.Create; + sl.text := s; + sl.SaveToFile(Result); + sl.free; +end; + +procedure SendCDMessage(desthandle, msgid: integer; l: string); +var + pData: PCopyDataStruct; +begin + pData := nil; + try + New(pData); + pData^.dwData := msgid; + pData^.cbData := Length(l) + 1; + pData^.lpData := PAnsiChar(AnsiString(l)); + SendMessage(desthandle, WM_COPYDATA, application.handle, integer(pData)); + finally + Dispose(pData); + end; +end; + +procedure Send_WriteValue(desthandle: integer; key, value: string); +var + j: TCatJSON; +begin + j := TCatJSON.Create; + j['k'] := key; + j['v'] := value; + SendCDMessage(desthandle, CRM_JS_WRITEVALUE, j.text); + j.free; +end; + +function TSpecialCEFReq.CEF_GetRcvdHeader(Response: ICefResponse): string; +var + i: integer; + s, kv, lastkv: string; + Map: TCefStringMultiMapOwn; + procedure Add(key, value: string); + begin + kv := key + ': ' + value; + if kv <> lastkv then + s := s + crlf + kv; // Workaround: CEF3 sometimes returns repeated headers + lastkv := kv; + end; + +begin + Map := TCefStringMultiMapOwn.Create; + Response.GetHeaderMap(Map); + s := 'HTTP/1.1 ' + inttostr(Response.getStatus) + ' ' + + Response.GetStatusText; + with Map as ICefStringMultiMap do + begin + for i := 0 to GetSize do + begin + if i < GetSize then + Add(GetKey(i), GetValue(i)); + end; + end; + Result := s; +end; + +function TSpecialCEFReq.CEF_GetSentHeader(request: ICefRequest; + IncludePostData: Boolean = true): string; +var + i: integer; + s, PostData, kv, lastkv: string; + Map: TCefStringMultiMapOwn; + procedure Add(key, value: string); + begin + kv := key + ': ' + value; + if kv <> lastkv then + s := s + crlf + kv; // Workaround: CEF3 sometimes returns repeated headers + lastkv := kv; + end; + +begin + Map := TCefStringMultiMapOwn.Create; + request.GetHeaderMap(Map); + s := request.getMethod + ' /' + getpathfromurl(request.GetURL) + ' HTTP/1.1'; + with Map as ICefStringMultiMap do + begin + if FindCount('Host') = 0 then + Add('Host', gethostfromurl(request.GetURL)); + for i := 0 to GetSize do + begin + if i < GetSize then + Add(GetKey(i), GetValue(i)); + end; + end; + if (IncludePostData) and (request.getMethod = 'POST') then + begin + PostData := CEF_GetPostData(request); + if PostData <> emptystr then + begin + s := s + crlf; + s := s + crlf + PostData; + end; + end; + Result := s + crlf; +end; + +function TSpecialCEFReq.CEF_GetPostData(request: ICefRequest): string; +var + i: integer; + ansi, datastr: AnsiString; + postElement: ICefPostDataElement; + PostData: ICefPostData; + list: IInterfaceList; +begin + ansi := ''; + PostData := request.getPostData; + if PostData <> nil then + begin + list := PostData.GetElements(PostData.GetCount); + for i := 0 to list.Count - 1 do + begin + postElement := list[i] as ICefPostDataElement; + case postElement.GetType of + PDE_TYPE_BYTES: + begin + SetLength(datastr, postElement.GetBytesCount); + postElement.GetBytes(postElement.GetBytesCount, PAnsiChar(datastr)); + ansi := ansi + datastr; + end; + PDE_TYPE_FILE: + ; + PDE_TYPE_EMPTY: + ; + end; + end; + end; + Result := ansi; +end; + +constructor TSpecialCEFReq.Create; +begin + inherited Create; + fCriticalSection := TCriticalSection.Create; + fCriticalSection.Enter; + fResponseStream := TMemoryStream.Create; + fLogged := false; +end; + +destructor TSpecialCEFReq.Destroy; +begin + fResponseStream.free; + fCriticalSection.free; + inherited; +end; + +procedure TSpecialCEFReq.OnDownloadData(const request: ICefUrlRequest; + data: Pointer; dataLength: NativeUInt); +begin + fResponseStream.WriteData(data, dataLength); + inherited; +end; + +procedure TSpecialCEFReq.OnRequestComplete(const request: ICefUrlRequest); +var + req: ICefRequest; + resp: ICefResponse; +var + SentHead, RcvdHead, referrer, respfilename: string; +begin + inherited; + fCriticalSection.Enter; + try + fr := TSuperObject.Create(stObject); + req := request.getrequest; + resp := request.getresponse; + SentHead := CEF_GetSentHeader(req); + RcvdHead := CEF_GetRcvdHeader(resp); + fr.s['method'] := req.getMethod; + fr.s['url'] := req.GetURL; + if pos('Referer', SentHead) <> 0 then + referrer := trim(getfield('Referer', SentHead)); + if req.getMethod = 'POST' then + fr.s['postdata'] := CEF_GetPostData(req) + else + fr.s['postdata'] := emptystr; + fr.s['status'] := inttostr(resp.getStatus); + fr.s['mimetype'] := resp.GetMimeType; + if Details <> emptystr then // user specified + fr.s['details'] := Details + else + begin + if lowercase(extracturlfileext(referrer)) = '.swf' then + fr.s['details'] := 'Flash Plugin Request' + else + fr.s['details'] := 'Browser Request'; + end; + fr.s['reqid'] := emptystr; + fr.s['response'] := emptystr; + respfilename := GetTempFile; + fr.s['responsefilename'] := respfilename; + fResponseStream.SaveToFile(respfilename); + fr.s['length'] := inttostr(fResponseStream.Size); + fr.b['isredir'] := false; + fr.b['islow'] := false; + fr.s['headers'] := SentHead; + fr.s['responseheaders'] := RcvdHead; + if MsgHandle <> 0 then + SendCDMessage(MsgHandle, CRM_LOG_REQUEST_JSON, fr.AsJson(true)); + fr := nil; + finally + fCriticalSection.Leave; + end; +end; + +constructor TSandcatV8Extension.Create; +begin + inherited Create; +end; + +function CEFV8ValueToStr(v: ICefv8Value): string; +begin + Result := emptystr; + if v.IsString then + Result := v.GetStringValue + else + begin + if v.IsUndefined then + Result := 'undefined' + else if v.IsNull then + Result := 'null' + else if v.IsBool then + begin + if v.GetBoolValue = true then + Result := 'true' + else + Result := 'false'; + end + else if v.IsInt then + Result := inttostr(v.GetIntValue) + else if v.IsUInt then + Result := inttostr(v.GetUIntValue) + else if v.IsDouble then + Result := floattostr(v.GetDoubleValue) + else if v.IsDate then + Result := datetimetostr(v.GetDateValue) + else if v.IsObject then + Result := '[object]' + else if v.IsArray then + Result := '[array]' + else if v.IsFunction then + Result := '[function ' + v.GetFunctionName + ']'; + end; +end; + +function TSandcatV8Extension.Execute(const name: ustring; + const obj: ICefv8Value; const arguments: TCefv8ValueArray; + var retval: ICefv8Value; var exception: ustring): Boolean; +var + printstr: string; + procedure LogRequest(Details, rid, Method, url, rcvdheader, Response: string); + var + pkt: tjinilist; + begin + pkt := tjinilist.Create; + pkt.values['ReqID'] := rid; + pkt.values['Details'] := Details; + pkt.values['ResponseHeaders'] := rcvdheader; + pkt.values['Method'] := Method; + pkt.values['URL'] := url; + pkt.values['ResponseFilename'] := SaveResponseToFile(Response); + SendCDMessage(fV8MsgHandle, CRM_XHR_LOG, pkt.text); + pkt.free; + end; + +begin + Result := false; + if (name = 'base64encode') then + begin + if (Length(arguments) <> 1) or (not arguments[0].IsString) then + begin + Result := false; + exit; + end; + retval := TCefv8ValueRef.NewString + (base64encode(arguments[0].GetStringValue)); + Result := true; + end + else if (name = 'base64decode') then + begin + if (Length(arguments) <> 1) or (not arguments[0].IsString) then + begin + Result := false; + exit; + end; + retval := TCefv8ValueRef.NewString + (base64decode(arguments[0].GetStringValue)); + Result := true; + end + else if (name = 'consoleoutput') then + begin + if (Length(arguments) = 0) or (not arguments[0].IsBool) then + begin + Result := false; + exit; + end; + if arguments[0].GetBoolValue = false then + SendCDMessage(fV8MsgHandle, CRM_CONSOLE_ENDEXTERNALOUTPUT, emptystr); + Result := true; + end + else if (name = 'logrequest') then + begin + if (Length(arguments) <> 6) or (not arguments[0].IsString) or + (not arguments[1].IsString) or (not arguments[2].IsString) or + (not arguments[3].IsString) or (not arguments[4].IsString) or + (not arguments[5].IsString) then + begin + Result := false; + exit; + end; + LogRequest(arguments[0].GetStringValue, arguments[1].GetStringValue, + arguments[2].GetStringValue, arguments[3].GetStringValue, + arguments[4].GetStringValue, arguments[5].GetStringValue); + Result := true; + end + else if (name = 'callwl') then + begin + if (Length(arguments) <> 1) or (not arguments[0].IsString) then + begin + Result := false; + exit; + end; + SendCDMessage(fV8MsgHandle, CRM_JS_RUN_WHITELISTED_LUA, + arguments[0].GetStringValue); + Result := true; + end + else if (name = 'writevalue') then + begin + if (Length(arguments) <> 2) or (not arguments[0].IsString) or + (not arguments[1].IsString) then + begin + Result := false; + exit; + end; + Send_WriteValue(fV8MsgHandle, arguments[0].GetStringValue, + CEFV8ValueToStr(arguments[1])); + Result := true; + end + else if (name = 'writeln') then + begin + if (Length(arguments) <> 1) then + begin + Result := false; + exit; + end; + SendCDMessage(fV8MsgHandle, CRM_JS_WRITELN, CEFV8ValueToStr(arguments[0])); + Result := true; + end + else if (name = 'write') then + begin + if (Length(arguments) <> 1) then + begin + Result := false; + exit; + end; + SendCDMessage(fV8MsgHandle, CRM_JS_WRITE, CEFV8ValueToStr(arguments[0])); + Result := true; + end; +end; + +procedure TCustomRenderProcessHandler.OnWebKitInitialized; +const + v8extension = '' + 'var Sandcat;' + 'if (!Sandcat) Sandcat = {};' + + '(function() {' + + 'Sandcat.Base64Encode = function(s) { native function base64encode(); return base64encode(s); };' + + 'Sandcat.Base64Decode = function(s) { native function base64decode(); return base64decode(s); };' + + 'Sandcat.LogRequest = function(details,rid,method,url,rcvdhead,response) { native function logrequest(); logrequest(details,rid,method,url,rcvdhead,response); };' + + 'Sandcat.CallWL = function(s) { native function callwl(); callwl(s); };' + + 'Sandcat.ConsoleOutput = function(b) { native function consoleoutput(); consoleoutput(b); };' + + 'Sandcat.WriteLn = function(s) { native function writeln(); writeln(s); };' + + 'Sandcat.WriteValue = function(key,value) { native function writevalue(); writevalue(key,value); };' + + 'Sandcat.Write = function(s) { native function write(); write(s); };' + + '})();'; +begin + fSandcatV8Extension := TSandcatV8Extension.Create; + CefRegisterExtension('v8/browser', v8extension, + fSandcatV8Extension as ICefV8Handler); +end; + +function TCustomRenderProcessHandler.OnProcessMessageReceived + (const Browser: ICefBrowser; sourceProcess: TCefProcessId; + const message: ICefProcessMessage): Boolean; +begin + Result := false; + if (message.getName = 'msg') then + begin + Result := true; + case message.getArgumentList.GetInt(0) of + SCTM_SET_V8_MSGHANDLE: + fSandcatV8Extension.fV8MsgHandle := message.getArgumentList.GetInt(1); + SCTM_V8_REGISTEREXTENSION: + begin // CefRegisterExtension not working from here + // CefRegisterExtension('v8/browserx',message.getArgumentList.GetString(1), SandcatV8Extension as ICefV8Handler); + end; + end; + // browser.SendProcessMessage(PID_BROWSER,message); // is crashing the renderer, review later + end; +end; + +procedure TCatChromium.SendMessage(const msg: integer; const msgstr: string); +var + m: ICefProcessMessage; +begin + if fCrm.Browser = nil then + exit; + m := TCefProcessMessageRef.New('msg'); + m.getArgumentList.SetInt(0, msg); + m.getArgumentList.SetString(1, msgstr); + fCrm.Browser.SendProcessMessage(PID_RENDERER, m); +end; + +procedure TCatChromium.RegisterNewV8Extension(const v8js: string); +var + m: ICefProcessMessage; +begin + if fCrm.Browser = nil then + exit; + m := TCefProcessMessageRef.New('msg'); + m.getArgumentList.SetInt(0, SCTM_V8_REGISTEREXTENSION); + m.getArgumentList.SetString(1, v8js); + fCrm.Browser.SendProcessMessage(PID_RENDERER, m); +end; + +procedure TCatChromium.SetV8MsgHandle(const handle: integer); +var + m: ICefProcessMessage; +begin + if fCrm.Browser = nil then + exit; + m := TCefProcessMessageRef.New('msg'); + m.getArgumentList.SetInt(0, SCTM_SET_V8_MSGHANDLE); + m.getArgumentList.SetInt(1, handle); + fCrm.Browser.SendProcessMessage(PID_RENDERER, m); +end; + +procedure TCatChromium.crmProcessMessageReceived(Sender: TObject; + const Browser: ICefBrowser; sourceProcess: TCefProcessId; + const message: ICefProcessMessage; out Result: Boolean); +begin + // test code + // if sourceprocess <> PID_RENDERER then exit; + { if message.getName = 'msg' then begin + showmessage(message.getName); + Result := True; + end else result:=false; } +end; + +function TCatChromium.IsMain(const b: ICefBrowser; const f: ICefFrame): Boolean; +begin + Result := (b <> nil) and (b.GetIdentifier = fCrm.BrowserId) and + ((f = nil) or (f.IsMain)); +end; + +function TCatChromium.GetZoomLevel: double; +begin + Result := 0; + if fCrm.Browser = nil then + exit; + Result := fCrm.Browser.GetHost.GetZoomLevel; +end; + +procedure TCatChromium.SetZoomLevel(const zl: double); +begin + if fCrm.Browser = nil then + exit; + fCrm.Browser.GetHost.SetZoomLevel(zl); +end; + +procedure TCatChromium.GoBack; +begin + if fCrm.Browser <> nil then + fCrm.Browser.GoBack; +end; + +procedure TCatChromium.GoForward; +begin + if fCrm.Browser <> nil then + fCrm.Browser.GoForward; +end; + +procedure TCatChromium.SetSource(const s: string); +begin + fSource := s; + if assigned(OnAfterSetSource) then + OnAfterSetSource(s); +end; + +function TCatChromium.IsFrameNil: Boolean; +begin + Result := false; + if fCrm.Browser = nil then + Result := true; + if fCrm.Browser = nil then + exit; + if fCrm.Browser.GetMainFrame = nil then + Result := true; +end; + +procedure TCatChromium.GetSourceAsText; +begin + if IsFrameNil then + exit; + fSourceVisitor := TCatSourceVisitorOwn.Create; + fSourceVisitor.Browser := self; + fCrm.Browser.GetMainFrame.GetText(fSourceVisitor) +end; + +procedure TCatChromium.GetSource; +var + ext: string; + showtext: Boolean; +begin + if IsFrameNil then + exit; + ext := lowercase(extracturlfileext(GetURL)); + showtext := false; + if fAdjustSourceDisplayMethod then + begin + if ext = '.js' then + showtext := true; + if ext = '.css' then + showtext := true; + if ext = '.xml' then + showtext := true; + end; + fSourceVisitor := TCatSourceVisitorOwn.Create; + fSourceVisitor.Browser := self; + if showtext then + fCrm.Browser.GetMainFrame.GetText(fSourceVisitor) + else + fCrm.Browser.GetMainFrame.GetSource(fSourceVisitor); + // There is no need to free the source visitor own according to the DCEF author + // fsourcevisitor.free; // causes AV +end; + +function TCatChromium.GetURL: string; +begin + if fCrm.Browser = nil then + exit; + if fCrm.Browser.GetMainFrame <> nil then + Result := fCrm.Browser.GetMainFrame.GetURL; +end; + +function TCatChromium.GetDevToolsURL: string; +begin + Result := emptystr; + if fCrm.Browser = nil then + exit; + if fCrm.Browser.GetHost <> nil then + Result := fCrm.Browser.GetHost.GetDevToolsURL(true); +end; + +function TCatChromium.GetURLShort: string; +var + u: string; +begin + u := GetURL; + if u = cHOMEURL then + begin + Result := emptystr; + end + else + begin + u := CatHTTP.gethostfromurl(u); + if beginswith(u, 'www.') then + begin + u := after(u, '.'); + u := before(u, '.'); + end + else + begin + u := before(u, '.'); + end; + Result := u; + end; +end; + +function TCatChromium.EvalJavaScript(const Script: string): variant; +var + ret: ICefv8Value; + expt: ICefV8Exception; + ctx: ICefv8Context; +begin + // test with console.write('eval:'..tab:evaljs('"v8" + " rocks" ')) + if IsFrameNil then + exit; + ctx := fCrm.Browser.GetMainFrame.GetV8Context; + // if ctx = nil then showmessage('nil'); + if ctx <> nil then + begin + ctx.Enter; + try + if ctx.Eval(Script, ret, expt) then + Result := ret.GetStringValue + else + Result := expt.message; + finally + ctx.exit; + ctx := nil; + end; + end; +end; + +procedure TCatChromium.RunJavaScript(const Script: string); +begin + RunJavaScript(Script, emptystr, 0, false); +end; + +procedure TCatChromium.RunJavaScript(const Script: string; + const ScriptURL: string; const StartLine: integer; + const ReportErrors: Boolean = false); +begin + // CEF will not execute the JS if no URL is loaded, + // so we load a blank URL before + if ReportErrors then + fLogJavaScriptErrors := true; + if GetURL = emptystr then + LoadBlank; + if fCrm.Browser = nil then + exit; + if fCrm.Browser.GetMainFrame = nil then + exit; + fCrm.Browser.GetMainFrame.ExecuteJavaScript(Script, ScriptURL, StartLine); +end; + +procedure TCatChromium.crmGetAuthCredentials(Sender: TObject; + const Browser: ICefBrowser; const frame: ICefFrame; isProxy: Boolean; + const host: ustring; port: integer; const realm, scheme: ustring; + const Callback: ICefAuthCallback; out Result: Boolean); +var + u, p: ustring; + r: Boolean; +begin + TThread.Synchronize(nil, + procedure + begin + with TPasswordDlg.Create(nil) do + try + if ShowModal = mrOk then + begin + u := edtusername.text; + p := edtPassword.text; + r := true; + end + else + r := false; + finally + free; + end + end); + + Result := r; + if r = true then + begin + Callback.Cont(u, p); + end; +end; + +procedure TCatChromium.ShowAuthDialog(const Username: string = ''; +const Password: string = ''); +var + u, p: string; + r: Boolean; +var + req: ICefRequest; + Map: ICefStringMultiMap; +begin + if IsFrameNil then + exit; + with TPasswordDlg.Create(nil) do + try + edtusername.text := Username; + edtPassword.text := Password; + if ShowModal = mrOk then + begin + u := edtusername.text; + p := edtPassword.text; + r := true; + end + else + r := false; + finally + free; + end; + if r = true then + begin + req := TCefRequestRef.New; + req.url := GetURL; + req.Method := 'GET'; + Map := TCefStringMultiMapOwn.Create; + req.GetHeaderMap(Map); + Map.Append('Authorization', 'Basic ' + base64encode(u + ':' + p)); + req.SetHeaderMap(Map); + fCrm.Browser.MainFrame.LoadRequest(req); + end; +end; + +procedure TCatChromium.crmLoadEnd(Sender: TObject; const Browser: ICefBrowser; +const frame: ICefFrame; httpStatusCode: integer); +begin + if IsMain(Browser, frame) = false then + exit; + fLastStatusCode := httpStatusCode; + if assigned(OnLoadEnd) then + OnLoadEnd(Sender, httpStatusCode); + if fAutoGetSource then + GetSource; +end; + +procedure TCatChromium.crmLoadStart(Sender: TObject; const Browser: ICefBrowser; +const frame: ICefFrame); +begin + if IsMain(Browser, frame) = false then + exit; + fResourceList.clear; + if assigned(OnLoadStart) then + OnLoadStart(Sender); +end; + +procedure TCatChromium.crmLoadError(Sender: TObject; const Browser: ICefBrowser; +const frame: ICefFrame; errorCode: integer; +const errorText, failedUrl: ustring); +begin + if IsMain(Browser, frame) = false then + exit; + if assigned(OnLoadError) then + OnLoadError(Sender, errorCode, errorText, failedUrl); +end; + +procedure TCatChromium.crmLoadingStateChange(Sender: TObject; +const Browser: ICefBrowser; isLoading, canGoBack, canGoForward: Boolean); +begin + if IsMain(Browser) = false then + exit; + if assigned(OnLoadingStateChange) then + OnLoadingStateChange(Sender, isLoading, canGoBack, canGoForward); +end; + +procedure TCatChromium.crmPluginCrashed(Sender: TObject; +const Browser: ICefBrowser; const pluginPath: ustring); +begin + // TODO +end; + +procedure TCatChromium.crmTitleChange(Sender: TObject; +const Browser: ICefBrowser; const title: ustring); +begin + if IsMain(Browser) = false then + exit; + fLastTitle := title; + if assigned(OnTitleChange) then + OnTitleChange(Sender, title); +end; + +procedure TCatChromium.crmAddressChange(Sender: TObject; +const Browser: ICefBrowser; const frame: ICefFrame; const url: ustring); +begin + if IsMain(Browser, frame) = false then + exit; + if assigned(OnAddressChange) then + OnAddressChange(Sender, url); +end; + +procedure TCatChromium.crmStatusMessage(Sender: TObject; +const Browser: ICefBrowser; const value: ustring); +begin + if assigned(OnStatusMessage) then + OnStatusMessage(Sender, value); +end; + +const + CRMMENU_ID_USER_FIRST = integer(MENU_ID_USER_FIRST); + CRMMENU_ID_OPENIMAGE = CRMMENU_ID_USER_FIRST; + CRMMENU_ID_OPENIMAGE_INNEWTAB = CRMMENU_ID_USER_FIRST + 1; + CRMMENU_ID_COPYIMAGEADDRESS = CRMMENU_ID_USER_FIRST + 2; + CRMMENU_ID_SAVEIMAGEAS = CRMMENU_ID_USER_FIRST + 3; + CRMMENU_ID_OPENLINK = CRMMENU_ID_USER_FIRST + 4; + CRMMENU_ID_OPENLINK_INNEWTAB = CRMMENU_ID_USER_FIRST + 5; + CRMMENU_ID_COPYADDRESS = CRMMENU_ID_USER_FIRST + 6; + CRMMENU_ID_SEARCH = CRMMENU_ID_USER_FIRST + 7; + CRMMENU_ID_SEARCH_INNEWTAB = CRMMENU_ID_USER_FIRST + 8; + CRMMENU_ID_LINK_COPYADDRESS = CRMMENU_ID_USER_FIRST + 9; + CRMMENU_ID_OPENLINK_INBGTAB = CRMMENU_ID_USER_FIRST + 10; + CRMMENU_ID_FRAMEMENU = CRMMENU_ID_USER_FIRST + 11; + CRMMENU_ID_FRAMEMENU_OPEN = CRMMENU_ID_USER_FIRST + 12; + CRMMENU_ID_FRAMEMENU_OPEN_INNEWTAB = CRMMENU_ID_USER_FIRST + 13; + CRMMENU_ID_FRAMEMENU_OPEN_INBGTAB = CRMMENU_ID_USER_FIRST + 14; + CRMMENU_ID_FRAMEMENU_COPYADDRESS = CRMMENU_ID_USER_FIRST + 15; + CRMMENU_ID_PAGE_SAVEAS = CRMMENU_ID_USER_FIRST + 16; + CRMMENU_ID_LINK_SAVEAS = CRMMENU_ID_USER_FIRST + 17; + CRMMENU_ID_PAGE_BOOKMARK = CRMMENU_ID_USER_FIRST + 18; + CRMMENU_ID_LINK_BOOKMARK = CRMMENU_ID_USER_FIRST + 19; + +procedure TCatChromium.crmBeforeContextMenu(Sender: TObject; +const Browser: ICefBrowser; const frame: ICefFrame; +const params: ICefContextMenuParams; const model: ICefMenuModel); +var + fn: string; + addsep, canclear: Boolean; + framemodel: ICefMenuModel; +begin + addsep := false; + canclear := true; + if params.IsEditable = false then + begin + if not(CM_TYPEFLAG_SELECTION in params.TypeFlags) then + begin + model.InsertSeparatorAt(2); + model.InsertItemAt(3, integer(MENU_ID_RELOAD), 'Reload'); + model.InsertItemAt(4, integer(MENU_ID_RELOAD_NOCACHE), + 'Reload (Ignore Cache)'); + model.InsertSeparatorAt(5); + model.InsertItemAt(6, integer(CRMMENU_ID_PAGE_BOOKMARK), 'Bookmark Page'); + model.InsertItemAt(7, integer(CRMMENU_ID_PAGE_SAVEAS), 'Save Page As...'); + model.InsertItemAt(8, CRMMENU_ID_COPYADDRESS, 'Copy Location'); + model.InsertSeparatorAt(9); + model.InsertItemAt(10, integer(MENU_ID_SELECT_ALL), 'Select All'); + if CM_TYPEFLAG_FRAME in params.TypeFlags then + begin + model.AddSeparator; + framemodel := model.AddSubMenu(CRMMENU_ID_FRAMEMENU, 'Frame'); + framemodel.AddItem(CRMMENU_ID_FRAMEMENU_OPEN, 'Open'); + framemodel.AddItem(CRMMENU_ID_FRAMEMENU_OPEN_INNEWTAB, + 'Open in New Tab'); + framemodel.AddItem(CRMMENU_ID_FRAMEMENU_OPEN_INBGTAB, + 'Open in Background Tab'); + framemodel.AddSeparator; + framemodel.AddItem(CRMMENU_ID_FRAMEMENU_COPYADDRESS, 'Copy Location') + end; + end + else + begin + model.AddSeparator; + model.AddItem(CRMMENU_ID_SEARCH, 'Search'); + model.AddItem(CRMMENU_ID_SEARCH_INNEWTAB, 'Search in New Tab'); + end; + end; + if CM_TYPEFLAG_LINK in params.TypeFlags then + begin + if canclear then + model.clear; + canclear := false; + model.AddItem(CRMMENU_ID_OPENLINK, 'Open Link Location'); + model.AddItem(CRMMENU_ID_OPENLINK_INNEWTAB, 'Open Link in New Tab'); + model.AddItem(CRMMENU_ID_OPENLINK_INBGTAB, 'Open Link in Background Tab'); + model.AddSeparator; + model.AddItem(CRMMENU_ID_LINK_BOOKMARK, 'Bookmark Link'); + model.AddItem(CRMMENU_ID_LINK_COPYADDRESS, 'Copy Link'); + model.AddItem(CRMMENU_ID_LINK_SAVEAS, 'Save Link As...'); + addsep := true; + end; + // CM_TYPEFLAG_FRAME + // CM_TYPEFLAG_SELECTION + // CM_TYPEFLAG_EDITABLE + if CM_TYPEFLAG_MEDIA in params.TypeFlags then + begin + if CM_MEDIATYPE_IMAGE = params.MediaType then + begin + if canclear then + model.clear; + canclear := false; + if addsep then + model.AddSeparator; + fn := extracturlfilename(params.SourceUrl); + if Length(fn) <= 50 then + model.AddItem(CRMMENU_ID_OPENIMAGE, 'Open Image (' + fn + ')') + else + model.AddItem(CRMMENU_ID_OPENIMAGE, 'Open Image'); + model.AddItem(CRMMENU_ID_OPENIMAGE_INNEWTAB, 'Open Image in New Tab'); + model.AddSeparator; + model.AddItem(CRMMENU_ID_COPYIMAGEADDRESS, 'Copy Image Location'); + model.AddItem(CRMMENU_ID_SAVEIMAGEAS, 'Save Image As...'); + end; + end; +end; + +procedure TCatChromium.crmContextMenuCommand(Sender: TObject; +const Browser: ICefBrowser; const frame: ICefFrame; +const params: ICefContextMenuParams; commandId: integer; +eventFlags: TCefEventFlags; out Result: Boolean); +begin + case commandId of + CRMMENU_ID_OPENLINK: + Load(params.LinkUrl); + CRMMENU_ID_OPENLINK_INNEWTAB: + SendMessageToTab(CRM_NEWTAB, params.LinkUrl); + CRMMENU_ID_OPENLINK_INBGTAB: + SendMessageToTab(CRM_NEWTAB_INBACKGROUND, params.LinkUrl); + CRMMENU_ID_OPENIMAGE: + Load(params.SourceUrl); + CRMMENU_ID_OPENIMAGE_INNEWTAB: + SendMessageToTab(CRM_NEWTAB, params.SourceUrl); + CRMMENU_ID_COPYIMAGEADDRESS: + clipboard.AsText := params.SourceUrl; + CRMMENU_ID_SAVEIMAGEAS: + SendMessageToTab(CRM_SAVECACHEDRESOURCE, params.SourceUrl); + CRMMENU_ID_COPYADDRESS: + clipboard.AsText := GetURL; + CRMMENU_ID_SEARCH: + SendMessageToTab(CRM_SEARCHWITHENGINE, params.SelectionText); + CRMMENU_ID_SEARCH_INNEWTAB: + SendMessageToTab(CRM_SEARCHWITHENGINE_INNEWTAB, params.SelectionText); + CRMMENU_ID_LINK_COPYADDRESS: + clipboard.AsText := params.LinkUrl; + CRMMENU_ID_FRAMEMENU_OPEN: + Load(params.FrameUrl); + CRMMENU_ID_FRAMEMENU_OPEN_INNEWTAB: + SendMessageToTab(CRM_NEWTAB, params.FrameUrl); + CRMMENU_ID_FRAMEMENU_OPEN_INBGTAB: + SendMessageToTab(CRM_NEWTAB_INBACKGROUND, params.FrameUrl); + CRMMENU_ID_FRAMEMENU_COPYADDRESS: + clipboard.AsText := params.FrameUrl; + CRMMENU_ID_PAGE_SAVEAS: + SendMessageToTab(CRM_SAVECACHEDRESOURCE, GetURL); + CRMMENU_ID_LINK_SAVEAS: + SendMessageToTab(CRM_SAVECLOUDRESOURCE, params.LinkUrl); + CRMMENU_ID_PAGE_BOOKMARK: + SendMessageToTab(CRM_BOOKMARKURL, GetURL); + CRMMENU_ID_LINK_BOOKMARK: + SendMessageToTab(CRM_BOOKMARKURL, params.LinkUrl); + end; +end; + +procedure TCatChromium.AddToResourceList(const url: string); +begin + if fResourceList.Count > 2000 then + exit; + if fResourceList.IndexOf(url) <> -1 then + exit; + if url = GetURL then + exit; + if pos('?', url) <> 0 then + exit; // url with params, most likely not an object + fResourceList.Add(url); + if assigned(OnBrowserMessage) then + OnBrowserMessage(CRM_NEWPAGERESOURCE, url); +end; + +procedure TCatChromium.crmGetResourceHandler(Sender: TObject; +const Browser: ICefBrowser; const frame: ICefFrame; const request: ICefRequest; +out Result: ICefResourceHandler); +var + req: ICefUrlRequest; + reqown: TSpecialCEFReq; +begin + if fInterceptRequests = false then + exit; + if Browser = nil then + exit; + fSentRequests := fSentRequests + 1; + // sendmessagetotab(msghandle,CRM_LOGWRITELN,'getresourcehandler:'+request.getUrl); + reqown := TSpecialCEFReq.Create; + reqown.MsgHandle := self.fMsgHandle; + req := TCefUrlRequestRef.New(request, reqown) as ICefUrlRequest; +end; + +procedure TCatChromium.crmBeforeResourceLoad(Sender: TObject; +const Browser: ICefBrowser; const frame: ICefFrame; const request: ICefRequest; +out Result: Boolean); +begin + // result:=false; // unnecessary + // This would avoid a weird crash during navigation with past CEF3 releases +end; + +procedure TCatChromium.SendMessageToTab(const id: integer; const s: string); +begin + SendCDMessage(fMsgHandle, id, s); +end; + +procedure TCatChromium.crmBeforePopup(Sender: TObject; +const Browser: ICefBrowser; const frame: ICefFrame; +const targetUrl, targetFrameName: ustring; var popupFeatures: TCefPopupFeatures; +var windowInfo: TCefWindowInfo; var client: ICefClient; +var settings: TCefBrowserSettings; var noJavascriptAccess: Boolean; +out Result: Boolean); +var + u: string; +begin + Result := fPreventPopup; + u := targetUrl; + SendMessageToTab(CRM_NEWTAB, u); + // if assigned(OnBeforePopup) then onBeforePopup(sender,u,result); + // targetUrl:=u; // ToDo: CEF3 latest returns a constant +end; + +procedure TCatChromium.crmConsoleMessage(Sender: TObject; +const Browser: ICefBrowser; const message, source: ustring; line: integer; +out Result: Boolean); +begin + if fLogJavaScriptErrors = false then + exit; + fLogJavaScriptErrors := false; + if assigned(OnConsoleMessage) then + OnConsoleMessage(Sender, message, source, line); +end; + +procedure TCatChromium.crmJsdialog(Sender: TObject; const Browser: ICefBrowser; +const originUrl, acceptLang: ustring; dialogType: TCefJsDialogType; +const messageText, defaultPromptText: ustring; Callback: ICefJsDialogCallback; +out suppressMessage, Result: Boolean); +begin + case dialogType of + JSDIALOGTYPE_ALERT: + begin + if assigned(OnBrowserMessage) then + OnBrowserMessage(CRM_JS_ALERT, messageText); + // ShowMessage(MessageText); + suppressMessage := true; + end; + end; +end; + +procedure TCatChromium.ViewSourceExternalEditor; +begin + if fCrm.Browser = nil then + exit; + if fCrm.Browser.GetMainFrame = nil then + exit; + fCrm.Browser.GetMainFrame.ViewSource; +end; + +procedure TCatChromium.crmBeforeDownload(Sender: TObject; +const Browser: ICefBrowser; const downloadItem: ICefDownloadItem; +const suggestedName: ustring; const Callback: ICefBeforeDownloadCallback); +var + s: string; +begin + if fEnableDownloads = false then + exit; + s := suggestedName; + // debug + // sendmessagetotab(msghandle,CRM_LOGWRITELN,'beforedownload:'+inttostr(downloaditem.getid)); + Callback.Cont(GetSpecialFolderPath(CSIDL_PERSONAL, false) + '\' + + suggestedName, true); + if assigned(OnBeforeDownload) then + OnBeforeDownload(Sender, downloadItem.getid, s); +end; + +procedure TCatChromium.crmDownloadUpdated(Sender: TObject; +const Browser: ICefBrowser; const downloadItem: ICefDownloadItem; +const Callback: ICefDownloadItemCallback); +var + cancel: Boolean; + state: integer; + function statetostr(s: integer): string; + begin + case s of + SCD_INPROGRESS: + Result := 'inprogress'; + SCD_CANCELED: + Result := 'canceled'; + SCD_COMPLETE: + Result := 'complete'; + end; + end; + +begin + if fEnableDownloads = false then + exit; + cancel := false; + state := SCD_UNKNOWN; + if downloadItem.IsInProgress then + begin + if downloadItem.IsValid then + if downloadItem.getPercentComplete <> 0 then + state := SCD_INPROGRESS; + end; + if downloadItem.IsComplete then + state := SCD_COMPLETE; + if downloadItem.IsCanceled then + begin + state := SCD_CANCELED; + end; + // debug + // sendmessagetotab(msghandle,CRM_LOGWRITELN,'downloadupdated: '+statetostr(state)+downloaditem.getfullpath); + if assigned(OnDownloadUpdated) then + OnDownloadUpdated(Sender, cancel, downloadItem.getid, state, + downloadItem.getPercentComplete, downloadItem.getfullpath); + if cancel = true then + Callback.cancel; +end; + +procedure TCatChromium.LogURL(const url: string); +begin + if url = emptystr then + exit; + if fURLLog.IndexOf(url) = -1 then + fURLLog.Add(url); +end; + +procedure TCatChromium.WMCopyData(var message: TMessage); +var + pData: PCopyDataStruct; + msgid: integer; + str: string; + j: TCatJSON; + procedure HandleResponse(json: string); + begin + j := TCatJSON.Create; + j.text := json; + if fLogURLs = true then + LogURL(j['url']); + if j['mimetype'] <> 'text/html' then + AddToResourceList(j['url']); + if fHeaders.StatusCode = emptystr then + begin // we just want the response for the first request + if j['url'] = GetURL then + begin + fHeaders.SentHead := j['headers']; + fHeaders.RcvdHead := j['responseheaders']; + fHeaders.StatusCode := j['status']; + end; + end; + j.free; + end; + +begin + message.Result := 0; + pData := PCopyDataStruct(message.LParam); + if (pData = nil) then + exit; + str := StrPas(PAnsiChar(pData^.lpData)); + msgid := pData^.dwData; + case msgid of + CRM_LOG_REQUEST_JSON: + HandleResponse(str); + end; + if assigned(OnBrowserMessage) then + OnBrowserMessage(msgid, str); + message.Result := 1; +end; + +procedure TCatChromium.crmMessage(var AMsg: TMessage); +begin + try + case AMsg.msg of + WM_COPYDATA: + WMCopyData(AMsg); + end; + except + end; +end; + +procedure TCatChromium.crmRenderProcessTerminated(Sender: TObject; +const Browser: ICefBrowser; status: TCefTerminationStatus); +begin + if assigned(OnBrowserMessage) then + OnBrowserMessage(CRM_CONSOLE_ENDEXTERNALOUTPUT, emptystr); + if assigned(OnLoadEnd) then + OnLoadEnd(Sender, 0); +end; + +{ procedure TCatChromium.LoadCustomCSS; + begin + needrecreate:=true; + FChrome.crm.options.UserStyleSheetEnabled :=true; + FChrome.crm.UserStyleSheetLocation:=UserScript.CSS_UserStyleSheet; + //FChrome.crm.Options.UniversalAccessFromFileUrlsAllowed:=true; + //FChrome.Crm.Options.FileAccessFromFileUrlsAllowed:=true; + end; +} + +function CEFStateToStr(s: TCefState): string; +begin + Result := emptystr; + case s of + STATE_ENABLED: + Result := 'Enabled'; + STATE_DISABLED: + Result := 'Disabled'; + STATE_DEFAULT: + Result := 'Default'; + end; +end; + +procedure TCatChromium.LoadSettings(settings, DefaultSettings: TCatJSON); + function GetState(CID: string): TCefState; + var + value, DefaultValue: Boolean; + begin + Result := STATE_DEFAULT; + DefaultValue := DefaultSettings[CID]; + value := settings.GetValue(CID, DefaultValue); + if value <> DefaultValue then + begin + fNeedRecreate := true; + if value = true then + Result := STATE_ENABLED + else + Result := STATE_DISABLED; + end; + end; + +begin + // LoadCustomCSS; + fNeedRecreate := false; + fCrm.Options.AcceleratedCompositing := GetState(CRMO_ACCELERATED_COMPOSITING); + fCrm.Options.ApplicationCache := GetState(CRMO_APPLICATION_CACHE); + fCrm.Options.AuthorAndUserStyles := GetState(CRMO_AUTHOR_AND_USER_STYLES); + fCrm.Options.CaretBrowsing := GetState(CRMO_CARET_BROWSING); + fCrm.Options.Databases := GetState(CRMO_DATABASES); + // fCrm.Options.DeveloperTools := GetState(CRMO_DEVELOPER_TOOLS); + fCrm.Options.FileAccessFromFileUrls := + GetState(CRMO_FILE_ACCESS_FROM_FILE_URLS); + fCrm.Options.ImageLoading := GetState(CRMO_IMAGE_LOADING); + fCrm.Options.ImageShrinkStandaloneToFit := + GetState(CRMO_IMAGE_SHRINK_STANDALONE_TO_FIT); + fCrm.Options.Java := GetState(CRMO_JAVA); + fCrm.Options.Javascript := GetState(CRMO_JAVASCRIPT); + fCrm.Options.JavascriptAccessClipboard := + GetState(CRMO_JAVASCRIPT_ACCESS_CLIPBOARD); + fCrm.Options.JavascriptCloseWindows := + GetState(CRMO_JAVASCRIPT_CLOSE_WINDOWS); + fCrm.Options.JavascriptDomPaste := GetState(CRMO_JAVASCRIPT_DOM_PASTE); + fCrm.Options.JavascriptOpenWindows := GetState(CRMO_JAVASCRIPT_OPEN_WINDOWS); + fCrm.Options.LocalStorage := GetState(CRMO_LOCAL_STORAGE); + // fCrm.Options.PageCache := GetState(CRMO_PAGE_CACHE); + fCrm.Options.Plugins := GetState(CRMO_PLUGINS); + fCrm.Options.TabToLinks := GetState(CRMO_TAB_TO_LINKS); + fCrm.Options.TextAreaResize := GetState(CRMO_TEXT_AREA_RESIZE); + fCrm.Options.UniversalAccessFromFileUrls := + GetState(CRMO_UNIVERSAL_ACCESS_FROM_FILE_URLS); + fCrm.Options.Webgl := GetState(CRMO_WEBGL); + fCrm.Options.WebSecurity := GetState(CRMO_WEBSECURITY); + { + // Recreating the browser causing a crash with the latest CEF + // (investigate later) + if fNeedRecreate then + begin + // showmessage(CEFStateToStr(crm.Options.Javascript)); + if fCrm.Browser <> nil then + begin + fNeedRecreate := false; + fCrm.ReCreateBrowser(GetURL); + end; + end; } +end; + +constructor TCatChromium.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + ControlStyle := ControlStyle + [csAcceptsControls]; + Color := clWindow; + fMsgHandle := +{$IF CompilerVersion >= 23}System.{$IFEND}Classes.AllocateHWnd(crmMessage); + fCriticalSection := TCriticalSection.Create; + fPreventPopup := true; + fInterceptRequests := true; + fLogURLs := false; + fEnableDownloads := true; + fAdjustSourceDisplayMethod := true; + fAutoGetSource := false; + fLogJavaScriptErrors := false; + fResourceList := TStringList.Create; + fURLLog := TStringList.Create; + fCrm := TChromium.Create(nil); + fCrm.Visible := false; + fCrm.Color := clWindow; + fCrm.Parent := self; + fCrm.Align := alclient; + fCrm.OnTitleChange := crmTitleChange; + fCrm.OnLoadEnd := crmLoadEnd; + fCrm.OnGetAuthCredentials := crmGetAuthCredentials; + fCrm.OnLoadStart := crmLoadStart; + fCrm.OnAddressChange := crmAddressChange; + fCrm.OnStatusMessage := crmStatusMessage; + fCrm.OnBeforeContextMenu := crmBeforeContextMenu; + fCrm.OnBeforeResourceLoad := crmBeforeResourceLoad; + fCrm.OnGetAuthCredentials := crmGetAuthCredentials; + fCrm.OnBeforePopup := crmBeforePopup; + fCrm.OnConsoleMessage := crmConsoleMessage; + fCrm.OnJsdialog := crmJsdialog; + fCrm.OnBeforeDownload := crmBeforeDownload; + fCrm.OnDownloadUpdated := crmDownloadUpdated; + fCrm.OnGetResourceHandler := crmGetResourceHandler; + fCrm.OnProcessMessageReceived := crmProcessMessageReceived; + fCrm.OnLoadError := crmLoadError; + fCrm.OnLoadingStateChange := crmLoadingStateChange; + fCrm.OnPluginCrashed := crmPluginCrashed; + fCrm.OnRenderProcessTerminated := crmRenderProcessTerminated; + fCrm.OnContextMenuCommand := crmContextMenuCommand; +end; + +procedure TCatChromium.ClearEvents; +begin + OnAfterSetSource := nil; + OnBrowserMessage := nil; + with fCrm do + begin + OnContextMenuCommand := nil; + OnAddressChange := nil; + OnBeforeContextMenu := nil; + OnBeforeDownload := nil; + OnBeforePopup := nil; + OnBeforeResourceLoad := nil; + OnConsoleMessage := nil; + OnDownloadUpdated := nil; + OnGetAuthCredentials := nil; + OnGetResourceHandler := nil; + OnJsdialog := nil; + OnLoadEnd := nil; + OnLoadError := nil; + OnLoadingStateChange := nil; + OnLoadStart := nil; + OnPluginCrashed := nil; + OnProcessMessageReceived := nil; + OnRenderProcessTerminated := nil; + OnStatusMessage := nil; + OnTitleChange := nil; + end; +end; + +procedure TCatChromium.ClearRequestData; +begin + fLastStatusCode := 0; + fSentRequests := 0; + fHeaders.SentHead := emptystr; + fHeaders.RcvdHead := emptystr; + fHeaders.StatusCode := emptystr; +end; + +procedure TCatChromium.SendRequest(const req: TCatChromiumRequest; +const Load: Boolean = false); +var + r: ICefRequest; + Map: ICefStringMultiMap; + data: ICefPostData; +var + slp: TStringLoop; + rheader, rvalue: string; +var + reqown: TSpecialCEFReq; + urlreq: ICefUrlRequest; + function CreateField(const str: AnsiString): ICefPostDataElement; + begin + Result := TCefPostDataElementRef.New; + Result.SetToBytes(Length(str), PAnsiChar(str)); + end; + +begin + if (Load = true) and (IsFrameNil) then + exit; + fSentRequests := fSentRequests + 1; + r := TCefRequestRef.New; + r.url := req.url; + r.Method := req.Method; + if req.Method = emptystr then + r.Method := 'GET'; + if req.IgnoreCache then + r.Flags := r.Flags + [UR_FLAG_SKIP_CACHE]; + if req.UseCookies then + r.Flags := r.Flags + [UR_FLAG_ALLOW_COOKIES]; + if req.UseCachedCredentials then + r.Flags := r.Flags + [UR_FLAG_ALLOW_CACHED_CREDENTIALS]; + if req.PostData <> emptystr then + begin + // r.Flags := UR_FLAG_SKIP_CACHE; + data := TCefPostDataRef.New; + data.AddElement(CreateField(req.PostData)); + { postdata.AddElement(CreateField('data.id=27')); + postdata.AddElement(CreateField('&data.title=title')); + postdata.AddElement(CreateField('&data.body=body')); } + r.PostData := data; + end; + if req.Headers <> emptystr then + begin + Map := TCefStringMultiMapOwn.Create; + r.GetHeaderMap(Map); + slp := TStringLoop.Create; + slp.LoadFromString(req.Headers); + while slp.found do + begin + if MatchStrings(slp.current, '*:*') then + begin + rheader := before(slp.current, ': '); + rvalue := after(slp.current, ': '); + Map.Append(rheader, rvalue); + end; + end; + slp.free; + // map.Append('Authorization','Basic '+base64encode(u+':'+p)); + r.SetHeaderMap(Map); + end; + if Load then + fCrm.Browser.MainFrame.LoadRequest(r) + else + begin + reqown := TSpecialCEFReq.Create; + reqown.MsgHandle := self.fMsgHandle; + reqown.Details := req.Details; + urlreq := TCefUrlRequestRef.New(r, reqown) as ICefUrlRequest; + end; +end; + +procedure TCatChromium.LoadFromString(const s, url: string); +begin + ClearRequestData; + if GetURL = emptystr then + LoadBlank; // CEF3 LoadString Bug Workaround + if fCrm.Browser = nil then + exit; + if fCrm.Browser.GetMainFrame = nil then + exit; + fCrm.Browser.GetMainFrame.LoadString(s, url); + fCrm.Visible := true; +end; + +procedure TCatChromium.Load(const url: string); +begin + ClearRequestData; + // Better to use crm.Load() instead of: + // if crm.Browser.GetMainFrame<>nil then crm.Browser.GetMainFrame.LoadURL(url); + fCrm.Load(url); + if fNeedRecreate then + fCrm.ReCreateBrowser(url); + fCrm.Visible := true; +end; + +procedure TCatChromium.LoadBlank(const WaitLoad: Boolean = false); +begin + ClearRequestData; + fCrm.Load(cHOMEURL); + fCrm.Visible := true; + if WaitLoad then + exit; + while isLoading do + application.ProcessMessages; +end; + +function TCatChromium.isLoading: Boolean; +begin + Result := false; + if fCrm.Browser = nil then + exit; + Result := fCrm.Browser.isLoading; +end; + +procedure TCatChromium.Reload(const IgnoreCache: Boolean = false); +begin + ClearRequestData; + if isLoading then + Stop; + if fCrm.Browser = nil then + exit; + if IgnoreCache then + fCrm.Browser.reloadignorecache + else + fCrm.Browser.Reload; // standard reload +end; + +procedure TCatChromium.Stop(const waitstop:boolean=false); +begin + if fCrm.Browser <> nil then + fCrm.Browser.StopLoad; + if waitstop = false then + exit; + while isLoading do + begin + application.ProcessMessages; + catdelay(100); + end; +end; + +// With past CEF releases, this would avoid some AV cases when closing a tab +procedure TCatChromium.StopLoadBlank; +begin + if isLoading then + begin + Stop; + LoadBlank(true); + end; + application.ProcessMessages; +end; + +destructor TCatChromium.Destroy; +begin +{$IF CompilerVersion >= 23}System.{$IFEND}Classes.DeallocateHWnd(fMsgHandle); + fInterceptRequests := false; + ClearEvents; + // StopLoadBlank; + fCrm.free; + fURLLog.free; + fResourceList.free; + fCriticalSection.free; + inherited Destroy; +end; + +constructor TCatSourceVisitorOwn.Create; +begin + inherited Create; + fCriticalSection := TCriticalSection.Create; +end; + +destructor TCatSourceVisitorOwn.Destroy; +begin + fCriticalSection.free; + inherited; +end; + +procedure TCatSourceVisitorOwn.Visit(const str: ustring); +var + t: TCatChromium; +begin + fCriticalSection.Enter; + try + if self.Browser <> nil then + begin + t := TCatChromium(self.Browser); + self.Browser := nil; + t.SetSource(str); + t := nil; + end; + finally + fCriticalSection.Leave; + end; +end; + +initialization + +CefRenderProcessHandler := TCustomRenderProcessHandler.Create; +CefRemoteDebuggingPort := 8000; + +end. diff --git a/src/CatConsole.pas b/src/CatConsole.pas new file mode 100644 index 0000000..8462f5e --- /dev/null +++ b/src/CatConsole.pas @@ -0,0 +1,425 @@ +unit CatConsole; + +{ + Catarinka Console Component + Copyright (c) 2012-2014 Syhunt Informatica + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + Vcl.Forms, Vcl.Controls, System.SysUtils, System.Classes, Vcl.Graphics, + Vcl.Menus, Vcl.Clipbrd, Vcl.Dialogs, +{$ELSE} + Forms, Controls, SysUtils, Classes, Graphics, Menus, Clipbrd, Dialogs, +{$IFEND} + CatConsoleCore, CatStringLoop, CatPrefs; + +type + TCatConsoleOnScriptCommand = procedure(const Code: string) of object; + +type + TCatConsole = class(TCustomControl) + private + fConsole: TConsole; + fCustomCommand: boolean; + fCustomCommandState: Integer; + fCustomHandler: string; + fHelpParser: TStringLoop; + fOnScriptCommand: TCatConsoleOnScriptCommand; + fPopupMenu: TPopupMenu; + fProgDir: string; + fPromptText: string; + function GetLastCommand: string; + procedure PopupMenuitemClick(Sender: TObject); + procedure SetCustomHandler(s: string); + procedure ConsoleBoot(Sender: TCustomConsole; var ABootFinished: boolean); + procedure ConsoleCommandExecute(Sender: TCustomConsole; ACommand: String; + var ACommandFinished: boolean); + procedure ConsoleCommandKeyPress(Sender: TCustomConsole; var AKey: Char; + var ATerminateCommand: boolean); + procedure ConsoleGetPrompt(Sender: TCustomConsole; + var APrompt, ADefaultText: string; var ADefaultCaretPos: Integer); + protected + public + function PrintAvailableCommands(Sender: TCustomConsole): boolean; + procedure Boot; + procedure Clear; + procedure ConsoleOutput(Enabled: boolean); + procedure LoadSettings(prefs: TCatPreferences); + procedure WriteLn(ALine: string = ''); + procedure Write(ALine: string = ''); + procedure WriteVersion; + procedure ResetPrompt; + procedure ResetFull; + procedure SetCurrentLine(s: string); + procedure SetPrompt(s: string); + constructor Create(AOwner: TWinControl); + destructor Destroy; override; + property Console: TConsole read fConsole; + property CustomHandler: string read fCustomHandler write SetCustomHandler; + property LastCommand: string read GetLastCommand; + property PromptText: string read fPromptText write fPromptText; + published + property OnScriptCommand: TCatConsoleOnScriptCommand read fOnScriptCommand + write fOnScriptCommand; + end; + +const + cCommandsSubDir = 'Scripts\Commands\'; + +var + TabCommands, TabCommandsDesc: TStringList; + +procedure AddConsoleCommand(cmd, luacode, description: string); +procedure ReadDiskCommands; + +implementation + +uses CatStrings, CatHTTP, CatFiles, CatJSON; + +procedure AddConsoleCommand(cmd, luacode, description: string); +var + cmdname, cmdparams: string; +begin + cmdname := cmd; + if pos(' ', cmd) <> 0 then + begin + cmdname := before(cmd, ' '); + cmdparams := after(cmd, ' '); + if cmdparams <> emptystr then + cmdparams := ' ' + cmdparams; + end; + if TabCommands.Values[cmdname] = emptystr then + begin + TabCommandsDesc.Add('' + cmdname + '' + cmdparams + + '  ' + description + ''); + TabCommandsDesc.Sorted := true; + end; + TabCommands.Values[cmdname] := luacode; +end; + +procedure ReadDiskCommands; +var + slp: TStringLoop; + script: TStringList; + progdir, cmd, desc: string; +const + cLuaCommentPrefix = '--'; +begin + progdir := extractfilepath(paramstr(0)); + script := TStringList.Create; + slp := TStringLoop.Create; + GetFiles(progdir + cCommandsSubDir + '\*.lua', slp.List); + while slp.Found do + begin + script.Clear; + script.LoadFromFile(progdir + cCommandsSubDir + '\' + slp.Current); + if script.Count >= 2 then + begin + cmd := trim(script.Strings[0]); + desc := trim(script.Strings[1]); + if beginswith(cmd, cLuaCommentPrefix) and + beginswith(desc, cLuaCommentPrefix) then + begin + cmd := trim(after(cmd, cLuaCommentPrefix)); + desc := trim(after(desc, cLuaCommentPrefix)); + AddConsoleCommand(cmd, script.Text, desc); + end; + end; + end; + slp.free; + script.free; +end; + +procedure TCatConsole.LoadSettings(prefs: TCatPreferences); +const + SCO_CONSOLE_FONT_COLOR = 'sandcat.console.font.color'; + SCO_CONSOLE_BGCOLOR = 'sandcat.console.bgcolor'; +begin + fConsole.Font.Color := HtmlColorToColor + (prefs.getvalue(SCO_CONSOLE_FONT_COLOR)); + fConsole.Color := HtmlColorToColor(prefs.getvalue(SCO_CONSOLE_BGCOLOR)); +end; + +procedure TCatConsole.SetCustomHandler(s: string); +begin + if s = emptystr then + fCustomHandler := emptystr + else + fCustomHandler := s + ' '; +end; + +procedure TCatConsole.Boot; +begin + fConsole.Boot; +end; + +procedure TCatConsole.ConsoleCommandExecute(Sender: TCustomConsole; + ACommand: String; var ACommandFinished: boolean); +var + p: TCommandParser; + cmdscriptfile, params: string; + sl: TStringList; + procedure List; + begin + ReadDiskCommands; + fHelpParser.Load(TabCommandsDesc); + ACommandFinished := False; + fCustomCommand := true; + fCustomCommandState := 0; + Sender.Writeln('Available commands:'); + PrintAvailableCommands(Sender); + end; + +begin + p := TCommandParser.Create(fCustomHandler + ACommand); + params := TabCommands.Values[p.Command]; + if ACommand <> emptystr then + begin + if p.Command = 'list' then + List + else + begin + cmdscriptfile := fProgDir + '\' + cCommandsSubDir + p.Command + '.lua'; + if params <> emptystr then + begin + if assigned(OnScriptCommand) then + OnScriptCommand(params); + ACommandFinished := False; + end + else if fileexists(cmdscriptfile) then + begin + sl := TStringList.Create; + sl.LoadFromFile(cmdscriptfile); + if assigned(OnScriptCommand) then + OnScriptCommand(sl.Text); + ACommandFinished := False; + sl.free; + end + else + Sender.Writeln('"' + p.Command + '" command not recognized.'); + end; + end; + p.free; +end; + +procedure TCatConsole.ConsoleCommandKeyPress(Sender: TCustomConsole; + var AKey: Char; var ATerminateCommand: boolean); +begin + if (fCustomCommand) then + Begin + if fCustomCommandState = 0 then + begin // help command + AKey := #0; + if PrintAvailableCommands(Sender) = False then + begin + fCustomCommand := False; + ATerminateCommand := true; + end; + end; + end; +end; + +function TCatConsole.PrintAvailableCommands(Sender: TCustomConsole): boolean; +var + c: Integer; +const + max = 20; + function RemoveHTML(s: string): string; + begin + s := replacestr(s, '  ', ' - '); + s := striphtml(s); + result := s; + end; + +begin + result := False; + c := 0; + while (fHelpParser.Found) do + begin + Inc(c); + Sender.Writeln(' ' + RemoveHTML(fHelpParser.Current)); + result := true; + if c = max then + Sender.Writeln('Press any key to continue. . .'); + if c = max then + exit; + end; + if c < max then + result := False; +end; + +procedure TCatConsole.ConsoleGetPrompt(Sender: TCustomConsole; + var APrompt, ADefaultText: string; var ADefaultCaretPos: Integer); +begin + APrompt := fPromptText + '>'; +end; + +procedure TCatConsole.SetCurrentLine(s: string); +begin + fConsole.CurrLine.Text := s; + fConsole.CaretX := Length(s) + 1; + fConsole.Invalidate; +end; + +procedure TCatConsole.SetPrompt(s: string); +begin + fPromptText := s; + if s + '>' <> fConsole.LastPrompt then + ResetPrompt; +end; + +procedure TCatConsole.ResetPrompt; +begin + fConsole.BeginExternalOutput; + fConsole.EndExternalOutput; +end; + +procedure TCatConsole.ResetFull; +begin + fCustomHandler := emptystr; + SetPrompt(emptystr); + Clear; + WriteVersion; +end; + +procedure TCatConsole.ConsoleOutput(Enabled: boolean); +begin + if Enabled = False then + begin + if fConsole.prompt = False then + fConsole.EndExternalOutput; + end; +end; + +function TCatConsole.GetLastCommand: string; +begin + result := fCustomHandler + fConsole.LastCommand; +end; + +procedure TCatConsole.Clear; +begin + fConsole.BeginExternalOutput; + fConsole.Clear; + fConsole.EndExternalOutput; +end; + +procedure TCatConsole.PopupMenuitemClick(Sender: TObject); +var + s: string; +begin + case tmenuitem(Sender).Tag of + 1: + Clear; + 2: + fConsole.PasteFromClipboard; + end; +end; + +procedure TCatConsole.Write(ALine: string = ''); +begin + ALine := replacestr(ALine, #10, emptystr); + if fConsole.prompt = true then + fConsole.BeginExternalOutput; + fConsole.Write(ALine); + fConsole.Repaint; + application.ProcessMessages; +end; + +procedure TCatConsole.Writeln(ALine: string = ''); +var + slp: TStringLoop; +begin + if fConsole.Lines.Count >= 1000 then + fConsole.Clear; + if fConsole.prompt = true then + fConsole.BeginExternalOutput; + if pos(crlf, ALine) <> 0 then + begin + slp := TStringLoop.Create; + slp.LoadFromString(ALine); + while slp.Found do + fConsole.Writeln(slp.Current); + slp.free; + end + else + fConsole.Writeln(ALine); + application.ProcessMessages; +end; + +procedure TCatConsole.WriteVersion; +begin + if fConsole.prompt = true then + fConsole.BeginExternalOutput; + fConsole.Writeln('Sandcat' + '/' + GetFileVersion(paramstr(0))); + fConsole.Writeln('Type help for a list of commands.'); + fConsole.Writeln; +end; + +procedure TCatConsole.ConsoleBoot(Sender: TCustomConsole; + var ABootFinished: boolean); +begin + WriteVersion; +end; + +constructor TCatConsole.Create(AOwner: TWinControl); +var + mi: tmenuitem; +begin + inherited Create(AOwner); + ControlStyle := ControlStyle + [csAcceptsControls]; + fProgDir := extractfilepath(paramstr(0)); + fHelpParser := TStringLoop.Create; + fConsole := TConsole.Create(self); + fConsole.Parent := self; + fConsole.Align := alClient; + fConsole.Font.Name := 'Fixedsys'; + fConsole.Color := $002D2D2D; + fConsole.Font.Color := clWhite; + fConsole.Font.Style := []; + fConsole.OnBoot := ConsoleBoot; + fConsole.OnCommandExecute := ConsoleCommandExecute; + fConsole.OnCommandKeyPress := ConsoleCommandKeyPress; + fConsole.OnGetPrompt := ConsoleGetPrompt; + fPopupMenu := TPopupMenu.Create(self); + fConsole.PopupMenu := fPopupMenu; + mi := tmenuitem.Create(self); + fPopupMenu.Items.Add(mi); + mi.Caption := '&Clear'; + mi.Tag := 1; + mi.OnClick := PopupMenuitemClick; + mi := tmenuitem.Create(self); + fPopupMenu.Items.Add(mi); + mi.Caption := '-'; + mi.OnClick := PopupMenuitemClick; + mi := tmenuitem.Create(self); + fPopupMenu.Items.Add(mi); + mi.Caption := '&Paste'; + mi.Tag := 2; + mi.OnClick := PopupMenuitemClick; +end; + +destructor TCatConsole.Destroy; +begin + fPopupMenu.free; + fHelpParser.free; + fConsole.free; + inherited Destroy; +end; + +initialization + +TabCommands := TStringList.Create; +TabCommandsDesc := TStringList.Create; +AddConsoleCommand('list', emptystr, 'Displays this list'); + +finalization + +TabCommands.free; +TabCommandsDesc.free; + +end. diff --git a/src/CatConsoleCore.pas b/src/CatConsoleCore.pas new file mode 100644 index 0000000..3878176 --- /dev/null +++ b/src/CatConsoleCore.pas @@ -0,0 +1,1349 @@ +unit CatConsoleCore; + +{ + Catarinka Console Core + Copyright (c) 2012-2014, Felipe Daragon + Based on TConsole. Copyright (c) 2002-2003, Michael Eldsörfer + License: MPL, dual (see below) + + ChangeLog: + - Added two new properties (LastCommand and LastPrompt). + - The PasteFromClipboard procedure was implemented. + - Fixed some characters not working, like ', #, $, % and ( + + TODO, FIXME: not working properly with the original TConsole demo + application. +} + +(* + Class: TConsole + + Version: 1.0 + Date: 09.07.2003 + Author: Michael Elsdörfer + Copyright: (c)2002/2003 by Michael Eldsörfer + eMail: michael@elsdoerfer.net + Internet: http://www.elsdoerfer.net + +The contents of this file are subject to the Mozilla Public License +Version 1.1 (the "License"); you may not use this file except in compliance +with the License. You may obtain a copy of the License at +http://www.mozilla.org/MPL/ + +Software distributed under the License is distributed on an "AS IS" basis, +WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for +the specific language governing rights and limitations under the License. + +Alternatively, the contents of this file may be used under the terms of the +GNU General Public License Version 2 or later (the "GPL"), in which case +the provisions of the GPL are applicable instead of those above. +If you wish to allow use of your version of this file only under the terms +of the GPL and not to allow others to use your version of this file +under the MPL, indicate your decision by deleting the provisions above and +replace them with the notice and other provisions required by the GPL. +If you do not delete the provisions above, a recipient may use your version +of this file under either the MPL or the GPL. +*) + +interface + +uses Windows, Classes, StdCtrls, Controls, Graphics, Messages, Math, ClipBrd; + +const + // Constants defining the default look of the console + CONSOLE_DEFAULT_BACKGROUND = clBlack; + CONSOLE_DEFAULT_FOREGROUND = clWhite; + CONSOLE_DEFAULT_FONTNAME = 'Courier New'; + CONSOLE_DEFAULT_FONTSIZE = 10; + CONSOLE_DEFAULT_FONTSTYLE = [fsBold]; + CONSOLE_DEFAULT_PROMPT = '>'; + +type + // Forward + TCustomConsole = class; + + // Events + TBootEvent = procedure(Sender: TCustomConsole; var ABootFinished: boolean) of object; + TShutDownEvent = procedure(Sender: TCustomConsole) of object; + TCommandExecuteEvent = procedure(Sender: TCustomConsole; ACommand: string; + var ACommandFinished: boolean) of object; + TGetPromptEvent = procedure(Sender: TCustomConsole; var APrompt: string; + var ADefaultText: string; var ADefaultCaretPos: Integer) of object; + TCommandKeyPressEvent = procedure(Sender: TCustomConsole; var AKey: Char; + var ATerminateCommand: boolean) of object; + TPromptKeyPressEvent = procedure(Sender: TCustomConsole; var AKey: Char) of object; + + + // TConsoleCaretType + TConsoleCaretType = (ctVerticalLine, ctHorizontalLine, ctHalfBlock, ctBlock); + + // TCustomConsoleLine: Represents a single line + PConsoleLine = ^TCustomConsoleLine; + TCustomConsoleLine = record + IsPromptLine: boolean; // True, if the line is a prompt line + Prompt: string; // Contains the prompt string of the line, if IsPromptLine is True + Text: string; // If IsPromptLine is True, Text contains the typed command string, else it containes the whole line string + end; + + // TConsoleLines + TConsoleLines = class(TObject) + private + fOwner: TCustomConsole; + fLines: TList; + function GetLines(Index: Integer): PConsoleLine; + procedure SetLines(Index: Integer; const Value: PConsoleLine); + function GetCount: Integer; + function GetCurrLine: PConsoleLine; + procedure SetCurrLine(const Value: PConsoleLine); + function GetWrappedLines(Index: Integer): string; + function GetWrappedLineCount: Integer; + function GetWrapWidth: Integer; + protected + function AddLine(Force: boolean = False): PConsoleLine; + procedure Writeln(ALine: string); + procedure Write(AText: string); + public + constructor Create(AOwner: TCustomConsole); + destructor Destroy; override; + + procedure Clear; + function IsEmptyLine(ALine: PConsoleLine): boolean; + function GetFullLineText(ALine: Integer): string; + function LogicalToWrappedLineIndex(ALine: Integer): Integer; + + property CurrLine: PConsoleLine read GetCurrLine write SetCurrLine; + property Lines[Index: Integer]: PConsoleLine read GetLines write SetLines; default; + property Count: Integer read GetCount; + property WrappedLines[Index: Integer]: string read GetWrappedLines; + property WrappedLineCount: Integer read GetWrappedLineCount; + property WrapWidth: Integer read GetWrapWidth; + end; + + // TCustomConsole + TCustomConsole = class(TCustomControl) + private + fPrompt: boolean; + fCaretX: Integer; + fLines: TConsoleLines; + fCaretOffset: TPoint; + fPaintLock: Integer; + fScrollBars: TScrollStyle; + fMouseWheelAccumulator: integer; + fInsertMode: boolean; + fOverwriteCaret: TConsoleCaretType; + fInsertCaret: TConsoleCaretType; + FActive: boolean; + FOnBoot: TBootEvent; + FOnCommandExecute: TCommandExecuteEvent; + FOnShutDown: TShutDownEvent; + FOnGetPrompt: TGetPromptEvent; + FBorderSize: Integer; + FExtraLineSpacing: Integer; + FAutoUseInsertMode: boolean; + FOnCommandKeyPress: TCommandKeyPressEvent; + FMinLeftCaret: Integer; + FOnPromptKeyPress: TPromptKeyPressEvent; + FLastCommand:string; + FLastPrompt:string; + function GetCanPaste: Boolean; + function GetFont: TFont; + procedure SetCaretX(Value: Integer); + procedure SetFont(const Value: TFont); + procedure SetScrollBars(const Value: TScrollStyle); + procedure SizeOrFontChanged(bFont: boolean); + procedure UpdateScrollBars; + function CaretXYPix: TPoint; + function GetAcceptInput: boolean; + function GetTopLine: Integer; + function GetTextHeight: Integer; + function RowColumnToPixels(rowcol: TPoint): TPoint; + function LogicalToPhysicalPos(p: TPoint): TPoint; + procedure SetInsertCaret(const Value: TConsoleCaretType); + procedure SetInsertMode(const Value: boolean); + procedure SetOverwriteCaret(const Value: TConsoleCaretType); + function GetCharWidth: Integer; + function GetLinesInWindow: Integer; + procedure SetActive(const Value: boolean); + function GetLines: TConsoleLines; + procedure SetLines(const Value: TConsoleLines); + procedure SetOnBoot(const Value: TBootEvent); + procedure SetOnCommandExecute(const Value: TCommandExecuteEvent); + procedure SetOnShutDown(const Value: TShutDownEvent); + procedure SetOnGetPrompt(const Value: TGetPromptEvent); + function GetPrompt: boolean; + procedure SetPrompt(const Value: boolean); + function GetCurrLine: PConsoleLine; + procedure SetCurrLine(const Value: PConsoleLine); + procedure SetBorderSize(const Value: Integer); + procedure SetExtraLineSpacing(const Value: Integer); + procedure SetAutoUseInsertMode(const Value: boolean); + procedure SetOnCommandKeyPress(const Value: TCommandKeyPressEvent); + procedure SetMinLeftCaret(const Value: Integer); + procedure SetOnPromptKeyPress(const Value: TPromptKeyPressEvent); + protected + // Status Flags + sfLinesChanging: boolean; + + // Windows Events + procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND; + procedure WMGetDlgCode(var Msg: TWMGetDlgCode); message WM_GETDLGCODE; + procedure WMHScroll(var Msg: TWMScroll); message WM_HSCROLL; + procedure WMPaste(var Message: TMessage); message WM_PASTE; + procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS; + procedure WMMouseWheel(var Msg: TMessage); message WM_MOUSEWHEEL; + procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS; + procedure WMSize(var Msg: TWMSize); message WM_SIZE; + procedure WMVScroll(var Msg: TWMScroll); message WM_VSCROLL; + + // More methods + procedure InvalidateRect(const aRect: TRect; aErase: boolean); + procedure DecPaintLock; + procedure IncPaintLock; + procedure InitializeCaret; + procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override; + procedure KeyDown(var Key: Word; Shift: TShiftState); override; + procedure KeyPress(var Key: Char); override; + procedure Loaded; override; + procedure Paint; override; + procedure PaintTextLines(AClip: TRect; FirstLine, CurrLine: integer); virtual; + procedure InvalidateLine(Line: integer); + procedure InvalidateLines(FirstLine, LastLine: integer); + procedure HideCaret; + procedure ShowCaret; + procedure DoOnPrompt(var APrompt: string; var DefaultText: string; + var DefaultCaretPos: Integer); + procedure KeyCommandHandler(AKey: Char); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + // Boot methods + procedure Boot; + procedure Shutdown; + + // Paintlock methods + procedure BeginUpdate; + procedure EndUpdate; + + // Various methods + procedure UpdateCaret; + procedure WndProc(var Msg: TMessage); override; + procedure PasteFromClipboard; + + // Output methods + procedure BeginExternalOutput; + procedure EndExternalOutput; + procedure Writeln(ALine: string = ''); + procedure Write(AText: string; AUpdateMinLeftCaret: boolean = False); + procedure Clear; + + // Active: To work with TCustomConsole, Active must be set to True + property Active: boolean read FActive write SetActive; + // AcceptInput: If False, key events are not regognized + property AcceptInput: boolean read GetAcceptInput; + // Automatically changes to Insert mode when a new prompt is activated + property AutoUseInsertMode: boolean read FAutoUseInsertMode write SetAutoUseInsertMode; + // CharWidth: Returns the width of a single char + property CharWidth: Integer read GetCharWidth; + // CaretX: CaretX stores the caret position in the current line + property CaretX: Integer read fCaretX write SetCaretX; + // Font: Wrapped to Canvas.Font + property Font: TFont read GetFont write SetFont; + // Lines: Provides access to the lines + property LastCommand: string read fLastCommand write FlastCommand; + // LastCommand: Stores the last entered command + property LastPrompt: string read fLastPrompt write FlastPrompt; + // LastPrompt: Stores the last prompt + property Lines: TConsoleLines read GetLines write SetLines; + // InsertMode: Switch between Insert and Overwrite mode + property InsertMode: boolean read FInsertMode write SetInsertMode; + // Insert Caret + Overwrite Caret + property InsertCaret: TConsoleCaretType read FInsertCaret write SetInsertCaret; + property OverwriteCaret: TConsoleCaretType read FOverwriteCaret write SetOverwriteCaret; + // PaintLock: PaintLock Counter; Can be modified by BeginUpdate and EndUpdate + property PaintLock: Integer read fPaintLock; + // CurrLine: Easy access to the current line + property CurrLine: PConsoleLine read GetCurrLine write SetCurrLine; + // TextHeight: Returns the high of a single text line + property TextHeight: Integer read GetTextHeight; + // TopLine: Stores the index of the first line visible + property TopLine: Integer read GetTopLine; + // LinesInWindow: Returns the number of visible lines + property LinesInWindow: Integer read GetLinesInWindow; + // Prompt: Returns True, if currently in prompting mode + property Prompt: boolean read GetPrompt write SetPrompt; + // BorderSize: Specifies the border size in pixels + property BorderSize: Integer read FBorderSize write SetBorderSize; + // ExtraLineSpacing: Makes it possible to add change the space between the single lines + property ExtraLineSpacing: Integer read FExtraLineSpacing write SetExtraLineSpacing; + // MinLeftCaret: Only available in command mode + property MinLeftCaret: Integer read FMinLeftCaret write SetMinLeftCaret; + // Events + property OnBoot: TBootEvent read FOnBoot write SetOnBoot; + property OnShutDown: TShutDownEvent read FOnShutDown write SetOnShutDown; + property OnCommandExecute: TCommandExecuteEvent read FOnCommandExecute write SetOnCommandExecute; + property OnGetPrompt: TGetPromptEvent read FOnGetPrompt write SetOnGetPrompt; + property OnCommandKeyPress: TCommandKeyPressEvent read FOnCommandKeyPress write SetOnCommandKeyPress; + property OnPromptKeyPress: TPromptKeyPressEvent read FOnPromptKeyPress write SetOnPromptKeyPress; + end; + + TConsole = class(TCustomConsole) + published + // TCustomConsole properties and events + property AutoUseInsertMode; + property InsertMode; + property InsertCaret; + property OverwriteCaret; + property BorderSize; + property ExtraLineSpacing; + property OnBoot; + property OnShutDown; + property OnCommandExecute; + property OnGetPrompt; + property OnCommandKeyPress; + property OnPromptKeyPress; + // inherited properties + property Align; + property Anchors; + property Constraints; + property Color; + property Ctl3D; + property ParentCtl3D; + property Enabled; + property Font; + property Height; + property Name; + property ParentColor; + property ParentFont; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property TabOrder; + property TabStop default True; + property Visible; + property Width; + // inherited events + property OnClick; + property OnDblClick; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnStartDock; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnKeyDown; + property OnKeyPress; + property OnKeyUp; + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnStartDrag; + end; + + TCommandParser = class + private + FParamList: TStringList; + FCommand: string; + function GetParameters(Index: Integer): string; + function GetParamCount: Integer; + public + constructor Create(ACommand: string); overload; + constructor Create; overload; + destructor Destroy; override; + + procedure ParseCommand(ACommand: string); + + property Command: string read FCommand; + property Parameters[Index: Integer]: string read GetParameters; + property ParamCount: Integer read GetParamCount; + end; + +procedure Register; + +implementation + +procedure Register; +Begin + RegisterComponents('elsdoerfer.net', [TConsole]); +end; + +{ TCustomConsole } + +// IncPaintLock: prevents TCustomConsole from painting itself until EndUpdate is called +procedure TCustomConsole.BeginUpdate; +begin + IncPaintLock; +end; + +// CaretXYPix: Returns the caret position in pixels +function TCustomConsole.CaretXYPix: TPoint; +var p: TPoint; +begin + // If CurrLine is nil, then exit + if CurrLine = nil then exit; + + // Y Caret position is always the last (logical) line. However, this line may + // be wrapped. In this case it's possible that the carets phyiscal position is + // above the last line. + p.Y := fLines.WrappedLineCount - + ( + ((Length(CurrLine.Prompt + CurrLine.Text)) div (fLines.WrapWidth)) - + ((fCaretX + Length(CurrLine.Prompt) - 1) div (fLines.WrapWidth)) + ); + + // X Caret position is definied by fCaretX. Again, the line may be wrapped and + // the caret phyiscal position differs from it's logical one. + p.X := (fCaretX + Length(CurrLine.Prompt)) mod (fLines.WrapWidth); + if p.X = 0 then p.X := fLines.WrapWidth; + + // Convert value to pixel and return + Result := RowColumnToPixels(p); +end; + +// Clear: Delete all lines +procedure TCustomConsole.Clear; +begin + fLines.Clear; + Invalidate; +end; + +// Create: Constructor +constructor TCustomConsole.Create(AOwner: TComponent); +begin + // Inherited + inherited; + ControlStyle := ControlStyle + [csOpaque]; + + // Defaults settings + fActive := False; + fPrompt := False; + fInsertMode := True; + fBorderSize := 3; + fExtraLineSpacing := 0; + FAutoUseInsertMode := True; + + // Font + Font.Name := CONSOLE_DEFAULT_FONTNAME; + Font.Style := CONSOLE_DEFAULT_FONTSTYLE; + Font.Size := CONSOLE_DEFAULT_FONTSIZE; + Font.Color := CONSOLE_DEFAULT_FOREGROUND; + + // Background Color + Color := CONSOLE_DEFAULT_BACKGROUND; + + // Default carets + InsertCaret := ctHorizontalLine; + OverwriteCaret := ctHalfBlock; + + // Create Lines Object + fLines := TConsoleLines.Create(Self); +end; + +// DecPaintLock: Decrements the paint lock counter +procedure TCustomConsole.DecPaintLock; +begin + Dec(fPaintLock); + if fPaintLock = 0 then Invalidate; +end; + +// Destroy: Destructor +destructor TCustomConsole.Destroy; +begin + // Free Lines Object + fLines.Free; + + // Inherited + inherited; +end; + +// LogicalToPhysicalPos: Takes a logical caret position (based on line index 0) +// and makes a physical caret position out of it (based on first visible line) +function TCustomConsole.LogicalToPhysicalPos(p: TPoint): TPoint; +var s: string; + i, L: integer; + x: integer; +begin + if p.Y - 1 < fLines.Count then begin + s := fLines.WrappedLines[p.Y - 1]; + l := Length(s); + x := 0; + for i := 1 to p.x - 1 do begin + inc(x); + end; + p.x := x + 1; + end; + Result := p; +end; + +// RowColumnToPixels: Calculates the pixels for a certain caret position +function TCustomConsole.RowColumnToPixels(RowCol: TPoint): TPoint; +var P: TPoint; + i: integer; + lText: string; +begin + P := LogicalToPhysicalPos(RowCol); + Result.X := BorderSize; + if ((RowCol.Y - 1) < fLines.WrappedLineCount) then + for i := 1 to (P.X - 1) do Begin + lText := fLines.WrappedLines[RowCol.Y - 1]; + if lText <> '' then Result.X := Result.X + Canvas.TextWidth(lText[1]); + end; + Result.Y := (RowCol.Y - TopLine) * TextHeight; +end; + +// EndUpdate: See DecPaintLock +procedure TCustomConsole.EndUpdate; +begin + DecPaintLock; +end; + +// GetCanPaste: Returns True if text from the clipboard can be pasted +function TCustomConsole.GetCanPaste: Boolean; +begin + Result := not AcceptInput and (Clipboard.HasFormat(CF_TEXT)); +end; + +// GetFont +function TCustomConsole.GetFont: TFont; +begin + Result := Canvas.Font +end; + +// GetAcceptInput: Only True, if fActive is also True +function TCustomConsole.GetAcceptInput: boolean; +begin + Result := Active; +end; + +// GetTextHeight: Calculates the height of a line +function TCustomConsole.GetTextHeight: Integer; +begin + Result := Canvas.TextHeight('Ay%ü') + ExtraLineSpacing; +end; + +// GetTopLine: Returns the physical line displayed on the very top of the control +function TCustomConsole.GetTopLine: Integer; +begin + Result := Max(fLines.GetWrappedLineCount - LinesInWindow + 2, 1); +end; + +// HideCaret +procedure TCustomConsole.HideCaret; +begin + Windows.HideCaret(Handle); +end; + +// IncPaintLock: Increments the Paint Lock Counter +procedure TCustomConsole.IncPaintLock; +begin + Inc(fPaintLock); +end; + +// InitializeCaret: Creates a caret object +procedure TCustomConsole.InitializeCaret; +var ct: TConsoleCaretType; + cw, ch: integer; +begin + // Caret type depends on keyboard mode + if InsertMode then ct := fInsertCaret + else ct := fOverwriteCaret; + + // Set values depending on caret type + case ct of + ctHorizontalLine: + begin + cw := CharWidth; + ch := 2; + fCaretOffset := Point(0, TextHeight - ExtraLineSpacing - 2); + end; + ctHalfBlock: + begin + cw := CharWidth; + ch := (TextHeight - 2) div 2; + fCaretOffset := Point(0, ch); + end; + ctBlock: + begin + cw := CharWidth; + ch := TextHeight - 2; + FCaretOffset := Point(0, 0); + end; + else begin // Vertical Line + cw := 2; + ch := TextHeight - 2; + FCaretOffset := Point(0, 0); + end; + end; + + // Create Caret + CreateCaret(Handle, 0, cw, ch); + + // Show it + UpdateCaret; +end; + +// InvalidateLine: Calculates the rect of a certain line and uses InvalidateRect +// to repaint it (reduces flickering) +procedure TCustomConsole.InvalidateLine(Line: integer); +var rcInval: TRect; +begin + if Visible and (Line >= TopLine) and (Line <= TopLine + LinesInWindow) and + (Line <= Lines.Count) and HandleAllocated then + begin + rcInval := Rect(0, TextHeight * (Line - TopLine), ClientWidth, 0); + rcInval.Bottom := rcInval.Top + TextHeight; + InvalidateRect(rcInval, False); + end; +end; + +// InvalidateLines: Calculates the rect of a certain line range und uses +// InvalidateRect to repaint it +procedure TCustomConsole.InvalidateLines(FirstLine, LastLine: integer); +var rcInval: TRect; +begin + if Visible and HandleAllocated then + if (FirstLine = -1) and (LastLine = -1) then begin + rcInval := ClientRect; + InvalidateRect(rcInval, false); + end else begin + FirstLine := Max(FirstLine, TopLine); + LastLine := Min(LastLine, TopLine + LinesInWindow); + + if (LastLine >= FirstLine) then begin + rcInval := Rect(0, TextHeight * (FirstLine - TopLine), + ClientWidth, TextHeight * (LastLine - TopLine + 1)); + InvalidateRect(rcInval, false); + end; + end; +end; + +// InvalidateRect +procedure TCustomConsole.InvalidateRect(const aRect: TRect; aErase: boolean); +begin + Windows.InvalidateRect(Handle, @aRect, aErase); +end; + +// KeyDown +procedure TCustomConsole.KeyDown(var Key: Word; Shift: TShiftState); +begin + inherited; + case key of // FD 18.11.2012, keys moved from KeyCommandHandler + VK_LEFT: CaretX := CaretX - 1; + VK_RIGHT: CaretX := CaretX + 1; + VK_END: CaretX := length(CurrLine.Text) + 1; + VK_HOME: CaretX := 1; + + VK_INSERT: + Begin + InsertMode := not InsertMode; + InitializeCaret; + end; + + VK_UP: + begin + CurrLine.Text := FLastCommand; + CaretX := Length(FLastCommand) + 1; Invalidate; + end; + VK_DOWN: + Begin + // Should Be Handled By An Event TODO : todo + end; + end; +end; + +// KeyPress +procedure TCustomConsole.KeyPress(var Key: Char); +begin + inherited; + KeyCommandHandler(Key); +end; + +// Loaded +procedure TCustomConsole.Loaded; +begin + inherited; + UpdateScrollBars; + Invalidate; +end; + +// Paint +procedure TCustomConsole.Paint; +var rcClip, rcDraw: TRect; + nL1, nL2: Integer; +begin + // Only paint if Paint Lock Counter is 0 + if fPaintLock <> 0 then exit; + + // Get the invalidated rect + rcClip := Canvas.ClipRect; + + // Calculate Line Range + nL1 := Max(TopLine + ((rcClip.Top) div TextHeight), TopLine) - 1; + nL2 := Min(TopLine + ((rcClip.Bottom + TextHeight - 1) div TextHeight), fLines.WrappedLineCount) - 1; + + // Now paint everything while the caret is hidden + HideCaret; + try + rcDraw := rcClip; + rcDraw.Left := 0; + rcDraw.Right := ClientWidth; + PaintTextLines(rcDraw, nL1, nL2); + finally + UpdateCaret; + end; +end; + +// PaintTextLines +procedure TCustomConsole.PaintTextLines(AClip: TRect; FirstLine, CurrLine: integer); +var rcLine, rcToken: TRect; + + function ColumnToXValue(Col: integer): integer; + begin + Result := Pred(Col) * CharWidth; + end; + + procedure PaintLines; + var nLine: integer; + sLine: string; + begin + // Initialize rcLine for drawing. Note that Top and Bottom are updated + // inside the loop. Get only the starting point for this. + rcLine := AClip; + rcLine.Bottom := (FirstLine - TopLine + 1) * TextHeight; + + // Now loop through all the lines + for nLine := FirstLine to CurrLine do begin + // Assign line + sLine := Lines.WrappedLines[nLine]; + + // Update the rcLine rect to this line + rcLine.Top := rcLine.Bottom; + Inc(rcLine.Bottom, TextHeight); + + // We will need this later to fill the non-text area + rcToken := rcLine; + + // Paint + if not Canvas.HandleAllocated then exit; + Brush.Color := Color; + Brush.Style := bsSolid; + Canvas.FillRect(Rect(0, rcLine.Top, BorderSize, rcLine.Bottom)); + Canvas.TextOut(BorderSize, rcLine.Top, sLine); + Canvas.FillRect(Rect(BorderSize + Canvas.TextWidth(sLine), rcLine.Top, rcLine.Right, rcLine.Bottom)); + end; + end; + +begin + // Without this painting does not work until the first time FillRect is called - no clue where the problem is + Canvas.Brush.Color := Color; + Canvas.FillRect(Rect(0, 0, ClientWidth, 0)); + + try + PaintLines; + finally + end; + + // If there is anything visible below the last line, then fill this as well + rcToken := AClip; + rcToken.Top := (CurrLine + 1 - TopLine + 1) * TextHeight; + if (rcToken.Top < rcToken.Bottom) then + begin + Canvas.Brush.Color := Color; + Canvas.FillRect(rcToken); + end; +end; + +// SetCaretX +procedure TCustomConsole.SetCaretX(Value: Integer); +begin + if (Value < 1) then Value := 1 + else if (Value < MinLeftCaret) and (not Prompt) then Value := FMinLeftCaret + else if (CurrLine <> nil) and (Value > length(CurrLine.Text) + 1) then + Value := length(CurrLine.Text) + 1; + + if Value <> fCaretX then Begin + fCaretX := Value; + UpdateCaret; + end; +end; + +// SetFont +procedure TCustomConsole.SetFont(const Value: TFont); +begin + Canvas.Font.Assign(Value); +end; + +procedure TCustomConsole.SetScrollBars(const Value: TScrollStyle); +begin + { TODO : add scrollbar support } +end; + +procedure TCustomConsole.ShowCaret; +begin + Windows.ShowCaret(Handle); +end; + +procedure TCustomConsole.SizeOrFontChanged(bFont: boolean); +begin + Invalidate; +end; + +procedure TCustomConsole.UpdateCaret; +var CX, CY: Integer; + iClientRect: TRect; +begin + CX := CaretXYPix.X + FCaretOffset.X; + CY := CaretXYPix.Y + FCaretOffset.Y + 1; + iClientRect := GetClientRect; + if (CX >= iClientRect.Left) and (CX < iClientRect.Right) and + (CY >= iClientRect.Top) and (CY < iClientRect.Bottom) and + (AcceptInput) and (fActive) then + begin + SetCaretPos(CX, CY); + ShowCaret; + end else begin + HideCaret; + SetCaretPos(CX, CY); + end; +end; + +procedure TCustomConsole.UpdateScrollBars; +begin + { TODO : add scrollbar support } +end; + +procedure TCustomConsole.WMEraseBkgnd(var Msg: TMessage); +begin + Msg.Result := 1; +end; + +procedure TCustomConsole.WMGetDlgCode(var Msg: TWMGetDlgCode); +begin + inherited; + Msg.Result := DLGC_WANTARROWS or DLGC_WANTCHARS or + DLGC_WANTTAB or DLGC_WANTALLKEYS; +end; + +procedure TCustomConsole.WMHScroll(var Msg: TWMScroll); +begin + { TODO : add scrolling support } +end; + +procedure TCustomConsole.WMKillFocus(var Msg: TWMKillFocus); +begin + HideCaret; + Windows.DestroyCaret; +end; + +procedure TCustomConsole.WMMouseWheel(var Msg: TMessage); +begin + { TODO : add scrolling support } +end; + +procedure TCustomConsole.WMPaste(var Message: TMessage); +begin + if AcceptInput then PasteFromClipboard; + Message.Result := ord(True); +end; + +procedure TCustomConsole.WMSetFocus(var Msg: TWMSetFocus); +begin + InitializeCaret; +end; + +procedure TCustomConsole.WMSize(var Msg: TWMSize); +begin + SizeOrFontChanged(False); +end; + +procedure TCustomConsole.WMVScroll(var Msg: TWMScroll); +begin + { TODO : add scrolling support } +end; + +procedure TCustomConsole.WndProc(var Msg: TMessage); +begin + inherited; +end; + +procedure TCustomConsole.SetInsertCaret(const Value: TConsoleCaretType); +begin + FInsertCaret := Value; +end; + +procedure TCustomConsole.SetInsertMode(const Value: boolean); +begin + if fInsertMode <> Value then Begin + fInsertMode := Value; + InitializeCaret; + end; +end; + +procedure TCustomConsole.SetOverwriteCaret(const Value: TConsoleCaretType); +begin + FOverwriteCaret := Value; +end; + +function TCustomConsole.GetCharWidth: Integer; +begin + Result := Canvas.TextWidth('a'); +end; + +function TCustomConsole.GetLinesInWindow: Integer; +begin + Result := ClientHeight div TextHeight; +end; + +// Set Active: Use this to boot or to shutdown the console +procedure TCustomConsole.SetActive(const Value: boolean); +var BootFinished: boolean; +begin + if (Value <> fActive) then Begin + case Value of + True: + begin + // Clear current lines + Clear; + + // Add a first, empty line + fLines.AddLine; + + // Call onBoot Event + BootFinished := True; + if Assigned(FOnBoot) then FOnBoot(Self, BootFinished); + if BootFinished then Prompt := True; + + InitializeCaret; + end; + + False: + begin + if Assigned(FOnShutDown) then FOnShutDown(Self); + end; + end; + fActive := Value; + end; +end; + +procedure TCustomConsole.PasteFromClipboard; +begin + fLines.CurrLine.Text := fLines.CurrLine.Text + Clipbrd.Clipboard.AsText; + CaretX := Length(fLines.CurrLine.Text) + 1; + Invalidate; +end; + +function TCustomConsole.GetLines: TConsoleLines; +begin + Result := fLines; +end; + +procedure TCustomConsole.SetLines(const Value: TConsoleLines); +begin + fLines := Value; +end; + +procedure TCustomConsole.Writeln(ALine: string); +begin + if not Prompt then Begin + fLines.Writeln(ALine); + fCaretX := length(ALine) + 1; + Invalidate; + end; +end; + +procedure TCustomConsole.Boot; +begin + Active := True; +end; + +procedure TCustomConsole.Shutdown; +begin + Active := False; +end; + +procedure TCustomConsole.SetOnBoot(const Value: TBootEvent); +begin + FOnBoot := Value; +end; + +procedure TCustomConsole.SetOnCommandExecute(const Value: TCommandExecuteEvent); +begin + FOnCommandExecute := Value; +end; + +procedure TCustomConsole.SetOnShutDown(const Value: TShutDownEvent); +begin + FOnShutDown := Value; +end; + +procedure TCustomConsole.SetOnGetPrompt(const Value: TGetPromptEvent); +begin + FOnGetPrompt := Value; +end; + +procedure TCustomConsole.MouseDown(Button: TMouseButton; Shift: TShiftState; X, + Y: Integer); +begin + inherited; + Windows.SetFocus(Handle); +end; + +function TCustomConsole.GetPrompt: boolean; +begin + Result := fPrompt; +end; + +procedure TCustomConsole.SetPrompt(const Value: boolean); +begin + if Value <> fPrompt then Begin + fPrompt := Value; + + if Value = True then Begin + CaretX := 1; + MinLeftCaret := 1; + with fLines.AddLine^ do Begin + IsPromptLine := True; + DoOnPrompt(Prompt, Text, fCaretX); + CaretX := fCaretX; // just for valid range checking + end; + if AutoUseInsertMode then InsertMode := True; + ShowCaret; + Invalidate; + end else Begin + fLines.AddLine; + end; // end else + end; // end if +end; + +procedure TCustomConsole.Write(AText: string; AUpdateMinLeftCaret: boolean = False); +begin + if not Prompt then Begin + fLines.Write(AText); + CaretX := length(CurrLine.Text) + 1; + if (AUpdateMinLeftCaret) then MinLeftCaret := length(CurrLine.Text) + 1; + end; +end; + +function TCustomConsole.GetCurrLine: PConsoleLine; +begin + Result := fLines.CurrLine; +end; + +procedure TCustomConsole.SetCurrLine(const Value: PConsoleLine); +begin + fLines.CurrLine := Value; + Invalidate; +end; + +{ TConsoleLines } + +function TConsoleLines.AddLine(Force: boolean = False): PConsoleLine; +begin + if (IsEmptyLine(CurrLine)) and (not Force) then Result := CurrLine + else Begin + New(Result); + Result.IsPromptLine := False; + Result.Prompt := ''; + Result.Text := ''; + fLines.Add(Result); + end; +end; + +procedure TConsoleLines.Clear; +var i: integer; +begin + try + for i := 0 to fLines.Count -1 do Dispose(fLines[i]); + finally + fLines.Clear; + end; +end; + +constructor TConsoleLines.Create(AOwner: TCustomConsole); +begin + fLines := TList.Create; + fOwner := AOwner; +end; + +destructor TConsoleLines.Destroy; +begin + try + Clear; + finally + fLines.Free; + end; + + inherited; +end; + +function TConsoleLines.GetCount: Integer; +begin + Result := fLines.Count; +end; + +function TConsoleLines.GetFullLineText(ALine: Integer): string; +begin + Result := Lines[ALine].Prompt + Lines[ALine].Text; +end; + +function TConsoleLines.GetCurrLine: PConsoleLine; +begin + if fLines.Count = 0 then Result := nil + else Result := fLines[fLines.Count - 1]; +end; + +function TConsoleLines.GetLines(Index: Integer): PConsoleLine; +begin + Result := fLines[Index]; +end; + +procedure TConsoleLines.SetCurrLine(const Value: PConsoleLine); +begin + fLines[fLines.Count - 1] := Value; +end; + +procedure TConsoleLines.SetLines(Index: Integer; + const Value: PConsoleLine); +begin + fLines[Index] := Value; +end; + +procedure TConsoleLines.Write(AText: string); +begin + CurrLine.Text := CurrLine.Text + AText; +end; + +procedure TConsoleLines.Writeln(ALine: string); +begin + CurrLine.Text := CurrLine.Text + ALine; + AddLine(True); +end; + +procedure TCustomConsole.SetBorderSize(const Value: Integer); +begin + FBorderSize := Value; +end; + +procedure TCustomConsole.SetExtraLineSpacing(const Value: Integer); +begin + FExtraLineSpacing := Value; +end; + +procedure TCustomConsole.BeginExternalOutput; +begin + Prompt := False; +end; + +procedure TCustomConsole.EndExternalOutput; +begin + Prompt := True; +end; + +function TConsoleLines.IsEmptyLine(ALine: PConsoleLine): boolean; +begin + Result := (ALine <> nil) and (not ALine.IsPromptLine) and (ALine.Text = ''); +end; + +function TConsoleLines.GetWrappedLines(Index: Integer): string; +var i, j, c: integer; + FullLine: string; +begin + c := 0; + Result := ''; + for i := 0 to fLines.Count - 1 do Begin + Inc(c, (Length(Lines[i].Prompt + Lines[i].Text) div WrapWidth) + 1); + if c > Index then Begin + Dec(c, (Length(Lines[i].Prompt + Lines[i].Text) div WrapWidth) + 1); + FullLine := Lines[i].Prompt + Lines[i].Text; + j := c; + while j < Index do Begin + Delete(FullLine, 1, WrapWidth); + inc(j); + end; // end while + Result := Copy(FullLine, 1, WrapWidth); + break; + end; // end if + end; // end for +end; + +function TConsoleLines.GetWrappedLineCount: Integer; +var i: integer; +begin + Result := 0; + for i := 0 to fLines.Count - 1 do + Result := Result + ((Length(Lines[i].Prompt + Lines[i].Text)) div WrapWidth ) + 1; +end; + +function TConsoleLines.GetWrapWidth: Integer; +begin + Result := (TCustomConsole(fOwner).ClientWidth - + TCustomConsole(fOwner).BorderSize * 2) div TCustomConsole(fOwner).CharWidth; +end; + +function TConsoleLines.LogicalToWrappedLineIndex(ALine: Integer): Integer; +begin + Result := 0; +end; + +procedure TCustomConsole.DoOnPrompt(var APrompt, DefaultText: string; + var DefaultCaretPos: Integer); +begin + if Assigned(fOnGetPrompt) then + fOnGetPrompt(Self, APrompt, DefaultText, DefaultCaretPos) + else Begin + APrompt := CONSOLE_DEFAULT_PROMPT; + end; + LastPrompt := APrompt; +end; + +procedure TCustomConsole.KeyCommandHandler(AKey: Char); +var CommandFinished: boolean; + ATerminate: boolean; +begin + // If we are not in prompt mode, filter keys by user event + ATerminate := False; + + if not (Prompt) and (Assigned(fOnCommandKeyPress)) then + fOnCommandKeyPress(Self, AKey, ATerminate) + else if (Assigned(fOnPromptKeyPress)) then fOnPromptKeyPress(Self, AKey); + + // Case Key + case Ord(AKey) of + VK_RETURN: + Begin + if Prompt then Begin // prompt mode + BeginExternalOutput; + CommandFinished := True; + if fLines[fLines.Count - 2].Text <> '' then + FLastCommand := fLines[fLines.Count - 2].Text; // FD 18.11.2012 + if Assigned(fOnCommandExecute) then + fOnCommandExecute(Self, fLines[fLines.Count - 2].Text, CommandFinished); + if CommandFinished and fActive then EndExternalOutput; + Invalidate; + end; + end; + + VK_BACK: + Begin + if (Prompt) or (CaretX > MinLeftCaret) then Begin + if (CaretX > length(CurrLine.Text)) then + Delete(CurrLine.Text, Length(CurrLine.Text), 1) + else Delete(CurrLine.Text, CaretX - 1, 1); + CaretX := CaretX - 1; + Invalidate; + end; + end; + + VK_TAB: + Begin + // Should Be Handled By An Event { TODO : todo } + end; + + else if (AKey <> #0) then // Insert char + Begin + if (CaretX > length(CurrLine.Text)) then CurrLine.Text := CurrLine.Text + AKey + else if InsertMode then Insert(AKey, CurrLine.Text, CaretX) // Insert Mode + else Begin // Overwrite Mode + Delete(CurrLine.Text, CaretX, 1); + Insert(AKey, CurrLine.Text, CaretX); + end; + + inc(fCaretX); + Invalidate; + end; + end; + + if (ATerminate) then EndExternalOutput; +end; + +procedure TCustomConsole.SetAutoUseInsertMode(const Value: boolean); +begin + FAutoUseInsertMode := Value; +end; + +procedure TCustomConsole.SetOnCommandKeyPress( + const Value: TCommandKeyPressEvent); +begin + FOnCommandKeyPress := Value; +end; + +{ TCommandParser } + +constructor TCommandParser.Create(ACommand: string); +begin + Create; + ParseCommand(ACommand); +end; + +constructor TCommandParser.Create; +begin + FParamList := TStringList.Create; +end; + +destructor TCommandParser.Destroy; +begin + FParamList.Free; + inherited; +end; + +function TCommandParser.GetParamCount: Integer; +begin + Result := FParamList.Count; +end; + +function TCommandParser.GetParameters(Index: Integer): string; +begin + if Index = 0 then Result := Command + else Result := FParamList[Index - 1]; +end; + +procedure TCommandParser.ParseCommand(ACommand: string); +var t: string; + Apost: boolean; + i: integer; + + procedure StoreSubString(AString: string); + Begin + if (AString <> '') then + // Store string (first substring as command, the others as parameters) + if (FCommand = '') then FCommand := AString + else FParamList.Add(AString); + end; +begin + // Reset + FParamList.Clear; + FCommand := ''; + Apost := False; + + // Parse + i := 1; + while (i <= length(ACommand)) do Begin + case ACommand[i] of + ' ': if not APost then Begin + StoreSubString(t); + t := ''; + end else t := t + ACommand[i]; + + '"': Apost := not Apost; + + else t := t + ACommand[i]; + end; + inc(i); + end; + StoreSubString(t); +end; + +procedure TCustomConsole.SetMinLeftCaret(const Value: Integer); +begin + FMinLeftCaret := Value; + if CaretX > FMinLeftCaret then CaretX := FMinLeftCaret; +end; + +procedure TCustomConsole.SetOnPromptKeyPress( + const Value: TPromptKeyPressEvent); +begin + FOnPromptKeyPress := Value; +end; + +end. diff --git a/src/CatDCP.pas b/src/CatDCP.pas new file mode 100644 index 0000000..857b175 --- /dev/null +++ b/src/CatDCP.pas @@ -0,0 +1,43 @@ +unit CatDCP; +{ + Catarinka - Quick AES string encryption/decryption functions + + Copyright (c) 2003-2014 Felipe Daragon + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details +} + +interface + +function StrToAES(const s, key: string): string; +function AESToStr(const s, key: string): string; + +implementation + +uses + DCPrijndael, DCPsha512; + +function StrToAES(const s, key: string): string; +var + Cipher: TDCP_rijndael; +begin + Cipher := TDCP_rijndael.Create(nil); + Cipher.InitStr(key, TDCP_sha512); + result := Cipher.EncryptString(s); + Cipher.Burn; + Cipher.Free; +end; + +function AESToStr(const s, key: string): string; +var + Cipher: TDCP_rijndael; +begin + Cipher := TDCP_rijndael.Create(nil); + Cipher.InitStr(key, TDCP_sha512); + result := Cipher.DecryptString(s); + Cipher.Burn; + Cipher.Free; +end; + +// ------------------------------------------------------------------------// +end. diff --git a/src/CatDCPKey.pas.ren b/src/CatDCPKey.pas.ren new file mode 100644 index 0000000..d2194ff --- /dev/null +++ b/src/CatDCPKey.pas.ren @@ -0,0 +1,24 @@ +unit CatDCPKey; + +interface + +const + // for storing passwords and preferences that need to be encrypted + CATKEY_PASSWORD = 1; + // for storing request headers in temporary cache files + CATKEY_REQUESTHEADERS = 2; + +function GetDCPKey(id:integer):string; + +implementation + +function GetDCPKey(id:integer):string; +begin + case id of + CATKEY_REQUESTHEADERS: result:='YourKey1'; + CATKEY_PASSWORD: result:='YourKey2'; + end +end; + +// ------------------------------------------------------------------------// +end. \ No newline at end of file diff --git a/src/CatFiles.pas b/src/CatFiles.pas new file mode 100644 index 0000000..c897e6a --- /dev/null +++ b/src/CatFiles.pas @@ -0,0 +1,532 @@ +unit CatFiles; +{ + Catarinka - File System functions + + Copyright (c) 2003-2014 Felipe Daragon + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details + + CopyAfterFirstLine and WipeFile functions by Peter Below + FileCopy function by David Stidolph +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + Winapi.Windows, System.Classes, System.SysUtils, Winapi.ShellAPI; +{$ELSE} + Windows, Classes, SysUtils, ShellAPI; +{$IFEND} +function DeleteFolder(const dir: string): boolean; +function DirExists(const dir: string): boolean; +function FileCanBeOpened(const filename: String): boolean; +function FileCopy(const source, dest: string): boolean; +function FilenameToMimeType(const filename: string): string; +function FixInvalidFilename(const filename: string; + const rep: string = '-'): string; +function ForceDir(const dir: string): boolean; +function GetDiskSerialNumber(const drive: string): string; +function GetFileSize(const filename: string): Int64; +function GetFileToStr(const filename: string): string; +function GetFileVersion(const Filename: string; const ResFormat:string='%d.%d.%d.%d'): string; +function GetSizeDescription(const bytes: cardinal): string; +function GetTextFileLinesCount(const filename: string): integer; +function GetTempFile(const ext: string): string; +function GetWindowsTempDir: string; +function SendToLog(const filename: TFilename; const s: string): boolean; +function SL_LoadFromFile(const SL: TStringList; const filename: string) + : boolean; +function SL_SaveToFile(const SL: TStringList; const filename: string): boolean; +procedure CatReadLn(const f: Text; var s: string); +procedure CopyAfterFirstLine(const sourcefile, targetfile: string; + appendln: boolean = false; lnstr: string = ''); +procedure GetDirs(const dir: string; const Result: TStrings; + SortResult: boolean = true); +procedure GetFiles(const dir: string; const Result: TStrings; + const IncludeDir: boolean = false; const IncludeExt: boolean = true); +procedure WipeFile(const filename: string); + +implementation + +uses + CatStrings; + +procedure CatReadLn(const f: Text; var s: string); +var + c: Char; + tempStr: string; +begin + tempStr := emptystr; + while not Eof(f) do + begin + read(f, c); + case Ord(c) of + 10: + Break; + 13: + begin + read(f, c); + Break; + end; + else + tempStr := tempStr + c; + end; + end; + s := tempStr; +end; + +// Deletes a directory and its sub directories +function DeleteFolder(const dir: string): boolean; +var + sdir: string; + st: TSHFileOpStruct; +begin + sdir := dir; + if LastChar(sdir) = '\' then + sdir := copy(sdir, 1, Length(sdir) - 1); + try + FillChar(st, SizeOf(st), #0); + sdir := sdir + #0#0; + with st do + begin + Wnd := 0; + wFunc := FO_DELETE; + pFrom := PChar(sdir); + fFlags := FOF_SILENT or FOF_NOCONFIRMATION; + end; + Result := (SHFileOperation(st) = 0); + except + Result := false; + end; +end; + +function DirExists(const dir: string): boolean; +begin + Result := DirectoryExists(dir); +end; + +function FileCanBeOpened(const filename: string): boolean; +var + h: integer; +begin + try + h := FileOpen(filename, fmOpenRead or fmShareDenyNone); + if h > 0 then + begin + Result := true; + FileClose(h); + end + else + Result := false; + except + Result := false + end; +end; + +function FilenameToMimeType(const filename: string): string; +var + ext: string; +begin + ext := LowerCase(ExtractFileExt(filename)); + if length(ext) > 1 then + ext := Copy(ext, 2, length(ext)); + if (ext = 'htm') or (ext = 'html') then + result := 'text/html' + else if ext = 'bmp' then + result := 'image/bmp' + else if ext = 'gif' then + result := 'image/gif' + else if (ext = 'jpg') or (ext = 'jpeg') then + result := 'image/jpeg' + else if (ext = 'png') then + result := 'image/png' + else if ext = 'txt' then + result := 'text/plain' + else + result := 'application/octet-stream'; // Unknown Type +end; + +// TODO: rewrite +function FixInvalidFilename(const filename: string; + const rep: string = '-'): string; +begin + result := filename; + result := ReplaceStr(result, '\', rep); + result := ReplaceStr(result, ':', rep); + result := ReplaceStr(result, '*', rep); + result := ReplaceStr(result, '?', rep); + result := ReplaceStr(result, '"', rep); + result := ReplaceStr(result, '<', rep); + result := ReplaceStr(result, '>', rep); + result := ReplaceStr(result, '|', rep); + result := ReplaceStr(result, '/', rep); +end; + +function ForceDir(const dir: string): boolean; +var + d: string; +begin + d := ReplaceStr(dir, '\\', '\'); + d := ReplaceStr(d, '//', '/'); + Result := ForceDirectories(d); +end; + +procedure GetDirs(const dir: string; const Result: TStrings; + SortResult: boolean = true); +var + SL: TStringList; + sr: TSearchRec; +begin + SL := TStringList.Create; + try + if FindFirst(dir + '*.*', faDirectory, sr) = 0 then + begin + repeat + if ((sr.Attr and faDirectory) = faDirectory) and (sr.name <> '.') and + (sr.name <> '..') then + SL.Add(sr.name); + until FindNext(sr) <> 0; + FindClose(sr); + end; + if SortResult = true then + SL.sort; + Result.Text := SL.Text; + finally + SL.Free; + end; +end; + +function GetDiskSerialNumber(const drive: string): string; +var + sn, len, flags: DWORD; +begin + GetVolumeInformation(PChar(drive), nil, 0, @sn, len, flags, nil, 0); + Result := IntToHex(HiWord(sn), 4) + '-' + IntToHex(LoWord(sn), 4); +end; + +procedure GetFiles(const dir: string; const Result: TStrings; + const IncludeDir: boolean = false; const IncludeExt: boolean = true); +var + rc: integer; + tmpPath, ffound: string; + sr: TSearchRec; +begin + if Result = nil then + exit; + tmpPath := IncludeTrailingBackSlash(ExtractFilePath(dir)); + rc := FindFirst(dir, faAnyFile, sr); + while rc = 0 do + begin + ffound := sr.name; + if IncludeExt = false then + ffound := changefileext(ffound, emptystr); + if IncludeDir then + Result.Add(tmpPath + ffound) + else + Result.Add(ffound); + rc := FindNext(sr); + end; + FindClose(sr); +end; + +function GetFileSize(const filename: string): Int64; +var + f: TWin32FindData; + h: THandle; +begin + Result := -1; + try + if not FileExists(filename) then + exit; + h := FindFirstFile({$IFDEF UNICODE}PWideChar{$ELSE}PChar{$ENDIF}(filename), f); + if h = INVALID_HANDLE_VALUE then + RaiseLastWin32Error; + try + Result := f.nFileSizeHigh shl 32 + f.nFileSizeLow; + finally +{$IF CompilerVersion >= 23}Winapi.{$IFEND}Windows.FindClose(h); + end; + except + end; +end; + +function GetFileToStr(const filename: string): string; +var + SL: TStringList; + f: TFileStream; +begin + SL := TStringList.Create; + f := TFileStream.Create(filename, fmOpenRead or fmShareDenyWrite); + with f do + begin + try + SL.LoadFromStream(f); + Result := SL.Text; + except + Result := emptystr; + end; + Free; + end; + SL.Free; +end; + +// Returns the version of a binary file (DLL, EXE, etc) +function GetFileVersion(const Filename: string; const ResFormat:string='%d.%d.%d.%d'): string; +var + p, pi: Pointer; + infosz, plen: DWord; + verinfo: VS_FIXEDFILEINFO; +begin + Result := EmptyStr; + infosz := GetFileVersionInfoSize({$IFDEF UNICODE}PWideChar{$ELSE}PChar{$ENDIF}(Filename), plen); + FillChar(verinfo, SizeOf(verinfo), 0); + if infosz > 0 then + begin + GetMem(p, infosz); + GetFileVersionInfo({$IFDEF UNICODE}PWideChar{$ELSE}PChar{$ENDIF}(Filename), + 0, infosz, p); + VerQueryValue(p, '\', pi, plen); + move(pi^, verinfo, SizeOf(verinfo)); + Result := Format(ResFormat, [verinfo.dwFileVersionMS shr 16, + verinfo.dwFileVersionMS and 65535, verinfo.dwFileVersionLS shr 16, + verinfo.dwFileVersionLS and 65535]); + FreeMem(p); + end; +end; + +function GetSizeDescription(const bytes: cardinal): string; +const + cFF = '0.0'; +begin + if bytes < 1 then + Result := '0 bytes' + else + case bytes of + 1 .. 1023: + Result := InttoStr(bytes) + ' bytes'; + 1024 .. 1048575: + Result := FormatFloat(cFF, bytes / 1024) + ' KB'; + 1048576 .. 1073741823: + Result := FormatFloat(cFF, bytes / 1048576) + ' MB'; + else + Result := FormatFloat(cFF, bytes / 1073741824) + ' GB'; + end; +end; + +// Returns a temporary filename (located in the Windows Temporary directory) +// This function will not create the temporary file, just return a filename suggestion +// Usage Example: ShowMessage(GetTempFile('.tmp')) +function GetTempFile(const ext: string): string; +var + buf: array [0 .. MAX_PATH] of {$IFDEF UNICODE}WideChar{$ELSE}Char{$ENDIF}; +begin + GetTempPath({$IFDEF UNICODE}Length{$ELSE}SizeOf{$ENDIF}(buf) - 1, buf); + GetTempFileName(buf, '~', 0, buf); + Result := StrPas(buf); + if ext<>emptystr then // if the extension is empty will return a .tmp + Result := ChangeFileExt(Result, ext); +end; + +function GetTextFileLinesCount(const filename: string): integer; +var + f: Textfile; + s: string; +begin + AssignFile(f, filename); + Reset(f); + Result := 0; + while not seekeof(f) do + begin + Result := Result + 1; + CatReadLn(f, s); + end; + Closefile(f); +end; + +function GetWindowsTempDir: String; +var + bufFolder: array [0 .. MAX_PATH] of +{$IFDEF UNICODE}WideChar{$ELSE}Char{$ENDIF}; +begin + GetTempPath({$IFDEF UNICODE}Length{$ELSE}SizeOf{$ENDIF}(bufFolder), + bufFolder); + Result := IncludeTrailingPathDelimiter(String(bufFolder)); +end; + +function SendToLog(const filename: TFilename; const s: String): boolean; +var + f: Textfile; +begin + try + AssignFile(f, filename); + if FileExists(filename) = false then + ReWrite(f) + else + begin + Reset(f); + Append(f); + end; + WriteLn(f, s); + Closefile(f); + Result := true; + except + Result := false; + end; +end; + +function SL_SaveToFile(const SL: TStringList; const filename: string): boolean; +var + fs: TStream; +begin + Result := false; + if filename = emptystr then + exit; + if FileExists(filename) = false then + begin + fs := TFileStream.Create(filename, fmCreate or fmOpenWrite or + fmShareDenyWrite); + fs.Free; + end; + + fs := TFileStream.Create(filename, fmOpenWrite or fmShareDenyWrite); + fs.Size := 0; + try + SL.SaveToStream(fs); + Result := true; + except + end; + fs.Free; +end; + +function SL_LoadFromFile(const SL: TStringList; const filename: string) + : boolean; +var + fs: TStream; +begin + Result := false; + if filename = emptystr then + exit; + fs := TFileStream.Create(filename, fmOpenRead or fmShareDenyNone); + try + SL.LoadFromStream(fs); + Result := true; + except + end; + fs.Free; +end; + +// By David Stidolph, 21 Jun 1995 +function FileCopy(const source, dest: string): boolean; +var + fSrc, fDst, len: integer; + Size: LongInt; + buffer: packed array [0 .. 2047] of Byte; +begin + Result := false; + if source <> dest then + begin + fSrc := FileOpen(source, fmOpenRead); + if fSrc >= 0 then + begin + Size := FileSeek(fSrc, 0, 2); + FileSeek(fSrc, 0, 0); + fDst := FileCreate(dest); + if fDst >= 0 then + begin + while Size > 0 do + begin + len := FileRead(fSrc, buffer, SizeOf(buffer)); + FileWrite(fDst, buffer, len); + Size := Size - len; + end; + FileSetDate(fDst, FileGetDate(fSrc)); + FileClose(fDst); + FileSetAttr(dest, FileGetAttr(source)); + Result := true; + end; + FileClose(fSrc); + end; + end; +end; + +// Peter Below ------------------------------------------------------------// + +// Based on an example from PB (4/5/1998) +procedure CopyAfterFirstLine(const sourcefile, targetfile: string; + appendln: boolean = false; lnstr: string = ''); +var + s: string; + source, Target: Textfile; +begin + AssignFile(source, sourcefile); + AssignFile(Target, targetfile); + Reset(source); + try + ReWrite(Target); + try + CatReadLn(source, s); + while not Eof(source) do + begin + CatReadLn(source, s); + WriteLn(Target, s); + end; + if appendln then + WriteLn(lnstr); + finally + Closefile(Target); + end; + finally + Closefile(source); + end; +end; + +{ + If you want to get rid of a file normally you just delete it. + But someone else can undelete it if the file hasn't been wiped correctly. + For security purposes, to insure that certain files are permanently + gone, the WipeFile procedure writes over the data in the file with + random characters and then erases it. +} +procedure WipeFile(const filename: string); // PB +var + buffer: array [0 .. 4095] of Byte; + max, n: LongInt; + i: integer; + fs: TFileStream; + + procedure RandomizeBuffer; + var + i: integer; + begin + for i := Low(buffer) to High(buffer) do + buffer[i] := Random(256); + end; + +begin + fs := TFileStream.Create(filename, fmOpenReadWrite or fmShareExclusive); + try + for i := 1 to 3 do + begin + RandomizeBuffer; + max := fs.Size; + fs.Position := 0; + while max > 0 do + begin + if max > SizeOf(buffer) then + n := SizeOf(buffer) + else + n := max; + fs.Write(buffer, n); + max := max - n; + end; + FlushFileBuffers(fs.Handle); + end; + finally + fs.Free; + end; + Deletefile(filename); +end; + +// ------------------------------------------------------------------------// +end. diff --git a/src/CatHTMLParser.pas b/src/CatHTMLParser.pas new file mode 100644 index 0000000..4e48998 --- /dev/null +++ b/src/CatHTMLParser.pas @@ -0,0 +1,494 @@ +unit CatHTMLParser; +{$B-} + +{ + Catarinka HTML Parser + Copyright (c) 2003-2014 Felipe Daragon + + Based on HTMLParser.pas (THtmlParser), + Copyright (c) 1999-2000 Przemyslaw Jankowski (pjank@home.pl) + + License: MIT (http://opensource.org/licenses/mit-license.php) + + You can do whatever you want with this code as long as you include the + original copyright and license. + + Changes: + - Added Pos, TagPos, TagLine and TextBetweenPos properties +} + +(***********************************************************************************) +(* *) +(* Classes defined in this unit allow you to parse (and update!) any HTML data *) +(* *) +(* To use this unit you must first: *) +(* - create a THtmlParser object *) +(* - set its >Text< property to the HTML text you want to parse *) +(* Then you can "move around" this text with two methods: *) +(* - NextTag - moves you to the next tag from current position *) +(* (after setting Text current position is the beginning of the text) *) +(* - PrevTag - moves to the previous tag ("goes back") *) +(* The current tag (the tag at current position) is returned by Tag property *) +(* You have also access to the text between two tags - it's in TextBetween prop. *) +(* There are also some useful methods: *) +(* - LoadFromFile - loads Text from the specified file from disk *) +(* - SaveToFile - saves the Text to disk *) +(* - GotoBeginning - sets current position at the beginning of the text *) +(* (note: Tag and TextBetween are set to nothing) *) +(* - GotoEnd - sets current position at the end of the text *) +(* (same note as above) *) +(* - RemoveTag - deletes the current tag *) +(* - InsertTag - inserts a new tag before the current one *) +(* (the current position "moves" behind the new tag) *) +(* - InsertText - inserts some text in the current position *) +(* *) +(* *) +(* The TTag class provides you access to everything between two brackets: < and > *) +(* - Name - this is the tag's name (e.g. 'TABLE', 'IMG' or '/BODY') *) +(* (when you read it, it always returns uppercase) *) +(* - Params - this is a TStringList with all parameters *) +(* (each line is something like: 'width=100' or 'ALT="my image"') *) +(* hint: you may use the TStringList's Names, Values properties *) +(* *) +(* *) +(* Take a look at the Demo1.pas (Button1Click) to see an example. *) +(* *) +(***********************************************************************************) +(* *) +(* version 1.0 - 18.03.2000 *) +(* - fixed adding empty lines in Tag.Params *) +(* (thanks to: JulianWEB ) *) +(* - changed the name TParser to THtmlParser because of a conflict *) +(* with Classes.pas unit (thanks: Michael Belmont) *) +(* - a little improved demo project - now shows, what's inside all TTag objects *) +(* *) +(* version 0.9 - 30.12.1999 *) +(* - first released version *) +(* *) +(***********************************************************************************) + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + System.SysUtils, System.Classes; +{$ELSE} + Classes, SysUtils; +{$IFEND} + + +type + TSimpleEvent = procedure of object; + + TSandTag = class + constructor Create; + destructor Destroy; override; + private + fName: string; + fParams: TStrings; + fOnChanged: TSimpleEvent; + procedure Changed; + function GetName:string; + function GetText:string; + procedure SetName(const NewName:string); + procedure SetText(const text:string); + public + property Text:string read GetText write SetText; // this is all the stuff + // between "<" and ">" + property Name:string read GetName write SetName; // tag name (returns uppercase) + property NameOriginal:string read fName; // FD + property Params:TStrings read fParams; // parameters list + private + // used only by TCatHTMLParser - updates TCatHTMLParser.Text + property OnChanged:TSimpleEvent read fOnChanged write fOnChanged; + end; + + TCatHTMLParser = class + constructor Create; + destructor Destroy; override; + private + fText: string; + fTextBetween: string; + fTag: TSandTag; + fPos: Integer; // current position in Text + fTagPos,fTagLen: Integer; // Tag position and length (including brackets) + fTBPos: Integer; // TextBetween position + function GetTag:TSandTag; + procedure SetText(const NewText:string); + procedure SetTextBetween(const text:string); + procedure TagChanged; + procedure ClearTag; + procedure ClearTB; + procedure CheckPos; + procedure SetTagText(const text:string); + function FindTag(next:Boolean):Boolean; + function GetTagLine:integer;// FD + public + property Text:string read fText write SetText; // here is all the HTML file + property Tag:TSandTag read GetTag; // current tag + procedure RemoveTag; // remove the current tag + procedure InsertTag(NewTag:TSandTag); // insert a new tag BEFORE the current one + procedure InsertText(text:string); // insert some text before the current tag + function NextTag:Boolean; // find next tag from current pos. + function PrevTag:Boolean; // find previous tag from current pos. + procedure GotoBeginning; + procedure GotoEnd; + procedure LoadFromFile(filename:string); + procedure SaveToFile(filename:string); + public + property Pos:integer read fPos; // FD + property TagPos:integer read fTagPos; // FD + property TagLine:integer read GetTagLine; // FD + property TextBetweenPos:integer read fTBPOS; // FD + property TextBetween:string // this is the text between two tags: + read fTextBetween // - the last one - before calling NextTag/PrevTag + write SetTextBetween; // - and the new (current) one + end; + + + +implementation + +function GetLineByPos(const s: string; const Position: Integer): Integer; +var + i, ln: Integer; +begin + result := -1; + if (Position = -1) then + Exit; + + i := 1; + ln := 0; + while i < Position do + begin + if (s[i] = #13) then + ln := ln + 1; + i := i + 1; + end; + result := ln; +end; + +{ TParams } + +type + TParams = class (TStringList) + fTag: TSandTag; + procedure Changed; override; + end; + +procedure TParams.Changed; +begin + inherited; + if Assigned(fTag) then fTag.Changed; +end; + + + +{ TSandTag } + +constructor TSandTag.Create; +begin + fName:= ''; + fParams:= TParams.Create; + TParams(fParams).fTag:= Self; + fOnChanged:= nil; +end; + +destructor TSandTag.Destroy; +begin + fParams.Free; + inherited Destroy; +end; + +procedure TSandTag.Changed; +begin + if Assigned(fOnChanged) then fOnChanged; +end; + +function TSandTag.GetName: string; +begin + Result:= UpperCase(fName); +end; + +procedure TSandTag.SetName(const NewName: string); +begin + if NewName<>fName then begin + fName:= NewName; + Changed; + end; +end; + +function TSandTag.GetText: string; +var i: Integer; +begin + Result:= fName; + for i:= 0 to fParams.Count-1 do + Result:= Result + ' ' + fParams[i]; +end; + +procedure TSandTag.SetText(const text: string); +var i,k: Integer; + len: Integer; + q1,q2: Boolean; + procedure AddParam; + var s: string; + begin + s:= Trim(Copy(text,k,i-k+1)); + if s<>'' then fParams.Add(s); + k:= i+1; + end; +begin + q1:= False; + q2:= False; + len:= Length(text); + + // getting name + i:= 1; + while not ((i>len) or (text[i]=' ')) do Inc(i); + fName:= Copy(text, 1, i-1); + + k:= i+1; i:= k; + fParams.Clear; + // getting parameters + while not (i>len) do begin + if (text[i] in ['''', '"']) then begin + if (text[i]='"') + then begin if not q1 then q2:= not q2 end + else begin if not q2 then q1:= not q1 end; + if not (q1 or q2) then AddParam; + end else + if (text[i]=' ') and not (q1 or q2) then AddParam; + Inc(i); + end; + if kLength(fText) then fPos:= Length(fText); +end; + +procedure TCatHTMLParser.InsertTag(NewTag: TSandTag); +begin + CheckPos; + Insert('<'+NewTag.Text+'>', fText, fPos); + NextTag; +end; + +procedure TCatHTMLParser.InsertText(text: string); +begin + CheckPos; + ClearTB; + Insert(text, fText, fPos); + Inc(fPos, Length(text)); +end; + +procedure TCatHTMLParser.RemoveTag; +begin + if fTagPos=0 then Exit; + Delete(fText, fTagPos, fTagLen); + ClearTag; + ClearTB; +end; + +procedure TCatHTMLParser.SetText(const NewText: string); +begin + fText:= NewText; + GotoBeginning; +end; + +procedure TCatHTMLParser.SetTextBetween(const text: string); +begin + if fTBPos=0 then Exit; + if text<>fTextBetween then begin + if (fTBPos<>0) and (fTagPos>fTBPos) then + Inc(fTagPos, Length(text)-Length(fTextBetween)); + Delete(fText, fTBPos, Length(fTextBetween)); + Insert(text, fText, fTBPos); + end; +end; + +procedure TCatHTMLParser.TagChanged; +var s: string; +begin + if fTagPos=0 then Exit; + Delete(fText, fTagPos+1, fTagLen-2); + s:= fTag.Text; + if (fTBPos>fTagPos) then Inc(fTBPos, Length(s)+2-fTagLen); + fTagLen:= Length(s)+2; + Insert(s, fText, fTagPos+1); +end; + + +function TCatHTMLParser.NextTag: Boolean; +begin + Result:= FindTag(True); +end; + + +function TCatHTMLParser.PrevTag: Boolean; +begin + Result:= FindTag(False); +end; + + + +function FindNext(const text:string; ch:char; startfrom:Integer; var pos:Integer):Boolean; +begin + pos:= startfrom; + while (pos<=Length(text)) and (text[pos]<>ch) do Inc(pos); + Result:= (text[pos]=ch); +end; + +function FindPrev(const text:string; ch:char; startfrom:Integer; var pos:Integer):Boolean; +begin + pos:= startfrom; + while (pos>0) and (text[pos]<>ch) do Dec(pos); + Result:= (text[pos]=ch); +end; + + +function TCatHTMLParser.FindTag(next: Boolean): Boolean; +var tag1, tag2, // first/last char of the new tag + tb1, tb2: Integer; // first/last char of new TextBetween +begin + + if Length(fText)=0 then begin + Result:= False; + Exit; + end; + + if fTagPos<>0 then + if next then Inc(fPos) else Dec(fPos); + + CheckPos; + + if next then begin + // find next tag + Result:= FindNext(fText, '<', fPos, tag1) and FindNext(fText, '>', tag1, tag2); + // find end of current tag + if FindNext(fText, '>', fPos, tb1) and (tb1', tb2, tag2) and FindPrev(fText, '<', tag2, tag1); + end; + + if Result then begin + fPos:= tag1; + if next + then tb2:= tag1-1 + else tb1:= tag2+1; + end + else begin + if next then begin + fPos:= Length(fText); + tb2:= Length(fText); + end + else begin + fPos:= 1; + tb1:= 1; + end; + tag1:= 0; + tag2:= 0; + end; + + fTagPos:= tag1; + fTagLen:= tag2-tag1+1; + SetTagText(Copy(fText, fTagPos+1, fTagLen-2)); + fTBPos:= tb1; + fTextBetween:= Copy(fText, fTBPos, tb2-tb1+1); +end; + +procedure TCatHTMLParser.GotoBeginning; +begin + fPos:= 0; + ClearTag; + ClearTB; +end; + +procedure TCatHTMLParser.GotoEnd; +begin + fPos:= Length(fText); + ClearTag; + ClearTB; +end; + +procedure TCatHTMLParser.LoadFromFile(filename: string); +var l: TStringList; +begin + l:= TStringList.Create; + try + l.LoadFromFile(filename); + Text:= l.Text; + finally + l.Free; + end; +end; + +procedure TCatHTMLParser.SaveToFile(filename: string); +var l: TStringList; +begin + l:= TStringList.Create; + try + l.Text:= Text; + l.SaveToFile(filename); + finally + l.Free; + end; +end; + +end. diff --git a/src/CatHTTP.pas b/src/CatHTTP.pas new file mode 100644 index 0000000..70f9d35 --- /dev/null +++ b/src/CatHTTP.pas @@ -0,0 +1,476 @@ +unit CatHTTP; +{ + Catarinka - HTTP and HTML related functions + Copyright (c) 2003-2014 Felipe Daragon + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details + + ColorToHTMLColor function by Ralf Mimoun + + 4.19.2011, FD: GetHostFromURL, GetPortFromURL, + GetDomainFromHost, GetPortFromHost are now IPv6 compatible +} + +interface + +uses +{$IF CompilerVersion >= 23} + System.Classes, System.SysUtils, Vcl.Graphics; +{$ELSE} + Classes, SysUtils, Graphics; +{$IFEND} +function BoolToDisplayState(const b: boolean): string; +function ColorToHTMLColor(const Color: TColor): string; +function ExtractUrlFileExt(const url: string): string; +function ExtractUrlFileName(const url: string): string; +function GetDomainFromHost(const host: string): string; +function GetField(const Field, ReqStr: string): ansistring; +function GetHeaderFromResponse(const r: string): string; +function GetHostFromURL(const url: string): string; +function GetPathFromRequest(const r: string): string; +function GetPathFromURL(const url: string; + const includeparams: boolean = true): string; +function GetPortFromHost(const host: string): string; +function GetPortFromURL(const url: string): string; +function GetPostDataFromRequest(const r: string): string; +function GetStatusCodeFromResponse(const r: string): integer; +function HostPort2URL(const host: string; const port: integer): string; +function HtmlColorToColor(const Color: string): TColor; +function HtmlEntityDecode(const s: string): string; +function HtmlEscape(const s: string): string; +function HtmlUnescape(const s: string): string; +function Path_TitleCase(const s: string): string; +function PostDataToJSON(const s: string): string; +function RemoveHeaderFromResponse(const r: string): string; +function StripHTML(const s: string): string; +function StripPHPCode(const s: string): string; +function URLDecode(const s: string): string; +function URLEncode(const s: string; plus: boolean = false; + const preserve: TSysCharSet = ['0' .. '9', 'A' .. 'Z', 'a' .. 'z', + ' ']): string; +function URLEncodeFull(const s: string): string; + +implementation + +uses + CatStrings, CatStringLoop, CatJSON; + +function BoolToDisplayState(const b: boolean): string; +begin + if b then + result := 'block' + else + result := 'none'; +end; + +// By Ralf Mimoun +function ColorToHTMLColor(const Color: TColor): string; +var + cl: LongInt; +begin + cl := ColorToRGB(Color); + result := format('#%6.6x', [((cl and $FF0000) shr 16) + ((cl and $00FF00)) + + ((cl and $0000FF) shl 16)]); +end; + +// TitleCase for URL paths +function Path_TitleCase(const s: string): string; +var + i: integer; +begin + result := s; + for i := 1 to length(result) - 1 do + if (result[i] in (['~', '/'] - ['.', '-', 'A' .. 'Z', 'a' .. 'z'])) then + if result[i + 1] in ['a' .. 'z'] then + result[i + 1] := Char(ord(result[i + 1]) and not $20); +end; + +function PostDataToJSON(const s: string): string; +var + d: TCatJSON; + slp: TStringLoop; + n, v: string; +begin + d := TCatJSON.Create; + slp := TStringLoop.Create; + slp.LoadFromString(replacestr(s, '&', crlf)); + while slp.Found do + begin + n := before(slp.current, '='); + v := after(slp.current, '='); + v := URLDecode(v); + if isValidJSONName(n) then + d[n] := v; + end; + slp.free; + result := d.Text; + d.free; +end; + +function GetStatusCodeFromResponse(const r: string): integer; +var + rlines: tstringlist; + st: string; +begin + result := -1; + rlines := tstringlist.Create; + rlines.Text := r; + if rlines.count <> 0 then + begin + st := after(rlines[0], ' '); // this is the status code + st := before(st, ' '); + if isinteger(st) then // confirm before returning + result := StrToInt(st); + end; + rlines.free; +end; + +function RemoveHeaderFromResponse(const r: string): string; +var + i: integer; + start: boolean; +begin + result := emptystr; + start := false; + for i := 1 to length(r) do + begin + if start = false then + begin + if (r[i] = #10) and (r[i - 1] = #13) and (r[i - 2] = #10) and + (r[i - 3] = #13) then + start := true; + end + else + result := result + r[i]; + end; +end; + +function GetHeaderFromResponse(const r: string): string; +var + i: integer; + collected: boolean; +begin + result := emptystr; + collected := false; + for i := 1 to length(r) do + begin + if collected = false then + if (r[i] = #10) and (r[i - 1] = #13) and (r[i - 2] = #10) and + (r[i - 3] = #13) then + break + else + result := result + r[i]; + end; +end; + +function HostPort2URL(const host: string; const port: integer): string; +var + proto, sport: string; +begin + if port = 443 then + proto := 'https://' + else + proto := 'http://'; + if (port <> 80) and (port <> 443) then + sport := ':' + inttostr(port); + result := proto + host + sport; +end; + +function StripHTML(const s: string): string; +var + i: integer; + strip: boolean; +begin + result := emptystr; + strip := false; + for i := 1 to length(s) do + begin + if s[i] = '<' then + strip := true; + if strip then + begin + if s[i] = '>' then + begin + strip := false; + Continue; + end; + end + else + result := result + s[i]; + end; +end; + +function StripPHPCode(const s: string): string; +var + i: integer; + strip: boolean; +begin + result := emptystr; + strip := false; + for i := 1 to length(s) do + begin + if (s[i] = '<') and (s[i + 1] = '?') then + strip := true; + if strip then + begin + if (s[i] = '>') and (s[i - 1] = '?') then + begin + strip := false; + Continue; + end; + end + else + result := result + s[i]; + end; +end; + +function HtmlEscape(const s: string): string; +begin + result := replacestr(s, '&', '&'); + result := replacestr(result, '<', '<'); + result := replacestr(result, '>', '>'); + result := replacestr(result, '"', '"'); + result := replacestr(result, '''', '''); +end; + +function HtmlUnescape(const s: string): string; +begin + result := replacestr(s, '&', '&'); + result := replacestr(result, '<', '<'); + result := replacestr(result, '>', '>'); + result := replacestr(result, '"', '"'); + result := replacestr(result, ''', ''''); +end; + +// Returns the value of field from a request/response header +function GetField(const Field, ReqStr: +{$IFDEF UNICODE}string{$ELSE}ansistring{$ENDIF}): ansistring; +var + slp: TStringLoop; + afield: string; +begin + result := emptystr; + afield := lowercase(Field); + if pos(afield, lowercase(ReqStr)) = 0 then + exit; // not found + slp := TStringLoop.Create; + slp.LoadFromString(ReqStr); + while slp.Found do + begin + if beginswith(trim(slp.CurrentLower), afield + ':') then + begin // found + result := trim(after(slp.current, ':')); + slp.Stop; + end; + end; + slp.free; +end; + +function HtmlColorToColor(const Color: string): TColor; +var + cl: string; +begin + cl := Color; + Delete(cl, 1, 1); + result := StrToIntDef('$' + Copy(cl, 5, 2) + Copy(cl, 3, 2) + Copy(cl, 1, 2), + $00FFFFFF); +end; + +function ExtractUrlFileName(const url: string): string; +var + i: integer; +begin + result := url; + if pos('?', result) <> 0 then + result := before(result, '?'); + i := LastDelimiter('/', result); + result := Copy(result, i + 1, length(result) - (i)); +end; + +function ExtractUrlFileExt(const url: string): string; +begin + result := ExtractUrlFileName(url); + if pos('?', result) <> 0 then + result := before(result, '?'); + result := extractfileext(result); +end; + +function GetHostFromURL(const url: string): string; +begin + result := after(url, '://'); + result := before(result, '/'); + if beginswith(result, '[') then + begin // ipv6 format + result := after(result, '['); + result := before(result, ']'); + result := '[' + result + ']'; + end + else + begin // ipv4 format + if pos(':', result) <> 0 then + result := before(result, ':'); + end; +end; + +function GetPortFromURL(const url: string): string; +var + temp: string; +begin + result := '80'; // default + if beginswith(lowercase(url), 'https://') then + result := '443'; + temp := after(url, '://'); + temp := before(temp, '/'); + if pos(':', temp) <> 0 then + begin // port provided via format [proto]://[host]:[port]/ + if beginswith(temp, '[') then + begin // ipv6 format + temp := after(temp, ']:'); + end + else + begin // ipv4 format + temp := after(temp, ':'); + end; + if isinteger(temp) then + result := temp; + end; +end; + +function GetPathFromURL(const url: string; + const includeparams: boolean = true): string; +begin + result := after(url, '://'); + result := after(result, '/'); + if includeparams = false then + begin + if pos('?', result) <> 0 then + result := before(result, '?'); + end; +end; + +function GetPostDataFromRequest(const r: string): string; +var + slp: TStringLoop; + foundempty, postbegin: boolean; + postdata: string; +begin + postdata := emptystr; + foundempty := false; + postbegin := false; + slp := TStringLoop.Create; + slp.LoadFromString(r); + while slp.Found do + begin + if foundempty then + begin + if trim(slp.current) <> emptystr then + postbegin := true; + end; + if postbegin then + begin + if postdata = emptystr then + postdata := slp.current + else + postdata := postdata + crlf + slp.current; + end; + if trim(slp.current) = emptystr then + foundempty := true; + end; + result := postdata; + slp.free; +end; + +function GetDomainFromHost(const host: string): string; +begin + result := GetHostFromURL('http://' + host + '/'); +end; + +function GetPortFromHost(const host: string): string; +begin + result := GetPortFromURL('http://' + host + '/'); +end; + +function HtmlEntityDecode(const s: string): string; +begin + result := replacestr(s, '<', '<'); + result := replacestr(result, '>', '>'); + result := replacestr(result, '"', '"'); + result := replacestr(result, '&', '&'); +end; + +function GetPathFromRequest(const r: string): string; +var + sl: tstringlist; +begin + result := '/'; + sl := tstringlist.Create; + sl.Text := r; + if sl.count <> 0 then + begin + result := after(sl[0], ' '); // path, after HTTP method + result := before(result, ' '); // before HTTP version + end; + sl.free; +end; + +function URLDecode(const s: string): string; +var + i: integer; +begin + result := emptystr; + if length(s) = 0 then + result := emptystr + else + begin + i := 1; + while i <= length(s) do + begin + if s[i] = '%' then + begin + result := result + Chr(HexToInt(s[i + 1] + s[i + 2])); + Inc(i, 2); + end + else if s[i] = '+' then + result := result + ' ' + else + result := result + s[i]; + + Inc(i); + end; + end; +end; + +function URLEncode(const s: string; plus: boolean = false; + const preserve: TSysCharSet = ['0' .. '9', 'A' .. 'Z', 'a' .. 'z', + ' ']): string; +var + i: integer; + sp: string; +begin + if length(s) = 0 then + result := emptystr + else + begin + if plus then + sp := '+' + else + sp := '%20'; + for i := 1 to length(s) do + begin + if not(s[i] in preserve) then + result := result + '%' + IntToHex(ord(s[i]), 2) + else if (s[i] = ' ') then + result := result + sp + else + result := result + s[i]; + end; + end; +end; + +function URLEncodeFull(const s: string): string; +begin + result := URLEncode(s, false, []); +end; + +// ------------------------------------------------------------------------// +end. diff --git a/src/CatHighlighters.pas b/src/CatHighlighters.pas new file mode 100644 index 0000000..d64d43c --- /dev/null +++ b/src/CatHighlighters.pas @@ -0,0 +1,198 @@ +unit CatHighlighters; + +{ + Catarinka - Multiple Code Highlighters + Copyright (c) 2011-2014 Syhunt Informatica + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details + + Color scheme adapted from the CodeRay project (MIT-licensed) + https://github.com/rubychan/coderay + Copyright (C) 2005-2012 Kornelius Kalnbach (@murphy_karasu) +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + System.Classes, System.SysUtils, System.TypInfo, Vcl.Graphics, +{$ELSE} + Classes, SysUtils, TypInfo, Graphics, +{$IFEND} + SynEditHighlighter, + SynHighlighterRuby, + SynHighlighterPerl, + SynHighlighterPython, + SynHighlighterPas, + SynHighlighterVBScript, + SynHighlighterSQL, + SynHighlighterWeb, + SynHighlighterWebData, + SynHighlighterWebMisc; + +type + TCatHighlighters = class + private + fSynWebEngine: TSynWebEngine; + WebJS: TSynWebESSyn; + WebCSS: TSynWebCSSSyn; + WebXML: TSynWebXMLSyn; + WebPHP: TSynWebPHPPlainSyn; + Ruby: TSynRubySyn; + Pascal: TSynPasSyn; + Perl: TSynPerlSyn; + Python: TSynPythonSyn; + SQLSyn: TSynSQLSyn; + VBScript: TSynVBScriptSyn; + public + WebHTML: TSynWebHtmlSyn; + function GetByFileExtension(const fileext: string): TSynCustomHighlighter; + function GetByContentType(const contenttype: string): TSynCustomHighlighter; + procedure SetCodeRayColors(const e: TSynWebEngine); + constructor Create(AOwner: TObject); + destructor Destroy; override; + end; + +implementation + +uses + CatStrings; + +function TCatHighlighters.GetByContentType(const contenttype: string) + : TSynCustomHighlighter; +var + ct: string; +begin + result := nil; + ct := lowercase(contenttype); + if pos('html', ct) <> 0 then + result := WebHTML; + if pos('javascript', ct) <> 0 then + result := WebJS; + if pos('xml', ct) <> 0 then + result := WebXML; + if pos('css', ct) <> 0 then + result := WebCSS; +end; + +type + TWebExts = (css, dpr, htm, html, js, json, jsie, lua, lp, pas, pasrem, php, + pl, py, rb, sql, tis, vbs, xml); + +function TCatHighlighters.GetByFileExtension(const fileext: string) + : TSynCustomHighlighter; +var + ext: string; +begin + result := WebHTML; + ext := lowercase(fileext); + if beginswith(ext, '.') then + ext := after(ext, '.'); + if ext = emptystr then + exit; + case TWebExts(GetEnumValue(TypeInfo(TWebExts), ext)) of + htm, html: + result := WebHTML; + lua, lp: + result := nil; + js, json, jsie, tis: + result := WebJS; + css: + result := WebCSS; + php: + result := WebPHP; + rb: + result := Ruby; + pas, dpr, pasrem: + result := Pascal; + pl: + result := Perl; + py: + result := Python; + sql: + result := SQLSyn; + vbs: + result := VBScript; + xml: + result := WebXML; + end; +end; + +procedure TCatHighlighters.SetCodeRayColors(const e: TSynWebEngine); +begin + e.mltagnameattri.foreground := $00007700; + e.mltagnameundefattri.foreground := $00007700; + e.mltagattri.foreground := $00007700; + e.mltagkeyattri.foreground := $008844BB; + e.mltagkeyundefattri.foreground := $008844BB; + e.mltagkeyundefattri.Style := e.mltagkeyundefattri.Style - [fsUnderline]; + e.mltagkeyvalueattri.foreground := $000022DD; + e.mltagkeyvaluequotedattri.foreground := $000022DD; + e.mlerrorattri.Style := e.mlerrorattri.Style - [fsUnderline]; + e.mlerrorattri.foreground := $00007700; + e.eskeyattri.foreground := $00008800; + e.esidentifierattri.foreground := clBlack; + e.esnumberattri.foreground := $00DD0000; + e.escommentattri.foreground := $00777777; + e.eswhitespaceattri.background := $00E0E0E0; + e.cssselectorattri.foreground := $00993333; + e.csspropattri.foreground := $00660066; + e.csspropundefattri.foreground := $00660066; + e.cssselectorclassattri.foreground := $006600BB; + e.cssselectoridattri.foreground := $0000AA00; + e.cssrulesetwhitespaceattri.background := clNone; + e.csswhitespaceattri.background := clNone; + e.csscommentattri.foreground := $00777777; + e.cssvalattri.foreground := $00888800; + e.cssvalundefattri.foreground := $00888800; + e.cssvalundefattri.Style := e.cssvalundefattri.Style - [fsUnderline]; + e.csserrorattri.foreground := $000000FF; + e.csserrorattri.Style := e.csserrorattri.Style - [fsUnderline]; + e.cssvalnumberattri.foreground := $0000AA00; + e.CssValStringAttri.foreground := $000022DD; + e.phpstringattri.foreground := $000022DD; + e.phpstringspecialattri.foreground := $000022DD; + e.phpvariableattri.foreground := $00008800; + e.phpfunctionattri.foreground := $00996633; + e.phpfunctionattri.Style := e.phpfunctionattri.Style + [fsBold]; + e.phpkeyattri.foreground := $00008800; + e.specialattri.phpmarker.foreground := $00666666; + e.phpcommentattri.foreground := $00777777; + e.phpdoccommentattri.foreground := $00777777; + e.phpidentifierattri.foreground := $00BB6600; + e.phpidentifierattri.Style := e.phpidentifierattri.Style + [fsBold]; + e.PhpNumberAttri.foreground := $00DD0000; +end; + +constructor TCatHighlighters.Create(AOwner: TObject); +begin + inherited Create; + Ruby := TSynRubySyn.Create(nil); + Pascal := TSynPasSyn.Create(nil); + Perl := TSynPerlSyn.Create(nil); + Python := TSynPythonSyn.Create(nil); + VBScript := TSynVBScriptSyn.Create(nil); + SQLSyn := TSynSQLSyn.Create(nil); + fSynWebEngine := TSynWebEngine.Create(nil); + fSynWebEngine.Options.CssVersion := scvCSS3; + WebHTML := TSynWebHtmlSyn.Create(nil); + WebHTML.Engine := fSynWebEngine; + WebHTML.Options.PhpEmbeded := false; + WebPHP := TSynWebPHPPlainSyn.Create(nil); + WebPHP.Engine := fSynWebEngine; + WebJS := TSynWebESSyn.Create(nil); + WebJS.Engine := fSynWebEngine; + WebCSS := TSynWebCSSSyn.Create(nil); + WebCSS.Engine := fSynWebEngine; + WebCSS.Options.CssVersion := scvCSS3; + WebXML := TSynWebXMLSyn.Create(nil); + WebXML.Engine := fSynWebEngine; + SetCodeRayColors(fSynWebEngine); +end; + +destructor TCatHighlighters.Destroy; +begin + inherited; +end; + +end. diff --git a/src/CatInet.pas b/src/CatInet.pas new file mode 100644 index 0000000..e25d119 --- /dev/null +++ b/src/CatInet.pas @@ -0,0 +1,196 @@ +unit CatInet; +{ + Catarinka - Internet related functions + + Copyright (c) 2003-2014 Felipe Daragon + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details + + GetTinyUrl function by Rodrigo Ruz V., released under the MIT license +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + Winapi.Windows, Winapi.WinSock, System.SysUtils, System.Win.Registry, + Winapi.WinInet; +{$ELSE} + Windows, WinSock, SysUtils, Registry, WinInet; +{$IFEND} + +function GetAbsoluteURL(const baseURL, relURL: string): string; +function GetTinyUrl(const URL: string): string; +function IPAddrToName(const IP: string): string; +function IsValidIP(const IP: string): Boolean; +function NameToIPAddr(const name: string): string; +procedure DisableProxy(const agent: string); +procedure EnableProxy(const agent, proxy: string); +procedure IESettingsChanged(const agent: string); + +implementation + +uses CatStrings; + +procedure DisableProxy(const agent: string); +var + Reg: TRegistry; +begin + Reg := TRegistry.Create; + try + Reg.RootKey := HKEY_CURRENT_USER; + if Reg.OpenKey + ('\Software\Microsoft\Windows\CurrentVersion\Internet Settings', True) + then + begin + Reg.WriteInteger('ProxyEnable', 0); + Reg.CloseKey; + end; + finally + Reg.Free; + end; + IESettingsChanged(agent); +end; + +procedure EnableProxy(const agent, proxy: string); +var + Reg: TRegistry; +begin + Reg := TRegistry.Create; + try + Reg.RootKey := HKEY_CURRENT_USER; + if Reg.OpenKey + ('\Software\Microsoft\Windows\CurrentVersion\Internet Settings', True) + then + begin + Reg.WriteString('ProxyServer', proxy); // format: proxy:proxyport + Reg.WriteInteger('ProxyEnable', 1); + Reg.CloseKey; + end; + finally + Reg.Free; + end; + IESettingsChanged(agent); +end; + +// Usage example: +// GetAbsoluteURL('http://someurl.com/demo/','/index.html') +// will return http://someurl.com/index.html +function GetAbsoluteURL(const baseURL, relURL: string): string; + procedure TruncateStr(var s: string); + var + i: Integer; + begin + for i := 1 to length(s) do + if (s[i] = #0) then + begin + SetLength(s, i - 1); + Exit; + end; + end; + +var + buflen: DWORD; +begin + buflen := 10240; + SetLength(Result, buflen); + InternetCombineUrl( +{$IFDEF UNICODE}PWideChar{$ELSE}PChar{$ENDIF}(baseURL), +{$IFDEF UNICODE}PWideChar{$ELSE}PChar{$ENDIF}(relURL), +{$IFDEF UNICODE}PWideChar{$ELSE}PChar{$ENDIF}(Result), buflen, + ICU_BROWSER_MODE); + TruncateStr(Result); + // workaround, ipv6 + Result := replacestr(Result, '%5B', '['); + Result := replacestr(Result, '%5D', ']'); +end; + +procedure IESettingsChanged(const agent: string); +var + HInet: HINTERNET; +begin + HInet := InternetOpen({$IFDEF UNICODE}PWideChar{$ELSE}PChar{$ENDIF}(agent), + INTERNET_OPEN_TYPE_DIRECT, nil, nil, INTERNET_FLAG_OFFLINE); + try + if HInet <> nil then + InternetSetOption(HInet, INTERNET_OPTION_SETTINGS_CHANGED, nil, 0); + finally + InternetCloseHandle(HInet); + end; +end; + +function IPAddrToName(const IP: string): string; +var + WSAData: TWSAData; + HostEnt: PHostEnt; + Addr: Longint; +begin + Result := EmptyStr; + if WSAStartup(MakeWord(1, 1), WSAData) <> 0 then + Exit; + Addr := inet_addr({$IFDEF UNICODE}PAnsiChar{$ELSE}PChar{$ENDIF}(IP)); + HostEnt := gethostbyaddr(@Addr, 4, PF_INET); + if HostEnt = nil then + Exit; + + Result := HostEnt^.h_name; + WSACleanup; +end; + +function IsValidIP(const IP: string): Boolean; +begin + Result := ((IP <> emptystr) and + (inet_addr({$IFDEF UNICODE}PAnsiChar{$ELSE}PChar{$ENDIF}(IP)) <> + INADDR_NONE)); +end; + +function NameToIPAddr(const name: string): string; +var + PHostEntry: PHostEnt; + InAddr: PInAddr; +begin + PHostEntry := gethostbyname + ({$IFDEF UNICODE}PAnsiChar{$ELSE}PChar{$ENDIF}(name)); + if PHostEntry <> nil then + begin + InAddr := Pointer(PHostEntry^.h_addr_list^); + NameToIPAddr := inet_ntoa(InAddr^); + end + else + NameToIPAddr := emptystr; +end; + +// By Rodrigo Ruz (MIT license) +function GetTinyUrl(const URL: string): string; +const + tinyurl = 'http://tinyurl.com/api-create.php?url=%s'; + BuffSize = 2048; +var + hInter, UrlHandle: HINTERNET; + BytesRead: Cardinal; + Buffer: Pointer; +begin + Result := emptystr; + hInter := InternetOpen('', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0); + if Assigned(hInter) then + begin + GetMem(Buffer, BuffSize); + try + UrlHandle := InternetOpenUrl(hInter, PChar(Format(tinyurl, [URL])), nil, + 0, INTERNET_FLAG_RELOAD, 0); + if Assigned(UrlHandle) then + begin + InternetReadFile(UrlHandle, Buffer, BuffSize, BytesRead); + if BytesRead > 0 then + SetString(Result, PAnsiChar(Buffer), BytesRead); + InternetCloseHandle(UrlHandle); + end; + finally + FreeMem(Buffer); + end; + InternetCloseHandle(hInter); + end +end; + +// ------------------------------------------------------------------------// +end. diff --git a/src/CatJINI.pas b/src/CatJINI.pas new file mode 100644 index 0000000..3bb4c50 --- /dev/null +++ b/src/CatJINI.pas @@ -0,0 +1,297 @@ +unit CatJINI; +{ + Catarinka TJIniList - JSON INIList-Like component + + Copyright (c) 2010-2014 Felipe Daragon + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details + + This component was made to replace the TIniList component. + It is also similar to TStringList (with the property Values, Strings and Count). + + TODO: Needs some cleanup +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + System.SysUtils, System.Classes, Winapi.Windows, +{$ELSE} + Classes, SysUtils, Windows, +{$IFEND} + Superobject; + +type + TJIniList = class + private + fBackup: Boolean; + fFileName: string; + fModified: Boolean; + fObject: ISuperObject; + function GetVersion: string; + function GetJSONLines: string; + procedure SetJSONLines(json: string); + function GetValue(const Key: string): string; + procedure SetValue(const Key: string; const Value: string); + function GetCount: integer; + function FixKeyValue(s: string): string; + public + constructor Create; + destructor Destroy; override; + function SaveJSON: Boolean; overload; + function SaveJSON(const FileName: string): Boolean; overload; + procedure Clear; + function LoadJSON: Boolean; overload; + function LoadJSON(const FileName: string): Boolean; overload; + function ReadString(Section, Key, default: string): string; + procedure WriteString(Section, Key, Value: string; Format: string = ''); + function ReadInteger(const Section, Key: string; default: integer): integer; + procedure WriteInteger(const Section, Key: string; Value: integer); + function ReadBool(const Section, Key: string; default: Boolean): Boolean; + procedure WriteBool(const Section, Key: string; Value: Boolean); + procedure DeleteSection(Section: string); + procedure DeleteSectionKey(Section, Key: string); + procedure AddString(const Section, Key, Value: String; + AddIfRepeated: Boolean); + // properties + property Backup: Boolean read fBackup write fBackup; + property Count: integer read GetCount; + property FileName: string read fFileName write fFileName; + property Text: string read GetJSONLines write SetJSONLines; + property Values[const Key: string]: string read GetValue + write SetValue; default; + property Version: string read GetVersion; + property sObject: ISuperObject read fObject; + published + end; + +implementation + +uses CatStrings; + +const + cBase64 = 'base64'; + cFormatKey = '.format'; + cValuesSection = 'data'; + cVersion = '1.0'; + + { TJIniList } + +function TJIniList.FixKeyValue(s: string): string; +begin + Result := ReplaceStr(s, '.', '_dot_'); // dots not allowed + Result := lowercase(Result); +end; + +function TJIniList.GetValue(const Key: string): string; +begin + Result := ReadString(cValuesSection, Key, emptystr); +end; + +procedure TJIniList.SetValue(const Key: string; const Value: string); +begin + WriteString(cValuesSection, Key, Value); +end; + +function TJIniList.GetJSONLines: string; +begin + Result := fObject.AsJson(true); +end; + +procedure TJIniList.SetJSONLines(json: string); +begin + fObject := nil; + fObject := TSuperObject.ParseString(StrToPWideChar(json), false) +end; + +constructor TJIniList.Create; +begin + inherited Create; + fBackup := false; + fObject := TSuperObject.Create(stObject); +end; + +procedure TJIniList.Clear; +begin + fObject.Clear; +end; + +destructor TJIniList.Destroy; +begin + fObject := nil; + inherited; +end; + +function TJIniList.LoadJSON: Boolean; +begin + Result := LoadJSON(fFileName); +end; + +function TJIniList.LoadJSON(const FileName: string): Boolean; +var + Stream: TStream; + FLines: TStringlist; +begin + Result := false; + FLines := TStringlist.Create; + if FileName <> emptystr then + begin + Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone); + try + FLines.LoadFromStream(Stream); + SetJSONLines(FLines.Text); + Result := true; + except + Result := false; + end; + Stream.Free; + end; + FLines.Free; +end; + +function TJIniList.GetVersion: string; +begin + Result := cVersion; +end; + +function TJIniList.ReadBool(const Section, Key: string; + default: Boolean): Boolean; +begin + Result := Boolean(ReadInteger(Section, Key, integer(default))); +end; + +function TJIniList.ReadInteger(const Section, Key: string; + default: integer): integer; +begin + Result := StrToInt(ReadString(Section, Key, IntToStr(default))); +end; + +function TJIniList.SaveJSON: Boolean; +begin + Result := SaveJSON(fFileName); +end; + +function TJIniList.SaveJSON(const FileName: string): Boolean; +var + SL: TStringlist; + Stream: TStream; +begin + Result := false; + if fBackup then + CopyFile( +{$IFDEF UNICODE}PWideChar{$ELSE}Pchar{$ENDIF}(FileName), +{$IFDEF UNICODE}PWideChar{$ELSE}Pchar{$ENDIF}(FileName + '.bak'), false); + if FileName = emptystr then + exit; + if fileexists(FileName) = false then + begin + Stream := TFileStream.Create(FileName, fmCreate or fmOpenWrite or + fmShareDenyWrite); + Stream.Free; + end; + SL := TStringlist.Create; + SL.Text := fObject.AsJson(true); + Stream := TFileStream.Create(FileName, fmOpenWrite or fmShareDenyWrite); + Stream.size := 0; + try + SL.SaveToStream(Stream); + Result := true; + except + Result := false; + end; + Stream.Free; + SL.Free; + + fModified := false; +end; + +procedure TJIniList.WriteBool(const Section, Key: string; Value: Boolean); +begin + WriteInteger(Section, Key, integer(Value)); +end; + +procedure TJIniList.WriteInteger(const Section, Key: string; Value: integer); +begin + WriteString(Section, Key, IntToStr(Value)); +end; + +procedure TJIniList.WriteString(Section, Key, Value: string; + Format: string = ''); +var + sk: string; +begin + Section := FixKeyValue(Section); + Key := FixKeyValue(Key); + sk := Section + '.' + Key; + if ReadString(Section, Key, emptystr) = Value then + exit; + if Format <> emptystr then + fObject.s[sk + cFormatKey] := Format; + if Format = cBase64 then + Value := Base64EnCode(Value); + fObject.s[sk] := Value; + fModified := true; +end; + +function TJIniList.ReadString(Section, Key, default: string): string; +var + fmt: string; + sk: string; +begin + Section := FixKeyValue(Section); + Key := FixKeyValue(Key); + sk := Section + '.' + Key; + Result := default; + if fObject.s[sk] <> emptystr then + Result := fObject.s[sk] + else + Result := default; + if fObject.s[sk + cFormatKey] <> emptystr then + begin + fmt := fObject.s[sk + cFormatKey]; + if fmt = cBase64 then + Result := Base64DeCode(Result); + end; +end; + +procedure TJIniList.AddString(const Section, Key, Value: String; + AddIfRepeated: Boolean); +var + SL: TStringlist; +begin + SL := TStringlist.Create; + SL.commatext := ReadString(Section, Key, emptystr); + if AddIfRepeated = true then + SL.Add(Value) + else + begin + if SL.indexof(Value) = -1 then + SL.Add(Value); + end; + WriteString(Section, Key, SL.commatext); + SL.Free; +end; + +procedure TJIniList.DeleteSection(Section: string); +begin + Section := FixKeyValue(Section); + fObject.o[Section].Clear; + fModified := true; +end; + +procedure TJIniList.DeleteSectionKey(Section, Key: string); +begin + Section := FixKeyValue(Section); + Key := FixKeyValue(Key); + fObject.o[Section + '.' + Key].Clear; + fModified := true; +end; + +function TJIniList.GetCount: integer; +begin + Result := 0; + // TODO: not implemented yet +end; + +end. diff --git a/src/CatJSON.pas b/src/CatJSON.pas new file mode 100644 index 0000000..c7fa600 --- /dev/null +++ b/src/CatJSON.pas @@ -0,0 +1,225 @@ +unit CatJSON; + +{ + Catarinka TCatJSON - JSON Manipulation Object + Copyright (c) 2010-2014 Felipe Daragon + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details + + 2013: + - Added the HasPath method + - Changed the default property from string to variant + + TODO: + - Count property not fully implemented. + - IncVal(), & SetValInt() may need revision +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + System.Classes, System.SysUtils, System.Variants, +{$ELSE} + Classes, SysUtils, Variants, +{$IFEND} + SuperObject; + +const + EmptyJSONStr = '{}'; + +type + TCatJSON = class + private + fCount: integer; + fObject: ISuperObject; + function GetText: string; + function GetTextUnquoted: string; + public + function GetVal(const Name: string): Variant; + function GetValue(const Name: string; DefaultValue: Variant): Variant; + function HasPath(const Name: string): Boolean; + procedure LoadFromFile(const Filename: string); + procedure SaveToFile(const Filename: string); + procedure SetText(const Text: string); + procedure SetVal(const Name: string; const Value: Variant); + procedure IncVal(const Name: string; Int: integer = 1); + procedure SetValInt(const Name: string; const Value: integer); + procedure Clear; + constructor Create(JSON: string = ''); + destructor Destroy; override; + // properties + property Count: integer read fCount; + property IntVal[const Name: string]: integer write SetValInt; + property sObject: ISuperObject read fObject; + property Text: string read GetText write SetText; + property TextUnquoted:string read GetTextUnquoted; // JSON with UnquotedKeys + property Val[const Name: string]: Variant read GetVal write SetVal; default; + published + end; + +function CatVariant(Text, ValName: string): Variant; +function IsValidJSONName(const S: string): Boolean; + +implementation + +uses CatFiles, CatStrings; + +function IsValidJSONName(const s: string): Boolean; +const + cJSONChars = ['-', '_', 'a' .. 'z', 'A' .. 'Z', '0' .. '9']; +var + i: integer; +begin + Result := True; + for i := 1 to Length(S) do + if not(S[i] in cJSONChars) then + begin + Result := False; + Break; + end; +end; + +function CatVariant(Text, ValName: string): Variant; +var + d: TCatJSON; +begin + d := TCatJSON.Create; + d.Text := Text; + Result := d[ValName]; + d.Free; +end; + +function TCatJSON.GetTextUnquoted: string; +var + ite: TSuperObjectIter; +begin + Result := '{'; + if ObjectFindFirst(fObject, ite) then + repeat + Result := Result + crlf + ite.key + ': ' + ite.Val.AsJson + ','; + until not ObjectFindNext(ite); + ObjectFindClose(ite); + Result := Result + '}'; +end; + +function TCatJSON.GetText: string; +begin + Result := fObject.AsJson(True); +end; + +procedure TCatJSON.LoadFromFile(const Filename: string); +var + sl: tstringlist; +begin + sl := tstringlist.Create; + SL_LoadFromFile(sl, Filename); + SetText(sl.Text); + sl.Free; +end; + +procedure TCatJSON.SaveToFile(const Filename: string); +var + sl: tstringlist; +begin + sl := tstringlist.Create; + sl.Text := GetText; + SL_SaveToFile(sl, Filename); + sl.Free; +end; + +procedure TCatJSON.SetText(const Text: string); +begin + fObject := nil; + fCount := 0; + fObject := TSuperObject.ParseString(StrToPWideChar(Text), False); +end; + +procedure TCatJSON.Clear; +begin + fObject.Clear; + fCount := 0; +end; + +constructor TCatJSON.Create(JSON: string = ''); +begin + fObject := TSuperObject.Create(stObject); + if JSON <> emptystr then + Text := JSON; +end; + +destructor TCatJSON.Destroy; +begin + fObject := nil; + inherited; +end; + +procedure TCatJSON.IncVal(const Name: string; Int: integer = 1); +var + i: integer; +begin + if fObject.S[name] = '' then + i := 0 + else + i := strtoint(fObject.S[name]); + i := i + Int; + fObject.S[name] := inttostr(i); + inc(fCount); +end; + +procedure TCatJSON.SetVal(const Name: string; const Value: Variant); +begin + case TVarData(Value).vType of + varString, {$IFDEF UNICODE}varUString, {$ENDIF}varOleStr: + fObject.S[name] := Value; + varBoolean: + fObject.b[name] := Value; + varInteger, varInt64: + fObject.i[name] := Value; + varDouble: + fObject.d[name] := Value; + end; + inc(fCount); +end; + +function TCatJSON.HasPath(const Name: string): Boolean; +begin + Result := False; + if fObject.O[name] <> nil then + Result := True; +end; + +function TCatJSON.GetValue(const Name: string; + DefaultValue: Variant): Variant; +begin + Result := DefaultValue; + if HasPath(Name) then + begin + case fObject.O[name].DataType of + stNull: + Result := DefaultValue; + stBoolean: + Result := fObject.b[Name]; + stDouble: + Result := fObject.d[Name]; + stInt: + Result := fObject.i[Name]; + stString: + Result := fObject.S[Name]; + stObject, stArray, stMethod: + Result := DefaultValue; + end; + end; +end; + +function TCatJSON.GetVal(const Name: string): Variant; +begin + Result := GetValue(name, null); +end; + +procedure TCatJSON.SetValInt(const Name: string; const Value: integer); +begin + SetVal(name, inttostr(Value)); +end; + +end. diff --git a/src/CatListEditor.pas b/src/CatListEditor.pas new file mode 100644 index 0000000..a25520a --- /dev/null +++ b/src/CatListEditor.pas @@ -0,0 +1,584 @@ +unit CatListEditor; +{ + Catarinka TCatListEditor + A fork of super.pas (TSuperList 1.7) with enhancements + Copyright (c) 2003-2014 Felipe Daragon + + License: 4-clause BSD, same license as the original code by Spanware Inc. + + Original Author: David Koretzky + Copyright (c) 1999 Spanware Inc. +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, + Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, + Vcl.StdCtrls, Vcl.ImgList, Vcl.Buttons, Vcl.Menus; +{$ELSE} + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + ExtCtrls, StdCtrls, ImgList, Buttons, Menus; +{$IFEND} + +type + TListBoxAlignment = (lbBottom, lbLeft ,lbRight, lbTop); //added all four alignments + TEnabledButton = (Plus, Minus); + FEnabledButtons = set of TEnabledButton; + +type + TCatListEditor = class(TCustomControl) + private + //the list box + FListBox : TListBox; + FListBoxAlignment : TListBoxAlignment; + FListBoxChanged : Boolean; + + //panel for holding the buttons + FPanel : TPanel; + + //the add and delete buttons + FAddButton : TSpeedButton; + FDeleteButton : TSpeedButton; + FMoreButton : TSpeedButton; + FMorePopupMenu : TPopupMenu; + FLoadFromFileItem:TMenuItem; + FSaveToFileItem:TMenuItem; + FClearItemSeparator:TMenuItem; + FClearItem:TMenuItem; + FSaveDialog:TSaveDialog; + FOpenDialog:TOpenDialog; + + //the events + FOnAddButtonClick: TNotifyEvent; + FOnDeleteButtonClick: TNotifyEvent; + FOnListBoxDoubleClick : TNotifyEvent; + FOnListBoxKeyDown : TNotifyEvent; + + FAddString : string; + FAddCaption : string; + FEditString : string; + FEditCaption : string; + + FMaxLength : Integer; //max length of string in listbox + FMaxCount : Integer; //max number of entries allowed in listbox + FAllowBlanks : boolean; //are blanks allowed in the listbox + FUseKeyMaps : boolean; //use default key strokes for adding, editing and deleting??? + + procedure WMSize(var Message: TWMSize); message WM_SIZE; + procedure AddBtnClick(Sender : TObject); + procedure DeleteBtnClick(Sender : TObject); + procedure ListBoxDoubleClick(Sender : TObject); + procedure ListBoxKeyDown(Sender : TObject; var Key : word; shift : TShiftState); + procedure SaveToFileItemClick(Sender : TObject); + procedure LoadFromFileItemClick(Sender : TObject); + procedure ClearItemClick(Sender : TObject); + procedure MoreBtnClick(Sender:TObject); + + procedure CreateButtons; + procedure CreatePanel; + procedure EnableButtons; + + procedure SetAlignment(value : TListBoxAlignment); + + function GetListBoxFont : TFont; + procedure SetListBoxFont(value : TFont); + + function GetListBoxItems : TStrings; + procedure SetListBoxItems(value : TStrings); + + function GetListBoxItemIndex : Integer; + procedure SetListBoxItemIndex(value : integer); + + public + FLabel : TLabel; + FCustomImageList: TCustomImageList; // FD + FAddImageIndex:integer;// FD + FDelImageIndex:integer;// FD + FMoreImageIndex:integer;// FD + constructor Create(AOwner : TComponent); override; + destructor Destroy; override; + procedure Delete; + function GetCurrentString : String; + property ListBoxItemIndex : Integer read GetListBoxItemIndex write SetListBoxItemIndex; + property ListBox : TListBox read FListBox write FListBox; + property ListBoxChanged : boolean read FListBoxChanged write FListBoxChanged default false; + procedure AddItems(value : TStrings); + published + property AddPrompt : string read FAddString write FAddString; + property AddCaption : string read FAddCaption write FAddCaption; + property Align; + property AllowBlanks : boolean read FAllowBlanks write FAllowBlanks default false; + property EditPrompt : string read FEditString write FEditString; + property EditCaption : string read FEditCaption write FEditCaption; + property ListBoxAlignment : TListBoxAlignment read FListBoxAlignment write SetAlignment default lbBottom; + property ListBoxFont : TFont read GetListBoxFont write SetListBoxFont; + property ListBoxItems : TStrings read GetListBoxItems write SetListBoxItems; + property MaxLength : Integer read FMaxLength write FMaxLength default 0; + property MaxCount : Integer read FMaxCount write FMaxCount default 0; + property OnAddClick: TNotifyEvent read FOnAddButtonClick write FOnAddButtonClick; + property OnDeleteClick: TNotifyEvent read FOnDeleteButtonClick write FOnDeleteButtonClick; + property OnListBoxDoubleClick : TNotifyEvent read FOnListBoxDoubleClick write FOnListBoxDoubleClick; + property OnListBoxKeyDown : TNotifyEvent read FOnListBoxKeyDown write FOnListBoxKeyDown; + property UseDefaultKeyMaps : boolean read FUsekeyMaps write FUseKeyMaps default false; + end; + +procedure Register; +function ShowEditListDialog(const PrevText:string;const egtext:string;const TituloJanela: TCaption; const TituloLabel: TCaption; var S: String):boolean; + +implementation + +procedure Register; +begin + RegisterComponents('Samples', [TCatListEditor]); +end; + +function ShowEditListDialog(const PrevText:string;const egtext:string;const TituloJanela: TCaption; const TituloLabel: TCaption; var S: String):boolean; +var +Form: TForm; +Edt: TCatListEditor; +begin + Result := false; + Form := TForm.Create(Application); + try + Form.BorderStyle := bsDialog; + Form.Caption := TituloJanela; + Form.Position := poScreenCenter; + Form.Width := 350; + Form.Height := 220; + + with TLabel.Create(Form) do + begin + Parent := Form; + Caption := TituloLabel; + Left := 10; + Top := 10; + end; + + Edt := TCatListEditor.Create(Form); + with Edt do + begin + Parent := Form; + ListboxItems.Text := PrevText; + FLabel.Caption:=egtext; + Left := 10; + Top := 25; + height := 119; + Width := Form.ClientWidth -20; + end; + + with TButton.Create(Form) do + begin + Parent := Form; + Caption := '&OK'; + Left := trunc((Form.ClientWidth)/2)-100; + Top := 155; + default:=true; + modalresult:=mrOk; + //Kind := bkOK; + end; + + with TButton.Create(Form) do + begin + Parent := Form; + Caption := 'Cancel'; + Left := trunc((Form.ClientWidth)/2)+30; + Top := 155; + modalresult:=mrCancel; + end; + + if Form.ShowModal = mrOK then + begin + S := Edt.Listboxitems.Text; + Result := true; + end; + finally + Form.Free; +end; +end; + +function NewInputBox(const TituloJanela:TCaption; const TituloLabel:TCaption; const PrevText:string):string; +var +Form: TForm; +Edt: TEdit; +begin + Result := prevtext; + Form := TForm.Create(Application); + try + Form.BorderStyle := bsDialog; + Form.Caption := TituloJanela; + Form.Position := poScreenCenter; + Form.Width := 350; + Form.Height := 120; + + with TLabel.Create(Form) do + begin + Parent := Form; + Caption := TituloLabel; + Left := 10; + Top := 10; + end; + + Edt := TEdit.Create(Form); + with Edt do + begin + Parent := Form; + Text := PrevText; + Left := 10; + Top := 25; + Width := Form.ClientWidth -20; + end; + + with TButton.Create(Form) do + begin + Parent := Form; + Caption := '&OK'; + Left := trunc((Form.ClientWidth)/2)-100; + Top := 55; + default:=true; + modalresult:=mrOk; + end; + + with TButton.Create(Form) do + begin + Parent := Form; + Caption := 'Cancel'; + Left := trunc((Form.ClientWidth)/2)+30; + Top := 55; + modalresult:=mrCancel; + end; + + if Form.ShowModal = mrOK then + result := Edt.Text; + + finally + Form.Free; +end; +end; + + +constructor TCatListEditor.Create(AOwner : TComponent); +begin + inherited Create(AOwner); + Width := 250; + Height := 200; + ControlStyle := ControlStyle + [csAcceptsControls]; + + FListBox := TListBox.Create(Self); + FListBox.Parent := Self; + FListbox.ctl3d:=true; + FListBox.Visible := true; + FListBox.Width := 250; FListBox.Height := 170; + FListBox.Top := 20; FListBox.Left := 0; + FListBox.Align := alClient; + FListBox.OnDblClick := ListBoxDoubleClick; + FListBox.OnKeyDown := ListBoxKeyDown; + + CreatePanel; + CreateButtons; + + FAddCaption := 'Input'; + FAddString := 'Enter New Value:'; + FEditCaption := 'Edit'; + FEditString := 'Edit Value'; +end; + + +procedure TCatListEditor.CreatePanel; +begin + FPanel := TPanel.Create(Self); + FPanel.Parent := Self; + FPanel.Visible := true; + FPanel.Align := alTop; + FPanel.Caption := ''; + FPanel.BevelInner := bvNone; + FPanel.BevelOuter := bvNone; + FPanel.Height := 35; + + FLabel := TLabel.Create(Self); + FLabel.Parent := FPanel; + Flabel.Font.Style:=[fsBold]; + FLabel.Visible := true; + Flabel.Caption:=''; + Flabel.Left:=0; + Flabel.Top:=8; + +end; + +procedure TCatListEditor.LoadFromFileItemClick(Sender:TObject); +begin + if not FOpenDialog.Execute then exit; + if fileexists(Fopendialog.FileName) then + Flistbox.Items.LoadFromFile(Fopendialog.FileName); +end; + +procedure TCatListEditor.SaveToFileItemClick(Sender:TObject); +begin + if not FSaveDialog.Execute then exit; + try Flistbox.Items.SaveToFile(Fsavedialog.FileName); except end; +end; + +procedure TCatListEditor.ClearItemClick(Sender:TObject); +begin + Flistbox.Items.clear; +end; + +procedure TCatListEditor.MoreBtnClick(Sender:TObject); +var + P : TPoint; +begin + P := FmoreButton.ClientToScreen(Point(0, FmoreButton.Height)); + FMorePopupMenu.Popup(P.x, P.y); +end; + +procedure TCatListEditor.CreateButtons; +const + cDefFilter='List files (*.lst)|*.lst|Text files (*.txt)|*.txt|All files (*.*)|*.*'; +begin + FMorePopupMenu := TPopupMenu.Create(Self); + FLoadFromFileItem:=tmenuitem.create(FMorePopupMenu); + FLoadFromFileItem.Caption:='Load from file...'; + FLoadFromFileItem.OnClick:=LoadFromFileItemClick; + FSaveToFileItem:=tmenuitem.create(FMorePopupMenu); + FSaveToFileItem.Caption:='Save to file...'; + FSaveToFileItem.OnClick:=SaveToFileItemClick; + FClearItem:=tmenuitem.create(FMorePopupMenu); + FClearItem.Caption:='Clear'; + FClearItem.OnClick:=ClearItemClick; + FClearItemSeparator:=tmenuitem.create(FMorePopupMenu); + FClearItemSeparator.Caption:='-'; + FMorePopupMenu.Items.Add(FLoadFromFileItem); + FMorePopupMenu.Items.Add(FSaveToFileItem); + FMorePopupMenu.items.add(FClearItemSeparator); + FMorePopupMenu.items.add(FClearItem); + FSaveDialog:=TSaveDialog.Create(Self); + FOpenDialog:=TOpenDialog.Create(Self); + FOpenDialog.DefaultExt:='lst'; FSaveDialog.DefaultExt:=FOpenDialog.DefaultExt; + FOpenDialog.Filter:=cDefFilter; + FSaveDialog.Filter:=cDefFilter; + + FmoreButton := TSpeedButton.Create(Self); + FmoreButton.Width := 30; + FmoreButton.Height := 25; + FmoreButton.Font.Name := 'MS Sans Serif Bold'; + FmoreButton.Font.Size := 8; + FmoreButton.Caption := 'More'; + FmoreButton.Parent := FPanel; + FmoreButton.Top := 5; FMoreButton.Left := Self.Width - 95; + FmoreButton.OnClick:=MoreBtnClick; + + FaddButton := TSpeedButton.Create(Self); + FAddButton.Width := 25; + FAddButton.Height := 25; + FaddButton.Font.Name := 'MS Sans Serif Bold'; + FaddButton.Font.Size := 8; + FaddButton.Caption := '+'; + FaddButton.Parent := FPanel; + FaddButton.Top := 5; FaddButton.Left := Self.Width - 60; + FaddButton.OnClick := AddBtnClick; + + FdeleteButton := TSpeedButton.Create(Self); + FdeleteButton.Width := 25; + FDeleteButton.Height := 25; + FdeleteButton.Font.Name := 'MS Sans Serif Bold'; + FdeleteButton.Font.Size := 8; + FdeleteButton.Caption := '-'; + FdeleteButton.Parent := FPanel; + FdeleteButton.Top := 5; FdeleteButton.Left := Self.Width - 30; + FDeleteButton.OnClick := DeleteBtnClick; +end; + +destructor TCatListEditor.Destroy; +begin + FSaveDialog.free; + FOpenDialog.free; + FLoadFromFileItem.free; + FSaveToFileItem.free; + FClearItemSeparator.free; + FClearItem.free; + FMorePopupMenu.free; + FListBox.Free; + FaddButton.Free; + FdeleteButton.Free; + Fmorebutton.free; + FLabel.free; + FPanel.Free; + inherited; +end; + +procedure TCatListEditor.WMSize(var Message: TWMSize); +var + w, h: Integer; +begin + inherited; + + w := Width; + h := Height; + + if (w < 75) then Width := 75; + if (h < 75) then Height := 75; + + case FListBoxAlignment of + lbBottom, lbTop: + begin + FPanel.Height := 35; + FMoreButton.Left := Self.Width -95; + FMoreButton.Top := 5; + FaddButton.Left := Self.Width - 60; + FaddButton.Top := 5; + FdeleteButton.Left := Self.Width - 30; + FdeleteButton.Top := 5; + end; + lbLeft, lbRight: + begin + FPanel.Width := 35; + FMoreButton.Left := 5; + FMoreButton.Top := FPanel.Top +5; + FAddButton.Left := 5; + FAddButton.Top := FPanel.Top + 5; + FDeleteButton.Left := 5; + FDeleteButton.Top := FPanel.Top + 35; + end; + end; + +end; + +procedure TCatListEditor.AddBtnClick(Sender: TObject); +var s : string; +begin + s := NewInputBox(FAddCaption, FAddString, ''); + if (Length(s) <= FMaxLength ) or (FMaxLength <= 0) then + if (FAllowBlanks) or ((not FAllowBlanks) and (Length(s) > 0)) then + begin + FListBox.Items.Add(s); + FListBoxChanged := true; + end; + if Assigned(FOnAddButtonClick) then FOnAddButtonClick(Self); + EnableButtons; +end; + +procedure TCatListEditor.DeleteBtnClick(Sender : TObject); +begin + if (FListBox.ItemIndex > -1) then + begin + FListBox.Items.Delete( FListBox.ItemIndex ); + FListBoxChanged := true; + end; + if Assigned(FOnDeleteButtonClick) then FOnDeleteButtonClick(Self); + //EnableButtons; +end; + +procedure TCatListEditor.EnableButtons; +begin + FAddButton.Enabled := (FListBox.Items.Count < FMaxCount) or (FMaxCount <= 0); + FDeleteButton.Enabled := (FListBox.Items.Count > 0); +end; + +procedure TCatListEditor.ListBoxDoubleClick(Sender : TObject); +var s : string; +begin + if (FListBox.ItemIndex < 0) then + exit; + + s := NewInputBox(FEditCaption, FEditString, FListBox.Items[FListBox.ItemIndex]); + if ( s <> FListBox.Items[FListBox.ItemIndex] ) then + begin + if (Length(s) < FMaxLength) or (FMaxLength <= 0) then + if (FAllowBlanks) or ((not FAllowBlanks) and (Length(s) > 0)) then + begin + FListBox.Items [FListBox.ItemIndex] := s; + FListBoxChanged := true; + end; + if Assigned(FOnListBoxDoubleClick) then FOnListBoxDoubleClick(Self); + end; +end; + +procedure TCatListEditor.SetAlignment(value : TListBoxAlignment ); +begin + FListBoxAlignment := value; + FListBox.Align := alClient; + case value of + lbLeft: FPanel.Align := alRight; + lbTop: FPanel.Align := alBottom; + lbRight : FPanel.Align := alLeft; + lbBottom : FPanel.Align := alTop; + end; + + SendMessage(Self.Handle, WM_SIZE, 0, 0); //call resize to realign everything +end; + +function TCatListEditor.GetListBoxFont : TFont; +begin + result := FListBox.Font; +end; + +procedure TCatListEditor.SetListBoxFont(value : TFont); +begin + FListBox.Font.Assign(value); +end; + +function TCatListEditor.GetListBoxItems : TStrings; +begin + result := FListBox.Items; +end; + +procedure TCatListEditor.SetListBoxItems(value : TStrings); +begin + FListBox.Items.Assign(value); +end; + +procedure TCatListEditor.SetListBoxItemIndex(value : integer); +begin + FListBox.ItemIndex := value; +end; + +function TCatListEditor.GetListBoxItemIndex : integer; +begin + result := FListBox.ItemIndex; +end; + +procedure TCatListEditor.Delete; +begin + if (FListBox.ItemIndex > -1) then + begin + FListBox.Items.Delete(FListBox.ItemIndex); + FListBoxChanged := true; + end; +end; + +function TCatListEditor.GetCurrentString : String; +begin + if (FListBox.ItemIndex > -1) then + result := FListBox.Items[ FListBox.ItemIndex] + else + result := ''; +end; + + +procedure TCatListEditor.ListBoxKeyDown(Sender : TObject; var Key : word; shift : TShiftState); +begin + if (FUseKeyMaps) then + begin + if (ssCtrl in shift) then + case key of + ord('a'), ord('A') : AddBtnClick(Sender); + ord('e'), ord('E') : ListBoxDoubleClick(Sender); + ord('d'), ord('D') : DeleteBtnClick(Sender); + end; + + if (key = 13) then + ListBoxDoubleClick(Sender); + + end; + + if Assigned(FOnListBoxKeyDown) then + FOnListBoxKeyDown(Sender); +end; + +procedure TCatListEditor.AddItems(value : TStrings); +begin + FListBox.Items.AddStrings(value); +end; + +end. diff --git a/src/CatLuaObject.pas b/src/CatLuaObject.pas new file mode 100644 index 0000000..a48861f --- /dev/null +++ b/src/CatLuaObject.pas @@ -0,0 +1,512 @@ +unit CatLuaObject; + +{ + pLua's LuaObject.pas fork + + Copyright (c) 2010-2014 Felipe Daragon + License: MIT (http://opensource.org/licenses/mit-license.php) + Same as the original code by Jeremy Darling. +} + +{$IFDEF FPC} +{$mode objfpc}{$H+} +{$ENDIF} + +interface + +uses + +{$IF CompilerVersion >= 23} // XE2 or higher + System.SysUtils, System.Classes, System.Variants, +{$ELSE} + Classes, SysUtils, Variants, +{$IFEND} + Lua, pLuaObject, pLua; + +type + TCatLuaObject = class; + + { TCatLuaObject } + + TCatLuaObject = class + protected + L : PLua_State; + FLuaReference : integer; + FParent : TCatLuaObject; + FChildren : TList; + + function GetLuaProp(PropName : AnsiString): Variant; + procedure SetLuaProp(PropName : AnsiString; const AValue: Variant); + function GetPropValue(L : PLua_State; propName : AnsiString): Variant; virtual; + function GetPropObject(propName: AnsiString) : Boolean; virtual; + function SetPropValue(L : PLua_State; PropName : AnsiString; const AValue: Variant) : Boolean; virtual; + function SetPropObject(propName: AnsiString) : Boolean; virtual; + function PropIsObject(propName : AnsiString): Boolean; virtual; + procedure CommonCreate(LuaState : PLua_State; AParent : TCatLuaObject = nil); virtual; + public + constructor Create(LuaState : PLua_State; AParent : TCatLuaObject = nil); overload; virtual; + constructor Create(LuaState: PLua_State; LuaClassName, LuaName: AnsiString); overload; virtual; + destructor Destroy; override; + + procedure PushSelf; + + procedure CallEvent(EventName : AnsiString); overload; + function CallEvent(EventName : AnsiString; args : Array of Variant; Results: PVariantArray = nil) : Integer; overload; + function EventExists(EventName: AnsiString): Boolean; + + property LState : PLua_State read L; + property LRef:integer read FLuaReference; + + property LuaProp[PropName : AnsiString] : Variant read GetLuaProp write SetLuaProp; + end; + + TCatLuaObjectRegisterMethodsCallback = procedure(L : Plua_State; classTable : Integer); + TCatLuaObjectNewCallback = function(L : PLua_State; AParent : TCatLuaObject=nil):TCatLuaObject; + +var + LuaObjects : TList; + +procedure ClearObjects; +procedure LuaCopyTable(L: Plua_State; IdxFrom, IdxTo, MtTo : Integer); +function LuaToTCatLuaObject(L: Plua_State; Idx : Integer) : TCatLuaObject; +procedure RegisterLuaObject(L: Plua_State); + +procedure RegisterTCatLuaObject(L : Plua_State; ObjectName : AnsiString; CreateFunc : lua_CFunction; MethodsCallback : TCatLuaObjectRegisterMethodsCallback = nil); +procedure RegisterObjectInstance(L : Plua_State; aClassName, InstanceName : AnsiString; ObjectInstance : TCatLuaObject); +procedure RegisterMethod(L : Plua_State; TheMethodName : AnsiString; TheMethodAddress : lua_CFunction; classTable : Integer); +function new_LuaObject(L : PLua_State; aClassName : AnsiString; NewCallback : TCatLuaObjectNewCallback) : Integer; cdecl; + +procedure PushTCatLuaObject(L : PLua_State; ObjectInstance : TCatLuaObject); + +function new_TCatLuaObject(L : PLua_State) : Integer; cdecl; +function index_TCatLuaObject(L : PLua_State) : Integer; cdecl; +function newindex_TCatLuaObject(L : PLua_State) : Integer; cdecl; +function gc_TCatLuaObject(L : PLua_State) : Integer; cdecl; +procedure RegisterClassTCatLuaObject(L : Plua_State); + +implementation + +uses + typinfo; + +const + LuaTCatLuaObjectClassName = 'TCatLuaObject'; + +constructor TCatLuaObject.Create(LuaState : PLua_State; AParent : TCatLuaObject = nil); +begin + CommonCreate(LuaState, nil); + // Create a reference to the object table, this way lua won't GC its version + FLuaReference := luaL_ref(L, LUA_REGISTRYINDEX); + lua_rawgeti (L, LUA_REGISTRYINDEX, FLuaReference); + LuaObjects.Add(Self); +end; + +constructor TCatLuaObject.Create(LuaState: PLua_State; LuaClassName, LuaName: AnsiString); +begin + CommonCreate(LuaState, nil); + RegisterObjectInstance(LuaState, LuaClassName, LuaName, self); +end; + +destructor TCatLuaObject.Destroy; +var + lo : TCatLuaObject; +begin + LuaObjects.Remove(Self); + if assigned(FParent) then + FParent.FChildren.Remove(Self); + while FChildren.Count > 0 do + begin + lo := TCatLuaObject(FChildren[FChildren.Count-1]); + FChildren.Delete(FChildren.Count-1); + lo.Free; + end; + FChildren.Free; + luaL_unref(L, LUA_REGISTRYINDEX, FLuaReference); + inherited Destroy; +end; + +procedure TCatLuaObject.PushSelf; +begin + lua_rawgeti(L, LUA_REGISTRYINDEX, FLuaReference); +end; + +procedure TCatLuaObject.CallEvent(EventName: AnsiString); +begin + CallEvent(EventName, []); +end; + +function TCatLuaObject.CallEvent(EventName : AnsiString; args: array of Variant; Results: PVariantArray) : Integer; +begin + result := -1; + if not EventExists(EventName) then + exit; + PushSelf; + result := plua_callfunction(L, EventName, args, results, lua_gettop(L)); +end; + +function TCatLuaObject.EventExists(EventName: AnsiString): Boolean; +begin + PushSelf; + result := plua_functionexists(L, EventName, lua_gettop(L)); + lua_pop(L, 1); +end; + +function TCatLuaObject.GetLuaProp(PropName : AnsiString): Variant; +var + idx : Integer; +begin + lua_rawgeti (L, LUA_REGISTRYINDEX, FLuaReference); // Place our object on the stack + idx := lua_gettop(L); + lua_pushliteral(L, {$IFDEF UNICODE}pAnsiChar{$ELSE}PChar{$ENDIF}(PropName)); // Place the event name on the stack + lua_gettable(L, idx); // try to get the item + result := plua_tovariant(L, lua_gettop(L)); + lua_pop(L, 2); +end; + +procedure TCatLuaObject.SetLuaProp(PropName : AnsiString; const AValue: Variant); +var + idx : Integer; +begin + lua_rawgeti (L, LUA_REGISTRYINDEX, FLuaReference); // Place our object on the stack + idx := lua_gettop(L); + lua_pushstring(L, {$IFDEF UNICODE}pAnsiChar{$ELSE}PChar{$ENDIF}(propName)); + plua_pushvariant(L, AValue); + lua_rawset(L, idx); +end; + +function TCatLuaObject.GetPropValue(L : PLua_State; propName: AnsiString): Variant; +begin + if IsPublishedProp(self, propName) then + result := typinfo.GetPropValue(self, propName) + else + result := NULL; +end; + +function TCatLuaObject.GetPropObject(propName: AnsiString) : Boolean; +begin + result := false; +end; + +function TCatLuaObject.SetPropValue(L : PLua_State; PropName: AnsiString; const AValue: Variant) : Boolean; +begin + result := IsPublishedProp(self, propName); + if result then + typinfo.SetPropValue(self, propName, AValue); +end; + +function TCatLuaObject.SetPropObject(propName: AnsiString) : Boolean; +begin + result := false; +end; + +function TCatLuaObject.PropIsObject(propName: AnsiString): Boolean; +begin + result := false; +end; + +procedure TCatLuaObject.CommonCreate(LuaState: PLua_State; AParent: TCatLuaObject); +begin + L := LuaState; + FParent := AParent; + if assigned(FParent) then + FParent.FChildren.Add(Self); + FChildren := TList.Create; +end; + +{ Global LUA Methods } + +procedure LuaCopyTable(L: Plua_State; IdxFrom, IdxTo, MtTo : Integer); +var + id:Integer; + tbl : Integer; + key, val : Variant; + cf : lua_CFunction; +begin + lua_pushnil(L); + while(lua_next(L, IdxFrom)<>0)do + begin + key := plua_tovariant(L, -2); + if CompareText(key, '__') = 1 then + tbl := MtTo + else + tbl := IdxTo; + case lua_type(L, -1) of + LUA_TFUNCTION : begin + cf := lua_tocfunction(L, -1); + plua_pushvariant(L, key); + lua_pushcfunction(L, cf); + lua_rawset(L, tbl); + end; + LUA_TTABLE : begin + id := lua_gettop(L); + LuaCopyTable(L, id, IdxTo, MtTo); + end; + else + val := plua_tovariant(L, -1); + plua_pushvariant(L, key); + plua_pushvariant(L, val); + lua_rawset(L, tbl); + end; + lua_pop(L, 1); + end; +end; + +function LuaToTCatLuaObject(L: Plua_State; Idx : Integer) : TCatLuaObject; +begin + result := nil; + if lua_type(L, Idx) = LUA_TTABLE then + begin + Idx := plua_absindex(L, Idx); + lua_pushstring(L, '_Self'); + lua_gettable(L, Idx); + result := TCatLuaObject(ptrint(lua_tointeger(L, -1))); + lua_pop(L, 1); + end + else + luaL_error(L, {$IFDEF UNICODE}pAnsiChar{$ELSE}PChar{$ENDIF}('Class table expected.')); +end; + +procedure PushTCatLuaObject(L: PLua_State; ObjectInstance: TCatLuaObject); +begin + lua_rawgeti(L, LUA_REGISTRYINDEX, ObjectInstance.FLuaReference); +end; + +function new_TCatLuaObject(L : PLua_State) : Integer; cdecl; +var + P, E : TCatLuaObject; + n, idx, idx2, mt : Integer; +begin + n := lua_gettop(L); + if lua_type(L, 1) <> LUA_TTABLE then + lua_remove(L, 1); + if n = 1 then + P := LuaToTCatLuaObject(L, 1) + else + P := nil; + + lua_newtable(L); + E := TCatLuaObject.Create(L, P); + idx := lua_gettop(L); + + lua_pushliteral(L, '_Self'); + lua_pushinteger(L, PtrInt(Pointer(E))); + lua_rawset(L, idx); + + lua_newtable(L); + mt := lua_gettop(L); + + lua_pushliteral(L, LuaTCatLuaObjectClassName); + lua_gettable(L, LUA_GLOBALSINDEX); + idx2 := lua_gettop(L); + + LuaCopyTable(L, idx2, idx, mt); + lua_setmetatable(L, idx); + + lua_pop(L, 1); + + result := 1; +end; + +function index_TCatLuaObject(L : PLua_State) : Integer; cdecl; +var + E : TCatLuaObject; + propName : AnsiString; + v : Variant; +begin + E := LuaToTCatLuaObject(L, 1); + lua_remove(L, 1); + if E = nil then + begin + result := 0; + exit; + end; + propName := plua_tostring(L, 1); + index_TCatLuaObject := 1; + if E.PropIsObject(propName) then + begin + if not E.GetPropObject(propName) then + index_TCatLuaObject := 0; + end + else + begin + v := E.GetPropValue(L,propName); + if v = NULL then + index_TCatLuaObject := 0 + else + plua_pushvariant(L, v); + end; +end; + +function newindex_TCatLuaObject(L : PLua_State) : Integer; cdecl; +var + TableIndex, ValueIndex : Integer; + E : TCatLuaObject; + propName : AnsiString; +begin + result := 0; + E := LuaToTCatLuaObject(L, 1); + if E = nil then + begin + exit; + end; + propName := plua_tostring(L, 2); + if E.PropIsObject(propName) and E.SetPropObject(propName) then + else if not E.SetPropValue(L,propName, plua_tovariant(L, 3)) then + begin + // This is a standard handler, no value was found in the object instance + // so we push the value into the Lua Object reference. + TableIndex := plua_absindex(L, 1); + ValueIndex := plua_absindex(L, 3); + lua_pushstring(L, {$IFDEF UNICODE}pAnsiChar{$ELSE}PChar{$ENDIF}(propName)); + lua_pushvalue(L, ValueIndex); + lua_rawset(L, TableIndex); + end; +end; + +function gc_TCatLuaObject(L : PLua_State) : Integer; cdecl; +var + E : TCatLuaObject; +begin + E := LuaToTCatLuaObject(L, 1); + // Release the object + if assigned(E) then + E.Free; + result := 0; +end; + +procedure RegisterObjectInstance(L: Plua_State; aClassName, InstanceName: AnsiString; ObjectInstance : TCatLuaObject); +var + idx, idx2, mt : Integer; +begin + lua_pushliteral(L, {$IFDEF UNICODE}pAnsiChar{$ELSE}PChar{$ENDIF}(InstanceName)); + lua_newtable(L); + + ObjectInstance.FLuaReference := luaL_ref(L, LUA_REGISTRYINDEX); + lua_rawgeti (L, LUA_REGISTRYINDEX, ObjectInstance.FLuaReference); + LuaObjects.Add(ObjectInstance); + idx := lua_gettop(L); + + lua_pushliteral(L, '_Self'); + lua_pushinteger(L, PtrInt(Pointer(ObjectInstance))); + lua_rawset(L, idx); + + lua_newtable(L); + mt := lua_gettop(L); + + lua_pushliteral(L, {$IFDEF UNICODE}pAnsiChar{$ELSE}PChar{$ENDIF}(aClassName)); + lua_gettable(L, LUA_GLOBALSINDEX); + idx2 := lua_gettop(L); + + LuaCopyTable(L, idx2, idx, mt); + lua_setmetatable(L, idx); + + lua_pop(L, 1); + + lua_settable(L, LUA_GLOBALSINDEX); +end; + +procedure RegisterMethod(L : Plua_State; TheMethodName : AnsiString; TheMethodAddress : lua_CFunction; classTable : Integer); +begin + lua_pushliteral(L, {$IFDEF UNICODE}pAnsiChar{$ELSE}PChar{$ENDIF}(TheMethodName)); + lua_pushcfunction(L, TheMethodAddress); + lua_rawset(L, classTable); +end; + +function new_LuaObject(L : PLua_State; aClassName : AnsiString; NewCallback : TCatLuaObjectNewCallback): Integer; cdecl; +var + P, E : TCatLuaObject; + n, idx, idx2, mt : Integer; +begin + n := lua_gettop(L); + if lua_type(L, 1) <> LUA_TTABLE then + lua_remove(L, 1); + if n > 1 then + P := LuaToTCatLuaObject(L, 2) + else + P := nil; + + lua_newtable(L); + E := NewCallback(L, P); + idx := lua_gettop(L); + + lua_pushliteral(L, '_Self'); + lua_pushinteger(L, PtrInt(Pointer(E))); + lua_rawset(L, idx); + + lua_newtable(L); + mt := lua_gettop(L); + + lua_pushliteral(L, {$IFDEF UNICODE}pAnsiChar{$ELSE}PChar{$ENDIF}(aClassName)); + lua_gettable(L, LUA_GLOBALSINDEX); + idx2 := lua_gettop(L); + + LuaCopyTable(L, idx2, idx, mt); + lua_setmetatable(L, idx); + + lua_pop(L, 1); + + result := 1; +end; + +procedure RegisterClassTCatLuaObject(L : Plua_State); +var + classTable : Integer; +begin + lua_pushstring(L, LuaTCatLuaObjectClassName); + lua_newtable(L); + classTable := lua_gettop(L); + + RegisterMethod(L, '__index', @index_TCatLuaObject, classTable); + RegisterMethod(L, '__newindex', @newindex_TCatLuaObject, classTable); + RegisterMethod(L, '__call', @new_TCatLuaObject, classTable); + RegisterMethod(L, '__gc', @gc_TCatLuaObject, classTable); + RegisterMethod(L, 'release', @gc_TCatLuaObject, classTable); + RegisterMethod(L, 'new', @new_TCatLuaObject, classTable); + + lua_settable(L, LUA_GLOBALSINDEX); +end; + +{ Global Management Methods } + +procedure RegisterTCatLuaObject(L: Plua_State; ObjectName : AnsiString; + CreateFunc : lua_CFunction; + MethodsCallback: TCatLuaObjectRegisterMethodsCallback); +var + classTable : Integer; +begin + lua_pushstring(L, {$IFDEF UNICODE}pAnsiChar{$ELSE}PChar{$ENDIF}(ObjectName)); + lua_newtable(L); + classTable := lua_gettop(L); + + RegisterMethod(L, '__index', @index_TCatLuaObject, classTable); + RegisterMethod(L, '__newindex', @newindex_TCatLuaObject, classTable); + RegisterMethod(L, '__call', CreateFunc, classTable); + RegisterMethod(L, '__gc', @gc_TCatLuaObject, classTable); + RegisterMethod(L, 'release', @gc_TCatLuaObject, classTable); + RegisterMethod(L, 'new', CreateFunc, classTable); + + if Assigned(MethodsCallback) then + MethodsCallback(L, classTable); + + lua_settable(L, LUA_GLOBALSINDEX); +end; + +procedure ClearObjects; +begin + while LuaObjects.Count > 0 do + TCatLuaObject(LuaObjects[LuaObjects.Count-1]).Free; +end; + +procedure RegisterLuaObject(L: Plua_State); +begin + RegisterClassTCatLuaObject(L); +end; + +initialization + LuaObjects := TList.Create; + +finalization + ClearObjects; + LuaObjects.Free; + +end. diff --git a/src/CatLuaUtils.pas b/src/CatLuaUtils.pas new file mode 100644 index 0000000..68ec36d --- /dev/null +++ b/src/CatLuaUtils.pas @@ -0,0 +1,310 @@ +unit CatLuaUtils; +{ + Lua Utils + Functions for getting and setting local and global variables in Lua + + Copyright (c) 2003-2014 Felipe Daragon + License: MIT (http://opensource.org/licenses/mit-license.php) + + Work in progress +} + +interface + +uses + Lua, pLua, Variants, SysUtils; + +type + MyPAnsiChar = {$IFDEF UNICODE}pAnsiChar{$ELSE}PChar{$ENDIF}; + +function pLuaAnyToString(L: PLua_State; idx: integer): string; +function pLua_GetLuaVar(L: PLua_State; idx: integer): Variant; +function pLua_GetGlobal(L: PLua_State; valName: AnsiString): Variant; +function pLua_GetLocal(L: PLua_State; valName: AnsiString): Variant; +procedure pLua_SetGlobal(L: PLua_State; valName: AnsiString; + const AValue: Variant); +procedure pLua_SetLocal(L: PLua_State; valName: AnsiString; + const AValue: Variant); + +// Gets a table field +function pLua_GetFieldStr(L: PLua_State; idx: integer; FieldName: MyPAnsiChar; + ADefaultValue: string = ''): string; +function pLua_GetFieldInt(L: PLua_State; idx: integer; FieldName: MyPAnsiChar; + ADefaultValue: integer): integer; +function pLua_GetFieldBool(L: PLua_State; idx: integer; FieldName: MyPAnsiChar; + ADefaultValue: boolean): boolean; +function pLua_GetFieldVariant(L: PLua_State; idx: integer; + FieldName: MyPAnsiChar; ADefaultValue: Variant): Variant; + +// Sets a table field +procedure pLua_SetFieldStr(L: PLua_State; FieldName: MyPAnsiChar; + AValue: string); +procedure pLua_SetFieldInt(L: PLua_State; FieldName: MyPAnsiChar; + AValue: integer); +procedure pLua_SetFieldBool(L: PLua_State; FieldName: MyPAnsiChar; + AValue: boolean); +procedure pLua_SetFieldVariant(L: PLua_State; FieldName: MyPAnsiChar; + AValue: Variant); + +implementation + +function pLua_GetFieldStr(L: PLua_State; idx: integer; FieldName: MyPAnsiChar; + ADefaultValue: string = ''): string; +begin + lua_pushstring(L, FieldName); + lua_gettable(L, idx); + if lua_isnil(L, -1) then + result := ADefaultValue + else + result := lua_tostring(L, -1); +end; + +function pLua_GetFieldInt(L: PLua_State; idx: integer; FieldName: MyPAnsiChar; + ADefaultValue: integer): integer; +begin + lua_pushstring(L, FieldName); + lua_gettable(L, idx); + if lua_isnil(L, -1) then + result := ADefaultValue + else + result := lua_tointeger(L, -1); +end; + +function pLua_GetFieldBool(L: PLua_State; idx: integer; FieldName: MyPAnsiChar; + ADefaultValue: boolean): boolean; +begin + lua_pushstring(L, FieldName); + lua_gettable(L, idx); + if lua_isnil(L, -1) then + result := ADefaultValue + else + result := lua_toboolean(L, -1); +end; + +function pLua_GetFieldVariant(L: PLua_State; idx: integer; + FieldName: MyPAnsiChar; ADefaultValue: Variant): Variant; +begin + lua_pushstring(L, FieldName); + lua_gettable(L, idx); + if lua_isnil(L, -1) then + result := ADefaultValue + else + result := plua_tovariant(L, -1); +end; + +function pLuaAnyToString(L: PLua_State; idx: integer): string; +var + ltype: integer; +begin + result := emptystr; + ltype := lua_type(L, idx); + case ltype of + LUA_TSTRING: + result := {$IFDEF UNICODE}pAnsiChar{$ELSE}PChar{$ENDIF}(lua_tostring(L, idx)); + LUA_TBOOLEAN: + begin + if lua_toboolean(L, idx) = true then + result := 'true' + else + result := 'false'; + end; + LUA_TNUMBER: + begin + if TVarData(plua_tovariant(L, idx)).vType = varDouble then + result := floattostr(lua_tonumber(L, idx)) + else + result := inttostr(lua_tointeger(L, idx)); + end; + end; +end; + +procedure pLua_SetFieldStr(L: PLua_State; FieldName: MyPAnsiChar; + AValue: string); +begin + plua_pushstring(L, AValue); + lua_setfield(L, -2, FieldName); +end; + +procedure pLua_SetFieldInt(L: PLua_State; FieldName: MyPAnsiChar; + AValue: integer); +begin + lua_pushinteger(L, AValue); + lua_setfield(L, -2, FieldName); +end; + +procedure pLua_SetFieldBool(L: PLua_State; FieldName: MyPAnsiChar; + AValue: boolean); +begin + lua_pushboolean(L, AValue); + lua_setfield(L, -2, FieldName); +end; + +procedure pLua_SetFieldVariant(L: PLua_State; FieldName: MyPAnsiChar; + AValue: Variant); +begin + plua_pushvariant(L, AValue); + lua_setfield(L, -2, FieldName); +end; + +function pLua_GetLuaVar(L: PLua_State; idx: integer): Variant; +var + ltype: integer; + v: Variant; + s: string; +begin + ltype := lua_type(L, idx); + case ltype of + LUA_TSTRING: + begin + s := {$IFDEF UNICODE}pAnsiChar{$ELSE}PChar{$ENDIF}(lua_tostring(L, idx)); + v := s; + end; + LUA_TBOOLEAN: + v := lua_toboolean(L, idx); + LUA_TNUMBER: + v := lua_tointeger(L, idx); + else + v := plua_tovariant(L, idx); + end; + result := v; +end; + +function pLua_GetGlobal(L: PLua_State; valName: AnsiString): Variant; // working +var + v: Variant; +begin + result := NULL; + lua_pushstring(L, {$IFDEF UNICODE}pAnsiChar{$ELSE}PChar{$ENDIF}(valName)); + lua_rawget(L, LUA_GLOBALSINDEX); + try + // writeln('getting '+valname); + v := pLua_GetLuaVar(L, -1); // plua_tovariant(L, -1); + result := v; + // writeln('got '+valname+': '+result); + finally + lua_pop(L, 1); + end; +end; + +function pLua_GetLocal(L: PLua_State; valName: AnsiString): Variant; +var + ar: plua_Debug; // use plua_debug, not lua_debug! + VarName: MyPAnsiChar; + VarValue: Variant; + current, stack: integer; + found: boolean; + Name: string; +begin + result := NULL; + found := false; + Name := valName; + + lua_getglobal(L, 'tostring'); // this fixes ocasional crash with lua_getstack + if lua_getstack(L, 1, @ar) <> 1 then + begin + Exit; + end; + current := 1; + VarName := lua_getlocal(L, @ar, current); + while VarName <> nil do + begin + // lua_pop(L,1); + // writeln('Matching var:'+varname); + if VarName = Name then + begin + found := true; + // writeln('Found var:'+varname); + try + VarValue := pLua_GetLuaVar(L, -1); // plua_tovariant(L, -1); + finally + lua_pop(L, 1); + end; + // writeln('found!'+varname+';'+varvalue); + result := VarValue; + Exit; + end; + lua_pop(L, 1); + VarName := lua_getlocal(L, @ar, current); + inc(current); + end; + if found = false then + begin // local not found, tries to get global with the same name + // writeln('not found locally:'+valname); + try + VarValue := pLua_GetGlobal(L, valName); + except + end; + result := VarValue; + // writeln('global search for '+valname+' returned):'+result); + end; +end; + +procedure pLua_SetLocal(L: PLua_State; valName: AnsiString; + const AValue: Variant); +var + ar: plua_Debug; + VarName: MyPAnsiChar; + current: integer; + found: boolean; + Name: string; + NewValue: Variant; +begin + found := false; + Name := valName; + NewValue := AValue; + + if lua_getstack(L, 1, @ar) <> 1 then + begin + Exit; + end; + current := 1; + VarName := lua_getlocal(L, @ar, current); + while VarName <> nil do + begin + if VarName = Name then + begin + found := true; + // writeln('Found var:'+varname+' changing to:'+newvalue); + // lua_pop(L,1); + try + plua_pushvariant(L, NewValue); + lua_setlocal(L, @ar, current); + finally + lua_pop(L, 1); + end; + // writeln('Changed var:'+varname+' to:'+newvalue); + Exit; + end; + lua_pop(L, 1); + inc(current); + VarName := lua_getlocal(L, @ar, current); + + end; + if found = false then + begin // new, local not found, tries to set global with the same name + // writeln('not found locally:'+valname); + pLua_SetGlobal(L, valName, NewValue); + end; +end; + +procedure pLua_SetGlobal(L: PLua_State; valName: AnsiString; + const AValue: Variant); +begin + // writeln('setting glob:'+valname+'; new value: '+avalue); + if VarIsType(AValue, varString) then + begin + lua_pushliteral(L, {$IFDEF UNICODE}pAnsiChar{$ELSE}PChar{$ENDIF}(valName)); + lua_pushstring(L, +{$IFDEF UNICODE}pAnsiChar{$ELSE}PChar{$ENDIF}(AnsiString(AValue))); + lua_settable(L, LUA_GLOBALSINDEX); + end + else + begin + lua_pushliteral(L, {$IFDEF UNICODE}pAnsiChar{$ELSE}PChar{$ENDIF}(valName)); + plua_pushvariant(L, AValue); + lua_settable(L, LUA_GLOBALSINDEX); + end; +end; + +// ------------------------------------------------------------------------// +end. diff --git a/src/CatPointer.pas b/src/CatPointer.pas new file mode 100644 index 0000000..5f1402f --- /dev/null +++ b/src/CatPointer.pas @@ -0,0 +1,55 @@ +unit CatPointer; +{ + Catarinka - Pointer To String and vice-versa functions + + Copyright (c) 2014 Felipe Daragon + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + System.SysUtils; +{$ELSE} + SysUtils; +{$IFEND} + +function PointerToStr(const P: Pointer): string; +function StrToPointer(const s: string): Pointer; + +implementation + +function PointerToStr(const P: Pointer): string; +var + PP: Pointer; + PC: ^Cardinal; +begin + PP := @P; + PC := PP; +{$IFDEF UNICODE} + Result := pansichar(PC^); +{$ELSE} + Result := pchar(PC^); +{$ENDIF} +end; + +function StrToPointer(const s: string): Pointer; +var + c: Cardinal; + P: Pointer; + PC: ^Cardinal; + PP: ^Pointer; + tStr: {$IFDEF UNICODE}pansichar{$ELSE}pchar{$ENDIF}; +begin + GetMem(tStr, 1 + Length(s)); + StrPCopy(tStr, s); + c := integer(tStr); + PC := @c; + P := PC; + PP := P; + Result := PP^; +end; + +end. diff --git a/src/CatPrefs.pas b/src/CatPrefs.pas new file mode 100644 index 0000000..459a887 --- /dev/null +++ b/src/CatPrefs.pas @@ -0,0 +1,178 @@ +unit CatPrefs; + +{ + Catarinka Preferences (TCatPreferences) + + Copyright (c) 2013-2014 Felipe Daragon + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + System.Classes, System.SysUtils, System.Variants, +{$ELSE} + Classes, SysUtils, Variants, +{$IFEND} + CatJSON; + +type + TCatPreferences = class + private + fCurrent: TCatJSON; + fDefault: TCatJSON; + fFilename: string; + fOptionList: TStringList; + function Encrypt(const CID: string; const Value: Variant): Variant; + function Decrypt(const CID: string; const Value: Variant): Variant; + function FGetValue(const CID: string): Variant; + function GetCIDList: string; + public + function GetValue(const CID: string): Variant; overload; + function GetValue(const CID: string; const DefaultValue: Variant) + : Variant; overload; + function GetRegValue(const CID: string; + const DefaultValue: Variant): Variant; + procedure SetValue(const CID: string; const Value: Variant); + procedure LoadFromFile(const f: string); + procedure LoadFromString(const s: string); + procedure RegisterDefault(const CID: string; const DefaultValue: Variant; + const AddToOptionList: boolean = true); + procedure RestoreDefaults; + procedure SaveToFile(const f: string); + constructor Create; + destructor Destroy; override; + // properties + property CIDList: string read GetCIDList; + property Current: TCatJSON read fCurrent; + property Default: TCatJSON read fDefault; + property Filename: string read fFilename write fFilename; + property OptionList: TStringList read fOptionList; + property Values[const CID: string]: Variant read FGetValue + write SetValue; default; + published + end; + +implementation + +uses CatDCP, CatStrings, CatDCPKey; + +function IsEncryptedCID(CID: string): boolean; +begin + result := false; + if endswith(CID, '.password') then + result := true + else if endswith(CID, '.encrypted') then + result := true; +end; + +function TCatPreferences.Encrypt(const CID: string; + const Value: Variant): Variant; +begin + if IsEncryptedCID(CID) then + result := strtoaes(Value,GetDCPKey(CATKEY_PASSWORD)) + else + result := Value; +end; + +function TCatPreferences.Decrypt(const CID: string; + const Value: Variant): Variant; +begin + if IsEncryptedCID(CID) then + result := aestostr(Value,GetDCPKey(CATKEY_PASSWORD)) + else + result := Value; +end; + +// Returns the CID of all available options +function TCatPreferences.GetCIDList: string; +begin + result := fOptionList.text; +end; + +function TCatPreferences.FGetValue(const CID: string): Variant; +begin + result := fCurrent.GetValue(CID, fdefault [CID]); + result := Decrypt(CID, result); +end; + +function TCatPreferences.GetValue(const CID: string): Variant; +begin + result := FGetValue(CID); +end; + +function TCatPreferences.GetValue(const CID: string; + const DefaultValue: Variant): Variant; +begin + result := fCurrent.GetValue(CID, DefaultValue); + result := Decrypt(CID, result); +end; + +function TCatPreferences.GetRegValue(const CID: string; + const DefaultValue: Variant): Variant; +begin + RegisterDefault(CID, DefaultValue); + result := fCurrent.GetValue(CID, DefaultValue); + result := Decrypt(CID, result); +end; + +procedure TCatPreferences.SetValue(const CID: string; const Value: Variant); +begin + fCurrent[CID] := Encrypt(CID, Value); +end; + +// Reverts to the default configuration +procedure TCatPreferences.RestoreDefaults; +begin + fCurrent.text := fdefault.text; +end; + +procedure TCatPreferences.RegisterDefault(const CID: string; + const DefaultValue: Variant; const AddToOptionList: boolean = true); +begin + if AddToOptionList then + begin + if fOptionList.indexof(CID) = -1 then + fOptionList.Add(CID); + end; + fDefault [CID] := DefaultValue; +end; + +procedure TCatPreferences.LoadFromFile(const f: string); +begin + Filename := f; + fCurrent.LoadFromFile(f); +end; + +procedure TCatPreferences.LoadFromString(const s: string); +begin + if s = emptystr then + fCurrent.text := EmptyJSONStr + else + fCurrent.text := s; +end; + +procedure TCatPreferences.SaveToFile(const f: string); +begin + fCurrent.SaveToFile(f); +end; + +constructor TCatPreferences.Create; +begin + inherited Create; + fCurrent := TCatJSON.Create; + fDefault := TCatJSON.Create; + fOptionList := TStringList.Create; +end; + +destructor TCatPreferences.Destroy; +begin + fOptionList.free; + fDefault.free; + fCurrent.free; + inherited; +end; + +end. diff --git a/src/CatRegEx.pas b/src/CatRegEx.pas new file mode 100644 index 0000000..4afd0b7 --- /dev/null +++ b/src/CatRegEx.pas @@ -0,0 +1,80 @@ +unit CatRegex; +{ + Catarinka - Regular Expression functions + + Copyright (c) 2003-2014 Felipe Daragon + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details + + Uses the RegExpr library by Andrey V. Sorokin. +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + System.Classes, System.SysUtils; +{$ELSE} + Classes, SysUtils; +{$IFEND} +function RegExpFind(const s, re: string): string; +function RegExpReplace(const s, re, sreplacement: string): string; +function CatMatch(const substr, s: string): boolean; + +implementation + +uses CatStrings, RegExpr; + +function RegExpReplace(const s, re, sreplacement: string): string; +var + r: TRegExpr; +begin + r := TRegExpr.Create; + try + r.Expression := re; + result := r.Replace(s, sreplacement, true); + finally + r.Free; + end; +end; + +function RegExpFind(const s, re: string): string; +var + r: TRegExpr; +begin + result := emptystr; + r := TRegExpr.Create; + try + r.Expression := re; + if r.Exec(s) then + repeat + result := result + r.Match[0] + ', '; + until not r.ExecNext; + finally + r.Free; + end; +end; + +function CatMatch(const substr, s: string): boolean; +const + cReEx = 'regexp:'; +var + tmpsub: string; +begin + result := false; + tmpsub := substr; + if (pos(cReEx, tmpsub) <> 0) then + begin + tmpsub := after(tmpsub, cReEx); + if (RegExpFind(s, tmpsub) <> emptystr) then + result := true; + end + else + begin + if (pos(tmpsub, s) <> 0) then + result := true; + end; +end; + +// ------------------------------------------------------------------------// +end. diff --git a/src/CatRes.pas b/src/CatRes.pas new file mode 100644 index 0000000..01031c4 --- /dev/null +++ b/src/CatRes.pas @@ -0,0 +1,112 @@ +unit CatRes; + +{ + Catarinka - Catarinka Resources Library + Useful functions for reading or saving resources + + Copyright (c) 2003-2014 Felipe Daragon + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + System.SysUtils, Winapi.Windows, vcl.imaging.Jpeg, System.Classes; +{$ELSE} + SysUtils, Windows, Jpeg, Classes; +{$IFEND} + +type + MyPWideChar = {$IFDEF UNICODE}PWideChar{$ELSE}PChar{$ENDIF}; + +function GetResourceAsPointer(const ResName, ResType: MyPWideChar; + out Size: longword): pointer; +function GetResourceAsString(const ResName, ResType: MyPWideChar): string; +function GetResourceAsJpeg(const ResName: string): TJPEGImage; +procedure SaveResourceAsFile(const ResName: string; const ResType: MyPWideChar; + const FileName: string); +function SaveResourceAsTempFile(const ResName: string; + const ResType: MyPWideChar): string; + +implementation + +uses CatFiles; + +// Usage Example: +// Jpg := GetResourceAsJpeg('sample_jpg'); +// Image1.Picture.Bitmap.Assign(Jpg); +function GetResourceAsJpeg(const ResName: string): TJPEGImage; +var + rs: TResourceStream; +begin + rs := TResourceStream.Create(hInstance, ResName, 'JPEG'); + try + Result := TJPEGImage.Create; + Result.LoadFromStream(rs); + finally + rs.Free; + end; +end; + +// Example: Memo1.Lines.Text := GetResourceAsString('sample_txt', 'text'); +function GetResourceAsString(const ResName, ResType: MyPWideChar): string; +var + rd: {$IFDEF UNICODE}pansichar{$ELSE}PChar{$ENDIF}; // resource data + sz: longword; // resource size +begin + rd := GetResourceAsPointer(ResName, ResType, sz); + SetString(Result, rd, sz); +end; + +procedure SaveResourceAsFile(const ResName: string; const ResType: MyPWideChar; + const FileName: string); +begin + with TResourceStream.Create(hInstance, ResName, ResType) do + try + SaveToFile(FileName); + finally + Free; + end; +end; + +{ + Usage Example: + procedure TForm1.FormCreate(Sender: TObject); + var size: longword; sample_wav: pointer; + begin + sample_wav := GetResourceAsPointer('sample_wav', 'wave', size); + sndPlaySound(sample_wav, SND_MEMORY or SND_NODEFAULT or SND_ASYNC); + end; +} +// Based on an example from the Pascal Newsletter #25 +function GetResourceAsPointer(const ResName, ResType: MyPWideChar; + out Size: longword): pointer; +var + ib: HRSRC; // InfoBlock + gmb: HGLOBAL; // GlobalMemoryBlock +begin + ib := FindResource(hInstance, ResName, ResType); + if ib = 0 then + raise Exception.Create(SysErrorMessage(GetLastError)); + Size := SizeofResource(hInstance, ib); + if Size = 0 then + raise Exception.Create(SysErrorMessage(GetLastError)); + gmb := LoadResource(hInstance, ib); + if gmb = 0 then + raise Exception.Create(SysErrorMessage(GetLastError)); + Result := LockResource(gmb); + if Result = nil then + raise Exception.Create(SysErrorMessage(GetLastError)); +end; + +function SaveResourceAsTempFile(const ResName: string; + const ResType: MyPWideChar): string; +begin + Result := GetWindowsTempDir + 'temp_' + ResName; + SaveResourceAsFile(ResName, ResType, Result); +end; + +// ------------------------------------------------------------------------// +end. diff --git a/src/CatSciterAx.pas b/src/CatSciterAx.pas new file mode 100644 index 0000000..2ee2dee --- /dev/null +++ b/src/CatSciterAx.pas @@ -0,0 +1,900 @@ +unit CatSciterAx; + +{ + AxSciterLib_TLB.pas slightly modified + If you regenerate the file, remember to re-apply the changes below. + -Felipe Daragon + + TSciter was not handling tab and arrow keys. This fixed it: + + Added Messages, and Controls to uses, and: + +TSciter = class(TOleControl) + private + procedure CNKeyDown(var Message: TMessage); message CN_KEYDOWN; + public + .... + end; + +procedure TMyActiveForm.CNKeyDown(var Message: TMessage); +begin +end; +} + +// ************************************************************************ // +// WARNING +// ------- +// The types declared in this file were generated from data read from a +// Type Library. If this type library is explicitly or indirectly (via +// another type library referring to this type library) re-imported, or the +// 'Refresh' command of the Type Library Editor activated while editing the +// Type Library, the contents of this file will be regenerated and all +// manual modifications will be lost. +// ************************************************************************ // + +// $Rev: 52393 $ +// File generated on 7/5/2013 06:33:59 from Type Library described below. + +// ************************************************************************ // +// Type Lib: AxSciter.dll (1) +// LIBID: {25D9681B-32F2-44C9-B94F-5E82E7ED0C75} +// LCID: 0 +// Helpfile: +// HelpString: AxSciter 1.0 Type Library +// DepndLst: +// (1) v2.0 stdole, (stdole2.tlb) +// SYS_KIND: SYS_WIN32 +// Errors: +// Error creating palette bitmap of (TElement) : Server AxSciter.dll contains no icons +// Error creating palette bitmap of (TElements) : Server AxSciter.dll contains no icons +// ************************************************************************ // +{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. +{$WARN SYMBOL_PLATFORM OFF} +{$WRITEABLECONST ON} +{$VARPROPSETTER ON} +{$ALIGN 4} + +interface + +uses Winapi.Windows, + Winapi.Messages, Vcl.controls, + System.Classes, System.Variants, System.Win.StdVCL, Vcl.Graphics, Vcl.OleCtrls, Vcl.OleServer, Winapi.ActiveX; + + + +// *********************************************************************// +// GUIDS declared in the TypeLibrary. Following prefixes are used: +// Type Libraries : LIBID_xxxx +// CoClasses : CLASS_xxxx +// DISPInterfaces : DIID_xxxx +// Non-DISP interfaces: IID_xxxx +// *********************************************************************// +const + // TypeLibrary Major and minor versions + AxSciterLibMajorVersion = 1; + AxSciterLibMinorVersion = 0; + + LIBID_AxSciterLib: TGUID = '{25D9681B-32F2-44C9-B94F-5E82E7ED0C75}'; + + IID_IElements: TGUID = '{C7171909-9F92-48D7-8691-EFB3390DEE55}'; + IID_IElement: TGUID = '{645B0717-C0AB-424D-B513-F083AD486BF1}'; + IID_ISciter: TGUID = '{FA63A755-C7B3-4DB6-833F-3D5FE102495E}'; + DIID__ISciterEvents: TGUID = '{ED2316A7-3EB2-4C80-9146-600B408B08D8}'; + CLASS_Sciter: TGUID = '{99829A7E-007E-4F60-AC36-31B646896593}'; + DIID__IElementEvents: TGUID = '{2A8AAFD6-6E87-4967-BF6D-C3F6BB9B3BD1}'; + CLASS_Element: TGUID = '{53FB239D-7857-4F0D-9083-871D8C0EAE3A}'; + CLASS_Elements: TGUID = '{B1C8635C-12B4-40F7-8038-6134FC5D398F}'; + +// *********************************************************************// +// Declaration of Enumerations defined in Type Library +// *********************************************************************// +// Constants for enum __MIDL___MIDL_itf_AxSciter_0000_0001 +type + __MIDL___MIDL_itf_AxSciter_0000_0001 = TOleEnum; +const + ContentBox = $00000000; + PaddingBox = $00000010; + BorderBox = $00000020; + MarginBox = $00000030; + BackImageArea = $00000040; + ForeImageArea = $00000050; + ScrollableArea = $00000060; + +// Constants for enum __MIDL___MIDL_itf_AxSciter_0000_0002 +type + __MIDL___MIDL_itf_AxSciter_0000_0002 = TOleEnum; +const + RootRelative = $00000001; + SelfRelative = $00000002; + ContainerRelative = $00000003; + ViewRelative = $00000004; + +// Constants for enum __MIDL___MIDL_itf_AxSciter_0000_0003 +type + __MIDL___MIDL_itf_AxSciter_0000_0003 = TOleEnum; +const + DATA_HTML = $00000000; + DATA_IMAGE = $00000001; + DATA_STYLE = $00000002; + DATA_CURSOR = $00000003; + DATA_SCRIPT = $00000004; + +// Constants for enum __MIDL___MIDL_itf_AxSciter_0000_0004 +type + __MIDL___MIDL_itf_AxSciter_0000_0004 = TOleEnum; +const + MASK_BUBBLING = $00000000; + MASK_SINKING = $00008000; + MASK_HANDLED = $00010000; + +// Constants for enum __MIDL___MIDL_itf_AxSciter_0000_0005 +type + __MIDL___MIDL_itf_AxSciter_0000_0005 = TOleEnum; +const + ME_MOUSE_ENTER = $00000000; + ME_MOUSE_LEAVE = $00000001; + ME_MOUSE_MOVE = $00000002; + ME_MOUSE_UP = $00000003; + ME_MOUSE_DOWN = $00000004; + ME_MOUSE_DCLICK = $00000005; + ME_MOUSE_WHEEL = $00000006; + ME_MOUSE_TICK = $00000007; + ME_MOUSE_IDLE = $00000008; + ME_DROP = $00000009; + ME_DRAG_ENTER = $0000000A; + ME_DRAG_LEAVE = $0000000B; + ME_DRAGGING = $00000100; + +// Constants for enum __MIDL___MIDL_itf_AxSciter_0000_0006 +type + __MIDL___MIDL_itf_AxSciter_0000_0006 = TOleEnum; +const + BE_BUTTON_CLICK = $00000000; + BE_BUTTON_PRESS = $00000001; + BE_BUTTON_STATE_CHANGED = $00000002; + BE_EDIT_VALUE_CHANGING = $00000003; + BE_EDIT_VALUE_CHANGED = $00000004; + BE_SELECT_SELECTION_CHANGED = $00000005; + BE_SELECT_STATE_CHANGED = $00000006; + BE_POPUP_REQUEST = $00000007; + BE_POPUP_READY = $00000008; + BE_POPUP_DISMISSED = $00000009; + BE_MENU_ITEM_ACTIVE = $0000000A; + BE_MENU_ITEM_CLICK = $0000000B; + BE_CONTEXT_MENU_SETUP = $0000000F; + BE_CONTEXT_MENU_REQUEST = $00000010; + BE_VISIUAL_STATUS_CHANGED = $00000011; + BE_HYPERLINK_CLICK = $00000080; + BE_TABLE_HEADER_CLICK = $00000081; + BE_TABLE_ROW_CLICK = $00000082; + BE_TABLE_ROW_DBL_CLICK = $00000083; + BE_ELEMENT_COLLAPSED = $00000090; + BE_ELEMENT_EXPANDED = $00000091; + BE_ACTIVATE_CHILD = $00000092; + BE_DO_SWITCH_TAB = $00000092; + BE_INIT_DATA_VIEW = $00000093; + BE_ROWS_DATA_REQUEST = $00000094; + BE_UI_STATE_CHANGED = $00000095; + BE_FORM_SUBMIT = $00000096; + BE_FORM_RESET = $00000097; + BE_DOCUMENT_COMPLETE = $00000098; + BE_HISTORY_PUSH = $00000099; + BE_HISTORY_DROP = $0000009A; + BE_HISTORY_PRIOR = $0000009B; + BE_HISTORY_NEXT = $0000009C; + BE_HISTORY_STATE_CHANGED = $0000009D; + BE_FIRST_APPLICATION_EVENT_CODE = $00000100; + +type + +// *********************************************************************// +// Forward declaration of types defined in TypeLibrary +// *********************************************************************// + IElements = interface; + IElementsDisp = dispinterface; + IElement = interface; + IElementDisp = dispinterface; + ISciter = interface; + ISciterDisp = dispinterface; + _ISciterEvents = dispinterface; + _IElementEvents = dispinterface; + +// *********************************************************************// +// Declaration of CoClasses defined in Type Library +// (NOTE: Here we map each CoClass to its Default Interface) +// *********************************************************************// + Sciter = ISciter; + Element = IElement; + Elements = IElements; + + +// *********************************************************************// +// Declaration of structures, unions and aliases. +// *********************************************************************// + PPSafeArray1 = ^PSafeArray; {*} + PByte1 = ^Byte; {*} + + ElementBoxType = __MIDL___MIDL_itf_AxSciter_0000_0001; + RelativeToType = __MIDL___MIDL_itf_AxSciter_0000_0002; + ResourceType = __MIDL___MIDL_itf_AxSciter_0000_0003; + PhaseMask = __MIDL___MIDL_itf_AxSciter_0000_0004; + MouseEvents = __MIDL___MIDL_itf_AxSciter_0000_0005; + BehaviorEvents = __MIDL___MIDL_itf_AxSciter_0000_0006; + +// *********************************************************************// +// Interface: IElements +// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable +// GUID: {C7171909-9F92-48D7-8691-EFB3390DEE55} +// *********************************************************************// + IElements = interface(IDispatch) + ['{C7171909-9F92-48D7-8691-EFB3390DEE55}'] + function _NewEnum: IUnknown; safecall; + function Get_Count: Integer; safecall; + function Get_Item(index: Integer): IElement; safecall; + property Count: Integer read Get_Count; + property Item[index: Integer]: IElement read Get_Item; + end; + +// *********************************************************************// +// DispIntf: IElementsDisp +// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable +// GUID: {C7171909-9F92-48D7-8691-EFB3390DEE55} +// *********************************************************************// + IElementsDisp = dispinterface + ['{C7171909-9F92-48D7-8691-EFB3390DEE55}'] + function _NewEnum: IUnknown; dispid -4; + property Count: Integer readonly dispid 1; + property Item[index: Integer]: IElement readonly dispid 2; + end; + +// *********************************************************************// +// Interface: IElement +// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable +// GUID: {645B0717-C0AB-424D-B513-F083AD486BF1} +// *********************************************************************// + IElement = interface(IDispatch) + ['{645B0717-C0AB-424D-B513-F083AD486BF1}'] + function Get_Tag: WideString; safecall; + function Get_Value: OleVariant; safecall; + procedure Set_Value(pVal: OleVariant); safecall; + function Select(const cssSelector: WideString): IElement; safecall; + function SelectAll(const cssSelector: WideString): IElements; safecall; + function Get_Attr(const name: WideString): OleVariant; safecall; + procedure Set_Attr(const name: WideString; pVal: OleVariant); safecall; + function Get_StyleAttr(const name: WideString): OleVariant; safecall; + procedure Set_StyleAttr(const name: WideString; pVal: OleVariant); safecall; + procedure Position(out x: Integer; out y: Integer; ofWhat: ElementBoxType; relTo: RelativeToType); safecall; + procedure Dimension(out width: Integer; out height: Integer; ofWhat: ElementBoxType); safecall; + function Call(const methodName: WideString; var params: PSafeArray): OleVariant; safecall; + function Get_HELEMENT: Integer; safecall; + property Tag: WideString read Get_Tag; + property Value: OleVariant read Get_Value write Set_Value; + property Attr[const name: WideString]: OleVariant read Get_Attr write Set_Attr; + property StyleAttr[const name: WideString]: OleVariant read Get_StyleAttr write Set_StyleAttr; + property HELEMENT: Integer read Get_HELEMENT; + end; + +// *********************************************************************// +// DispIntf: IElementDisp +// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable +// GUID: {645B0717-C0AB-424D-B513-F083AD486BF1} +// *********************************************************************// + IElementDisp = dispinterface + ['{645B0717-C0AB-424D-B513-F083AD486BF1}'] + property Tag: WideString readonly dispid 1; + property Value: OleVariant dispid 2; + function Select(const cssSelector: WideString): IElement; dispid 3; + function SelectAll(const cssSelector: WideString): IElements; dispid 4; + property Attr[const name: WideString]: OleVariant dispid 5; + property StyleAttr[const name: WideString]: OleVariant dispid 6; + procedure Position(out x: Integer; out y: Integer; ofWhat: ElementBoxType; relTo: RelativeToType); dispid 7; + procedure Dimension(out width: Integer; out height: Integer; ofWhat: ElementBoxType); dispid 8; + function Call(const methodName: WideString; var params: {NOT_OLEAUTO(PSafeArray)}OleVariant): OleVariant; dispid 9; + property HELEMENT: Integer readonly dispid 10; + end; + +// *********************************************************************// +// Interface: ISciter +// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable +// GUID: {FA63A755-C7B3-4DB6-833F-3D5FE102495E} +// *********************************************************************// + ISciter = interface(IDispatch) + ['{FA63A755-C7B3-4DB6-833F-3D5FE102495E}'] + procedure LoadHtml(const html: WideString; const baseUrl: WideString); safecall; + procedure LoadUrl(const urlToLoad: WideString); safecall; + function Get_Root: IElement; safecall; + function Call(const name: WideString; var params: PSafeArray): OleVariant; safecall; + function Eval(const script: WideString): OleVariant; safecall; + procedure DataReady(requestId: Integer; var data: Byte; dataLength: Integer); safecall; + function Get_Methods: IDispatch; safecall; + procedure _Set_Methods(const pVal: IDispatch); safecall; + property Root: IElement read Get_Root; + property Methods: IDispatch read Get_Methods write _Set_Methods; + end; + +// *********************************************************************// +// DispIntf: ISciterDisp +// Flags: (4544) Dual NonExtensible OleAutomation Dispatchable +// GUID: {FA63A755-C7B3-4DB6-833F-3D5FE102495E} +// *********************************************************************// + ISciterDisp = dispinterface + ['{FA63A755-C7B3-4DB6-833F-3D5FE102495E}'] + procedure LoadHtml(const html: WideString; const baseUrl: WideString); dispid 1; + procedure LoadUrl(const urlToLoad: WideString); dispid 2; + property Root: IElement readonly dispid 3; + function Call(const name: WideString; var params: {NOT_OLEAUTO(PSafeArray)}OleVariant): OleVariant; dispid 4; + function Eval(const script: WideString): OleVariant; dispid 5; + procedure DataReady(requestId: Integer; var data: Byte; dataLength: Integer); dispid 6; + property Methods: IDispatch dispid 7; + end; + +// *********************************************************************// +// DispIntf: _ISciterEvents +// Flags: (4096) Dispatchable +// GUID: {ED2316A7-3EB2-4C80-9146-600B408B08D8} +// *********************************************************************// + _ISciterEvents = dispinterface + ['{ED2316A7-3EB2-4C80-9146-600B408B08D8}'] + function onStdOut(const msg: WideString): HResult; dispid 1; + function onStdErr(const msg: WideString): HResult; dispid 2; + function OnLoadData(const url: WideString; resType: ResourceType; requestId: Integer; + out discard: WordBool): HResult; dispid 3; + function OnDataLoaded(const url: WideString; resType: ResourceType; var data: Byte; + dataLength: Integer; requestId: Integer): HResult; dispid 4; + end; + +// *********************************************************************// +// DispIntf: _IElementEvents +// Flags: (4096) Dispatchable +// GUID: {2A8AAFD6-6E87-4967-BF6D-C3F6BB9B3BD1} +// *********************************************************************// + _IElementEvents = dispinterface + ['{2A8AAFD6-6E87-4967-BF6D-C3F6BB9B3BD1}'] + function OnMouse(const target: IElement; eventType: Integer; x: Integer; y: Integer; + buttons: Integer; keys: Integer): WordBool; dispid 1; + function OnKey(const target: IElement; eventType: Integer; code: Integer; keys: Integer): WordBool; dispid 2; + function OnFocus(const target: IElement; eventType: Integer): WordBool; dispid 3; + function OnTimer(timerId: Integer): WordBool; dispid 4; + function OnSize: HResult; dispid 5; + function OnControlEvent(const target: IElement; eventType: Integer; reason: Integer; + const source: IElement): WordBool; dispid 6; + function OnScroll(const target: IElement; eventType: Integer; pos: Integer; isVertical: WordBool): WordBool; dispid 7; + end; + + +// *********************************************************************// +// OLE Control Proxy class declaration +// Control Name : TSciter +// Help String : Sciter Class +// Default Interface: ISciter +// Def. Intf. DISP? : No +// Event Interface: _ISciterEvents +// TypeFlags : (34) CanCreate Control +// *********************************************************************// + TSciteronStdOut = procedure(ASender: TObject; const msg: WideString) of object; + TSciteronStdErr = procedure(ASender: TObject; const msg: WideString) of object; + TSciterOnLoadData = procedure(ASender: TObject; const url: WideString; resType: ResourceType; + requestId: Integer; out discard: WordBool) of object; + TSciterOnDataLoaded = procedure(ASender: TObject; const url: WideString; resType: ResourceType; + var data: Byte; dataLength: Integer; + requestId: Integer) of object; + + TSciter = class(TOleControl) + private + FOnonStdOut: TSciteronStdOut; + FOnonStdErr: TSciteronStdErr; + FOnLoadData: TSciterOnLoadData; + FOnDataLoaded: TSciterOnDataLoaded; + FIntf: ISciter; + function GetControlInterface: ISciter; + procedure CNKeyDown(var Message: TMessage); message CN_KEYDOWN; + protected + procedure CreateControl; + procedure InitControlData; override; + function Get_Root: IElement; + function Get_Methods: IDispatch; + procedure _Set_Methods(const pVal: IDispatch); + public + procedure LoadHtml(const html: WideString; const baseUrl: WideString); + procedure LoadUrl(const urlToLoad: WideString); + function Call(const name: WideString; var params: PSafeArray): OleVariant; + function Eval(const script: WideString): OleVariant; + procedure DataReady(requestId: Integer; var data: Byte; dataLength: Integer); + property ControlInterface: ISciter read GetControlInterface; + property DefaultInterface: ISciter read GetControlInterface; + property Root: IElement read Get_Root; + property Methods: IDispatch index 7 read GetIDispatchProp (* [[PUTREF-SETTER]] write _SetIDispatchProp*); + published + property Anchors; + property TabStop; + property Align; + property DragCursor; + property DragMode; + property ParentShowHint; + property PopupMenu; + property ShowHint; + property TabOrder; + property Visible; + property OnDragDrop; + property OnDragOver; + property OnEndDrag; + property OnEnter; + property OnExit; + property OnStartDrag; + property OnonStdOut: TSciteronStdOut read FOnonStdOut write FOnonStdOut; + property OnonStdErr: TSciteronStdErr read FOnonStdErr write FOnonStdErr; + property OnLoadData: TSciterOnLoadData read FOnLoadData write FOnLoadData; + property OnDataLoaded: TSciterOnDataLoaded read FOnDataLoaded write FOnDataLoaded; + end; + +// *********************************************************************// +// The Class CoElement provides a Create and CreateRemote method to +// create instances of the default interface IElement exposed by +// the CoClass Element. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoElement = class + class function Create: IElement; + class function CreateRemote(const MachineName: string): IElement; + end; + + TElementOnMouse = procedure(ASender: TObject; const target: IElement; eventType: Integer; + x: Integer; y: Integer; buttons: Integer; + keys: Integer) of object; + TElementOnKey = procedure(ASender: TObject; const target: IElement; eventType: Integer; + code: Integer; keys: Integer) of object; + TElementOnFocus = procedure(ASender: TObject; const target: IElement; eventType: Integer) of object; + TElementOnTimer = procedure(ASender: TObject; timerId: Integer) of object; + TElementOnControlEvent = procedure(ASender: TObject; const target: IElement; eventType: Integer; + reason: Integer; const source: IElement) of object; + TElementOnScroll = procedure(ASender: TObject; const target: IElement; eventType: Integer; + pos: Integer; isVertical: WordBool) of object; + + +// *********************************************************************// +// OLE Server Proxy class declaration +// Server Object : TElement +// Help String : Element Class +// Default Interface: IElement +// Def. Intf. DISP? : No +// Event Interface: _IElementEvents +// TypeFlags : (2) CanCreate +// *********************************************************************// + TElement = class(TOleServer) + private + FOnMouse: TElementOnMouse; + FOnKey: TElementOnKey; + FOnFocus: TElementOnFocus; + FOnTimer: TElementOnTimer; + FOnSize: TNotifyEvent; + FOnControlEvent: TElementOnControlEvent; + FOnScroll: TElementOnScroll; + FIntf: IElement; + function GetDefaultInterface: IElement; + protected + procedure InitServerData; override; + procedure InvokeEvent(DispID: TDispID; var Params: TVariantArray); override; + function Get_Tag: WideString; + function Get_Value: OleVariant; + procedure Set_Value(pVal: OleVariant); + function Get_Attr(const name: WideString): OleVariant; + procedure Set_Attr(const name: WideString; pVal: OleVariant); + function Get_StyleAttr(const name: WideString): OleVariant; + procedure Set_StyleAttr(const name: WideString; pVal: OleVariant); + function Get_HELEMENT: Integer; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Connect; override; + procedure ConnectTo(svrIntf: IElement); + procedure Disconnect; override; + function Select(const cssSelector: WideString): IElement; + function SelectAll(const cssSelector: WideString): IElements; + procedure Position(out x: Integer; out y: Integer; ofWhat: ElementBoxType; relTo: RelativeToType); + procedure Dimension(out width: Integer; out height: Integer; ofWhat: ElementBoxType); + function Call(const methodName: WideString; var params: PSafeArray): OleVariant; + property DefaultInterface: IElement read GetDefaultInterface; + property Tag: WideString read Get_Tag; + property Value: OleVariant read Get_Value write Set_Value; + property Attr[const name: WideString]: OleVariant read Get_Attr write Set_Attr; + property StyleAttr[const name: WideString]: OleVariant read Get_StyleAttr write Set_StyleAttr; + property HELEMENT: Integer read Get_HELEMENT; + published + property OnMouse: TElementOnMouse read FOnMouse write FOnMouse; + property OnKey: TElementOnKey read FOnKey write FOnKey; + property OnFocus: TElementOnFocus read FOnFocus write FOnFocus; + property OnTimer: TElementOnTimer read FOnTimer write FOnTimer; + property OnSize: TNotifyEvent read FOnSize write FOnSize; + property OnControlEvent: TElementOnControlEvent read FOnControlEvent write FOnControlEvent; + property OnScroll: TElementOnScroll read FOnScroll write FOnScroll; + end; + +// *********************************************************************// +// The Class CoElements provides a Create and CreateRemote method to +// create instances of the default interface IElements exposed by +// the CoClass Elements. The functions are intended to be used by +// clients wishing to automate the CoClass objects exposed by the +// server of this typelibrary. +// *********************************************************************// + CoElements = class + class function Create: IElements; + class function CreateRemote(const MachineName: string): IElements; + end; + + +// *********************************************************************// +// OLE Server Proxy class declaration +// Server Object : TElements +// Help String : Elements Class +// Default Interface: IElements +// Def. Intf. DISP? : No +// Event Interface: +// TypeFlags : (2) CanCreate +// *********************************************************************// + TElements = class(TOleServer) + private + FIntf: IElements; + function GetDefaultInterface: IElements; + protected + procedure InitServerData; override; + function Get_Count: Integer; + function Get_Item(index: Integer): IElement; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Connect; override; + procedure ConnectTo(svrIntf: IElements); + procedure Disconnect; override; + property DefaultInterface: IElements read GetDefaultInterface; + property Count: Integer read Get_Count; + property Item[index: Integer]: IElement read Get_Item; + published + end; + +procedure Register; + +resourcestring + dtlServerPage = 'ActiveX'; + + dtlOcxPage = 'ActiveX'; + +implementation + +uses System.Win.ComObj; + +procedure TSciter.CNKeyDown(var Message: TMessage); +begin +end; + +procedure TSciter.InitControlData; +const + CEventDispIDs: array [0..3] of DWORD = ( + $00000001, $00000002, $00000003, $00000004); + CControlData: TControlData2 = ( + ClassID: '{99829A7E-007E-4F60-AC36-31B646896593}'; + EventIID: '{ED2316A7-3EB2-4C80-9146-600B408B08D8}'; + EventCount: 4; + EventDispIDs: @CEventDispIDs; + LicenseKey: nil (*HR:$80004002*); + Flags: $00000000; + Version: 500); +begin + ControlData := @CControlData; + TControlData2(CControlData).FirstEventOfs := UIntPtr(@@FOnonStdOut) - UIntPtr(Self); +end; + +procedure TSciter.CreateControl; + + procedure DoCreate; + begin + FIntf := IUnknown(OleObject) as ISciter; + end; + +begin + if FIntf = nil then DoCreate; +end; + +function TSciter.GetControlInterface: ISciter; +begin + CreateControl; + Result := FIntf; +end; + +function TSciter.Get_Root: IElement; +begin + Result := DefaultInterface.Root; +end; + +function TSciter.Get_Methods: IDispatch; +begin + Result := DefaultInterface.Methods; +end; + +procedure TSciter._Set_Methods(const pVal: IDispatch); +begin + DefaultInterface.Methods := pVal; +end; + +procedure TSciter.LoadHtml(const html: WideString; const baseUrl: WideString); +begin + DefaultInterface.LoadHtml(html, baseUrl); +end; + +procedure TSciter.LoadUrl(const urlToLoad: WideString); +begin + DefaultInterface.LoadUrl(urlToLoad); +end; + +function TSciter.Call(const name: WideString; var params: PSafeArray): OleVariant; +begin + Result := DefaultInterface.Call(name, params); +end; + +function TSciter.Eval(const script: WideString): OleVariant; +begin + Result := DefaultInterface.Eval(script); +end; + +procedure TSciter.DataReady(requestId: Integer; var data: Byte; dataLength: Integer); +begin + DefaultInterface.DataReady(requestId, data, dataLength); +end; + +class function CoElement.Create: IElement; +begin + Result := CreateComObject(CLASS_Element) as IElement; +end; + +class function CoElement.CreateRemote(const MachineName: string): IElement; +begin + Result := CreateRemoteComObject(MachineName, CLASS_Element) as IElement; +end; + +procedure TElement.InitServerData; +const + CServerData: TServerData = ( + ClassID: '{53FB239D-7857-4F0D-9083-871D8C0EAE3A}'; + IntfIID: '{645B0717-C0AB-424D-B513-F083AD486BF1}'; + EventIID: '{2A8AAFD6-6E87-4967-BF6D-C3F6BB9B3BD1}'; + LicenseKey: nil; + Version: 500); +begin + ServerData := @CServerData; +end; + +procedure TElement.Connect; +var + punk: IUnknown; +begin + if FIntf = nil then + begin + punk := GetServer; + ConnectEvents(punk); + Fintf:= punk as IElement; + end; +end; + +procedure TElement.ConnectTo(svrIntf: IElement); +begin + Disconnect; + FIntf := svrIntf; + ConnectEvents(FIntf); +end; + +procedure TElement.DisConnect; +begin + if Fintf <> nil then + begin + DisconnectEvents(FIntf); + FIntf := nil; + end; +end; + +function TElement.GetDefaultInterface: IElement; +begin + if FIntf = nil then + Connect; + Assert(FIntf <> nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call "Connect" or "ConnectTo" before this operation'); + Result := FIntf; +end; + +constructor TElement.Create(AOwner: TComponent); +begin + inherited Create(AOwner); +end; + +destructor TElement.Destroy; +begin + inherited Destroy; +end; + +procedure TElement.InvokeEvent(DispID: TDispID; var Params: TVariantArray); +begin + case DispID of + -1: Exit; // DISPID_UNKNOWN + 1: if Assigned(FOnMouse) then + FOnMouse(Self, + IUnknown(TVarData(Params[0]).VPointer) as IElement {const IElement}, + Params[1] {Integer}, + Params[2] {Integer}, + Params[3] {Integer}, + Params[4] {Integer}, + Params[5] {Integer}); + 2: if Assigned(FOnKey) then + FOnKey(Self, + IUnknown(TVarData(Params[0]).VPointer) as IElement {const IElement}, + Params[1] {Integer}, + Params[2] {Integer}, + Params[3] {Integer}); + 3: if Assigned(FOnFocus) then + FOnFocus(Self, + IUnknown(TVarData(Params[0]).VPointer) as IElement {const IElement}, + Params[1] {Integer}); + 4: if Assigned(FOnTimer) then + FOnTimer(Self, Params[0] {Integer}); + 5: if Assigned(FOnSize) then + FOnSize(Self); + 6: if Assigned(FOnControlEvent) then + FOnControlEvent(Self, + IUnknown(TVarData(Params[0]).VPointer) as IElement {const IElement}, + Params[1] {Integer}, + Params[2] {Integer}, + IUnknown(TVarData(Params[3]).VPointer) as IElement {const IElement}); + 7: if Assigned(FOnScroll) then + FOnScroll(Self, + IUnknown(TVarData(Params[0]).VPointer) as IElement {const IElement}, + Params[1] {Integer}, + Params[2] {Integer}, + Params[3] {WordBool}); + end; {case DispID} +end; + +function TElement.Get_Tag: WideString; +begin + Result := DefaultInterface.Tag; +end; + +function TElement.Get_Value: OleVariant; +begin + Result := DefaultInterface.Value; +end; + +procedure TElement.Set_Value(pVal: OleVariant); +begin + DefaultInterface.Value := pVal; +end; + +function TElement.Get_Attr(const name: WideString): OleVariant; +begin + Result := DefaultInterface.Attr[name]; +end; + +procedure TElement.Set_Attr(const name: WideString; pVal: OleVariant); +begin + DefaultInterface.Attr[name] := pVal; +end; + +function TElement.Get_StyleAttr(const name: WideString): OleVariant; +begin + Result := DefaultInterface.StyleAttr[name]; +end; + +procedure TElement.Set_StyleAttr(const name: WideString; pVal: OleVariant); +begin + DefaultInterface.StyleAttr[name] := pVal; +end; + +function TElement.Get_HELEMENT: Integer; +begin + Result := DefaultInterface.HELEMENT; +end; + +function TElement.Select(const cssSelector: WideString): IElement; +begin + Result := DefaultInterface.Select(cssSelector); +end; + +function TElement.SelectAll(const cssSelector: WideString): IElements; +begin + Result := DefaultInterface.SelectAll(cssSelector); +end; + +procedure TElement.Position(out x: Integer; out y: Integer; ofWhat: ElementBoxType; + relTo: RelativeToType); +begin + DefaultInterface.Position(x, y, ofWhat, relTo); +end; + +procedure TElement.Dimension(out width: Integer; out height: Integer; ofWhat: ElementBoxType); +begin + DefaultInterface.Dimension(width, height, ofWhat); +end; + +function TElement.Call(const methodName: WideString; var params: PSafeArray): OleVariant; +begin + Result := DefaultInterface.Call(methodName, params); +end; + +class function CoElements.Create: IElements; +begin + Result := CreateComObject(CLASS_Elements) as IElements; +end; + +class function CoElements.CreateRemote(const MachineName: string): IElements; +begin + Result := CreateRemoteComObject(MachineName, CLASS_Elements) as IElements; +end; + +procedure TElements.InitServerData; +const + CServerData: TServerData = ( + ClassID: '{B1C8635C-12B4-40F7-8038-6134FC5D398F}'; + IntfIID: '{C7171909-9F92-48D7-8691-EFB3390DEE55}'; + EventIID: ''; + LicenseKey: nil; + Version: 500); +begin + ServerData := @CServerData; +end; + +procedure TElements.Connect; +var + punk: IUnknown; +begin + if FIntf = nil then + begin + punk := GetServer; + Fintf:= punk as IElements; + end; +end; + +procedure TElements.ConnectTo(svrIntf: IElements); +begin + Disconnect; + FIntf := svrIntf; +end; + +procedure TElements.DisConnect; +begin + if Fintf <> nil then + begin + FIntf := nil; + end; +end; + +function TElements.GetDefaultInterface: IElements; +begin + if FIntf = nil then + Connect; + Assert(FIntf <> nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call "Connect" or "ConnectTo" before this operation'); + Result := FIntf; +end; + +constructor TElements.Create(AOwner: TComponent); +begin + inherited Create(AOwner); +end; + +destructor TElements.Destroy; +begin + inherited Destroy; +end; + +function TElements.Get_Count: Integer; +begin + Result := DefaultInterface.Count; +end; + +function TElements.Get_Item(index: Integer): IElement; +begin + Result := DefaultInterface.Item[index]; +end; + +procedure Register; +begin + RegisterComponents(dtlOcxPage, [TSciter]); + RegisterComponents(dtlServerPage, [TElement, TElements]); +end; + +end. \ No newline at end of file diff --git a/src/CatStdSysMenu.pas b/src/CatStdSysMenu.pas new file mode 100644 index 0000000..40cb2dc --- /dev/null +++ b/src/CatStdSysMenu.pas @@ -0,0 +1,389 @@ +{ + Copyright © Colin Wilson 2002 + Modifications copyright (c) 2013-2014 Felipe Daragon + License: MPL 1.1 (see below) + + This is cmpStandardSystemMenu.pas with some minor modifications: + Added a public Load method to TStandardSystemMenu, and a StdSysMenu procedure + so there is no need to register the component and drop it to a form, + just add it to the uses clause and call: StdSysMenu(self) from the form. +} + +unit CatStdSysMenu; + +(*======================================================================* + | cmpStandardSystemMenu unit for MiscUnits package | + | | + | Drop one of these on your application's main form, and you get all | + | five items in the task bar icon menu (Restore, Move, Size, Minimize, | + | Maximize Close) instead of the measly three items that Windows gives | + | you by default | + | | + | | + | The contents of this file are subject to the Mozilla Public License | + | Version 1.1 (the "License"); you may not use this file except in | + | compliance with the License. You may obtain a copy of the License | + | at http://www.mozilla.org/MPL/ | + | | + | Software distributed under the License is distributed on an "AS IS" | + | basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See | + | the License for the specific language governing rights and | + | limitations under the License. | + | | + | Copyright © Colin Wilson 2002. All Rights Reserved | + | | + | Version Date By Description | + | ------- ---------- ---- ------------------------------------------| + | 1.0 2001 CPWW Original | + | 1.1 26/02/2002 CPWW Fixed design-time problems | + *======================================================================*) + +interface + +uses + Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus; + +const + scxRESTORE = $fff0; + scxMINIMIZE = SC_MINIMIZE; + scxMAXIMIZE = $fff3; + scxSIZE = $fff4; + scxMOVE = $fff5; + +type +//--------------------------------------------------------------------------- +// TStandardSystemMenu class + TStandardSystemMenu = class(TComponent) + private + fMenuHandle : HMenu; + fWindowMenuHandle : HMenu; + fObjectInstance : pointer; + fOldOwnerWindowProc : TFNWndProc; + + fSysObjectInstance : pointer; + fOldSysWindowProc : TFNWndProc; + + fIconic : boolean; + fMaximized : boolean; + + procedure CloneSystemMenu; + procedure OwnerWindowProc(var msg: TMessage); + procedure SysOwnerWindowProc(var msg: TMessage); + + procedure OnMinimized; + procedure OnMaximized; + procedure OnRestored (resetmax : boolean); + + function HookProc (var Msg : TMessage) : boolean; + + protected + procedure Loaded; override; + { Protected declarations } + public + procedure SetItemState (itemID, state : Integer); + procedure Load; + destructor Destroy; override; + { Public declarations } + published + { Published declarations } + end; + +procedure StdSysMenu(Comp: TComponent); + +implementation + +procedure StdSysMenu(Comp: TComponent); // FD +var + sm: TStandardSystemMenu; +begin + sm := TStandardSystemMenu.Create(Comp); + sm.Load; +end; + +{ TStandardSystemMenu } + +(*----------------------------------------------------------------------* + | TStandardSystemMenu.CloneSystemMenu | + | | + | Make the (hidden) application's system menu a copy of the main | + | form's system menu. | + *----------------------------------------------------------------------*) +procedure TStandardSystemMenu.CloneSystemMenu; +var + count : Integer; + item : TMenuItemInfo; + buffer : array [0..256] of char; + i : Integer; +begin + count := GetMenuItemCount (fMenuHandle); // Delete all application's system + while count > 0 do // menu items. + begin + DeleteMenu (fMenuHandle, 0, MF_BYPOSITION); + Dec (count) + end; + + count := GetMenuItemCount (fWindowMenuHandle); + + // Now copy entries from the main form's + // system menu to the application's system menu + for i := 0 to count - 1 do + begin + FillChar (item, sizeof (item), 0); + + if (Win32MajorVersion > 4) or ((Win32MajorVersion = 4) and (Win32MinorVersion >= 10)) then // Ie Win2K or '98 + begin + item.cbSize := sizeof (item); + item.fMask := MIIM_STATE or MIIM_BITMAP or MIIM_ID or MIIM_STRING or MIIM_FTYPE; + end + else + begin + item.cbSize := 44; // Sizeof old-style MENUITEMINFO + item.fMask := MIIM_STATE or MIIM_ID or MIIM_TYPE; + end; + item.cch := sizeof (buffer); + item.dwTypeData := buffer; + // Get details from window system menu + if GetMenuItemInfo (fWindowMenuHandle, i, True, item) then + begin + case item.wID of + SC_RESTORE : item.wID := scxRestore; + SC_MINIMIZE : item.wID := scxMinimize; + SC_MAXIMIZE : item.wID := scxMaximize; + SC_MOVE : item.wID := scxMove; + SC_SIZE : item.wID := scxSize; + end; + // Add item to application system menu. + InsertMenuItem (fMenuHandle, i, True, item) + end + else + RaiseLastOSError + end +end; + +(*----------------------------------------------------------------------* + | destructor TStandardSystemMenu.Destroy | + | | + | Tidy up | + *----------------------------------------------------------------------*) +destructor TStandardSystemMenu.Destroy; +begin + if Assigned (fObjectInstance) then + Classes.FreeObjectInstance (fObjectInstance); + + if Assigned (fSysObjectInstance) then + Classes.FreeObjectInstance (fSysObjectInstance); + + inherited; +end; + +(*----------------------------------------------------------------------* + | TStandardSystemMenu.HookProc | + | | + | Intercept WM_WINDOWPASCHANGING messages + *----------------------------------------------------------------------*) +function TStandardSystemMenu.HookProc(var Msg: TMessage): boolean; +var + LocalFlags: word; +begin + Result := false; + if Msg.Msg = WM_WindowPosChanging then + begin + with TWMWindowPosMsg(Msg).WindowPos^ do + begin + if (hWnd = Application.Handle) and + not IsIconic(hWnd) and + (cx > 0) and (cy > 0) then + begin + LocalFlags := flags or SWP_NoZOrder; + if TForm (Owner).BorderStyle = bsSizeable then + LocalFlags := LocalFlags and not SWP_NoSize + else + LocalFlags := LocalFlags or SWP_NoSize; + SetWindowPos(TForm (Owner).Handle, 0, x, y, cx, cy, LocalFlags); + TForm (Owner).Invalidate + end + end + end +end; + +(*----------------------------------------------------------------------* + | TStandardSystemMenu.Loaded | + | | + | Subclass the main form and the hidden application window | + *----------------------------------------------------------------------*) +procedure TStandardSystemMenu.Loaded; +begin + inherited; + if not (csDesigning in ComponentState) then + begin + fMenuHandle := GetSystemMenu (Application.Handle, False); + fWindowMenuHandle := GetSystemMenu ((Owner as TForm).Handle, False); + CloneSystemMenu; + + fObjectInstance := Classes.MakeObjectInstance (OwnerWindowProc); + fOldOwnerWindowProc := TfnWndProc (SetWindowLong (TForm (Owner).Handle, GWL_WNDPROC, Integer (fObjectInstance))); + + fSysObjectInstance := Classes.MakeObjectInstance (SysOwnerWindowProc); + fOldSysWindowProc := TfnWndProc (SetWindowLong (Application.Handle, GWL_WNDPROC, Integer (fSysObjectInstance))); + + Application.HookMainWindow(HookProc); + end +end; + +procedure TStandardSystemMenu.Load; +begin + Loaded;// FD +end; + +(*----------------------------------------------------------------------* + | TStandardSystemMenu.OnMaximized | + | | + | Main window maximized. Set the menu item states to reflect this. | + *----------------------------------------------------------------------*) +procedure TStandardSystemMenu.OnMaximized; +begin + fIconic := False; + fMaximized := True; + SetItemState (scxMinimize, MFS_ENABLED); + SetItemState (scxMaximize, MFS_DISABLED or MFS_GRAYED); + SetItemState (scxMove, MFS_DISABLED or MFS_GRAYED); + SetItemState (scxSize, MFS_DISABLED or MFS_GRAYED); + SetItemState (scxRestore, MFS_ENABLED); +end; + +(*----------------------------------------------------------------------* + | TStandardSystemMenu.OnMinimized | + | | + | Main window minimized. Set the menu item states to reflect this. | + *----------------------------------------------------------------------*) +procedure TStandardSystemMenu.OnMinimized; +begin + fIconic := True; + SetItemState (scxMinimize, MFS_DISABLED or MFS_GRAYED); + SetItemState (scxMaximize, MFS_ENABLED); + SetItemState (scxMove, MFS_DISABLED or MFS_GRAYED); + SetItemState (scxSize, MFS_DISABLED or MFS_GRAYED); + SetItemState (scxRestore, MFS_ENABLED); +end; + +(*----------------------------------------------------------------------* + | TStandardSystemMenu.OnRestored | + | | + | Main window restored. Set the menu item states to reflect this. | + *----------------------------------------------------------------------*) +procedure TStandardSystemMenu.OnRestored (resetmax : boolean); +begin + fIconic := False; + if resetmax then fMaximized := False; + if fMaximized then + OnMaximized + else + begin + SetItemState (scxMinimize, MFS_ENABLED); + SetItemState (scxMaximize, MFS_ENABLED); + SetItemState (scxMove, MFS_ENABLED); + SetItemState (scxSize, MFS_ENABLED); + SetItemState (scxRestore, MFS_DISABLED or MFS_GRAYED) + end +end; + +(*----------------------------------------------------------------------* + | TStandardSystemMenu.OwnerWindowProc | + | | + | Grab messages sent to the main form | + *----------------------------------------------------------------------*) +procedure TStandardSystemMenu.OwnerWindowProc (var msg : TMessage); +begin + with msg do + begin + if msg = WM_SIZE then // Window sized. Set menu item states. + begin + case wParam of + SIZE_MAXIMIZED : OnMaximized; + SIZE_MINIMIZED : OnMinimized; + SIZE_RESTORED : OnRestored (true) + end + end + else + if msg = WM_DESTROY then // Window destroyed - unsubclass + begin + SetWindowLong (TForm (Owner).Handle, GWL_WNDPROC, Integer (fOldOwnerWindowProc)); + SetWindowLong (Application.Handle, GWL_WNDPROC, Integer (fOldSysWindowProc)); + Application.UnHookMainWindow(HookProc); + end; + result := CallWindowProc (fOldOwnerWindowProc, TForm (Owner).Handle, msg, wParam, lParam) + end +end; + +(*----------------------------------------------------------------------* + | TStandardSystemMenu.SetItemState | + | | + | Set the required menu item state | + | | + | Parameters: | + | itemID : Integer The id of the item to adjust | + | state: Integer The new state | + *----------------------------------------------------------------------*) +procedure TStandardSystemMenu.SetItemState(itemID, state: Integer); +var + item : TMenuItemInfo; +begin + FillChar (item, SizeOf (item), 0); + item.cbSize := 44; + item.fMask := MIIM_STATE; + if GetMenuItemInfo (fMenuHandle, itemID, False, item) then + begin + item.fState := state; + SetMenuItemInfo (fMenuHandle, itemID, False, item) + end +end; + +(*----------------------------------------------------------------------* + | TStandardSystemMenu.SysOwnerWindowProc | + | | + | Intercept messages to the (hidden) application window | + *----------------------------------------------------------------------*) +procedure TStandardSystemMenu.SysOwnerWindowProc(var msg: TMessage); +var + m : Integer; +begin + with msg do + begin + if msg = WM_SYSCOMMAND then + begin + m := -1; + case wParam of + scxRestore : m := SC_RESTORE; + scxMinimize : m := SC_MINIMIZE; + scxMaximize : if fMaximized then // It's also minimized, but it *was* maximized so restore! + SendMessage (Application.Handle, WM_SYSCOMMAND, SC_RESTORE, lParam) + else + begin + if fIconic then + SendMessage (Application.Handle, WM_SYSCOMMAND, SC_RESTORE, lParam); + SendMessage (TForm (owner).Handle, WM_SYSCOMMAND, SC_MAXIMIZE, lParam); + end; + + scxMove : m := SC_MOVE; + scxSize : m := SC_SIZE; + end; + + if m <> -1 then + if fIconic then + SendMessage (Application.Handle, WM_SYSCOMMAND, m, lParam) + else + SendMessage (TForm (owner).Handle, WM_SYSCOMMAND, m, lParam); + end + else + if msg = WM_SIZE then + case wParam of + SIZE_MAXIMIZED : OnMaximized; + SIZE_MINIMIZED : OnMinimized; + SIZE_RESTORED : OnRestored (false) + end; + + result := CallWindowProc (fOldSysWindowProc, Application.Handle, msg, wParam, lParam); + end +end; + +end. diff --git a/src/CatStorage.pas b/src/CatStorage.pas new file mode 100644 index 0000000..c2e8ec3 --- /dev/null +++ b/src/CatStorage.pas @@ -0,0 +1,208 @@ +unit CatStorage; +{ + Catarinka Storage Object + + Copyright (c) 2013-2014 Felipe Daragon + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + System.Classes, System.SysUtils, Vcl.Forms, System.SyncObjs, Vcl.Dialogs, +{$ELSE} + Classes, SysUtils, Forms, SyncObjs, Dialogs, +{$IFEND} + GpStructuredStorage; + +type + TCatStorage = class + private + fCriticalSection: TCriticalSection; + fDeleteWhenFreeing: boolean; + fFilename: string; + fVFS: IGPStructuredStorage; + public + function CachedFileExists(const f: string): boolean; + function GetFilename: string; + function GetTextFile(const f: string): string; + procedure Clear; + procedure LoadFromFile(const cachefilename: string); + procedure MakeTemporary; + procedure New(const cachefilename: string); + procedure Open(const cachefilename: string); + procedure ExtractFile(const f, outfilename: string); + procedure SaveToFile(const cachefilename: string); + procedure SaveFolderToFile(const cachefilename: string; const folder: string = '/'); + procedure StoreFile(const vfs_filename, fs_filename: string); + procedure StoreString(const f, content: string); + constructor Create; + destructor Destroy; override; + // properties + property Filename: string read fFilename write fFilename; + published + end; + +implementation + +uses CatFiles, CatDCP, CatStrings, CatZIP, CatStringLoop; + +// Resets the cache +procedure TCatStorage.Clear; +begin + fVFS := nil; + fVFS := CreateStructuredStorage; + fVFS.Initialize(Filename, fmCreate); +end; + +function TCatStorage.CachedFileExists(const f: string): boolean; +begin + result := fVFS.FileExists(f); +end; + +// Extracts a cached file +procedure TCatStorage.ExtractFile(const f, outfilename: string); +var + v: TStream; + fs: TFileStream; +begin + v := fVFS.OpenFile(f, fmOpenRead); + fs := TFileStream.Create(outfilename, fmCreate); + fs.CopyFrom(v, v.Size); + fs.Free; + FreeAndNil(v); +end; + +// Gets the contents of a cached text file +function TCatStorage.GetTextFile(const f: string): string; +var + v: TStream; + sl: tstringlist; +begin + sl := tstringlist.Create; + v := fVFS.OpenFile(f, fmOpenRead); + sl.LoadFromStream(v); + result := sl.Text; + FreeAndNil(v); + sl.Free; +end; + +// Stores a disk file in the cache +procedure TCatStorage.StoreFile(const vfs_filename, fs_filename: string); +var + v: TStream; + fs: TFileStream; +begin + fs := TFileStream.Create(fs_filename, fmOpenRead); + v := fVFS.OpenFile(vfs_filename, fmCreate); + v.CopyFrom(fs, fs.Size); + FreeAndNil(v); + FreeAndNil(fs); +end; + +// Stores a string as a file in the cache +procedure TCatStorage.StoreString(const f, content: string); +var + v: TStream; + sl: tstringlist; +begin + fCriticalSection.Enter; + sl := tstringlist.Create; + sl.Text := content; + v := fVFS.OpenFile(f, fmCreate); + sl.SaveToStream(v); + FreeAndNil(v); + sl.Free; + // showmessage('storing: '+f+' size:'+inttostr(length(content))); +end; + +procedure TCatStorage.LoadFromFile(const cachefilename: string); +begin + if FileExists(cachefilename) = false then + exit; + fVFS := nil; // releases the storage file or we cannot copy the file + FileCopy(cachefilename, Filename); + fVFS := CreateStructuredStorage; + fVFS.Initialize(Filename, fmOpenReadWrite); +end; + +procedure TCatStorage.SaveToFile(const cachefilename: string); +begin + fVFS := nil; // releases the storage or we cannot copy the file + FileCopy(Filename, cachefilename); + fVFS := CreateStructuredStorage; + fVFS.Initialize(Filename, fmOpenReadWrite); // reopens the storage file +end; + +procedure TCatStorage.SaveFolderToFile(const cachefilename: string; + const folder: string = '/'); +var + slp: TStringLoop; + exportvfs: IGPStructuredStorage; + source, dest: TStream; + tempcachefilename: string; +begin + tempcachefilename := cachefilename + '.tmp'; + exportvfs := CreateStructuredStorage; + exportvfs.Initialize(tempcachefilename, fmCreate); + slp := TStringLoop.Create; + fVFS.FileNames(folder, slp.List); + while slp.Found do + begin + dest := exportvfs.OpenFile(folder + slp.current, fmCreate); + source := fVFS.OpenFile(folder + slp.current, fmOpenRead); + dest.CopyFrom(source, source.Size); + FreeAndNil(source); + FreeAndNil(dest); + end; + slp.Free; + exportvfs := nil; + FileCopy(tempcachefilename, cachefilename); + deletefile(tempcachefilename); +end; + +function TCatStorage.GetFilename: string; +begin + result := fFilename; +end; + +procedure TCatStorage.New(const cachefilename: string); +begin + Filename := cachefilename; + fVFS.Initialize(Filename, fmCreate); +end; + +procedure TCatStorage.Open(const cachefilename: string); +begin + if FileExists(cachefilename) = false then + exit; + fFilename := cachefilename; + fVFS.Initialize(cachefilename, fmOpenReadWrite); +end; + +procedure TCatStorage.MakeTemporary; +begin + fDeleteWhenFreeing := true; +end; + +constructor TCatStorage.Create; +begin + inherited Create; + fCriticalSection := TCriticalSection.Create; + fDeleteWhenFreeing := false; + fVFS := CreateStructuredStorage; +end; + +destructor TCatStorage.Destroy; +begin + fVFS := nil; + if fDeleteWhenFreeing then + deletefile(fFilename); + fCriticalSection.Free; + inherited; +end; + +// ------------------------------------------------------------------------// +end. diff --git a/src/CatStringLoop.pas b/src/CatStringLoop.pas new file mode 100644 index 0000000..d579d80 --- /dev/null +++ b/src/CatStringLoop.pas @@ -0,0 +1,241 @@ +{ + Catarinka TStringLoop + Loops through a string list + + Copyright (c) 2003-2014 Felipe Daragon + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details +} + +unit CatStringLoop; + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + System.Classes, System.SysUtils; +{$ELSE} + Classes, SysUtils; +{$IFEND} + +type + TStringLoop = class + protected + fCSV: TStringList; + fCurrent: string; + fIsCSV: boolean; + fList: TStringList; + fPosition: integer; + function GetCount: integer; + function GetCountAsStr: string; + function GetCurrentLower: string; + function GetCurrentUpper: string; + function GetLine(const l: integer): string; + procedure SetCurrent(const s: string); + procedure SetLine(const l: integer; const v: string); + public + constructor Create(const sl: tstrings = nil); + destructor Destroy; override; + procedure Load(const sl: tstrings); + procedure LoadFromString(const s: string); + procedure LoadFromFile(const filename: string); + procedure Reset; + procedure Stop; + procedure Clear; + function Found: boolean; + function GetValue(const s: string): string; + procedure SetValue(const s: string; const v: string); + function Index(const zerostart: boolean = true): integer; + function IndexAsStr: string; + function IndexOf(const s: string): integer; + function Contains(const s: string; const casesensitive: boolean = true): boolean; + procedure Delete; + property Lines[const l: integer]: string read GetLine write SetLine; + property Values[const s: string]: string read GetValue + write SetValue; default; + // properties + property Count: integer read GetCount; + property CountAsStr:string read GetCountAsStr; + property Current: string read fCurrent write SetCurrent; + property CurrentLower: string read GetCurrentLower; + property CurrentUpper: string read GetCurrentUpper; + property IsCSV: boolean read fIsCSV write fIsCSV; + property List: TStringList read FList; + published + end; + +implementation + +function TStringLoop.GetCount: integer; +begin + result := fList.Count; +end; + +procedure TStringLoop.Delete; +begin + fList.Delete(FPosition - 1); +end; + +function TStringLoop.Contains(const s: string; + const casesensitive: boolean = true): boolean; + procedure check(substr, str: string); + begin + if pos(substr, str) <> 0 then + result := true; + end; + +begin + result := false; + case casesensitive of + false: + check(uppercase(s), uppercase(FCurrent)); + true: + check(s, FCurrent); + end; +end; + +procedure TStringLoop.Stop; +begin + FPosition := fList.Count; +end; + +function TStringLoop.GetCurrentUpper: string; +begin + result := uppercase(FCurrent); +end; + +function TStringLoop.GetCurrentLower: string; +begin + result := lowercase(FCurrent); +end; + +function TStringLoop.IndexAsStr: string; +begin + result := inttostr(FPosition); +end; + +function TStringLoop.GetCountAsStr: string; +begin + result := inttostr(fList.Count); +end; + +function TStringLoop.IndexOf(const s: string): integer; +begin + result := fList.IndexOf(s); +end; + +function TStringLoop.Index(const zerostart: boolean = true): integer; +begin + result := FPosition; + if zerostart then + result := FPosition - 1; +end; + +procedure TStringLoop.Clear; +begin + fList.Clear; + Reset; +end; + +function TStringLoop.GetValue(const s: string): string; +begin + if isCSV = false then + fcsv.commatext := FCurrent; + result := fcsv.Values[s]; +end; + +procedure TStringLoop.SetValue(const s, v: string); +begin + if isCSV = false then + fcsv.commatext := FCurrent; + fcsv.Values[s] := v; + SetCurrent(fcsv.commatext); +end; + +function TStringLoop.GetLine(const l: integer): string; +begin + if isCSV = false then + fcsv.commatext := FCurrent; + try + result := fcsv[l]; + except + end; +end; + +procedure TStringLoop.SetLine(const l: integer; const v: string); +begin + if isCSV = false then + fcsv.commatext := FCurrent; + try + fcsv[l] := v; + except + end; + SetCurrent(fcsv.commatext); +end; + +procedure TStringLoop.SetCurrent(const s: string); +begin + FCurrent := s; + fList[FPosition - 1] := s; +end; + +function TStringLoop.Found: boolean; +var + i: integer; +begin + result := false; + i := FPosition; + if i < fList.Count then + begin + result := true; + FCurrent := fList[i]; + // If each line is a CSV string and the IsCSV property is set + // to true, it should be faster to retrive a value (via GetValue). + if isCSV then + fcsv.commatext := FCurrent; + FPosition := FPosition + 1; + end; +end; + +procedure TStringLoop.Reset; +begin + FPosition := 0; + FCurrent := emptystr; + fcsv.Clear; +end; + +procedure TStringLoop.LoadFromFile(const filename: string); +begin + fList.LoadFromFile(filename); + Reset; +end; + +procedure TStringLoop.LoadFromString(const s: string); +begin + fList.text := s; + Reset; +end; + +procedure TStringLoop.Load(const sl: tstrings); +begin + LoadFromString(sl.text); +end; + +constructor TStringLoop.Create(const sl: tstrings = nil); +begin + isCSV := false; + fList := tstringlist.Create; + fcsv := tstringlist.Create; + if sl <> nil then + Load(sl); + Reset; +end; + +destructor TStringLoop.Destroy; +begin + fList.free; + fcsv.free; + inherited; +end; + +end. diff --git a/src/CatStrings.pas b/src/CatStrings.pas new file mode 100644 index 0000000..b30a2e2 --- /dev/null +++ b/src/CatStrings.pas @@ -0,0 +1,1007 @@ +unit CatStrings; +{ + Catarinka - String Operation functions + + Copyright (c) 2003-2014 Felipe Daragon + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details + + Base64 encode and decode functions by Lukas Gebauer (BSD license, included below) + MD5 function by Stijn Sanders (MIT license, included at the end of this file) + IScan, SplitString, GetTextBetweenTags functions by Peter Below + + Note: random functions included with this library are not suitable + for cryptographic purposes. +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + System.Classes, System.SysUtils, System.StrUtils; +{$ELSE} + Classes, SysUtils, StrUtils; +{$IFEND} +function After(const s, substr: string): string; +function ASCIIToInt(const s: string): Integer; +function Base64Encode(const s: string): string; +function Base64Decode(const s: string): string; +function Before(const s, substr: string): string; +function BeginsWith(const s, prefix: string): Boolean; +function BoolToStr(const b: Boolean): string; +function BoolToYN(const b: Boolean): string; +function CatWrapText(const text: string; const chars: Integer): TStringList; +function CommaTextToStr(const s: string): string; +function EndsWith(const s, prefix: string): Boolean; +function ExtractFromString(const s, startstr, endstr: string): string; +function ExtractFromTag(const s, tag: string): string; +function GetLineByPos(const s: string; const Position: Integer): Integer; +function GetToken(const aString, SepChar: string; const TokenNum: Byte): string; +function GetValidCompName(const s: string): string; +function HexToInt(const Hex: string; const WarnError: Boolean = false): Integer; +function HexToStr(const s: string): string; +function IIF(const Cond: Boolean; const TrueStr: String; + const FalseStr: string = ''): string; overload; +function IIF(const Cond: Boolean; const TrueInt: Integer; + const FalseInt: Integer = 0): Integer; overload; +function IScan(ch: Char; const s: string; fromPos: Integer): Integer; +function IsHexStr(const s: string): Boolean; +function IsInteger(const s: string): Boolean; +function LastChar(const s: string): Char; +function LeftPad(const s: string; const c: Char; const len: Integer): string; +function LeftStr(s: string; c: longword): string; +function MatchStrings(const source, pattern: string): Boolean; +function MD5Hash(s: UTF8String): UTF8String; +function Occurs(substr, s: string): Integer; +function RandomString(const len: Integer; + const chars: string = 'abcdefghijklmnopqrstuvwxyz'): string; +function RemoveNumbers(const s: string): string; +function RemoveQuotes(const s: string): string; +function RemoveShortcuts(const s: string): string; +function RepeatString(const s: string; count: cardinal): string; +function ReplaceStr(const s, substr, repstr: string): string; +function RestStr(const s: string; const index: longword): string; +function RightPad(const s: string; const c: Char; const len: Integer): string; +function StrDecrease(const s: string; const step: Integer = 1): string; +function StrIncrease(const s: string; const step: Integer = 1): string; +function StripBadChars(const s: string; const badchars: TSysCharSet): string; +function StrToAlphaNum(const s: string): string; +function StrToBool(const s: string): Boolean; +function StrToCommaText(const s: string): string; +function StrToHex(const s: string): string; +function StrToIntSafe(const s: string; const FalseInt: Integer = 0): Integer; +function StrToPWideChar(const s: string): PWideChar; +function TitleCase(const s: string): string; +procedure GetTextBetweenTags(const s, tag1, tag2: string; const list: TStrings; + const includetags: Boolean = false); +procedure MergeStrings(const dest, source: TStrings); +procedure SplitString(const s: string; separator: Char; + substrings: TStringList); +procedure StripBlankLines(const sl: TStringList); + +const + CRLF = #13 + #10; + +implementation + +function After(const s, substr: string): string; +var + i: Byte; +begin + i := pos(substr, s); + if i = 0 then + result := emptystr + else + result := Copy(s, i + length(substr), length(s)); +end; + +function ASCIIToInt(const s: string): Integer; +var + i, len: Integer; + c: Char; +begin + result := 0; + len := length(s); + for i := len downto 1 do + begin + c := s[i]; + result := result + ord(c) shl ((len - i) shl 8); + end; +end; + +function Before(const s, substr: string): string; +var + i: Byte; +begin + i := pos(substr, s); + if i = 0 then + result := s + else + result := Copy(s, 1, i - 1); +end; + +function BeginsWith(const s, prefix: string): Boolean; +var + tmpstr: string; +begin + tmpstr := s; +{$IFDEF UNICODE} + SetLength(tmpstr, StrLen(PAnsiChar(AnsiString(prefix)))); +{$ELSE} + SetLength(tmpstr, StrLen(PChar(prefix))); +{$ENDIF} + result := AnsiCompareText(tmpstr, prefix) = 0; +end; + +function BoolToStr(const b: Boolean): string; +begin + if b = true then + result := 'True' + else + result := 'False'; +end; + +function BoolToYN(const b: Boolean): string; +begin + if b = true then + result := 'Yes' + else + result := 'No'; +end; + +// Wraps a text and returns it as a stringlist +function CatWrapText(const text: string; const chars: Integer): TStringList; +var + sl: TStringList; + P, ln: Integer; + s, newln: string; +begin + sl := TStringList.Create; + result := sl; + if length(text) = 0 then + Exit; + ln := 0; + sl.Add(emptystr); + s := text + ' '; + P := pos(' ', s); + while P <> 0 do + begin + newln := Copy(s, 1, P); + if (length(sl.Strings[ln]) + length(newln)) < (chars + 1) then + sl.Strings[ln] := sl.Strings[ln] + newln + else + begin + sl.Add(newln); + inc(ln); + end; + Delete(s, 1, P); + P := pos(' ', s); + end; +end; + +function EndsWith(const s, prefix: string): Boolean; +begin + result := AnsiEndsStr(prefix, s); +end; + +function ExtractFromTag(const s, tag: string): string; +begin + result := ExtractFromString(s, '<' + tag + '>', ''); +end; + +function GetLineByPos(const s: string; const Position: Integer): Integer; +var + i, ln: Integer; +begin + result := -1; + if (Position = -1) then + Exit; + + i := 1; + ln := 0; + while i < Position do + begin + if (s[i] = #13) then + ln := ln + 1; + i := i + 1; + end; + result := ln; +end; + +// Returns a valid Pascal component name (stripping invalid chars) +function GetValidCompName(const s: string): string; +var + i: Integer; +begin + result := emptystr; + for i := 1 to length(s) do + begin + if (s[i] in ['0' .. '9', 'A' .. 'Z', 'a' .. 'z', '_']) then + result := result + Copy(s, i, 1); + end; +end; + +function HexToInt(const Hex: string; const WarnError: Boolean = false): Integer; +begin + if IsHexStr(Hex) then + result := StrToInt('$' + Hex) + else + begin + if WarnError = true then + raise EConvertError.Create('Invalid character in hex string') + else + result := 0; + end; +end; + +function IIF(const Cond: Boolean; const TrueStr: String; + const FalseStr: String = ''): string; overload; +begin + if Cond = true then + result := TrueStr + else + result := FalseStr; +end; + +function IIF(const Cond: Boolean; const TrueInt: Integer; + const FalseInt: Integer = 0): Integer; overload; +begin + if Cond = true then + result := TrueInt + else + result := FalseInt; +end; + +function IsInteger(const s: string): Boolean; +var + v, c: Integer; +begin + Val(s, v, c); + result := c = 0; +end; + +// Returns true if the string contains valid hexadecimal digits +function IsHexStr(const s: string): Boolean; +var + i: Integer; +begin + result := true; + for i := 1 to length(s) do + if not(s[i] in ['0' .. '9', 'A' .. 'F', 'a' .. 'f']) then + begin + result := false; + Break; + end; +end; + +function LastChar(const s: string): Char; +begin + if s = emptystr then + result := #0 + else + result := s[length(s)]; +end; + +function LeftPad(const s: string; const c: Char; const len: Integer): string; +var + i: Integer; +begin + result := s; + i := len - length(s); + if i < 1 then + Exit; + result := s + StringOfChar(c, i); +end; + +function RightPad(const s: string; const c: Char; const len: Integer): string; +var + i: Integer; +begin + result := s; + i := len - length(s); + if i < 1 then + Exit; + result := StringOfChar(c, i) + s; +end; + +function LeftStr(s: string; c: longword): string; +begin + result := Copy(s, 1, c); +end; + +procedure MergeStrings(const dest, source: TStrings); +var + i: Integer; +begin + for i := 0 to -1 + source.count do + if dest.IndexOf(source[i]) = -1 then + dest.Add(source[i]); +end; + +function Occurs(substr, s: string): Integer; +var + i: Integer; +begin + result := 0; + for i := 1 to length(s) do + if Copy(s, i, length(substr)) = substr then + inc(result); +end; + +function RandomString(const len: Integer; + const chars: string = 'abcdefghijklmnopqrstuvwxyz'): string; +begin + Randomize; + result := emptystr; + repeat + result := result + chars[Random(length(chars)) + 1]; + until (length(result) = len); +end; + +function RemoveQuotes(const s: string): string; +begin + result := AnsiDequotedStr(s, '"'); + result := AnsiDequotedStr(result, ''''); + if length(result) <> 2 then + Exit; + if result = '""' then + result := emptystr + else if result = '''''' then + result := emptystr; +end; + +function RemoveNumbers(const s: string): string; +var + i, l: Integer; +begin + SetLength(result, length(s)); + l := 0; + for i := 1 to length(s) do + if not(s[i] in ['0' .. '9']) then + begin + inc(l); + result[l] := s[i]; + end; + SetLength(result, l); +end; + +function RemoveShortcuts(const s: string): string; +begin + result := ReplaceStr(s, '&', emptystr); +end; + +function RepeatString(const s: string; count: cardinal): string; +var + i: Integer; +begin + for i := 1 to count do + result := result + s; +end; + +function ReplaceStr(const s, substr, repstr: string): string; +begin + result := stringreplace(s, substr, repstr, [rfReplaceAll]); +end; + +function StrIncrease(const s: string; const step: Integer = 1): string; +var + i, c: Integer; + tmpstr: WideString; +begin + tmpstr := ''; + for i := 1 to length(s) do + begin + c := ord(s[i]); + inc(c, step); + tmpstr := tmpstr + widechar(c); + end; + result := tmpstr; +end; + +function StrDecrease(const s: string; const step: Integer = 1): string; +var + i, c: Integer; + tmpstr: WideString; +begin + tmpstr := ''; + for i := 1 to length(s) do + begin + c := ord(s[i]); + dec(c, step); + tmpstr := tmpstr + widechar(c); + end; + result := tmpstr; +end; + +function RestStr(const s: string; const index: longword): string; +var + l: Integer; +begin + l := length(s); + if l > 0 then + result := Copy(s, index, l) + else + result := emptystr; +end; + +procedure StripBlankLines(const sl: TStringList); +var + i: Integer; +begin + for i := (sl.count - 1) downto 0 do + begin + if (Trim(sl[i]) = emptystr) then + sl.Delete(i); + end; +end; + +function StrToCommaText(const s: string): string; +var + sl: TStringList; +begin + sl := TStringList.Create; + sl.text := s; + result := sl.CommaText; + sl.free; +end; + +function StripBadChars(const s: string; const badchars: TSysCharSet): string; +var + i, P: Integer; +begin + P := 0; + SetLength(result, length(s)); + for i := 1 to length(s) do + begin + if not(s[i] in badchars) then + begin + inc(P); + result[P] := s[i]; + end; + end; + SetLength(result, P); +end; + +function CommaTextToStr(const s: string): string; +var + sl: TStringList; +begin + sl := TStringList.Create; + sl.CommaText := s; + result := sl.GetText; + sl.free; +end; + +function StrToAlphaNum(const s: string): string; +var + i: Integer; + tmpstr: string; +begin + tmpstr := emptystr; + for i := 1 to length(s) do + begin + if (s[i] in ['0' .. '9', 'A' .. 'Z', 'a' .. 'z']) then + tmpstr := tmpstr + Copy(s, i, 1); + end; + result := tmpstr; +end; + +function StrToBool(const s: string): Boolean; +var + tmpstr: string; +begin + tmpstr := Trim(LowerCase(s)); + if (tmpstr = 'true') or (tmpstr = '1') or (tmpstr = 'yes') or (tmpstr = 'y') + then + result := true + else + result := false; +end; + +function StrToHex(const s: string): string; +var + i: Integer; +begin + result := emptystr; + for i := 1 to length(s) do + result := result + IntToHex(ord(Copy(s, i, 1)[1]), 2); +end; + +function StrToIntSafe(const s: string; const FalseInt: Integer = 0): Integer; +begin + if IsInteger(s) then + result := StrToInt(s) + else + result := FalseInt; +end; + +function StrToPWideChar(const s: string): PWideChar; +begin + result := PWideChar(WideString(s)); +end; + +function HexToStr(const s: string): string; +var + i: Integer; + h: string; +begin + result := emptystr; + try + for i := 1 to length(s) div 2 do + begin + h := Copy(s, (i - 1) * 2 + 1, 2); + result := result + Char(StrToInt('$' + h)); + end; + except + result := emptystr; + end; +end; + +function TitleCase(const s: string): string; +var + i: Integer; +begin + if s = emptystr then + result := emptystr + else + begin + result := Uppercase(s[1]); + for i := 2 to length(s) do + if s[i - 1] = ' ' then + result := result + Uppercase(s[i]) + else + result := result + LowerCase(s[i]); + end; +end; + +// CONTRIBUTED ------------------------------------------------------------// + +// Peter Below, 11.27.1996 +function IScan(ch: Char; const s: string; fromPos: Integer): Integer; +var + i: Integer; +begin + result := 0; + for i := fromPos to length(s) do + begin + if s[i] = ch then + begin + result := i; + Break; + end; + end; +end; + +// PB, 08.07.1997 +procedure SplitString(const s: string; separator: Char; + substrings: TStringList); +var + i, n: Integer; +begin + if Assigned(substrings) and (length(s) > 0) then + begin + i := 1; + repeat + n := IScan(separator, s, i); + if n = 0 then + n := length(s) + 1; + substrings.Add(Copy(s, i, n - i)); + i := n + 1; + until i > length(s); + end; +end; + +// Based on an example by PB +procedure GetTextBetweenTags(const s, tag1, tag2: string; const list: TStrings; + const includetags: Boolean = false); +var + pScan, pEnd, pTag1, pTag2: {$IFDEF UNICODE}PAnsiChar{$ELSE}PChar{$ENDIF}; + foundText, searchtext: string; +begin + searchtext := Uppercase(s); + pTag1 := {$IFDEF UNICODE}PAnsiChar{$ELSE}PChar{$ENDIF}(Uppercase(tag1)); + pTag2 := {$IFDEF UNICODE}PAnsiChar{$ELSE}PChar{$ENDIF}(Uppercase(tag2)); + pScan := {$IFDEF UNICODE}PAnsiChar{$ELSE}PChar{$ENDIF}(searchtext); + repeat + pScan := StrPos(pScan, pTag1); + if pScan <> nil then + begin + inc(pScan, length(tag1)); + pEnd := StrPos(pScan, pTag2); + if pEnd <> nil then + begin + SetString(foundText, +{$IFDEF UNICODE}PAnsiChar{$ELSE}PChar{$ENDIF}(s) + (pScan - +{$IFDEF UNICODE}PAnsiChar{$ELSE}PChar{$ENDIF}(searchtext)), pEnd - pScan); + if includetags then + list.Add(Uppercase(tag1) + foundText + Uppercase(tag2)) + else + list.Add(foundText); + list.text := list.GetText; + pScan := pEnd + length(tag2); + end + else + pScan := nil; + end; + until pScan = nil; +end; + +// Based on an example by Mike Orriss +function ExtractFromString(const s, startstr, endstr: string): string; +var + ps, pe: Integer; +begin + ps := pos(startstr, s); + pe := pos(endstr, s); + if (pe <= ps) or (ps = 0) then + result := emptystr + else + begin + inc(ps, length(startstr)); + result := Copy(s, ps, pe - ps); + end; +end; + +// Based on an example from Thomas Scheffczyk +function GetToken(const aString, SepChar: String; const TokenNum: Byte): String; +var + Token, tmpstr: String; + StrLen, Num, EndofToken: Integer; +begin + tmpstr := aString; + StrLen := length(tmpstr); + Num := 1; + EndofToken := StrLen; + while ((Num <= TokenNum) and (EndofToken <> 0)) do + begin + EndofToken := pos(SepChar, tmpstr); + if EndofToken <> 0 then + begin + Token := Copy(tmpstr, 1, EndofToken - 1); + Delete(tmpstr, 1, EndofToken); + inc(Num); + end + else + Token := tmpstr; + end; + if Num >= TokenNum then + result := Token + else + result := emptystr; +end; + +{ + This function takes two strings and compares them. The first string + can be anything, but should not contain pattern characters (* or ?). + The pattern string can have as many of these pattern characters as you want. + For example: MatchStrings('David Stidolph','*St*') would return True. + + Original code by Sean Stanley in C + Rewritten in Pascal by David Stidolph + Slightly modified by Felipe Daragon (XE2 and higher support) +} +function MatchStrings(const source, pattern: String): Boolean; +var + pSource: Array [0 .. 255] of {$IFDEF UNICODE}AnsiChar{$ELSE}Char{$ENDIF}; + pPattern: Array [0 .. 255] of {$IFDEF UNICODE}AnsiChar{$ELSE}Char{$ENDIF}; + + function MatchPattern(element, pattern: +{$IFDEF UNICODE}PAnsiChar{$ELSE}PChar{$ENDIF}): Boolean; + + function IsPatternWild(pattern: +{$IFDEF UNICODE}PAnsiChar{$ELSE}PChar{$ENDIF}): Boolean; + // var t: Integer; + begin + result := StrScan(pattern, '*') <> nil; + if not result then + result := StrScan(pattern, '?') <> nil; + end; + + begin + if 0 = StrComp(pattern, '*') then + result := true + else if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then + result := false + else if element^ = Chr(0) then + result := true + else + begin + case pattern^ of + '*': + if MatchPattern(element, @pattern[1]) then + result := true + else + result := MatchPattern(@element[1], pattern); + '?': + result := MatchPattern(@element[1], @pattern[1]); + else + if element^ = pattern^ then + result := MatchPattern(@element[1], @pattern[1]) + else + result := false; + end; + end; + end; + +begin + StrPCopy(pSource, source); + StrPCopy(pPattern, pattern); + result := MatchPattern(pSource, pPattern); +end; + +// CONTRIBUTED ------------------------------------------------------------// +// Base64 encoder and decoder taken from Ararat Synapse's synacode.pas +{ + | Copyright (c)1999-2007, Lukas Gebauer | + | All rights reserved. | + | | + | Redistribution and use in source and binary forms, with or without | + | modification, are permitted provided that the following conditions are met: | + | | + | Redistributions of source code must retain the above copyright notice, this | + | list of conditions and the following disclaimer. | + | | + | Redistributions in binary form must reproduce the above copyright notice, | + | this list of conditions and the following disclaimer in the documentation | + | and/or other materials provided with the distribution. | + | | + | Neither the name of Lukas Gebauer nor the names of its contributors may | + | be used to endorse or promote products derived from this software without | + | specific prior written permission. | + | | + | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | + | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | + | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | + | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | + | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | + | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | + | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | + | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | + | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | + | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | + | DAMAGE. | +} +function Encode3to4(const Value, Table: AnsiString): AnsiString; +var + c: Byte; + n, l: Integer; + count: Integer; + DOut: array [0 .. 3] of Byte; +begin + SetLength(result, ((length(Value) + 2) div 3) * 4); + l := 1; + count := 1; + while count <= length(Value) do + begin + c := ord(Value[count]); + inc(count); + DOut[0] := (c and $FC) shr 2; + DOut[1] := (c and $03) shl 4; + if count <= length(Value) then + begin + c := ord(Value[count]); + inc(count); + DOut[1] := DOut[1] + (c and $F0) shr 4; + DOut[2] := (c and $0F) shl 2; + if count <= length(Value) then + begin + c := ord(Value[count]); + inc(count); + DOut[2] := DOut[2] + (c and $C0) shr 6; + DOut[3] := (c and $3F); + end + else + begin + DOut[3] := $40; + end; + end + else + begin + DOut[2] := $40; + DOut[3] := $40; + end; + for n := 0 to 3 do + begin + if (DOut[n] + 1) <= length(Table) then + begin + result[l] := Table[DOut[n] + 1]; + inc(l); + end; + end; + end; + SetLength(result, l - 1); +end; + +function Decode4to3Ex(const Value, Table: AnsiString): AnsiString; +var + x, y, lv: Integer; + d: Integer; + dl: Integer; + c: Byte; + P: Integer; +begin + lv := length(Value); + SetLength(result, lv); + x := 1; + dl := 4; + d := 0; + P := 1; + while x <= lv do + begin + y := ord(Value[x]); + if y in [33 .. 127] then + c := ord(Table[y - 32]) + else + c := 64; + inc(x); + if c > 63 then + continue; + d := (d shl 6) or c; + dec(dl); + if dl <> 0 then + continue; + result[P] := AnsiChar((d shr 16) and $FF); + inc(P); + result[P] := AnsiChar((d shr 8) and $FF); + inc(P); + result[P] := AnsiChar(d and $FF); + inc(P); + d := 0; + dl := 4; + end; + case dl of + 1: + begin + d := d shr 2; + result[P] := AnsiChar((d shr 8) and $FF); + inc(P); + result[P] := AnsiChar(d and $FF); + inc(P); + end; + 2: + begin + d := d shr 4; + result[P] := AnsiChar(d and $FF); + inc(P); + end; + end; + SetLength(result, P - 1); +end; + +function Base64Encode(const s: string): string; +const + TableBase64 = + 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/='; +begin + result := string(Encode3to4(AnsiString(s), TableBase64)); +end; + +function Base64Decode(const s: string): string; +const + ReTablebase64 = #$40 + #$40 + #$40 + #$40 + #$40 + #$40 + #$40 + #$40 + #$40 + + #$40 + #$3E + #$40 + #$40 + #$40 + #$3F + #$34 + #$35 + #$36 + #$37 + #$38 + + #$39 + #$3A + #$3B + #$3C + #$3D + #$40 + #$40 + #$40 + #$40 + #$40 + #$40 + + #$40 + #$00 + #$01 + #$02 + #$03 + #$04 + #$05 + #$06 + #$07 + #$08 + #$09 + + #$0A + #$0B + #$0C + #$0D + #$0E + #$0F + #$10 + #$11 + #$12 + #$13 + #$14 + + #$15 + #$16 + #$17 + #$18 + #$19 + #$40 + #$40 + #$40 + #$40 + #$40 + #$40 + + #$1A + #$1B + #$1C + #$1D + #$1E + #$1F + #$20 + #$21 + #$22 + #$23 + #$24 + + #$25 + #$26 + #$27 + #$28 + #$29 + #$2A + #$2B + #$2C + #$2D + #$2E + #$2F + + #$30 + #$31 + #$32 + #$33 + #$40 + #$40 + #$40 + #$40 + #$40 + #$40; +begin + result := string(Decode4to3Ex(AnsiString(s), ReTablebase64)); +end; + +{ + + Taken from md5.pas v1.0.3 + Copyright 2012-2013 Stijn Sanders + License: MIT (http://opensource.org/licenses/mit-license.php) + + https://github.com/stijnsanders/TMongoWire/blob/master/mongoAuth.pas + + Based on http://www.ietf.org/rfc/rfc1321.txt + +} + +function MD5Hash(s: UTF8String): UTF8String; +const + roll1: array [0 .. 3] of cardinal = (7, 12, 17, 22); + roll2: array [0 .. 3] of cardinal = (5, 9, 14, 20); + roll3: array [0 .. 3] of cardinal = (4, 11, 16, 23); + roll4: array [0 .. 3] of cardinal = (6, 10, 15, 21); + base1: array [0 .. 15] of cardinal = ($D76AA478, $E8C7B756, $242070DB, + $C1BDCEEE, $F57C0FAF, $4787C62A, $A8304613, $FD469501, $698098D8, $8B44F7AF, + $FFFF5BB1, $895CD7BE, $6B901122, $FD987193, $A679438E, $49B40821); + base2: array [0 .. 15] of cardinal = ($F61E2562, $C040B340, $265E5A51, + $E9B6C7AA, $D62F105D, $02441453, $D8A1E681, $E7D3FBC8, $21E1CDE6, $C33707D6, + $F4D50D87, $455A14ED, $A9E3E905, $FCEFA3F8, $676F02D9, $8D2A4C8A); + base3: array [0 .. 15] of cardinal = ($FFFA3942, $8771F681, $6D9D6122, + $FDE5380C, $A4BEEA44, $4BDECFA9, $F6BB4B60, $BEBFBC70, $289B7EC6, $EAA127FA, + $D4EF3085, $04881D05, $D9D4D039, $E6DB99E5, $1FA27CF8, $C4AC5665); + base4: array [0 .. 15] of cardinal = ($F4292244, $432AFF97, $AB9423A7, + $FC93A039, $655B59C3, $8F0CCC92, $FFEFF47D, $85845DD1, $6FA87E4F, $FE2CE6E0, + $A3014314, $4E0811A1, $F7537E82, $BD3AF235, $2AD7D2BB, $EB86D391); + Hex: array [0 .. 15] of AnsiChar = '0123456789abcdef'; +var + a: cardinal; + dl, i, j, k, l: Integer; + d: array of cardinal; + g, h: array [0 .. 3] of cardinal; +begin + a := length(s); + dl := a + 9; + if (dl and $3F) <> 0 then + dl := (dl and $FFC0) + $40; + i := dl; + dl := dl shr 2; + SetLength(d, dl); + SetLength(s, i); + j := a + 1; + s[j] := #$80; + while j < i do + begin + inc(j); + s[j] := #0; + end; + Move(s[1], d[0], i); + d[dl - 2] := a shl 3; + h[0] := $67452301; + h[1] := $EFCDAB89; + h[2] := $98BADCFE; + h[3] := $10325476; + i := 0; + while i < dl do + begin + g := h; + j := i; + for k := 0 to 15 do + begin + l := k * 3; + a := h[l and 3] + ((h[(l + 1) and 3] and h[(l + 2) and 3]) or + (not(h[(l + 1) and 3]) and h[(l + 3) and 3])) + d[j] + base1[k]; + h[l and 3] := h[(l + 1) and 3] + + ((a shl roll1[k and 3]) or (a shr (32 - roll1[k and 3]))); + inc(j); + end; + j := 1; + for k := 0 to 15 do + begin + l := k * 3; + a := h[l and 3] + ((h[(l + 3) and 3] and h[(l + 1) and 3]) or + (not(h[(l + 3) and 3]) and h[(l + 2) and 3])) + d[i or (j and $F)] + + base2[k]; + h[l and 3] := h[(l + 1) and 3] + + ((a shl roll2[k and 3]) or (a shr (32 - roll2[k and 3]))); + inc(j, 5); + end; + j := 5; + for k := 0 to 15 do + begin + l := k * 3; + a := h[l and 3] + (h[(l + 1) and 3] xor h[(l + 2) and 3] xor h[(l + 3) and + 3]) + d[i or (j and $F)] + base3[k]; + h[l and 3] := h[(l + 1) and 3] + + ((a shl roll3[k and 3]) or (a shr (32 - roll3[k and 3]))); + inc(j, 3); + end; + j := 0; + for k := 0 to 15 do + begin + l := k * 3; + a := h[l and 3] + (h[(l + 2) and 3] xor (h[(l + 1) and 3] or + not h[(l + 3) and 3])) + d[i or (j and $F)] + base4[k]; + h[l and 3] := h[(l + 1) and 3] + + ((a shl roll4[k and 3]) or (a shr (32 - roll4[k and 3]))); + inc(j, 7); + end; + for k := 0 to 3 do + inc(h[k], g[k]); + inc(i, 16); + end; + SetLength(result, 32); + for k := 0 to 31 do + result[k + 1] := Hex[h[k shr 3] shr ((k xor 1) shl 2) and $F]; +end; + +// ------------------------------------------------------------------------// +end. diff --git a/src/CatSynEdit.pas b/src/CatSynEdit.pas new file mode 100644 index 0000000..6bf25be --- /dev/null +++ b/src/CatSynEdit.pas @@ -0,0 +1,240 @@ +unit CatSynEdit; + +{ + Catarinka TCatSynEdit - Enhanced SynEdit with popup menu + Copyright (c) 2013-2014 Felipe Daragon + Based on uSynEditPopupEdit.pas by Rodrigo Ruz V + + License: MIT (http://opensource.org/licenses/mit-license.php) + Same license as the original code. +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + Winapi.Messages, System.Classes, System.Types, System.SysUtils, + Winapi.Windows, Vcl.ActnList, +{$ELSE} + Messages, Classes, Types, SysUtils, Windows, ActnList, +{$IFEND} + Menus, SynEdit; + +{$DEFINE OVMOUSEWHEEL} + +type + TCatSynEdit = class(SynEdit.TSynEdit) + private + FActnList: TActionList; + FPopupMenu: TPopupMenu; + procedure CreateActns; + procedure FillPopupMenu(APopupMenu: TPopupMenu); + procedure CutExecute(Sender: TObject); + procedure CutUpdate(Sender: TObject); + procedure CopyExecute(Sender: TObject); + procedure CopyUpdate(Sender: TObject); + procedure PasteExecute(Sender: TObject); + procedure PasteUpdate(Sender: TObject); + procedure DeleteExecute(Sender: TObject); + procedure DeleteUpdate(Sender: TObject); + procedure SelectAllExecute(Sender: TObject); + procedure SelectAllUpdate(Sender: TObject); + procedure RedoExecute(Sender: TObject); + procedure RedoUpdate(Sender: TObject); + procedure UndoExecute(Sender: TObject); + procedure UndoUpdate(Sender: TObject); + procedure SetPopupMenu_(const Value: TPopupMenu); + function GetPopupMenu_: TPopupMenu; + protected + {$IFDEF OVMOUSEWHEEL} + function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; + MousePos: TPoint): Boolean; override; + {$ENDIF} + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + published + property PopupMenu: TPopupMenu read GetPopupMenu_ write SetPopupMenu_; + end; + +implementation + +const + MenuName = 'uSynEditPopupMenu'; + +{$IFDEF OVMOUSEWHEEL} +function TCatSynEdit.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; + MousePos: TPoint): Boolean; +var + I: Integer; +begin + Result := inherited DoMouseWheel(Shift, WheelDelta, MousePos); + if WheelDelta < 0 then + begin + for I := 1 to 10 do + Perform(WM_VSCROLL, MAKELONG(SB_LINEDOWN, 0), 0); + end + else if WheelDelta > 0 then + begin + for I := 1 to 10 do + Perform(WM_VSCROLL, MAKELONG(SB_LINEUP, 0), 0); + end; +end; +{$ENDIF} + +procedure TCatSynEdit.CopyExecute(Sender: TObject); +begin + Self.CopyToClipboard; +end; + +procedure TCatSynEdit.CopyUpdate(Sender: TObject); +begin + TAction(Sender).Enabled := Self.SelAvail; +end; + +procedure TCatSynEdit.CutExecute(Sender: TObject); +begin + Self.CutToClipboard; +end; + +procedure TCatSynEdit.CutUpdate(Sender: TObject); +begin + TAction(Sender).Enabled := Self.SelAvail and not Self.ReadOnly; +end; + +procedure TCatSynEdit.DeleteExecute(Sender: TObject); +begin + Self.SelText := ''; +end; + +procedure TCatSynEdit.DeleteUpdate(Sender: TObject); +begin + TAction(Sender).Enabled := Self.SelAvail and not Self.ReadOnly; +end; + +procedure TCatSynEdit.PasteExecute(Sender: TObject); +begin + Self.PasteFromClipboard; +end; + +procedure TCatSynEdit.PasteUpdate(Sender: TObject); +begin + TAction(Sender).Enabled := Self.CanPaste; +end; + +procedure TCatSynEdit.RedoExecute(Sender: TObject); +begin + Self.Redo; +end; + +procedure TCatSynEdit.RedoUpdate(Sender: TObject); +begin + TAction(Sender).Enabled := Self.CanRedo; +end; + +procedure TCatSynEdit.SelectAllExecute(Sender: TObject); +begin + Self.SelectAll; +end; + +procedure TCatSynEdit.SelectAllUpdate(Sender: TObject); +begin + TAction(Sender).Enabled := Self.Lines.Text <> ''; +end; + +procedure TCatSynEdit.UndoExecute(Sender: TObject); +begin + Self.Undo; +end; + +procedure TCatSynEdit.UndoUpdate(Sender: TObject); +begin + TAction(Sender).Enabled := Self.CanUndo; +end; + +constructor TCatSynEdit.Create(AOwner: TComponent); +begin + inherited; + FActnList := TActionList.Create(Self); + FPopupMenu := TPopupMenu.Create(Self); + FPopupMenu.Name := MenuName; + CreateActns; + FillPopupMenu(FPopupMenu); + PopupMenu := FPopupMenu; +end; + +procedure TCatSynEdit.CreateActns; + + procedure AddActItem(const AText: string; AShortCut: TShortCut; + AEnabled: Boolean; OnExecute, OnUpdate: TNotifyEvent); + Var + ActionItem: TAction; + begin + ActionItem := TAction.Create(FActnList); + ActionItem.ActionList := FActnList; + ActionItem.Caption := AText; + ActionItem.ShortCut := AShortCut; + ActionItem.Enabled := AEnabled; + ActionItem.OnExecute := OnExecute; + ActionItem.OnUpdate := OnUpdate; + end; + +begin + AddActItem('&Undo', Menus.ShortCut(Word('Z'), [ssCtrl]), False, UndoExecute, + UndoUpdate); + AddActItem('&Redo', Menus.ShortCut(Word('Z'), [ssCtrl, ssShift]), False, + RedoExecute, RedoUpdate); + AddActItem('-', 0, False, nil, nil); + AddActItem('Cu&t', Menus.ShortCut(Word('X'), [ssCtrl]), False, CutExecute, + CutUpdate); + AddActItem('&Copy', Menus.ShortCut(Word('C'), [ssCtrl]), False, CopyExecute, + CopyUpdate); + AddActItem('&Paste', Menus.ShortCut(Word('V'), [ssCtrl]), False, PasteExecute, + PasteUpdate); + AddActItem('De&lete', 0, False, DeleteExecute, DeleteUpdate); + AddActItem('-', 0, False, nil, nil); + AddActItem('Select &All', Menus.ShortCut(Word('A'), [ssCtrl]), False, + SelectAllExecute, SelectAllUpdate); +end; + +procedure TCatSynEdit.SetPopupMenu_(const Value: TPopupMenu); +Var + MenuItem: TMenuItem; +begin + SynEdit.TSynEdit(Self).PopupMenu := Value; + if CompareText(MenuName, Value.Name) <> 0 then + begin + MenuItem := TMenuItem.Create(Value); + MenuItem.Caption := '-'; + Value.Items.Add(MenuItem); + FillPopupMenu(Value); + end; +end; + +function TCatSynEdit.GetPopupMenu_: TPopupMenu; +begin + Result := SynEdit.TSynEdit(Self).PopupMenu; +end; + +destructor TCatSynEdit.Destroy; +begin + FPopupMenu.Free; + FActnList.Free; + inherited; +end; + +procedure TCatSynEdit.FillPopupMenu(APopupMenu: TPopupMenu); +var + I: Integer; + MenuItem: TMenuItem; +begin + if Assigned(FActnList) then + for I := 0 to FActnList.ActionCount - 1 do + begin + MenuItem := TMenuItem.Create(APopupMenu); + MenuItem.Action := FActnList.Actions[I]; + APopupMenu.Items.Add(MenuItem); + end; +end; + +end. diff --git a/src/CatTasks.pas b/src/CatTasks.pas new file mode 100644 index 0000000..3971b5c --- /dev/null +++ b/src/CatTasks.pas @@ -0,0 +1,285 @@ +unit CatTasks; +{ + Catarinka - Task Management library + + Copyright (c) 2003-2014 Felipe Daragon + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details + + Portions based on code from Guido Geurt's ggProcessViewer.pas +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + Winapi.Windows, Vcl.Forms, System.SysUtils, System.Classes, Winapi.TlHelp32; +{$ELSE} + Windows, Forms, SysUtils, Classes, TlHelp32; +{$IFEND} +function KillTask(const ExeFileName: string): Integer; +function RunTask(const ExeFileName: string; const Wait: boolean = false; + const WindowState: Integer = SW_SHOW): Cardinal; +function TaskRunning(const ExeFileName: WideString): boolean; +procedure GetProcesses(ProcList: TStringList); +procedure GetProcessesOnNT(ProcList: TStringList); +procedure KillEXE(const ExeFileName: string); +procedure KillMultipleTask(ProcList: TStringList; const TaskName: string); +procedure KillProcessbyPID(const PID: Cardinal); +procedure ResumeProcess(const ProcessID: DWORD); +procedure SuspendProcess(const ProcessID: DWORD); + +implementation + +uses CatStrings; + +type + // NT Functions for getting the process information + TEnumProcesses = function(lpidProcess: LPDWORD; cb: DWORD; + var cbNeeded: DWORD): BOOL; StdCall; + TGetModuleBaseNameA = function(hProcess: THandle; hModule: hModule; + lpBaseName: PAnsiChar; nSize: DWORD): DWORD; StdCall; + TGetModuleFileNameExA = function(hProcess: THandle; hModule: hModule; + lpFilename: PAnsiChar; nSize: DWORD): DWORD; StdCall; + TEnumProcessModules = function(hProcess: THandle; lphModule: LPDWORD; + cb: DWORD; var lpcbNeeded: DWORD): BOOL; StdCall; + TByte = array [0 .. 0] of byte; + + // Address holders of the procedures for NT +var + EnumProcesses: TEnumProcesses; + GetModuleBaseNameA: TGetModuleBaseNameA; + GetModuleFileNameExA: TGetModuleFileNameExA; + EnumProcessModules: TEnumProcessModules; + +const + THREAD_SUSPEND_RESUME = $00000002; + cPSAPIDLL = 'PSAPI.dll'; + cProcSep = '_pid='; + +function OpenThread(dwDesiredAccess: DWORD; bInheritHandle: BOOL; + dwThreadId: DWORD): DWORD; stdcall; external 'kernel32.dll'; + +procedure SuspendProcess(const ProcessID: DWORD); +var + ThreadsSnapshot, ThreadHandle: THandle; + ThreadRecord: TThreadEntry32; +begin + ThreadsSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0); + ThreadRecord.dwSize := sizeof(ThreadRecord); + if Thread32First(ThreadsSnapshot, ThreadRecord) then + begin + repeat + if ThreadRecord.th32OwnerProcessID = ProcessID then + begin + ThreadHandle := OpenThread(THREAD_SUSPEND_RESUME, false, + ThreadRecord.th32ThreadID); + if ThreadHandle = 0 then + exit; + SuspendThread(ThreadHandle); + CloseHandle(ThreadHandle); + end; + until not Thread32Next(ThreadsSnapshot, ThreadRecord); + end; + CloseHandle(ThreadsSnapshot); +end; + +procedure ResumeProcess(const ProcessID: DWORD); +var + ThreadsSnapshot: THandle; + ThreadRecord: TThreadEntry32; + ThreadHandle: THandle; +begin + ThreadsSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0); + ThreadRecord.dwSize := sizeof(ThreadRecord); + if Thread32First(ThreadsSnapshot, ThreadRecord) then + begin + repeat + if ThreadRecord.th32OwnerProcessID = ProcessID then + begin + ThreadHandle := OpenThread(THREAD_SUSPEND_RESUME, false, + ThreadRecord.th32ThreadID); + if ThreadHandle = 0 then + exit; + ResumeThread(ThreadHandle); + CloseHandle(ThreadHandle); + end; + until not Thread32Next(ThreadsSnapshot, ThreadRecord); + end; + CloseHandle(ThreadsSnapshot); +end; + +procedure KillProcessbyPID(const PID: Cardinal); +var + h: THandle; + lpExitCode: {$IFDEF UNICODE}Cardinal{$ELSE}DWORD{$ENDIF}; +begin + h := OpenProcess(PROCESS_TERMINATE or PROCESS_QUERY_INFORMATION, false, PID); + if h = 0 then + exit; + if GetExitCodeProcess(h, lpExitCode) then + TerminateProcess(h, lpExitCode) + else + CloseHandle(h); +end; + +function RunTask(const ExeFileName: string; const Wait: boolean = false; + const WindowState: Integer = SW_SHOW): Cardinal; +var + Prog: array [0 .. 512] of char; + CurDir: array [0 .. 255] of char; + WorkDir: string; + StartupInfo: TStartupInfo; + ProcessInfo: TProcessInformation; + ExitCode: Cardinal; +begin + StrPCopy(Prog, ExeFileName); + GetDir(0, WorkDir); + StrPCopy(CurDir, WorkDir); + FillChar(StartupInfo, sizeof(StartupInfo), #0); + StartupInfo.cb := sizeof(StartupInfo); + StartupInfo.dwFlags := STARTF_USESHOWWINDOW; + StartupInfo.wShowWindow := WindowState; + if CreateProcess(nil, Prog, nil, nil, false, CREATE_NEW_CONSOLE or + NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo) then + begin + Result := ProcessInfo.dwProcessId; + if Wait = true then + begin + repeat + application.ProcessMessages; + GetExitCodeProcess(ProcessInfo.hProcess, ExitCode); + WaitForSingleObject(ProcessInfo.hProcess, 10); + until (ExitCode <> STILL_ACTIVE) or application.Terminated; + end; + end + else + Result := $FFFFFFFF; // -1 +end; + +function TaskRunning(const ExeFileName: WideString): boolean; +var + ContinueLoop: BOOL; + FSnapshotHandle: THandle; + FProcessEntry32: TProcessEntry32; +begin + Result := false; + FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); + FProcessEntry32.dwSize := sizeof(FProcessEntry32); + ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32); + while Integer(ContinueLoop) <> 0 do + begin + if (UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) + = UpperCase(ExeFileName)) then + Result := true; + ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32); + end; + CloseHandle(FSnapshotHandle); +end; + +procedure GetProcessesOnNT(ProcList: TStringList); +var + i: Integer; + PIDNeeded, dwsz: DWORD; + PIDList: array [0 .. 1000] of Integer; + PIDName: array [0 .. MAX_PATH - 1] of +{$IFDEF UNICODE}AnsiChar{$ELSE}char{$ENDIF}; + PH: THandle; + hMod: hModule; +begin + ProcList.clear; + try + if not EnumProcesses(@PIDList, 1000, PIDNeeded) then + raise Exception.Create('Error: ' + cPSAPIDLL + ' not found.'); + for i := 0 to (PIDNeeded div sizeof(Integer) - 1) do + begin + PH := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false, + PIDList[i]); + if PH <> 0 then + if GetModuleFileNameExA(PH, 0, PIDName, sizeof(PIDName)) > 0 then + if EnumProcessModules(PH, @hMod, sizeof(hMod), dwsz) then + begin + GetModuleFileNameExA(PH, hMod, PIDName, sizeof(PIDName)); + ProcList.Add(ExtractFileName(PIDName) + cProcSep + + IntToStr(PIDList[i])); + CloseHandle(PH); + end; + end; + except + end; +end; + +function KillTask(const ExeFileName: string): Integer; +const + PROCESS_TERMINATE = $0001; +var + ContinueLoop: BOOL; + FSnapshotHandle: THandle; + FProcessEntry32: TProcessEntry32; +begin + Result := 0; + FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); + FProcessEntry32.dwSize := sizeof(FProcessEntry32); + ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32); + + while Integer(ContinueLoop) <> 0 do + begin + if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) + = UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) + = UpperCase(ExeFileName))) then + begin + Result := Integer(TerminateProcess(OpenProcess(PROCESS_TERMINATE, BOOL(0), + FProcessEntry32.th32ProcessID), 0)); + end; + ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32); + end; + CloseHandle(FSnapshotHandle); +end; + +procedure KillEXE(const ExeFileName: string); +var + sl: TStringList; +begin + sl := TStringList.Create; + GetProcesses(sl); + if sl.Count = 0 then + KillTask(ExeFileName) + else + KillMultipleTask(sl, ExeFileName); + sl.free; +end; + +procedure KillMultipleTask(ProcList: TStringList; const TaskName: string); +var + i, c: Integer; +begin + c := ProcList.Count; + for i := 0 to c do + begin + If i < c then + begin + if (lowercase(before(ProcList.strings[i], cProcSep)) = lowercase(TaskName)) + then + KillProcessbyPID(strtoint(after(ProcList.strings[i], cProcSep))); + end; + end; +end; + +procedure GetProcesses(ProcList: TStringList); +var + h: THandle; +begin + h := LoadLibrary(cPSAPIDLL); + if (h <> 0) then + begin + @EnumProcesses := GetProcAddress(h, 'EnumProcesses'); + @GetModuleBaseNameA := GetProcAddress(h, 'GetModuleBaseNameA'); + @GetModuleFileNameExA := GetProcAddress(h, 'GetModuleFileNameExA'); + @EnumProcessModules := GetProcAddress(h, 'EnumProcessModules'); + GetProcessesOnNT(ProcList); + FreeLibrary(h); + end +end; + +// ------------------------------------------------------------------------// +end. diff --git a/src/CatTime.pas b/src/CatTime.pas new file mode 100644 index 0000000..420bd94 --- /dev/null +++ b/src/CatTime.pas @@ -0,0 +1,179 @@ +unit CatTime; +{ + Catarinka - Useful time-related functions + + Copyright (c) 2003-2014 Felipe Daragon + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + System.SysUtils, Vcl.Controls; +{$ELSE} + SysUtils, Controls; +{$IFEND} +function CalcAge(const StartDate, Date: TDate): integer; +function DateTimeToUnix(const Date: TDateTime): Longint; +function DescribeDateDiff(const t, d: string): string; +function DescribePassedTime(const starttime: TDateTime): string; +function DescribeTimeDiff(const t: string): string; +function DiffDate(const day1, day2: TDateTime): integer; +function GetDayOfWeekAsNumber: integer; +function GetDayOfWeekAsText: string; +function UnixToDateTime(const sec: Longint): TDateTime; + +implementation + +const + UnixStartDate: TDateTime = 25569.0; // 01/01/1970 + +function CalcAge(const StartDate, Date: TDate): integer; +var + d, m, y: Word; + ds, ms, ys: Word; + age: integer; +begin + Result := 0; + if not(Date > StartDate) then + Exit; + DecodeDate(Date, y, m, d); + DecodeDate(StartDate, ys, ms, ds); + age := y - ys; + if m > ms then + Result := age + else + begin + if m < ms then + Result := age - 1 + else + begin + if d >= ds then + Result := age + else + Result := age - 1 + end + end; +end; + +function DateTimeToUnix(const Date: TDateTime): Longint; +begin + Result := Round((Date - UnixStartDate) * 86400); +end; + +function DescribeDateDiff(const t, d: string): string; +var + dif: integer; + d1, d2: TDate; +begin + d1 := Date; + d2 := strtodate(d); + dif := trunc(d1) - trunc(d2); + if dif = 1 then + Result := t + ' Yesterday' + else + Result := t + ' ' + d; +end; + +function DescribePassedTime(const starttime: TDateTime): string; +const + timeformat = 'hh:nn:ss'; // 24h + dateformat = 'ddd, dd mmm yyyy'; +var + Date, time: string; +begin + Date := FormatDateTime(dateformat, starttime); + time := FormatDateTime(timeformat, starttime); + if FormatDateTime(dateformat, now) = Date then + Result := DescribeTimeDiff(time) + else + Result := DescribeDateDiff(time, datetostr(starttime)); +end; + +function DescribeTimeDiff(const t: string): string; + function TimeExt(n: string; s: string; p: string): string; + begin + if n = '1' then + Result := n + ' ' + s + else + Result := n + ' ' + p; + end; + +var + h, m, s: string; + t1, t2, ft: ttime; +const + zero = '0'; +begin + t2 := now; + t1 := strtotime(t); + ft := t2 - t1; + h := FormatDateTime('h', ft); + m := FormatDateTime('n', ft); + s := FormatDateTime('s', ft); + if h <> zero then + begin + Result := 'about ' + TimeExt(h, 'hour ago', 'hours ago'); + end + else + begin + if m <> zero then + begin + Result := TimeExt(m, 'minute ago', 'minutes ago'); + end + else + begin + if s <> zero then + Result := TimeExt(s, 'second ago', 'seconds ago'); + end; + end; +end; + +function DiffDate(const day1, day2: TDateTime): integer; +var + diff: double; +begin + diff := day2 - day1; + Result := Round(diff); +end; + +function GetDayOfWeekAsNumber: integer; +var + d: TDateTime; +begin + d := now; + Result := DayOfWeek(d); +end; + +function GetDayOfWeekAsText: string; +var + d: TDateTime; +begin + d := now; + case DayOfWeek(d) of + 1: + Result := 'Sunday'; + 2: + Result := 'Monday'; + 3: + Result := 'Tuesday'; + 4: + Result := 'Wednesday'; + 5: + Result := 'Thursday'; + 6: + Result := 'Friday'; + 7: + Result := 'Saturday'; + end; +end; + +function UnixToDateTime(const sec: Longint): TDateTime; +begin + Result := (sec / 86400) + UnixStartDate; +end; + +// ------------------------------------------------------------------------// +end. diff --git a/src/CatUI.pas b/src/CatUI.pas new file mode 100644 index 0000000..fa5c2de --- /dev/null +++ b/src/CatUI.pas @@ -0,0 +1,565 @@ +unit CatUI; + +{ + Catarinka - User Interface related functions + + Copyright (c) 2003-2014 Felipe Daragon + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details + + ForceForegroundWindow function by Ray Lischner, + based on code from Karl E. Peterson, with portions from + Daniel P. Stasinski +} + +interface + +uses +{$IF CompilerVersion >= 23} + Winapi.Windows, Vcl.Forms, Vcl.Menus, Vcl.ExtCtrls, System.SysUtils, + System.Classes, Vcl.Controls, Vcl.ComCtrls, Winapi.CommCtrl, Winapi.Messages, + Winapi.ShlObj; +{$ELSE} + Windows, Forms, Menus, ExtCtrls, SysUtils, Classes, Controls, ComCtrls, + CommCtrl, Messages, ShlObj; +{$IFEND} +function AskYN(const question: string): Boolean; +function GetWindowState: integer; +function ForceForegroundWindow(hwnd: THandle): Boolean; +function GetWindowClassHandle(const Title: string): integer; +function GetFullPath(N: TTreeNode; Sep: string = '\'): string; +function GetFullPathData(N: TTreeNode): string; +function GetLVCheckedItems(lvcomp: TListview): string; +function GetLVCheckedItemsSingleLn(lvcomp: TListview): string; +function GetPercentage(const percent, Value: integer): Int64; +function GetSpecialFolderPath(const Folder: integer; + const CanCreate: Boolean): string; +function MakeNotifyEvent(forObject: TObject; const procname: string) + : TNotifyEvent; +function TreeItemSearch(tv: ttreeview; const SearchItem: string): TTreeNode; + +procedure AddListViewItem(LV: TListview; const capt: string; const ii: integer; + const mv: Boolean); +procedure AddMultipleListViewItems(LV: TListview; const captlist: string; + const ii: integer; const mv: Boolean); +procedure ApplyWindowState(const i: integer); +procedure CommaToLVItems(lvcomp: TListview; const commastring: string); +procedure CloseWindowByClass(const classname: string); +procedure DisableLVToolTips(H: THandle); +procedure ExpandTreeViewItems(tv: ttreeview); +procedure FlashUI(const times: integer = 2; const delay: integer = 500); +procedure LoadListviewStrings(listview: TListview; const filename: string); +procedure QuickSortTreeViewItems(tv: ttreeview); +procedure ShowPopupMenu(PopupMenu: TPopupMenu; const AppHandle: integer); +procedure SaveListviewStrings(listview: TListview; const filename: string); +procedure SaveMemStreamToStrings(Stream: TMemoryStream; List: TStrings); +procedure SetNodeBoldState(Node: TTreeNode; const Value: Boolean); + +type + TCanvasPanel = class(TPanel) + public + property Canvas; + end; + + { + CSIDL_DESKTOPDIRECTORY returns the path to the current desktop + CSIDL_PERSONAL is the My Documents directory + CSIDL___LOCAL_APPDATA is the (user name)\Local Settings\Application Data directory } +const + CSIDL_DESKTOP = $0000; { } + CSIDL_INTERNET = $0001; { Internet Explorer (icon on desktop) } + CSIDL_PROGRAMS = $0002; { Start Menu\Programs } + CSIDL_CONTROLS = $0003; { My Computer\Control Panel } + CSIDL_PRINTERS = $0004; { My Computer\Printers } + CSIDL_PERSONAL = $0005; + { My Documents. This is equivalent to CSIDL_MYDOCUMENTS in XP and above } + CSIDL_FAVORITES = $0006; { \Favorites } + CSIDL_STARTUP = $0007; { Start Menu\Programs\Startup } + CSIDL_RECENT = $0008; { \Recent } + CSIDL_SENDTO = $0009; { \SendTo } + CSIDL_BITBUCKET = $000A; { \Recycle Bin } + CSIDL_STARTMENU = $000B; { \Start Menu } + CSIDL_MYDOCUMENTS = $000C; { logical "My Documents" desktop icon } + CSIDL_MYMUSIC = $000D; { "My Music" folder } + CSIDL_MYVIDEO = $000E; { "My Video" folder } + CSIDL_DESKTOPDIRECTORY = $0010; { \Desktop } + CSIDL_DRIVES = $0011; { My Computer } + CSIDL_NETWORK = $0012; { Network Neighborhood (My Network Places) } + CSIDL_NETHOOD = $0013; { \nethood } + CSIDL_FONTS = $0014; { windows\fonts } + CSIDL_TEMPLATES = $0015; + CSIDL_COMMON_STARTMENU = $0016; { All Users\Start Menu } + CSIDL_COMMON_PROGRAMS = $0017; { All Users\Start Menu\Programs } + CSIDL_COMMON_STARTUP = $0018; { All Users\Startup } + CSIDL_COMMON_DESKTOPDIRECTORY = $0019; { All Users\Desktop } + CSIDL_APPDATA = $001A; { \Application Data } + CSIDL_PRINTHOOD = $001B; { \PrintHood } + CSIDL_LOCAL_APPDATA = $001C; + { \Local Settings\Application Data (non roaming) } + CSIDL_ALTSTARTUP = $001D; { non localized startup } + CSIDL_COMMON_ALTSTARTUP = $001E; { non localized common startup } + CSIDL_COMMON_FAVORITES = $001F; + CSIDL_INTERNET_CACHE = $0020; + CSIDL_COOKIES = $0021; + CSIDL_HISTORY = $0022; + CSIDL_COMMON_APPDATA = $0023; { All Users\Application Data } + CSIDL_WINDOWS = $0024; { GetWindowsDirectory() } + CSIDL_SYSTEM = $0025; { GetSystemDirectory() } + CSIDL_PROGRAM_FILES = $0026; { C:\Program Files } + CSIDL_MYPICTURES = $0027; { C:\Program Files\My Pictures } + CSIDL_PROFILE = $0028; { USERPROFILE } + CSIDL_SYSTEMX86 = $0029; { x86 system directory on RISC } + CSIDL_PROGRAM_FILESX86 = $002A; { x86 C:\Program Files on RISC } + CSIDL_PROGRAM_FILES_COMMON = $002B; { C:\Program Files\Common } + CSIDL_PROGRAM_FILES_COMMONX86 = $002C; { x86 C:\Program Files\Common on RISC } + CSIDL_COMMON_TEMPLATES = $002D; { All Users\Templates } + CSIDL_COMMON_DOCUMENTS = $002E; { All Users\Documents } + CSIDL_COMMON_ADMINTOOLS = $002F; + { All Users\Start Menu\Programs\Administrative Tools } + CSIDL_ADMINTOOLS = $0030; + { \Start Menu\Programs\Administrative Tools } + CSIDL_CONNECTIONS = $0031; { Network and Dial-up Connections } + CSIDL_COMMON_MUSIC = $0035; { All Users\My Music } + CSIDL_COMMON_PICTURES = $0036; { All Users\My Pictures } + CSIDL_COMMON_VIDEO = $0037; { All Users\My Video } + CSIDL_RESOURCES = $0038; { Resource Directory } + CSIDL_RESOURCES_LOCALIZED = $0039; { Localized Resource Directory } + CSIDL_COMMON_OEM_LINKS = $003A; { Links to All Users OEM specific apps } + CSIDL_CDBURN_AREA = $003B; + { USERPROFILE\Local Settings\Application Data\Microsoft\CD Burning } + CSIDL_COMPUTERSNEARME = $003D; + { Computers Near Me (computered from Workgroup membership) } + CSIDL_PROFILES = $003E; + +implementation + +uses + CatPointer, CatStrings; + +procedure AddListViewItem(LV: TListview; const capt: string; const ii: integer; + const mv: Boolean); +begin + with LV.Items.Add do + begin + Caption := capt; + imageindex := ii; + makevisible(mv); + end; +end; + +procedure AddMultipleListViewItems(LV: TListview; const captlist: string; + const ii: integer; const mv: Boolean); +var + c, i: integer; + List: TStringlist; +begin + List := TStringlist.Create; + List.text := captlist; + c := List.count; + for i := 0 to c do + begin + if i < c then + AddListViewItem(LV, List[i], ii, mv); + end; + List.free; +end; + +procedure ApplyWindowState(const i: integer); +begin + case i of + 0: + Application.MainForm.WindowState := WsMaximized; + 1: + Application.MainForm.WindowState := WsMinimized; + 2: + Application.MainForm.WindowState := WsNormal; + end; +end; + +function AskYN(const question: string): Boolean; +begin + case Application.MessageBox({$IFDEF UNICODE}pwidechar{$ELSE}pchar{$ENDIF}(question), {$IFDEF UNICODE}pwidechar{$ELSE}pchar{$ENDIF}(Application.Title), mb_YesNo + mb_DefButton1) of + IDYes: + Result := true; + IDNo: + Result := false; + end; +end; + +// Usage example CloseWindowByClass('TSomeForm') +procedure CloseWindowByClass(const classname: string); +var + winHandle: THandle; + winClass: array [0 .. 63] of char; +begin + winHandle := Application.Handle; + repeat + winHandle := GetNextWindow(winHandle, GW_HWNDNEXT); + GetClassName(winHandle, winClass, sizeof(winClass)); + if (winHandle <> 0) and (StrComp(winClass, pchar(classname)) = 0) then + PostMessage(winHandle, WM_CLOSE, 0, 0); + until (winHandle = 0); +end; + +procedure CommaToLVItems(lvcomp: TListview; const commastring: string); +var + i: integer; + sl: TStringlist; +begin + sl := TStringlist.Create; + sl.CommaText := commastring; + for i := 0 to sl.count - 1 do + begin + if (before(sl[i], '=') <> emptystr) then + begin + with lvcomp.Items.Add do + begin + Caption := before(sl[i], '='); + if after(sl[i], '=') = '1' then + checked := true + else + checked := false; + end; + end; + end; + sl.free; +end; + +// Needs testing +procedure DisableLVToolTips(H: THandle); +var + styles: dword; +begin + styles := ListView_GetExtendedListViewStyle(H); + styles := styles and not LVS_EX_INFOTIP; + ListView_SetExtendedListViewStyle(H, styles); +end; + +procedure ExpandTreeViewItems(tv: ttreeview); +var + i, c: integer; +begin + tv.Items.BeginUpdate; + c := tv.Items.count; + for i := 0 to c do + begin + if i < c then + begin + tv.Items[i].Expand(false); + end; + end; + tv.Items.EndUpdate; + try + tv.Items[0].Selected := true; + except + end; +end; + +procedure FlashUI(const times: integer = 2; const delay: integer = 500); +var + i: integer; + procedure doflash(b: Boolean); + begin + FlashWindow(Application.MainForm.Handle, b); + FlashWindow(Application.Handle, b); + end; + +begin + for i := 0 to times do + begin + doflash(true); + sleep(delay); + doflash(false); + sleep(delay); + end; +end; + +function GetFullPath(N: TTreeNode; Sep: string = '\'): string; +begin + Result := N.text; + N := N.Parent; + while (N <> nil) do + begin + Result := N.text + Sep + Result; + N := N.Parent; + end; +end; + +function GetFullPathData(N: TTreeNode): string; +begin + Result := PointerToStr(N.data); + N := N.Parent; + while (N <> nil) do + begin + Result := PointerToStr(N.data) + '/' + Result; + N := N.Parent; + end; +end; + +function GetLVCheckedItems(lvcomp: TListview): string; +var + i: integer; + sl: TStringlist; +begin + sl := TStringlist.Create; + for i := 0 to lvcomp.Items.count - 1 do + begin + if lvcomp.Items[i].checked then + sl.Add(lvcomp.Items[i].Caption + '=1') + else + sl.Add(lvcomp.Items[i].Caption + '=0'); + end; + Result := sl.CommaText; + sl.free; +end; + +function GetLVCheckedItemsSingleLn(lvcomp: TListview): string; +var + i: integer; +begin + for i := 0 to lvcomp.Items.count - 1 do + begin + if lvcomp.Items[i].checked then + Result := Result + inttostr(i) + ';'; + end; + Result := Result; +end; + +function GetPercentage(const percent, Value: integer): Int64; +var + p: Real; +begin + p := ((percent / Value) * 100); + Result := Round(p); +end; + +// Gets the path of special system folders +// Usage example: GetSpecialFolderPath (CSIDL_PERSONAL, false); +function GetSpecialFolderPath(const Folder: integer; + const CanCreate: Boolean): string; +var + FilePath: array [0 .. 255] of char; +begin + SHGetSpecialFolderPath(0, @FilePath[0], Folder, CanCreate); + Result := FilePath; +end; + +function GetWindowClassHandle(const Title: string): integer; +begin + result := FindWindow(pchar(Title), nil); +end; + +function GetWindowState: integer; +begin + Result := 2; + case Application.MainForm.WindowState of + WsMaximized: + Result := 0; + WsMinimized: + Result := 1; + WsNormal: + Result := 2; + end; +end; + +procedure LoadListviewStrings(listview: TListview; const filename: string); +var + sl, lineelements: TStringlist; + i: integer; + item: TListItem; +begin + Assert(Assigned(listview)); + sl := TStringlist.Create; + try + sl.LoadFromFile(filename); + lineelements := TStringlist.Create; + try + for i := 0 to sl.count - 1 do + begin + lineelements.Clear; + SplitString(sl[i], #9, lineelements); + if lineelements.count > 0 then + begin + item := listview.Items.Add; + item.Caption := lineelements[0]; + lineelements.Delete(0); + item.SubItems.Assign(lineelements); + end; + end; + finally + lineelements.free; + end; + finally + sl.free + end; +end; + +function MakeNotifyEvent(forObject: TObject; const procname: String) + : TNotifyEvent; +begin + TMethod(Result).data := forObject; + TMethod(Result).code := forObject.methodAddress(procname); +end; + +procedure QuickSortTreeViewItems(tv: ttreeview); +begin + tv.Items.BeginUpdate; + tv.sorttype := stnone; + tv.sorttype := sttext; + tv.Items.EndUpdate; +end; + +procedure SaveListviewStrings(listview: TListview; const filename: string); +var + sl: TStringlist; + S: string; + i, si: integer; + item: TListItem; +begin + Assert(Assigned(listview)); + sl := TStringlist.Create; + try + for i := 0 to listview.Items.count - 1 do + begin + item := listview.Items[i]; + S := item.Caption; + for si := 0 to item.SubItems.count - 1 do + S := S + #9 + item.SubItems[si]; + sl.Add(S); + end; + sl.SaveToFile(filename); + finally + sl.free + end; +end; + +procedure SaveMemStreamToStrings(Stream: TMemoryStream; List: TStrings); +var + p, q, r: pchar; +begin + p := Stream.Memory; + q := p + Stream.Size - 1; + r := p; + while (p <> nil) and (p < q) do + begin + while (p < q) and (p^ <> #13) and (p^ <> #10) do + Inc(p); + List.Add(Copy(StrPas(r), 1, p - r)); + if (p[0] = #13) and (p[1] = #10) then + Inc(p, 2) + else + Inc(p); + r := p; + end; +end; + +procedure ShowPopupMenu(PopupMenu: TPopupMenu; const AppHandle: integer); +var + p: TPoint; +begin + SetForegroundWindow(AppHandle); + GetCursorPos(p); + PopupMenu.Popup(p.x, p.y); + PostMessage(AppHandle, WM_NULL, 0, 0); +end; + +procedure SetNodeBoldState(Node: TTreeNode; const Value: Boolean); +var + TVItem: TTVItem; +begin + if not Assigned(Node) then + Exit; + with TVItem do + begin + mask := TVIF_STATE or TVIF_HANDLE; + hItem := Node.ItemId; + stateMask := TVIS_BOLD; + if Value then + state := TVIS_BOLD + else + state := 0; + TreeView_SetItem(Node.Handle, TVItem); + end; +end; + +function TreeItemSearch(tv: ttreeview; const SearchItem: string): TTreeNode; +var + i: integer; + sitem: string; +begin + Result := nil; + if (tv = nil) or (SearchItem = emptystr) then + Exit; + for i := 0 to tv.Items.count - 1 do + begin + sitem := tv.Items[i].text; + if SearchItem = sitem then + begin + Result := tv.Items[i]; + Exit; + end + else + Result := nil; + end; +end; + +function ForceForegroundWindow(hwnd: THandle): Boolean; +const + SPI_GETFOREGROUNDLOCKTIMEOUT = $2000; + SPI_SETFOREGROUNDLOCKTIMEOUT = $2001; +var + ForegroundThreadID, ThisThreadID, timeout: dword; +begin + if IsIconic(hwnd) then + ShowWindow(hwnd, SW_RESTORE); + + if GetForegroundWindow = hwnd then + Result := true + else + begin + // Windows 98/2000 doesn't want to foreground a window when some other + // window has keyboard focus + + if ((Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion > 4)) or + ((Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and + ((Win32MajorVersion > 4) or ((Win32MajorVersion = 4) and + (Win32MinorVersion > 0)))) then + begin + // Code from Karl E. Peterson, www.mvps.org/vb/sample.htm + // Converted to Delphi by Ray Lischner + // Published in The Delphi Magazine 55, page 16 + + Result := false; + ForegroundThreadID := GetWindowThreadProcessID(GetForegroundWindow, nil); + ThisThreadID := GetWindowThreadProcessID(hwnd, nil); + if AttachThreadInput(ThisThreadID, ForegroundThreadID, true) then + begin + BringWindowToTop(hwnd); // IE 5.5 related hack + SetForegroundWindow(hwnd); + AttachThreadInput(ThisThreadID, ForegroundThreadID, false); + Result := (GetForegroundWindow = hwnd); + end; + if not Result then + begin + // Code by Daniel P. Stasinski + SystemParametersInfo(SPI_GETFOREGROUNDLOCKTIMEOUT, 0, @timeout, 0); + SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(0), + SPIF_SENDCHANGE); + BringWindowToTop(hwnd); // IE 5.5 related hack + SetForegroundWindow(hwnd); + SystemParametersInfo(SPI_SETFOREGROUNDLOCKTIMEOUT, 0, TObject(timeout), + SPIF_SENDCHANGE); + end; + end + else + begin + BringWindowToTop(hwnd); // IE 5.5 related hack + SetForegroundWindow(hwnd); + end; + + Result := (GetForegroundWindow = hwnd); + end; +end; + +// ------------------------------------------------------------------------// +end. diff --git a/src/CatUtils.pas b/src/CatUtils.pas new file mode 100644 index 0000000..f3448bc --- /dev/null +++ b/src/CatUtils.pas @@ -0,0 +1,42 @@ +unit CatUtils; + +{ + Catarinka - Utils + + Copyright (c) 2003-2014 Felipe Daragon + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + Winapi.Windows, Vcl.Forms; +{$ELSE} + Windows, Forms; +{$IFEND} +procedure CatDelay(const ms: Integer); + +implementation + +procedure CatDelay(const ms: Integer); +var + c, te: Integer; +begin + c := GetTickCount; + repeat + te := GetTickCount - c; + if te < 0 then + te := te + MaxInt; + + if (ms > te) and (MsgWaitForMultipleObjects(0, PHandle(0)^, True, ms - te, + QS_ALLEVENTS) <> WAIT_TIMEOUT) then + Application.ProcessMessages + else + break; + until False; +end; + +// ------------------------------------------------------------------------// +end. diff --git a/src/CatZIP.pas b/src/CatZIP.pas new file mode 100644 index 0000000..b51afc8 --- /dev/null +++ b/src/CatZIP.pas @@ -0,0 +1,165 @@ +unit CatZIP; +{ + Catarinka - ZIP Compression/Decompression + + Copyright (c) 2013-2014 Felipe Daragon + License: 3-clause BSD + See https://github.com/felipedaragon/catarinka/ for details +} + +interface + +uses +{$IF CompilerVersion >= 23} // XE2 or higher + System.Classes; +{$ELSE} + Classes; +{$IFEND} +procedure ExtractZIPFile(const zipname, filename, outfilename: string); +procedure ExtractZIPFileToStream(const zipname, filename: string; + ms: TMemoryStream); +procedure GUnZipStream(Document: TMemoryStream); +procedure GUnZipTStream(var Document: TStream); +procedure GZipAFile(const outzipname, infilename, filetozip: string); +procedure GZipTStream(var Document: TStream); +function GetTextFileFromZIP(const zipname, filename: string): string; + +implementation + +uses CatStrings, AbZipKit, AbUtils, AbGzTyp; + +// WIP: Functions marked as untested need testing to make sure that they +// are working properly. + +// working +procedure GUnZipStream(Document: TMemoryStream); +var + kit: TAbGzipStreamHelper; + outms: TMemoryStream; +begin + kit := TAbGzipStreamHelper.Create(Document); + if kit.FindFirstItem then + begin + outms := TMemoryStream.Create; + kit.ExtractItemData(outms); + outms.Position := 0; + Document.Clear; + Document.LoadFromStream(outms); + outms.free; + end; + kit.free; +end; + +// untested +procedure GUnZipTStream(var Document: TStream); +var + kit: TAbGzipStreamHelper; + outms: TMemoryStream; +begin + kit := TAbGzipStreamHelper.Create(Document); + if kit.FindFirstItem then + begin + outms := TMemoryStream.Create; + kit.ExtractItemData(outms); + outms.Position := 0; + outms.SaveToStream(Document); + outms.free; + end; + kit.free; +end; + +// untested +procedure GZipTStream(var Document: TStream); +var + kit: TAbZipKit; + ms: TMemoryStream; +begin + ms := TMemoryStream.Create; + ms.LoadFromStream(Document); + kit := TAbZipKit.Create(nil); + kit.archivetype := atGzip; + kit.forcetype := true; + kit.Stream := Document; // outstream + kit.AddFromStream('Untitled', ms); + ms.free; + kit.free; +end; + +// working +procedure GZipAFile(const outzipname, infilename, filetozip: string); +var + kit: TAbZipKit; + ms, outstream: TMemoryStream; +begin + ms := TMemoryStream.Create; + ms.LoadFromFile(filetozip); + outstream := TMemoryStream.Create; + kit := TAbZipKit.Create(nil); + kit.archivetype := atGzip; + kit.forcetype := true; + kit.Stream := outstream; + kit.AddFromStream(infilename, ms); + outstream.SaveToFile(outzipname); + outstream.free; + ms.free; + kit.free; +end; + +procedure ExtractZIPFileToStream(const zipname, filename: string; + ms: TMemoryStream); +var + kit: TAbZipKit; + f: string; +begin + f := replacestr(filename, '\', '/'); + kit := TAbZipKit.Create(nil); + kit.OpenArchive(zipname); + if kit.FindFile(f) <> -1 then + kit.ExtractToStream(f, ms); + kit.free; + ms.Position := 0; +end; + +// working +procedure ExtractZIPFile(const zipname, filename, outfilename: string); +var + kit: TAbZipKit; + ms: TMemoryStream; + f: string; +begin + f := replacestr(filename, '\', '/'); + ms := TMemoryStream.Create; + kit := TAbZipKit.Create(nil); + kit.OpenArchive(zipname); + if kit.FindFile(f) <> -1 then + kit.ExtractToStream(f, ms); + kit.free; + ms.Position := 0; + ms.SaveToFile(outfilename); + ms.free; +end; + +// working +function GetTextFileFromZIP(const zipname, filename: string): string; +var + kit: TAbZipKit; + sl: tstringlist; + ms: TMemoryStream; + f: string; +begin + f := replacestr(filename, '\', '/'); + ms := TMemoryStream.Create; + sl := tstringlist.Create; + kit := TAbZipKit.Create(nil); + kit.OpenArchive(zipname); + if kit.FindFile(f) <> -1 then + kit.ExtractToStream(f, ms); + kit.free; + ms.Position := 0; + sl.LoadFromStream(ms); + result := sl.text; + sl.free; + ms.free; +end; + +end. diff --git a/src/thirdparty/ExtPascalUtils.pas b/src/thirdparty/ExtPascalUtils.pas new file mode 100644 index 0000000..4b03b13 --- /dev/null +++ b/src/thirdparty/ExtPascalUtils.pas @@ -0,0 +1,738 @@ +{ +Unit for complementary functions +Author: Wanderlan Santos dos Anjos (wanderlan.anjos@gmail.com) +Date: jul-2008 +License: BSDBSD +} +unit ExtPascalUtils; + +{$IFDEF FPC}{$MACRO ON}{$MODE DELPHI}{$ENDIF} + +interface + +uses + Classes, TypInfo; + +const + ExtPascalVersion = '0.9.8'; + +{$IF not Defined(FPC) and (RTLVersion <= 17)} +type + // Implements StrictDelimiter property for FPC 2.2.2, Delphi 7 and older versions + TStringList = class(Classes.TStringList) + private + function GetDelimitedText : string; + procedure SetDelimitedText(const AValue : string); + public + StrictDelimiter : boolean; // Missing property in FPC 2.2.2, Delphi 7 an older versions + property DelimitedText : string read GetDelimitedText write SetDelimitedText; // Property override for FPC 2.2.2, Delphi 7 an older versions + end; +{$IFEND} + +type + TBrowser = (brUnknown, brIE, brFirefox, brChrome, brSafari, brOpera, brKonqueror, brMobileSafari); // Internet Browsers + TCSSUnit = (cssPX, cssPerc, cssEM, cssEX, cssIN, cssCM, cssMM, cssPT, cssPC, cssnone); // HTML CSS units + TExtProcedure = procedure of object; // Defines a procedure than can be called by a request + +{ +Determine browser from HTTP_USER_AGENT header string. +@param UserAgentStr String returned by, for example, RequestHeader['HTTP_USER_AGENT']. +@return TBrowser +} +function DetermineBrowser(const UserAgentStr : string) : TBrowser; + +{ +Mimics preg_match php function. Searches S for a match to delimiter strings given in Delims parameter +@param Delims Delimiter strings to match +@param S Subject string +@param Matches Substrings from Subject string delimited by Delimiter strings. Matches (TStringList) should already be created. +@param Remove matches strings from S, default is true +@return True if some match hit, false otherwise +} +function Extract(const Delims : array of string; var S : string; var Matches : TStringList; Remove : boolean = true) : boolean; + +{ +Mimics explode php function. +Creates a TStringList where each string is a substring formed by the splitting of S string through delimiter Delim. +@param Delim Delimiter used to split the string +@param S Source string to split +@return TStringList created with substrings from S +} +function Explode(Delim : char; const S : string; Separator : char = '=') : TStringList; + +{ +The opposite of LastDelimiter RTL function. +Returns the index of the first occurence in a string of the characters specified. +If none of the characters in Delimiters appears in string S, function returns zero. +@param Delimiters String where each character is a valid delimiter. +@param S String to search for delimiters. +@param Offset Index from where the search begins. +} +function FirstDelimiter(const Delimiters, S : string; Offset : integer = 1) : integer; + +// The opposite of "StrUtils.PosEx" function. Returns the index value of the last occurrence of a specified substring in a given string. +function RPosEx(const Substr, Str : string; Offset : integer = 1) : integer; + +{ +Returns the number of occurrences of Substr in Str until UntilStr occurs +@param Substr String to count in Str +@param Str String where the counting will be done +@param UntilStr Optional String, stop counting if this string occurs +} +function CountStr(const Substr, Str : string; UntilStr : string = '') : integer; + +{ +Converts a string with param place holders to a JavaScript string. Converts a string representing a regular expression to a JavaScript RegExp. +Replaces " to ', ^M^J to
and isolated ^M or ^J to
, surrounds the string with " and insert %0..%9 JS place holders. +When setting a TExtFormTextField value (in property setter setvalue), the UseBR should be set to false, +because otherwise it is impossible to display multiline text in a TExtFormTextArea. +@param S Source string with param place holders or RegExpr +@param UseBR If true uses replace ^M^J to
else to \n +@return a well formatted JS string +} +function StrToJS(const S : string; UseBR : boolean = false) : string; + +{ +Finds S string in Cases array, returning its index or -1 if not found. Good to use in Pascal "case" command. Similar to AnsiIndexText. +@param S Source string where to search +@param Cases String array to find in S +} +function CaseOf(const S : string; const Cases : array of string) : integer; + +{ +Finds Cases array in S string, returning its index or -1 if not found. Good to use in Pascal "case" command. Reverse to AnsiIndexStr. +@param S string to find in Cases array +@param Cases String array where to search +} +function RCaseOf(const S : string; const Cases : array of string) : integer; + +{ +Converts a Pascal enumerated type constant into a JS string, used internally by ExtToPascal wrapper. See ExtFixes.txt for more information. +@param TypeInfo Type information record that describes the enumerated type, use TypeInfo() function with enumerated type +@param Value The enumerated value, represented as an integer +@return JS string +} +function EnumToJSString(TypeInfo : PTypeInfo; Value : integer) : string; + +{ +Helper function to make code more pascalish, use +@example BodyStyle := SetPaddings(10, 15); +instead +@example BodyStyle := 'padding:10px 15px'; +} +function SetPaddings(Top : integer; Right : integer = 0; Bottom : integer = -1; Left : integer = 0; CSSUnit : TCSSUnit = cssPX; + Header : boolean = true) : string; + +{ +Helper function to make code more pascalish, use +@example Margins := SetMargins(3, 3, 3); +instead +@example Margins := '3 3 3 0'; +} +function SetMargins(Top : integer; Right : integer = 0; Bottom : integer = 0; Left : integer = 0; CSSUnit : TCSSUnit = cssNone; + Header : boolean = false) : string; + +// Returns true if BeforesS string occurs before AfterS string in S string +function Before(const BeforeS, AfterS, S : string) : boolean; + +// Returns true if all chars in S are uppercase +function IsUpperCase(S : string) : boolean; + +// Beautify generated JS commands from ExtPascal, automatically used when DEBUGJS symbol is defined +function BeautifyJS(const AScript : string; const StartingLevel : integer = 0; SplitHTMLNewLine : boolean = true) : string; + +// Beautify generated CSS from ExtPascal, automatically used when DEBUGJS symbol is defined +function BeautifyCSS(const AStyle : string) : string; + +// Screen space, in characters, used for a field using regular expression mask +function LengthRegExp(Rex : string; CountAll : Boolean = true) : integer; + +function JSDateToDateTime(JSDate : string) : TDateTime; + +implementation + +uses + StrUtils, SysUtils, Math, DateUtils; + +{$IF not Defined(FPC) and (RTLVersion <= 17)} +function TStringList.GetDelimitedText: string; +var + I : integer; + P : pchar; +begin + Result := ''; + for I := 0 to Count-1 do begin + P := pchar(Strings[I]); + if not StrictDelimiter then + while not(P^ in [#0..' ', QuoteChar, Delimiter]) do inc(P) + else + while not(P^ in [#0, Delimiter]) do inc(P); + // strings in list may to contain #0 + if (P <> pchar(Strings[I]) + length(Strings[I])) and not StrictDelimiter then + Result := Result + QuoteChar + Strings[I] + QuoteChar + else + Result := Result + Strings[I]; + if I < Count-1 then Result := Result + Delimiter; + end; + if (length(Result) = 0) and (Count = 1) then Result := QuoteChar + QuoteChar; +end; + +procedure TStringList.SetDelimitedText(const AValue : string); +var + I, J : integer; + aNotFirst : boolean; +begin + BeginUpdate; + I := 1; + aNotFirst := false; + try + Clear; + while I <= length(AValue) do begin + // skip delimiter + if aNotFirst and (I <= length(AValue)) and (AValue[I] = Delimiter) then inc(I); + // skip spaces + if not StrictDelimiter then + while (I <= length(AValue)) and (ord(AValue[I]) <= ord(' ')) do inc(I); + // read next string + if I <= length(AValue) then begin + if AValue[I] = QuoteChar then begin + // next string is quoted + J := I + 1; + while (J <= length(AValue)) and ((AValue[J] <> QuoteChar) or + ((J+1 <= length(AValue)) and (AValue[J+1] = QuoteChar))) do + if (J <= length(AValue)) and (AValue[J] = QuoteChar) then + inc(J, 2) + else + inc(J); + // J is position of closing quote + Add(StringReplace(Copy(AValue, I+1, J-I-1), QuoteChar + QuoteChar, QuoteChar, [rfReplaceAll])); + I := J + 1; + end + else begin + // next string is not quoted + J := I; + if not StrictDelimiter then + while (J <= length(AValue)) and (ord(AValue[J]) > ord(' ')) and (AValue[J] <> Delimiter) do inc(J) + else + while (J <= length(AValue)) and (AValue[J] <> Delimiter) do inc(J); + Add(copy(AValue, I, J-i)); + I := J; + end; + end + else + if aNotFirst then Add(''); + // skip spaces + if not StrictDelimiter then + while (I <= length(AValue)) and (ord(AValue[I]) <= ord(' ')) do inc(I); + aNotFirst:=true; + end; + finally + EndUpdate; + end; +end; +{$IFEND} + +function DetermineBrowser(const UserAgentStr : string) : TBrowser; begin + Result := TBrowser(RCaseOf(UserAgentStr, ['MSIE', 'Firefox', 'Chrome', 'Safari', 'Opera', 'Konqueror'])+1); + // Note string order must match order in TBrowser enumeration above + if (Result = brSafari) and // Which Safari? + (Pos('Mobile', UserAgentStr) > 0) and + (Pos('Apple', UserAgentStr) > 0) then + Result := brMobileSafari +end; + +function Extract(const Delims : array of string; var S : string; var Matches : TStringList; Remove : boolean = true) : boolean; +var + I, J : integer; + Points : array of integer; +begin + Result := false; + if Matches <> nil then Matches.Clear; + SetLength(Points, length(Delims)); + J := 1; + for I := 0 to high(Delims) do begin + J := PosEx(Delims[I], S, J); + Points[I] := J; + if J = 0 then + exit + else + inc(J, length(Delims[I])); + end; + for I := 0 to high(Delims)-1 do begin + J := Points[I] + length(Delims[I]); + Matches.Add(trim(copy(S, J, Points[I+1]-J))); + end; + if Remove then S := copy(S, Points[high(Delims)] + length(Delims[high(Delims)]), length(S)); + Result := true +end; + +function Explode(Delim : char; const S : string; Separator : char = '=') : TStringList; +var + I : integer; +begin + Result := TStringList.Create; + Result.StrictDelimiter := true; + Result.Delimiter := Delim; + Result.DelimitedText := S; + Result.NameValueSeparator := Separator; + for I := 0 to Result.Count-1 do Result[I] := trim(Result[I]); +end; + +function FirstDelimiter(const Delimiters, S : string; Offset : integer = 1) : integer; +var + I : integer; +begin + for Result := Offset to length(S) do + for I := 1 to length(Delimiters) do + if Delimiters[I] = S[Result] then exit; + Result := 0; +end; + +function RPosEx(const Substr, Str : string; Offset : integer = 1) : integer; +var + I : integer; +begin + Result := PosEx(Substr, Str, Offset); + while Result <> 0 do begin + I := PosEx(Substr, Str, Result+1); + if I = 0 then + break + else + Result := I + end; +end; + +function CountStr(const Substr, Str : string; UntilStr : string = '') : integer; +var + I, J : integer; +begin + I := 0; + Result := 0; + J := Pos(UntilStr, Str); + repeat + I := PosEx(Substr, Str, I+1); + if (J <> 0) and (J < I) then exit; + if I <> 0 then inc(Result); + until I = 0; +end; + +function StrToJS(const S : string; UseBR : boolean = false) : string; +var + I, J : integer; + BR : string; +begin + BR := IfThen(UseBR, '
', '\n'); + Result := AnsiReplaceStr(S, '"', ''''); + Result := AnsiReplaceStr(Result, ^M^J, BR); + Result := AnsiReplaceStr(Result, ^M, BR); + Result := AnsiReplaceStr(Result, ^J, BR); + if (Result <> '') and (Result[1] = #3) then begin // Is RegEx + delete(Result, 1, 1); + if Pos('/', Result) <> 1 then Result := '/' + Result + '/'; + end + else begin + I := pos('%', Result); + if (pos(';', Result) = 0) and (I <> 0) and ((length(Result) > 1) and (I < length(Result)) and (Result[I+1] in ['0'..'9'])) then begin // Has param place holder, ";" disable place holder + J := FirstDelimiter(' "''[]{}><=!*-+/,', Result, I+2); + if J = 0 then J := length(Result)+1; + if J <> (length(Result)+1) then begin + insert('+"', Result, J); + Result := Result + '"'; + end; + if I <> 1 then begin + insert('"+', Result, I); + Result := '"' + Result; + end; + end + else + if (I = 1) and (length(Result) > 1) and (Result[2] in ['a'..'z', 'A'..'Z']) then + Result := copy(Result, 2, length(Result)) + else + Result := '"' + Result + '"' + end; +end; + +function CaseOf(const S : string; const Cases : array of string) : integer; begin + for Result := 0 to high(Cases) do + if SameText(S, Cases[Result]) then exit; + Result := -1; +end; + +function RCaseOf(const S : string; const Cases : array of string) : integer; begin + for Result := 0 to high(Cases) do + if pos(Cases[Result], S) <> 0 then exit; + Result := -1; +end; + +function EnumToJSString(TypeInfo : PTypeInfo; Value : integer) : string; +var + I : integer; + JS: string; +begin + Result := ''; + JS := GetEnumName(TypeInfo, Value); + for I := 1 to length(JS) do + if JS[I] in ['A'..'Z'] then begin + Result := LowerCase(copy(JS, I, 100)); + if Result = 'perc' then Result := '%'; + exit + end; +end; + +function SetPaddings(Top : integer; Right : integer = 0; Bottom : integer = -1; Left : integer = 0; CSSUnit : TCSSUnit = cssPX; + Header : boolean = true) : string; +begin + Result := Format('%s%d%3:s %2:d%3:s', [IfThen(Header, 'padding: ', ''), Top, Right, EnumToJSString(TypeInfo(TCSSUnit), ord(CSSUnit))]); + if Bottom <> -1 then + Result := Result + Format(' %d%2:s %1:d%2:s', [Bottom, Left, EnumToJSString(TypeInfo(TCSSUnit), ord(CSSUnit))]); +end; + +function SetMargins(Top : integer; Right : integer = 0; Bottom : integer = 0; Left : integer = 0; CSSUnit : TCSSUnit = cssNone; + Header : boolean = false) : string; +begin + Result := Format('%s%d%5:s %2:d%5:s %3:d%5:s %4:d%s', [IfThen(Header, 'margin: ', ''), Top, Right, Bottom, Left, + EnumToJSString(TypeInfo(TCSSUnit), ord(CSSUnit))]) +end; + +function Before(const BeforeS, AfterS, S : string) : boolean; +var + I : integer; +begin + I := pos(BeforeS, S); + Result := (I <> 0) and (I < pos(AfterS, S)) +end; + +function IsUpperCase(S : string) : boolean; +var + I : integer; +begin + Result := false; + for I := 1 to length(S) do + if S[I] in ['a'..'z'] then exit; + Result := true; +end; + +function SpaceIdents(const aLevel: integer; const aWidth: string = ' '): string; +var + c: integer; +begin + Result := ''; + if aLevel < 1 then Exit; + for c := 1 to aLevel do Result := Result + aWidth; +end; + +function MinValueOf(Values : array of integer; const MinValue : integer = 0) : integer; +var + I : integer; +begin + for I := 0 to High(Values) do + if Values[I] <= MinValue then Values[I] := MAXINT; + Result := MinIntValue(Values); + // if all are the minimum value then return 0 + if Result = MAXINT then Result := MinValue; +end; + +function BeautifyJS(const AScript : string; const StartingLevel : integer = 0; SplitHTMLNewLine : boolean = true) : string; +var + pBlockBegin, pBlockEnd, pPropBegin, pPropEnd, pStatEnd, {pFuncBegin,} pSqrBegin, pSqrEnd, + pFunction, pString, pOpPlus, pOpMinus, pOpTime, {pOpDivide,} pOpEqual, pRegex : integer; + P, Lvl : integer; + Res : string; + + function AddNewLine(const atPos : integer; const AddText : string) : integer; begin + insert(^J + AddText, Res, atPos); + Result := length(^J + AddText); + end; + + function SplitHTMLString(AStart, AEnd : integer): integer; // range is including the quotes + var + br,pe,ps: integer; + s: string; + begin + Result := AEnd; + s := copy(res, AStart, AEnd); + // find html new line (increase verbosity) + br := PosEx('
', res, AStart+1); + pe := PosEx('

', res, AStart+1); + ps := MinValueOf([br,pe]); + // html new line is found + // Result-5 is to skip the mark at the end of the line + while (ps > 0) and (ps < Result-5) do begin + s := '"+'^J+SpaceIdents(Lvl)+SpaceIdents(3)+'"'; + Insert(s, res, ps+4); + Result := Result + length(s); + // find next new line + br := PosEx('
', res, ps+length(s)+4); + pe := PosEx('

', res, ps+length(s)+4); + ps := MinValueOf([br,pe]); + end; + end; + +var + Backward, onReady, inProp, inNew : boolean; + LvlProp, i, j, k : integer; +begin + // skip empty script + if AScript = '' then exit; + P := 1; + Res := AScript; + inNew := true; + inProp := false; + onReady := false; + LvlProp := 1000; // max identation depth + Lvl := StartingLevel; + // remove space in the beginning + if Res[1] = ' ' then Delete(Res, 1, 1); + // proceed the whole generated script by scanning the text + while (p > 0) and (p < Length(Res)-1) do begin + // chars that will be processed (10 signs) + inc(P); + pString := PosEx('"', Res, P); + pOpEqual := PosEx('=', Res, P); + pOpPlus := PosEx('+', Res, P); + pOpMinus := PosEx('-', Res, P); + pOpTime := PosEx('*', Res, P); + pBlockBegin := PosEx('{', Res, P); + pBlockEnd := PosEx('}', Res, P); + pPropBegin := PosEx(':', Res, P); + pPropEnd := PosEx(',', Res, P); + pStatEnd := PosEx(';', Res, P); + pSqrBegin := PosEx('[', Res, P); + pSqrEnd := PosEx(']', Res, P); + pFunction := PosEx('function', Res, P); + pRegex := PosEx('regex:', Res, P); + // process what is found first + P := MinValueOf([pBlockBegin, pBlockEnd, pPropBegin, pPropEnd, pStatEnd, {pFuncBegin,} pSqrBegin, pSqrEnd, + pString, pOpEqual, pOpPlus, pOpMinus, pOpTime, {pOpDivide,} pFunction, pRegex]); + // keep Ext's onReady function at the first line + if (not onReady) and (P > 0) and (length(Res) >= P) and (res[p] = 'f') then + if Copy(Res, P-9, 9) = '.onReady(' then begin + onReady := true; + continue; + end; + // now, let's proceed with what char is found + if P > 0 then begin + // reset inProp status based on minimum lvlProp + if inProp then inProp := Lvl >= LvlProp; // or (lvl > StartingLevel); + // process chars + case res[p] of // skip string by jump to the next mark + '"' : + if Res[P+1] = '"' then // skip empty string + inc(P) + else + if SplitHTMLNewLine then // proceed html string value + P := SplitHTMLString(P, PosEx('"', Res, P+1)) + else // just skip the string + P := PosEx('"', Res, P+1); + '=', '+', '*', '/': begin // neat the math operator + insert(' ', Res, P); inc(P); + if Res[P+1] = '=' then inc(P); // double equals + insert(' ', Res, P+1); inc(P); + end; + '{' : // statement block begin + if Res[P+1] = '}' then // skip empty statement + inc(P) + else begin + inc(Lvl); // Increase identation level + inProp := false; + inc(P, AddNewLine(P+1, SpaceIdents(Lvl))); + end; + '}' : begin // statement block end + // some pair values are treated specially: keep },{ pair intact to save empty lines + if (length(Res) >= (P+2)) and (Res[P+1] = ',') and (Res[P+2] = '{') then begin + dec(Lvl); + inc(P, AddNewLine(P, SpaceIdents(Lvl)) + 2); + inc(Lvl); + inc(P, AddNewLine(P+1, SpaceIdents(Lvl))); + continue; + end; + if not inNew then // special })] pair for items property group object ending + inNew := (Res[P+1] = ')') and (Res[P+2] = ']'); + // common treatment for block ending + dec(Lvl); // decrease identation level + P := P + AddNewLine(P, SpaceIdents(lvl)); + // bring the following trails + I := P; + Backward := false; + repeat + inc(I); + // find multiple statement block end + if (length(Res) >= I) and (Res[I] in ['{', '}', ';']) then backward := true; + if inNew and (length(Res) >= I) and (Res[I] = ']') then backward := true; + until (I > length(Res)) or (Res[I] = ',') or backward; + if not backward then // add new line + inc(P, AddNewLine(i+1, SpaceIdents(Lvl))) + else // suspend new line to proceed with next block + P := i-1; + end; + ';' : begin // end of statement + // fix to ExtPascal parser bug which become helpful, because it could be mark of new object creation + if (length(Res) >= P+2) and (Res[P+1] = ' ') and (Res[P+2] = 'O') then begin // ; O string + inProp := false; + delete(Res, P+1, 1); + inc(P, AddNewLine(P+1, ^J+SpaceIdents(Lvl))); + continue; + end; + if (length(Res) >= P+1) and (Res[P+1] = '}') then continue; // skip if it's already at the end of block + if P = length(Res) then // skip identation on last end of statement + inc(P, AddNewLine(P+1, SpaceIdents(StartingLevel-1))) + else + inc(P, AddNewLine(P+1, SpaceIdents(lvl))); + end; + '[' : begin // square declaration begin + if Res[P+1] = '[' then begin // double square treat as sub level + inc(Lvl); + inc(P, AddNewLine(p+1, SpaceIdents(Lvl))); + inProp := true; + continue; + end; + // find special pair within square block + i := PosEx(']', Res, P+1); + j := PosEx('{', Res, P+1); + k := PosEx('new ', Res, P+1); + if (j > 0) and (j < i) then begin // new block found in property value + inc(Lvl); + // new object found in property value, add new line + if (k > 0) and (k < i) then begin + inNew := true; + inc(P, AddNewLine(P+1, SpaceIdents(Lvl))); + end + else begin // move forward to next block beginning + inNew := false; + inc(J, AddNewLine(J+1, SpaceIdents(Lvl))); + P := j-1; + end; + end + else // no sub block found, move at the end of square block + P := i; + end; + ']' : // square declaration end + if Res[P-1] = ']' then begin // double square ending found, end sub block + dec(Lvl); + inc(P, AddNewLine(P, SpaceIdents(Lvl))); + end + else // skip processing if not part of square sub block + if not inNew then + continue + else begin // end of block square items group + dec(Lvl); + inc(P, AddNewLine(P, SpaceIdents(Lvl))); + end; + ':' : begin // property value begin + if Res[P+1] <> ' ' then begin // separate name:value with a space + insert(' ', Res, P+1); + inc(P); + end; + inProp := true; + if Lvl < LvlProp then LvlProp := Lvl; // get minimum depth level of property + end; + ',' : // property value end + if inProp then inc(P, AddNewLine(P+1, SpaceIdents(Lvl))); + 'f' : begin // independent function definition + if inProp then Continue; // skip function if within property + if copy(Res, P, 8) = 'function' then // add new line for independent function + inc(P, AddNewLine(P, SpaceIdents(Lvl)) + 7); + end; + 'r' : begin + P := PosEx('/', Res, P); + P := PosEx('/', Res, P+1); + end; + end; + end; + end; + Result := Res; +end; + +function BeautifyCSS(const AStyle : string) : string; +var + pOpen, pClose, pProp, pEnd, pString : integer; + P, Lvl : integer; + Res : string; +begin + P := 1; + Lvl := 0; + Res := ^J+AStyle; + while P > 0 do begin + inc(P); + pString := PosEx('''', Res, P); + pOpen := PosEx('{', Res, P); + pClose := PosEx('}', Res, P); + pProp := PosEx(':', Res, P); + pEnd := PosEx(';', Res, P); + P := MinValueOf([pString, pOpen, pClose, pProp, pEnd]); + if P > 0 then + case Res[p] of + '''' : P := PosEx('''', Res, P+1); + '{' : begin + Inc(lvl); + if (res[p-1] <> ' ') then begin + Insert(' ', res, p); + p := p+1; + end; + Insert(^J+SpaceIdents(lvl), res, p+1); + p := p + Length(^J+SpaceIdents(lvl)); + end; + '}' : begin + dec(lvl); + insert(^J+SpaceIdents(lvl), Res, P); + inc(P, length(^J+SpaceIdents(Lvl))); + insert(^J+SpaceIdents(lvl), Res, P+1); + inc(P, length(^J+SpaceIdents(Lvl))); + end; + ':' : + if Res[P+1] <> ' ' then begin + insert(' ', Res, P+1); + inc(P); + end; + ';' : begin + if Res[P+1] = '}' then continue; + if Res[P+1] = ' ' then delete(Res, P+1, 1); + insert(^J+SpaceIdents(Lvl), Res, P+1); + inc(P, length(^J+SpaceIdents(Lvl))); + end; + end; + end; + Result := Res; +end; + +function LengthRegExp(Rex : string; CountAll : Boolean = true) : integer; +var + Slash, I : integer; + N : string; +begin + Result := 0; + N := ''; + Slash := 0; + for I := 1 to length(Rex) do + case Rex[I] of + '\' : + if CountAll and (I < length(Rex)) and (Rex[I+1] in ['d', 'D', 'l', 'f', 'n', 'r', 's', 'S', 't', 'w', 'W']) then inc(Slash); + ',', '{' : begin + N := ''; + if Slash > 1 then begin + inc(Result, Slash); + Slash := 0; + end; + end; + '}' : begin + inc(Result, StrToIntDef(N, 0)); + N := ''; + dec(Slash); + end; + '0'..'9' : N := N + Rex[I]; + '?' : inc(Slash); + '*' : + if not CountAll then begin + Result := -1; + exit; + end; + end; + inc(Result, Slash); +end; + +function JSDateToDateTime(JSDate : string) : TDateTime; begin + Result := EncodeDateTime(StrToInt(copy(JSDate, 12, 4)), AnsiIndexStr(copy(JSDate, 5, 3), ['Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec']) +1, + StrToInt(copy(JSDate, 9, 2)), StrToInt(copy(JSDate, 17, 2)), StrToInt(copy(JSDate, 20, 2)), StrToInt(copy(JSDate, 23, 2)), 0); +end; + +end. diff --git a/src/thirdparty/RegExpr.pas b/src/thirdparty/RegExpr.pas new file mode 100644 index 0000000..158f7d3 --- /dev/null +++ b/src/thirdparty/RegExpr.pas @@ -0,0 +1,4041 @@ +unit RegExpr; + +{ + TRegExpr class library + Delphi Regular Expressions + + Copyright (c) 1999-2004 Andrey V. Sorokin, St.Petersburg, Russia + + You may use this software in any kind of development, + including comercial, redistribute, and modify it freely, + under the following restrictions : + 1. This software is provided as it is, without any kind of + warranty given. Use it at Your own risk.The author is not + responsible for any consequences of use of this software. + 2. The origin of this software may not be mispresented, You + must not claim that You wrote the original software. If + You use this software in any kind of product, it would be + appreciated that there in a information box, or in the + documentation would be an acknowledgement like + + Partial Copyright (c) 2004 Andrey V. Sorokin + http://RegExpStudio.com + mailto:anso@mail.ru + + 3. You may not have any income from distributing this source + (or altered version of it) to other developers. When You + use this product in a comercial package, the source may + not be charged seperatly. + 4. Altered versions must be plainly marked as such, and must + not be misrepresented as being the original software. + 5. RegExp Studio application and all the visual components as + well as documentation is not part of the TRegExpr library + and is not free for usage. + + mailto:anso@mail.ru + http://RegExpStudio.com + http://anso.da.ru/ +} + +interface + +// ======== Determine compiler +{$IFDEF VER80} Sorry, TRegExpr is for 32-bits Delphi only. Delphi 1 is not supported (and whos really care today?!). {$ENDIF} +{$IFDEF VER90} {$DEFINE D2} {$ENDIF} // D2 +{$IFDEF VER93} {$DEFINE D2} {$ENDIF} // CPPB 1 +{$IFDEF VER100} {$DEFINE D3} {$DEFINE D2} {$ENDIF} // D3 +{$IFDEF VER110} {$DEFINE D4} {$DEFINE D3} {$DEFINE D2} {$ENDIF} // CPPB 3 +{$IFDEF VER120} {$DEFINE D4} {$DEFINE D3} {$DEFINE D2} {$ENDIF} // D4 +{$IFDEF VER130} {$DEFINE D5} {$DEFINE D4} {$DEFINE D3} {$DEFINE D2} {$ENDIF} // D5 +{$IFDEF VER140} {$DEFINE D6} {$DEFINE D5} {$DEFINE D4} {$DEFINE D3} {$DEFINE D2} {$ENDIF} // D6 +{$IFDEF VER150} {$DEFINE D7} {$DEFINE D6} {$DEFINE D5} {$DEFINE D4} {$DEFINE D3} {$DEFINE D2} {$ENDIF} // D7 + +// ======== Define base compiler options +{$BOOLEVAL OFF} +{$EXTENDEDSYNTAX ON} +{$LONGSTRINGS ON} +{$OPTIMIZATION ON} +{$IFDEF D6} + {$WARN SYMBOL_PLATFORM OFF} // Suppress .Net warnings +{$ENDIF} +{$IFDEF D7} + {$WARN UNSAFE_CAST OFF} // Suppress .Net warnings + {$WARN UNSAFE_TYPE OFF} // Suppress .Net warnings + {$WARN UNSAFE_CODE OFF} // Suppress .Net warnings +{$ENDIF} +{$IFDEF FPC} + {$MODE DELPHI} // Delphi-compatible mode in FreePascal +{$ENDIF} + +// ======== Define options for TRegExpr engine +{.$DEFINE UniCode} // Unicode support +{$DEFINE RegExpPCodeDump} // p-code dumping (see Dump method) +{$IFNDEF FPC} // the option is not supported in FreePascal + {$DEFINE reRealExceptionAddr} // exceptions will point to appropriate source line, not to Error procedure +{$ENDIF} +{$DEFINE ComplexBraces} // support braces in complex cases +{$IFNDEF UniCode} // the option applicable only for non-UniCode mode + {$DEFINE UseSetOfChar} // Significant optimization by using set of char +{$ENDIF} +{$IFDEF UseSetOfChar} + {$DEFINE UseFirstCharSet} // Fast skip between matches for r.e. that starts with determined set of chars +{$ENDIF} + +// ======== Define Pascal-language options +// Define 'UseAsserts' option (do not edit this definitions). +// Asserts used to catch 'strange bugs' in TRegExpr implementation (when something goes +// completely wrong). You can swith asserts on/off with help of {$C+}/{$C-} compiler options. +{$IFDEF D3} {$DEFINE UseAsserts} {$ENDIF} +{$IFDEF FPC} {$DEFINE UseAsserts} {$ENDIF} + +// Define 'use subroutine parameters default values' option (do not edit this definition). +{$IFDEF D4} {$DEFINE DefParam} {$ENDIF} + +// Define 'OverMeth' options, to use method overloading (do not edit this definitions). +{$IFDEF D5} {$DEFINE OverMeth} {$ENDIF} +{$IFDEF FPC} {$DEFINE OverMeth} {$ENDIF} + +uses + Classes, // TStrings in Split method + SysUtils; // Exception + +type + {$IFDEF UniCode} + PRegExprChar = PWideChar; + RegExprString = WideString; + REChar = WideChar; + {$ELSE} + PRegExprChar = PChar; + RegExprString = AnsiString; //###0.952 was string + REChar = Char; + {$ENDIF} + TREOp = REChar; // internal p-code type //###0.933 + PREOp = ^TREOp; + TRENextOff = integer; // internal Next "pointer" (offset to current p-code) //###0.933 + PRENextOff = ^TRENextOff; // used for extracting Next "pointers" from compiled r.e. //###0.933 + TREBracesArg = integer; // type of {m,n} arguments + PREBracesArg = ^TREBracesArg; + +const + REOpSz = SizeOf (TREOp) div SizeOf (REChar); // size of p-code in RegExprString units + RENextOffSz = SizeOf (TRENextOff) div SizeOf (REChar); // size of Next 'pointer' -"- + REBracesArgSz = SizeOf (TREBracesArg) div SizeOf (REChar); // size of BRACES arguments -"- + +type + TRegExprInvertCaseFunction = function (const Ch : REChar) : REChar + of object; + +const + EscChar = '\'; // 'Escape'-char ('\' in common r.e.) used for escaping metachars (\w, \d etc). + RegExprModifierI : boolean = False; // default value for ModifierI + RegExprModifierR : boolean = True; // default value for ModifierR + RegExprModifierS : boolean = True; // default value for ModifierS + RegExprModifierG : boolean = True; // default value for ModifierG + RegExprModifierM : boolean = False; // default value for ModifierM + RegExprModifierX : boolean = False; // default value for ModifierX + RegExprSpaceChars : RegExprString = // default value for SpaceChars + ' '#$9#$A#$D#$C; + RegExprWordChars : RegExprString = // default value for WordChars + '0123456789' //###0.940 + + 'abcdefghijklmnopqrstuvwxyz' + + 'ABCDEFGHIJKLMNOPQRSTUVWXYZ_'; + RegExprLineSeparators : RegExprString =// default value for LineSeparators + #$d#$a{$IFDEF UniCode}+#$b#$c#$2028#$2029#$85{$ENDIF}; //###0.947 + RegExprLinePairedSeparator : RegExprString =// default value for LinePairedSeparator + #$d#$a; + { if You need Unix-styled line separators (only \n), then use: + RegExprLineSeparators = #$a; + RegExprLinePairedSeparator = ''; + } + + +const + NSUBEXP = 15; // max number of subexpression //###0.929 + // Cannot be more than NSUBEXPMAX + // Be carefull - don't use values which overflow CLOSE opcode + // (in this case you'll get compiler erorr). + // Big NSUBEXP will cause more slow work and more stack required + NSUBEXPMAX = 255; // Max possible value for NSUBEXP. //###0.945 + // Don't change it! It's defined by internal TRegExpr design. + + MaxBracesArg = $7FFFFFFF - 1; // max value for {n,m} arguments //###0.933 + + {$IFDEF ComplexBraces} + LoopStackMax = 10; // max depth of loops stack //###0.925 + {$ENDIF} + + TinySetLen = 3; + // if range includes more then TinySetLen chars, //###0.934 + // then use full (32 bytes) ANYOFFULL instead of ANYOF[BUT]TINYSET + // !!! Attension ! If you change TinySetLen, you must + // change code marked as "//!!!TinySet" + + +type + +{$IFDEF UseSetOfChar} + PSetOfREChar = ^TSetOfREChar; + TSetOfREChar = set of REChar; +{$ENDIF} + + TRegExpr = class; + + TRegExprReplaceFunction = function (ARegExpr : TRegExpr): string + of object; + + TRegExpr = class + private + startp : array [0 .. NSUBEXP - 1] of PRegExprChar; // founded expr starting points + endp : array [0 .. NSUBEXP - 1] of PRegExprChar; // founded expr end points + + {$IFDEF ComplexBraces} + LoopStack : array [1 .. LoopStackMax] of integer; // state before entering loop + LoopStackIdx : integer; // 0 - out of all loops + {$ENDIF} + + // The "internal use only" fields to pass info from compile + // to execute that permits the execute phase to run lots faster on + // simple cases. + regstart : REChar; // char that must begin a match; '\0' if none obvious + reganch : REChar; // is the match anchored (at beginning-of-line only)? + regmust : PRegExprChar; // string (pointer into program) that match must include, or nil + regmlen : integer; // length of regmust string + // Regstart and reganch permit very fast decisions on suitable starting points + // for a match, cutting down the work a lot. Regmust permits fast rejection + // of lines that cannot possibly match. The regmust tests are costly enough + // that regcomp() supplies a regmust only if the r.e. contains something + // potentially expensive (at present, the only such thing detected is * or + + // at the start of the r.e., which can involve a lot of backup). Regmlen is + // supplied because the test in regexec() needs it and regcomp() is computing + // it anyway. + {$IFDEF UseFirstCharSet} //###0.929 + FirstCharSet : TSetOfREChar; + {$ENDIF} + + // work variables for Exec's routins - save stack in recursion} + reginput : PRegExprChar; // String-input pointer. + fInputStart : PRegExprChar; // Pointer to first char of input string. + fInputEnd : PRegExprChar; // Pointer to char AFTER last char of input string + + // work variables for compiler's routines + regparse : PRegExprChar; // Input-scan pointer. + regnpar : integer; // count. + regdummy : char; + regcode : PRegExprChar; // Code-emit pointer; @regdummy = don't. + regsize : integer; // Code size. + + regexpbeg : PRegExprChar; // only for error handling. Contains + // pointer to beginning of r.e. while compiling + fExprIsCompiled : boolean; // true if r.e. successfully compiled + + // programm is essentially a linear encoding + // of a nondeterministic finite-state machine (aka syntax charts or + // "railroad normal form" in parsing technology). Each node is an opcode + // plus a "next" pointer, possibly plus an operand. "Next" pointers of + // all nodes except BRANCH implement concatenation; a "next" pointer with + // a BRANCH on both ends of it is connecting two alternatives. (Here we + // have one of the subtle syntax dependencies: an individual BRANCH (as + // opposed to a collection of them) is never concatenated with anything + // because of operator precedence.) The operand of some types of node is + // a literal string; for others, it is a node leading into a sub-FSM. In + // particular, the operand of a BRANCH node is the first node of the branch. + // (NB this is *not* a tree structure: the tail of the branch connects + // to the thing following the set of BRANCHes.) The opcodes are: + programm : PRegExprChar; // Unwarranted chumminess with compiler. + + fExpression : PRegExprChar; // source of compiled r.e. + fInputString : PRegExprChar; // input string + + fLastError : integer; // see Error, LastError + + fModifiers : integer; // modifiers + fCompModifiers : integer; // compiler's copy of modifiers + fProgModifiers : integer; // modifiers values from last programm compilation + + fSpaceChars : RegExprString; //###0.927 + fWordChars : RegExprString; //###0.929 + fInvertCase : TRegExprInvertCaseFunction; //###0.927 + + fLineSeparators : RegExprString; //###0.941 + fLinePairedSeparatorAssigned : boolean; + fLinePairedSeparatorHead, + fLinePairedSeparatorTail : REChar; + {$IFNDEF UniCode} + fLineSeparatorsSet : set of REChar; + {$ENDIF} + + procedure InvalidateProgramm; + // Mark programm as have to be [re]compiled + + function IsProgrammOk : boolean; //###0.941 + // Check if we can use precompiled r.e. or + // [re]compile it if something changed + + function GetExpression : RegExprString; + procedure SetExpression (const s : RegExprString); + + function GetModifierStr : RegExprString; + class function ParseModifiersStr (const AModifiers : RegExprString; + var AModifiersInt : integer) : boolean; //###0.941 class function now + // Parse AModifiers string and return true and set AModifiersInt + // if it's in format 'ismxrg-ismxrg'. + procedure SetModifierStr (const AModifiers : RegExprString); + + function GetModifier (AIndex : integer) : boolean; + procedure SetModifier (AIndex : integer; ASet : boolean); + + procedure Error (AErrorID : integer); virtual; // error handler. + // Default handler raise exception ERegExpr with + // Message = ErrorMsg (AErrorID), ErrorCode = AErrorID + // and CompilerErrorPos = value of property CompilerErrorPos. + + + {==================== Compiler section ===================} + function CompileRegExpr (exp : PRegExprChar) : boolean; + // compile a regular expression into internal code + + procedure Tail (p : PRegExprChar; val : PRegExprChar); + // set the next-pointer at the end of a node chain + + procedure OpTail (p : PRegExprChar; val : PRegExprChar); + // regoptail - regtail on operand of first argument; nop if operandless + + function EmitNode (op : TREOp) : PRegExprChar; + // regnode - emit a node, return location + + procedure EmitC (b : REChar); + // emit (if appropriate) a byte of code + + procedure InsertOperator (op : TREOp; opnd : PRegExprChar; sz : integer); //###0.90 + // insert an operator in front of already-emitted operand + // Means relocating the operand. + + function ParseReg (paren : integer; var flagp : integer) : PRegExprChar; + // regular expression, i.e. main body or parenthesized thing + + function ParseBranch (var flagp : integer) : PRegExprChar; + // one alternative of an | operator + + function ParsePiece (var flagp : integer) : PRegExprChar; + // something followed by possible [*+?] + + function ParseAtom (var flagp : integer) : PRegExprChar; + // the lowest level + + function GetCompilerErrorPos : integer; + // current pos in r.e. - for error hanling + + {$IFDEF UseFirstCharSet} //###0.929 + procedure FillFirstCharSet (prog : PRegExprChar); + {$ENDIF} + + {===================== Mathing section ===================} + function regrepeat (p : PRegExprChar; AMax : integer) : integer; + // repeatedly match something simple, report how many + + function regnext (p : PRegExprChar) : PRegExprChar; + // dig the "next" pointer out of a node + + function MatchPrim (prog : PRegExprChar) : boolean; + // recursively matching routine + + function ExecPrim (AOffset: integer) : boolean; + // Exec for stored InputString + + {$IFDEF RegExpPCodeDump} + function DumpOp (op : REChar) : RegExprString; + {$ENDIF} + + function GetSubExprMatchCount : integer; + function GetMatchPos (Idx : integer) : integer; + function GetMatchLen (Idx : integer) : integer; + function GetMatch (Idx : integer) : RegExprString; + + function GetInputString : RegExprString; + procedure SetInputString (const AInputString : RegExprString); + + {$IFNDEF UseSetOfChar} + function StrScanCI (s : PRegExprChar; ch : REChar) : PRegExprChar; //###0.928 + {$ENDIF} + + procedure SetLineSeparators (const AStr : RegExprString); + procedure SetLinePairedSeparator (const AStr : RegExprString); + function GetLinePairedSeparator : RegExprString; + + public + constructor Create; + destructor Destroy; override; + + class function VersionMajor : integer; //###0.944 + class function VersionMinor : integer; //###0.944 + + property Expression : RegExprString read GetExpression write SetExpression; + // Regular expression. + // For optimization, TRegExpr will automatically compiles it into 'P-code' + // (You can see it with help of Dump method) and stores in internal + // structures. Real [re]compilation occures only when it really needed - + // while calling Exec[Next], Substitute, Dump, etc + // and only if Expression or other P-code affected properties was changed + // after last [re]compilation. + // If any errors while [re]compilation occures, Error method is called + // (by default Error raises exception - see below) + + property ModifierStr : RegExprString read GetModifierStr write SetModifierStr; + // Set/get default values of r.e.syntax modifiers. Modifiers in + // r.e. (?ismx-ismx) will replace this default values. + // If you try to set unsupported modifier, Error will be called + // (by defaul Error raises exception ERegExpr). + + property ModifierI : boolean index 1 read GetModifier write SetModifier; + // Modifier /i - caseinsensitive, initialized from RegExprModifierI + + property ModifierR : boolean index 2 read GetModifier write SetModifier; + // Modifier /r - use r.e.syntax extended for russian, + // (was property ExtSyntaxEnabled in previous versions) + // If true, then à-ÿ additional include russian letter '¸', + // À-ß additional include '¨', and à-ß include all russian symbols. + // You have to turn it off if it may interfere with you national alphabet. + // , initialized from RegExprModifierR + + property ModifierS : boolean index 3 read GetModifier write SetModifier; + // Modifier /s - '.' works as any char (else as [^\n]), + // , initialized from RegExprModifierS + + property ModifierG : boolean index 4 read GetModifier write SetModifier; + // Switching off modifier /g switchs all operators in + // non-greedy style, so if ModifierG = False, then + // all '*' works as '*?', all '+' as '+?' and so on. + // , initialized from RegExprModifierG + + property ModifierM : boolean index 5 read GetModifier write SetModifier; + // Treat string as multiple lines. That is, change `^' and `$' from + // matching at only the very start or end of the string to the start + // or end of any line anywhere within the string. + // , initialized from RegExprModifierM + + property ModifierX : boolean index 6 read GetModifier write SetModifier; + // Modifier /x - eXtended syntax, allow r.e. text formatting, + // see description in the help. Initialized from RegExprModifierX + + function Exec (const AInputString : RegExprString) : boolean; {$IFDEF OverMeth} overload; + {$IFNDEF FPC} // I do not know why FreePascal cannot overload methods with empty param list + function Exec : boolean; overload; //###0.949 + {$ENDIF} + function Exec (AOffset: integer) : boolean; overload; //###0.949 + {$ENDIF} + // match a programm against a string AInputString + // !!! Exec store AInputString into InputString property + // For Delphi 5 and higher available overloaded versions - first without + // parameter (uses already assigned to InputString property value) + // and second that has integer parameter and is same as ExecPos + + function ExecNext : boolean; + // find next match: + // ExecNext; + // works same as + // if MatchLen [0] = 0 then ExecPos (MatchPos [0] + 1) + // else ExecPos (MatchPos [0] + MatchLen [0]); + // but it's more simpler ! + // Raises exception if used without preceeding SUCCESSFUL call to + // Exec* (Exec, ExecPos, ExecNext). So You always must use something like + // if Exec (InputString) then repeat { proceed results} until not ExecNext; + + function ExecPos (AOffset: integer {$IFDEF DefParam}= 1{$ENDIF}) : boolean; + // find match for InputString starting from AOffset position + // (AOffset=1 - first char of InputString) + + property InputString : RegExprString read GetInputString write SetInputString; + // returns current input string (from last Exec call or last assign + // to this property). + // Any assignment to this property clear Match* properties ! + + function Substitute (const ATemplate : RegExprString) : RegExprString; + // Returns ATemplate with '$&' or '$0' replaced by whole r.e. + // occurence and '$n' replaced by occurence of subexpression #n. + // Since v.0.929 '$' used instead of '\' (for future extensions + // and for more Perl-compatibility) and accept more then one digit. + // If you want place into template raw '$' or '\', use prefix '\' + // Example: '1\$ is $2\\rub\\' -> '1$ is \rub\' + // If you want to place raw digit after '$n' you must delimit + // n with curly braces '{}'. + // Example: 'a$12bc' -> 'abc' + // 'a${1}2bc' -> 'a2bc'. + + procedure Split (AInputStr : RegExprString; APieces : TStrings); + // Split AInputStr into APieces by r.e. occurencies + // Internally calls Exec[Next] + + function Replace (AInputStr : RegExprString; + const AReplaceStr : RegExprString; + AUseSubstitution : boolean{$IFDEF DefParam}= False{$ENDIF}) //###0.946 + : RegExprString; {$IFDEF OverMeth} overload; + function Replace (AInputStr : RegExprString; + AReplaceFunc : TRegExprReplaceFunction) + : RegExprString; overload; + {$ENDIF} + function ReplaceEx (AInputStr : RegExprString; + AReplaceFunc : TRegExprReplaceFunction) + : RegExprString; + // Returns AInputStr with r.e. occurencies replaced by AReplaceStr + // If AUseSubstitution is true, then AReplaceStr will be used + // as template for Substitution methods. + // For example: + // Expression := '({-i}block|var)\s*\(\s*([^ ]*)\s*\)\s*'; + // Replace ('BLOCK( test1)', 'def "$1" value "$2"', True); + // will return: def 'BLOCK' value 'test1' + // Replace ('BLOCK( test1)', 'def "$1" value "$2"') + // will return: def "$1" value "$2" + // Internally calls Exec[Next] + // Overloaded version and ReplaceEx operate with call-back function, + // so You can implement really complex functionality. + + property SubExprMatchCount : integer read GetSubExprMatchCount; + // Number of subexpressions has been found in last Exec* call. + // If there are no subexpr. but whole expr was found (Exec* returned True), + // then SubExprMatchCount=0, if no subexpressions nor whole + // r.e. found (Exec* returned false) then SubExprMatchCount=-1. + // Note, that some subexpr. may be not found and for such + // subexpr. MathPos=MatchLen=-1 and Match=''. + // For example: Expression := '(1)?2(3)?'; + // Exec ('123'): SubExprMatchCount=2, Match[0]='123', [1]='1', [2]='3' + // Exec ('12'): SubExprMatchCount=1, Match[0]='12', [1]='1' + // Exec ('23'): SubExprMatchCount=2, Match[0]='23', [1]='', [2]='3' + // Exec ('2'): SubExprMatchCount=0, Match[0]='2' + // Exec ('7') - return False: SubExprMatchCount=-1 + + property MatchPos [Idx : integer] : integer read GetMatchPos; + // pos of entrance subexpr. #Idx into tested in last Exec* + // string. First subexpr. have Idx=1, last - MatchCount, + // whole r.e. have Idx=0. + // Returns -1 if in r.e. no such subexpr. or this subexpr. + // not found in input string. + + property MatchLen [Idx : integer] : integer read GetMatchLen; + // len of entrance subexpr. #Idx r.e. into tested in last Exec* + // string. First subexpr. have Idx=1, last - MatchCount, + // whole r.e. have Idx=0. + // Returns -1 if in r.e. no such subexpr. or this subexpr. + // not found in input string. + // Remember - MatchLen may be 0 (if r.e. match empty string) ! + + property Match [Idx : integer] : RegExprString read GetMatch; + // == copy (InputString, MatchPos [Idx], MatchLen [Idx]) + // Returns '' if in r.e. no such subexpr. or this subexpr. + // not found in input string. + + function LastError : integer; + // Returns ID of last error, 0 if no errors (unusable if + // Error method raises exception) and clear internal status + // into 0 (no errors). + + function ErrorMsg (AErrorID : integer) : RegExprString; virtual; + // Returns Error message for error with ID = AErrorID. + + property CompilerErrorPos : integer read GetCompilerErrorPos; + // Returns pos in r.e. there compiler stopped. + // Usefull for error diagnostics + + property SpaceChars : RegExprString read fSpaceChars write fSpaceChars; //###0.927 + // Contains chars, treated as /s (initially filled with RegExprSpaceChars + // global constant) + + property WordChars : RegExprString read fWordChars write fWordChars; //###0.929 + // Contains chars, treated as /w (initially filled with RegExprWordChars + // global constant) + + property LineSeparators : RegExprString read fLineSeparators write SetLineSeparators; //###0.941 + // line separators (like \n in Unix) + + property LinePairedSeparator : RegExprString read GetLinePairedSeparator write SetLinePairedSeparator; //###0.941 + // paired line separator (like \r\n in DOS and Windows). + // must contain exactly two chars or no chars at all + + class function InvertCaseFunction (const Ch : REChar) : REChar; + // Converts Ch into upper case if it in lower case or in lower + // if it in upper (uses current system local setings) + + property InvertCase : TRegExprInvertCaseFunction read fInvertCase write fInvertCase; //##0.935 + // Set this property if you want to override case-insensitive functionality. + // Create set it to RegExprInvertCaseFunction (InvertCaseFunction by default) + + procedure Compile; //###0.941 + // [Re]compile r.e. Usefull for example for GUI r.e. editors (to check + // all properties validity). + + {$IFDEF RegExpPCodeDump} + function Dump : RegExprString; + // dump a compiled regexp in vaguely comprehensible form + {$ENDIF} + end; + + ERegExpr = class (Exception) + public + ErrorCode : integer; + CompilerErrorPos : integer; + end; + +const + RegExprInvertCaseFunction : TRegExprInvertCaseFunction = {$IFDEF FPC} nil {$ELSE} TRegExpr.InvertCaseFunction{$ENDIF}; + // defaul for InvertCase property + +function ExecRegExpr (const ARegExpr, AInputStr : RegExprString) : boolean; +// true if string AInputString match regular expression ARegExpr +// ! will raise exeption if syntax errors in ARegExpr + +procedure SplitRegExpr (const ARegExpr, AInputStr : RegExprString; APieces : TStrings); +// Split AInputStr into APieces by r.e. ARegExpr occurencies + +function ReplaceRegExpr (const ARegExpr, AInputStr, AReplaceStr : RegExprString; + AUseSubstitution : boolean{$IFDEF DefParam}= False{$ENDIF}) : RegExprString; //###0.947 +// Returns AInputStr with r.e. occurencies replaced by AReplaceStr +// If AUseSubstitution is true, then AReplaceStr will be used +// as template for Substitution methods. +// For example: +// ReplaceRegExpr ('({-i}block|var)\s*\(\s*([^ ]*)\s*\)\s*', +// 'BLOCK( test1)', 'def "$1" value "$2"', True) +// will return: def 'BLOCK' value 'test1' +// ReplaceRegExpr ('({-i}block|var)\s*\(\s*([^ ]*)\s*\)\s*', +// 'BLOCK( test1)', 'def "$1" value "$2"') +// will return: def "$1" value "$2" + +function QuoteRegExprMetaChars (const AStr : RegExprString) : RegExprString; +// Replace all metachars with its safe representation, +// for example 'abc$cd.(' converts into 'abc\$cd\.\(' +// This function usefull for r.e. autogeneration from +// user input + +function RegExprSubExpressions (const ARegExpr : string; + ASubExprs : TStrings; AExtendedSyntax : boolean{$IFDEF DefParam}= False{$ENDIF}) : integer; +// Makes list of subexpressions found in ARegExpr r.e. +// In ASubExps every item represent subexpression, +// from first to last, in format: +// String - subexpression text (without '()') +// low word of Object - starting position in ARegExpr, including '(' +// if exists! (first position is 1) +// high word of Object - length, including starting '(' and ending ')' +// if exist! +// AExtendedSyntax - must be True if modifier /m will be On while +// using the r.e. +// Usefull for GUI editors of r.e. etc (You can find example of using +// in TestRExp.dpr project) +// Returns +// 0 Success. No unbalanced brackets was found; +// -1 There are not enough closing brackets ')'; +// -(n+1) At position n was found opening '[' without //###0.942 +// corresponding closing ']'; +// n At position n was found closing bracket ')' without +// corresponding opening '('. +// If Result <> 0, then ASubExpr can contain empty items or illegal ones + + +implementation + +uses + Windows; // CharUpper/Lower + +const + TRegExprVersionMajor : integer = 0; + TRegExprVersionMinor : integer = 952; + // TRegExpr.VersionMajor/Minor return values of this constants + + MaskModI = 1; // modifier /i bit in fModifiers + MaskModR = 2; // -"- /r + MaskModS = 4; // -"- /s + MaskModG = 8; // -"- /g + MaskModM = 16; // -"- /m + MaskModX = 32; // -"- /x + + {$IFDEF UniCode} + XIgnoredChars = ' '#9#$d#$a; + {$ELSE} + XIgnoredChars = [' ', #9, #$d, #$a]; + {$ENDIF} + +{=============================================================} +{=================== WideString functions ====================} +{=============================================================} + +{$IFDEF UniCode} + +function StrPCopy (Dest: PRegExprChar; const Source: RegExprString): PRegExprChar; + var + i, Len : Integer; + begin + Len := length (Source); //###0.932 + for i := 1 to Len do + Dest [i - 1] := Source [i]; + Dest [Len] := #0; + Result := Dest; + end; { of function StrPCopy +--------------------------------------------------------------} + +function StrLCopy (Dest, Source: PRegExprChar; MaxLen: Cardinal): PRegExprChar; + var i: Integer; + begin + for i := 0 to MaxLen - 1 do + Dest [i] := Source [i]; + Result := Dest; + end; { of function StrLCopy +--------------------------------------------------------------} + +function StrLen (Str: PRegExprChar): Cardinal; + begin + Result:=0; + while Str [result] <> #0 + do Inc (Result); + end; { of function StrLen +--------------------------------------------------------------} + +function StrPos (Str1, Str2: PRegExprChar): PRegExprChar; + var n: Integer; + begin + Result := nil; + n := Pos (RegExprString (Str2), RegExprString (Str1)); + if n = 0 + then EXIT; + Result := Str1 + n - 1; + end; { of function StrPos +--------------------------------------------------------------} + +function StrLComp (Str1, Str2: PRegExprChar; MaxLen: Cardinal): Integer; + var S1, S2: RegExprString; + begin + S1 := Str1; + S2 := Str2; + if Copy (S1, 1, MaxLen) > Copy (S2, 1, MaxLen) + then Result := 1 + else + if Copy (S1, 1, MaxLen) < Copy (S2, 1, MaxLen) + then Result := -1 + else Result := 0; + end; { function StrLComp +--------------------------------------------------------------} + +function StrScan (Str: PRegExprChar; Chr: WideChar): PRegExprChar; + begin + Result := nil; + while (Str^ <> #0) and (Str^ <> Chr) + do Inc (Str); + if (Str^ <> #0) + then Result := Str; + end; { of function StrScan +--------------------------------------------------------------} + +{$ENDIF} + + +{=============================================================} +{===================== Global functions ======================} +{=============================================================} + +function ExecRegExpr (const ARegExpr, AInputStr : RegExprString) : boolean; + var r : TRegExpr; + begin + r := TRegExpr.Create; + try + r.Expression := ARegExpr; + Result := r.Exec (AInputStr); + finally r.Free; + end; + end; { of function ExecRegExpr +--------------------------------------------------------------} + +procedure SplitRegExpr (const ARegExpr, AInputStr : RegExprString; APieces : TStrings); + var r : TRegExpr; + begin + APieces.Clear; + r := TRegExpr.Create; + try + r.Expression := ARegExpr; + r.Split (AInputStr, APieces); + finally r.Free; + end; + end; { of procedure SplitRegExpr +--------------------------------------------------------------} + +function ReplaceRegExpr (const ARegExpr, AInputStr, AReplaceStr : RegExprString; + AUseSubstitution : boolean{$IFDEF DefParam}= False{$ENDIF}) : RegExprString; + begin + with TRegExpr.Create do try + Expression := ARegExpr; + Result := Replace (AInputStr, AReplaceStr, AUseSubstitution); + finally Free; + end; + end; { of function ReplaceRegExpr +--------------------------------------------------------------} + +function QuoteRegExprMetaChars (const AStr : RegExprString) : RegExprString; + const + RegExprMetaSet : RegExprString = '^$.[()|?+*'+EscChar+'{' + + ']}'; // - this last are additional to META. + // Very similar to META array, but slighly changed. + // !Any changes in META array must be synchronized with this set. + var + i, i0, Len : integer; + begin + Result := ''; + Len := length (AStr); + i := 1; + i0 := i; + while i <= Len do begin + if Pos (AStr [i], RegExprMetaSet) > 0 then begin + Result := Result + System.Copy (AStr, i0, i - i0) + + EscChar + AStr [i]; + i0 := i + 1; + end; + inc (i); + end; + Result := Result + System.Copy (AStr, i0, MaxInt); // Tail + end; { of function QuoteRegExprMetaChars +--------------------------------------------------------------} + +function RegExprSubExpressions (const ARegExpr : string; + ASubExprs : TStrings; AExtendedSyntax : boolean{$IFDEF DefParam}= False{$ENDIF}) : integer; + type + TStackItemRec = record //###0.945 + SubExprIdx : integer; + StartPos : integer; + end; + TStackArray = packed array [0 .. NSUBEXPMAX - 1] of TStackItemRec; + var + Len, SubExprLen : integer; + i, i0 : integer; + Modif : integer; + Stack : ^TStackArray; //###0.945 + StackIdx, StackSz : integer; + begin + Result := 0; // no unbalanced brackets found at this very moment + + ASubExprs.Clear; // I don't think that adding to non empty list + // can be usefull, so I simplified algorithm to work only with empty list + + Len := length (ARegExpr); // some optimization tricks + + // first we have to calculate number of subexpression to reserve + // space in Stack array (may be we'll reserve more then need, but + // it's faster then memory reallocation during parsing) + StackSz := 1; // add 1 for entire r.e. + for i := 1 to Len do + if ARegExpr [i] = '(' + then inc (StackSz); +// SetLength (Stack, StackSz); //###0.945 + GetMem (Stack, SizeOf (TStackItemRec) * StackSz); + try + + StackIdx := 0; + i := 1; + while (i <= Len) do begin + case ARegExpr [i] of + '(': begin + if (i < Len) and (ARegExpr [i + 1] = '?') then begin + // this is not subexpression, but comment or other + // Perl extension. We must check is it (?ismxrg-ismxrg) + // and change AExtendedSyntax if /x is changed. + inc (i, 2); // skip '(?' + i0 := i; + while (i <= Len) and (ARegExpr [i] <> ')') + do inc (i); + if i > Len + then Result := -1 // unbalansed '(' + else + if TRegExpr.ParseModifiersStr (System.Copy (ARegExpr, i, i - i0), Modif) + then AExtendedSyntax := (Modif and MaskModX) <> 0; + end + else begin // subexpression starts + ASubExprs.Add (''); // just reserve space + with Stack [StackIdx] do begin + SubExprIdx := ASubExprs.Count - 1; + StartPos := i; + end; + inc (StackIdx); + end; + end; + ')': begin + if StackIdx = 0 + then Result := i // unbalanced ')' + else begin + dec (StackIdx); + with Stack [StackIdx] do begin + SubExprLen := i - StartPos + 1; + ASubExprs.Objects [SubExprIdx] := + TObject (StartPos or (SubExprLen ShL 16)); + ASubExprs [SubExprIdx] := System.Copy ( + ARegExpr, StartPos + 1, SubExprLen - 2); // add without brackets + end; + end; + end; + EscChar: inc (i); // skip quoted symbol + '[': begin + // we have to skip character ranges at once, because they can + // contain '#', and '#' in it must NOT be recognized as eXtended + // comment beginning! + i0 := i; + inc (i); + if ARegExpr [i] = ']' // cannot be 'emty' ranges - this interpretes + then inc (i); // as ']' by itself + while (i <= Len) and (ARegExpr [i] <> ']') do + if ARegExpr [i] = EscChar //###0.942 + then inc (i, 2) // skip 'escaped' char to prevent stopping at '\]' + else inc (i); + if (i > Len) or (ARegExpr [i] <> ']') //###0.942 + then Result := - (i0 + 1); // unbalansed '[' //###0.942 + end; + '#': if AExtendedSyntax then begin + // skip eXtended comments + while (i <= Len) and (ARegExpr [i] <> #$d) and (ARegExpr [i] <> #$a) + // do not use [#$d, #$a] due to UniCode compatibility + do inc (i); + while (i + 1 <= Len) and ((ARegExpr [i + 1] = #$d) or (ARegExpr [i + 1] = #$a)) + do inc (i); // attempt to work with different kinds of line separators + // now we are at the line separator that must be skipped. + end; + // here is no 'else' clause - we simply skip ordinary chars + end; // of case + inc (i); // skip scanned char + // ! can move after Len due to skipping quoted symbol + end; + + // check brackets balance + if StackIdx <> 0 + then Result := -1; // unbalansed '(' + + // check if entire r.e. added + if (ASubExprs.Count = 0) + or ((integer (ASubExprs.Objects [0]) and $FFFF) <> 1) + or (((integer (ASubExprs.Objects [0]) ShR 16) and $FFFF) <> Len) + // whole r.e. wasn't added because it isn't bracketed + // well, we add it now: + then ASubExprs.InsertObject (0, ARegExpr, TObject ((Len ShL 16) or 1)); + + finally FreeMem (Stack); + end; + end; { of function RegExprSubExpressions +--------------------------------------------------------------} + + + +const + MAGIC = TREOp (216);// programm signature + +// name opcode opnd? meaning + EEND = TREOp (0); // - End of program + BOL = TREOp (1); // - Match "" at beginning of line + EOL = TREOp (2); // - Match "" at end of line + ANY = TREOp (3); // - Match any one character + ANYOF = TREOp (4); // Str Match any character in string Str + ANYBUT = TREOp (5); // Str Match any char. not in string Str + BRANCH = TREOp (6); // Node Match this alternative, or the next + BACK = TREOp (7); // - Jump backward (Next < 0) + EXACTLY = TREOp (8); // Str Match string Str + NOTHING = TREOp (9); // - Match empty string + STAR = TREOp (10); // Node Match this (simple) thing 0 or more times + PLUS = TREOp (11); // Node Match this (simple) thing 1 or more times + ANYDIGIT = TREOp (12); // - Match any digit (equiv [0-9]) + NOTDIGIT = TREOp (13); // - Match not digit (equiv [0-9]) + ANYLETTER = TREOp (14); // - Match any letter from property WordChars + NOTLETTER = TREOp (15); // - Match not letter from property WordChars + ANYSPACE = TREOp (16); // - Match any space char (see property SpaceChars) + NOTSPACE = TREOp (17); // - Match not space char (see property SpaceChars) + BRACES = TREOp (18); // Node,Min,Max Match this (simple) thing from Min to Max times. + // Min and Max are TREBracesArg + COMMENT = TREOp (19); // - Comment ;) + EXACTLYCI = TREOp (20); // Str Match string Str case insensitive + ANYOFCI = TREOp (21); // Str Match any character in string Str, case insensitive + ANYBUTCI = TREOp (22); // Str Match any char. not in string Str, case insensitive + LOOPENTRY = TREOp (23); // Node Start of loop (Node - LOOP for this loop) + LOOP = TREOp (24); // Node,Min,Max,LoopEntryJmp - back jump for LOOPENTRY. + // Min and Max are TREBracesArg + // Node - next node in sequence, + // LoopEntryJmp - associated LOOPENTRY node addr + ANYOFTINYSET= TREOp (25); // Chrs Match any one char from Chrs (exactly TinySetLen chars) + ANYBUTTINYSET=TREOp (26); // Chrs Match any one char not in Chrs (exactly TinySetLen chars) + ANYOFFULLSET= TREOp (27); // Set Match any one char from set of char + // - very fast (one CPU instruction !) but takes 32 bytes of p-code + BSUBEXP = TREOp (28); // Idx Match previously matched subexpression #Idx (stored as REChar) //###0.936 + BSUBEXPCI = TREOp (29); // Idx -"- in case-insensitive mode + + // Non-Greedy Style Ops //###0.940 + STARNG = TREOp (30); // Same as START but in non-greedy mode + PLUSNG = TREOp (31); // Same as PLUS but in non-greedy mode + BRACESNG = TREOp (32); // Same as BRACES but in non-greedy mode + LOOPNG = TREOp (33); // Same as LOOP but in non-greedy mode + + // Multiline mode \m + BOLML = TREOp (34); // - Match "" at beginning of line + EOLML = TREOp (35); // - Match "" at end of line + ANYML = TREOp (36); // - Match any one character + + // Word boundary + BOUND = TREOp (37); // Match "" between words //###0.943 + NOTBOUND = TREOp (38); // Match "" not between words //###0.943 + + // !!! Change OPEN value if you add new opcodes !!! + + OPEN = TREOp (39); // - Mark this point in input as start of \n + // OPEN + 1 is \1, etc. + CLOSE = TREOp (ord (OPEN) + NSUBEXP); + // - Analogous to OPEN. + + // !!! Don't add new OpCodes after CLOSE !!! + +// We work with p-code thru pointers, compatible with PRegExprChar. +// Note: all code components (TRENextOff, TREOp, TREBracesArg, etc) +// must have lengths that can be divided by SizeOf (REChar) ! +// A node is TREOp of opcode followed Next "pointer" of TRENextOff type. +// The Next is a offset from the opcode of the node containing it. +// An operand, if any, simply follows the node. (Note that much of +// the code generation knows about this implicit relationship!) +// Using TRENextOff=integer speed up p-code processing. + +// Opcodes description: +// +// BRANCH The set of branches constituting a single choice are hooked +// together with their "next" pointers, since precedence prevents +// anything being concatenated to any individual branch. The +// "next" pointer of the last BRANCH in a choice points to the +// thing following the whole choice. This is also where the +// final "next" pointer of each individual branch points; each +// branch starts with the operand node of a BRANCH node. +// BACK Normal "next" pointers all implicitly point forward; BACK +// exists to make loop structures possible. +// STAR,PLUS,BRACES '?', and complex '*' and '+', are implemented as +// circular BRANCH structures using BACK. Complex '{min,max}' +// - as pair LOOPENTRY-LOOP (see below). Simple cases (one +// character per match) are implemented with STAR, PLUS and +// BRACES for speed and to minimize recursive plunges. +// LOOPENTRY,LOOP {min,max} are implemented as special pair +// LOOPENTRY-LOOP. Each LOOPENTRY initialize loopstack for +// current level. +// OPEN,CLOSE are numbered at compile time. + + +{=============================================================} +{================== Error handling section ===================} +{=============================================================} + +const + reeOk = 0; + reeCompNullArgument = 100; + reeCompRegexpTooBig = 101; + reeCompParseRegTooManyBrackets = 102; + reeCompParseRegUnmatchedBrackets = 103; + reeCompParseRegUnmatchedBrackets2 = 104; + reeCompParseRegJunkOnEnd = 105; + reePlusStarOperandCouldBeEmpty = 106; + reeNestedSQP = 107; + reeBadHexDigit = 108; + reeInvalidRange = 109; + reeParseAtomTrailingBackSlash = 110; + reeNoHexCodeAfterBSlashX = 111; + reeHexCodeAfterBSlashXTooBig = 112; + reeUnmatchedSqBrackets = 113; + reeInternalUrp = 114; + reeQPSBFollowsNothing = 115; + reeTrailingBackSlash = 116; + reeRarseAtomInternalDisaster = 119; + reeBRACESArgTooBig = 122; + reeBracesMinParamGreaterMax = 124; + reeUnclosedComment = 125; + reeComplexBracesNotImplemented = 126; + reeUrecognizedModifier = 127; + reeBadLinePairedSeparator = 128; + reeRegRepeatCalledInappropriately = 1000; + reeMatchPrimMemoryCorruption = 1001; + reeMatchPrimCorruptedPointers = 1002; + reeNoExpression = 1003; + reeCorruptedProgram = 1004; + reeNoInpitStringSpecified = 1005; + reeOffsetMustBeGreaterThen0 = 1006; + reeExecNextWithoutExec = 1007; + reeGetInputStringWithoutInputString = 1008; + reeDumpCorruptedOpcode = 1011; + reeModifierUnsupported = 1013; + reeLoopStackExceeded = 1014; + reeLoopWithoutEntry = 1015; + reeBadPCodeImported = 2000; + +function TRegExpr.ErrorMsg (AErrorID : integer) : RegExprString; + begin + case AErrorID of + reeOk: Result := 'No errors'; + reeCompNullArgument: Result := 'TRegExpr(comp): Null Argument'; + reeCompRegexpTooBig: Result := 'TRegExpr(comp): Regexp Too Big'; + reeCompParseRegTooManyBrackets: Result := 'TRegExpr(comp): ParseReg Too Many ()'; + reeCompParseRegUnmatchedBrackets: Result := 'TRegExpr(comp): ParseReg Unmatched ()'; + reeCompParseRegUnmatchedBrackets2: Result := 'TRegExpr(comp): ParseReg Unmatched ()'; + reeCompParseRegJunkOnEnd: Result := 'TRegExpr(comp): ParseReg Junk On End'; + reePlusStarOperandCouldBeEmpty: Result := 'TRegExpr(comp): *+ Operand Could Be Empty'; + reeNestedSQP: Result := 'TRegExpr(comp): Nested *?+'; + reeBadHexDigit: Result := 'TRegExpr(comp): Bad Hex Digit'; + reeInvalidRange: Result := 'TRegExpr(comp): Invalid [] Range'; + reeParseAtomTrailingBackSlash: Result := 'TRegExpr(comp): Parse Atom Trailing \'; + reeNoHexCodeAfterBSlashX: Result := 'TRegExpr(comp): No Hex Code After \x'; + reeHexCodeAfterBSlashXTooBig: Result := 'TRegExpr(comp): Hex Code After \x Is Too Big'; + reeUnmatchedSqBrackets: Result := 'TRegExpr(comp): Unmatched []'; + reeInternalUrp: Result := 'TRegExpr(comp): Internal Urp'; + reeQPSBFollowsNothing: Result := 'TRegExpr(comp): ?+*{ Follows Nothing'; + reeTrailingBackSlash: Result := 'TRegExpr(comp): Trailing \'; + reeRarseAtomInternalDisaster: Result := 'TRegExpr(comp): RarseAtom Internal Disaster'; + reeBRACESArgTooBig: Result := 'TRegExpr(comp): BRACES Argument Too Big'; + reeBracesMinParamGreaterMax: Result := 'TRegExpr(comp): BRACE Min Param Greater then Max'; + reeUnclosedComment: Result := 'TRegExpr(comp): Unclosed (?#Comment)'; + reeComplexBracesNotImplemented: Result := 'TRegExpr(comp): If you want take part in beta-testing BRACES ''{min,max}'' and non-greedy ops ''*?'', ''+?'', ''??'' for complex cases - remove ''.'' from {.$DEFINE ComplexBraces}'; + reeUrecognizedModifier: Result := 'TRegExpr(comp): Urecognized Modifier'; + reeBadLinePairedSeparator: Result := 'TRegExpr(comp): LinePairedSeparator must countain two different chars or no chars at all'; + + reeRegRepeatCalledInappropriately: Result := 'TRegExpr(exec): RegRepeat Called Inappropriately'; + reeMatchPrimMemoryCorruption: Result := 'TRegExpr(exec): MatchPrim Memory Corruption'; + reeMatchPrimCorruptedPointers: Result := 'TRegExpr(exec): MatchPrim Corrupted Pointers'; + reeNoExpression: Result := 'TRegExpr(exec): Not Assigned Expression Property'; + reeCorruptedProgram: Result := 'TRegExpr(exec): Corrupted Program'; + reeNoInpitStringSpecified: Result := 'TRegExpr(exec): No Input String Specified'; + reeOffsetMustBeGreaterThen0: Result := 'TRegExpr(exec): Offset Must Be Greater Then 0'; + reeExecNextWithoutExec: Result := 'TRegExpr(exec): ExecNext Without Exec[Pos]'; + reeGetInputStringWithoutInputString: Result := 'TRegExpr(exec): GetInputString Without InputString'; + reeDumpCorruptedOpcode: Result := 'TRegExpr(dump): Corrupted Opcode'; + reeLoopStackExceeded: Result := 'TRegExpr(exec): Loop Stack Exceeded'; + reeLoopWithoutEntry: Result := 'TRegExpr(exec): Loop Without LoopEntry !'; + + reeBadPCodeImported: Result := 'TRegExpr(misc): Bad p-code imported'; + else Result := 'Unknown error'; + end; + end; { of procedure TRegExpr.Error +--------------------------------------------------------------} + +function TRegExpr.LastError : integer; + begin + Result := fLastError; + fLastError := reeOk; + end; { of function TRegExpr.LastError +--------------------------------------------------------------} + + +{=============================================================} +{===================== Common section ========================} +{=============================================================} + +class function TRegExpr.VersionMajor : integer; //###0.944 + begin + Result := TRegExprVersionMajor; + end; { of class function TRegExpr.VersionMajor +--------------------------------------------------------------} + +class function TRegExpr.VersionMinor : integer; //###0.944 + begin + Result := TRegExprVersionMinor; + end; { of class function TRegExpr.VersionMinor +--------------------------------------------------------------} + +constructor TRegExpr.Create; + begin + inherited; + programm := nil; + fExpression := nil; + fInputString := nil; + + regexpbeg := nil; + fExprIsCompiled := false; + + ModifierI := RegExprModifierI; + ModifierR := RegExprModifierR; + ModifierS := RegExprModifierS; + ModifierG := RegExprModifierG; + ModifierM := RegExprModifierM; //###0.940 + + SpaceChars := RegExprSpaceChars; //###0.927 + WordChars := RegExprWordChars; //###0.929 + fInvertCase := RegExprInvertCaseFunction; //###0.927 + + fLineSeparators := RegExprLineSeparators; //###0.941 + LinePairedSeparator := RegExprLinePairedSeparator; //###0.941 + end; { of constructor TRegExpr.Create +--------------------------------------------------------------} + +destructor TRegExpr.Destroy; + begin + if programm <> nil + then FreeMem (programm); + if fExpression <> nil + then FreeMem (fExpression); + if fInputString <> nil + then FreeMem (fInputString); + end; { of destructor TRegExpr.Destroy +--------------------------------------------------------------} + +class function TRegExpr.InvertCaseFunction (const Ch : REChar) : REChar; + begin + {$IFDEF UniCode} + if Ch >= #128 + then Result := Ch + else + {$ENDIF} + begin + Result := {$IFDEF FPC}AnsiUpperCase (Ch) [1]{$ELSE} REChar (CharUpper (PChar (Ch))){$ENDIF}; + if Result = Ch + then Result := {$IFDEF FPC}AnsiLowerCase (Ch) [1]{$ELSE} REChar (CharLower (PChar (Ch))){$ENDIF}; + end; + end; { of function TRegExpr.InvertCaseFunction +--------------------------------------------------------------} + +function TRegExpr.GetExpression : RegExprString; + begin + if fExpression <> nil + then Result := fExpression + else Result := ''; + end; { of function TRegExpr.GetExpression +--------------------------------------------------------------} + +procedure TRegExpr.SetExpression (const s : RegExprString); + var + Len : integer; //###0.950 + begin + if (s <> fExpression) or not fExprIsCompiled then begin + fExprIsCompiled := false; + if fExpression <> nil then begin + FreeMem (fExpression); + fExpression := nil; + end; + if s <> '' then begin + Len := length (s); //###0.950 + GetMem (fExpression, (Len + 1) * SizeOf (REChar)); +// StrPCopy (fExpression, s); //###0.950 replaced due to StrPCopy limitation of 255 chars + {$IFDEF UniCode} + StrPCopy (fExpression, Copy (s, 1, Len)); //###0.950 + {$ELSE} + StrLCopy (fExpression, PRegExprChar (s), Len); //###0.950 + {$ENDIF UniCode} + + InvalidateProgramm; //###0.941 + end; + end; + end; { of procedure TRegExpr.SetExpression +--------------------------------------------------------------} + +function TRegExpr.GetSubExprMatchCount : integer; + begin + if Assigned (fInputString) then begin + Result := NSUBEXP - 1; + while (Result > 0) and ((startp [Result] = nil) + or (endp [Result] = nil)) + do dec (Result); + end + else Result := -1; + end; { of function TRegExpr.GetSubExprMatchCount +--------------------------------------------------------------} + +function TRegExpr.GetMatchPos (Idx : integer) : integer; + begin + if (Idx >= 0) and (Idx < NSUBEXP) and Assigned (fInputString) + and Assigned (startp [Idx]) and Assigned (endp [Idx]) then begin + Result := (startp [Idx] - fInputString) + 1; + end + else Result := -1; + end; { of function TRegExpr.GetMatchPos +--------------------------------------------------------------} + +function TRegExpr.GetMatchLen (Idx : integer) : integer; + begin + if (Idx >= 0) and (Idx < NSUBEXP) and Assigned (fInputString) + and Assigned (startp [Idx]) and Assigned (endp [Idx]) then begin + Result := endp [Idx] - startp [Idx]; + end + else Result := -1; + end; { of function TRegExpr.GetMatchLen +--------------------------------------------------------------} + +function TRegExpr.GetMatch (Idx : integer) : RegExprString; + begin + if (Idx >= 0) and (Idx < NSUBEXP) and Assigned (fInputString) + and Assigned (startp [Idx]) and Assigned (endp [Idx]) + //then Result := copy (fInputString, MatchPos [Idx], MatchLen [Idx]) //###0.929 + then SetString (Result, startp [idx], endp [idx] - startp [idx]) + else Result := ''; + end; { of function TRegExpr.GetMatch +--------------------------------------------------------------} + +function TRegExpr.GetModifierStr : RegExprString; + begin + Result := '-'; + + if ModifierI + then Result := 'i' + Result + else Result := Result + 'i'; + if ModifierR + then Result := 'r' + Result + else Result := Result + 'r'; + if ModifierS + then Result := 's' + Result + else Result := Result + 's'; + if ModifierG + then Result := 'g' + Result + else Result := Result + 'g'; + if ModifierM + then Result := 'm' + Result + else Result := Result + 'm'; + if ModifierX + then Result := 'x' + Result + else Result := Result + 'x'; + + if Result [length (Result)] = '-' // remove '-' if all modifiers are 'On' + then System.Delete (Result, length (Result), 1); + end; { of function TRegExpr.GetModifierStr +--------------------------------------------------------------} + +class function TRegExpr.ParseModifiersStr (const AModifiers : RegExprString; +var AModifiersInt : integer) : boolean; +// !!! Be carefull - this is class function and must not use object instance fields + var + i : integer; + IsOn : boolean; + Mask : integer; + begin + Result := true; + IsOn := true; + Mask := 0; // prevent compiler warning + for i := 1 to length (AModifiers) do + if AModifiers [i] = '-' + then IsOn := false + else begin + if Pos (AModifiers [i], 'iI') > 0 + then Mask := MaskModI + else if Pos (AModifiers [i], 'rR') > 0 + then Mask := MaskModR + else if Pos (AModifiers [i], 'sS') > 0 + then Mask := MaskModS + else if Pos (AModifiers [i], 'gG') > 0 + then Mask := MaskModG + else if Pos (AModifiers [i], 'mM') > 0 + then Mask := MaskModM + else if Pos (AModifiers [i], 'xX') > 0 + then Mask := MaskModX + else begin + Result := false; + EXIT; + end; + if IsOn + then AModifiersInt := AModifiersInt or Mask + else AModifiersInt := AModifiersInt and not Mask; + end; + end; { of function TRegExpr.ParseModifiersStr +--------------------------------------------------------------} + +procedure TRegExpr.SetModifierStr (const AModifiers : RegExprString); + begin + if not ParseModifiersStr (AModifiers, fModifiers) + then Error (reeModifierUnsupported); + end; { of procedure TRegExpr.SetModifierStr +--------------------------------------------------------------} + +function TRegExpr.GetModifier (AIndex : integer) : boolean; + var + Mask : integer; + begin + Result := false; + case AIndex of + 1: Mask := MaskModI; + 2: Mask := MaskModR; + 3: Mask := MaskModS; + 4: Mask := MaskModG; + 5: Mask := MaskModM; + 6: Mask := MaskModX; + else begin + Error (reeModifierUnsupported); + EXIT; + end; + end; + Result := (fModifiers and Mask) <> 0; + end; { of function TRegExpr.GetModifier +--------------------------------------------------------------} + +procedure TRegExpr.SetModifier (AIndex : integer; ASet : boolean); + var + Mask : integer; + begin + case AIndex of + 1: Mask := MaskModI; + 2: Mask := MaskModR; + 3: Mask := MaskModS; + 4: Mask := MaskModG; + 5: Mask := MaskModM; + 6: Mask := MaskModX; + else begin + Error (reeModifierUnsupported); + EXIT; + end; + end; + if ASet + then fModifiers := fModifiers or Mask + else fModifiers := fModifiers and not Mask; + end; { of procedure TRegExpr.SetModifier +--------------------------------------------------------------} + + +{=============================================================} +{==================== Compiler section =======================} +{=============================================================} + +procedure TRegExpr.InvalidateProgramm; + begin + if programm <> nil then begin + FreeMem (programm); + programm := nil; + end; + end; { of procedure TRegExpr.InvalidateProgramm +--------------------------------------------------------------} + +procedure TRegExpr.Compile; //###0.941 + begin + if fExpression = nil then begin // No Expression assigned + Error (reeNoExpression); + EXIT; + end; + CompileRegExpr (fExpression); + end; { of procedure TRegExpr.Compile +--------------------------------------------------------------} + +function TRegExpr.IsProgrammOk : boolean; + {$IFNDEF UniCode} + var + i : integer; + {$ENDIF} + begin + Result := false; + + // check modifiers + if fModifiers <> fProgModifiers //###0.941 + then InvalidateProgramm; + + // can we optimize line separators by using sets? + {$IFNDEF UniCode} + fLineSeparatorsSet := []; + for i := 1 to length (fLineSeparators) + do System.Include (fLineSeparatorsSet, fLineSeparators [i]); + {$ENDIF} + + // [Re]compile if needed + if programm = nil + then Compile; //###0.941 + + // check [re]compiled programm + if programm = nil + then EXIT // error was set/raised by Compile (was reeExecAfterCompErr) + else if programm [0] <> MAGIC // Program corrupted. + then Error (reeCorruptedProgram) + else Result := true; + end; { of function TRegExpr.IsProgrammOk +--------------------------------------------------------------} + +procedure TRegExpr.Tail (p : PRegExprChar; val : PRegExprChar); +// set the next-pointer at the end of a node chain + var + scan : PRegExprChar; + temp : PRegExprChar; +// i : int64; + begin + if p = @regdummy + then EXIT; + // Find last node. + scan := p; + REPEAT + temp := regnext (scan); + if temp = nil + then BREAK; + scan := temp; + UNTIL false; + // Set Next 'pointer' + if val < scan + then PRENextOff (scan + REOpSz)^ := - (scan - val) //###0.948 + // work around PWideChar subtraction bug (Delphi uses + // shr after subtraction to calculate widechar distance %-( ) + // so, if difference is negative we have .. the "feature" :( + // I could wrap it in $IFDEF UniCode, but I didn't because + // "P – Q computes the difference between the address given + // by P (the higher address) and the address given by Q (the + // lower address)" - Delphi help quotation. + else PRENextOff (scan + REOpSz)^ := val - scan; //###0.933 + end; { of procedure TRegExpr.Tail +--------------------------------------------------------------} + +procedure TRegExpr.OpTail (p : PRegExprChar; val : PRegExprChar); +// regtail on operand of first argument; nop if operandless + begin + // "Operandless" and "op != BRANCH" are synonymous in practice. + if (p = nil) or (p = @regdummy) or (PREOp (p)^ <> BRANCH) + then EXIT; + Tail (p + REOpSz + RENextOffSz, val); //###0.933 + end; { of procedure TRegExpr.OpTail +--------------------------------------------------------------} + +function TRegExpr.EmitNode (op : TREOp) : PRegExprChar; //###0.933 +// emit a node, return location + begin + Result := regcode; + if Result <> @regdummy then begin + PREOp (regcode)^ := op; + inc (regcode, REOpSz); + PRENextOff (regcode)^ := 0; // Next "pointer" := nil + inc (regcode, RENextOffSz); + end + else inc (regsize, REOpSz + RENextOffSz); // compute code size without code generation + end; { of function TRegExpr.EmitNode +--------------------------------------------------------------} + +procedure TRegExpr.EmitC (b : REChar); +// emit a byte to code + begin + if regcode <> @regdummy then begin + regcode^ := b; + inc (regcode); + end + else inc (regsize); // Type of p-code pointer always is ^REChar + end; { of procedure TRegExpr.EmitC +--------------------------------------------------------------} + +procedure TRegExpr.InsertOperator (op : TREOp; opnd : PRegExprChar; sz : integer); +// insert an operator in front of already-emitted operand +// Means relocating the operand. + var + src, dst, place : PRegExprChar; + i : integer; + begin + if regcode = @regdummy then begin + inc (regsize, sz); + EXIT; + end; + src := regcode; + inc (regcode, sz); + dst := regcode; + while src > opnd do begin + dec (dst); + dec (src); + dst^ := src^; + end; + place := opnd; // Op node, where operand used to be. + PREOp (place)^ := op; + inc (place, REOpSz); + for i := 1 + REOpSz to sz do begin + place^ := #0; + inc (place); + end; + end; { of procedure TRegExpr.InsertOperator +--------------------------------------------------------------} + +function strcspn (s1 : PRegExprChar; s2 : PRegExprChar) : integer; +// find length of initial segment of s1 consisting +// entirely of characters not from s2 + var scan1, scan2 : PRegExprChar; + begin + Result := 0; + scan1 := s1; + while scan1^ <> #0 do begin + scan2 := s2; + while scan2^ <> #0 do + if scan1^ = scan2^ + then EXIT + else inc (scan2); + inc (Result); + inc (scan1) + end; + end; { of function strcspn +--------------------------------------------------------------} + +const +// Flags to be passed up and down. + HASWIDTH = 01; // Known never to match nil string. + SIMPLE = 02; // Simple enough to be STAR/PLUS/BRACES operand. + SPSTART = 04; // Starts with * or +. + WORST = 0; // Worst case. + META : array [0 .. 12] of REChar = ( + '^', '$', '.', '[', '(', ')', '|', '?', '+', '*', EscChar, '{', #0); + // Any modification must be synchronized with QuoteRegExprMetaChars !!! + +{$IFDEF UniCode} + RusRangeLo : array [0 .. 33] of REChar = + (#$430,#$431,#$432,#$433,#$434,#$435,#$451,#$436,#$437, + #$438,#$439,#$43A,#$43B,#$43C,#$43D,#$43E,#$43F, + #$440,#$441,#$442,#$443,#$444,#$445,#$446,#$447, + #$448,#$449,#$44A,#$44B,#$44C,#$44D,#$44E,#$44F,#0); + RusRangeHi : array [0 .. 33] of REChar = + (#$410,#$411,#$412,#$413,#$414,#$415,#$401,#$416,#$417, + #$418,#$419,#$41A,#$41B,#$41C,#$41D,#$41E,#$41F, + #$420,#$421,#$422,#$423,#$424,#$425,#$426,#$427, + #$428,#$429,#$42A,#$42B,#$42C,#$42D,#$42E,#$42F,#0); + RusRangeLoLow = #$430{'à'}; + RusRangeLoHigh = #$44F{'ÿ'}; + RusRangeHiLow = #$410{'À'}; + RusRangeHiHigh = #$42F{'ß'}; +{$ELSE} + RusRangeLo = 'àáâãäå¸æçèéêëìíîïðñòóôõö÷øùúûüýþÿ'; + RusRangeHi = 'ÀÁÂÃÄŨÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞß'; + RusRangeLoLow = 'à'; + RusRangeLoHigh = 'ÿ'; + RusRangeHiLow = 'À'; + RusRangeHiHigh = 'ß'; +{$ENDIF} + +function TRegExpr.CompileRegExpr (exp : PRegExprChar) : boolean; +// compile a regular expression into internal code +// We can't allocate space until we know how big the compiled form will be, +// but we can't compile it (and thus know how big it is) until we've got a +// place to put the code. So we cheat: we compile it twice, once with code +// generation turned off and size counting turned on, and once "for real". +// This also means that we don't allocate space until we are sure that the +// thing really will compile successfully, and we never have to move the +// code and thus invalidate pointers into it. (Note that it has to be in +// one piece because free() must be able to free it all.) +// Beware that the optimization-preparation code in here knows about some +// of the structure of the compiled regexp. + var + scan, longest : PRegExprChar; + len : cardinal; + flags : integer; + begin + Result := false; // life too dark + + regparse := nil; // for correct error handling + regexpbeg := exp; + try + + if programm <> nil then begin + FreeMem (programm); + programm := nil; + end; + + if exp = nil then begin + Error (reeCompNullArgument); + EXIT; + end; + + fProgModifiers := fModifiers; + // well, may it's paranoia. I'll check it later... !!!!!!!! + + // First pass: determine size, legality. + fCompModifiers := fModifiers; + regparse := exp; + regnpar := 1; + regsize := 0; + regcode := @regdummy; + EmitC (MAGIC); + if ParseReg (0, flags) = nil + then EXIT; + + // Small enough for 2-bytes programm pointers ? + // ###0.933 no real p-code length limits now :))) +// if regsize >= 64 * 1024 then begin +// Error (reeCompRegexpTooBig); +// EXIT; +// end; + + // Allocate space. + GetMem (programm, regsize * SizeOf (REChar)); + + // Second pass: emit code. + fCompModifiers := fModifiers; + regparse := exp; + regnpar := 1; + regcode := programm; + EmitC (MAGIC); + if ParseReg (0, flags) = nil + then EXIT; + + // Dig out information for optimizations. + {$IFDEF UseFirstCharSet} //###0.929 + FirstCharSet := []; + FillFirstCharSet (programm + REOpSz); + {$ENDIF} + regstart := #0; // Worst-case defaults. + reganch := #0; + regmust := nil; + regmlen := 0; + scan := programm + REOpSz; // First BRANCH. + if PREOp (regnext (scan))^ = EEND then begin // Only one top-level choice. + scan := scan + REOpSz + RENextOffSz; + + // Starting-point info. + if PREOp (scan)^ = EXACTLY + then regstart := (scan + REOpSz + RENextOffSz)^ + else if PREOp (scan)^ = BOL + then inc (reganch); + + // If there's something expensive in the r.e., find the longest + // literal string that must appear and make it the regmust. Resolve + // ties in favor of later strings, since the regstart check works + // with the beginning of the r.e. and avoiding duplication + // strengthens checking. Not a strong reason, but sufficient in the + // absence of others. + if (flags and SPSTART) <> 0 then begin + longest := nil; + len := 0; + while scan <> nil do begin + if (PREOp (scan)^ = EXACTLY) + and (strlen (scan + REOpSz + RENextOffSz) >= len) then begin + longest := scan + REOpSz + RENextOffSz; + len := strlen (longest); + end; + scan := regnext (scan); + end; + regmust := longest; + regmlen := len; + end; + end; + + Result := true; + + finally begin + if not Result + then InvalidateProgramm; + regexpbeg := nil; + fExprIsCompiled := Result; //###0.944 + end; + end; + + end; { of function TRegExpr.CompileRegExpr +--------------------------------------------------------------} + +function TRegExpr.ParseReg (paren : integer; var flagp : integer) : PRegExprChar; +// regular expression, i.e. main body or parenthesized thing +// Caller must absorb opening parenthesis. +// Combining parenthesis handling with the base level of regular expression +// is a trifle forced, but the need to tie the tails of the branches to what +// follows makes it hard to avoid. + var + ret, br, ender : PRegExprChar; + parno : integer; + flags : integer; + SavedModifiers : integer; + begin + Result := nil; + flagp := HASWIDTH; // Tentatively. + parno := 0; // eliminate compiler stupid warning + SavedModifiers := fCompModifiers; + + // Make an OPEN node, if parenthesized. + if paren <> 0 then begin + if regnpar >= NSUBEXP then begin + Error (reeCompParseRegTooManyBrackets); + EXIT; + end; + parno := regnpar; + inc (regnpar); + ret := EmitNode (TREOp (ord (OPEN) + parno)); + end + else ret := nil; + + // Pick up the branches, linking them together. + br := ParseBranch (flags); + if br = nil then begin + Result := nil; + EXIT; + end; + if ret <> nil + then Tail (ret, br) // OPEN -> first. + else ret := br; + if (flags and HASWIDTH) = 0 + then flagp := flagp and not HASWIDTH; + flagp := flagp or flags and SPSTART; + while (regparse^ = '|') do begin + inc (regparse); + br := ParseBranch (flags); + if br = nil then begin + Result := nil; + EXIT; + end; + Tail (ret, br); // BRANCH -> BRANCH. + if (flags and HASWIDTH) = 0 + then flagp := flagp and not HASWIDTH; + flagp := flagp or flags and SPSTART; + end; + + // Make a closing node, and hook it on the end. + if paren <> 0 + then ender := EmitNode (TREOp (ord (CLOSE) + parno)) + else ender := EmitNode (EEND); + Tail (ret, ender); + + // Hook the tails of the branches to the closing node. + br := ret; + while br <> nil do begin + OpTail (br, ender); + br := regnext (br); + end; + + // Check for proper termination. + if paren <> 0 then + if regparse^ <> ')' then begin + Error (reeCompParseRegUnmatchedBrackets); + EXIT; + end + else inc (regparse); // skip trailing ')' + if (paren = 0) and (regparse^ <> #0) then begin + if regparse^ = ')' + then Error (reeCompParseRegUnmatchedBrackets2) + else Error (reeCompParseRegJunkOnEnd); + EXIT; + end; + fCompModifiers := SavedModifiers; // restore modifiers of parent + Result := ret; + end; { of function TRegExpr.ParseReg +--------------------------------------------------------------} + +function TRegExpr.ParseBranch (var flagp : integer) : PRegExprChar; +// one alternative of an | operator +// Implements the concatenation operator. + var + ret, chain, latest : PRegExprChar; + flags : integer; + begin + flagp := WORST; // Tentatively. + + ret := EmitNode (BRANCH); + chain := nil; + while (regparse^ <> #0) and (regparse^ <> '|') + and (regparse^ <> ')') do begin + latest := ParsePiece (flags); + if latest = nil then begin + Result := nil; + EXIT; + end; + flagp := flagp or flags and HASWIDTH; + if chain = nil // First piece. + then flagp := flagp or flags and SPSTART + else Tail (chain, latest); + chain := latest; + end; + if chain = nil // Loop ran zero times. + then EmitNode (NOTHING); + Result := ret; + end; { of function TRegExpr.ParseBranch +--------------------------------------------------------------} + +function TRegExpr.ParsePiece (var flagp : integer) : PRegExprChar; +// something followed by possible [*+?{] +// Note that the branching code sequences used for ? and the general cases +// of * and + and { are somewhat optimized: they use the same NOTHING node as +// both the endmarker for their branch list and the body of the last branch. +// It might seem that this node could be dispensed with entirely, but the +// endmarker role is not redundant. + function parsenum (AStart, AEnd : PRegExprChar) : TREBracesArg; + begin + Result := 0; + if AEnd - AStart + 1 > 8 then begin // prevent stupid scanning + Error (reeBRACESArgTooBig); + EXIT; + end; + while AStart <= AEnd do begin + Result := Result * 10 + (ord (AStart^) - ord ('0')); + inc (AStart); + end; + if (Result > MaxBracesArg) or (Result < 0) then begin + Error (reeBRACESArgTooBig); + EXIT; + end; + end; + + var + op : REChar; + NonGreedyOp, NonGreedyCh : boolean; //###0.940 + TheOp : TREOp; //###0.940 + NextNode : PRegExprChar; + flags : integer; + BracesMin, Bracesmax : TREBracesArg; + p, savedparse : PRegExprChar; + + procedure EmitComplexBraces (ABracesMin, ABracesMax : TREBracesArg; + ANonGreedyOp : boolean); //###0.940 + {$IFDEF ComplexBraces} + var + off : integer; + {$ENDIF} + begin + {$IFNDEF ComplexBraces} + Error (reeComplexBracesNotImplemented); + {$ELSE} + if ANonGreedyOp + then TheOp := LOOPNG + else TheOp := LOOP; + InsertOperator (LOOPENTRY, Result, REOpSz + RENextOffSz); + NextNode := EmitNode (TheOp); + if regcode <> @regdummy then begin + off := (Result + REOpSz + RENextOffSz) + - (regcode - REOpSz - RENextOffSz); // back to Atom after LOOPENTRY + PREBracesArg (regcode)^ := ABracesMin; + inc (regcode, REBracesArgSz); + PREBracesArg (regcode)^ := ABracesMax; + inc (regcode, REBracesArgSz); + PRENextOff (regcode)^ := off; + inc (regcode, RENextOffSz); + end + else inc (regsize, REBracesArgSz * 2 + RENextOffSz); + Tail (Result, NextNode); // LOOPENTRY -> LOOP + if regcode <> @regdummy then + Tail (Result + REOpSz + RENextOffSz, NextNode); // Atom -> LOOP + {$ENDIF} + end; + + procedure EmitSimpleBraces (ABracesMin, ABracesMax : TREBracesArg; + ANonGreedyOp : boolean); //###0.940 + begin + if ANonGreedyOp //###0.940 + then TheOp := BRACESNG + else TheOp := BRACES; + InsertOperator (TheOp, Result, REOpSz + RENextOffSz + REBracesArgSz * 2); + if regcode <> @regdummy then begin + PREBracesArg (Result + REOpSz + RENextOffSz)^ := ABracesMin; + PREBracesArg (Result + REOpSz + RENextOffSz + REBracesArgSz)^ := ABracesMax; + end; + end; + + begin + Result := ParseAtom (flags); + if Result = nil + then EXIT; + + op := regparse^; + if not ((op = '*') or (op = '+') or (op = '?') or (op = '{')) then begin + flagp := flags; + EXIT; + end; + if ((flags and HASWIDTH) = 0) and (op <> '?') then begin + Error (reePlusStarOperandCouldBeEmpty); + EXIT; + end; + + case op of + '*': begin + flagp := WORST or SPSTART; + NonGreedyCh := (regparse + 1)^ = '?'; //###0.940 + NonGreedyOp := NonGreedyCh or ((fCompModifiers and MaskModG) = 0); //###0.940 + if (flags and SIMPLE) = 0 then begin + if NonGreedyOp //###0.940 + then EmitComplexBraces (0, MaxBracesArg, NonGreedyOp) + else begin // Emit x* as (x&|), where & means "self". + InsertOperator (BRANCH, Result, REOpSz + RENextOffSz); // Either x + OpTail (Result, EmitNode (BACK)); // and loop + OpTail (Result, Result); // back + Tail (Result, EmitNode (BRANCH)); // or + Tail (Result, EmitNode (NOTHING)); // nil. + end + end + else begin // Simple + if NonGreedyOp //###0.940 + then TheOp := STARNG + else TheOp := STAR; + InsertOperator (TheOp, Result, REOpSz + RENextOffSz); + end; + if NonGreedyCh //###0.940 + then inc (regparse); // Skip extra char ('?') + end; { of case '*'} + '+': begin + flagp := WORST or SPSTART or HASWIDTH; + NonGreedyCh := (regparse + 1)^ = '?'; //###0.940 + NonGreedyOp := NonGreedyCh or ((fCompModifiers and MaskModG) = 0); //###0.940 + if (flags and SIMPLE) = 0 then begin + if NonGreedyOp //###0.940 + then EmitComplexBraces (1, MaxBracesArg, NonGreedyOp) + else begin // Emit x+ as x(&|), where & means "self". + NextNode := EmitNode (BRANCH); // Either + Tail (Result, NextNode); + Tail (EmitNode (BACK), Result); // loop back + Tail (NextNode, EmitNode (BRANCH)); // or + Tail (Result, EmitNode (NOTHING)); // nil. + end + end + else begin // Simple + if NonGreedyOp //###0.940 + then TheOp := PLUSNG + else TheOp := PLUS; + InsertOperator (TheOp, Result, REOpSz + RENextOffSz); + end; + if NonGreedyCh //###0.940 + then inc (regparse); // Skip extra char ('?') + end; { of case '+'} + '?': begin + flagp := WORST; + NonGreedyCh := (regparse + 1)^ = '?'; //###0.940 + NonGreedyOp := NonGreedyCh or ((fCompModifiers and MaskModG) = 0); //###0.940 + if NonGreedyOp then begin //###0.940 // We emit x?? as x{0,1}? + if (flags and SIMPLE) = 0 + then EmitComplexBraces (0, 1, NonGreedyOp) + else EmitSimpleBraces (0, 1, NonGreedyOp); + end + else begin // greedy '?' + InsertOperator (BRANCH, Result, REOpSz + RENextOffSz); // Either x + Tail (Result, EmitNode (BRANCH)); // or + NextNode := EmitNode (NOTHING); // nil. + Tail (Result, NextNode); + OpTail (Result, NextNode); + end; + if NonGreedyCh //###0.940 + then inc (regparse); // Skip extra char ('?') + end; { of case '?'} + '{': begin + savedparse := regparse; + // !!!!!!!!!!!! + // Filip Jirsak's note - what will happen, when we are at the end of regparse? + inc (regparse); + p := regparse; + while Pos (regparse^, '0123456789') > 0 // MUST appear + do inc (regparse); + if (regparse^ <> '}') and (regparse^ <> ',') or (p = regparse) then begin + regparse := savedparse; + flagp := flags; + EXIT; + end; + BracesMin := parsenum (p, regparse - 1); + if regparse^ = ',' then begin + inc (regparse); + p := regparse; + while Pos (regparse^, '0123456789') > 0 + do inc (regparse); + if regparse^ <> '}' then begin + regparse := savedparse; + EXIT; + end; + if p = regparse + then BracesMax := MaxBracesArg + else BracesMax := parsenum (p, regparse - 1); + end + else BracesMax := BracesMin; // {n} == {n,n} + if BracesMin > BracesMax then begin + Error (reeBracesMinParamGreaterMax); + EXIT; + end; + if BracesMin > 0 + then flagp := WORST; + if BracesMax > 0 + then flagp := flagp or HASWIDTH or SPSTART; + + NonGreedyCh := (regparse + 1)^ = '?'; //###0.940 + NonGreedyOp := NonGreedyCh or ((fCompModifiers and MaskModG) = 0); //###0.940 + if (flags and SIMPLE) <> 0 + then EmitSimpleBraces (BracesMin, BracesMax, NonGreedyOp) + else EmitComplexBraces (BracesMin, BracesMax, NonGreedyOp); + if NonGreedyCh //###0.940 + then inc (regparse); // Skip extra char '?' + end; { of case '{'} +// else // here we can't be + end; { of case op} + + inc (regparse); + if (regparse^ = '*') or (regparse^ = '+') or (regparse^ = '?') or (regparse^ = '{') then begin + Error (reeNestedSQP); + EXIT; + end; + end; { of function TRegExpr.ParsePiece +--------------------------------------------------------------} + +function TRegExpr.ParseAtom (var flagp : integer) : PRegExprChar; +// the lowest level +// Optimization: gobbles an entire sequence of ordinary characters so that +// it can turn them into a single node, which is smaller to store and +// faster to run. Backslashed characters are exceptions, each becoming a +// separate node; the code is simpler that way and it's not worth fixing. + var + ret : PRegExprChar; + flags : integer; + RangeBeg, RangeEnd : REChar; + CanBeRange : boolean; + len : integer; + ender : REChar; + begmodfs : PRegExprChar; + + {$IFDEF UseSetOfChar} //###0.930 + RangePCodeBeg : PRegExprChar; + RangePCodeIdx : integer; + RangeIsCI : boolean; + RangeSet : TSetOfREChar; + RangeLen : integer; + RangeChMin, RangeChMax : REChar; + {$ENDIF} + + procedure EmitExactly (ch : REChar); + begin + if (fCompModifiers and MaskModI) <> 0 + then ret := EmitNode (EXACTLYCI) + else ret := EmitNode (EXACTLY); + EmitC (ch); + EmitC (#0); + flagp := flagp or HASWIDTH or SIMPLE; + end; + + procedure EmitStr (const s : RegExprString); + var i : integer; + begin + for i := 1 to length (s) + do EmitC (s [i]); + end; + + function HexDig (ch : REChar) : integer; + begin + Result := 0; + if (ch >= 'a') and (ch <= 'f') + then ch := REChar (ord (ch) - (ord ('a') - ord ('A'))); + if (ch < '0') or (ch > 'F') or ((ch > '9') and (ch < 'A')) then begin + Error (reeBadHexDigit); + EXIT; + end; + Result := ord (ch) - ord ('0'); + if ch >= 'A' + then Result := Result - (ord ('A') - ord ('9') - 1); + end; + + function EmitRange (AOpCode : REChar) : PRegExprChar; + begin + {$IFDEF UseSetOfChar} + case AOpCode of + ANYBUTCI, ANYBUT: + Result := EmitNode (ANYBUTTINYSET); + else // ANYOFCI, ANYOF + Result := EmitNode (ANYOFTINYSET); + end; + case AOpCode of + ANYBUTCI, ANYOFCI: + RangeIsCI := True; + else // ANYBUT, ANYOF + RangeIsCI := False; + end; + RangePCodeBeg := regcode; + RangePCodeIdx := regsize; + RangeLen := 0; + RangeSet := []; + RangeChMin := #255; + RangeChMax := #0; + {$ELSE} + Result := EmitNode (AOpCode); + // ToDo: + // !!!!!!!!!!!!! Implement ANYOF[BUT]TINYSET generation for UniCode !!!!!!!!!! + {$ENDIF} + end; + +{$IFDEF UseSetOfChar} + procedure EmitRangeCPrim (b : REChar); //###0.930 + begin + if b in RangeSet + then EXIT; + inc (RangeLen); + if b < RangeChMin + then RangeChMin := b; + if b > RangeChMax + then RangeChMax := b; + Include (RangeSet, b); + end; + {$ENDIF} + + procedure EmitRangeC (b : REChar); + {$IFDEF UseSetOfChar} + var + Ch : REChar; + {$ENDIF} + begin + CanBeRange := false; + {$IFDEF UseSetOfChar} + if b <> #0 then begin + EmitRangeCPrim (b); //###0.930 + if RangeIsCI + then EmitRangeCPrim (InvertCase (b)); //###0.930 + end + else begin + {$IFDEF UseAsserts} + Assert (RangeLen > 0, 'TRegExpr.ParseAtom(subroutine EmitRangeC): empty range'); // impossible, but who knows.. + Assert (RangeChMin <= RangeChMax, 'TRegExpr.ParseAtom(subroutine EmitRangeC): RangeChMin > RangeChMax'); // impossible, but who knows.. + {$ENDIF} + if RangeLen <= TinySetLen then begin // emit "tiny set" + if regcode = @regdummy then begin + regsize := RangePCodeIdx + TinySetLen; // RangeChMin/Max !!! + EXIT; + end; + regcode := RangePCodeBeg; + for Ch := RangeChMin to RangeChMax do //###0.930 + if Ch in RangeSet then begin + regcode^ := Ch; + inc (regcode); + end; + // fill rest: + while regcode < RangePCodeBeg + TinySetLen do begin + regcode^ := RangeChMax; + inc (regcode); + end; + end + else begin + if regcode = @regdummy then begin + regsize := RangePCodeIdx + SizeOf (TSetOfREChar); + EXIT; + end; + if (RangePCodeBeg - REOpSz - RENextOffSz)^ = ANYBUTTINYSET + then RangeSet := [#0 .. #255] - RangeSet; + PREOp (RangePCodeBeg - REOpSz - RENextOffSz)^ := ANYOFFULLSET; + regcode := RangePCodeBeg; + Move (RangeSet, regcode^, SizeOf (TSetOfREChar)); + inc (regcode, SizeOf (TSetOfREChar)); + end; + end; + {$ELSE} + EmitC (b); + {$ENDIF} + end; + + procedure EmitSimpleRangeC (b : REChar); + begin + RangeBeg := b; + EmitRangeC (b); + CanBeRange := true; + end; + + procedure EmitRangeStr (const s : RegExprString); + var i : integer; + begin + for i := 1 to length (s) + do EmitRangeC (s [i]); + end; + + function UnQuoteChar (var APtr : PRegExprChar) : REChar; //###0.934 + begin + case APtr^ of + 't': Result := #$9; // tab (HT/TAB) + 'n': Result := #$a; // newline (NL) + 'r': Result := #$d; // car.return (CR) + 'f': Result := #$c; // form feed (FF) + 'a': Result := #$7; // alarm (bell) (BEL) + 'e': Result := #$1b; // escape (ESC) + 'x': begin // hex char + Result := #0; + inc (APtr); + if APtr^ = #0 then begin + Error (reeNoHexCodeAfterBSlashX); + EXIT; + end; + if APtr^ = '{' then begin // \x{nnnn} //###0.936 + REPEAT + inc (APtr); + if APtr^ = #0 then begin + Error (reeNoHexCodeAfterBSlashX); + EXIT; + end; + if APtr^ <> '}' then begin + if (Ord (Result) + ShR (SizeOf (REChar) * 8 - 4)) and $F <> 0 then begin + Error (reeHexCodeAfterBSlashXTooBig); + EXIT; + end; + Result := REChar ((Ord (Result) ShL 4) or HexDig (APtr^)); + // HexDig will cause Error if bad hex digit found + end + else BREAK; + UNTIL False; + end + else begin + Result := REChar (HexDig (APtr^)); + // HexDig will cause Error if bad hex digit found + inc (APtr); + if APtr^ = #0 then begin + Error (reeNoHexCodeAfterBSlashX); + EXIT; + end; + Result := REChar ((Ord (Result) ShL 4) or HexDig (APtr^)); + // HexDig will cause Error if bad hex digit found + end; + end; + else Result := APtr^; + end; + end; + + begin + Result := nil; + flagp := WORST; // Tentatively. + + inc (regparse); + case (regparse - 1)^ of + '^': if ((fCompModifiers and MaskModM) = 0) + or ((fLineSeparators = '') and not fLinePairedSeparatorAssigned) + then ret := EmitNode (BOL) + else ret := EmitNode (BOLML); + '$': if ((fCompModifiers and MaskModM) = 0) + or ((fLineSeparators = '') and not fLinePairedSeparatorAssigned) + then ret := EmitNode (EOL) + else ret := EmitNode (EOLML); + '.': + if (fCompModifiers and MaskModS) <> 0 then begin + ret := EmitNode (ANY); + flagp := flagp or HASWIDTH or SIMPLE; + end + else begin // not /s, so emit [^:LineSeparators:] + ret := EmitNode (ANYML); + flagp := flagp or HASWIDTH; // not so simple ;) +// ret := EmitRange (ANYBUT); +// EmitRangeStr (LineSeparators); //###0.941 +// EmitRangeStr (LinePairedSeparator); // !!! isn't correct if have to accept only paired +// EmitRangeC (#0); +// flagp := flagp or HASWIDTH or SIMPLE; + end; + '[': begin + if regparse^ = '^' then begin // Complement of range. + if (fCompModifiers and MaskModI) <> 0 + then ret := EmitRange (ANYBUTCI) + else ret := EmitRange (ANYBUT); + inc (regparse); + end + else + if (fCompModifiers and MaskModI) <> 0 + then ret := EmitRange (ANYOFCI) + else ret := EmitRange (ANYOF); + + CanBeRange := false; + + if (regparse^ = ']') then begin + EmitSimpleRangeC (regparse^); // []-a] -> ']' .. 'a' + inc (regparse); + end; + + while (regparse^ <> #0) and (regparse^ <> ']') do begin + if (regparse^ = '-') + and ((regparse + 1)^ <> #0) and ((regparse + 1)^ <> ']') + and CanBeRange then begin + inc (regparse); + RangeEnd := regparse^; + if RangeEnd = EscChar then begin + {$IFDEF UniCode} //###0.935 + if (ord ((regparse + 1)^) < 256) + and (char ((regparse + 1)^) + in ['d', 'D', 's', 'S', 'w', 'W']) then begin + {$ELSE} + if (regparse + 1)^ in ['d', 'D', 's', 'S', 'w', 'W'] then begin + {$ENDIF} + EmitRangeC ('-'); // or treat as error ?!! + CONTINUE; + end; + inc (regparse); + RangeEnd := UnQuoteChar (regparse); + end; + + // r.e.ranges extension for russian + if ((fCompModifiers and MaskModR) <> 0) + and (RangeBeg = RusRangeLoLow) and (RangeEnd = RusRangeLoHigh) then begin + EmitRangeStr (RusRangeLo); + end + else if ((fCompModifiers and MaskModR) <> 0) + and (RangeBeg = RusRangeHiLow) and (RangeEnd = RusRangeHiHigh) then begin + EmitRangeStr (RusRangeHi); + end + else if ((fCompModifiers and MaskModR) <> 0) + and (RangeBeg = RusRangeLoLow) and (RangeEnd = RusRangeHiHigh) then begin + EmitRangeStr (RusRangeLo); + EmitRangeStr (RusRangeHi); + end + else begin // standard r.e. handling + if RangeBeg > RangeEnd then begin + Error (reeInvalidRange); + EXIT; + end; + inc (RangeBeg); + EmitRangeC (RangeEnd); // prevent infinite loop if RangeEnd=$ff + while RangeBeg < RangeEnd do begin //###0.929 + EmitRangeC (RangeBeg); + inc (RangeBeg); + end; + end; + inc (regparse); + end + else begin + if regparse^ = EscChar then begin + inc (regparse); + if regparse^ = #0 then begin + Error (reeParseAtomTrailingBackSlash); + EXIT; + end; + case regparse^ of // r.e.extensions + 'd': EmitRangeStr ('0123456789'); + 'w': EmitRangeStr (WordChars); + 's': EmitRangeStr (SpaceChars); + else EmitSimpleRangeC (UnQuoteChar (regparse)); + end; { of case} + end + else EmitSimpleRangeC (regparse^); + inc (regparse); + end; + end; { of while} + EmitRangeC (#0); + if regparse^ <> ']' then begin + Error (reeUnmatchedSqBrackets); + EXIT; + end; + inc (regparse); + flagp := flagp or HASWIDTH or SIMPLE; + end; + '(': begin + if regparse^ = '?' then begin + // check for extended Perl syntax : (?..) + if (regparse + 1)^ = '#' then begin // (?#comment) + inc (regparse, 2); // find closing ')' + while (regparse^ <> #0) and (regparse^ <> ')') + do inc (regparse); + if regparse^ <> ')' then begin + Error (reeUnclosedComment); + EXIT; + end; + inc (regparse); // skip ')' + ret := EmitNode (COMMENT); // comment + end + else begin // modifiers ? + inc (regparse); // skip '?' + begmodfs := regparse; + while (regparse^ <> #0) and (regparse^ <> ')') + do inc (regparse); + if (regparse^ <> ')') + or not ParseModifiersStr (copy (begmodfs, 1, (regparse - begmodfs)), fCompModifiers) then begin + Error (reeUrecognizedModifier); + EXIT; + end; + inc (regparse); // skip ')' + ret := EmitNode (COMMENT); // comment +// Error (reeQPSBFollowsNothing); +// EXIT; + end; + end + else begin + ret := ParseReg (1, flags); + if ret = nil then begin + Result := nil; + EXIT; + end; + flagp := flagp or flags and (HASWIDTH or SPSTART); + end; + end; + #0, '|', ')': begin // Supposed to be caught earlier. + Error (reeInternalUrp); + EXIT; + end; + '?', '+', '*': begin + Error (reeQPSBFollowsNothing); + EXIT; + end; + EscChar: begin + if regparse^ = #0 then begin + Error (reeTrailingBackSlash); + EXIT; + end; + case regparse^ of // r.e.extensions + 'b': ret := EmitNode (BOUND); //###0.943 + 'B': ret := EmitNode (NOTBOUND); //###0.943 + 'A': ret := EmitNode (BOL); //###0.941 + 'Z': ret := EmitNode (EOL); //###0.941 + 'd': begin // r.e.extension - any digit ('0' .. '9') + ret := EmitNode (ANYDIGIT); + flagp := flagp or HASWIDTH or SIMPLE; + end; + 'D': begin // r.e.extension - not digit ('0' .. '9') + ret := EmitNode (NOTDIGIT); + flagp := flagp or HASWIDTH or SIMPLE; + end; + 's': begin // r.e.extension - any space char + {$IFDEF UseSetOfChar} + ret := EmitRange (ANYOF); + EmitRangeStr (SpaceChars); + EmitRangeC (#0); + {$ELSE} + ret := EmitNode (ANYSPACE); + {$ENDIF} + flagp := flagp or HASWIDTH or SIMPLE; + end; + 'S': begin // r.e.extension - not space char + {$IFDEF UseSetOfChar} + ret := EmitRange (ANYBUT); + EmitRangeStr (SpaceChars); + EmitRangeC (#0); + {$ELSE} + ret := EmitNode (NOTSPACE); + {$ENDIF} + flagp := flagp or HASWIDTH or SIMPLE; + end; + 'w': begin // r.e.extension - any english char / digit / '_' + {$IFDEF UseSetOfChar} + ret := EmitRange (ANYOF); + EmitRangeStr (WordChars); + EmitRangeC (#0); + {$ELSE} + ret := EmitNode (ANYLETTER); + {$ENDIF} + flagp := flagp or HASWIDTH or SIMPLE; + end; + 'W': begin // r.e.extension - not english char / digit / '_' + {$IFDEF UseSetOfChar} + ret := EmitRange (ANYBUT); + EmitRangeStr (WordChars); + EmitRangeC (#0); + {$ELSE} + ret := EmitNode (NOTLETTER); + {$ENDIF} + flagp := flagp or HASWIDTH or SIMPLE; + end; + '1' .. '9': begin //###0.936 + if (fCompModifiers and MaskModI) <> 0 + then ret := EmitNode (BSUBEXPCI) + else ret := EmitNode (BSUBEXP); + EmitC (REChar (ord (regparse^) - ord ('0'))); + flagp := flagp or HASWIDTH or SIMPLE; + end; + else EmitExactly (UnQuoteChar (regparse)); + end; { of case} + inc (regparse); + end; + else begin + dec (regparse); + if ((fCompModifiers and MaskModX) <> 0) and // check for eXtended syntax + ((regparse^ = '#') + or ({$IFDEF UniCode}StrScan (XIgnoredChars, regparse^) <> nil //###0.947 + {$ELSE}regparse^ in XIgnoredChars{$ENDIF})) then begin //###0.941 \x + if regparse^ = '#' then begin // Skip eXtended comment + // find comment terminator (group of \n and/or \r) + while (regparse^ <> #0) and (regparse^ <> #$d) and (regparse^ <> #$a) + do inc (regparse); + while (regparse^ = #$d) or (regparse^ = #$a) // skip comment terminator + do inc (regparse); // attempt to support different type of line separators + end + else begin // Skip the blanks! + while {$IFDEF UniCode}StrScan (XIgnoredChars, regparse^) <> nil //###0.947 + {$ELSE}regparse^ in XIgnoredChars{$ENDIF} + do inc (regparse); + end; + ret := EmitNode (COMMENT); // comment + end + else begin + len := strcspn (regparse, META); + if len <= 0 then + if regparse^ <> '{' then begin + Error (reeRarseAtomInternalDisaster); + EXIT; + end + else len := strcspn (regparse + 1, META) + 1; // bad {n,m} - compile as EXATLY + ender := (regparse + len)^; + if (len > 1) + and ((ender = '*') or (ender = '+') or (ender = '?') or (ender = '{')) + then dec (len); // Back off clear of ?+*{ operand. + flagp := flagp or HASWIDTH; + if len = 1 + then flagp := flagp or SIMPLE; + if (fCompModifiers and MaskModI) <> 0 + then ret := EmitNode (EXACTLYCI) + else ret := EmitNode (EXACTLY); + while (len > 0) + and (((fCompModifiers and MaskModX) = 0) or (regparse^ <> '#')) do begin + if ((fCompModifiers and MaskModX) = 0) or not ( //###0.941 + {$IFDEF UniCode}StrScan (XIgnoredChars, regparse^) <> nil //###0.947 + {$ELSE}regparse^ in XIgnoredChars{$ENDIF} ) + then EmitC (regparse^); + inc (regparse); + dec (len); + end; + EmitC (#0); + end; { of if not comment} + end; { of case else} + end; { of case} + + Result := ret; + end; { of function TRegExpr.ParseAtom +--------------------------------------------------------------} + +function TRegExpr.GetCompilerErrorPos : integer; + begin + Result := 0; + if (regexpbeg = nil) or (regparse = nil) + then EXIT; // not in compiling mode ? + Result := regparse - regexpbeg; + end; { of function TRegExpr.GetCompilerErrorPos +--------------------------------------------------------------} + + +{=============================================================} +{===================== Matching section ======================} +{=============================================================} + +{$IFNDEF UseSetOfChar} +function TRegExpr.StrScanCI (s : PRegExprChar; ch : REChar) : PRegExprChar; //###0.928 - now method of TRegExpr + begin + while (s^ <> #0) and (s^ <> ch) and (s^ <> InvertCase (ch)) + do inc (s); + if s^ <> #0 + then Result := s + else Result := nil; + end; { of function TRegExpr.StrScanCI +--------------------------------------------------------------} +{$ENDIF} + +function TRegExpr.regrepeat (p : PRegExprChar; AMax : integer) : integer; +// repeatedly match something simple, report how many + var + scan : PRegExprChar; + opnd : PRegExprChar; + TheMax : integer; + {Ch,} InvCh : REChar; //###0.931 + sestart, seend : PRegExprChar; //###0.936 + begin + Result := 0; + scan := reginput; + opnd := p + REOpSz + RENextOffSz; //OPERAND + TheMax := fInputEnd - scan; + if TheMax > AMax + then TheMax := AMax; + case PREOp (p)^ of + ANY: begin + // note - ANYML cannot be proceeded in regrepeat because can skip + // more than one char at once + Result := TheMax; + inc (scan, Result); + end; + EXACTLY: begin // in opnd can be only ONE char !!! +// Ch := opnd^; // store in register //###0.931 + while (Result < TheMax) and (opnd^ = scan^) do begin + inc (Result); + inc (scan); + end; + end; + EXACTLYCI: begin // in opnd can be only ONE char !!! +// Ch := opnd^; // store in register //###0.931 + while (Result < TheMax) and (opnd^ = scan^) do begin // prevent unneeded InvertCase //###0.931 + inc (Result); + inc (scan); + end; + if Result < TheMax then begin //###0.931 + InvCh := InvertCase (opnd^); // store in register + while (Result < TheMax) and + ((opnd^ = scan^) or (InvCh = scan^)) do begin + inc (Result); + inc (scan); + end; + end; + end; + BSUBEXP: begin //###0.936 + sestart := startp [ord (opnd^)]; + if sestart = nil + then EXIT; + seend := endp [ord (opnd^)]; + if seend = nil + then EXIT; + REPEAT + opnd := sestart; + while opnd < seend do begin + if (scan >= fInputEnd) or (scan^ <> opnd^) + then EXIT; + inc (scan); + inc (opnd); + end; + inc (Result); + reginput := scan; + UNTIL Result >= AMax; + end; + BSUBEXPCI: begin //###0.936 + sestart := startp [ord (opnd^)]; + if sestart = nil + then EXIT; + seend := endp [ord (opnd^)]; + if seend = nil + then EXIT; + REPEAT + opnd := sestart; + while opnd < seend do begin + if (scan >= fInputEnd) or + ((scan^ <> opnd^) and (scan^ <> InvertCase (opnd^))) + then EXIT; + inc (scan); + inc (opnd); + end; + inc (Result); + reginput := scan; + UNTIL Result >= AMax; + end; + ANYDIGIT: + while (Result < TheMax) and + (scan^ >= '0') and (scan^ <= '9') do begin + inc (Result); + inc (scan); + end; + NOTDIGIT: + while (Result < TheMax) and + ((scan^ < '0') or (scan^ > '9')) do begin + inc (Result); + inc (scan); + end; + {$IFNDEF UseSetOfChar} //###0.929 + ANYLETTER: + while (Result < TheMax) and + (Pos (scan^, fWordChars) > 0) //###0.940 + { ((scan^ >= 'a') and (scan^ <= 'z') !! I've forgotten (>='0') and (<='9') + or (scan^ >= 'A') and (scan^ <= 'Z') or (scan^ = '_'))} do begin + inc (Result); + inc (scan); + end; + NOTLETTER: + while (Result < TheMax) and + (Pos (scan^, fWordChars) <= 0) //###0.940 + { not ((scan^ >= 'a') and (scan^ <= 'z') !! I've forgotten (>='0') and (<='9') + or (scan^ >= 'A') and (scan^ <= 'Z') + or (scan^ = '_'))} do begin + inc (Result); + inc (scan); + end; + ANYSPACE: + while (Result < TheMax) and + (Pos (scan^, fSpaceChars) > 0) do begin + inc (Result); + inc (scan); + end; + NOTSPACE: + while (Result < TheMax) and + (Pos (scan^, fSpaceChars) <= 0) do begin + inc (Result); + inc (scan); + end; + {$ENDIF} + ANYOFTINYSET: begin + while (Result < TheMax) and //!!!TinySet + ((scan^ = opnd^) or (scan^ = (opnd + 1)^) + or (scan^ = (opnd + 2)^)) do begin + inc (Result); + inc (scan); + end; + end; + ANYBUTTINYSET: begin + while (Result < TheMax) and //!!!TinySet + (scan^ <> opnd^) and (scan^ <> (opnd + 1)^) + and (scan^ <> (opnd + 2)^) do begin + inc (Result); + inc (scan); + end; + end; + {$IFDEF UseSetOfChar} //###0.929 + ANYOFFULLSET: begin + while (Result < TheMax) and + (scan^ in PSetOfREChar (opnd)^) do begin + inc (Result); + inc (scan); + end; + end; + {$ELSE} + ANYOF: + while (Result < TheMax) and + (StrScan (opnd, scan^) <> nil) do begin + inc (Result); + inc (scan); + end; + ANYBUT: + while (Result < TheMax) and + (StrScan (opnd, scan^) = nil) do begin + inc (Result); + inc (scan); + end; + ANYOFCI: + while (Result < TheMax) and (StrScanCI (opnd, scan^) <> nil) do begin + inc (Result); + inc (scan); + end; + ANYBUTCI: + while (Result < TheMax) and (StrScanCI (opnd, scan^) = nil) do begin + inc (Result); + inc (scan); + end; + {$ENDIF} + else begin // Oh dear. Called inappropriately. + Result := 0; // Best compromise. + Error (reeRegRepeatCalledInappropriately); + EXIT; + end; + end; { of case} + reginput := scan; + end; { of function TRegExpr.regrepeat +--------------------------------------------------------------} + +function TRegExpr.regnext (p : PRegExprChar) : PRegExprChar; +// dig the "next" pointer out of a node + var offset : TRENextOff; + begin + if p = @regdummy then begin + Result := nil; + EXIT; + end; + offset := PRENextOff (p + REOpSz)^; //###0.933 inlined NEXT + if offset = 0 + then Result := nil + else Result := p + offset; + end; { of function TRegExpr.regnext +--------------------------------------------------------------} + +function TRegExpr.MatchPrim (prog : PRegExprChar) : boolean; +// recursively matching routine +// Conceptually the strategy is simple: check to see whether the current +// node matches, call self recursively to see whether the rest matches, +// and then act accordingly. In practice we make some effort to avoid +// recursion, in particular by going through "ordinary" nodes (that don't +// need to know whether the rest of the match failed) by a loop instead of +// by recursion. + var + scan : PRegExprChar; // Current node. + next : PRegExprChar; // Next node. + len : integer; + opnd : PRegExprChar; + no : integer; + save : PRegExprChar; + nextch : REChar; + BracesMin, BracesMax : integer; // we use integer instead of TREBracesArg for better support */+ + {$IFDEF ComplexBraces} + SavedLoopStack : array [1 .. LoopStackMax] of integer; // :(( very bad for recursion + SavedLoopStackIdx : integer; //###0.925 + {$ENDIF} + begin + Result := false; + scan := prog; + + while scan <> nil do begin + len := PRENextOff (scan + 1)^; //###0.932 inlined regnext + if len = 0 + then next := nil + else next := scan + len; + + case scan^ of + NOTBOUND, //###0.943 //!!! think about UseSetOfChar !!! + BOUND: + if (scan^ = BOUND) + xor ( + ((reginput = fInputStart) or (Pos ((reginput - 1)^, fWordChars) <= 0)) + and (reginput^ <> #0) and (Pos (reginput^, fWordChars) > 0) + or + (reginput <> fInputStart) and (Pos ((reginput - 1)^, fWordChars) > 0) + and ((reginput^ = #0) or (Pos (reginput^, fWordChars) <= 0))) + then EXIT; + + BOL: if reginput <> fInputStart + then EXIT; + EOL: if reginput^ <> #0 + then EXIT; + BOLML: if reginput > fInputStart then begin + nextch := (reginput - 1)^; + if (nextch <> fLinePairedSeparatorTail) + or ((reginput - 1) <= fInputStart) + or ((reginput - 2)^ <> fLinePairedSeparatorHead) + then begin + if (nextch = fLinePairedSeparatorHead) + and (reginput^ = fLinePairedSeparatorTail) + then EXIT; // don't stop between paired separator + if + {$IFNDEF UniCode} + not (nextch in fLineSeparatorsSet) + {$ELSE} + (pos (nextch, fLineSeparators) <= 0) + {$ENDIF} + then EXIT; + end; + end; + EOLML: if reginput^ <> #0 then begin + nextch := reginput^; + if (nextch <> fLinePairedSeparatorHead) + or ((reginput + 1)^ <> fLinePairedSeparatorTail) + then begin + if (nextch = fLinePairedSeparatorTail) + and (reginput > fInputStart) + and ((reginput - 1)^ = fLinePairedSeparatorHead) + then EXIT; // don't stop between paired separator + if + {$IFNDEF UniCode} + not (nextch in fLineSeparatorsSet) + {$ELSE} + (pos (nextch, fLineSeparators) <= 0) + {$ENDIF} + then EXIT; + end; + end; + ANY: begin + if reginput^ = #0 + then EXIT; + inc (reginput); + end; + ANYML: begin //###0.941 + if (reginput^ = #0) + or ((reginput^ = fLinePairedSeparatorHead) + and ((reginput + 1)^ = fLinePairedSeparatorTail)) + or {$IFNDEF UniCode} (reginput^ in fLineSeparatorsSet) + {$ELSE} (pos (reginput^, fLineSeparators) > 0) {$ENDIF} + then EXIT; + inc (reginput); + end; + ANYDIGIT: begin + if (reginput^ = #0) or (reginput^ < '0') or (reginput^ > '9') + then EXIT; + inc (reginput); + end; + NOTDIGIT: begin + if (reginput^ = #0) or ((reginput^ >= '0') and (reginput^ <= '9')) + then EXIT; + inc (reginput); + end; + {$IFNDEF UseSetOfChar} //###0.929 + ANYLETTER: begin + if (reginput^ = #0) or (Pos (reginput^, fWordChars) <= 0) //###0.943 + then EXIT; + inc (reginput); + end; + NOTLETTER: begin + if (reginput^ = #0) or (Pos (reginput^, fWordChars) > 0) //###0.943 + then EXIT; + inc (reginput); + end; + ANYSPACE: begin + if (reginput^ = #0) or not (Pos (reginput^, fSpaceChars) > 0) //###0.943 + then EXIT; + inc (reginput); + end; + NOTSPACE: begin + if (reginput^ = #0) or (Pos (reginput^, fSpaceChars) > 0) //###0.943 + then EXIT; + inc (reginput); + end; + {$ENDIF} + EXACTLYCI: begin + opnd := scan + REOpSz + RENextOffSz; // OPERAND + // Inline the first character, for speed. + if (opnd^ <> reginput^) + and (InvertCase (opnd^) <> reginput^) + then EXIT; + len := strlen (opnd); + //###0.929 begin + no := len; + save := reginput; + while no > 1 do begin + inc (save); + inc (opnd); + if (opnd^ <> save^) + and (InvertCase (opnd^) <> save^) + then EXIT; + dec (no); + end; + //###0.929 end + inc (reginput, len); + end; + EXACTLY: begin + opnd := scan + REOpSz + RENextOffSz; // OPERAND + // Inline the first character, for speed. + if opnd^ <> reginput^ + then EXIT; + len := strlen (opnd); + //###0.929 begin + no := len; + save := reginput; + while no > 1 do begin + inc (save); + inc (opnd); + if opnd^ <> save^ + then EXIT; + dec (no); + end; + //###0.929 end + inc (reginput, len); + end; + BSUBEXP: begin //###0.936 + no := ord ((scan + REOpSz + RENextOffSz)^); + if startp [no] = nil + then EXIT; + if endp [no] = nil + then EXIT; + save := reginput; + opnd := startp [no]; + while opnd < endp [no] do begin + if (save >= fInputEnd) or (save^ <> opnd^) + then EXIT; + inc (save); + inc (opnd); + end; + reginput := save; + end; + BSUBEXPCI: begin //###0.936 + no := ord ((scan + REOpSz + RENextOffSz)^); + if startp [no] = nil + then EXIT; + if endp [no] = nil + then EXIT; + save := reginput; + opnd := startp [no]; + while opnd < endp [no] do begin + if (save >= fInputEnd) or + ((save^ <> opnd^) and (save^ <> InvertCase (opnd^))) + then EXIT; + inc (save); + inc (opnd); + end; + reginput := save; + end; + ANYOFTINYSET: begin + if (reginput^ = #0) or //!!!TinySet + ((reginput^ <> (scan + REOpSz + RENextOffSz)^) + and (reginput^ <> (scan + REOpSz + RENextOffSz + 1)^) + and (reginput^ <> (scan + REOpSz + RENextOffSz + 2)^)) + then EXIT; + inc (reginput); + end; + ANYBUTTINYSET: begin + if (reginput^ = #0) or //!!!TinySet + (reginput^ = (scan + REOpSz + RENextOffSz)^) + or (reginput^ = (scan + REOpSz + RENextOffSz + 1)^) + or (reginput^ = (scan + REOpSz + RENextOffSz + 2)^) + then EXIT; + inc (reginput); + end; + {$IFDEF UseSetOfChar} //###0.929 + ANYOFFULLSET: begin + if (reginput^ = #0) + or not (reginput^ in PSetOfREChar (scan + REOpSz + RENextOffSz)^) + then EXIT; + inc (reginput); + end; + {$ELSE} + ANYOF: begin + if (reginput^ = #0) or (StrScan (scan + REOpSz + RENextOffSz, reginput^) = nil) + then EXIT; + inc (reginput); + end; + ANYBUT: begin + if (reginput^ = #0) or (StrScan (scan + REOpSz + RENextOffSz, reginput^) <> nil) + then EXIT; + inc (reginput); + end; + ANYOFCI: begin + if (reginput^ = #0) or (StrScanCI (scan + REOpSz + RENextOffSz, reginput^) = nil) + then EXIT; + inc (reginput); + end; + ANYBUTCI: begin + if (reginput^ = #0) or (StrScanCI (scan + REOpSz + RENextOffSz, reginput^) <> nil) + then EXIT; + inc (reginput); + end; + {$ENDIF} + NOTHING: ; + COMMENT: ; + BACK: ; + Succ (OPEN) .. TREOp (Ord (OPEN) + NSUBEXP - 1) : begin //###0.929 + no := ord (scan^) - ord (OPEN); +// save := reginput; + save := startp [no]; //###0.936 + startp [no] := reginput; //###0.936 + Result := MatchPrim (next); + if not Result //###0.936 + then startp [no] := save; +// if Result and (startp [no] = nil) +// then startp [no] := save; + // Don't set startp if some later invocation of the same + // parentheses already has. + EXIT; + end; + Succ (CLOSE) .. TREOp (Ord (CLOSE) + NSUBEXP - 1): begin //###0.929 + no := ord (scan^) - ord (CLOSE); +// save := reginput; + save := endp [no]; //###0.936 + endp [no] := reginput; //###0.936 + Result := MatchPrim (next); + if not Result //###0.936 + then endp [no] := save; +// if Result and (endp [no] = nil) +// then endp [no] := save; + // Don't set endp if some later invocation of the same + // parentheses already has. + EXIT; + end; + BRANCH: begin + if (next^ <> BRANCH) // No choice. + then next := scan + REOpSz + RENextOffSz // Avoid recursion + else begin + REPEAT + save := reginput; + Result := MatchPrim (scan + REOpSz + RENextOffSz); + if Result + then EXIT; + reginput := save; + scan := regnext (scan); + UNTIL (scan = nil) or (scan^ <> BRANCH); + EXIT; + end; + end; + {$IFDEF ComplexBraces} + LOOPENTRY: begin //###0.925 + no := LoopStackIdx; + inc (LoopStackIdx); + if LoopStackIdx > LoopStackMax then begin + Error (reeLoopStackExceeded); + EXIT; + end; + save := reginput; + LoopStack [LoopStackIdx] := 0; // init loop counter + Result := MatchPrim (next); // execute LOOP + LoopStackIdx := no; // cleanup + if Result + then EXIT; + reginput := save; + EXIT; + end; + LOOP, LOOPNG: begin //###0.940 + if LoopStackIdx <= 0 then begin + Error (reeLoopWithoutEntry); + EXIT; + end; + opnd := scan + PRENextOff (scan + REOpSz + RENextOffSz + 2 * REBracesArgSz)^; + BracesMin := PREBracesArg (scan + REOpSz + RENextOffSz)^; + BracesMax := PREBracesArg (scan + REOpSz + RENextOffSz + REBracesArgSz)^; + save := reginput; + if LoopStack [LoopStackIdx] >= BracesMin then begin // Min alredy matched - we can work + if scan^ = LOOP then begin + // greedy way - first try to max deep of greed ;) + if LoopStack [LoopStackIdx] < BracesMax then begin + inc (LoopStack [LoopStackIdx]); + no := LoopStackIdx; + Result := MatchPrim (opnd); + LoopStackIdx := no; + if Result + then EXIT; + reginput := save; + end; + dec (LoopStackIdx); // Fail. May be we are too greedy? ;) + Result := MatchPrim (next); + if not Result + then reginput := save; + EXIT; + end + else begin + // non-greedy - try just now + Result := MatchPrim (next); + if Result + then EXIT + else reginput := save; // failed - move next and try again + if LoopStack [LoopStackIdx] < BracesMax then begin + inc (LoopStack [LoopStackIdx]); + no := LoopStackIdx; + Result := MatchPrim (opnd); + LoopStackIdx := no; + if Result + then EXIT; + reginput := save; + end; + dec (LoopStackIdx); // Failed - back up + EXIT; + end + end + else begin // first match a min_cnt times + inc (LoopStack [LoopStackIdx]); + no := LoopStackIdx; + Result := MatchPrim (opnd); + LoopStackIdx := no; + if Result + then EXIT; + dec (LoopStack [LoopStackIdx]); + reginput := save; + EXIT; + end; + end; + {$ENDIF} + STAR, PLUS, BRACES, STARNG, PLUSNG, BRACESNG: begin + // Lookahead to avoid useless match attempts when we know + // what character comes next. + nextch := #0; + if next^ = EXACTLY + then nextch := (next + REOpSz + RENextOffSz)^; + BracesMax := MaxInt; // infinite loop for * and + //###0.92 + if (scan^ = STAR) or (scan^ = STARNG) + then BracesMin := 0 // STAR + else if (scan^ = PLUS) or (scan^ = PLUSNG) + then BracesMin := 1 // PLUS + else begin // BRACES + BracesMin := PREBracesArg (scan + REOpSz + RENextOffSz)^; + BracesMax := PREBracesArg (scan + REOpSz + RENextOffSz + REBracesArgSz)^; + end; + save := reginput; + opnd := scan + REOpSz + RENextOffSz; + if (scan^ = BRACES) or (scan^ = BRACESNG) + then inc (opnd, 2 * REBracesArgSz); + + if (scan^ = PLUSNG) or (scan^ = STARNG) or (scan^ = BRACESNG) then begin + // non-greedy mode + BracesMax := regrepeat (opnd, BracesMax); // don't repeat more than BracesMax + // Now we know real Max limit to move forward (for recursion 'back up') + // In some cases it can be faster to check only Min positions first, + // but after that we have to check every position separtely instead + // of fast scannig in loop. + no := BracesMin; + while no <= BracesMax do begin + reginput := save + no; + // If it could work, try it. + if (nextch = #0) or (reginput^ = nextch) then begin + {$IFDEF ComplexBraces} + System.Move (LoopStack, SavedLoopStack, SizeOf (LoopStack)); //###0.925 + SavedLoopStackIdx := LoopStackIdx; + {$ENDIF} + if MatchPrim (next) then begin + Result := true; + EXIT; + end; + {$IFDEF ComplexBraces} + System.Move (SavedLoopStack, LoopStack, SizeOf (LoopStack)); + LoopStackIdx := SavedLoopStackIdx; + {$ENDIF} + end; + inc (no); // Couldn't or didn't - move forward. + end; { of while} + EXIT; + end + else begin // greedy mode + no := regrepeat (opnd, BracesMax); // don't repeat more than max_cnt + while no >= BracesMin do begin + // If it could work, try it. + if (nextch = #0) or (reginput^ = nextch) then begin + {$IFDEF ComplexBraces} + System.Move (LoopStack, SavedLoopStack, SizeOf (LoopStack)); //###0.925 + SavedLoopStackIdx := LoopStackIdx; + {$ENDIF} + if MatchPrim (next) then begin + Result := true; + EXIT; + end; + {$IFDEF ComplexBraces} + System.Move (SavedLoopStack, LoopStack, SizeOf (LoopStack)); + LoopStackIdx := SavedLoopStackIdx; + {$ENDIF} + end; + dec (no); // Couldn't or didn't - back up. + reginput := save + no; + end; { of while} + EXIT; + end; + end; + EEND: begin + Result := true; // Success! + EXIT; + end; + else begin + Error (reeMatchPrimMemoryCorruption); + EXIT; + end; + end; { of case scan^} + scan := next; + end; { of while scan <> nil} + + // We get here only if there's trouble -- normally "case EEND" is the + // terminating point. + Error (reeMatchPrimCorruptedPointers); + end; { of function TRegExpr.MatchPrim +--------------------------------------------------------------} + +{$IFDEF UseFirstCharSet} //###0.929 +procedure TRegExpr.FillFirstCharSet (prog : PRegExprChar); + var + scan : PRegExprChar; // Current node. + next : PRegExprChar; // Next node. + opnd : PRegExprChar; + min_cnt : integer; + begin + scan := prog; + while scan <> nil do begin + next := regnext (scan); + case PREOp (scan)^ of + BSUBEXP, BSUBEXPCI: begin //###0.938 + FirstCharSet := [#0 .. #255]; // :((( we cannot + // optimize r.e. if it starts with back reference + EXIT; + end; + BOL, BOLML: ; // EXIT; //###0.937 + EOL, EOLML: begin //###0.948 was empty in 0.947, was EXIT in 0.937 + Include (FirstCharSet, #0); + if ModifierM + then begin + opnd := PRegExprChar (LineSeparators); + while opnd^ <> #0 do begin + Include (FirstCharSet, opnd^); + inc (opnd); + end; + end; + EXIT; + end; + BOUND, NOTBOUND: ; //###0.943 ?!! + ANY, ANYML: begin // we can better define ANYML !!! + FirstCharSet := [#0 .. #255]; //###0.930 + EXIT; + end; + ANYDIGIT: begin + FirstCharSet := FirstCharSet + ['0' .. '9']; + EXIT; + end; + NOTDIGIT: begin + FirstCharSet := FirstCharSet + ([#0 .. #255] - ['0' .. '9']); //###0.948 FirstCharSet was forgotten + EXIT; + end; + EXACTLYCI: begin + Include (FirstCharSet, (scan + REOpSz + RENextOffSz)^); + Include (FirstCharSet, InvertCase ((scan + REOpSz + RENextOffSz)^)); + EXIT; + end; + EXACTLY: begin + Include (FirstCharSet, (scan + REOpSz + RENextOffSz)^); + EXIT; + end; + ANYOFFULLSET: begin + FirstCharSet := FirstCharSet + PSetOfREChar (scan + REOpSz + RENextOffSz)^; + EXIT; + end; + ANYOFTINYSET: begin + //!!!TinySet + Include (FirstCharSet, (scan + REOpSz + RENextOffSz)^); + Include (FirstCharSet, (scan + REOpSz + RENextOffSz + 1)^); + Include (FirstCharSet, (scan + REOpSz + RENextOffSz + 2)^); + // ... // up to TinySetLen + EXIT; + end; + ANYBUTTINYSET: begin + //!!!TinySet + FirstCharSet := FirstCharSet + ([#0 .. #255] - [ //###0.948 FirstCharSet was forgotten + (scan + REOpSz + RENextOffSz)^, + (scan + REOpSz + RENextOffSz + 1)^, + (scan + REOpSz + RENextOffSz + 2)^]); + // ... // up to TinySetLen + EXIT; + end; + NOTHING: ; + COMMENT: ; + BACK: ; + Succ (OPEN) .. TREOp (Ord (OPEN) + NSUBEXP - 1) : begin //###0.929 + FillFirstCharSet (next); + EXIT; + end; + Succ (CLOSE) .. TREOp (Ord (CLOSE) + NSUBEXP - 1): begin //###0.929 + FillFirstCharSet (next); + EXIT; + end; + BRANCH: begin + if (PREOp (next)^ <> BRANCH) // No choice. + then next := scan + REOpSz + RENextOffSz // Avoid recursion. + else begin + REPEAT + FillFirstCharSet (scan + REOpSz + RENextOffSz); + scan := regnext (scan); + UNTIL (scan = nil) or (PREOp (scan)^ <> BRANCH); + EXIT; + end; + end; + {$IFDEF ComplexBraces} + LOOPENTRY: begin //###0.925 +// LoopStack [LoopStackIdx] := 0; //###0.940 line removed + FillFirstCharSet (next); // execute LOOP + EXIT; + end; + LOOP, LOOPNG: begin //###0.940 + opnd := scan + PRENextOff (scan + REOpSz + RENextOffSz + REBracesArgSz * 2)^; + min_cnt := PREBracesArg (scan + REOpSz + RENextOffSz)^; + FillFirstCharSet (opnd); + if min_cnt = 0 + then FillFirstCharSet (next); + EXIT; + end; + {$ENDIF} + STAR, STARNG: //###0.940 + FillFirstCharSet (scan + REOpSz + RENextOffSz); + PLUS, PLUSNG: begin //###0.940 + FillFirstCharSet (scan + REOpSz + RENextOffSz); + EXIT; + end; + BRACES, BRACESNG: begin //###0.940 + opnd := scan + REOpSz + RENextOffSz + REBracesArgSz * 2; + min_cnt := PREBracesArg (scan + REOpSz + RENextOffSz)^; // BRACES + FillFirstCharSet (opnd); + if min_cnt > 0 + then EXIT; + end; + EEND: begin + FirstCharSet := [#0 .. #255]; //###0.948 + EXIT; + end; + else begin + Error (reeMatchPrimMemoryCorruption); + EXIT; + end; + end; { of case scan^} + scan := next; + end; { of while scan <> nil} + end; { of procedure FillFirstCharSet +--------------------------------------------------------------} +{$ENDIF} + +function TRegExpr.Exec (const AInputString : RegExprString) : boolean; + begin + InputString := AInputString; + Result := ExecPrim (1); + end; { of function TRegExpr.Exec +--------------------------------------------------------------} + +{$IFDEF OverMeth} +{$IFNDEF FPC} +function TRegExpr.Exec : boolean; + begin + Result := ExecPrim (1); + end; { of function TRegExpr.Exec +--------------------------------------------------------------} +{$ENDIF} +function TRegExpr.Exec (AOffset: integer) : boolean; + begin + Result := ExecPrim (AOffset); + end; { of function TRegExpr.Exec +--------------------------------------------------------------} +{$ENDIF} + +function TRegExpr.ExecPos (AOffset: integer {$IFDEF DefParam}= 1{$ENDIF}) : boolean; + begin + Result := ExecPrim (AOffset); + end; { of function TRegExpr.ExecPos +--------------------------------------------------------------} + +function TRegExpr.ExecPrim (AOffset: integer) : boolean; + procedure ClearMatchs; + // Clears matchs array + var i : integer; + begin + for i := 0 to NSUBEXP - 1 do begin + startp [i] := nil; + endp [i] := nil; + end; + end; { of procedure ClearMatchs; +..............................................................} + function RegMatch (str : PRegExprChar) : boolean; + // try match at specific point + begin + //###0.949 removed clearing of start\endp + reginput := str; + Result := MatchPrim (programm + REOpSz); + if Result then begin + startp [0] := str; + endp [0] := reginput; + end; + end; { of function RegMatch +..............................................................} + var + s : PRegExprChar; + StartPtr: PRegExprChar; + InputLen : integer; + begin + Result := false; // Be paranoid... + + ClearMatchs; //###0.949 + // ensure that Match cleared either if optimization tricks or some error + // will lead to leaving ExecPrim without actual search. That is + // importent for ExecNext logic and so on. + + if not IsProgrammOk //###0.929 + then EXIT; + + // Check InputString presence + if not Assigned (fInputString) then begin + Error (reeNoInpitStringSpecified); + EXIT; + end; + + InputLen := length (fInputString); + + //Check that the start position is not negative + if AOffset < 1 then begin + Error (reeOffsetMustBeGreaterThen0); + EXIT; + end; + // Check that the start position is not longer than the line + // If so then exit with nothing found + if AOffset > (InputLen + 1) // for matching empty string after last char. + then EXIT; + + StartPtr := fInputString + AOffset - 1; + + // If there is a "must appear" string, look for it. + if regmust <> nil then begin + s := StartPtr; + REPEAT + s := StrScan (s, regmust [0]); + if s <> nil then begin + if StrLComp (s, regmust, regmlen) = 0 + then BREAK; // Found it. + inc (s); + end; + UNTIL s = nil; + if s = nil // Not present. + then EXIT; + end; + + // Mark beginning of line for ^ . + fInputStart := fInputString; + + // Pointer to end of input stream - for + // pascal-style string processing (may include #0) + fInputEnd := fInputString + InputLen; + + {$IFDEF ComplexBraces} + // no loops started + LoopStackIdx := 0; //###0.925 + {$ENDIF} + + // Simplest case: anchored match need be tried only once. + if reganch <> #0 then begin + Result := RegMatch (StartPtr); + EXIT; + end; + + // Messy cases: unanchored match. + s := StartPtr; + if regstart <> #0 then // We know what char it must start with. + REPEAT + s := StrScan (s, regstart); + if s <> nil then begin + Result := RegMatch (s); + if Result + then EXIT + else ClearMatchs; //###0.949 + inc (s); + end; + UNTIL s = nil + else begin // We don't - general case. + repeat //###0.948 + {$IFDEF UseFirstCharSet} + if s^ in FirstCharSet + then Result := RegMatch (s); + {$ELSE} + Result := RegMatch (s); + {$ENDIF} + if Result or (s^ = #0) // Exit on a match or after testing the end-of-string. + then EXIT + else ClearMatchs; //###0.949 + inc (s); + until false; +(* optimized and fixed by Martin Fuller - empty strings + were not allowed to pass thru in UseFirstCharSet mode + {$IFDEF UseFirstCharSet} //###0.929 + while s^ <> #0 do begin + if s^ in FirstCharSet + then Result := RegMatch (s); + if Result + then EXIT; + inc (s); + end; + {$ELSE} + REPEAT + Result := RegMatch (s); + if Result + then EXIT; + inc (s); + UNTIL s^ = #0; + {$ENDIF} +*) + end; + // Failure + end; { of function TRegExpr.ExecPrim +--------------------------------------------------------------} + +function TRegExpr.ExecNext : boolean; + var offset : integer; + begin + Result := false; + if not Assigned (startp[0]) or not Assigned (endp[0]) then begin + Error (reeExecNextWithoutExec); + EXIT; + end; +// Offset := MatchPos [0] + MatchLen [0]; +// if MatchLen [0] = 0 + Offset := endp [0] - fInputString + 1; //###0.929 + if endp [0] = startp [0] //###0.929 + then inc (Offset); // prevent infinite looping if empty string match r.e. + Result := ExecPrim (Offset); + end; { of function TRegExpr.ExecNext +--------------------------------------------------------------} + +function TRegExpr.GetInputString : RegExprString; + begin + if not Assigned (fInputString) then begin + Error (reeGetInputStringWithoutInputString); + EXIT; + end; + Result := fInputString; + end; { of function TRegExpr.GetInputString +--------------------------------------------------------------} + +procedure TRegExpr.SetInputString (const AInputString : RegExprString); + var + Len : integer; + i : integer; + begin + // clear Match* - before next Exec* call it's undefined + for i := 0 to NSUBEXP - 1 do begin + startp [i] := nil; + endp [i] := nil; + end; + + // need reallocation of input string buffer ? + Len := length (AInputString); + if Assigned (fInputString) and (Length (fInputString) <> Len) then begin + FreeMem (fInputString); + fInputString := nil; + end; + // buffer [re]allocation + if not Assigned (fInputString) + then GetMem (fInputString, (Len + 1) * SizeOf (REChar)); + + // copy input string into buffer + {$IFDEF UniCode} + StrPCopy (fInputString, Copy (AInputString, 1, Len)); //###0.927 + {$ELSE} + StrLCopy (fInputString, PRegExprChar (AInputString), Len); + {$ENDIF} + + { + fInputString : string; + fInputStart, fInputEnd : PRegExprChar; + + SetInputString: + fInputString := AInputString; + UniqueString (fInputString); + fInputStart := PChar (fInputString); + Len := length (fInputString); + fInputEnd := PRegExprChar (integer (fInputStart) + Len); ?? + !! startp/endp âñå ðàâíî áóäåò îïàñíî èñïîëüçîâàòü ? + } + end; { of procedure TRegExpr.SetInputString +--------------------------------------------------------------} + +procedure TRegExpr.SetLineSeparators (const AStr : RegExprString); + begin + if AStr <> fLineSeparators then begin + fLineSeparators := AStr; + InvalidateProgramm; + end; + end; { of procedure TRegExpr.SetLineSeparators +--------------------------------------------------------------} + +procedure TRegExpr.SetLinePairedSeparator (const AStr : RegExprString); + begin + if length (AStr) = 2 then begin + if AStr [1] = AStr [2] then begin + // it's impossible for our 'one-point' checking to support + // two chars separator for identical chars + Error (reeBadLinePairedSeparator); + EXIT; + end; + if not fLinePairedSeparatorAssigned + or (AStr [1] <> fLinePairedSeparatorHead) + or (AStr [2] <> fLinePairedSeparatorTail) then begin + fLinePairedSeparatorAssigned := true; + fLinePairedSeparatorHead := AStr [1]; + fLinePairedSeparatorTail := AStr [2]; + InvalidateProgramm; + end; + end + else if length (AStr) = 0 then begin + if fLinePairedSeparatorAssigned then begin + fLinePairedSeparatorAssigned := false; + InvalidateProgramm; + end; + end + else Error (reeBadLinePairedSeparator); + end; { of procedure TRegExpr.SetLinePairedSeparator +--------------------------------------------------------------} + +function TRegExpr.GetLinePairedSeparator : RegExprString; + begin + if fLinePairedSeparatorAssigned then begin + {$IFDEF UniCode} + // Here is some UniCode 'magic' + // If You do know better decision to concatenate + // two WideChars, please, let me know! + Result := fLinePairedSeparatorHead; //###0.947 + Result := Result + fLinePairedSeparatorTail; + {$ELSE} + Result := fLinePairedSeparatorHead + fLinePairedSeparatorTail; + {$ENDIF} + end + else Result := ''; + end; { of function TRegExpr.GetLinePairedSeparator +--------------------------------------------------------------} + +function TRegExpr.Substitute (const ATemplate : RegExprString) : RegExprString; +// perform substitutions after a regexp match +// completely rewritten in 0.929 + var + TemplateLen : integer; + TemplateBeg, TemplateEnd : PRegExprChar; + p, p0, ResultPtr : PRegExprChar; + ResultLen : integer; + n : integer; + Ch : REChar; + function ParseVarName (var APtr : PRegExprChar) : integer; + // extract name of variable (digits, may be enclosed with + // curly braces) from APtr^, uses TemplateEnd !!! + const + Digits = ['0' .. '9']; + var + p : PRegExprChar; + Delimited : boolean; + begin + Result := 0; + p := APtr; + Delimited := (p < TemplateEnd) and (p^ = '{'); + if Delimited + then inc (p); // skip left curly brace + if (p < TemplateEnd) and (p^ = '&') + then inc (p) // this is '$&' or '${&}' + else + while (p < TemplateEnd) and + {$IFDEF UniCode} //###0.935 + (ord (p^) < 256) and (char (p^) in Digits) + {$ELSE} + (p^ in Digits) + {$ENDIF} + do begin + Result := Result * 10 + (ord (p^) - ord ('0')); //###0.939 + inc (p); + end; + if Delimited then + if (p < TemplateEnd) and (p^ = '}') + then inc (p) // skip right curly brace + else p := APtr; // isn't properly terminated + if p = APtr + then Result := -1; // no valid digits found or no right curly brace + APtr := p; + end; + begin + // Check programm and input string + if not IsProgrammOk + then EXIT; + if not Assigned (fInputString) then begin + Error (reeNoInpitStringSpecified); + EXIT; + end; + // Prepare for working + TemplateLen := length (ATemplate); + if TemplateLen = 0 then begin // prevent nil pointers + Result := ''; + EXIT; + end; + TemplateBeg := pointer (ATemplate); + TemplateEnd := TemplateBeg + TemplateLen; + // Count result length for speed optimization. + ResultLen := 0; + p := TemplateBeg; + while p < TemplateEnd do begin + Ch := p^; + inc (p); + if Ch = '$' + then n := ParseVarName (p) + else n := -1; + if n >= 0 then begin + if (n < NSUBEXP) and Assigned (startp [n]) and Assigned (endp [n]) + then inc (ResultLen, endp [n] - startp [n]); + end + else begin + if (Ch = EscChar) and (p < TemplateEnd) + then inc (p); // quoted or special char followed + inc (ResultLen); + end; + end; + // Get memory. We do it once and it significant speed up work ! + if ResultLen = 0 then begin + Result := ''; + EXIT; + end; + SetString (Result, nil, ResultLen); + // Fill Result + ResultPtr := pointer (Result); + p := TemplateBeg; + while p < TemplateEnd do begin + Ch := p^; + inc (p); + if Ch = '$' + then n := ParseVarName (p) + else n := -1; + if n >= 0 then begin + p0 := startp [n]; + if (n < NSUBEXP) and Assigned (p0) and Assigned (endp [n]) then + while p0 < endp [n] do begin + ResultPtr^ := p0^; + inc (ResultPtr); + inc (p0); + end; + end + else begin + if (Ch = EscChar) and (p < TemplateEnd) then begin // quoted or special char followed + Ch := p^; + inc (p); + end; + ResultPtr^ := Ch; + inc (ResultPtr); + end; + end; + end; { of function TRegExpr.Substitute +--------------------------------------------------------------} + +procedure TRegExpr.Split (AInputStr : RegExprString; APieces : TStrings); + var PrevPos : integer; + begin + PrevPos := 1; + if Exec (AInputStr) then + REPEAT + APieces.Add (System.Copy (AInputStr, PrevPos, MatchPos [0] - PrevPos)); + PrevPos := MatchPos [0] + MatchLen [0]; + UNTIL not ExecNext; + APieces.Add (System.Copy (AInputStr, PrevPos, MaxInt)); // Tail + end; { of procedure TRegExpr.Split +--------------------------------------------------------------} + +function TRegExpr.Replace (AInputStr : RegExprString; const AReplaceStr : RegExprString; + AUseSubstitution : boolean{$IFDEF DefParam}= False{$ENDIF}) : RegExprString; + var + PrevPos : integer; + begin + Result := ''; + PrevPos := 1; + if Exec (AInputStr) then + REPEAT + Result := Result + System.Copy (AInputStr, PrevPos, + MatchPos [0] - PrevPos); + if AUseSubstitution //###0.946 + then Result := Result + Substitute (AReplaceStr) + else Result := Result + AReplaceStr; + PrevPos := MatchPos [0] + MatchLen [0]; + UNTIL not ExecNext; + Result := Result + System.Copy (AInputStr, PrevPos, MaxInt); // Tail + end; { of function TRegExpr.Replace +--------------------------------------------------------------} + +function TRegExpr.ReplaceEx (AInputStr : RegExprString; + AReplaceFunc : TRegExprReplaceFunction) + : RegExprString; + var + PrevPos : integer; + begin + Result := ''; + PrevPos := 1; + if Exec (AInputStr) then + REPEAT + Result := Result + System.Copy (AInputStr, PrevPos, + MatchPos [0] - PrevPos) + + AReplaceFunc (Self); + PrevPos := MatchPos [0] + MatchLen [0]; + UNTIL not ExecNext; + Result := Result + System.Copy (AInputStr, PrevPos, MaxInt); // Tail + end; { of function TRegExpr.ReplaceEx +--------------------------------------------------------------} + + +{$IFDEF OverMeth} +function TRegExpr.Replace (AInputStr : RegExprString; + AReplaceFunc : TRegExprReplaceFunction) + : RegExprString; + begin + ReplaceEx (AInputStr, AReplaceFunc); + end; { of function TRegExpr.Replace +--------------------------------------------------------------} +{$ENDIF} + +{=============================================================} +{====================== Debug section ========================} +{=============================================================} + +{$IFDEF RegExpPCodeDump} +function TRegExpr.DumpOp (op : TREOp) : RegExprString; +// printable representation of opcode + begin + case op of + BOL: Result := 'BOL'; + EOL: Result := 'EOL'; + BOLML: Result := 'BOLML'; + EOLML: Result := 'EOLML'; + BOUND: Result := 'BOUND'; //###0.943 + NOTBOUND: Result := 'NOTBOUND'; //###0.943 + ANY: Result := 'ANY'; + ANYML: Result := 'ANYML'; //###0.941 + ANYLETTER: Result := 'ANYLETTER'; + NOTLETTER: Result := 'NOTLETTER'; + ANYDIGIT: Result := 'ANYDIGIT'; + NOTDIGIT: Result := 'NOTDIGIT'; + ANYSPACE: Result := 'ANYSPACE'; + NOTSPACE: Result := 'NOTSPACE'; + ANYOF: Result := 'ANYOF'; + ANYBUT: Result := 'ANYBUT'; + ANYOFCI: Result := 'ANYOF/CI'; + ANYBUTCI: Result := 'ANYBUT/CI'; + BRANCH: Result := 'BRANCH'; + EXACTLY: Result := 'EXACTLY'; + EXACTLYCI: Result := 'EXACTLY/CI'; + NOTHING: Result := 'NOTHING'; + COMMENT: Result := 'COMMENT'; + BACK: Result := 'BACK'; + EEND: Result := 'END'; + BSUBEXP: Result := 'BSUBEXP'; + BSUBEXPCI: Result := 'BSUBEXP/CI'; + Succ (OPEN) .. TREOp (Ord (OPEN) + NSUBEXP - 1): //###0.929 + Result := Format ('OPEN[%d]', [ord (op) - ord (OPEN)]); + Succ (CLOSE) .. TREOp (Ord (CLOSE) + NSUBEXP - 1): //###0.929 + Result := Format ('CLOSE[%d]', [ord (op) - ord (CLOSE)]); + STAR: Result := 'STAR'; + PLUS: Result := 'PLUS'; + BRACES: Result := 'BRACES'; + {$IFDEF ComplexBraces} + LOOPENTRY: Result := 'LOOPENTRY'; //###0.925 + LOOP: Result := 'LOOP'; //###0.925 + LOOPNG: Result := 'LOOPNG'; //###0.940 + {$ENDIF} + ANYOFTINYSET: Result:= 'ANYOFTINYSET'; + ANYBUTTINYSET:Result:= 'ANYBUTTINYSET'; + {$IFDEF UseSetOfChar} //###0.929 + ANYOFFULLSET: Result:= 'ANYOFFULLSET'; + {$ENDIF} + STARNG: Result := 'STARNG'; //###0.940 + PLUSNG: Result := 'PLUSNG'; //###0.940 + BRACESNG: Result := 'BRACESNG'; //###0.940 + else Error (reeDumpCorruptedOpcode); + end; {of case op} + Result := ':' + Result; + end; { of function TRegExpr.DumpOp +--------------------------------------------------------------} + +function TRegExpr.Dump : RegExprString; +// dump a regexp in vaguely comprehensible form + var + s : PRegExprChar; + op : TREOp; // Arbitrary non-END op. + next : PRegExprChar; + i : integer; + Diff : integer; +{$IFDEF UseSetOfChar} //###0.929 + Ch : REChar; +{$ENDIF} + begin + if not IsProgrammOk //###0.929 + then EXIT; + + op := EXACTLY; + Result := ''; + s := programm + REOpSz; + while op <> EEND do begin // While that wasn't END last time... + op := s^; + Result := Result + Format ('%2d%s', [s - programm, DumpOp (s^)]); // Where, what. + next := regnext (s); + if next = nil // Next ptr. + then Result := Result + ' (0)' + else begin + if next > s //###0.948 PWideChar subtraction workaround (see comments in Tail method for details) + then Diff := next - s + else Diff := - (s - next); + Result := Result + Format (' (%d) ', [(s - programm) + Diff]); + end; + inc (s, REOpSz + RENextOffSz); + if (op = ANYOF) or (op = ANYOFCI) or (op = ANYBUT) or (op = ANYBUTCI) + or (op = EXACTLY) or (op = EXACTLYCI) then begin + // Literal string, where present. + while s^ <> #0 do begin + Result := Result + s^; + inc (s); + end; + inc (s); + end; + if (op = ANYOFTINYSET) or (op = ANYBUTTINYSET) then begin + for i := 1 to TinySetLen do begin + Result := Result + s^; + inc (s); + end; + end; + if (op = BSUBEXP) or (op = BSUBEXPCI) then begin + Result := Result + ' \' + IntToStr (Ord (s^)); + inc (s); + end; + {$IFDEF UseSetOfChar} //###0.929 + if op = ANYOFFULLSET then begin + for Ch := #0 to #255 do + if Ch in PSetOfREChar (s)^ then + if Ch < ' ' + then Result := Result + '#' + IntToStr (Ord (Ch)) //###0.936 + else Result := Result + Ch; + inc (s, SizeOf (TSetOfREChar)); + end; + {$ENDIF} + if (op = BRACES) or (op = BRACESNG) then begin //###0.941 + // show min/max argument of BRACES operator + Result := Result + Format ('{%d,%d}', [PREBracesArg (s)^, PREBracesArg (s + REBracesArgSz)^]); + inc (s, REBracesArgSz * 2); + end; + {$IFDEF ComplexBraces} + if (op = LOOP) or (op = LOOPNG) then begin //###0.940 + Result := Result + Format (' -> (%d) {%d,%d}', [ + (s - programm - (REOpSz + RENextOffSz)) + PRENextOff (s + 2 * REBracesArgSz)^, + PREBracesArg (s)^, PREBracesArg (s + REBracesArgSz)^]); + inc (s, 2 * REBracesArgSz + RENextOffSz); + end; + {$ENDIF} + Result := Result + #$d#$a; + end; { of while} + + // Header fields of interest. + + if regstart <> #0 + then Result := Result + 'start ' + regstart; + if reganch <> #0 + then Result := Result + 'anchored '; + if regmust <> nil + then Result := Result + 'must have ' + regmust; + {$IFDEF UseFirstCharSet} //###0.929 + Result := Result + #$d#$a'FirstCharSet:'; + for Ch := #0 to #255 do + if Ch in FirstCharSet + then begin + if Ch < ' ' + then Result := Result + '#' + IntToStr(Ord(Ch)) //###0.948 + else Result := Result + Ch; + end; + {$ENDIF} + Result := Result + #$d#$a; + end; { of function TRegExpr.Dump +--------------------------------------------------------------} +{$ENDIF} + +{$IFDEF reRealExceptionAddr} +{$OPTIMIZATION ON} +// ReturnAddr works correctly only if compiler optimization is ON +// I placed this method at very end of unit because there are no +// way to restore compiler optimization flag ... +{$ENDIF} +procedure TRegExpr.Error (AErrorID : integer); +{$IFDEF reRealExceptionAddr} + function ReturnAddr : pointer; //###0.938 + asm + mov eax,[ebp+4] + end; +{$ENDIF} + var + e : ERegExpr; + begin + fLastError := AErrorID; // dummy stub - useless because will raise exception + if AErrorID < 1000 // compilation error ? + then e := ERegExpr.Create (ErrorMsg (AErrorID) // yes - show error pos + + ' (pos ' + IntToStr (CompilerErrorPos) + ')') + else e := ERegExpr.Create (ErrorMsg (AErrorID)); + e.ErrorCode := AErrorID; + e.CompilerErrorPos := CompilerErrorPos; + raise e + {$IFDEF reRealExceptionAddr} + At ReturnAddr; //###0.938 + {$ENDIF} + end; { of procedure TRegExpr.Error +--------------------------------------------------------------} + +(* + PCode persistence: + FirstCharSet + programm, regsize + regstart // -> programm + reganch // -> programm + regmust, regmlen // -> programm + fExprIsCompiled +*) + +// be carefull - placed here code will be always compiled with +// compiler optimization flag + +{$IFDEF FPC} +initialization + RegExprInvertCaseFunction := TRegExpr.InvertCaseFunction; + +{$ENDIF} +end. + diff --git a/src/thirdparty/cef.inc b/src/thirdparty/cef.inc new file mode 100644 index 0000000..68e0614 --- /dev/null +++ b/src/thirdparty/cef.inc @@ -0,0 +1,191 @@ +(* + * Delphi Chromium Embedded + * + * Usage allowed under the restrictions of the Lesser GNU General Public License + * or alternatively the restrictions of the Mozilla Public License 1.1 + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for + * the specific language governing rights and limitations under the License. + * + * Unit owner : Henri Gourvest + * Web site : http://www.progdigy.com + * Repository : http://code.google.com/p/delphichromiumembedded/ + * Group : http://groups.google.com/group/delphichromiumembedded + *) + + {.$define CEF_STRING_TYPE_UTF8} +{$define CEF_STRING_TYPE_UTF16} +{.$define CEF_STRING_TYPE_WIDE} + +{.$DEFINE CEF_MULTI_THREADED_MESSAGE_LOOP} + +{$IFDEF FPC} + // force multithreading message loop on FPC, still not work + {$DEFINE CEF_MULTI_THREADED_MESSAGE_LOOP} + {$DEFINE SUPPORTS_INLINE} +{$ENDIF} + +{$IFDEF VER130} + {$DEFINE DELPHI5_UP} +{$ENDIF} + +{$IFDEF VER140} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI6_UP} +{$ENDIF} + +{$IFDEF VER150} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI7_UP} +{$ENDIF} + +{$IFDEF VER160} + // DELPHI 8 for Dotnet + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI7_UP} + {$DEFINE DELPHI8_UP} +{$ENDIF} + +// Delphi 2005 +{$IFDEF VER170} + {$DEFINE SUPPORTS_INLINE} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI7_UP} + {$DEFINE DELPHI8_UP} + {$DEFINE DELPHI9_UP} +{$ENDIF} + +{$IFDEF VER180} + // Delphi 2007 + {$IFDEF VER185} + {$DEFINE SUPPORTS_INLINE} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI7_UP} + {$DEFINE DELPHI8_UP} + {$DEFINE DELPHI9_UP} + {$DEFINE DELPHI10_UP} + {$DEFINE DELPHI11_UP} + // Delphi 2006 + {$ELSE} + {$DEFINE SUPPORTS_INLINE} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI7_UP} + {$DEFINE DELPHI8_UP} + {$DEFINE DELPHI9_UP} + {$DEFINE DELPHI10_UP} + {$ENDIF} +{$ENDIF} + +// Delphi 2009 +{$IFDEF VER200} + {$DEFINE SUPPORTS_INLINE} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI7_UP} + {$DEFINE DELPHI8_UP} + {$DEFINE DELPHI9_UP} + {$DEFINE DELPHI10_UP} + {$DEFINE DELPHI11_UP} + {$DEFINE DELPHI12_UP} +{$ENDIF} + +//Delphi 2010 +{$IFDEF VER210} + {$DEFINE SUPPORTS_INLINE} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI7_UP} + {$DEFINE DELPHI8_UP} + {$DEFINE DELPHI9_UP} + {$DEFINE DELPHI10_UP} + {$DEFINE DELPHI11_UP} + {$DEFINE DELPHI12_UP} + {$DEFINE DELPHI14_UP} +{$ENDIF} + +// Delphi XE +{$IFDEF VER220} + {$DEFINE SUPPORTS_INLINE} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI7_UP} + {$DEFINE DELPHI8_UP} + {$DEFINE DELPHI9_UP} + {$DEFINE DELPHI10_UP} + {$DEFINE DELPHI11_UP} + {$DEFINE DELPHI12_UP} + {$DEFINE DELPHI14_UP} + {$DEFINE DELPHI15_UP} +{$ENDIF} + +{$IFDEF VER230} + {$DEFINE SUPPORTS_INLINE} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI7_UP} + {$DEFINE DELPHI8_UP} + {$DEFINE DELPHI9_UP} + {$DEFINE DELPHI10_UP} + {$DEFINE DELPHI11_UP} + {$DEFINE DELPHI12_UP} + {$DEFINE DELPHI14_UP} + {$DEFINE DELPHI15_UP} + {$DEFINE DELPHI16_UP} +{$ENDIF} + +{$IFDEF VER240} + {$DEFINE SUPPORTS_INLINE} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI7_UP} + {$DEFINE DELPHI8_UP} + {$DEFINE DELPHI9_UP} + {$DEFINE DELPHI10_UP} + {$DEFINE DELPHI11_UP} + {$DEFINE DELPHI12_UP} + {$DEFINE DELPHI14_UP} + {$DEFINE DELPHI15_UP} + {$DEFINE DELPHI16_UP} + {$DEFINE DELPHI17_UP} +{$ENDIF} + +{$IFDEF VER250} + {$DEFINE SUPPORTS_INLINE} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI7_UP} + {$DEFINE DELPHI8_UP} + {$DEFINE DELPHI9_UP} + {$DEFINE DELPHI10_UP} + {$DEFINE DELPHI11_UP} + {$DEFINE DELPHI12_UP} + {$DEFINE DELPHI14_UP} + {$DEFINE DELPHI15_UP} + {$DEFINE DELPHI16_UP} + {$DEFINE DELPHI17_UP} + {$DEFINE DELPHI18_UP} +{$ENDIF} + +{$IFDEF VER260} + {$DEFINE SUPPORTS_INLINE} + {$DEFINE DELPHI5_UP} + {$DEFINE DELPHI6_UP} + {$DEFINE DELPHI7_UP} + {$DEFINE DELPHI8_UP} + {$DEFINE DELPHI9_UP} + {$DEFINE DELPHI10_UP} + {$DEFINE DELPHI11_UP} + {$DEFINE DELPHI12_UP} + {$DEFINE DELPHI14_UP} + {$DEFINE DELPHI15_UP} + {$DEFINE DELPHI16_UP} + {$DEFINE DELPHI17_UP} + {$DEFINE DELPHI18_UP} + {$DEFINE DELPHI19_UP} +{$ENDIF} \ No newline at end of file diff --git a/src/thirdparty/cefgui.pas b/src/thirdparty/cefgui.pas new file mode 100644 index 0000000..333d522 --- /dev/null +++ b/src/thirdparty/cefgui.pas @@ -0,0 +1,1138 @@ +(* + * Delphi Chromium Embedded 3 + * + * Usage allowed under the restrictions of the Lesser GNU General Public License + * or alternatively the restrictions of the Mozilla Public License 1.1 + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for + * the specific language governing rights and limitations under the License. + * + * Unit owner : Henri Gourvest + * Web site : http://www.progdigy.com + * Repository : http://code.google.com/p/delphichromiumembedded/ + * Group : http://groups.google.com/group/delphichromiumembedded + * + * Embarcadero Technologies, Inc is not permitted to use or redistribute + * this source code without explicit permission. + * + *) + +unit cefgui; + +{$I cef.inc} + +interface + +uses + Classes, ceflib; + +type + TOnProcessMessageReceived = procedure(Sender: TObject; const browser: ICefBrowser; + sourceProcess: TCefProcessId; const message: ICefProcessMessage; out Result: Boolean) of object; + + TOnLoadingStateChange = procedure(Sender: TObject; const browser: ICefBrowser; isLoading, canGoBack, canGoForward: Boolean) of object; + TOnLoadStart = procedure(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame) of object; + TOnLoadEnd = procedure(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; httpStatusCode: Integer) of object; + TOnLoadError = procedure(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; errorCode: Integer; + const errorText, failedUrl: ustring) of object; + TOnRenderProcessTerminated = procedure(Sender: TObject; const browser: ICefBrowser; status: TCefTerminationStatus) of object; + TOnPluginCrashed = procedure(Sender: TObject; const browser: ICefBrowser; const pluginPath: ustring) of object; + + TOnTakeFocus = procedure(Sender: TObject; const browser: ICefBrowser; next: Boolean) of object; + TOnSetFocus = procedure(Sender: TObject; const browser: ICefBrowser; source: TCefFocusSource; out Result: Boolean) of object; + TOnGotFocus = procedure(Sender: TObject; const browser: ICefBrowser) of object; + + TOnBeforeContextMenu = procedure(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; + const params: ICefContextMenuParams; const model: ICefMenuModel) of object; + TOnContextMenuCommand = procedure(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; + const params: ICefContextMenuParams; commandId: Integer; + eventFlags: TCefEventFlags; out Result: Boolean) of object; + TOnContextMenuDismissed = procedure(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame) of object; + + TOnPreKeyEvent = procedure(Sender: TObject; const browser: ICefBrowser; const event: PCefKeyEvent; + osEvent: TCefEventHandle; out isKeyboardShortcut: Boolean; out Result: Boolean) of object; + TOnKeyEvent = procedure(Sender: TObject; const browser: ICefBrowser; const event: PCefKeyEvent; + osEvent: TCefEventHandle; out Result: Boolean) of object; + + TOnAddressChange = procedure(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; const url: ustring) of object; + TOnTitleChange = procedure(Sender: TObject; const browser: ICefBrowser; const title: ustring) of object; + TOnTooltip = procedure(Sender: TObject; const browser: ICefBrowser; var text: ustring; out Result: Boolean) of object; + TOnStatusMessage = procedure(Sender: TObject; const browser: ICefBrowser; const value: ustring) of object; + TOnConsoleMessage = procedure(Sender: TObject; const browser: ICefBrowser; const message, source: ustring; line: Integer; out Result: Boolean) of object; + + TOnBeforeDownload = procedure(Sender: TObject; const browser: ICefBrowser; const downloadItem: ICefDownloadItem; + const suggestedName: ustring; const callback: ICefBeforeDownloadCallback) of object; + TOnDownloadUpdated = procedure(Sender: TObject; const browser: ICefBrowser; const downloadItem: ICefDownloadItem; + const callback: ICefDownloadItemCallback) of object; + + TOnRequestGeolocationPermission = procedure(Sender: TObject; const browser: ICefBrowser; + const requestingUrl: ustring; requestId: Integer; const callback: ICefGeolocationCallback) of object; + TOnCancelGeolocationPermission = procedure(Sender: TObject; const browser: ICefBrowser; + const requestingUrl: ustring; requestId: Integer) of object; + + TOnJsdialog = procedure(Sender: TObject; const browser: ICefBrowser; const originUrl, acceptLang: ustring; + dialogType: TCefJsDialogType; const messageText, defaultPromptText: ustring; + callback: ICefJsDialogCallback; out suppressMessage: Boolean; out Result: Boolean) of object; + TOnBeforeUnloadDialog = procedure(Sender: TObject; const browser: ICefBrowser; + const messageText: ustring; isReload: Boolean; + const callback: ICefJsDialogCallback; out Result: Boolean) of object; + TOnResetDialogState = procedure(Sender: TObject; const browser: ICefBrowser) of object; + TOnDialogClosed = procedure(Sender: TObject; const browser: ICefBrowser) of object; + TOnBeforePopup = procedure(Sender: TObject; const browser: ICefBrowser; + const frame: ICefFrame; const targetUrl, targetFrameName: ustring; + var popupFeatures: TCefPopupFeatures; var windowInfo: TCefWindowInfo; + var client: ICefClient; var settings: TCefBrowserSettings; + var noJavascriptAccess: Boolean; out Result: Boolean) of object; + + TOnAfterCreated = procedure(Sender: TObject; const browser: ICefBrowser) of object; + TOnBeforeClose = procedure(Sender: TObject; const browser: ICefBrowser) of object; + TOnRunModal = procedure(Sender: TObject; const browser: ICefBrowser; out Result: Boolean) of object; + TOnClose = procedure(Sender: TObject; const browser: ICefBrowser; out Result: Boolean) of object; + + TOnBeforeBrowse = procedure(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest; isRedirect: Boolean; out Result: Boolean) of object; + TOnBeforeResourceLoad = procedure(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest; out Result: Boolean) of object; + TOnGetResourceHandler = procedure(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest; out Result: ICefResourceHandler) of object; + TOnResourceRedirect = procedure(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; + const oldUrl: ustring; var newUrl: ustring) of object; + TOnGetAuthCredentials = procedure(Sender: TObject; const browser: ICefBrowser; const frame: ICefFrame; + isProxy: Boolean; const host: ustring; port: Integer; const realm, scheme: ustring; + const callback: ICefAuthCallback; out Result: Boolean) of object; + TOnQuotaRequest = procedure(Sender: TObject; const browser: ICefBrowser; + const originUrl: ustring; newSize: Int64; const callback: ICefQuotaCallback; + out Result: Boolean) of object; + TOnGetCookieManager = procedure(Sender: TObject; out Result: ICefCookieManager) of object; + TOnProtocolExecution = procedure(Sender: TObject; const browser: ICefBrowser; + const url: ustring; out allowOsExecution: Boolean) of object; + TOnBeforePluginLoad = procedure(Sender: TObject; const browser: ICefBrowser; + const url, policyUrl: ustring; const info: ICefWebPluginInfo; out Result: Boolean) of Object; + + TOnFileDialog = procedure(Sender: TObject; const browser: ICefBrowser; + mode: TCefFileDialogMode; const title, defaultFileName: ustring; + acceptTypes: TStrings; const callback: ICefFileDialogCallback; + out Result: Boolean) of Object; + + TOnGetRootScreenRect = procedure(Sender: TObject; const browser: ICefBrowser; + rect: PCefRect; out Result: Boolean) of Object; + TOnGetViewRect = procedure(Sender: TObject; const browser: ICefBrowser; + rect: PCefRect; out Result: Boolean) of Object; + TOnGetScreenPoint = procedure(Sender: TObject; const browser: ICefBrowser; + viewX, viewY: Integer; screenX, screenY: PInteger; out Result: Boolean) of Object; + TOnGetScreenInfo = procedure(Sender: TObject; const browser: ICefBrowser; + screenInfo: PCefScreenInfo; Result: Boolean) of Object; + TOnPopupShow = procedure(Sender: TObject; const browser: ICefBrowser; + show: Boolean) of Object; + TOnPopupSize = procedure(Sender: TObject; const browser: ICefBrowser; + const rect: PCefRect) of Object; + TOnPaint = procedure(Sender: TObject; const browser: ICefBrowser; + kind: TCefPaintElementType; dirtyRectsCount: NativeUInt; const dirtyRects: PCefRectArray; + const buffer: Pointer; width, height: Integer) of Object; + TOnCursorChange = procedure(Sender: TObject; const browser: ICefBrowser; + cursor: TCefCursorHandle) of Object; + TOnScrollOffsetChanged = procedure(Sender: TObject; const browser: ICefBrowser) of Object; + + TOnDragEnter = procedure(Sender: TObject; const browser: ICefBrowser; + const dragData: ICefDragData; mask: TCefDragOperations; out Result: Boolean) of Object; + + TChromiumOptions = class(TPersistent) + private + FJavascript: TCefState; + FJavascriptOpenWindows: TCefState; + FJavascriptCloseWindows: TCefState; + FJavascriptAccessClipboard: TCefState; + FJavascriptDomPaste: TCefState; + FCaretBrowsing: TCefState; + FJava: TCefState; + FPlugins: TCefState; + FUniversalAccessFromFileUrls: TCefState; + FFileAccessFromFileUrls: TCefState; + FWebSecurity: TCefState; + FImageLoading: TCefState; + FImageShrinkStandaloneToFit: TCefState; + FTextAreaResize: TCefState; + FTabToLinks: TCefState; + FAuthorAndUserStyles: TCefState; + FLocalStorage: TCefState; + FDatabases: TCefState; + FApplicationCache: TCefState; + FWebgl: TCefState; + FAcceleratedCompositing: TCefState; + published + property Javascript: TCefState read FJavascript write FJavascript default STATE_DEFAULT; + property JavascriptOpenWindows: TCefState read FJavascriptOpenWindows write FJavascriptOpenWindows default STATE_DEFAULT; + property JavascriptCloseWindows: TCefState read FJavascriptCloseWindows write FJavascriptCloseWindows default STATE_DEFAULT; + property JavascriptAccessClipboard: TCefState read FJavascriptAccessClipboard write FJavascriptAccessClipboard default STATE_DEFAULT; + property JavascriptDomPaste: TCefState read FJavascriptDomPaste write FJavascriptDomPaste default STATE_DEFAULT; + property CaretBrowsing: TCefState read FCaretBrowsing write FCaretBrowsing default STATE_DEFAULT; + property Java: TCefState read FJava write FJava default STATE_DEFAULT; + property Plugins: TCefState read FPlugins write FPlugins default STATE_DEFAULT; + property UniversalAccessFromFileUrls: TCefState read FUniversalAccessFromFileUrls write FUniversalAccessFromFileUrls default STATE_DEFAULT; + property FileAccessFromFileUrls: TCefState read FFileAccessFromFileUrls write FFileAccessFromFileUrls default STATE_DEFAULT; + property WebSecurity: TCefState read FWebSecurity write FWebSecurity default STATE_DEFAULT; + property ImageLoading: TCefState read FImageLoading write FImageLoading default STATE_DEFAULT; + property ImageShrinkStandaloneToFit: TCefState read FImageShrinkStandaloneToFit write FImageShrinkStandaloneToFit default STATE_DEFAULT; + property TextAreaResize: TCefState read FTextAreaResize write FTextAreaResize default STATE_DEFAULT; + property TabToLinks: TCefState read FTabToLinks write FTabToLinks default STATE_DEFAULT; + property AuthorAndUserStyles: TCefState read FAuthorAndUserStyles write FAuthorAndUserStyles default STATE_DEFAULT; + property LocalStorage: TCefState read FLocalStorage write FLocalStorage default STATE_DEFAULT; + property Databases: TCefState read FDatabases write FDatabases default STATE_DEFAULT; + property ApplicationCache: TCefState read FApplicationCache write FApplicationCache default STATE_DEFAULT; + property Webgl: TCefState read FWebgl write FWebgl default STATE_DEFAULT; + property AcceleratedCompositing: TCefState read FAcceleratedCompositing write FAcceleratedCompositing default STATE_DEFAULT; + end; + + TChromiumFontOptions = class(TPersistent) + private + FStandardFontFamily: ustring; + FCursiveFontFamily: ustring; + FSansSerifFontFamily: ustring; + FMinimumLogicalFontSize: Integer; + FFantasyFontFamily: ustring; + FSerifFontFamily: ustring; + FDefaultFixedFontSize: Integer; + FDefaultFontSize: Integer; + FRemoteFontsDisabled: TCefState; + FFixedFontFamily: ustring; + FMinimumFontSize: Integer; + public + constructor Create; virtual; + published + property StandardFontFamily: ustring read FStandardFontFamily; + property FixedFontFamily: ustring read FFixedFontFamily write FFixedFontFamily; + property SerifFontFamily: ustring read FSerifFontFamily write FSerifFontFamily; + property SansSerifFontFamily: ustring read FSansSerifFontFamily write FSansSerifFontFamily; + property CursiveFontFamily: ustring read FCursiveFontFamily write FCursiveFontFamily; + property FantasyFontFamily: ustring read FFantasyFontFamily write FFantasyFontFamily; + property DefaultFontSize: Integer read FDefaultFontSize write FDefaultFontSize default 0; + property DefaultFixedFontSize: Integer read FDefaultFixedFontSize write FDefaultFixedFontSize default 0; + property MinimumFontSize: Integer read FMinimumFontSize write FMinimumFontSize default 0; + property MinimumLogicalFontSize: Integer read FMinimumLogicalFontSize write FMinimumLogicalFontSize default 0; + property RemoteFonts: TCefState read FRemoteFontsDisabled write FRemoteFontsDisabled default STATE_DEFAULT; + end; + + IChromiumEvents = interface + ['{0C139DB1-0349-4D7F-8155-76FEA6A0126D}'] + procedure GetSettings(var settings: TCefBrowserSettings); + function doOnProcessMessageReceived(const browser: ICefBrowser; + sourceProcess: TCefProcessId; const message: ICefProcessMessage): Boolean; + + procedure doOnLoadingStateChange(const browser: ICefBrowser; isLoading, canGoBack, canGoForward: Boolean); + procedure doOnLoadStart(const browser: ICefBrowser; const frame: ICefFrame); + procedure doOnLoadEnd(const browser: ICefBrowser; const frame: ICefFrame; httpStatusCode: Integer); + procedure doOnLoadError(const browser: ICefBrowser; const frame: ICefFrame; errorCode: Integer; + const errorText, failedUrl: ustring); + procedure doOnRenderProcessTerminated(const browser: ICefBrowser; status: TCefTerminationStatus); + procedure doOnPluginCrashed(const browser: ICefBrowser; const pluginPath: ustring); + + procedure doOnTakeFocus(const browser: ICefBrowser; next: Boolean); + function doOnSetFocus(const browser: ICefBrowser; source: TCefFocusSource): Boolean; + procedure doOnGotFocus(const browser: ICefBrowser); + + procedure doOnBeforeContextMenu(const browser: ICefBrowser; const frame: ICefFrame; + const params: ICefContextMenuParams; const model: ICefMenuModel); + function doOnContextMenuCommand(const browser: ICefBrowser; const frame: ICefFrame; + const params: ICefContextMenuParams; commandId: Integer; + eventFlags: TCefEventFlags): Boolean; + procedure doOnContextMenuDismissed(const browser: ICefBrowser; const frame: ICefFrame); + + function doOnPreKeyEvent(const browser: ICefBrowser; const event: PCefKeyEvent; + osEvent: TCefEventHandle; out isKeyboardShortcut: Boolean): Boolean; + function doOnKeyEvent(const browser: ICefBrowser; const event: PCefKeyEvent; + osEvent: TCefEventHandle): Boolean; + + procedure doOnAddressChange(const browser: ICefBrowser; const frame: ICefFrame; const url: ustring); + procedure doOnTitleChange(const browser: ICefBrowser; const title: ustring); + function doOnTooltip(const browser: ICefBrowser; var text: ustring): Boolean; + procedure doOnStatusMessage(const browser: ICefBrowser; const value: ustring); + function doOnConsoleMessage(const browser: ICefBrowser; const message, source: ustring; line: Integer): Boolean; + + procedure doOnRequestGeolocationPermission(const browser: ICefBrowser; + const requestingUrl: ustring; requestId: Integer; const callback: ICefGeolocationCallback); + procedure doOnCancelGeolocationPermission(const browser: ICefBrowser; + const requestingUrl: ustring; requestId: Integer); + + procedure doOnBeforeDownload(const browser: ICefBrowser; const downloadItem: ICefDownloadItem; + const suggestedName: ustring; const callback: ICefBeforeDownloadCallback); + procedure doOnDownloadUpdated(const browser: ICefBrowser; const downloadItem: ICefDownloadItem; + const callback: ICefDownloadItemCallback); + + function doOnJsdialog(const browser: ICefBrowser; const originUrl, acceptLang: ustring; + dialogType: TCefJsDialogType; const messageText, defaultPromptText: ustring; + callback: ICefJsDialogCallback; out suppressMessage: Boolean): Boolean; + function doOnBeforeUnloadDialog(const browser: ICefBrowser; + const messageText: ustring; isReload: Boolean; + const callback: ICefJsDialogCallback): Boolean; + procedure doOnResetDialogState(const browser: ICefBrowser); + procedure doOnDialogClosed(const browser: ICefBrowser); + + function doOnBeforePopup(const browser: ICefBrowser; + const frame: ICefFrame; const targetUrl, targetFrameName: ustring; + var popupFeatures: TCefPopupFeatures; var windowInfo: TCefWindowInfo; + var client: ICefClient; var settings: TCefBrowserSettings; + var noJavascriptAccess: Boolean): Boolean; + procedure doOnAfterCreated(const browser: ICefBrowser); + procedure doOnBeforeClose(const browser: ICefBrowser); + function doOnRunModal(const browser: ICefBrowser): Boolean; + function doOnClose(const browser: ICefBrowser): Boolean; + + function doOnBeforeBrowse(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest; isRedirect: Boolean): Boolean; + function doOnBeforeResourceLoad(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest): Boolean; + function doOnGetResourceHandler(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest): ICefResourceHandler; + procedure doOnResourceRedirect(const browser: ICefBrowser; const frame: ICefFrame; + const oldUrl: ustring; var newUrl: ustring); + function doOnGetAuthCredentials(const browser: ICefBrowser; const frame: ICefFrame; + isProxy: Boolean; const host: ustring; port: Integer; const realm, scheme: ustring; + const callback: ICefAuthCallback): Boolean; + function doOnQuotaRequest(const browser: ICefBrowser; const originUrl: ustring; + newSize: Int64; const callback: ICefQuotaCallback): Boolean; + function doOnGetCookieManager: ICefCookieManager; + procedure doOnProtocolExecution(const browser: ICefBrowser; const url: ustring; out allowOsExecution: Boolean); + function doOnBeforePluginLoad(const browser: ICefBrowser; const url, policyUrl: ustring; + const info: ICefWebPluginInfo): Boolean; + + function doOnFileDialog(const browser: ICefBrowser; mode: TCefFileDialogMode; + const title, defaultFileName: ustring; acceptTypes: TStrings; + const callback: ICefFileDialogCallback): Boolean; + + function doOnGetRootScreenRect(const browser: ICefBrowser; rect: PCefRect): Boolean; + function doOnGetViewRect(const browser: ICefBrowser; rect: PCefRect): Boolean; + function doOnGetScreenPoint(const browser: ICefBrowser; viewX, viewY: Integer; + screenX, screenY: PInteger): Boolean; + function doOnGetScreenInfo(const browser: ICefBrowser; screenInfo: PCefScreenInfo): Boolean; + procedure doOnPopupShow(const browser: ICefBrowser; show: Boolean); + procedure doOnPopupSize(const browser: ICefBrowser; const rect: PCefRect); + procedure doOnPaint(const browser: ICefBrowser; kind: TCefPaintElementType; + dirtyRectsCount: NativeUInt; const dirtyRects: PCefRectArray; + const buffer: Pointer; width, height: Integer); + procedure doOnCursorChange(const browser: ICefBrowser; cursor: TCefCursorHandle); + procedure doOnScrollOffsetChanged(const browser: ICefBrowser); + + function doOnDragEnter(const browser: ICefBrowser; const dragData: ICefDragData; + mask: TCefDragOperations): Boolean; + end; + + ICefClientHandler = interface + ['{E76F6888-D9C3-4FCE-9C23-E89659820A36}'] + procedure Disconnect; + function GetRequestContextHandler: ICefRequestContextHandler; + end; + + TCustomClientHandler = class(TCefClientOwn, ICefClientHandler) + private + FEvents: IChromiumEvents; + FLoadHandler: ICefLoadHandler; + FFocusHandler: ICefFocusHandler; + FContextMenuHandler: ICefContextMenuHandler; + FDialogHandler: ICefDialogHandler; + FKeyboardHandler: ICefKeyboardHandler; + FDisplayHandler: ICefDisplayHandler; + FDownloadHandler: ICefDownloadHandler; + FGeolocationHandler: ICefGeolocationHandler; + FJsDialogHandler: ICefJsDialogHandler; + FLifeSpanHandler: ICefLifeSpanHandler; + FRenderHandler: ICefRenderHandler; + FRequestHandler: ICefRequestHandler; + FDragHandler: ICefDragHandler; + FRequestContextHandler: ICefRequestContextHandler; + protected + function GetContextMenuHandler: ICefContextMenuHandler; override; + function GetDialogHandler: ICefDialogHandler; override; + function GetDisplayHandler: ICefDisplayHandler; override; + function GetDownloadHandler: ICefDownloadHandler; override; + function GetFocusHandler: ICefFocusHandler; override; + function GetGeolocationHandler: ICefGeolocationHandler; override; + function GetJsdialogHandler: ICefJsdialogHandler; override; + function GetKeyboardHandler: ICefKeyboardHandler; override; + function GetLifeSpanHandler: ICefLifeSpanHandler; override; + function GetRenderHandler: ICefRenderHandler; override; + function GetLoadHandler: ICefLoadHandler; override; + function GetRequestHandler: ICefRequestHandler; override; + function GetRequestContextHandler: ICefRequestContextHandler; + function OnProcessMessageReceived(const browser: ICefBrowser; + sourceProcess: TCefProcessId; const message: ICefProcessMessage): Boolean; override; + procedure Disconnect; + public + constructor Create(const events: IChromiumEvents; renderer: Boolean); reintroduce; virtual; + end; + + TCustomClientHandlerClass = class of TCustomClientHandler; + + TCustomLoadHandler = class(TCefLoadHandlerOwn) + private + FEvent: IChromiumEvents; + protected + procedure OnLoadingStateChange(const browser: ICefBrowser; isLoading, + canGoBack, canGoForward: Boolean); override; + procedure OnLoadStart(const browser: ICefBrowser; const frame: ICefFrame); override; + procedure OnLoadEnd(const browser: ICefBrowser; const frame: ICefFrame; httpStatusCode: Integer); override; + procedure OnLoadError(const browser: ICefBrowser; const frame: ICefFrame; errorCode: Integer; + const errorText, failedUrl: ustring); override; + public + constructor Create(const events: IChromiumEvents); reintroduce; virtual; + end; + + TCustomFocusHandler = class(TCefFocusHandlerOwn) + private + FEvent: IChromiumEvents; + protected + procedure OnTakeFocus(const browser: ICefBrowser; next: Boolean); override; + function OnSetFocus(const browser: ICefBrowser; source: TCefFocusSource): Boolean; override; + procedure OnGotFocus(const browser: ICefBrowser); override; + public + constructor Create(const events: IChromiumEvents); reintroduce; virtual; + end; + + TCustomContextMenuHandler = class(TCefContextMenuHandlerOwn) + private + FEvent: IChromiumEvents; + protected + procedure OnBeforeContextMenu(const browser: ICefBrowser; const frame: ICefFrame; + const params: ICefContextMenuParams; const model: ICefMenuModel); override; + function OnContextMenuCommand(const browser: ICefBrowser; const frame: ICefFrame; + const params: ICefContextMenuParams; commandId: Integer; + eventFlags: TCefEventFlags): Boolean; override; + procedure OnContextMenuDismissed(const browser: ICefBrowser; const frame: ICefFrame); override; + public + constructor Create(const events: IChromiumEvents); reintroduce; virtual; + end; + + TCustomDialogHandler = class(TCefDialogHandlerOwn) + private + FEvent: IChromiumEvents; + protected + function OnFileDialog(const browser: ICefBrowser; mode: TCefFileDialogMode; + const title: ustring; const defaultFileName: ustring; + acceptTypes: TStrings; const callback: ICefFileDialogCallback): Boolean; override; + public + constructor Create(const events: IChromiumEvents); reintroduce; virtual; + end; + + TCustomKeyboardHandler = class(TCefKeyboardHandlerOwn) + private + FEvent: IChromiumEvents; + protected + function OnPreKeyEvent(const browser: ICefBrowser; const event: PCefKeyEvent; + osEvent: TCefEventHandle; out isKeyboardShortcut: Boolean): Boolean; override; + function OnKeyEvent(const browser: ICefBrowser; const event: PCefKeyEvent; + osEvent: TCefEventHandle): Boolean; override; + public + constructor Create(const events: IChromiumEvents); reintroduce; virtual; + end; + + TCustomDisplayHandler = class(TCefDisplayHandlerOwn) + private + FEvent: IChromiumEvents; + protected + procedure OnAddressChange(const browser: ICefBrowser; const frame: ICefFrame; const url: ustring); override; + procedure OnTitleChange(const browser: ICefBrowser; const title: ustring); override; + function OnTooltip(const browser: ICefBrowser; var text: ustring): Boolean; override; + procedure OnStatusMessage(const browser: ICefBrowser; const value: ustring); override; + function OnConsoleMessage(const browser: ICefBrowser; const message, source: ustring; line: Integer): Boolean; override; + public + constructor Create(const events: IChromiumEvents); reintroduce; virtual; + end; + + TCustomDownloadHandler = class(TCefDownloadHandlerOwn) + private + FEvent: IChromiumEvents; + protected + procedure OnBeforeDownload(const browser: ICefBrowser; const downloadItem: ICefDownloadItem; + const suggestedName: ustring; const callback: ICefBeforeDownloadCallback); override; + procedure OnDownloadUpdated(const browser: ICefBrowser; const downloadItem: ICefDownloadItem; + const callback: ICefDownloadItemCallback); override; + public + constructor Create(const events: IChromiumEvents); reintroduce; virtual; + end; + + TCustomGeolocationHandler = class(TCefGeolocationHandlerOwn) + private + FEvent: IChromiumEvents; + protected + procedure OnRequestGeolocationPermission(const browser: ICefBrowser; + const requestingUrl: ustring; requestId: Integer; const callback: ICefGeolocationCallback); override; + procedure OnCancelGeolocationPermission(const browser: ICefBrowser; + const requestingUrl: ustring; requestId: Integer); override; + public + constructor Create(const events: IChromiumEvents); reintroduce; virtual; + end; + + TCustomJsDialogHandler = class(TCefJsDialogHandlerOwn) + private + FEvent: IChromiumEvents; + protected + function OnJsdialog(const browser: ICefBrowser; const originUrl, acceptLang: ustring; + dialogType: TCefJsDialogType; const messageText, defaultPromptText: ustring; + callback: ICefJsDialogCallback; out suppressMessage: Boolean): Boolean; override; + function OnBeforeUnloadDialog(const browser: ICefBrowser; + const messageText: ustring; isReload: Boolean; + const callback: ICefJsDialogCallback): Boolean; override; + procedure OnResetDialogState(const browser: ICefBrowser); override; + procedure OnDialogClosed(const browser: ICefBrowser); override; + public + constructor Create(const events: IChromiumEvents); reintroduce; virtual; + end; + + TCustomLifeSpanHandler = class(TCefLifeSpanHandlerOwn) + private + FEvent: IChromiumEvents; + protected + function OnBeforePopup(const browser: ICefBrowser; const frame: ICefFrame; + const targetUrl, targetFrameName: ustring; var popupFeatures: TCefPopupFeatures; + var windowInfo: TCefWindowInfo; var client: ICefClient; var settings: TCefBrowserSettings; + var noJavascriptAccess: Boolean): Boolean; override; + procedure OnAfterCreated(const browser: ICefBrowser); override; + procedure OnBeforeClose(const browser: ICefBrowser); override; + function RunModal(const browser: ICefBrowser): Boolean; override; + function DoClose(const browser: ICefBrowser): Boolean; override; + public + constructor Create(const events: IChromiumEvents); reintroduce; virtual; + end; + + TCustomRequestHandler = class(TCefRequestHandlerOwn) + private + FEvent: IChromiumEvents; + protected + function OnBeforeBrowse(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest; isRedirect: Boolean): Boolean; override; + function OnBeforeResourceLoad(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest): Boolean; override; + function GetResourceHandler(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest): ICefResourceHandler; override; + procedure OnResourceRedirect(const browser: ICefBrowser; const frame: ICefFrame; + const oldUrl: ustring; var newUrl: ustring); override; + function GetAuthCredentials(const browser: ICefBrowser; const frame: ICefFrame; + isProxy: Boolean; const host: ustring; port: Integer; const realm, scheme: ustring; + const callback: ICefAuthCallback): Boolean; override; + function OnQuotaRequest(const browser: ICefBrowser; const originUrl: ustring; + newSize: Int64; const callback: ICefQuotaCallback): Boolean; override; + procedure OnProtocolExecution(const browser: ICefBrowser; const url: ustring; out allowOsExecution: Boolean); override; + function OnBeforePluginLoad(const browser: ICefBrowser; const url: ustring; + const policyUrl: ustring; const info: ICefWebPluginInfo): Boolean; override; + procedure OnPluginCrashed(const browser: ICefBrowser; const pluginPath: ustring); override; + procedure OnRenderProcessTerminated(const browser: ICefBrowser; status: TCefTerminationStatus); override; + public + constructor Create(const events: IChromiumEvents); reintroduce; virtual; + end; + + TCustomRenderHandler = class(TCefRenderHandlerOwn) + private + FEvent: IChromiumEvents; + protected + function GetRootScreenRect(const browser: ICefBrowser; rect: PCefRect): Boolean; override; + function GetViewRect(const browser: ICefBrowser; rect: PCefRect): Boolean; override; + function GetScreenPoint(const browser: ICefBrowser; viewX, viewY: Integer; + screenX, screenY: PInteger): Boolean; override; + procedure OnPopupShow(const browser: ICefBrowser; show: Boolean); override; + procedure OnPopupSize(const browser: ICefBrowser; const rect: PCefRect); override; + procedure OnPaint(const browser: ICefBrowser; kind: TCefPaintElementType; + dirtyRectsCount: NativeUInt; const dirtyRects: PCefRectArray; + const buffer: Pointer; width, height: Integer); override; + procedure OnCursorChange(const browser: ICefBrowser; cursor: TCefCursorHandle); override; + function GetScreenInfo(const browser: ICefBrowser; + screenInfo: PCefScreenInfo): Boolean; override; + procedure OnScrollOffsetChanged(const browser: ICefBrowser); override; + public + constructor Create(const events: IChromiumEvents); reintroduce; virtual; + end; + + TCustomDragHandler = class(TCefDragHandlerOwn) + private + FEvent: IChromiumEvents; + protected + function OnDragEnter(const browser: ICefBrowser; + const dragData: ICefDragData; mask: TCefDragOperations): Boolean; override; + public + constructor Create(const events: IChromiumEvents); reintroduce; virtual; + end; + + TCustomRequestContextHandler = class(TCefRequestContextHandlerOwn) + private + FEvent: IChromiumEvents; + protected + function GetCookieManager: ICefCookieManager; override; + public + constructor Create(const events: IChromiumEvents); reintroduce; virtual; + end; + +implementation + +{ TChromiumFontOptions } + +constructor TChromiumFontOptions.Create; +begin + FStandardFontFamily := ''; + FCursiveFontFamily := ''; + FSansSerifFontFamily := ''; + FMinimumLogicalFontSize := 0; + FFantasyFontFamily := ''; + FSerifFontFamily := ''; + FDefaultFixedFontSize := 0; + FDefaultFontSize := 0; + FRemoteFontsDisabled := STATE_DEFAULT; + FFixedFontFamily := ''; + FMinimumFontSize := 0; +end; + +{ TCefCustomHandler } + +constructor TCustomClientHandler.Create(const events: IChromiumEvents; renderer: Boolean); +begin + inherited Create; + FEvents := events; + FLoadHandler := TCustomLoadHandler.Create(events); + FFocusHandler := TCustomFocusHandler.Create(events); + FContextMenuHandler := TCustomContextMenuHandler.Create(events); + FDialogHandler := TCustomDialogHandler.Create(events); + FKeyboardHandler := TCustomKeyboardHandler.Create(events); + FDisplayHandler := TCustomDisplayHandler.Create(events); + FDownloadHandler := TCustomDownloadHandler.Create(events); + FGeolocationHandler := TCustomGeolocationHandler.Create(events); + FJsDialogHandler := TCustomJsDialogHandler.Create(events); + FLifeSpanHandler := TCustomLifeSpanHandler.Create(events); + FRequestHandler := TCustomRequestHandler.Create(events); + FRequestContextHandler := TCustomRequestContextHandler.Create(events); + if renderer then + FRenderHandler := TCustomRenderHandler.Create(events) else + FRenderHandler := nil; + FDragHandler := TCustomDragHandler.Create(events); +end; + +procedure TCustomClientHandler.Disconnect; +begin + FEvents := nil; + FLoadHandler := nil; + FFocusHandler := nil; + FContextMenuHandler := nil; + FDialogHandler := nil; + FKeyboardHandler := nil; + FDisplayHandler := nil; + FDownloadHandler := nil; + FGeolocationHandler := nil; + FJsDialogHandler := nil; + FLifeSpanHandler := nil; + FRequestHandler := nil; + FRenderHandler := nil; + FDragHandler := nil; + FRequestContextHandler := nil; +end; + +function TCustomClientHandler.GetContextMenuHandler: ICefContextMenuHandler; +begin + Result := FContextMenuHandler; +end; + +function TCustomClientHandler.GetDialogHandler: ICefDialogHandler; +begin + Result := FDialogHandler; +end; + +function TCustomClientHandler.GetDisplayHandler: ICefDisplayHandler; +begin + Result := FDisplayHandler; +end; + +function TCustomClientHandler.GetDownloadHandler: ICefDownloadHandler; +begin + Result := FDownloadHandler; +end; + +function TCustomClientHandler.GetFocusHandler: ICefFocusHandler; +begin + Result := FFocusHandler; +end; + +function TCustomClientHandler.GetGeolocationHandler: ICefGeolocationHandler; +begin + Result := FGeolocationHandler; +end; + +function TCustomClientHandler.GetJsdialogHandler: ICefJsDialogHandler; +begin + Result := FJsDialogHandler; +end; + +function TCustomClientHandler.GetKeyboardHandler: ICefKeyboardHandler; +begin + Result := FKeyboardHandler; +end; + +function TCustomClientHandler.GetLifeSpanHandler: ICefLifeSpanHandler; +begin + Result := FLifeSpanHandler; +end; + +function TCustomClientHandler.GetLoadHandler: ICefLoadHandler; +begin + Result := FLoadHandler; +end; + +function TCustomClientHandler.GetRenderHandler: ICefRenderHandler; +begin + Result := FRenderHandler; +end; + +function TCustomClientHandler.GetRequestContextHandler: ICefRequestContextHandler; +begin + Result := FRequestContextHandler; +end; + +function TCustomClientHandler.GetRequestHandler: ICefRequestHandler; +begin + Result := FRequestHandler; +end; + +function TCustomClientHandler.OnProcessMessageReceived( + const browser: ICefBrowser; sourceProcess: TCefProcessId; + const message: ICefProcessMessage): Boolean; +begin + Result := FEvents.doOnProcessMessageReceived(browser, sourceProcess, message); +end; + +{ TCustomLoadHandler } + +constructor TCustomLoadHandler.Create(const events: IChromiumEvents); +begin + inherited Create; + FEvent := events; +end; + +procedure TCustomLoadHandler.OnLoadEnd(const browser: ICefBrowser; + const frame: ICefFrame; httpStatusCode: Integer); +begin + FEvent.doOnLoadEnd(browser, frame, httpStatusCode); +end; + +procedure TCustomLoadHandler.OnLoadError(const browser: ICefBrowser; + const frame: ICefFrame; errorCode: Integer; const errorText, + failedUrl: ustring); +begin + FEvent.doOnLoadError(browser, frame, errorCode, errorText, failedUrl); +end; + +procedure TCustomLoadHandler.OnLoadingStateChange(const browser: ICefBrowser; + isLoading, canGoBack, canGoForward: Boolean); +begin + FEvent.doOnLoadingStateChange(browser, isLoading, canGoBack, canGoForward); +end; + +procedure TCustomLoadHandler.OnLoadStart(const browser: ICefBrowser; + const frame: ICefFrame); +begin + FEvent.doOnLoadStart(browser, frame); +end; + +{ TCustomFocusHandler } + +constructor TCustomFocusHandler.Create(const events: IChromiumEvents); +begin + inherited Create; + FEvent := events; +end; + +procedure TCustomFocusHandler.OnGotFocus(const browser: ICefBrowser); +begin + FEvent.doOnGotFocus(browser); +end; + +function TCustomFocusHandler.OnSetFocus(const browser: ICefBrowser; + source: TCefFocusSource): Boolean; +begin + Result := FEvent.doOnSetFocus(browser, source); +end; + +procedure TCustomFocusHandler.OnTakeFocus(const browser: ICefBrowser; + next: Boolean); +begin + FEvent.doOnTakeFocus(browser, next); +end; + +{ TCustomContextMenuHandler } + +constructor TCustomContextMenuHandler.Create(const events: IChromiumEvents); +begin + inherited Create; + FEvent := events; +end; + +procedure TCustomContextMenuHandler.OnBeforeContextMenu( + const browser: ICefBrowser; const frame: ICefFrame; + const params: ICefContextMenuParams; const model: ICefMenuModel); +begin + FEvent.doOnBeforeContextMenu(browser, frame, params, model); +end; + +function TCustomContextMenuHandler.OnContextMenuCommand( + const browser: ICefBrowser; const frame: ICefFrame; + const params: ICefContextMenuParams; commandId: Integer; + eventFlags: TCefEventFlags): Boolean; +begin + Result := FEvent.doOnContextMenuCommand(browser, frame, params, commandId, + eventFlags); +end; + +procedure TCustomContextMenuHandler.OnContextMenuDismissed( + const browser: ICefBrowser; const frame: ICefFrame); +begin + FEvent.doOnContextMenuDismissed(browser, frame); +end; + +{ TCustomKeyboardHandler } + +constructor TCustomKeyboardHandler.Create(const events: IChromiumEvents); +begin + inherited Create; + FEvent := events; +end; + +function TCustomKeyboardHandler.OnKeyEvent(const browser: ICefBrowser; + const event: PCefKeyEvent; osEvent: TCefEventHandle): Boolean; +begin + Result := FEvent.doOnKeyEvent(browser, event, osEvent); +end; + +function TCustomKeyboardHandler.OnPreKeyEvent(const browser: ICefBrowser; + const event: PCefKeyEvent; osEvent: TCefEventHandle; + out isKeyboardShortcut: Boolean): Boolean; +begin + Result := FEvent.doOnPreKeyEvent(browser, event, osEvent, isKeyboardShortcut); +end; + +{ TCustomDisplayHandler } + +constructor TCustomDisplayHandler.Create(const events: IChromiumEvents); +begin + inherited Create; + FEvent := events; +end; + +procedure TCustomDisplayHandler.OnAddressChange(const browser: ICefBrowser; + const frame: ICefFrame; const url: ustring); +begin + FEvent.doOnAddressChange(browser, frame, url); +end; + +function TCustomDisplayHandler.OnConsoleMessage(const browser: ICefBrowser; + const message, source: ustring; line: Integer): Boolean; +begin + Result := FEvent.doOnConsoleMessage(browser, message, source, line); +end; + +procedure TCustomDisplayHandler.OnStatusMessage(const browser: ICefBrowser; + const value: ustring); +begin + FEvent.doOnStatusMessage(browser, value); +end; + +procedure TCustomDisplayHandler.OnTitleChange(const browser: ICefBrowser; + const title: ustring); +begin + FEvent.doOnTitleChange(browser, title); +end; + +function TCustomDisplayHandler.OnTooltip(const browser: ICefBrowser; + var text: ustring): Boolean; +begin + Result := FEvent.doOnTooltip(browser, text); +end; + +{ TCustomDownloadHandler } + +constructor TCustomDownloadHandler.Create(const events: IChromiumEvents); +begin + inherited Create; + FEvent := events; +end; + +procedure TCustomDownloadHandler.OnBeforeDownload(const browser: ICefBrowser; + const downloadItem: ICefDownloadItem; const suggestedName: ustring; + const callback: ICefBeforeDownloadCallback); +begin + FEvent.doOnBeforeDownload(browser, downloadItem, suggestedName, callback); +end; + +procedure TCustomDownloadHandler.OnDownloadUpdated(const browser: ICefBrowser; + const downloadItem: ICefDownloadItem; + const callback: ICefDownloadItemCallback); +begin + FEvent.doOnDownloadUpdated(browser, downloadItem, callback); +end; + +{ TCustomGeolocationHandler } + +constructor TCustomGeolocationHandler.Create(const events: IChromiumEvents); +begin + inherited Create; + FEvent := events; +end; + +procedure TCustomGeolocationHandler.OnCancelGeolocationPermission( + const browser: ICefBrowser; const requestingUrl: ustring; requestId: Integer); +begin + FEvent.doOnCancelGeolocationPermission(browser, requestingUrl, requestId); +end; + +procedure TCustomGeolocationHandler.OnRequestGeolocationPermission( + const browser: ICefBrowser; const requestingUrl: ustring; requestId: Integer; + const callback: ICefGeolocationCallback); +begin + FEvent.doOnRequestGeolocationPermission(browser, requestingUrl, requestId, callback); +end; + +{ TCustomJsDialogHandler } + +constructor TCustomJsDialogHandler.Create(const events: IChromiumEvents); +begin + inherited Create; + FEvent := events; +end; + +function TCustomJsDialogHandler.OnBeforeUnloadDialog(const browser: ICefBrowser; + const messageText: ustring; isReload: Boolean; + const callback: ICefJsDialogCallback): Boolean; +begin + Result := FEvent.doOnBeforeUnloadDialog(browser, messageText, isReload, callback); +end; + +procedure TCustomJsDialogHandler.OnDialogClosed(const browser: ICefBrowser); +begin + FEvent.doOnDialogClosed(browser); +end; + +function TCustomJsDialogHandler.OnJsdialog(const browser: ICefBrowser; + const originUrl, acceptLang: ustring; dialogType: TCefJsDialogType; + const messageText, defaultPromptText: ustring; callback: ICefJsDialogCallback; + out suppressMessage: Boolean): Boolean; +begin + Result := FEvent.doOnJsdialog(browser, originUrl, acceptLang, dialogType, + messageText, defaultPromptText, callback, suppressMessage); +end; + +procedure TCustomJsDialogHandler.OnResetDialogState(const browser: ICefBrowser); +begin + FEvent.doOnResetDialogState(browser); +end; + +{ TCustomLifeSpanHandler } + +constructor TCustomLifeSpanHandler.Create(const events: IChromiumEvents); +begin + inherited Create; + FEvent := events; +end; + +function TCustomLifeSpanHandler.DoClose(const browser: ICefBrowser): Boolean; +begin + Result := FEvent.doOnClose(browser); +end; + +procedure TCustomLifeSpanHandler.OnAfterCreated(const browser: ICefBrowser); +begin + FEvent.doOnAfterCreated(browser); +end; + +procedure TCustomLifeSpanHandler.OnBeforeClose(const browser: ICefBrowser); +begin + FEvent.doOnBeforeClose(browser); +end; + + +function TCustomLifeSpanHandler.OnBeforePopup(const browser: ICefBrowser; + const frame: ICefFrame; const targetUrl, targetFrameName: ustring; + var popupFeatures: TCefPopupFeatures; var windowInfo: TCefWindowInfo; + var client: ICefClient; var settings: TCefBrowserSettings; + var noJavascriptAccess: Boolean): Boolean; +begin + Result := FEvent.doOnBeforePopup(browser, frame, targetUrl, targetFrameName, + popupFeatures, windowInfo, client, settings, noJavascriptAccess); +end; + +function TCustomLifeSpanHandler.RunModal(const browser: ICefBrowser): Boolean; +begin + Result := FEvent.doOnRunModal(browser); +end; + +{ TCustomRequestHandler } + +constructor TCustomRequestHandler.Create(const events: IChromiumEvents); +begin + inherited Create; + FEvent := events; +end; + +function TCustomRequestHandler.GetAuthCredentials(const browser: ICefBrowser; + const frame: ICefFrame; isProxy: Boolean; const host: ustring; port: Integer; + const realm, scheme: ustring; const callback: ICefAuthCallback): Boolean; +begin + Result := FEvent.doOnGetAuthCredentials(browser, frame, isProxy, host, port, + realm, scheme, callback); +end; + +function TCustomRequestHandler.GetResourceHandler(const browser: ICefBrowser; + const frame: ICefFrame; const request: ICefRequest): ICefResourceHandler; +begin + Result := FEvent.doOnGetResourceHandler(browser, frame, request); +end; + +function TCustomRequestHandler.OnBeforeBrowse(const browser: ICefBrowser; + const frame: ICefFrame; const request: ICefRequest; + isRedirect: Boolean): Boolean; +begin + Result := FEvent.doOnBeforeBrowse(browser, frame, request, isRedirect); +end; + +function TCustomRequestHandler.OnBeforePluginLoad(const browser: ICefBrowser; + const url, policyUrl: ustring; const info: ICefWebPluginInfo): Boolean; +begin + Result := FEvent.doOnBeforePluginLoad(browser, url, policyUrl, info); +end; + +function TCustomRequestHandler.OnBeforeResourceLoad(const browser: ICefBrowser; + const frame: ICefFrame; const request: ICefRequest): Boolean; +begin + Result := FEvent.doOnBeforeResourceLoad(browser, frame, request); +end; + +procedure TCustomRequestHandler.OnPluginCrashed(const browser: ICefBrowser; + const pluginPath: ustring); +begin + FEvent.doOnPluginCrashed(browser, pluginPath); +end; + +procedure TCustomRequestHandler.OnProtocolExecution(const browser: ICefBrowser; + const url: ustring; out allowOsExecution: Boolean); +begin + FEvent.doOnProtocolExecution(browser, url, allowOsExecution); +end; + +function TCustomRequestHandler.OnQuotaRequest(const browser: ICefBrowser; + const originUrl: ustring; newSize: Int64; + const callback: ICefQuotaCallback): Boolean; +begin + Result := FEvent.doOnQuotaRequest(browser, originUrl, newSize, callback); +end; + +procedure TCustomRequestHandler.OnRenderProcessTerminated( + const browser: ICefBrowser; status: TCefTerminationStatus); +begin + FEvent.doOnRenderProcessTerminated(browser, status); +end; + +procedure TCustomRequestHandler.OnResourceRedirect(const browser: ICefBrowser; + const frame: ICefFrame; const oldUrl: ustring; var newUrl: ustring); +begin + FEvent.doOnResourceRedirect(browser, frame, oldUrl, newUrl); +end; + +{ TCustomDialogHandler } + +constructor TCustomDialogHandler.Create(const events: IChromiumEvents); +begin + inherited Create; + FEvent := events; +end; + +function TCustomDialogHandler.OnFileDialog(const browser: ICefBrowser; + mode: TCefFileDialogMode; const title, defaultFileName: ustring; + acceptTypes: TStrings; const callback: ICefFileDialogCallback): Boolean; +begin + Result := FEvent.doOnFileDialog(browser, mode, title, + defaultFileName, acceptTypes, callback) +end; + +{ TCustomRenderHandler } + +constructor TCustomRenderHandler.Create(const events: IChromiumEvents); +begin + inherited Create; + FEvent := events; +end; + +function TCustomRenderHandler.GetRootScreenRect(const browser: ICefBrowser; + rect: PCefRect): Boolean; +begin + Result := FEvent.doOnGetRootScreenRect(browser, rect); +end; + +function TCustomRenderHandler.GetScreenInfo(const browser: ICefBrowser; + screenInfo: PCefScreenInfo): Boolean; +begin + Result := FEvent.doOnGetScreenInfo(browser, screenInfo); +end; + +function TCustomRenderHandler.GetScreenPoint(const browser: ICefBrowser; viewX, + viewY: Integer; screenX, screenY: PInteger): Boolean; +begin + Result := FEvent.doOnGetScreenPoint(browser, viewX, viewY, screenX, screenY); +end; + +function TCustomRenderHandler.GetViewRect(const browser: ICefBrowser; + rect: PCefRect): Boolean; +begin + Result := FEvent.doOnGetViewRect(browser, rect); +end; + +procedure TCustomRenderHandler.OnCursorChange(const browser: ICefBrowser; + cursor: TCefCursorHandle); +begin + FEvent.doOnCursorChange(browser, cursor); +end; + +procedure TCustomRenderHandler.OnPaint(const browser: ICefBrowser; + kind: TCefPaintElementType; dirtyRectsCount: NativeUInt; + const dirtyRects: PCefRectArray; const buffer: Pointer; width, height: Integer); +begin + FEvent.doOnPaint(browser, kind, dirtyRectsCount, dirtyRects, buffer, width, height); +end; + +procedure TCustomRenderHandler.OnPopupShow(const browser: ICefBrowser; + show: Boolean); +begin + FEvent.doOnPopupShow(browser, show); +end; + +procedure TCustomRenderHandler.OnPopupSize(const browser: ICefBrowser; + const rect: PCefRect); +begin + FEvent.doOnPopupSize(browser, rect); +end; + +procedure TCustomRenderHandler.OnScrollOffsetChanged( + const browser: ICefBrowser); +begin + FEvent.doOnScrollOffsetChanged(browser); +end; + +{ TCustomDragHandler } + +constructor TCustomDragHandler.Create(const events: IChromiumEvents); +begin + inherited Create; + FEvent := events; +end; + +function TCustomDragHandler.OnDragEnter(const browser: ICefBrowser; + const dragData: ICefDragData; mask: TCefDragOperations): Boolean; +begin + Result := FEvent.doOnDragEnter(browser, dragData, mask); +end; + +{ TCustomRequestContextHandler } + +constructor TCustomRequestContextHandler.Create(const events: IChromiumEvents); +begin + inherited Create; + FEvent := events; +end; + +function TCustomRequestContextHandler.GetCookieManager: ICefCookieManager; +begin + Result := FEvent.doOnGetCookieManager() +end; + +end. diff --git a/src/thirdparty/ceflib.pas b/src/thirdparty/ceflib.pas new file mode 100644 index 0000000..a7b67b9 --- /dev/null +++ b/src/thirdparty/ceflib.pas @@ -0,0 +1,16800 @@ +(* + * Delphi Chromium Embedded 3 + * + * Usage allowed under the restrictions of the Lesser GNU General Public License + * or alternatively the restrictions of the Mozilla Public License 1.1 + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for + * the specific language governing rights and limitations under the License. + * + * Unit owner : Henri Gourvest + * Web site : http://www.progdigy.com + * Repository : http://code.google.ctom/p/delphichromiumembedded/ + * Group : http://groups.google.com/group/delphichromiumembedded + * + * Embarcadero Technologies, Inc is not permitted to use or redistribute + * this source code without explicit permission. + * + *) + +{$IFDEF FPC} + {$MODE DELPHI}{$H+} +{$ENDIF} +unit ceflib; +{$IFNDEF CPUX64} + {$ALIGN ON} + {$MINENUMSIZE 4} +{$ENDIF} +{$I cef.inc} + +interface +uses +{$IFDEF DELPHI14_UP} + Rtti, TypInfo, Variants, Generics.Collections, +{$ENDIF} +{$IFDEF CEF_MULTI_THREADED_MESSAGE_LOOP} + Messages, +{$ENDIF} + SysUtils, Classes, Math, SyncObjs +{$IFDEF MSWINDOWS} + , Windows +{$ENDIF} +{$IFNDEF FPC} +{$ENDIF} + ; + +type +{$IFDEF UNICODE} + ustring = type string; + rbstring = type RawByteString; +{$ELSE} + {$IFDEF FPC} + {$if declared(unicodestring)} + ustring = type unicodestring; + {$else} + ustring = type WideString; + {$ifend} + {$ELSE} + ustring = type WideString; + {$ENDIF} + rbstring = type AnsiString; +{$ENDIF} + +{$if not defined(UInt64)} + UInt64 = Int64; +{$ifend} + +{$ifndef DELPHI16_UP} + NativeUInt = Cardinal; + PNativeUInt = ^NativeUInt; + NativeInt = Integer; +{$endif} + + TCefWindowHandle = {$IFDEF MACOS}Pointer{$ELSE}HWND{$ENDIF}; + TCefCursorHandle = {$IFDEF MACOS}Pointer{$ELSE}HCURSOR{$ENDIF}; + TCefEventHandle = {$IFDEF MACOS}Pointer{$ELSE}PMsg{$ENDIF}; + TCefTextInputContext = Pointer; + + // CEF provides functions for converting between UTF-8, -16 and -32 strings. + // CEF string types are safe for reading from multiple threads but not for + // modification. It is the user's responsibility to provide synchronization if + // modifying CEF strings from multiple threads. + + // CEF character type definitions. wchat_t is 2 bytes on Windows and 4 bytes on + // most other platforms. + + Char16 = WideChar; + PChar16 = PWideChar; + + // CEF string type definitions. Whomever allocates |str| is responsible for + // providing an appropriate |dtor| implementation that will free the string in + // the same memory space. When reusing an existing string structure make sure + // to call |dtor| for the old value before assigning new |str| and |dtor| + // values. Static strings will have a NULL |dtor| value. Using the below + // functions if you want this managed for you. + + PCefStringWide = ^TCefStringWide; + TCefStringWide = record + str: PWideChar; + length: NativeUInt; + dtor: procedure(str: PWideChar); stdcall; + end; + + PCefStringUtf8 = ^TCefStringUtf8; + TCefStringUtf8 = record + str: PAnsiChar; + length: NativeUInt; + dtor: procedure(str: PAnsiChar); stdcall; + end; + + PCefStringUtf16 = ^TCefStringUtf16; + TCefStringUtf16 = record + str: PChar16; + length: NativeUInt; + dtor: procedure(str: PChar16); stdcall; + end; + + + // It is sometimes necessary for the system to allocate string structures with + // the expectation that the user will free them. The userfree types act as a + // hint that the user is responsible for freeing the structure. + + PCefStringUserFreeWide = ^TCefStringUserFreeWide; + TCefStringUserFreeWide = type TCefStringWide; + + PCefStringUserFreeUtf8 = ^TCefStringUserFreeUtf8; + TCefStringUserFreeUtf8 = type TCefStringUtf8; + + PCefStringUserFreeUtf16 = ^TCefStringUserFreeUtf16; + TCefStringUserFreeUtf16 = type TCefStringUtf16; + +{$IFDEF CEF_STRING_TYPE_UTF8} + TCefChar = AnsiChar; + PCefChar = PAnsiChar; + TCefStringUserFree = TCefStringUserFreeUtf8; + PCefStringUserFree = PCefStringUserFreeUtf8; + TCefString = TCefStringUtf8; + PCefString = PCefStringUtf8; +{$ENDIF} + +{$IFDEF CEF_STRING_TYPE_UTF16} + TCefChar = Char16; + PCefChar = PChar16; + TCefStringUserFree = TCefStringUserFreeUtf16; + PCefStringUserFree = PCefStringUserFreeUtf16; + TCefString = TCefStringUtf16; + PCefString = PCefStringUtf16; +{$ENDIF} + +{$IFDEF CEF_STRING_TYPE_WIDE} + TCefChar = WideChar; + PCefChar = PWideChar; + TCefStringUserFree = TCefStringUserFreeWide; + PCefStringUserFree = PCefStringUserFreeWide; + TCefString = TCefStringWide; + PCefString = PCefStringWide; +{$ENDIF} + + // CEF strings are NUL-terminated wide character strings prefixed with a size + // value, similar to the Microsoft BSTR type. Use the below API functions for + // allocating, managing and freeing CEF strings. + + // CEF string maps are a set of key/value string pairs. + TCefStringMap = Pointer; + + // CEF string multimaps are a set of key/value string pairs. + // More than one value can be assigned to a single key. + TCefStringMultimap = Pointer; + + // CEF string maps are a set of key/value string pairs. + TCefStringList = Pointer; + +//--------------------------------------------------------------------- + + // Structure representing CefExecuteProcess arguments. + PCefMainArgs = ^TCefMainArgs; + TCefMainArgs = record + instance: HINST; + end; + + // Structure representing window information. + PCefWindowInfo = ^TCefWindowInfo; +{$IFDEF MACOS} + TCefWindowInfo = record + m_windowName: TCefString; + m_x: Integer; + m_y: Integer; + m_nWidth: Integer; + m_nHeight: Integer; + m_bHidden: Integer; + + // NSView pointer for the parent view. + m_ParentView: TCefWindowHandle; + + // NSView pointer for the new browser view. + m_View: TCefWindowHandle; + end; +{$ENDIF} + +{$IFDEF MSWINDOWS} + TCefWindowInfo = record + // Standard parameters required by CreateWindowEx() + ex_style: DWORD; + window_name: TCefString; + style: DWORD; + x: Integer; + y: Integer; + width: Integer; + height: Integer; + parent_window: HWND; + menu: HMENU; + // If window rendering is disabled no browser window will be created. Set + // |parent_window| to be used for identifying monitor info + // (MonitorFromWindow). If |parent_window| is not provided the main screen + // monitor will be used. + window_rendering_disabled: BOOL; + + // Set to true to enable transparent painting. + // If window rendering is disabled and |transparent_painting| is set to true + // WebKit rendering will draw on a transparent background (RGBA=0x00000000). + // When this value is false the background will be white and opaque. + transparent_painting: BOOL; + + // Handle for the new browser window. + window: HWND ; + end; +{$ENDIF} + +// 32-bit ARGB color value, not premultiplied. The color components are always +// in a known order. Equivalent to the SkColor type. + + TCefColor = Cardinal; + +// Return the alpha byte from a cef_color_t value. +function CefColorGetA(color: TCefColor): Byte; +// Return the red byte from a cef_color_t value. +function CefColorGetR(color: TCefColor): Byte; +// Return the green byte from a cef_color_t value. +function CefColorGetG(color: TCefColor): Byte; +// Return the blue byte from a cef_color_t value. +function CefColorGetB(color: TCefColor): Byte; + +// Return an cef_color_t value with the specified byte component values. +function CefColorSetARGB(a, r, g, b: Byte): TCefColor; + +type + // Log severity levels. + TCefLogSeverity = ( + // Default logging (currently INFO logging). + LOGSEVERITY_DEFAULT, + // Verbose logging. + LOGSEVERITY_VERBOSE, + // INFO logging. + LOGSEVERITY_INFO, + // WARNING logging. + LOGSEVERITY_WARNING, + // ERROR logging. + LOGSEVERITY_ERROR, + // ERROR_REPORT logging. + LOGSEVERITY_ERROR_REPORT, + // Disables logging completely. + LOGSEVERITY_DISABLE = 99 + ); + + // Represents the state of a setting. + TCefState = ( + // Use the default state for the setting. + STATE_DEFAULT = 0, + + // Enable or allow the setting. + STATE_ENABLED, + + // Disable or disallow the setting. + STATE_DISABLED + ); + + // Initialization settings. Specify NULL or 0 to get the recommended default + // values. Many of these and other settings can also configured using command- + // line switches. + + PCefSettings = ^TCefSettings; + TCefSettings = record + // Size of this structure. + size: NativeUInt; + + // Set to true (1) to use a single process for the browser and renderer. This + // run mode is not officially supported by Chromium and is less stable than + // the multi-process default. Also configurable using the "single-process" + // command-line switch. + single_process: Boolean; + + // The path to a separate executable that will be launched for sub-processes. + // By default the browser process executable is used. See the comments on + // CefExecuteProcess() for details. Also configurable using the + // "browser-subprocess-path" command-line switch. + browser_subprocess_path: TCefString; + + // Set to true (1) to have the browser process message loop run in a separate + // thread. If false (0) than the CefDoMessageLoopWork() function must be + // called from your application message loop. + multi_threaded_message_loop: Boolean; + + // Set to true (1) to disable configuration of browser process features using + // standard CEF and Chromium command-line arguments. Configuration can still + // be specified using CEF data structures or via the + // CefApp::OnBeforeCommandLineProcessing() method. + command_line_args_disabled: Boolean; + + // The location where cache data will be stored on disk. If empty an in-memory + // cache will be used for some features and a temporary disk cache for others. + // HTML5 databases such as localStorage will only persist across sessions if a + // cache path is specified. + cache_path: TCefString; + + // To persist session cookies (cookies without an expiry date or validity + // interval) by default when using the global cookie manager set this value to + // true. Session cookies are generally intended to be transient and most Web + // browsers do not persist them. A |cache_path| value must also be specified to + // enable this feature. Also configurable using the "persist-session-cookies" + // command-line switch. + persist_session_cookies: Boolean; + + // Value that will be returned as the User-Agent HTTP header. If empty the + // default User-Agent string will be used. Also configurable using the + // "user-agent" command-line switch. + user_agent: TCefString; + + // Value that will be inserted as the product portion of the default + // User-Agent string. If empty the Chromium product version will be used. If + // |userAgent| is specified this value will be ignored. Also configurable + // using the "product-version" command-line switch. + product_version: TCefString; + + // The locale string that will be passed to WebKit. If empty the default + // locale of "en-US" will be used. This value is ignored on Linux where locale + // is determined using environment variable parsing with the precedence order: + // LANGUAGE, LC_ALL, LC_MESSAGES and LANG. Also configurable using the "lang" + // command-line switch. + locale: TCefString; + + // The directory and file name to use for the debug log. If empty, the + // default name of "debug.log" will be used and the file will be written + // to the application directory. Also configurable using the "log-file" + // command-line switch. + log_file: TCefString; + + // The log severity. Only messages of this severity level or higher will be + // logged. + log_severity: TCefLogSeverity; + + // Enable DCHECK in release mode to ease debugging. Also configurable using the + // "enable-release-dcheck" command-line switch. + release_dcheck_enabled: Boolean; + + // Custom flags that will be used when initializing the V8 JavaScript engine. + // The consequences of using custom flags may not be well tested. Also + // configurable using the "js-flags" command-line switch. + javascript_flags: TCefString; + + // The fully qualified path for the resources directory. If this value is + // empty the cef.pak and/or devtools_resources.pak files must be located in + // the module directory on Windows/Linux or the app bundle Resources directory + // on Mac OS X. Also configurable using the "resources-dir-path" command-line + // switch. + resources_dir_path: TCefString; + + // The fully qualified path for the locales directory. If this value is empty + // the locales directory must be located in the module directory. This value + // is ignored on Mac OS X where pack files are always loaded from the app + // bundle Resources directory. Also configurable using the "locales-dir-path" + // command-line switch. + locales_dir_path: TCefString; + + // Set to true (1) to disable loading of pack files for resources and locales. + // A resource bundle handler must be provided for the browser and render + // processes via CefApp::GetResourceBundleHandler() if loading of pack files + // is disabled. Also configurable using the "disable-pack-loading" command- + // line switch. + pack_loading_disabled: Boolean; + + // Set to a value between 1024 and 65535 to enable remote debugging on the + // specified port. For example, if 8080 is specified the remote debugging URL + // will be http://localhost:8080. CEF can be remotely debugged from any CEF or + // Chrome browser window. Also configurable using the "remote-debugging-port" + // command-line switch. + remote_debugging_port: Integer; + + // The number of stack trace frames to capture for uncaught exceptions. + // Specify a positive value to enable the CefV8ContextHandler:: + // OnUncaughtException() callback. Specify 0 (default value) and + // OnUncaughtException() will not be called. Also configurable using the + // "uncaught-exception-stack-size" command-line switch. + + uncaught_exception_stack_size: Integer; + + // By default CEF V8 references will be invalidated (the IsValid() method will + // return false) after the owning context has been released. This reduces the + // need for external record keeping and avoids crashes due to the use of V8 + // references after the associated context has been released. + // + // CEF currently offers two context safety implementations with different + // performance characteristics. The default implementation (value of 0) uses a + // map of hash values and should provide better performance in situations with + // a small number contexts. The alternate implementation (value of 1) uses a + // hidden value attached to each context and should provide better performance + // in situations with a large number of contexts. + // + // If you need better performance in the creation of V8 references and you + // plan to manually track context lifespan you can disable context safety by + // specifying a value of -1. + // + // Also configurable using the "context-safety-implementation" command-line + // switch. + + context_safety_implementation: Integer; + + // Set to true (1) to ignore errors related to invalid SSL certificates. + // Enabling this setting can lead to potential security vulnerabilities like + // "man in the middle" attacks. Applications that load content from the + // internet should not enable this setting. Also configurable using the + // "ignore-certificate-errors" command-line switch. + ignore_certificate_errors: Boolean; + + // Used on Mac OS X to specify the background color for hardware accelerated + // content. + background_color: TCefColor; + end; + + // Browser initialization settings. Specify NULL or 0 to get the recommended + // default values. The consequences of using custom values may not be well + // tested. Many of these and other settings can also configured using command- + // line switches. + PCefBrowserSettings = ^TCefBrowserSettings; + TCefBrowserSettings = record + // Size of this structure. + size: NativeUInt; + + // The below values map to WebPreferences settings. + + // Font settings. + standard_font_family: TCefString; + fixed_font_family: TCefString; + serif_font_family: TCefString; + sans_serif_font_family: TCefString; + cursive_font_family: TCefString; + fantasy_font_family: TCefString; + default_font_size: Integer; + default_fixed_font_size: Integer; + minimum_font_size: Integer; + minimum_logical_font_size: Integer; + + // Default encoding for Web content. If empty "ISO-8859-1" will be used. Also + // configurable using the "default-encoding" command-line switch. + default_encoding: TCefString; + + // Location of the user style sheet that will be used for all pages. This must + // be a data URL of the form "data:text/css;charset=utf-8;base64,csscontent" + // where "csscontent" is the base64 encoded contents of the CSS file. Also + // configurable using the "user-style-sheet-location" command-line switch. + user_style_sheet_location: TCefString; + + // Controls the loading of fonts from remote sources. Also configurable using + // the "disable-remote-fonts" command-line switch. + remote_fonts: TCefState; + + // Controls whether JavaScript can be executed. Also configurable using the + // "disable-javascript" command-line switch. + javascript: TCefState; + + + // Controls whether JavaScript can be used for opening windows. Also + // configurable using the "disable-javascript-open-windows" command-line + // switch. + javascript_open_windows: TCefState; + + // Controls whether JavaScript can be used to close windows that were not + // opened via JavaScript. JavaScript can still be used to close windows that + // were opened via JavaScript. Also configurable using the + // "disable-javascript-close-windows" command-line switch. + javascript_close_windows: TCefState; + + // Controls whether JavaScript can access the clipboard. Also configurable + // using the "disable-javascript-access-clipboard" command-line switch. + javascript_access_clipboard: TCefState; + + // Controls whether DOM pasting is supported in the editor via + // execCommand("paste"). The |javascript_access_clipboard| setting must also + // be enabled. Also configurable using the "disable-javascript-dom-paste" + // command-line switch. + javascript_dom_paste: TCefState; + + // Controls whether the caret position will be drawn. Also configurable using + // the "enable-caret-browsing" command-line switch. + caret_browsing: TCefState; + + // Controls whether the Java plugin will be loaded. Also configurable using + // the "disable-java" command-line switch. + java: TCefState; + + // Controls whether any plugins will be loaded. Also configurable using the + // "disable-plugins" command-line switch. + plugins: TCefState; + + // Controls whether file URLs will have access to all URLs. Also configurable + // using the "allow-universal-access-from-files" command-line switch. + universal_access_from_file_urls: TCefState; + + // Controls whether file URLs will have access to other file URLs. Also + // configurable using the "allow-access-from-files" command-line switch. + file_access_from_file_urls: TCefState; + + // Controls whether web security restrictions (same-origin policy) will be + // enforced. Disabling this setting is not recommend as it will allow risky + // security behavior such as cross-site scripting (XSS). Also configurable + // using the "disable-web-security" command-line switch. + web_security: TCefState; + + // Controls whether image URLs will be loaded from the network. A cached image + // will still be rendered if requested. Also configurable using the + // "disable-image-loading" command-line switch. + image_loading: TCefState; + + // Controls whether standalone images will be shrunk to fit the page. Also + // configurable using the "image-shrink-standalone-to-fit" command-line + // switch. + image_shrink_standalone_to_fit: TCefState; + + // Controls whether text areas can be resized. Also configurable using the + // "disable-text-area-resize" command-line switch. + text_area_resize: TCefState; + + // Controls whether the tab key can advance focus to links. Also configurable + // using the "disable-tab-to-links" command-line switch. + tab_to_links: TCefState; + + // Controls whether style sheets can be used. Also configurable using the + // "disable-author-and-user-styles" command-line switch. + author_and_user_styles: TCefState; + + // Controls whether local storage can be used. Also configurable using the + // "disable-local-storage" command-line switch. + local_storage: TCefState; + + // Controls whether databases can be used. Also configurable using the + // "disable-databases" command-line switch. + databases: TCefState; + + // Controls whether the application cache can be used. Also configurable using + // the "disable-application-cache" command-line switch. + application_cache: TCefState; + + // Controls whether WebGL can be used. Note that WebGL requires hardware + // support and may not work on all systems even when enabled. Also + // configurable using the "disable-webgl" command-line switch. + webgl: TCefState; + + // Controls whether content that depends on accelerated compositing can be + // used. Note that accelerated compositing requires hardware support and may + // not work on all systems even when enabled. Also configurable using the + // "disable-accelerated-compositing" command-line switch. + accelerated_compositing: TCefState; + end; + + // URL component parts. + PCefUrlParts = ^TCefUrlParts; + TCefUrlParts = record + // The complete URL specification. + spec: TCefString; + + // Scheme component not including the colon (e.g., "http"). + scheme: TCefString; + + // User name component. + username: TCefString; + + // Password component. + password: TCefString; + + // Host component. This may be a hostname, an IPv4 address or an IPv6 literal + // surrounded by square brackets (e.g., "[2001:db8::1]"). + host: TCefString; + + // Port number component. + port: TCefString; + + // Path component including the first slash following the host. + path: TCefString; + + // Query string component (i.e., everything following the '?'). + query: TCefString; + end; + + TUrlParts = record + spec: ustring; + scheme: ustring; + username: ustring; + password: ustring; + host: ustring; + port: ustring; + path: ustring; + query: ustring; + end; + + // Time information. Values should always be in UTC. + PCefTime = ^TCefTime; + TCefTime = record + year: Integer; // Four digit year "2007" + month: Integer; // 1-based month (values 1 = January, etc.) + day_of_week: Integer; // 0-based day of week (0 = Sunday, etc.) + day_of_month: Integer; // 1-based day of month (1-31) + hour: Integer; // Hour within the current day (0-23) + minute: Integer; // Minute within the current hour (0-59) + second: Integer; // Second within the current minute (0-59 plus leap + // seconds which may take it up to 60). + millisecond: Integer; // Milliseconds within the current second (0-999) + end; + + // Cookie information. + TCefCookie = record + // The cookie name. + name: TCefString; + + // The cookie value. + value: TCefString; + + // If |domain| is empty a host cookie will be created instead of a domain + // cookie. Domain cookies are stored with a leading "." and are visible to + // sub-domains whereas host cookies are not. + domain: TCefString; + + // If |path| is non-empty only URLs at or below the path will get the cookie + // value. + path: TCefString; + + // If |secure| is true the cookie will only be sent for HTTPS requests. + secure: Boolean; + + // If |httponly| is true the cookie will only be sent for HTTP requests. + httponly: Boolean; + + // The cookie creation date. This is automatically populated by the system on + // cookie creation. + creation: TCefTime; + + // The cookie last access date. This is automatically populated by the system + // on access. + last_access: TCefTime; + + // The cookie expiration date is only valid if |has_expires| is true. + has_expires: Boolean; + expires: TCefTime; + end; + + // Process termination status values. + TCefTerminationStatus = ( + // Non-zero exit status. + TS_ABNORMAL_TERMINATION, + // SIGKILL or task manager kill. + TS_PROCESS_WAS_KILLED, + // Segmentation fault. + TS_PROCESS_CRASHED + ); + + // Path key values. + TCefPathKey = ( + // Current directory. + PK_DIR_CURRENT, + // Directory containing PK_FILE_EXE. + PK_DIR_EXE, + // Directory containing PK_FILE_MODULE. + PK_DIR_MODULE, + // Temporary directory. + PK_DIR_TEMP, + // Path and filename of the current executable. + PK_FILE_EXE, + // Path and filename of the module containing the CEF code (usually the libcef + // module). + PK_FILE_MODULE + ); + + // Storage types. + TCefStorageType = ( + ST_LOCALSTORAGE = 0, + ST_SESSIONSTORAGE + ); + + // Supported error code values. See net\base\net_error_list.h for complete + // descriptions of the error codes. + TCefErrorcode = Integer; + +const + ERR_NONE = 0; + ERR_FAILED = -2; + ERR_ABORTED = -3; + ERR_INVALID_ARGUMENT = -4; + ERR_INVALID_HANDLE = -5; + ERR_FILE_NOT_FOUND = -6; + ERR_TIMED_OUT = -7; + ERR_FILE_TOO_BIG = -8; + ERR_UNEXPECTED = -9; + ERR_ACCESS_DENIED = -10; + ERR_NOT_IMPLEMENTED = -11; + ERR_CONNECTION_CLOSED = -100; + ERR_CONNECTION_RESET = -101; + ERR_CONNECTION_REFUSED = -102; + ERR_CONNECTION_ABORTED = -103; + ERR_CONNECTION_FAILED = -104; + ERR_NAME_NOT_RESOLVED = -105; + ERR_INTERNET_DISCONNECTED = -106; + ERR_SSL_PROTOCOL_ERROR = -107; + ERR_ADDRESS_INVALID = -108; + ERR_ADDRESS_UNREACHABLE = -109; + ERR_SSL_CLIENT_AUTH_CERT_NEEDED = -110; + ERR_TUNNEL_CONNECTION_FAILED = -111; + ERR_NO_SSL_VERSIONS_ENABLED = -112; + ERR_SSL_VERSION_OR_CIPHER_MISMATCH = -113; + ERR_SSL_RENEGOTIATION_REQUESTED = -114; + ERR_CERT_COMMON_NAME_INVALID = -200; + ERR_CERT_DATE_INVALID = -201; + ERR_CERT_AUTHORITY_INVALID = -202; + ERR_CERT_CONTAINS_ERRORS = -203; + ERR_CERT_NO_REVOCATION_MECHANISM = -204; + ERR_CERT_UNABLE_TO_CHECK_REVOCATION = -205; + ERR_CERT_REVOKED = -206; + ERR_CERT_INVALID = -207; + ERR_CERT_END = -208; + ERR_INVALID_URL = -300; + ERR_DISALLOWED_URL_SCHEME = -301; + ERR_UNKNOWN_URL_SCHEME = -302; + ERR_TOO_MANY_REDIRECTS = -310; + ERR_UNSAFE_REDIRECT = -311; + ERR_UNSAFE_PORT = -312; + ERR_INVALID_RESPONSE = -320; + ERR_INVALID_CHUNKED_ENCODING = -321; + ERR_METHOD_NOT_SUPPORTED = -322; + ERR_UNEXPECTED_PROXY_AUTH = -323; + ERR_EMPTY_RESPONSE = -324; + ERR_RESPONSE_HEADERS_TOO_BIG = -325; + ERR_CACHE_MISS = -400; + ERR_INSECURE_RESPONSE = -501; + +// "Verb" of a drag-and-drop operation as negotiated between the source and +// destination. These constants match their equivalents in WebCore's +// DragActions.h and should not be renumbered. +type + TCefDragOperation = ( + //DRAG_OPERATION_NONE = 0; + DRAG_OPERATION_COPY, + DRAG_OPERATION_LINK, + DRAG_OPERATION_GENERIC, + DRAG_OPERATION_PRIVATE, + DRAG_OPERATION_MOVE, + DRAG_OPERATION_DELETE + //DRAG_OPERATION_EVERY = High(Cardinal); + ); + TCefDragOperations = set of TCefDragOperation; + + // V8 access control values. + TCefV8AccessControl = ( + //V8_ACCESS_CONTROL_DEFAULT = 0; + V8_ACCESS_CONTROL_ALL_CAN_READ, + V8_ACCESS_CONTROL_ALL_CAN_WRITE, + V8_ACCESS_CONTROL_PROHIBITS_OVERWRITING + ); + TCefV8AccessControls = set of TCefV8AccessControl; + + // V8 property attribute values. + TCefV8PropertyAttribute = ( + //V8_PROPERTY_ATTRIBUTE_NONE = 0; // Writeable, Enumerable, Configurable + V8_PROPERTY_ATTRIBUTE_READONLY, // Not writeable + V8_PROPERTY_ATTRIBUTE_DONTENUM, // Not enumerable + V8_PROPERTY_ATTRIBUTE_DONTDELETE // Not configurable + ); + TCefV8PropertyAttributes = set of TCefV8PropertyAttribute; + +type + // Post data elements may represent either bytes or files. + TCefPostDataElementType = ( + PDE_TYPE_EMPTY = 0, + PDE_TYPE_BYTES, + PDE_TYPE_FILE + ); + + // Resource type for a request. + TCefResourceType = ( + // Top level page. + RT_MAIN_FRAME = 0, + // Frame or iframe. + RT_SUB_FRAME, + // CSS stylesheet. + RT_STYLESHEET, + // External script. + RT_SCRIPT, + // Image (jpg/gif/png/etc). + RT_IMAGE, + // Font. + RT_FONT_RESOURCE, + // Some other subresource. This is the default type if the actual type is + // unknown. + RT_SUB_RESOURCE, + // Object (or embed) tag for a plugin, or a resource that a plugin requested. + RT_OBJECT, + // Media resource. + RT_MEDIA, + // Main resource of a dedicated worker. + RT_WORKER, + // Main resource of a shared worker. + RT_SHARED_WORKER, + // Explicitly requested prefetch. + RT_PREFETCH, + // Favicon. + RT_FAVICON, + // XMLHttpRequest. + RT_XHR + ); + + // Transition type for a request. Made up of one source value and 0 or more + // qualifiers. + TCefTransitionType = Integer; +const + // Source is a link click or the JavaScript window.open function. This is + // also the default value for requests like sub-resource loads that are not + // navigations. + TT_LINK = 0; + // Source is some other "explicit" navigation action such as creating a new + // browser or using the LoadURL function. This is also the default value + // for navigations where the actual type is unknown. + TT_EXPLICIT = 1; + // Source is a subframe navigation. This is any content that is automatically + // loaded in a non-toplevel frame. For example, if a page consists of several + // frames containing ads, those ad URLs will have this transition type. + // The user may not even realize the content in these pages is a separate + // frame, so may not care about the URL. + TT_AUTO_SUBFRAME = 3; + // Source is a subframe navigation explicitly requested by the user that will + // generate new navigation entries in the back/forward list. These are + // probably more important than frames that were automatically loaded in + // the background because the user probably cares about the fact that this + // link was loaded. + TT_MANUAL_SUBFRAME = 4; + // Source is a form submission by the user. NOTE: In some situations + // submitting a form does not result in this transition type. This can happen + // if the form uses a script to submit the contents. + TT_FORM_SUBMIT = 7; + // Source is a "reload" of the page via the Reload function or by re-visiting + // the same URL. NOTE: This is distinct from the concept of whether a + // particular load uses "reload semantics" (i.e. bypasses cached data). + TT_RELOAD = 8; + // General mask defining the bits used for the source values. + TT_SOURCE_MASK = $FF; + + // Qualifiers. + // Any of the core values above can be augmented by one or more qualifiers. + // These qualifiers further define the transition. + + // Attempted to visit a URL but was blocked. + TT_BLOCKED_FLAG = $00800000; + // Used the Forward or Back function to navigate among browsing history. + TT_FORWARD_BACK_FLAG = $01000000; + // The beginning of a navigation chain. + TT_CHAIN_START_FLAG = $10000000; + // The last transition in a redirect chain. + TT_CHAIN_END_FLAG = $20000000; + // Redirects caused by JavaScript or a meta refresh tag on the page. + TT_CLIENT_REDIRECT_FLAG = $40000000; + // Redirects sent from the server by HTTP headers. + TT_SERVER_REDIRECT_FLAG = $80000000; + // Used to test whether a transition involves a redirect. + TT_IS_REDIRECT_MASK = $C0000000; + // General mask defining the bits used for the qualifiers. + TT_QUALIFIER_MASK = $FFFFFF00; +// ); + +type + // Flags used to customize the behavior of CefURLRequest. + TCefUrlRequestFlag = ( + // Default behavior. + //UR_FLAG_NONE = 0, + // If set the cache will be skipped when handling the request. + UR_FLAG_SKIP_CACHE, + // If set user name, password, and cookies may be sent with the request. + UR_FLAG_ALLOW_CACHED_CREDENTIALS, + // If set cookies may be sent with the request and saved from the response. + // UR_FLAG_ALLOW_CACHED_CREDENTIALS must also be set. + UR_FLAG_ALLOW_COOKIES, + // If set upload progress events will be generated when a request has a body. + UR_FLAG_REPORT_UPLOAD_PROGRESS, + // If set load timing info will be collected for the request. + UR_FLAG_REPORT_LOAD_TIMING, + // If set the headers sent and received for the request will be recorded. + UR_FLAG_REPORT_RAW_HEADERS, + // If set the CefURLRequestClient::OnDownloadData method will not be called. + UR_FLAG_NO_DOWNLOAD_DATA, + // If set 5XX redirect errors will be propagated to the observer instead of + // automatically re-tried. This currently only applies for requests + // originated in the browser process. + UR_FLAG_NO_RETRY_ON_5XX + ); + TCefUrlRequestFlags = set of TCefUrlRequestFlag; + + // Flags that represent CefURLRequest status. + TCefUrlRequestStatus = ( + // Unknown status. + UR_UNKNOWN = 0, + // Request succeeded. + UR_SUCCESS, + // An IO request is pending, and the caller will be informed when it is + // completed. + UR_IO_PENDING, + // Request was canceled programatically. + UR_CANCELED, + // Request failed for some reason. + UR_FAILED + ); + + // Structure representing a rectangle. + PCefRect = ^TCefRect; + TCefRect = record + x: Integer; + y: Integer; + width: Integer; + height: Integer; + end; + + TCefRectArray = array[0..(High(Integer) div SizeOf(TCefRect))-1] of TCefRect; + PCefRectArray = ^TCefRectArray; + + // Existing process IDs. + TCefProcessId = ( + // Browser process. + PID_BROWSER, + // Renderer process. + PID_RENDERER + ); + + + // Existing thread IDs. + TCefThreadId = ( + // BROWSER PROCESS THREADS -- Only available in the browser process. + // The main thread in the browser. This will be the same as the main + // application thread if CefInitialize() is called with a + // CefSettings.multi_threaded_message_loop value of false. + /// + TID_UI, + + // Used to interact with the database. + TID_DB, + + // Used to interact with the file system. + TID_FILE, + + // Used for file system operations that block user interactions. + // Responsiveness of this thread affects users. + TID_FILE_USER_BLOCKING, + + // Used to launch and terminate browser processes. + TID_PROCESS_LAUNCHER, + + // Used to handle slow HTTP cache operations. + TID_CACHE, + + // Used to process IPC and network messages. + TID_IO, + + // RENDER PROCESS THREADS -- Only available in the render process. + + /// + // The main thread in the renderer. Used for all WebKit and V8 interaction. + /// + TID_RENDERER + ); + + // Supported value types. + TCefValueType = ( + VTYPE_INVALID = 0, + VTYPE_NULL, + VTYPE_BOOL, + VTYPE_INT, + VTYPE_DOUBLE, + VTYPE_STRING, + VTYPE_BINARY, + VTYPE_DICTIONARY, + VTYPE_LIST + ); + + // Supported JavaScript dialog types. + TCefJsDialogType = ( + JSDIALOGTYPE_ALERT = 0, + JSDIALOGTYPE_CONFIRM, + JSDIALOGTYPE_PROMPT + ); + + // Screen information used when window rendering is disabled. This structure is + // passed as a parameter to CefRenderHandler::GetScreenInfo and should be filled + // in by the client. + /// + TCefScreenInfo = record + // Device scale factor. Specifies the ratio between physical and logical + // pixels. + device_scale_factor: Single; + + // The screen depth in bits per pixel. + depth: Integer; + + // The bits per color component. This assumes that the colors are balanced + // equally. + depth_per_component: Integer; + + // This can be true for black and white printers. + is_monochrome: Boolean; + + // This is set from the rcMonitor member of MONITORINFOEX, to whit: + // "A RECT structure that specifies the display monitor rectangle, + // expressed in virtual-screen coordinates. Note that if the monitor + // is not the primary display monitor, some of the rectangle's + // coordinates may be negative values." + // + // The |rect| and |available_rect| properties are used to determine the + // available surface for rendering popup views. + rect: TCefRect; + + // This is set from the rcWork member of MONITORINFOEX, to whit: + // "A RECT structure that specifies the work area rectangle of the + // display monitor that can be used by applications, expressed in + // virtual-screen coordinates. Windows uses this rectangle to + // maximize an application on the monitor. The rest of the area in + // rcMonitor contains system windows such as the task bar and side + // bars. Note that if the monitor is not the primary display monitor, + // some of the rectangle's coordinates may be negative values". + // + // The |rect| and |available_rect| properties are used to determine the + // available surface for rendering popup views. + /// + available_rect: TCefRect; + end; + + // Supported menu IDs. Non-English translations can be provided for the + // IDS_MENU_* strings in CefResourceBundleHandler::GetLocalizedString(). + TCefMenuId = ( + // Navigation. + MENU_ID_BACK = 100, + MENU_ID_FORWARD = 101, + MENU_ID_RELOAD = 102, + MENU_ID_RELOAD_NOCACHE = 103, + MENU_ID_STOPLOAD = 104, + + // Editing. + MENU_ID_UNDO = 110, + MENU_ID_REDO = 111, + MENU_ID_CUT = 112, + MENU_ID_COPY = 113, + MENU_ID_PASTE = 114, + MENU_ID_DELETE = 115, + MENU_ID_SELECT_ALL = 116, + + // Miscellaneous. + MENU_ID_FIND = 130, + MENU_ID_PRINT = 131, + MENU_ID_VIEW_SOURCE = 132, + + // All user-defined menu IDs should come between MENU_ID_USER_FIRST and + // MENU_ID_USER_LAST to avoid overlapping the Chromium and CEF ID ranges + // defined in the tools/gritsettings/resource_ids file. + MENU_ID_USER_FIRST = 26500, + MENU_ID_USER_LAST = 28500 + ); + + // Mouse button types. + TCefMouseButtonType = ( + MBT_LEFT, + MBT_MIDDLE, + MBT_RIGHT + ); + + // Paint element types. + TCefPaintElementType = ( + PET_VIEW, + PET_POPUP + ); + + // Supported event bit flags. + TCefEventFlag = ( + //EVENTFLAG_NONE = 0, + EVENTFLAG_CAPS_LOCK_ON, + EVENTFLAG_SHIFT_DOWN, + EVENTFLAG_CONTROL_DOWN, + EVENTFLAG_ALT_DOWN, + EVENTFLAG_LEFT_MOUSE_BUTTON, + EVENTFLAG_MIDDLE_MOUSE_BUTTON, + EVENTFLAG_RIGHT_MOUSE_BUTTON, + // Mac OS-X command key. + EVENTFLAG_COMMAND_DOWN, + EVENTFLAG_NUM_LOCK_ON, + EVENTFLAG_IS_KEY_PAD, + EVENTFLAG_IS_LEFT, + EVENTFLAG_IS_RIGHT + ); + TCefEventFlags = set of TCefEventFlag; + + // Structure representing mouse event information. + PCefMouseEvent = ^TCefMouseEvent; + TCefMouseEvent = record + // X coordinate relative to the left side of the view. + x: Integer; + + // Y coordinate relative to the top side of the view. + y: Integer; + + // Bit flags describing any pressed modifier keys. See + // cef_event_flags_t for values. + modifiers: TCefEventFlags; + end; + + // Supported menu item types. + TCefMenuItemType = ( + MENUITEMTYPE_NONE, + MENUITEMTYPE_COMMAND, + MENUITEMTYPE_CHECK, + MENUITEMTYPE_RADIO, + MENUITEMTYPE_SEPARATOR, + MENUITEMTYPE_SUBMENU + ); + + // Supported context menu type flags. + TCefContextMenuTypeFlag = ( + // No node is selected. + //CM_TYPEFLAG_NONE = 0, + // The top page is selected. + CM_TYPEFLAG_PAGE, + // A subframe page is selected. + CM_TYPEFLAG_FRAME, + // A link is selected. + CM_TYPEFLAG_LINK, + // A media node is selected. + CM_TYPEFLAG_MEDIA, + // There is a textual or mixed selection that is selected. + CM_TYPEFLAG_SELECTION, + // An editable element is selected. + CM_TYPEFLAG_EDITABLE + ); + TCefContextMenuTypeFlags = set of TCefContextMenuTypeFlag; + + // Supported context menu media types. + TCefContextMenuMediaType = ( + // No special node is in context. + CM_MEDIATYPE_NONE, + // An image node is selected. + CM_MEDIATYPE_IMAGE, + // A video node is selected. + CM_MEDIATYPE_VIDEO, + // An audio node is selected. + CM_MEDIATYPE_AUDIO, + // A file node is selected. + CM_MEDIATYPE_FILE, + // A plugin node is selected. + CM_MEDIATYPE_PLUGIN + ); + + // Supported context menu media state bit flags. + TCefContextMenuMediaStateFlag = ( + //CM_MEDIAFLAG_NONE = 0, + CM_MEDIAFLAG_ERROR, + CM_MEDIAFLAG_PAUSED, + CM_MEDIAFLAG_MUTED, + CM_MEDIAFLAG_LOOP, + CM_MEDIAFLAG_CAN_SAVE, + CM_MEDIAFLAG_HAS_AUDIO, + CM_MEDIAFLAG_HAS_VIDEO, + CM_MEDIAFLAG_CONTROL_ROOT_ELEMENT, + CM_MEDIAFLAG_CAN_PRINT, + CM_MEDIAFLAG_CAN_ROTATE + ); + TCefContextMenuMediaStateFlags = set of TCefContextMenuMediaStateFlag; + + // Supported context menu edit state bit flags. + TCefContextMenuEditStateFlag = ( + //CM_EDITFLAG_NONE = 0, + CM_EDITFLAG_CAN_UNDO, + CM_EDITFLAG_CAN_REDO, + CM_EDITFLAG_CAN_CUT, + CM_EDITFLAG_CAN_COPY, + CM_EDITFLAG_CAN_PASTE, + CM_EDITFLAG_CAN_DELETE, + CM_EDITFLAG_CAN_SELECT_ALL, + CM_EDITFLAG_CAN_TRANSLATE + ); + TCefContextMenuEditStateFlags = set of TCefContextMenuEditStateFlag; + + // Key event types. + TCefKeyEventType = ( + KEYEVENT_RAWKEYDOWN = 0, + KEYEVENT_KEYDOWN, + KEYEVENT_KEYUP, + KEYEVENT_CHAR + ); + + // Structure representing keyboard event information. + PCefKeyEvent = ^TCefKeyEvent; + TCefKeyEvent = record + // The type of keyboard event. + kind: TCefKeyEventType; + + // Bit flags describing any pressed modifier keys. See + // cef_event_flags_t for values. + modifiers: TCefEventFlags; + + // The Windows key code for the key event. This value is used by the DOM + // specification. Sometimes it comes directly from the event (i.e. on + // Windows) and sometimes it's determined using a mapping function. See + // WebCore/platform/chromium/KeyboardCodes.h for the list of values. + windows_key_code: Integer; + + // The actual key code genenerated by the platform. + native_key_code: Integer; + + // Indicates whether the event is considered a "system key" event (see + // http://msdn.microsoft.com/en-us/library/ms646286(VS.85).aspx for details). + // This value will always be false on non-Windows platforms. + is_system_key: Boolean; + + // The character generated by the keystroke. + character: WideChar; + + // Same as |character| but unmodified by any concurrently-held modifiers + // (except shift). This is useful for working out shortcut keys. + unmodified_character: WideChar; + + // True if the focus is currently on an editable field on the page. This is + // useful for determining if standard key events should be intercepted. + focus_on_editable_field: Boolean; + end; + + // Focus sources. + TCefFocusSource = ( + // The source is explicit navigation via the API (LoadURL(), etc). + FOCUS_SOURCE_NAVIGATION = 0, + // The source is a system-generated focus event. + FOCUS_SOURCE_SYSTEM + ); + + // Navigation types. + TCefNavigationType = ( + NAVIGATION_LINK_CLICKED, + NAVIGATION_FORM_SUBMITTED, + NAVIGATION_BACK_FORWARD, + NAVIGATION_RELOAD, + NAVIGATION_FORM_RESUBMITTED, + NAVIGATION_OTHER + ); + + // Supported XML encoding types. The parser supports ASCII, ISO-8859-1, and + // UTF16 (LE and BE) by default. All other types must be translated to UTF8 + // before being passed to the parser. If a BOM is detected and the correct + // decoder is available then that decoder will be used automatically. + TCefXmlEncodingType = ( + XML_ENCODING_NONE = 0, + XML_ENCODING_UTF8, + XML_ENCODING_UTF16LE, + XML_ENCODING_UTF16BE, + XML_ENCODING_ASCII + ); + + // XML node types. + TCefXmlNodeType = ( + XML_NODE_UNSUPPORTED = 0, + XML_NODE_PROCESSING_INSTRUCTION, + XML_NODE_DOCUMENT_TYPE, + XML_NODE_ELEMENT_START, + XML_NODE_ELEMENT_END, + XML_NODE_ATTRIBUTE, + XML_NODE_TEXT, + XML_NODE_CDATA, + XML_NODE_ENTITY_REFERENCE, + XML_NODE_WHITESPACE, + XML_NODE_COMMENT + ); + + // Popup window features. + PCefPopupFeatures = ^TCefPopupFeatures; + TCefPopupFeatures = record + x: Integer; + xSet: Boolean; + y: Integer; + ySet: Boolean; + width: Integer; + widthSet: Boolean; + height: Integer; + heightSet: Boolean; + + menuBarVisible: Boolean; + statusBarVisible: Boolean; + toolBarVisible: Boolean; + locationBarVisible: Boolean; + scrollbarsVisible: Boolean; + resizable: Boolean; + + fullscreen: Boolean; + dialog: Boolean; + additionalFeatures: TCefStringList; + end; + + // DOM document types. + TCefDomDocumentType = ( + DOM_DOCUMENT_TYPE_UNKNOWN = 0, + DOM_DOCUMENT_TYPE_HTML, + DOM_DOCUMENT_TYPE_XHTML, + DOM_DOCUMENT_TYPE_PLUGIN + ); + + // DOM event category flags. + TCefDomEventCategory = Integer; +const + DOM_EVENT_CATEGORY_UNKNOWN = $0; + DOM_EVENT_CATEGORY_UI = $1; + DOM_EVENT_CATEGORY_MOUSE = $2; + DOM_EVENT_CATEGORY_MUTATION = $4; + DOM_EVENT_CATEGORY_KEYBOARD = $8; + DOM_EVENT_CATEGORY_TEXT = $10; + DOM_EVENT_CATEGORY_COMPOSITION = $20; + DOM_EVENT_CATEGORY_DRAG = $40; + DOM_EVENT_CATEGORY_CLIPBOARD = $80; + DOM_EVENT_CATEGORY_MESSAGE = $100; + DOM_EVENT_CATEGORY_WHEEL = $200; + DOM_EVENT_CATEGORY_BEFORE_TEXT_INSERTED = $400; + DOM_EVENT_CATEGORY_OVERFLOW = $800; + DOM_EVENT_CATEGORY_PAGE_TRANSITION = $1000; + DOM_EVENT_CATEGORY_POPSTATE = $2000; + DOM_EVENT_CATEGORY_PROGRESS = $4000; + DOM_EVENT_CATEGORY_XMLHTTPREQUEST_PROGRESS = $8000; + DOM_EVENT_CATEGORY_BEFORE_LOAD = $10000; + +type + // DOM event processing phases. + TCefDomEventPhase = ( + DOM_EVENT_PHASE_UNKNOWN = 0, + DOM_EVENT_PHASE_CAPTURING, + DOM_EVENT_PHASE_AT_TARGET, + DOM_EVENT_PHASE_BUBBLING + ); + + // DOM node types. + TCefDomNodeType = ( + DOM_NODE_TYPE_UNSUPPORTED = 0, + DOM_NODE_TYPE_ELEMENT, + DOM_NODE_TYPE_ATTRIBUTE, + DOM_NODE_TYPE_TEXT, + DOM_NODE_TYPE_CDATA_SECTION, + DOM_NODE_TYPE_ENTITY, + DOM_NODE_TYPE_PROCESSING_INSTRUCTIONS, + DOM_NODE_TYPE_COMMENT, + DOM_NODE_TYPE_DOCUMENT, + DOM_NODE_TYPE_DOCUMENT_TYPE, + DOM_NODE_TYPE_DOCUMENT_FRAGMENT, + DOM_NODE_TYPE_NOTATION, + DOM_NODE_TYPE_XPATH_NAMESPACE + ); + + // Supported file dialog modes. + TCefFileDialogMode = ( + // Requires that the file exists before allowing the user to pick it. + FILE_DIALOG_OPEN, + + // Like Open, but allows picking multiple files to open. + FILE_DIALOG_OPEN_MULTIPLE, + + // Allows picking a nonexistent file, and prompts to overwrite if the file + // already exists. + FILE_DIALOG_SAVE + ); + + // Geoposition error codes. + TCefGeopositionErrorCode = ( + GEOPOSITON_ERROR_NONE, + GEOPOSITON_ERROR_PERMISSION_DENIED, + GEOPOSITON_ERROR_POSITION_UNAVAILABLE, + GEOPOSITON_ERROR_TIMEOUT + ); + + // Structure representing geoposition information. The properties of this + // structure correspond to those of the JavaScript Position object although + // their types may differ. + PCefGeoposition = ^TCefGeoposition; + TCefGeoposition = record + // Latitude in decimal degrees north (WGS84 coordinate frame). + latitude: Double; + + // Longitude in decimal degrees west (WGS84 coordinate frame). + longitude: Double; + + // Altitude in meters (above WGS84 datum). + altitude: Double; + + // Accuracy of horizontal position in meters. + accuracy: Double; + + // Accuracy of altitude in meters. + altitude_accuracy: Double; + + // Heading in decimal degrees clockwise from true north. + heading: Double; + + // Horizontal component of device velocity in meters per second. + speed: Double; + + // Time of position measurement in miliseconds since Epoch in UTC time. This + // is taken from the host computer's system clock. + timestamp: TCefTime; + + // Error code, see enum above. + error_code: TCefGeopositionErrorCode; + + // Human-readable error message. + error_message: TCefString; + end; + +(******************************************************************************* + capi + *******************************************************************************) +type + PCefv8Handler = ^TCefv8Handler; + PCefV8Accessor = ^TCefV8Accessor; + PCefv8Value = ^TCefv8Value; + PCefV8StackTrace = ^TCefV8StackTrace; + PCefV8StackFrame = ^TCefV8StackFrame; + PCefV8ValueArray = array[0..(High(Integer) div SizeOf(Pointer)) - 1] of PCefV8Value; + PPCefV8Value = ^PCefV8ValueArray; + PCefSchemeHandlerFactory = ^TCefSchemeHandlerFactory; + PCefSchemeRegistrar = ^TCefSchemeRegistrar; + PCefFrame = ^TCefFrame; + PCefRequest = ^TCefRequest; + PCefStreamReader = ^TCefStreamReader; + PCefPostData = ^TCefPostData; + PCefPostDataElement = ^TCefPostDataElement; + PPCefPostDataElement = ^PCefPostDataElement; + PCefReadHandler = ^TCefReadHandler; + PCefWriteHandler = ^TCefWriteHandler; + PCefStreamWriter = ^TCefStreamWriter; + PCefBase = ^TCefBase; + PCefBrowser = ^TCefBrowser; + PCefRunFileDialogCallback = ^TCefRunFileDialogCallback; + PCefBrowserHost = ^TCefBrowserHost; + PCefTask = ^TCefTask; + PCefTaskRunner = ^TCefTaskRunner; + PCefDownloadHandler = ^TCefDownloadHandler; + PCefXmlReader = ^TCefXmlReader; + PCefZipReader = ^TCefZipReader; + PCefDomVisitor = ^TCefDomVisitor; + PCefDomDocument = ^TCefDomDocument; + PCefDomNode = ^TCefDomNode; + PCefDomEventListener = ^TCefDomEventListener; + PCefDomEvent = ^TCefDomEvent; + PCefResponse = ^TCefResponse; + PCefv8Context = ^TCefv8Context; + PCefCookieVisitor = ^TCefCookieVisitor; + PCefCookie = ^TCefCookie; + PCefClient = ^TCefClient; + PCefLifeSpanHandler = ^TCefLifeSpanHandler; + PCefLoadHandler = ^TCefLoadHandler; + PCefRequestHandler = ^TCefRequestHandler; + PCefDisplayHandler = ^TCefDisplayHandler; + PCefFocusHandler = ^TCefFocusHandler; + PCefKeyboardHandler = ^TCefKeyboardHandler; + PCefJsDialogHandler = ^TCefJsDialogHandler; + PCefApp = ^TCefApp; + PCefV8Exception = ^TCefV8Exception; + PCefResourceBundleHandler = ^TCefResourceBundleHandler; + PCefCookieManager = ^TCefCookieManager; + PCefWebPluginInfo = ^TCefWebPluginInfo; + PCefCommandLine = ^TCefCommandLine; + PCefProcessMessage = ^TCefProcessMessage; + PCefBinaryValue = ^TCefBinaryValue; + PCefDictionaryValue = ^TCefDictionaryValue; + PCefListValue = ^TCefListValue; + PCefBrowserProcessHandler = ^TCefBrowserProcessHandler; + PCefRenderProcessHandler = ^TCefRenderProcessHandler; + PCefAuthCallback = ^TCefAuthCallback; + PCefQuotaCallback = ^TCefQuotaCallback; + PCefAllowCertificateErrorCallback = ^TCefAllowCertificateErrorCallback; + PCefResourceHandler = ^TCefResourceHandler; + PCefCallback = ^TCefCallback; + PCefCompletionHandler = ^TCefCompletionHandler; + PCefContextMenuHandler = ^TCefContextMenuHandler; + PCefContextMenuParams = ^TCefContextMenuParams; + PCefMenuModel = ^TCefMenuModel; + PCefGeolocationCallback = ^TCefGeolocationCallback; + PCefGeolocationHandler = ^TCefGeolocationHandler; + PCefBeforeDownloadCallback = ^TCefBeforeDownloadCallback; + PCefDownloadItemCallback = ^TCefDownloadItemCallback; + PCefDownloadItem = ^TCefDownloadItem; + PCefStringVisitor = ^TCefStringVisitor; + PCefJsDialogCallback = ^TCefJsDialogCallback; + PCefUrlRequest = ^TCefUrlRequest; + PCefUrlRequestClient = ^TCefUrlRequestClient; + PCefWebPluginInfoVisitor = ^TCefWebPluginInfoVisitor; + PCefWebPluginUnstableCallback = ^TCefWebPluginUnstableCallback; + PCefFileDialogCallback = ^TCefFileDialogCallback; + PCefDialogHandler = ^TCefDialogHandler; + PCefRenderHandler = ^TCefRenderHandler; + PCefGetGeolocationCallback = ^TCefGetGeolocationCallback; + PCefTraceClient = ^TCefTraceClient; + PCefScreenInfo = ^TCefScreenInfo; + PCefDragData = ^TCefDragData; + PCefDragHandler = ^TCefDragHandler; + PCefRequestContextHandler = ^TCefRequestContextHandler; + PCefRequestContext = ^TCefRequestContext; + + // Structure defining the reference count implementation functions. All + // framework structures must include the cef_base_t structure first. + TCefBase = record + // Size of the data structure. + size: NativeUInt; + + // Increment the reference count. + add_ref: function(self: PCefBase): Integer; stdcall; + // Decrement the reference count. Delete this object when no references + // remain. + release: function(self: PCefBase): Integer; stdcall; + // Returns the current number of references. + get_refct: function(self: PCefBase): Integer; stdcall; + end; + + // Structure representing a binary value. Can be used on any process and thread. + TCefBinaryValue = record + // Base structure. + base: TCefBase; + + // Returns true (1) if this object is valid. Do not call any other functions + // if this function returns false (0). + is_valid: function(self: PCefBinaryValue): Integer; stdcall; + + // Returns true (1) if this object is currently owned by another object. + is_owned: function(self: PCefBinaryValue): Integer; stdcall; + + // Returns a copy of this object. The data in this object will also be copied. + copy: function(self: PCefBinaryValue): PCefBinaryValue; stdcall; + + // Returns the data size. + get_size: function(self: PCefBinaryValue): NativeUInt; stdcall; + + // Read up to |buffer_size| number of bytes into |buffer|. Reading begins at + // the specified byte |data_offset|. Returns the number of bytes read. + get_data: function(self: PCefBinaryValue; buffer: Pointer; buffer_size, + data_offset: NativeUInt): NativeUInt; stdcall; + end; + + // Structure representing a dictionary value. Can be used on any process and + // thread. + TCefDictionaryValue = record + // Base structure. + base: TCefBase; + + // Returns true (1) if this object is valid. Do not call any other functions + // if this function returns false (0). + is_valid: function(self: PCefDictionaryValue): Integer; stdcall; + + // Returns true (1) if this object is currently owned by another object. + is_owned: function(self: PCefDictionaryValue): Integer; stdcall; + + // Returns true (1) if the values of this object are read-only. Some APIs may + // expose read-only objects. + is_read_only: function(self: PCefDictionaryValue): Integer; stdcall; + + // Returns a writable copy of this object. If |exclude_NULL_children| is true + // (1) any NULL dictionaries or lists will be excluded from the copy. + copy: function(self: PCefDictionaryValue; exclude_empty_children: Integer): PCefDictionaryValue; stdcall; + + // Returns the number of values. + get_size: function(self: PCefDictionaryValue): NativeUInt; stdcall; + + // Removes all values. Returns true (1) on success. + clear: function(self: PCefDictionaryValue): Integer; stdcall; + + // Returns true (1) if the current dictionary has a value for the given key. + has_key: function(self: PCefDictionaryValue; const key: PCefString): Integer; stdcall; + + // Reads all keys for this dictionary into the specified vector. + get_keys: function(self: PCefDictionaryValue; const keys: TCefStringList): Integer; stdcall; + + // Removes the value at the specified key. Returns true (1) is the value was + // removed successfully. + remove: function(self: PCefDictionaryValue; const key: PCefString): Integer; stdcall; + + // Returns the value type for the specified key. + get_type: function(self: PCefDictionaryValue; const key: PCefString): TCefValueType; stdcall; + + // Returns the value at the specified key as type bool. + get_bool: function(self: PCefDictionaryValue; const key: PCefString): Integer; stdcall; + + // Returns the value at the specified key as type int. + get_int: function(self: PCefDictionaryValue; const key: PCefString): Integer; stdcall; + + // Returns the value at the specified key as type double. + get_double: function(self: PCefDictionaryValue; const key: PCefString): Double; stdcall; + + // Returns the value at the specified key as type string. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_string: function(self: PCefDictionaryValue; const key: PCefString): PCefStringUserFree; stdcall; + + // Returns the value at the specified key as type binary. + get_binary: function(self: PCefDictionaryValue; const key: PCefString): PCefBinaryValue; stdcall; + + // Returns the value at the specified key as type dictionary. + get_dictionary: function(self: PCefDictionaryValue; const key: PCefString): PCefDictionaryValue; stdcall; + + // Returns the value at the specified key as type list. + get_list: function(self: PCefDictionaryValue; const key: PCefString): PCefListValue; stdcall; + + // Sets the value at the specified key as type null. Returns true (1) if the + // value was set successfully. + set_null: function(self: PCefDictionaryValue; const key: PCefString): Integer; stdcall; + + // Sets the value at the specified key as type bool. Returns true (1) if the + // value was set successfully. + set_bool: function(self: PCefDictionaryValue; const key: PCefString; value: Integer): Integer; stdcall; + + // Sets the value at the specified key as type int. Returns true (1) if the + // value was set successfully. + set_int: function(self: PCefDictionaryValue; const key: PCefString; value: Integer): Integer; stdcall; + + // Sets the value at the specified key as type double. Returns true (1) if the + // value was set successfully. + set_double: function(self: PCefDictionaryValue; const key: PCefString; value: Double): Integer; stdcall; + + // Sets the value at the specified key as type string. Returns true (1) if the + // value was set successfully. + set_string: function(self: PCefDictionaryValue; const key: PCefString; value: PCefString): Integer; stdcall; + + // Sets the value at the specified key as type binary. Returns true (1) if the + // value was set successfully. If |value| is currently owned by another object + // then the value will be copied and the |value| reference will not change. + // Otherwise, ownership will be transferred to this object and the |value| + // reference will be invalidated. + set_binary: function(self: PCefDictionaryValue; const key: PCefString; value: PCefBinaryValue): Integer; stdcall; + + // Sets the value at the specified key as type dict. Returns true (1) if the + // value was set successfully. After calling this function the |value| object + // will no longer be valid. If |value| is currently owned by another object + // then the value will be copied and the |value| reference will not change. + // Otherwise, ownership will be transferred to this object and the |value| + // reference will be invalidated. + set_dictionary: function(self: PCefDictionaryValue; const key: PCefString; value: PCefDictionaryValue): Integer; stdcall; + + // Sets the value at the specified key as type list. Returns true (1) if the + // value was set successfully. After calling this function the |value| object + // will no longer be valid. If |value| is currently owned by another object + // then the value will be copied and the |value| reference will not change. + // Otherwise, ownership will be transferred to this object and the |value| + // reference will be invalidated. + set_list: function(self: PCefDictionaryValue; const key: PCefString; value: PCefListValue): Integer; stdcall; + end; + + // Structure representing a list value. Can be used on any process and thread. + TCefListValue = record + // Base structure. + base: TCefBase; + + // Returns true (1) if this object is valid. Do not call any other functions + // if this function returns false (0). + is_valid: function(self: PCefListValue): Integer; stdcall; + + // Returns true (1) if this object is currently owned by another object. + is_owned: function(self: PCefListValue): Integer; stdcall; + + // Returns true (1) if the values of this object are read-only. Some APIs may + // expose read-only objects. + is_read_only: function(self: PCefListValue): Integer; stdcall; + + // Returns a writable copy of this object. + copy: function(self: PCefListValue): PCefListValue; stdcall; + + // Sets the number of values. If the number of values is expanded all new + // value slots will default to type null. Returns true (1) on success. + set_size: function(self: PCefListValue; size: NativeUInt): Integer; stdcall; + + // Returns the number of values. + get_size: function(self: PCefListValue): NativeUInt; stdcall; + + // Removes all values. Returns true (1) on success. + clear: function(self: PCefListValue): Integer; stdcall; + + // Removes the value at the specified index. + remove: function(self: PCefListValue; index: Integer): Integer; stdcall; + + // Returns the value type at the specified index. + get_type: function(self: PCefListValue; index: Integer): TCefValueType; stdcall; + + // Returns the value at the specified index as type bool. + get_bool: function(self: PCefListValue; index: Integer): Integer; stdcall; + + // Returns the value at the specified index as type int. + get_int: function(self: PCefListValue; index: Integer): Integer; stdcall; + + // Returns the value at the specified index as type double. + get_double: function(self: PCefListValue; index: Integer): Double; stdcall; + + // Returns the value at the specified index as type string. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_string: function(self: PCefListValue; index: Integer): PCefStringUserFree; stdcall; + + // Returns the value at the specified index as type binary. + get_binary: function(self: PCefListValue; index: Integer): PCefBinaryValue; stdcall; + + // Returns the value at the specified index as type dictionary. + get_dictionary: function(self: PCefListValue; index: Integer): PCefDictionaryValue; stdcall; + + // Returns the value at the specified index as type list. + get_list: function(self: PCefListValue; index: Integer): PCefListValue; stdcall; + + // Sets the value at the specified index as type null. Returns true (1) if the + // value was set successfully. + set_null: function(self: PCefListValue; index: Integer): Integer; stdcall; + + // Sets the value at the specified index as type bool. Returns true (1) if the + // value was set successfully. + set_bool: function(self: PCefListValue; index, value: Integer): Integer; stdcall; + + // Sets the value at the specified index as type int. Returns true (1) if the + // value was set successfully. + set_int: function(self: PCefListValue; index, value: Integer): Integer; stdcall; + + // Sets the value at the specified index as type double. Returns true (1) if + // the value was set successfully. + set_double: function(self: PCefListValue; index: Integer; value: Double): Integer; stdcall; + + // Sets the value at the specified index as type string. Returns true (1) if + // the value was set successfully. + set_string: function(self: PCefListValue; index: Integer; value: PCefString): Integer; stdcall; + + // Sets the value at the specified index as type binary. Returns true (1) if + // the value was set successfully. After calling this function the |value| + // object will no longer be valid. If |value| is currently owned by another + // object then the value will be copied and the |value| reference will not + // change. Otherwise, ownership will be transferred to this object and the + // |value| reference will be invalidated. + set_binary: function(self: PCefListValue; index: Integer; value: PCefBinaryValue): Integer; stdcall; + + // Sets the value at the specified index as type dict. Returns true (1) if the + // value was set successfully. After calling this function the |value| object + // will no longer be valid. If |value| is currently owned by another object + // then the value will be copied and the |value| reference will not change. + // Otherwise, ownership will be transferred to this object and the |value| + // reference will be invalidated. + set_dictionary: function(self: PCefListValue; index: Integer; value: PCefDictionaryValue): Integer; stdcall; + + // Sets the value at the specified index as type list. Returns true (1) if the + // value was set successfully. After calling this function the |value| object + // will no longer be valid. If |value| is currently owned by another object + // then the value will be copied and the |value| reference will not change. + // Otherwise, ownership will be transferred to this object and the |value| + // reference will be invalidated. + set_list: function(self: PCefListValue; index: Integer; value: PCefListValue): Integer; stdcall; + end; + + // Implement this structure for asynchronous task execution. If the task is + // posted successfully and if the associated message loop is still running then + // the execute() function will be called on the target thread. If the task fails + // to post then the task object may be destroyed on the source thread instead of + // the target thread. For this reason be cautious when performing work in the + // task object destructor. + + TCefTask = record + // Base structure. + base: TCefBase; + // Method that will be executed on the target thread. + execute: procedure(self: PCefTask); stdcall; + end; + + // Structure that asynchronously executes tasks on the associated thread. It is + // safe to call the functions of this structure on any thread. + // + // CEF maintains multiple internal threads that are used for handling different + // types of tasks in different processes. The cef_thread_id_t definitions in + // cef_types.h list the common CEF threads. Task runners are also available for + // other CEF threads as appropriate (for example, V8 WebWorker threads). + TCefTaskRunner = record + // Base structure. + base: TCefBase; + + // Returns true (1) if this object is pointing to the same task runner as + // |that| object. + is_same: function(self, that: PCefTaskRunner): Integer; stdcall; + + // Returns true (1) if this task runner belongs to the current thread. + belongs_to_current_thread: function(self: PCefTaskRunner): Integer; stdcall; + + // Returns true (1) if this task runner is for the specified CEF thread. + belongs_to_thread: function(self: PCefTaskRunner; threadId: TCefThreadId): Integer; stdcall; + + // Post a task for execution on the thread associated with this task runner. + // Execution will occur asynchronously. + post_task: function(self: PCefTaskRunner; task: PCefTask): Integer; stdcall; + + // Post a task for delayed execution on the thread associated with this task + // runner. Execution will occur asynchronously. Delayed tasks are not + // supported on V8 WebWorker threads and will be executed without the + // specified delay. + post_delayed_task: function(self: PCefTaskRunner; task: PCefTask; delay_ms: Int64): Integer; stdcall; + end; + + // Structure representing a message. Can be used on any process and thread. + TCefProcessMessage = record + // Base structure. + base: TCefBase; + + // Returns true (1) if this object is valid. Do not call any other functions + // if this function returns false (0). + is_valid: function(self: PCefProcessMessage): Integer; stdcall; + + // Returns true (1) if the values of this object are read-only. Some APIs may + // expose read-only objects. + is_read_only: function(self: PCefProcessMessage): Integer; stdcall; + + // Returns a writable copy of this object. + copy: function(self: PCefProcessMessage): PCefProcessMessage; stdcall; + + // Returns the message name. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_name: function(self: PCefProcessMessage): PCefStringUserFree; stdcall; + + // Returns the list of arguments. + get_argument_list: function(self: PCefProcessMessage): PCefListValue; stdcall; + end; + + // Class used to represent a browser window. When used in the browser process + // the methods of this class may be called on any thread unless otherwise + // indicated in the comments. When used in the render process the methods of + // this class may only be called on the main thread. + + TCefBrowser = record + // Base structure. + base: TCefBase; + + // Returns the browser host object. This function can only be called in the + // browser process. + get_host: function(self: PCefBrowser): PCefBrowserHost; stdcall; + + // Returns true (1) if the browser can navigate backwards. + can_go_back: function(self: PCefBrowser): Integer; stdcall; + + // Navigate backwards. + go_back: procedure(self: PCefBrowser); stdcall; + + // Returns true (1) if the browser can navigate forwards. + can_go_forward: function(self: PCefBrowser): Integer; stdcall; + + // Navigate forwards. + go_forward: procedure(self: PCefBrowser); stdcall; + + // Returns true (1) if the browser is currently loading. + is_loading: function(self: PCefBrowser): Integer; stdcall; + + // Reload the current page. + reload: procedure(self: PCefBrowser); stdcall; + + // Reload the current page ignoring any cached data. + reload_ignore_cache: procedure(self: PCefBrowser); stdcall; + + // Stop loading the page. + stop_load: procedure(self: PCefBrowser); stdcall; + + // Returns the globally unique identifier for this browser. + get_identifier : function(self: PCefBrowser): Integer; stdcall; + + // Returns true (1) if this object is pointing to the same handle as |that| + // object. + is_same: function(self, that: PCefBrowser): Integer; stdcall; + + // Returns true (1) if the window is a popup window. + is_popup: function(self: PCefBrowser): Integer; stdcall; + + // Returns true (1) if a document has been loaded in the browser. + has_document: function(self: PCefBrowser): Integer; stdcall; + + // Returns the main (top-level) frame for the browser window. + get_main_frame: function(self: PCefBrowser): PCefFrame; stdcall; + + // Returns the focused frame for the browser window. + get_focused_frame: function(self: PCefBrowser): PCefFrame; stdcall; + + // Returns the frame with the specified identifier, or NULL if not found. + get_frame_byident: function(self: PCefBrowser; identifier: Int64): PCefFrame; stdcall; + + // Returns the frame with the specified name, or NULL if not found. + get_frame: function(self: PCefBrowser; const name: PCefString): PCefFrame; stdcall; + + // Returns the number of frames that currently exist. + get_frame_count: function(self: PCefBrowser): NativeUInt; stdcall; + + // Returns the identifiers of all existing frames. + get_frame_identifiers: procedure(self: PCefBrowser; identifiersCount: PNativeUInt; identifiers: PInt64); stdcall; + + // Returns the names of all existing frames. + get_frame_names: procedure(self: PCefBrowser; names: TCefStringList); stdcall; + + // Send a message to the specified |target_process|. Returns true (1) if the + // message was sent successfully. + send_process_message: function(self: PCefBrowser; target_process: TCefProcessId; + message: PCefProcessMessage): Integer; stdcall; + end; + + // Callback structure for cef_browser_host_t::RunFileDialog. The functions of + // this structure will be called on the browser process UI thread. + TCefRunFileDialogCallback = record + // Base structure. + base: TCefBase; + + // Called asynchronously after the file dialog is dismissed. If the selection + // was successful |file_paths| will be a single value or a list of values + // depending on the dialog mode. If the selection was cancelled |file_paths| + // will be NULL. + cont: procedure(self: PCefRunFileDialogCallback; browser_host: PCefBrowserHost; + file_paths: TCefStringList); stdcall; + end; + + // Structure used to represent the browser process aspects of a browser window. + // The functions of this structure can only be called in the browser process. + // They may be called on any thread in that process unless otherwise indicated + // in the comments. + TCefBrowserHost = record + // Base structure. + base: TCefBase; + + // Returns the hosted browser object. + get_browser: function(self: PCefBrowserHost): PCefBrowser; stdcall; + + // Call this function before destroying a contained browser window. This + // function performs any internal cleanup that may be needed before the + // browser window is destroyed. See cef_life_span_handler_t::do_close() + // documentation for additional usage information. + parent_window_will_close: procedure(self: PCefBrowserHost); stdcall; + + // Request that the browser close. The JavaScript 'onbeforeunload' event will + // be fired. If |force_close| is false (0) the event handler, if any, will be + // allowed to prompt the user and the user can optionally cancel the close. If + // |force_close| is true (1) the prompt will not be displayed and the close + // will proceed. Results in a call to cef_life_span_handler_t::do_close() if + // the event handler allows the close or if |force_close| is true (1). See + // cef_life_span_handler_t::do_close() documentation for additional usage + // information. + close_browser: procedure(self: PCefBrowserHost; force_close: Integer); stdcall; + + // Set focus for the browser window. If |enable| is true (1) focus will be set + // to the window. Otherwise, focus will be removed. + set_focus: procedure(self: PCefBrowserHost; enable: Integer); stdcall; + + // Retrieve the window handle for this browser. + get_window_handle: function(self: PCefBrowserHost): TCefWindowHandle; stdcall; + + // Retrieve the window handle of the browser that opened this browser. Will + // return NULL for non-popup windows. This function can be used in combination + // with custom handling of modal windows. + get_opener_window_handle: function(self: PCefBrowserHost): TCefWindowHandle; stdcall; + + // Returns the client for this browser. + get_client: function(self: PCefBrowserHost): PCefClient; stdcall; + + // Returns the request context for this browser. + get_request_context: function(self: PCefBrowserHost): PCefRequestContext; stdcall; + + // Returns the DevTools URL for this browser. If |http_scheme| is true (1) the + // returned URL will use the http scheme instead of the chrome-devtools + // scheme. Remote debugging can be enabled by specifying the "remote- + // debugging-port" command-line flag or by setting the + // CefSettings.remote_debugging_port value. If remote debugging is not enabled + // this function will return an NULL string. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_dev_tools_url: function(self: PCefBrowserHost; http_scheme: Integer): PCefStringUserFree; stdcall; + + // Get the current zoom level. The default zoom level is 0.0. This function + // can only be called on the UI thread. + get_zoom_level: function(self: PCefBrowserHost): Double; stdcall; + + // Change the zoom level to the specified value. Specify 0.0 to reset the zoom + // level. If called on the UI thread the change will be applied immediately. + // Otherwise, the change will be applied asynchronously on the UI thread. + set_zoom_level: procedure(self: PCefBrowserHost; zoomLevel: Double); stdcall; + + // Call to run a file chooser dialog. Only a single file chooser dialog may be + // pending at any given time. |mode| represents the type of dialog to display. + // |title| to the title to be used for the dialog and may be NULL to show the + // default title ("Open" or "Save" depending on the mode). |default_file_name| + // is the default file name to select in the dialog. |accept_types| is a list + // of valid lower-cased MIME types or file extensions specified in an input + // element and is used to restrict selectable files to such types. |callback| + // will be executed after the dialog is dismissed or immediately if another + // dialog is already pending. The dialog will be initiated asynchronously on + // the UI thread. + run_file_dialog: procedure(self: PCefBrowserHost; mode: TCefFileDialogMode; + const title, default_file_name: PCefString; accept_types: TCefStringList; + callback: PCefRunFileDialogCallback); stdcall; + + // Download the file at |url| using cef_download_handler_t. + start_download: procedure(self: PCefBrowserHost; const url: PCefString); stdcall; + + // Print the current browser contents. + print: procedure(self: PCefBrowserHost); stdcall; + + // Search for |searchText|. |identifier| can be used to have multiple searches + // running simultaniously. |forward| indicates whether to search forward or + // backward within the page. |matchCase| indicates whether the search should + // be case-sensitive. |findNext| indicates whether this is the first request + // or a follow-up. + find: procedure(self: PCefBrowserHost; identifier: Integer; + const searchText: PCefString; forward, matchCase, findNext: Integer); stdcall; + + // Cancel all searches that are currently going on. + stop_finding: procedure(self: PCefBrowserHost; clearSelection: Integer); stdcall; + + // Set whether mouse cursor change is disabled. + set_mouse_cursor_change_disabled: procedure(self: PCefBrowserHost; disabled: Integer); stdcall; + + // Returns true (1) if mouse cursor change is disabled. + is_mouse_cursor_change_disabled: function(self: PCefBrowserHost): Integer; stdcall; + + // Returns true (1) if window rendering is disabled. + is_window_rendering_disabled: function(self: PCefBrowserHost): Integer; stdcall; + + // Notify the browser that the widget has been resized. The browser will first + // call cef_render_handler_t::GetViewRect to get the new size and then call + // cef_render_handler_t::OnPaint asynchronously with the updated regions. This + // function is only used when window rendering is disabled. + was_resized: procedure(self: PCefBrowserHost); stdcall; + + // Notify the browser that it has been hidden or shown. Layouting and + // cef_render_handler_t::OnPaint notification will stop when the browser is + // hidden. This function is only used when window rendering is disabled. + was_hidden: procedure(self: PCefBrowserHost; hidden: Integer); stdcall; + + // Send a notification to the browser that the screen info has changed. The + // browser will then call cef_render_handler_t::GetScreenInfo to update the + // screen information with the new values. This simulates moving the webview + // window from one display to another, or changing the properties of the + // current display. This function is only used when window rendering is + // disabled. + notify_screen_info_changed: procedure(self: PCefBrowserHost); stdcall; + + // Invalidate the |dirtyRect| region of the view. The browser will call + // cef_render_handler_t::OnPaint asynchronously with the updated regions. This + // function is only used when window rendering is disabled. + invalidate: procedure(self: PCefBrowserHost; const dirtyRect: PCefRect; + kind: TCefPaintElementType); stdcall; + + // Send a key event to the browser. + send_key_event: procedure(self: PCefBrowserHost; const event: PCefKeyEvent); stdcall; + + // Send a mouse click event to the browser. The |x| and |y| coordinates are + // relative to the upper-left corner of the view. + send_mouse_click_event: procedure(self: PCefBrowserHost; + const event: PCefMouseEvent; kind: TCefMouseButtonType; + mouseUp, clickCount: Integer); stdcall; + + // Send a mouse move event to the browser. The |x| and |y| coordinates are + // relative to the upper-left corner of the view. + send_mouse_move_event: procedure(self: PCefBrowserHost; + const event: PCefMouseEvent; mouseLeave: Integer); stdcall; + + // Send a mouse wheel event to the browser. The |x| and |y| coordinates are + // relative to the upper-left corner of the view. The |deltaX| and |deltaY| + // values represent the movement delta in the X and Y directions respectively. + // In order to scroll inside select popups with window rendering disabled + // cef_render_handler_t::GetScreenPoint should be implemented properly. + send_mouse_wheel_event: procedure(self: PCefBrowserHost; + const event: PCefMouseEvent; deltaX, deltaY: Integer); stdcall; + + // Send a focus event to the browser. + send_focus_event: procedure(self: PCefBrowserHost; setFocus: Integer); stdcall; + + // Send a capture lost event to the browser. + send_capture_lost_event: procedure(self: PCefBrowserHost); stdcall; + + // Get the NSTextInputContext implementation for enabling IME on Mac when + // window rendering is disabled. + get_nstext_input_context: function(self: PCefBrowserHost): TCefTextInputContext; stdcall; + + // Handles a keyDown event prior to passing it through the NSTextInputClient + // machinery. + handle_key_event_before_text_input_client: procedure(self: PCefBrowserHost; keyEvent: TCefEventHandle); stdcall; + + // Performs any additional actions after NSTextInputClient handles the event. + handle_key_event_after_text_input_client: procedure(self: PCefBrowserHost; keyEvent: TCefEventHandle); stdcall; + end; + + // Implement this structure to receive string values asynchronously. + TCefStringVisitor = record + // Base structure. + base: TCefBase; + + // Method that will be executed. + visit: procedure(self: PCefStringVisitor; const str: PCefString); stdcall; + end; + + // Structure used to represent a frame in the browser window. When used in the + // browser process the functions of this structure may be called on any thread + // unless otherwise indicated in the comments. When used in the render process + // the functions of this structure may only be called on the main thread. + TCefFrame = record + // Base structure. + base: TCefBase; + + // True if this object is currently attached to a valid frame. + is_valid: function(self: PCefFrame): Integer; stdcall; + + // Execute undo in this frame. + undo: procedure(self: PCefFrame); stdcall; + + // Execute redo in this frame. + redo: procedure(self: PCefFrame); stdcall; + + // Execute cut in this frame. + cut: procedure(self: PCefFrame); stdcall; + + // Execute copy in this frame. + copy: procedure(self: PCefFrame); stdcall; + + // Execute paste in this frame. + paste: procedure(self: PCefFrame); stdcall; + + // Execute delete in this frame. + del: procedure(self: PCefFrame); stdcall; + + // Execute select all in this frame. + select_all: procedure(self: PCefFrame); stdcall; + + // Save this frame's HTML source to a temporary file and open it in the + // default text viewing application. This function can only be called from the + // browser process. + view_source: procedure(self: PCefFrame); stdcall; + + // Retrieve this frame's HTML source as a string sent to the specified + // visitor. + get_source: procedure(self: PCefFrame; visitor: PCefStringVisitor); stdcall; + + // Retrieve this frame's display text as a string sent to the specified + // visitor. + get_text: procedure(self: PCefFrame; visitor: PCefStringVisitor); stdcall; + + // Load the request represented by the |request| object. + load_request: procedure(self: PCefFrame; request: PCefRequest); stdcall; + + // Load the specified |url|. + load_url: procedure(self: PCefFrame; const url: PCefString); stdcall; + + // Load the contents of |string_val| with the specified dummy |url|. |url| + // should have a standard scheme (for example, http scheme) or behaviors like + // link clicks and web security restrictions may not behave as expected. + load_string: procedure(self: PCefFrame; const stringVal, url: PCefString); stdcall; + + // Execute a string of JavaScript code in this frame. The |script_url| + // parameter is the URL where the script in question can be found, if any. The + // renderer may request this URL to show the developer the source of the + // error. The |start_line| parameter is the base line number to use for error + // reporting. + execute_java_script: procedure(self: PCefFrame; const code, + script_url: PCefString; start_line: Integer); stdcall; + + // Returns true (1) if this is the main (top-level) frame. + is_main: function(self: PCefFrame): Integer; stdcall; + + // Returns true (1) if this is the focused frame. + is_focused: function(self: PCefFrame): Integer; stdcall; + + // Returns the name for this frame. If the frame has an assigned name (for + // example, set via the iframe "name" attribute) then that value will be + // returned. Otherwise a unique name will be constructed based on the frame + // parent hierarchy. The main (top-level) frame will always have an NULL name + // value. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_name: function(self: PCefFrame): PCefStringUserFree; stdcall; + + // Returns the globally unique identifier for this frame. + get_identifier: function(self: PCefFrame): Int64; stdcall; + + // Returns the parent of this frame or NULL if this is the main (top-level) + // frame. + get_parent: function(self: PCefFrame): PCefFrame; stdcall; + + // Returns the URL currently loaded in this frame. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_url: function(self: PCefFrame): PCefStringUserFree; stdcall; + + // Returns the browser that this frame belongs to. + get_browser: function(self: PCefFrame): PCefBrowser; stdcall; + + // Get the V8 context associated with the frame. This function can only be + // called from the render process. + get_v8context: function(self: PCefFrame): PCefv8Context; stdcall; + + // Visit the DOM document. This function can only be called from the render + // process. + visit_dom: procedure(self: PCefFrame; visitor: PCefDomVisitor); stdcall; + end; + + // Structure used to implement a custom resource bundle structure. The functions + // of this structure may be called on multiple threads. + TCefResourceBundleHandler = record + // Base structure. + base: TCefBase; + + // Called to retrieve a localized translation for the string specified by + // |message_id|. To provide the translation set |string| to the translation + // string and return true (1). To use the default translation return false + // (0). Supported message IDs are listed in cef_pack_strings.h. + get_localized_string: function(self: PCefResourceBundleHandler; + message_id: Integer; string_val: PCefString): Integer; stdcall; + + // Called to retrieve data for the resource specified by |resource_id|. To + // provide the resource data set |data| and |data_size| to the data pointer + // and size respectively and return true (1). To use the default resource data + // return false (0). The resource data will not be copied and must remain + // resident in memory. Supported resource IDs are listed in + // cef_pack_resources.h. + get_data_resource: function(self: PCefResourceBundleHandler; + resource_id: Integer; var data: Pointer; var data_size: NativeUInt): Integer; stdcall; + end; + + // Structure used to create and/or parse command line arguments. Arguments with + // '--', '-' and, on Windows, '/' prefixes are considered switches. Switches + // will always precede any arguments without switch prefixes. Switches can + // optionally have a value specified using the '=' delimiter (e.g. + // "-switch=value"). An argument of "--" will terminate switch parsing with all + // subsequent tokens, regardless of prefix, being interpreted as non-switch + // arguments. Switch names are considered case-insensitive. This structure can + // be used before cef_initialize() is called. + + TCefCommandLine = record + // Base structure. + base: TCefBase; + + // Returns true (1) if this object is valid. Do not call any other functions + // if this function returns false (0). + is_valid: function(self: PCefCommandLine): Integer; stdcall; + + // Returns true (1) if the values of this object are read-only. Some APIs may + // expose read-only objects. + is_read_only: function(self: PCefCommandLine): Integer; stdcall; + + // Returns a writable copy of this object. + copy: function(self: PCefCommandLine): PCefCommandLine; stdcall; + + // Initialize the command line with the specified |argc| and |argv| values. + // The first argument must be the name of the program. This function is only + // supported on non-Windows platforms. + init_from_argv: procedure(self: PCefCommandLine; argc: Integer; const argv: PPAnsiChar); stdcall; + + // Initialize the command line with the string returned by calling + // GetCommandLineW(). This function is only supported on Windows. + init_from_string: procedure(self: PCefCommandLine; command_line: PCefString); stdcall; + + // Reset the command-line switches and arguments but leave the program + // component unchanged. + reset: procedure(self: PCefCommandLine); stdcall; + + // Retrieve the original command line string as a vector of strings. The argv + // array: { program, [(--|-|/)switch[=value]]*, [--], [argument]* } + get_argv: procedure(self: PCefCommandLine; argv: TCefStringList); stdcall; + + // Constructs and returns the represented command line string. Use this + // function cautiously because quoting behavior is unclear. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_command_line_string: function(self: PCefCommandLine): PCefStringUserFree; stdcall; + + // Get the program part of the command line string (the first item). + // The resulting string must be freed by calling cef_string_userfree_free(). + get_program: function(self: PCefCommandLine): PCefStringUserFree; stdcall; + + // Set the program part of the command line string (the first item). + set_program: procedure(self: PCefCommandLine; program_: PCefString); stdcall; + + // Returns true (1) if the command line has switches. + has_switches: function(self: PCefCommandLine): Integer; stdcall; + + // Returns true (1) if the command line contains the given switch. + has_switch: function(self: PCefCommandLine; const name: PCefString): Integer; stdcall; + + // Returns the value associated with the given switch. If the switch has no + // value or isn't present this function returns the NULL string. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_switch_value: function(self: PCefCommandLine; const name: PCefString): PCefStringUserFree; stdcall; + + // Returns the map of switch names and values. If a switch has no value an + // NULL string is returned. + get_switches: procedure(self: PCefCommandLine; switches: TCefStringMap); stdcall; + + // Add a switch to the end of the command line. If the switch has no value + // pass an NULL value string. + append_switch: procedure(self: PCefCommandLine; const name: PCefString); stdcall; + + // Add a switch with the specified value to the end of the command line. + append_switch_with_value: procedure(self: PCefCommandLine; const name, value: PCefString); stdcall; + + // True if there are remaining command line arguments. + has_arguments: function(self: PCefCommandLine): Integer; stdcall; + + // Get the remaining command line arguments. + get_arguments: procedure(self: PCefCommandLine; arguments: TCefStringList); stdcall; + + // Add an argument to the end of the command line. + append_argument: procedure(self: PCefCommandLine; const argument: PCefString); stdcall; + + // Insert a command before the current command. Common for debuggers, like + // "valgrind" or "gdb --args". + prepend_wrapper: procedure(self: PCefCommandLine; const wrapper: PCefString); stdcall; + end; + + + // Structure used to implement browser process callbacks. The functions of this + // structure will be called on the browser process main thread unless otherwise + // indicated. + TCefBrowserProcessHandler = record + // Base structure. + base: TCefBase; + + // Called on the browser process UI thread immediately after the CEF context + // has been initialized. + on_context_initialized: procedure(self: PCefBrowserProcessHandler); stdcall; + + // Called before a child process is launched. Will be called on the browser + // process UI thread when launching a render process and on the browser + // process IO thread when launching a GPU or plugin process. Provides an + // opportunity to modify the child process command line. Do not keep a + // reference to |command_line| outside of this function. + on_before_child_process_launch: procedure(self: PCefBrowserProcessHandler; + command_line: PCefCommandLine); stdcall; + + // Called on the browser process IO thread after the main thread has been + // created for a new render process. Provides an opportunity to specify extra + // information that will be passed to + // cef_render_process_handler_t::on_render_thread_created() in the render + // process. Do not keep a reference to |extra_info| outside of this function. + on_render_process_thread_created: procedure(self: PCefBrowserProcessHandler; + extra_info: PCefListValue); stdcall; + end; + + // Structure used to implement render process callbacks. The functions of this + // structure will be called on the render process main thread (TID_RENDERER) + // unless otherwise indicated. + TCefRenderProcessHandler = record + // Base structure. + base: TCefBase; + + // Called after the render process main thread has been created. |extra_info| + // is a read-only value originating from + // cef_browser_process_handler_t::on_render_process_thread_created(). Do not + // keep a reference to |extra_info| outside of this function. + on_render_thread_created: procedure(self: PCefRenderProcessHandler; + extra_info: PCefListValue); stdcall; + + // Called after WebKit has been initialized. + on_web_kit_initialized: procedure(self: PCefRenderProcessHandler); stdcall; + + // Called after a browser has been created. When browsing cross-origin a new + // browser will be created before the old browser with the same identifier is + // destroyed. + on_browser_created: procedure(self: PCefRenderProcessHandler; + browser: PCefBrowser); stdcall; + + // Called before a browser is destroyed. + on_browser_destroyed: procedure(self: PCefRenderProcessHandler; + browser: PCefBrowser); stdcall; + + // Return the handler for browser load status events. + get_load_handler: function(self: PCefRenderProcessHandler): PCefLoadHandler; stdcall; + + // Called before browser navigation. Return true (1) to cancel the navigation + // or false (0) to allow the navigation to proceed. The |request| object + // cannot be modified in this callback. + on_before_navigation: function(self: PCefRenderProcessHandler; + browser: PCefBrowser; frame: PCefFrame; request: PCefRequest; + navigation_type: TCefNavigationType; is_redirect: Integer): Integer; stdcall; + + // Called immediately after the V8 context for a frame has been created. To + // retrieve the JavaScript 'window' object use the + // cef_v8context_t::get_global() function. V8 handles can only be accessed + // from the thread on which they are created. A task runner for posting tasks + // on the associated thread can be retrieved via the + // cef_v8context_t::get_task_runner() function. + on_context_created: procedure(self: PCefRenderProcessHandler; + browser: PCefBrowser; frame: PCefFrame; context: PCefv8Context); stdcall; + + // Called immediately before the V8 context for a frame is released. No + // references to the context should be kept after this function is called. + on_context_released: procedure(self: PCefRenderProcessHandler; + browser: PCefBrowser; frame: PCefFrame; context: PCefv8Context); stdcall; + + // Called for global uncaught exceptions in a frame. Execution of this + // callback is disabled by default. To enable set + // CefSettings.uncaught_exception_stack_size > 0. + on_uncaught_exception: procedure(self: PCefRenderProcessHandler; + browser: PCefBrowser; frame: PCefFrame; context: PCefv8Context; + exception: PCefV8Exception; stackTrace: PCefV8StackTrace); stdcall; + + // Called when a new node in the the browser gets focus. The |node| value may + // be NULL if no specific node has gained focus. The node object passed to + // this function represents a snapshot of the DOM at the time this function is + // executed. DOM objects are only valid for the scope of this function. Do not + // keep references to or attempt to access any DOM objects outside the scope + // of this function. + on_focused_node_changed: procedure(self: PCefRenderProcessHandler; + browser: PCefBrowser; frame: PCefFrame; node: PCefDomNode); stdcall; + + // Called when a new message is received from a different process. Return true + // (1) if the message was handled or false (0) otherwise. Do not keep a + // reference to or attempt to access the message outside of this callback. + on_process_message_received: function(self: PCefRenderProcessHandler; + browser: PCefBrowser; source_process: TCefProcessId; + message: PCefProcessMessage): Integer; stdcall; + end; + + // Implement this structure to provide handler implementations. Methods will be + // called by the process and/or thread indicated. + TCefApp = record + // Base structure. + base: TCefBase; + + // Provides an opportunity to view and/or modify command-line arguments before + // processing by CEF and Chromium. The |process_type| value will be NULL for + // the browser process. Do not keep a reference to the cef_command_line_t + // object passed to this function. The CefSettings.command_line_args_disabled + // value can be used to start with an NULL command-line object. Any values + // specified in CefSettings that equate to command-line arguments will be set + // before this function is called. Be cautious when using this function to + // modify command-line arguments for non-browser processes as this may result + // in undefined behavior including crashes. + on_before_command_line_processing: procedure(self: PCefApp; const process_type: PCefString; + command_line: PCefCommandLine); stdcall; + + // Provides an opportunity to register custom schemes. Do not keep a reference + // to the |registrar| object. This function is called on the main thread for + // each process and the registered schemes should be the same across all + // processes. + on_register_custom_schemes: procedure(self: PCefApp; registrar: PCefSchemeRegistrar); stdcall; + + // Return the handler for resource bundle events. If + // CefSettings.pack_loading_disabled is true (1) a handler must be returned. + // If no handler is returned resources will be loaded from pack files. This + // function is called by the browser and render processes on multiple threads. + get_resource_bundle_handler: function(self: PCefApp): PCefResourceBundleHandler; stdcall; + + // Return the handler for functionality specific to the browser process. This + // function is called on multiple threads in the browser process. + get_browser_process_handler: function(self: PCefApp): PCefBrowserProcessHandler; stdcall; + + // Return the handler for functionality specific to the render process. This + // function is called on the render process main thread. + get_render_process_handler: function(self: PCefApp): PCefRenderProcessHandler; stdcall; + end; + + + // Implement this structure to handle events related to browser life span. The + // functions of this structure will be called on the UI thread unless otherwise + // indicated. + TCefLifeSpanHandler = record + // Base structure. + base: TCefBase; + + // Called on the IO thread before a new popup window is created. The |browser| + // and |frame| parameters represent the source of the popup request. The + // |target_url| and |target_frame_name| values may be NULL if none were + // specified with the request. The |popupFeatures| structure contains + // information about the requested popup window. To allow creation of the + // popup window optionally modify |windowInfo|, |client|, |settings| and + // |no_javascript_access| and return false (0). To cancel creation of the + // popup window return true (1). The |client| and |settings| values will + // default to the source browser's values. The |no_javascript_access| value + // indicates whether the new browser window should be scriptable and in the + // same process as the source browser. + + on_before_popup: function(self: PCefLifeSpanHandler; + browser: PCefBrowser; frame: PCefFrame; + const target_url, target_frame_name: PCefString; + const popupFeatures: PCefPopupFeatures; + windowInfo: PCefWindowInfo; var client: PCefClient; + settings: PCefBrowserSettings; no_javascript_access: PInteger): Integer; stdcall; + + // Called after a new browser is created. + on_after_created: procedure(self: PCefLifeSpanHandler; browser: PCefBrowser); stdcall; + + // Called when a modal window is about to display and the modal loop should + // begin running. Return false (0) to use the default modal loop + // implementation or true (1) to use a custom implementation. + run_modal: function(self: PCefLifeSpanHandler; browser: PCefBrowser): Integer; stdcall; + + // Called when a browser has recieved a request to close. This may result + // directly from a call to cef_browser_host_t::close_browser() or indirectly + // if the browser is a top-level OS window created by CEF and the user + // attempts to close the window. This function will be called after the + // JavaScript 'onunload' event has been fired. It will not be called for + // browsers after the associated OS window has been destroyed (for those + // browsers it is no longer possible to cancel the close). + // + // If CEF created an OS window for the browser returning false (0) will send + // an OS close notification to the browser window's top-level owner (e.g. + // WM_CLOSE on Windows, performClose: on OS-X and "delete_event" on Linux). If + // no OS window exists (window rendering disabled) returning false (0) will + // cause the browser object to be destroyed immediately. Return true (1) if + // the browser is parented to another window and that other window needs to + // receive close notification via some non-standard technique. + // + // If an application provides its own top-level window it should handle OS + // close notifications by calling cef_browser_host_t::CloseBrowser(false (0)) + // instead of immediately closing (see the example below). This gives CEF an + // opportunity to process the 'onbeforeunload' event and optionally cancel the + // close before do_close() is called. + // + // The cef_life_span_handler_t::OnBeforeclose() function will be called + // immediately before the browser object is destroyed. The application should + // only exit after OnBeforeclose() has been called for all existing browsers. + // + // If the browser represents a modal window and a custom modal loop + // implementation was provided in cef_life_span_handler_t::run_modal() this + // callback should be used to restore the opener window to a usable state. + // + // By way of example consider what should happen during window close when the + // browser is parented to an application-provided top-level OS window. 1. + // User clicks the window close button which sends an OS close + // notification (e.g. WM_CLOSE on Windows, performClose: on OS-X and + // "delete_event" on Linux). + // 2. Application's top-level window receives the close notification and: + // A. Calls CefBrowserHost::CloseBrowser(false). + // B. Cancels the window close. + // 3. JavaScript 'onbeforeunload' handler executes and shows the close + // confirmation dialog (which can be overridden via + // CefJSDialogHandler::OnBeforeUnloadDialog()). + // 4. User approves the close. 5. JavaScript 'onunload' handler executes. 6. + // Application's do_close() handler is called. Application will: + // A. Call CefBrowserHost::ParentWindowWillClose() to notify CEF that the + // parent window will be closing. + // B. Set a flag to indicate that the next close attempt will be allowed. + // C. Return false. + // 7. CEF sends an OS close notification. 8. Application's top-level window + // receives the OS close notification and + // allows the window to close based on the flag from #6B. + // 9. Browser OS window is destroyed. 10. Application's + // cef_life_span_handler_t::OnBeforeclose() handler is called and + // the browser object is destroyed. + // 11. Application exits by calling cef_quit_message_loop() if no other + // browsers + // exist. + do_close: function(self: PCefLifeSpanHandler; browser: PCefBrowser): Integer; stdcall; + + // Called just before a browser is destroyed. Release all references to the + // browser object and do not attempt to execute any functions on the browser + // object after this callback returns. If this is a modal window and a custom + // modal loop implementation was provided in run_modal() this callback should + // be used to exit the custom modal loop. See do_close() documentation for + // additional usage information. + on_before_close: procedure(self: PCefLifeSpanHandler; browser: PCefBrowser); stdcall; + end; + + + // functions of this structure will be called on the browser process UI thread + // or render process main thread (TID_RENDERER). + + TCefLoadHandler = record + // Base structure. + base: TCefBase; + + // Called when the loading state has changed. This callback will be executed + // twice -- once when loading is initiated either programmatically or by user + // action, and once when loading is terminated due to completion, cancellation + // of failure. + on_loading_state_change: procedure(self: PCefLoadHandler; + browser: PCefBrowser; isLoading, canGoBack, canGoForward: Integer); stdcall; + + // Called when the browser begins loading a frame. The |frame| value will + // never be NULL -- call the is_main() function to check if this frame is the + // main frame. Multiple frames may be loading at the same time. Sub-frames may + // start or continue loading after the main frame load has ended. This + // function may not be called for a particular frame if the load request for + // that frame fails. For notification of overall browser load status use + // OnLoadingStateChange instead. + on_load_start: procedure(self: PCefLoadHandler; + browser: PCefBrowser; frame: PCefFrame); stdcall; + + // Called when the browser is done loading a frame. The |frame| value will + // never be NULL -- call the is_main() function to check if this frame is the + // main frame. Multiple frames may be loading at the same time. Sub-frames may + // start or continue loading after the main frame load has ended. This + // function will always be called for all frames irrespective of whether the + // request completes successfully. + on_load_end: procedure(self: PCefLoadHandler; browser: PCefBrowser; + frame: PCefFrame; httpStatusCode: Integer); stdcall; + + // Called when the resource load for a navigation fails or is canceled. + // |errorCode| is the error code number, |errorText| is the error text and + // |failedUrl| is the URL that failed to load. See net\base\net_error_list.h + // for complete descriptions of the error codes. + on_load_error: procedure(self: PCefLoadHandler; browser: PCefBrowser; + frame: PCefFrame; errorCode: Integer; const errorText, failedUrl: PCefString); stdcall; + end; + + // Generic callback structure used for asynchronous continuation. + TCefCallback = record + // Base structure. + base: TCefBase; + + // Continue processing. + cont: procedure(self: PCefCallback); stdcall; + + // Cancel processing. + cancel: procedure(self: PCefCallback); stdcall; + end; + + // Generic callback structure used for asynchronous completion. + TCefCompletionHandler = record + // Base structure. + base: TCefBase; + // Method that will be called once the task is complete. + on_complete: procedure(self: PCefCompletionHandler); stdcall; + end; + + + // Structure used to implement a custom request handler structure. The functions + // of this structure will always be called on the IO thread. + TCefResourceHandler = record + // Base structure. + base: TCefBase; + + // Begin processing the request. To handle the request return true (1) and + // call cef_callback_t::cont() once the response header information is + // available (cef_callback_t::cont() can also be called from inside this + // function if header information is available immediately). To cancel the + // request return false (0). + process_request: function(self: PCefResourceHandler; + request: PCefRequest; callback: PCefCallback): Integer; stdcall; + + // Retrieve response header information. If the response length is not known + // set |response_length| to -1 and read_response() will be called until it + // returns false (0). If the response length is known set |response_length| to + // a positive value and read_response() will be called until it returns false + // (0) or the specified number of bytes have been read. Use the |response| + // object to set the mime type, http status code and other optional header + // values. To redirect the request to a new URL set |redirectUrl| to the new + // URL. + get_response_headers: procedure(self: PCefResourceHandler; + response: PCefResponse; response_length: PInt64; redirectUrl: PCefString); stdcall; + + // Read response data. If data is available immediately copy up to + // |bytes_to_read| bytes into |data_out|, set |bytes_read| to the number of + // bytes copied, and return true (1). To read the data at a later time set + // |bytes_read| to 0, return true (1) and call cef_callback_t::cont() when the + // data is available. To indicate response completion return false (0). + read_response: function(self: PCefResourceHandler; + data_out: Pointer; bytes_to_read: Integer; bytes_read: PInteger; + callback: PCefCallback): Integer; stdcall; + + // Return true (1) if the specified cookie can be sent with the request or + // false (0) otherwise. If false (0) is returned for any cookie then no + // cookies will be sent with the request. + can_get_cookie: function(self: PCefResourceHandler; + const cookie: PCefCookie): Integer; stdcall; + + // Return true (1) if the specified cookie returned with the response can be + // set or false (0) otherwise. + can_set_cookie: function(self: PCefResourceHandler; + const cookie: PCefCookie): Integer; stdcall; + + // Request processing has been canceled. + cancel: procedure(self: PCefResourceHandler); stdcall; + end; + + // Callback structure used for asynchronous continuation of authentication + // requests. + TCefAuthCallback = record + // Base structure. + base: TCefBase; + + // Continue the authentication request. + cont: procedure(self: PCefAuthCallback; + const username, password: PCefString); stdcall; + + // Cancel the authentication request. + cancel: procedure(self: PCefAuthCallback); stdcall; + end; + + // Callback structure used for asynchronous continuation of quota requests. + TCefQuotaCallback = record + // Base structure. + base: TCefBase; + + // Continue the quota request. If |allow| is true (1) the request will be + // allowed. Otherwise, the request will be denied. + cont: procedure(self: PCefQuotaCallback; allow: Integer); stdcall; + // Cancel the quota request. + cancel: procedure(self: PCefQuotaCallback); stdcall; + end; + + // Callback structure used for asynchronous continuation of url requests when + // invalid SSL certificates are encountered. + TCefAllowCertificateErrorCallback = record + // Base structure. + base: TCefBase; + + // Continue the url request. If |allow| is true (1) the request will be + // continued. Otherwise, the request will be canceled. + cont: procedure(self: PCefAllowCertificateErrorCallback; allow: Integer); stdcall; + end; + + // Implement this structure to handle events related to browser requests. The + // functions of this structure will be called on the thread indicated. + TCefRequestHandler = record + // Base structure. + base: TCefBase; + + // Called on the UI thread before browser navigation. Return true (1) to + // cancel the navigation or false (0) to allow the navigation to proceed. The + // |request| object cannot be modified in this callback. + // cef_load_handler_t::OnLoadingStateChange will be called twice in all cases. + // If the navigation is allowed cef_load_handler_t::OnLoadStart and + // cef_load_handler_t::OnLoadEnd will be called. If the navigation is canceled + // cef_load_handler_t::OnLoadError will be called with an |errorCode| value of + // ERR_ABORTED. + on_before_browse: function(self: PCefRequestHandler; browser: PCefBrowser; + frame: PCefFrame; request: PCefRequest; is_redirect: Integer): Integer; stdcall; + + // Called on the IO thread before a resource request is loaded. The |request| + // object may be modified. To cancel the request return true (1) otherwise + // return false (0). + on_before_resource_load: function(self: PCefRequestHandler; + browser: PCefBrowser; frame: PCefFrame; request: PCefRequest): Integer; stdcall; + + // Called on the IO thread before a resource is loaded. To allow the resource + // to load normally return NULL. To specify a handler for the resource return + // a cef_resource_handler_t object. The |request| object should not be + // modified in this callback. + get_resource_handler: function(self: PCefRequestHandler; + browser: PCefBrowser; frame: PCefFrame; request: PCefRequest): PCefResourceHandler; stdcall; + + // Called on the IO thread when a resource load is redirected. The |old_url| + // parameter will contain the old URL. The |new_url| parameter will contain + // the new URL and can be changed if desired. + on_resource_redirect: procedure(self: PCefRequestHandler; + browser: PCefBrowser; frame: PCefFrame; const old_url: PCefString; + new_url: PCefString); stdcall; + + // Called on the IO thread when the browser needs credentials from the user. + // |isProxy| indicates whether the host is a proxy server. |host| contains the + // hostname and |port| contains the port number. Return true (1) to continue + // the request and call cef_auth_callback_t::cont() when the authentication + // information is available. Return false (0) to cancel the request. + get_auth_credentials: function(self: PCefRequestHandler; + browser: PCefBrowser; frame: PCefFrame; isProxy: Integer; const host: PCefString; + port: Integer; const realm, scheme: PCefString; callback: PCefAuthCallback): Integer; stdcall; + + // Called on the IO thread when JavaScript requests a specific storage quota + // size via the webkitStorageInfo.requestQuota function. |origin_url| is the + // origin of the page making the request. |new_size| is the requested quota + // size in bytes. Return true (1) and call cef_quota_callback_t::cont() either + // in this function or at a later time to grant or deny the request. Return + // false (0) to cancel the request. + on_quota_request: function(self: PCefRequestHandler; browser: PCefBrowser; + const origin_url: PCefString; new_size: Int64; callback: PCefQuotaCallback): Integer; stdcall; + + // Called on the UI thread to handle requests for URLs with an unknown + // protocol component. Set |allow_os_execution| to true (1) to attempt + // execution via the registered OS protocol handler, if any. SECURITY WARNING: + // YOU SHOULD USE THIS METHOD TO ENFORCE RESTRICTIONS BASED ON SCHEME, HOST OR + // OTHER URL ANALYSIS BEFORE ALLOWING OS EXECUTION. + on_protocol_execution: procedure(self: PCefRequestHandler; + browser: PCefBrowser; const url: PCefString; allow_os_execution: PInteger); stdcall; + + // Called on the UI thread to handle requests for URLs with an invalid SSL + // certificate. Return true (1) and call + // cef_allow_certificate_error_callback_t:: cont() either in this function or + // at a later time to continue or cancel the request. Return false (0) to + // cancel the request immediately. If |callback| is NULL the error cannot be + // recovered from and the request will be canceled automatically. If + // CefSettings.ignore_certificate_errors is set all invalid certificates will + // be accepted without calling this function. + on_certificate_error: function(self: PCefRequestHandler; + cert_error: TCefErrorCode; const request_url: PCefString; + callback: PCefAllowCertificateErrorCallback): Integer; stdcall; + + // Called on the browser process IO thread before a plugin is loaded. Return + // true (1) to block loading of the plugin. + on_before_plugin_load: function(self: PCefRequestHandler; browser: PCefBrowser; + const url, policy_url: PCefString; info: PCefWebPluginInfo): Integer; stdcall; + + // Called on the browser process UI thread when a plugin has crashed. + // |plugin_path| is the path of the plugin that crashed. + on_plugin_crashed: procedure(self: PCefRequestHandler; browser: PCefBrowser; + const plugin_path: PCefString); stdcall; + + // Called on the browser process UI thread when the render process terminates + // unexpectedly. |status| indicates how the process terminated. + on_render_process_terminated: procedure(self: PCefRequestHandler; + browser: PCefBrowser; status: TCefTerminationStatus); stdcall + end; + + // Implement this structure to handle events related to browser display state. + + // The functions of this structure will be called on the UI thread. + TCefDisplayHandler = record + // Base structure. + base: TCefBase; + + // Called when a frame's address has changed. + on_address_change: procedure(self: PCefDisplayHandler; + browser: PCefBrowser; frame: PCefFrame; const url: PCefString); stdcall; + + // Called when the page title changes. + on_title_change: procedure(self: PCefDisplayHandler; + browser: PCefBrowser; const title: PCefString); stdcall; + + // Called when the browser is about to display a tooltip. |text| contains the + // text that will be displayed in the tooltip. To handle the display of the + // tooltip yourself return true (1). Otherwise, you can optionally modify + // |text| and then return false (0) to allow the browser to display the + // tooltip. When window rendering is disabled the application is responsible + // for drawing tooltips and the return value is ignored. + on_tooltip: function(self: PCefDisplayHandler; + browser: PCefBrowser; text: PCefString): Integer; stdcall; + + // Called when the browser receives a status message. |text| contains the text + // that will be displayed in the status message. + on_status_message: procedure(self: PCefDisplayHandler; + browser: PCefBrowser; const value: PCefString); stdcall; + + // Called to display a console message. Return true (1) to stop the message + // from being output to the console. + on_console_message: function(self: PCefDisplayHandler; + browser: PCefBrowser; const message: PCefString; + const source: PCefString; line: Integer): Integer; stdcall; + end; + + // Implement this structure to handle events related to focus. The functions of + // this structure will be called on the UI thread. + TCefFocusHandler = record + // Base structure. + base: TCefBase; + + // Called when the browser component is about to loose focus. For instance, if + // focus was on the last HTML element and the user pressed the TAB key. |next| + // will be true (1) if the browser is giving focus to the next component and + // false (0) if the browser is giving focus to the previous component. + on_take_focus: procedure(self: PCefFocusHandler; + browser: PCefBrowser; next: Integer); stdcall; + + // Called when the browser component is requesting focus. |source| indicates + // where the focus request is originating from. Return false (0) to allow the + // focus to be set or true (1) to cancel setting the focus. + on_set_focus: function(self: PCefFocusHandler; + browser: PCefBrowser; source: TCefFocusSource): Integer; stdcall; + + // Called when the browser component has received focus. + on_got_focus: procedure(self: PCefFocusHandler; browser: PCefBrowser); stdcall; + end; + + // Implement this structure to handle events related to keyboard input. The + // functions of this structure will be called on the UI thread. + TCefKeyboardHandler = record + // Base structure. + base: TCefBase; + + // Called before a keyboard event is sent to the renderer. |event| contains + // information about the keyboard event. |os_event| is the operating system + // event message, if any. Return true (1) if the event was handled or false + // (0) otherwise. If the event will be handled in on_key_event() as a keyboard + // shortcut set |is_keyboard_shortcut| to true (1) and return false (0). + on_pre_key_event: function(self: PCefKeyboardHandler; + browser: PCefBrowser; const event: PCefKeyEvent; + os_event: TCefEventHandle; is_keyboard_shortcut: PInteger): Integer; stdcall; + + // Called after the renderer and JavaScript in the page has had a chance to + // handle the event. |event| contains information about the keyboard event. + // |os_event| is the operating system event message, if any. Return true (1) + // if the keyboard event was handled or false (0) otherwise. + on_key_event: function(self: PCefKeyboardHandler; + browser: PCefBrowser; const event: PCefKeyEvent; + os_event: TCefEventHandle): Integer; stdcall; + end; + + // Callback structure used for asynchronous continuation of JavaScript dialog + // requests. + TCefJsDialogCallback = record + // Base structure. + base: TCefBase; + + // Continue the JS dialog request. Set |success| to true (1) if the OK button + // was pressed. The |user_input| value should be specified for prompt dialogs. + cont: procedure(self: PCefJsDialogCallback; success: Integer; const user_input: PCefString); stdcall; + end; + + // Implement this structure to handle events related to JavaScript dialogs. The + // functions of this structure will be called on the UI thread. + TCefJsDialogHandler = record + // Base structure. + base: TCefBase; + + // Called to run a JavaScript dialog. The |default_prompt_text| value will be + // specified for prompt dialogs only. Set |suppress_message| to true (1) and + // return false (0) to suppress the message (suppressing messages is + // preferable to immediately executing the callback as this is used to detect + // presumably malicious behavior like spamming alert messages in + // onbeforeunload). Set |suppress_message| to false (0) and return false (0) + // to use the default implementation (the default implementation will show one + // modal dialog at a time and suppress any additional dialog requests until + // the displayed dialog is dismissed). Return true (1) if the application will + // use a custom dialog or if the callback has been executed immediately. + // Custom dialogs may be either modal or modeless. If a custom dialog is used + // the application must execute |callback| once the custom dialog is + // dismissed. + on_jsdialog: function(self: PCefJsDialogHandler; + browser: PCefBrowser; const origin_url, accept_lang: PCefString; + dialog_type: TCefJsDialogType; const message_text, default_prompt_text: PCefString; + callback: PCefJsDialogCallback; suppress_message: PInteger): Integer; stdcall; + + // Called to run a dialog asking the user if they want to leave a page. Return + // false (0) to use the default dialog implementation. Return true (1) if the + // application will use a custom dialog or if the callback has been executed + // immediately. Custom dialogs may be either modal or modeless. If a custom + // dialog is used the application must execute |callback| once the custom + // dialog is dismissed. + on_before_unload_dialog: function(self: PCefJsDialogHandler; + browser: PCefBrowser; const message_text: PCefString; is_reload: Integer; + callback: PCefJsDialogCallback): Integer; stdcall; + + // Called to cancel any pending dialogs and reset any saved dialog state. Will + // be called due to events like page navigation irregardless of whether any + // dialogs are currently pending. + on_reset_dialog_state: procedure(self: PCefJsDialogHandler; browser: PCefBrowser); stdcall; + + // Called when the default implementation dialog is closed. + on_dialog_closed: procedure(self: PCefJsDialogHandler; browser: PCefBrowser); stdcall; + end; + + // Supports creation and modification of menus. See cef_menu_id_t for the + // command ids that have default implementations. All user-defined command ids + // should be between MENU_ID_USER_FIRST and MENU_ID_USER_LAST. The functions of + // this structure can only be accessed on the browser process the UI thread. + TCefMenuModel = record + // Base structure. + base: TCefBase; + + // Clears the menu. Returns true (1) on success. + clear: function(self: PCefMenuModel): Integer; stdcall; + + // Returns the number of items in this menu. + get_count: function(self: PCefMenuModel): Integer; stdcall; + + // Add a separator to the menu. Returns true (1) on success. + add_separator: function(self: PCefMenuModel): Integer; stdcall; + + // Add an item to the menu. Returns true (1) on success. + add_item: function(self: PCefMenuModel; command_id: Integer; + const text: PCefString): Integer; stdcall; + + // Add a check item to the menu. Returns true (1) on success. + add_check_item: function(self: PCefMenuModel; command_id: Integer; + const text: PCefString): Integer; stdcall; + + // Add a radio item to the menu. Only a single item with the specified + // |group_id| can be checked at a time. Returns true (1) on success. + add_radio_item: function(self: PCefMenuModel; command_id: Integer; + const text: PCefString; group_id: Integer): Integer; stdcall; + + // Add a sub-menu to the menu. The new sub-menu is returned. + add_sub_menu: function(self: PCefMenuModel; command_id: Integer; + const text: PCefString): PCefMenuModel; stdcall; + + // Insert a separator in the menu at the specified |index|. Returns true (1) + // on success. + insert_separator_at: function(self: PCefMenuModel; index: Integer): Integer; stdcall; + + // Insert an item in the menu at the specified |index|. Returns true (1) on + // success. + insert_item_at: function(self: PCefMenuModel; index, command_id: Integer; + const text: PCefString): Integer; stdcall; + + // Insert a check item in the menu at the specified |index|. Returns true (1) + // on success. + insert_check_item_at: function(self: PCefMenuModel; index, command_id: Integer; + const text: PCefString): Integer; stdcall; + + // Insert a radio item in the menu at the specified |index|. Only a single + // item with the specified |group_id| can be checked at a time. Returns true + // (1) on success. + insert_radio_item_at: function(self: PCefMenuModel; index, command_id: Integer; + const text: PCefString; group_id: Integer): Integer; stdcall; + + // Insert a sub-menu in the menu at the specified |index|. The new sub-menu is + // returned. + insert_sub_menu_at: function(self: PCefMenuModel; index, command_id: Integer; + const text: PCefString): PCefMenuModel; stdcall; + + // Removes the item with the specified |command_id|. Returns true (1) on + // success. + remove: function(self: PCefMenuModel; command_id: Integer): Integer; stdcall; + + // Removes the item at the specified |index|. Returns true (1) on success. + remove_at: function(self: PCefMenuModel; index: Integer): Integer; stdcall; + + // Returns the index associated with the specified |command_id| or -1 if not + // found due to the command id not existing in the menu. + get_index_of: function(self: PCefMenuModel; command_id: Integer): Integer; stdcall; + + // Returns the command id at the specified |index| or -1 if not found due to + // invalid range or the index being a separator. + get_command_id_at: function(self: PCefMenuModel; index: Integer): Integer; stdcall; + + // Sets the command id at the specified |index|. Returns true (1) on success. + set_command_id_at: function(self: PCefMenuModel; index, command_id: Integer): Integer; stdcall; + + // Returns the label for the specified |command_id| or NULL if not found. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_label: function(self: PCefMenuModel; command_id: Integer): PCefStringUserFree; stdcall; + + // Returns the label at the specified |index| or NULL if not found due to + // invalid range or the index being a separator. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_label_at: function(self: PCefMenuModel; index: Integer): PCefStringUserFree; stdcall; + + // Sets the label for the specified |command_id|. Returns true (1) on success. + set_label: function(self: PCefMenuModel; command_id: Integer; + const text: PCefString): Integer; stdcall; + + // Set the label at the specified |index|. Returns true (1) on success. + set_label_at: function(self: PCefMenuModel; index: Integer; + const text: PCefString): Integer; stdcall; + + // Returns the item type for the specified |command_id|. + get_type: function(self: PCefMenuModel; command_id: Integer): TCefMenuItemType; stdcall; + + // Returns the item type at the specified |index|. + get_type_at: function(self: PCefMenuModel; index: Integer): TCefMenuItemType; stdcall; + + // Returns the group id for the specified |command_id| or -1 if invalid. + get_group_id: function(self: PCefMenuModel; command_id: Integer): Integer; stdcall; + + // Returns the group id at the specified |index| or -1 if invalid. + get_group_id_at: function(self: PCefMenuModel; index: Integer): Integer; stdcall; + + // Sets the group id for the specified |command_id|. Returns true (1) on + // success. + set_group_id: function(self: PCefMenuModel; command_id, group_id: Integer): Integer; stdcall; + + // Sets the group id at the specified |index|. Returns true (1) on success. + set_group_id_at: function(self: PCefMenuModel; index, group_id: Integer): Integer; stdcall; + + // Returns the submenu for the specified |command_id| or NULL if invalid. + get_sub_menu: function(self: PCefMenuModel; command_id: Integer): PCefMenuModel; stdcall; + + // Returns the submenu at the specified |index| or NULL if invalid. + get_sub_menu_at: function(self: PCefMenuModel; index: Integer): PCefMenuModel; stdcall; + + // Returns true (1) if the specified |command_id| is visible. + is_visible: function(self: PCefMenuModel; command_id: Integer): Integer; stdcall; + + // Returns true (1) if the specified |index| is visible. + is_visible_at: function(self: PCefMenuModel; index: Integer): Integer; stdcall; + + // Change the visibility of the specified |command_id|. Returns true (1) on + // success. + set_visible: function(self: PCefMenuModel; command_id, visible: Integer): Integer; stdcall; + + // Change the visibility at the specified |index|. Returns true (1) on + // success. + set_visible_at: function(self: PCefMenuModel; index, visible: Integer): Integer; stdcall; + + // Returns true (1) if the specified |command_id| is enabled. + is_enabled: function(self: PCefMenuModel; command_id: Integer): Integer; stdcall; + + // Returns true (1) if the specified |index| is enabled. + is_enabled_at: function(self: PCefMenuModel; index: Integer): Integer; stdcall; + + // Change the enabled status of the specified |command_id|. Returns true (1) + // on success. + set_enabled: function(self: PCefMenuModel; command_id, enabled: Integer): Integer; stdcall; + + // Change the enabled status at the specified |index|. Returns true (1) on + // success. + set_enabled_at: function(self: PCefMenuModel; index, enabled: Integer): Integer; stdcall; + + // Returns true (1) if the specified |command_id| is checked. Only applies to + // check and radio items. + is_checked: function(self: PCefMenuModel; command_id: Integer): Integer; stdcall; + + // Returns true (1) if the specified |index| is checked. Only applies to check + // and radio items. + is_checked_at: function(self: PCefMenuModel; index: Integer): Integer; stdcall; + + // Check the specified |command_id|. Only applies to check and radio items. + // Returns true (1) on success. + set_checked: function(self: PCefMenuModel; command_id, checked: Integer): Integer; stdcall; + + // Check the specified |index|. Only applies to check and radio items. Returns + // true (1) on success. + set_checked_at: function(self: PCefMenuModel; index, checked: Integer): Integer; stdcall; + + // Returns true (1) if the specified |command_id| has a keyboard accelerator + // assigned. + has_accelerator: function(self: PCefMenuModel; command_id: Integer): Integer; stdcall; + + // Returns true (1) if the specified |index| has a keyboard accelerator + // assigned. + has_accelerator_at: function(self: PCefMenuModel; index: Integer): Integer; stdcall; + + // Set the keyboard accelerator for the specified |command_id|. |key_code| can + // be any virtual key or character value. Returns true (1) on success. + set_accelerator: function(self: PCefMenuModel; command_id, key_code, + shift_pressed, ctrl_pressed, alt_pressed: Integer): Integer; stdcall; + + // Set the keyboard accelerator at the specified |index|. |key_code| can be + // any virtual key or character value. Returns true (1) on success. + set_accelerator_at: function(self: PCefMenuModel; index, key_code, + shift_pressed, ctrl_pressed, alt_pressed: Integer): Integer; stdcall; + + // Remove the keyboard accelerator for the specified |command_id|. Returns + // true (1) on success. + remove_accelerator: function(self: PCefMenuModel; command_id: Integer): Integer; stdcall; + + // Remove the keyboard accelerator at the specified |index|. Returns true (1) + // on success. + remove_accelerator_at: function(self: PCefMenuModel; index: Integer): Integer; stdcall; + + // Retrieves the keyboard accelerator for the specified |command_id|. Returns + // true (1) on success. + get_accelerator: function(self: PCefMenuModel; command_id: Integer; key_code, + shift_pressed, ctrl_pressed, alt_pressed: PInteger): Integer; stdcall; + + // Retrieves the keyboard accelerator for the specified |index|. Returns true + // (1) on success. + get_accelerator_at: function(self: PCefMenuModel; index: Integer; key_code, + shift_pressed, ctrl_pressed, alt_pressed: PInteger): Integer; stdcall; + end; + + // Implement this structure to handle context menu events. The functions of this + // structure will be called on the UI thread. + TCefContextMenuHandler = record + // Base structure. + base: TCefBase; + + // Called before a context menu is displayed. |params| provides information + // about the context menu state. |model| initially contains the default + // context menu. The |model| can be cleared to show no context menu or + // modified to show a custom menu. Do not keep references to |params| or + // |model| outside of this callback. + on_before_context_menu: procedure(self: PCefContextMenuHandler; + browser: PCefBrowser; frame: PCefFrame; params: PCefContextMenuParams; + model: PCefMenuModel); stdcall; + + // Called to execute a command selected from the context menu. Return true (1) + // if the command was handled or false (0) for the default implementation. See + // cef_menu_id_t for the command ids that have default implementations. All + // user-defined command ids should be between MENU_ID_USER_FIRST and + // MENU_ID_USER_LAST. |params| will have the same values as what was passed to + // on_before_context_menu(). Do not keep a reference to |params| outside of + // this callback. + on_context_menu_command: function(self: PCefContextMenuHandler; + browser: PCefBrowser; frame: PCefFrame; params: PCefContextMenuParams; + command_id: Integer; event_flags: Integer): Integer; stdcall; + + // Called when the context menu is dismissed irregardless of whether the menu + // was NULL or a command was selected. + on_context_menu_dismissed: procedure(self: PCefContextMenuHandler; + browser: PCefBrowser; frame: PCefFrame); stdcall; + end; + + + // Provides information about the context menu state. The ethods of this + // structure can only be accessed on browser process the UI thread. + TCefContextMenuParams = record + // Base structure. + base: TCefBase; + + // Returns the X coordinate of the mouse where the context menu was invoked. + // Coords are relative to the associated RenderView's origin. + get_xcoord: function(self: PCefContextMenuParams): Integer; stdcall; + + // Returns the Y coordinate of the mouse where the context menu was invoked. + // Coords are relative to the associated RenderView's origin. + get_ycoord: function(self: PCefContextMenuParams): Integer; stdcall; + + // Returns flags representing the type of node that the context menu was + // invoked on. + get_type_flags: function(self: PCefContextMenuParams): Integer; stdcall; + + // Returns the URL of the link, if any, that encloses the node that the + // context menu was invoked on. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_link_url: function(self: PCefContextMenuParams): PCefStringUserFree; stdcall; + + // Returns the link URL, if any, to be used ONLY for "copy link address". We + // don't validate this field in the frontend process. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_unfiltered_link_url: function(self: PCefContextMenuParams): PCefStringUserFree; stdcall; + + // Returns the source URL, if any, for the element that the context menu was + // invoked on. Example of elements with source URLs are img, audio, and video. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_source_url: function(self: PCefContextMenuParams): PCefStringUserFree; stdcall; + + // Returns true (1) if the context menu was invoked on an image which has non- + // NULL contents. + has_image_contents: function(self: PCefContextMenuParams): Integer; stdcall; + + // Returns the URL of the top level page that the context menu was invoked on. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_page_url: function(self: PCefContextMenuParams): PCefStringUserFree; stdcall; + + // Returns the URL of the subframe that the context menu was invoked on. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_frame_url: function(self: PCefContextMenuParams): PCefStringUserFree; stdcall; + + // Returns the character encoding of the subframe that the context menu was + // invoked on. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_frame_charset: function(self: PCefContextMenuParams): PCefStringUserFree; stdcall; + + // Returns the type of context node that the context menu was invoked on. + get_media_type: function(self: PCefContextMenuParams): TCefContextMenuMediaType; stdcall; + + // Returns flags representing the actions supported by the media element, if + // any, that the context menu was invoked on. + get_media_state_flags: function(self: PCefContextMenuParams): Integer; stdcall; + + // Returns the text of the selection, if any, that the context menu was + // invoked on. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_selection_text: function(self: PCefContextMenuParams): PCefStringUserFree; stdcall; + + // Returns true (1) if the context menu was invoked on an editable node. + is_editable: function(self: PCefContextMenuParams): Integer; stdcall; + + // Returns true (1) if the context menu was invoked on an editable node where + // speech-input is enabled. + is_speech_input_enabled: function(self: PCefContextMenuParams): Integer; stdcall; + + // Returns flags representing the actions supported by the editable node, if + // any, that the context menu was invoked on. + get_edit_state_flags: function(self: PCefContextMenuParams): Integer; stdcall; + end; + + // Callback structure used for asynchronous continuation of geolocation + // permission requests. + TCefGeolocationCallback = record + // Base structure. + base: TCefBase; + + // Call to allow or deny geolocation access. + cont: procedure(self: PCefGeolocationCallback; allow: Integer); stdcall; + end; + + + // Implement this structure to handle events related to geolocation permission + // requests. The functions of this structure will be called on the browser + // process IO thread. + TCefGeolocationHandler = record + // Base structure. + base: TCefBase; + + // Called when a page requests permission to access geolocation information. + // |requesting_url| is the URL requesting permission and |request_id| is the + // unique ID for the permission request. Call + // cef_geolocation_callback_t::Continue to allow or deny the permission + // request. + on_request_geolocation_permission: procedure(self: PCefGeolocationHandler; + browser: PCefBrowser; const requesting_url: PCefString; request_id: Integer; + callback: PCefGeolocationCallback); stdcall; + + // Called when a geolocation access request is canceled. |requesting_url| is + // the URL that originally requested permission and |request_id| is the unique + // ID for the permission request. + on_cancel_geolocation_permission: procedure(self: PCefGeolocationHandler; + browser: PCefBrowser; const requesting_url: PCefString; request_id: Integer); stdcall; + end; + + // Implement this structure to provide handler implementations. + TCefClient = record + // Base structure. + base: TCefBase; + + // Return the handler for context menus. If no handler is provided the default + // implementation will be used. + get_context_menu_handler: function(self: PCefClient): PCefContextMenuHandler; stdcall; + + // Return the handler for dialogs. If no handler is provided the default + // implementation will be used. + get_dialog_handler: function(self: PCefClient): PCefDialogHandler; stdcall; + + // Return the handler for browser display state events. + get_display_handler: function(self: PCefClient): PCefDisplayHandler; stdcall; + + // Return the handler for download events. If no handler is returned downloads + // will not be allowed. + get_download_handler: function(self: PCefClient): PCefDownloadHandler; stdcall; + + // Return the handler for drag events. + get_drag_handler: function(self: PCefClient): PCefDragHandler; stdcall; + + // Return the handler for focus events. + get_focus_handler: function(self: PCefClient): PCefFocusHandler; stdcall; + + // Return the handler for geolocation permissions requests. If no handler is + // provided geolocation access will be denied by default. + get_geolocation_handler: function(self: PCefClient): PCefGeolocationHandler; stdcall; + + // Return the handler for JavaScript dialog events. + get_jsdialog_handler: function(self: PCefClient): PCefJsDialogHandler; stdcall; + + // Return the handler for keyboard events. + get_keyboard_handler: function(self: PCefClient): PCefKeyboardHandler; stdcall; + + // Return the handler for browser life span events. + get_life_span_handler: function(self: PCefClient): PCefLifeSpanHandler; stdcall; + + // Return the handler for browser load status events. + get_load_handler: function(self: PCefClient): PCefLoadHandler; stdcall; + + // Return the handler for off-screen rendering events. + get_render_handler: function(self: PCefClient): PCefRenderHandler; stdcall; + + // Return the handler for browser request events. + get_request_handler: function(self: PCefClient): PCefRequestHandler; stdcall; + + // Called when a new message is received from a different process. Return true + // (1) if the message was handled or false (0) otherwise. Do not keep a + // reference to or attempt to access the message outside of this callback. + on_process_message_received: function(self: PCefClient; browser: PCefBrowser; + source_process: TCefProcessId; message: PCefProcessMessage): Integer; stdcall; + end; + + // Structure used to represent a web request. The functions of this structure + // may be called on any thread. + TCefRequest = record + // Base structure. + base: TCefBase; + + // Returns true (1) if this object is read-only. + is_read_only: function(self: PCefRequest): Integer; stdcall; + + // Get the fully qualified URL. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_url: function(self: PCefRequest): PCefStringUserFree; stdcall; + // Set the fully qualified URL. + set_url: procedure(self: PCefRequest; const url: PCefString); stdcall; + + // Get the request function type. The value will default to POST if post data + // is provided and GET otherwise. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_method: function(self: PCefRequest): PCefStringUserFree; stdcall; + // Set the request function type. + set_method: procedure(self: PCefRequest; const method: PCefString); stdcall; + + // Get the post data. + get_post_data: function(self: PCefRequest): PCefPostData; stdcall; + // Set the post data. + set_post_data: procedure(self: PCefRequest; postData: PCefPostData); stdcall; + + // Get the header values. + get_header_map: procedure(self: PCefRequest; headerMap: TCefStringMultimap); stdcall; + // Set the header values. + set_header_map: procedure(self: PCefRequest; headerMap: TCefStringMultimap); stdcall; + + // Set all values at one time. + set_: procedure(self: PCefRequest; const url, method: PCefString; + postData: PCefPostData; headerMap: TCefStringMultimap); stdcall; + + // Get the flags used in combination with cef_urlrequest_t. See + // cef_urlrequest_flags_t for supported values. + get_flags: function(self: PCefRequest): Integer; stdcall; + // Set the flags used in combination with cef_urlrequest_t. See + // cef_urlrequest_flags_t for supported values. + set_flags: procedure(self: PCefRequest; flags: Integer); stdcall; + + // Get the URL to the first party for cookies used in combination with + // cef_urlrequest_t. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_first_party_for_cookies: function(self: PCefRequest): PCefStringUserFree; stdcall; + // Set the URL to the first party for cookies used in combination with + // cef_urlrequest_t. + set_first_party_for_cookies: procedure(self: PCefRequest; const url: PCefString); stdcall; + + // Get the resource type for this request. Accurate resource type information + // may only be available in the browser process. + get_resource_type: function(self: PCefRequest): TCefResourceType; stdcall; + + // Get the transition type for this request. Only available in the browser + // process and only applies to requests that represent a main frame or sub- + // frame navigation. + get_transition_type: function(self: PCefRequest): TCefTransitionType; stdcall; + end; + + + TCefPostDataElementArray = array[0..(High(Integer) div SizeOf(PCefPostDataElement)) - 1] of PCefPostDataElement; + PCefPostDataElementArray = ^TCefPostDataElementArray; + + // Structure used to represent post data for a web request. The functions of + // this structure may be called on any thread. + TCefPostData = record + // Base structure. + base: TCefBase; + + // Returns true (1) if this object is read-only. + is_read_only: function(self: PCefPostData):Integer; stdcall; + + // Returns the number of existing post data elements. + get_element_count: function(self: PCefPostData): NativeUInt; stdcall; + + // Retrieve the post data elements. + get_elements: procedure(self: PCefPostData; elementsCount: PNativeUInt; + elements: PCefPostDataElementArray); stdcall; + + // Remove the specified post data element. Returns true (1) if the removal + // succeeds. + remove_element: function(self: PCefPostData; + element: PCefPostDataElement): Integer; stdcall; + + // Add the specified post data element. Returns true (1) if the add succeeds. + add_element: function(self: PCefPostData; + element: PCefPostDataElement): Integer; stdcall; + + // Remove all existing post data elements. + remove_elements: procedure(self: PCefPostData); stdcall; + + end; + + // Structure used to represent a single element in the request post data. The + // functions of this structure may be called on any thread. + TCefPostDataElement = record + // Base structure. + base: TCefBase; + + // Returns true (1) if this object is read-only. + is_read_only: function(self: PCefPostDataElement): Integer; stdcall; + + // Remove all contents from the post data element. + set_to_empty: procedure(self: PCefPostDataElement); stdcall; + + // The post data element will represent a file. + set_to_file: procedure(self: PCefPostDataElement; + const fileName: PCefString); stdcall; + + // The post data element will represent bytes. The bytes passed in will be + // copied. + set_to_bytes: procedure(self: PCefPostDataElement; + size: NativeUInt; const bytes: Pointer); stdcall; + + // Return the type of this post data element. + get_type: function(self: PCefPostDataElement): TCefPostDataElementType; stdcall; + + // Return the file name. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_file: function(self: PCefPostDataElement): PCefStringUserFree; stdcall; + + // Return the number of bytes. + get_bytes_count: function(self: PCefPostDataElement): NativeUInt; stdcall; + + // Read up to |size| bytes into |bytes| and return the number of bytes + // actually read. + get_bytes: function(self: PCefPostDataElement; + size: NativeUInt; bytes: Pointer): NativeUInt; stdcall; + end; + + // Structure used to represent a web response. The functions of this structure + // may be called on any thread. + TCefResponse = record + // Base structure. + base: TCefBase; + + // Returns true (1) if this object is read-only. + is_read_only: function(self: PCefResponse): Integer; stdcall; + + // Get the response status code. + get_status: function(self: PCefResponse): Integer; stdcall; + // Set the response status code. + set_status: procedure(self: PCefResponse; status: Integer); stdcall; + + // Get the response status text. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_status_text: function(self: PCefResponse): PCefStringUserFree; stdcall; + // Set the response status text. + set_status_text: procedure(self: PCefResponse; const statusText: PCefString); stdcall; + + // Get the response mime type. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_mime_type: function(self: PCefResponse): PCefStringUserFree; stdcall; + // Set the response mime type. + set_mime_type: procedure(self: PCefResponse; const mimeType: PCefString); stdcall; + + // Get the value for the specified response header field. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_header: function(self: PCefResponse; const name: PCefString): PCefStringUserFree; stdcall; + + // Get all response header fields. + get_header_map: procedure(self: PCefResponse; headerMap: TCefStringMultimap); stdcall; + // Set all response header fields. + set_header_map: procedure(self: PCefResponse; headerMap: TCefStringMultimap); stdcall; + end; + + // Structure the client can implement to provide a custom stream reader. The + // functions of this structure may be called on any thread. + TCefReadHandler = record + // Base structure. + base: TCefBase; + + // Read raw binary data. + read: function(self: PCefReadHandler; ptr: Pointer; + size, n: NativeUInt): NativeUInt; stdcall; + + // Seek to the specified offset position. |whence| may be any one of SEEK_CUR, + // SEEK_END or SEEK_SET. Return zero on success and non-zero on failure. + seek: function(self: PCefReadHandler; offset: Int64; + whence: Integer): Integer; stdcall; + + // Return the current offset position. + tell: function(self: PCefReadHandler): Int64; stdcall; + + // Return non-zero if at end of file. + eof: function(self: PCefReadHandler): Integer; stdcall; + end; + + // Structure used to read data from a stream. The functions of this structure + // may be called on any thread. + TCefStreamReader = record + // Base structure. + base: TCefBase; + + // Read raw binary data. + read: function(self: PCefStreamReader; ptr: Pointer; + size, n: NativeUInt): NativeUInt; stdcall; + + // Seek to the specified offset position. |whence| may be any one of SEEK_CUR, + // SEEK_END or SEEK_SET. Returns zero on success and non-zero on failure. + seek: function(self: PCefStreamReader; offset: Int64; + whence: Integer): Integer; stdcall; + + // Return the current offset position. + tell: function(self: PCefStreamReader): Int64; stdcall; + + // Return non-zero if at end of file. + eof: function(self: PCefStreamReader): Integer; stdcall; + end; + + // Structure the client can implement to provide a custom stream writer. The + // functions of this structure may be called on any thread. + // TODO: implement class + TCefWriteHandler = record + // Base structure. + base: TCefBase; + + // Write raw binary data. + write: function(self: PCefWriteHandler; + const ptr: Pointer; size, n: NativeUInt): NativeUInt; stdcall; + + // Seek to the specified offset position. |whence| may be any one of SEEK_CUR, + // SEEK_END or SEEK_SET. + seek: function(self: PCefWriteHandler; offset: Int64; + whence: Integer): Integer; stdcall; + + // Return the current offset position. + tell: function(self: PCefWriteHandler): Int64; stdcall; + + // Flush the stream. + flush: function(self: PCefWriteHandler): Integer; stdcall; + end; + + // Structure used to write data to a stream. The functions of this structure may + // be called on any thread. + // TODO: Implement class + TCefStreamWriter = record + // Base structure. + base: TCefBase; + + // Write raw binary data. + write: function(self: PCefStreamWriter; + const ptr: Pointer; size, n: NativeUInt): NativeUInt; stdcall; + + // Seek to the specified offset position. |whence| may be any one of SEEK_CUR, + // SEEK_END or SEEK_SET. + seek: function(self: PCefStreamWriter; offset: Int64; + whence: Integer): Integer; stdcall; + + // Return the current offset position. + tell: function(self: PCefStreamWriter): Int64; stdcall; + + // Flush the stream. + flush: function(self: PCefStreamWriter): Integer; stdcall; + end; + + // Structure representing a V8 context handle. V8 handles can only be accessed + // from the thread on which they are created. Valid threads for creating a V8 + // handle include the render process main thread (TID_RENDERER) and WebWorker + // threads. A task runner for posting tasks on the associated thread can be + // retrieved via the cef_v8context_t::get_task_runner() function. + + TCefV8Context = record + // Base structure. + base: TCefBase; + + // Returns the task runner associated with this context. V8 handles can only + // be accessed from the thread on which they are created. This function can be + // called on any render process thread. + get_task_runner: function(self: PCefv8Context): PCefTask; stdcall; + + // Returns true (1) if the underlying handle is valid and it can be accessed + // on the current thread. Do not call any other functions if this function + // returns false (0). + is_valid: function(self: PCefv8Context): Integer; stdcall; + + // Returns the browser for this context. This function will return an NULL + // reference for WebWorker contexts. + get_browser: function(self: PCefv8Context): PCefBrowser; stdcall; + + // Returns the frame for this context. This function will return an NULL + // reference for WebWorker contexts. + get_frame: function(self: PCefv8Context): PCefFrame; stdcall; + + // Returns the global object for this context. The context must be entered + // before calling this function. + get_global: function(self: PCefv8Context): PCefv8Value; stdcall; + + // Enter this context. A context must be explicitly entered before creating a + // V8 Object, Array, Function or Date asynchronously. exit() must be called + // the same number of times as enter() before releasing this context. V8 + // objects belong to the context in which they are created. Returns true (1) + // if the scope was entered successfully. + enter: function(self: PCefv8Context): Integer; stdcall; + + // Exit this context. Call this function only after calling enter(). Returns + // true (1) if the scope was exited successfully. + exit: function(self: PCefv8Context): Integer; stdcall; + + // Returns true (1) if this object is pointing to the same handle as |that| + // object. + is_same: function(self, that: PCefv8Context): Integer; stdcall; + + // Evaluates the specified JavaScript code using this context's global object. + // On success |retval| will be set to the return value, if any, and the + // function will return true (1). On failure |exception| will be set to the + // exception, if any, and the function will return false (0). + eval: function(self: PCefv8Context; const code: PCefString; + var retval: PCefv8Value; var exception: PCefV8Exception): Integer; stdcall; + end; + + // Structure that should be implemented to handle V8 function calls. The + // functions of this structure will be called on the thread associated with the + // V8 function. + TCefv8Handler = record + // Base structure. + base: TCefBase; + + // Handle execution of the function identified by |name|. |object| is the + // receiver ('this' object) of the function. |arguments| is the list of + // arguments passed to the function. If execution succeeds set |retval| to the + // function return value. If execution fails set |exception| to the exception + // that will be thrown. Return true (1) if execution was handled. + execute: function(self: PCefv8Handler; + const name: PCefString; obj: PCefv8Value; argumentsCount: NativeUInt; + const arguments: PPCefV8Value; var retval: PCefV8Value; + var exception: TCefString): Integer; stdcall; + end; + + // Structure that should be implemented to handle V8 accessor calls. Accessor + // identifiers are registered by calling cef_v8value_t::set_value_byaccessor(). + // The functions of this structure will be called on the thread associated with + // the V8 accessor. + TCefV8Accessor = record + // Base structure. + base: TCefBase; + + // Handle retrieval the accessor value identified by |name|. |object| is the + // receiver ('this' object) of the accessor. If retrieval succeeds set + // |retval| to the return value. If retrieval fails set |exception| to the + // exception that will be thrown. Return true (1) if accessor retrieval was + // handled. + get: function(self: PCefV8Accessor; const name: PCefString; + obj: PCefv8Value; out retval: PCefv8Value; exception: PCefString): Integer; stdcall; + + // Handle assignment of the accessor value identified by |name|. |object| is + // the receiver ('this' object) of the accessor. |value| is the new value + // being assigned to the accessor. If assignment fails set |exception| to the + // exception that will be thrown. Return true (1) if accessor assignment was + // handled. + put: function(self: PCefV8Accessor; const name: PCefString; + obj: PCefv8Value; value: PCefv8Value; exception: PCefString): Integer; stdcall; + end; + + // Structure representing a V8 exception. The functions of this structure may be + // called on any render process thread. + TCefV8Exception = record + // Base structure. + base: TCefBase; + + // Returns the exception message. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_message: function(self: PCefV8Exception): PCefStringUserFree; stdcall; + + // Returns the line of source code that the exception occurred within. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_source_line: function(self: PCefV8Exception): PCefStringUserFree; stdcall; + + // Returns the resource name for the script from where the function causing + // the error originates. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_script_resource_name: function(self: PCefV8Exception): PCefStringUserFree; stdcall; + + // Returns the 1-based number of the line where the error occurred or 0 if the + // line number is unknown. + get_line_number: function(self: PCefV8Exception): Integer; stdcall; + + // Returns the index within the script of the first character where the error + // occurred. + get_start_position: function(self: PCefV8Exception): Integer; stdcall; + + // Returns the index within the script of the last character where the error + // occurred. + get_end_position: function(self: PCefV8Exception): Integer; stdcall; + + // Returns the index within the line of the first character where the error + // occurred. + get_start_column: function(self: PCefV8Exception): Integer; stdcall; + + // Returns the index within the line of the last character where the error + // occurred. + get_end_column: function(self: PCefV8Exception): Integer; stdcall; + end; + + // Structure representing a V8 value handle. V8 handles can only be accessed + // from the thread on which they are created. Valid threads for creating a V8 + // handle include the render process main thread (TID_RENDERER) and WebWorker + // threads. A task runner for posting tasks on the associated thread can be + // retrieved via the cef_v8context_t::get_task_runner() function. + + TCefv8Value = record + // Base structure. + base: TCefBase; + + // Returns true (1) if the underlying handle is valid and it can be accessed + // on the current thread. Do not call any other functions if this function + // returns false (0). + is_valid: function(self: PCefv8Value): Integer; stdcall; + // True if the value type is undefined. + is_undefined: function(self: PCefv8Value): Integer; stdcall; + // True if the value type is null. + is_null: function(self: PCefv8Value): Integer; stdcall; + // True if the value type is bool. + is_bool: function(self: PCefv8Value): Integer; stdcall; + // True if the value type is int. + is_int: function(self: PCefv8Value): Integer; stdcall; + // True if the value type is unsigned int. + is_uint: function(self: PCefv8Value): Integer; stdcall; + // True if the value type is double. + is_double: function(self: PCefv8Value): Integer; stdcall; + // True if the value type is Date. + is_date: function(self: PCefv8Value): Integer; stdcall; + // True if the value type is string. + is_string: function(self: PCefv8Value): Integer; stdcall; + // True if the value type is object. + is_object: function(self: PCefv8Value): Integer; stdcall; + // True if the value type is array. + is_array: function(self: PCefv8Value): Integer; stdcall; + // True if the value type is function. + is_function: function(self: PCefv8Value): Integer; stdcall; + + // Returns true (1) if this object is pointing to the same handle as |that| + // object. + is_same: function(self, that: PCefv8Value): Integer; stdcall; + + // Return a bool value. The underlying data will be converted to if + // necessary. + get_bool_value: function(self: PCefv8Value): Integer; stdcall; + // Return an int value. The underlying data will be converted to if + // necessary. + get_int_value: function(self: PCefv8Value): Integer; stdcall; + // Return an unisgned int value. The underlying data will be converted to if + // necessary. + get_uint_value: function(self: PCefv8Value): Cardinal; stdcall; + // Return a double value. The underlying data will be converted to if + // necessary. + get_double_value: function(self: PCefv8Value): double; stdcall; + // Return a Date value. The underlying data will be converted to if + // necessary. + get_date_value: function(self: PCefv8Value): TCefTime; stdcall; + // Return a string value. The underlying data will be converted to if + // necessary. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_string_value: function(self: PCefv8Value): PCefStringUserFree; stdcall; + + + // OBJECT METHODS - These functions are only available on objects. Arrays and + // functions are also objects. String- and integer-based keys can be used + // interchangably with the framework converting between them as necessary. + + // Returns true (1) if this is a user created object. + is_user_created: function(self: PCefv8Value): Integer; stdcall; + + // Returns true (1) if the last function call resulted in an exception. This + // attribute exists only in the scope of the current CEF value object. + has_exception: function(self: PCefv8Value): Integer; stdcall; + + // Returns the exception resulting from the last function call. This attribute + // exists only in the scope of the current CEF value object. + get_exception: function(self: PCefv8Value): PCefV8Exception; stdcall; + + // Clears the last exception and returns true (1) on success. + clear_exception: function(self: PCefv8Value): Integer; stdcall; + + // Returns true (1) if this object will re-throw future exceptions. This + // attribute exists only in the scope of the current CEF value object. + will_rethrow_exceptions: function(self: PCefv8Value): Integer; stdcall; + + // Set whether this object will re-throw future exceptions. By default + // exceptions are not re-thrown. If a exception is re-thrown the current + // context should not be accessed again until after the exception has been + // caught and not re-thrown. Returns true (1) on success. This attribute + // exists only in the scope of the current CEF value object. + set_rethrow_exceptions: function(self: PCefv8Value; rethrow: Integer): Integer; stdcall; + + + // Returns true (1) if the object has a value with the specified identifier. + has_value_bykey: function(self: PCefv8Value; const key: PCefString): Integer; stdcall; + // Returns true (1) if the object has a value with the specified identifier. + has_value_byindex: function(self: PCefv8Value; index: Integer): Integer; stdcall; + + // Deletes the value with the specified identifier and returns true (1) on + // success. Returns false (0) if this function is called incorrectly or an + // exception is thrown. For read-only and don't-delete values this function + // will return true (1) even though deletion failed. + delete_value_bykey: function(self: PCefv8Value; const key: PCefString): Integer; stdcall; + // Deletes the value with the specified identifier and returns true (1) on + // success. Returns false (0) if this function is called incorrectly, deletion + // fails or an exception is thrown. For read-only and don't-delete values this + // function will return true (1) even though deletion failed. + delete_value_byindex: function(self: PCefv8Value; index: Integer): Integer; stdcall; + + // Returns the value with the specified identifier on success. Returns NULL if + // this function is called incorrectly or an exception is thrown. + get_value_bykey: function(self: PCefv8Value; const key: PCefString): PCefv8Value; stdcall; + // Returns the value with the specified identifier on success. Returns NULL if + // this function is called incorrectly or an exception is thrown. + get_value_byindex: function(self: PCefv8Value; index: Integer): PCefv8Value; stdcall; + + // Associates a value with the specified identifier and returns true (1) on + // success. Returns false (0) if this function is called incorrectly or an + // exception is thrown. For read-only values this function will return true + // (1) even though assignment failed. + set_value_bykey: function(self: PCefv8Value; const key: PCefString; + value: PCefv8Value; attribute: Integer): Integer; stdcall; + // Associates a value with the specified identifier and returns true (1) on + // success. Returns false (0) if this function is called incorrectly or an + // exception is thrown. For read-only values this function will return true + // (1) even though assignment failed. + set_value_byindex: function(self: PCefv8Value; index: Integer; + value: PCefv8Value): Integer; stdcall; + + // Registers an identifier and returns true (1) on success. Access to the + // identifier will be forwarded to the cef_v8accessor_t instance passed to + // cef_v8value_t::cef_v8value_create_object(). Returns false (0) if this + // function is called incorrectly or an exception is thrown. For read-only + // values this function will return true (1) even though assignment failed. + set_value_byaccessor: function(self: PCefv8Value; const key: PCefString; + settings: Integer; attribute: Integer): Integer; stdcall; + + // Read the keys for the object's values into the specified vector. Integer- + // based keys will also be returned as strings. + get_keys: function(self: PCefv8Value; keys: TCefStringList): Integer; stdcall; + + // Sets the user data for this object and returns true (1) on success. Returns + // false (0) if this function is called incorrectly. This function can only be + // called on user created objects. + set_user_data: function(self: PCefv8Value; user_data: PCefBase): Integer; stdcall; + + // Returns the user data, if any, assigned to this object. + get_user_data: function(self: PCefv8Value): PCefBase; stdcall; + + // Returns the amount of externally allocated memory registered for the + // object. + get_externally_allocated_memory: function(self: PCefv8Value): Integer; stdcall; + + // Adjusts the amount of registered external memory for the object. Used to + // give V8 an indication of the amount of externally allocated memory that is + // kept alive by JavaScript objects. V8 uses this information to decide when + // to perform global garbage collection. Each cef_v8value_t tracks the amount + // of external memory associated with it and automatically decreases the + // global total by the appropriate amount on its destruction. + // |change_in_bytes| specifies the number of bytes to adjust by. This function + // returns the number of bytes associated with the object after the + // adjustment. This function can only be called on user created objects. + adjust_externally_allocated_memory: function(self: PCefv8Value; change_in_bytes: Integer): Integer; stdcall; + + // ARRAY METHODS - These functions are only available on arrays. + + // Returns the number of elements in the array. + get_array_length: function(self: PCefv8Value): Integer; stdcall; + + + // FUNCTION METHODS - These functions are only available on functions. + + // Returns the function name. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_function_name: function(self: PCefv8Value): PCefStringUserFree; stdcall; + + // Returns the function handler or NULL if not a CEF-created function. + get_function_handler: function( + self: PCefv8Value): PCefv8Handler; stdcall; + + // Execute the function using the current V8 context. This function should + // only be called from within the scope of a cef_v8handler_t or + // cef_v8accessor_t callback, or in combination with calling enter() and + // exit() on a stored cef_v8context_t reference. |object| is the receiver + // ('this' object) of the function. If |object| is NULL the current context's + // global object will be used. |arguments| is the list of arguments that will + // be passed to the function. Returns the function return value on success. + // Returns NULL if this function is called incorrectly or an exception is + // thrown. + execute_function: function(self: PCefv8Value; obj: PCefv8Value; + argumentsCount: NativeUInt; const arguments: PPCefV8Value): PCefv8Value; stdcall; + + // Execute the function using the specified V8 context. |object| is the + // receiver ('this' object) of the function. If |object| is NULL the specified + // context's global object will be used. |arguments| is the list of arguments + // that will be passed to the function. Returns the function return value on + // success. Returns NULL if this function is called incorrectly or an + // exception is thrown. + execute_function_with_context: function(self: PCefv8Value; context: PCefv8Context; + obj: PCefv8Value; argumentsCount: NativeUInt; const arguments: PPCefV8Value): PCefv8Value; stdcall; + end; + + // Structure representing a V8 stack trace handle. V8 handles can only be + // accessed from the thread on which they are created. Valid threads for + // creating a V8 handle include the render process main thread (TID_RENDERER) + // and WebWorker threads. A task runner for posting tasks on the associated + // thread can be retrieved via the cef_v8context_t::get_task_runner() function. + TCefV8StackTrace = record + // Base structure. + base: TCefBase; + + // Returns true (1) if the underlying handle is valid and it can be accessed + // on the current thread. Do not call any other functions if this function + // returns false (0). + is_valid: function(self: PCefV8StackTrace): Integer; stdcall; + + // Returns the number of stack frames. + get_frame_count: function(self: PCefV8StackTrace): Integer; stdcall; + + // Returns the stack frame at the specified 0-based index. + get_frame: function(self: PCefV8StackTrace; index: Integer): PCefV8StackFrame; stdcall; + end; + + // Structure representing a V8 stack frame handle. V8 handles can only be + // accessed from the thread on which they are created. Valid threads for + // creating a V8 handle include the render process main thread (TID_RENDERER) + // and WebWorker threads. A task runner for posting tasks on the associated + // thread can be retrieved via the cef_v8context_t::get_task_runner() function. + + TCefV8StackFrame = record + // Base structure. + base: TCefBase; + + // Returns true (1) if the underlying handle is valid and it can be accessed + // on the current thread. Do not call any other functions if this function + // returns false (0). + is_valid: function(self: PCefV8StackFrame): Integer; stdcall; + + // Returns the name of the resource script that contains the function. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_script_name: function(self: PCefV8StackFrame): PCefStringUserFree; stdcall; + + // Returns the name of the resource script that contains the function or the + // sourceURL value if the script name is undefined and its source ends with a + // "//@ sourceURL=..." string. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_script_name_or_source_url: function(self: PCefV8StackFrame): PCefStringUserFree; stdcall; + + // Returns the name of the function. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_function_name: function(self: PCefV8StackFrame): PCefStringUserFree; stdcall; + + // Returns the 1-based line number for the function call or 0 if unknown. + get_line_number: function(self: PCefV8StackFrame): Integer; stdcall; + + // Returns the 1-based column offset on the line for the function call or 0 if + // unknown. + get_column: function(self: PCefV8StackFrame): Integer; stdcall; + + // Returns true (1) if the function was compiled using eval(). + is_eval: function(self: PCefV8StackFrame): Integer; stdcall; + + // Returns true (1) if the function was called as a constructor via "new". + is_constructor: function(self: PCefV8StackFrame): Integer; stdcall; + end; + + // Structure that manages custom scheme registrations. + TCefSchemeRegistrar = record + // Base structure. + base: TCefBase; + + // Register a custom scheme. This function should not be called for the built- + // in HTTP, HTTPS, FILE, FTP, ABOUT and DATA schemes. + // + // If |is_standard| is true (1) the scheme will be treated as a standard + // scheme. Standard schemes are subject to URL canonicalization and parsing + // rules as defined in the Common Internet Scheme Syntax RFC 1738 Section 3.1 + // available at http://www.ietf.org/rfc/rfc1738.txt + // + // In particular, the syntax for standard scheme URLs must be of the form: + // 
+    //  [scheme]://[username]:[password]@[host]:[port]/[url-path]
+    //
Standard scheme URLs must have a host component that is a fully + // qualified domain name as defined in Section 3.5 of RFC 1034 [13] and + // Section 2.1 of RFC 1123. These URLs will be canonicalized to + // "scheme://host/path" in the simplest case and + // "scheme://username:password@host:port/path" in the most explicit case. For + // example, "scheme:host/path" and "scheme:///host/path" will both be + // canonicalized to "scheme://host/path". The origin of a standard scheme URL + // is the combination of scheme, host and port (i.e., "scheme://host:port" in + // the most explicit case). + // + // For non-standard scheme URLs only the "scheme:" component is parsed and + // canonicalized. The remainder of the URL will be passed to the handler as- + // is. For example, "scheme:///some%20text" will remain the same. Non-standard + // scheme URLs cannot be used as a target for form submission. + // + // If |is_local| is true (1) the scheme will be treated as local (i.e., with + // the same security rules as those applied to "file" URLs). Normal pages + // cannot link to or access local URLs. Also, by default, local URLs can only + // perform XMLHttpRequest calls to the same URL (origin + path) that + // originated the request. To allow XMLHttpRequest calls from a local URL to + // other URLs with the same origin set the + // CefSettings.file_access_from_file_urls_allowed value to true (1). To allow + // XMLHttpRequest calls from a local URL to all origins set the + // CefSettings.universal_access_from_file_urls_allowed value to true (1). + // + // If |is_display_isolated| is true (1) the scheme will be treated as display- + // isolated. This means that pages cannot display these URLs unless they are + // from the same scheme. For example, pages in another origin cannot create + // iframes or hyperlinks to URLs with this scheme. + // + // This function may be called on any thread. It should only be called once + // per unique |scheme_name| value. If |scheme_name| is already registered or + // if an error occurs this function will return false (0). + add_custom_scheme: function(self: PCefSchemeRegistrar; + const scheme_name: PCefString; is_standard, is_local, + is_display_isolated: Integer): Integer; stdcall; + end; + + // Structure that creates cef_scheme_handler_t instances. The functions of this + // structure will always be called on the IO thread. + TCefSchemeHandlerFactory = record + // Base structure. + base: TCefBase; + + // Return a new resource handler instance to handle the request or an NULL + // reference to allow default handling of the request. |browser| and |frame| + // will be the browser window and frame respectively that originated the + // request or NULL if the request did not originate from a browser window (for + // example, if the request came from cef_urlrequest_t). The |request| object + // passed to this function will not contain cookie data. + create: function(self: PCefSchemeHandlerFactory; + browser: PCefBrowser; frame: PCefFrame; const scheme_name: PCefString; + request: PCefRequest): PCefResourceHandler; stdcall; + end; + + // Structure used to represent a download item. + TCefDownloadItem = record + // Base structure. + base: TCefBase; + + // Returns true (1) if this object is valid. Do not call any other functions + // if this function returns false (0). + is_valid: function(self: PCefDownloadItem): Integer; stdcall; + + // Returns true (1) if the download is in progress. + is_in_progress: function(self: PCefDownloadItem): Integer; stdcall; + + // Returns true (1) if the download is complete. + is_complete: function(self: PCefDownloadItem): Integer; stdcall; + + // Returns true (1) if the download has been canceled or interrupted. + is_canceled: function(self: PCefDownloadItem): Integer; stdcall; + + // Returns a simple speed estimate in bytes/s. + get_current_speed: function(self: PCefDownloadItem): Int64; stdcall; + + // Returns the rough percent complete or -1 if the receive total size is + // unknown. + get_percent_complete: function(self: PCefDownloadItem): Integer; stdcall; + + // Returns the total number of bytes. + get_total_bytes: function(self: PCefDownloadItem): Int64; stdcall; + + // Returns the number of received bytes. + get_received_bytes: function(self: PCefDownloadItem): Int64; stdcall; + + // Returns the time that the download started. + get_start_time: function(self: PCefDownloadItem): TCefTime; stdcall; + + // Returns the time that the download ended. + get_end_time: function(self: PCefDownloadItem): TCefTime; stdcall; + + // Returns the full path to the downloaded or downloading file. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_full_path: function(self: PCefDownloadItem): PCefStringUserFree; stdcall; + + // Returns the unique identifier for this download. + get_id: function(self: PCefDownloadItem): Cardinal; stdcall; + + // Returns the URL. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_url: function(self: PCefDownloadItem): PCefStringUserFree; stdcall; + + // Returns the suggested file name. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_suggested_file_name: function(self: PCefDownloadItem): PCefStringUserFree; stdcall; + + // Returns the content disposition. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_content_disposition: function(self: PCefDownloadItem): PCefStringUserFree; stdcall; + + // Returns the mime type. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_mime_type: function(self: PCefDownloadItem): PCefStringUserFree; stdcall; + end; + + // Callback structure used to asynchronously continue a download. + TCefBeforeDownloadCallback = record + // Base structure. + base: TCefBase; + + // Call to continue the download. Set |download_path| to the full file path + // for the download including the file name or leave blank to use the + // suggested name and the default temp directory. Set |show_dialog| to true + // (1) if you do wish to show the default "Save As" dialog. + cont: procedure(self: PCefBeforeDownloadCallback; + const download_path: PCefString; show_dialog: Integer); stdcall; + end; + + // Callback structure used to asynchronously cancel a download. + TCefDownloadItemCallback = record + // Base structure. + base: TCefBase; + + // Call to cancel the download. + cancel: procedure(self: PCefDownloadItemCallback); stdcall; + end; + + // Structure used to handle file downloads. The functions of this structure will + // always be called on the UI thread. + TCefDownloadHandler = record + // Base structure. + base: TCefBase; + + // Called before a download begins. |suggested_name| is the suggested name for + // the download file. By default the download will be canceled. Execute + // |callback| either asynchronously or in this function to continue the + // download if desired. Do not keep a reference to |download_item| outside of + // this function. + on_before_download: procedure(self: PCefDownloadHandler; + browser: PCefBrowser; download_item: PCefDownloadItem; + const suggested_name: PCefString; callback: PCefBeforeDownloadCallback); stdcall; + + // Called when a download's status or progress information has been updated. + // This may be called multiple times before and after on_before_download(). + // Execute |callback| either asynchronously or in this function to cancel the + // download if desired. Do not keep a reference to |download_item| outside of + // this function. + on_download_updated: procedure(self: PCefDownloadHandler; + browser: PCefBrowser; download_item: PCefDownloadItem; + callback: PCefDownloadItemCallback); stdcall; + end; + + // Structure that supports the reading of XML data via the libxml streaming API. + // The functions of this structure should only be called on the thread that + // creates the object. + TCefXmlReader = record + // Base structure. + base: TcefBase; + + // Moves the cursor to the next node in the document. This function must be + // called at least once to set the current cursor position. Returns true (1) + // if the cursor position was set successfully. + move_to_next_node: function(self: PCefXmlReader): Integer; stdcall; + + // Close the document. This should be called directly to ensure that cleanup + // occurs on the correct thread. + close: function(self: PCefXmlReader): Integer; stdcall; + + // Returns true (1) if an error has been reported by the XML parser. + has_error: function(self: PCefXmlReader): Integer; stdcall; + + // Returns the error string. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_error: function(self: PCefXmlReader): PCefStringUserFree; stdcall; + + + // The below functions retrieve data for the node at the current cursor + // position. + + // Returns the node type. + get_type: function(self: PCefXmlReader): TCefXmlNodeType; stdcall; + + // Returns the node depth. Depth starts at 0 for the root node. + get_depth: function(self: PCefXmlReader): Integer; stdcall; + + // Returns the local name. See http://www.w3.org/TR/REC-xml-names/#NT- + // LocalPart for additional details. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_local_name: function(self: PCefXmlReader): PCefStringUserFree; stdcall; + + // Returns the namespace prefix. See http://www.w3.org/TR/REC-xml-names/ for + // additional details. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_prefix: function(self: PCefXmlReader): PCefStringUserFree; stdcall; + + // Returns the qualified name, equal to (Prefix:)LocalName. See + // http://www.w3.org/TR/REC-xml-names/#ns-qualnames for additional details. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_qualified_name: function(self: PCefXmlReader): PCefStringUserFree; stdcall; + + // Returns the URI defining the namespace associated with the node. See + // http://www.w3.org/TR/REC-xml-names/ for additional details. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_namespace_uri: function(self: PCefXmlReader): PCefStringUserFree; stdcall; + + // Returns the base URI of the node. See http://www.w3.org/TR/xmlbase/ for + // additional details. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_base_uri: function(self: PCefXmlReader): PCefStringUserFree; stdcall; + + // Returns the xml:lang scope within which the node resides. See + // http://www.w3.org/TR/REC-xml/#sec-lang-tag for additional details. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_xml_lang: function(self: PCefXmlReader): PCefStringUserFree; stdcall; + + // Returns true (1) if the node represents an NULL element. is considered + // NULL but is not. + is_empty_element: function(self: PCefXmlReader): Integer; stdcall; + + // Returns true (1) if the node has a text value. + has_value: function(self: PCefXmlReader): Integer; stdcall; + + // Returns the text value. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_value: function(self: PCefXmlReader): PCefStringUserFree; stdcall; + + // Returns true (1) if the node has attributes. + has_attributes: function(self: PCefXmlReader): Integer; stdcall; + + // Returns the number of attributes. + get_attribute_count: function(self: PCefXmlReader): NativeUInt; stdcall; + + // Returns the value of the attribute at the specified 0-based index. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_attribute_byindex: function(self: PCefXmlReader; index: Integer): PCefStringUserFree; stdcall; + + // Returns the value of the attribute with the specified qualified name. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_attribute_byqname: function(self: PCefXmlReader; const qualifiedName: PCefString): PCefStringUserFree; stdcall; + + // Returns the value of the attribute with the specified local name and + // namespace URI. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_attribute_bylname: function(self: PCefXmlReader; const localName, namespaceURI: PCefString): PCefStringUserFree; stdcall; + + // Returns an XML representation of the current node's children. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_inner_xml: function(self: PCefXmlReader): PCefStringUserFree; stdcall; + + // Returns an XML representation of the current node including its children. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_outer_xml: function(self: PCefXmlReader): PCefStringUserFree; stdcall; + + // Returns the line number for the current node. + get_line_number: function(self: PCefXmlReader): Integer; stdcall; + + + // Attribute nodes are not traversed by default. The below functions can be + // used to move the cursor to an attribute node. move_to_carrying_element() + // can be called afterwards to return the cursor to the carrying element. The + // depth of an attribute node will be 1 + the depth of the carrying element. + + // Moves the cursor to the attribute at the specified 0-based index. Returns + // true (1) if the cursor position was set successfully. + move_to_attribute_byindex: function(self: PCefXmlReader; index: Integer): Integer; stdcall; + + // Moves the cursor to the attribute with the specified qualified name. + // Returns true (1) if the cursor position was set successfully. + move_to_attribute_byqname: function(self: PCefXmlReader; const qualifiedName: PCefString): Integer; stdcall; + + // Moves the cursor to the attribute with the specified local name and + // namespace URI. Returns true (1) if the cursor position was set + // successfully. + move_to_attribute_bylname: function(self: PCefXmlReader; const localName, namespaceURI: PCefString): Integer; stdcall; + + // Moves the cursor to the first attribute in the current element. Returns + // true (1) if the cursor position was set successfully. + move_to_first_attribute: function(self: PCefXmlReader): Integer; stdcall; + + // Moves the cursor to the next attribute in the current element. Returns true + // (1) if the cursor position was set successfully. + move_to_next_attribute: function(self: PCefXmlReader): Integer; stdcall; + + // Moves the cursor back to the carrying element. Returns true (1) if the + // cursor position was set successfully. + move_to_carrying_element: function(self: PCefXmlReader): Integer; stdcall; + end; + + // Structure that supports the reading of zip archives via the zlib unzip API. + // The functions of this structure should only be called on the thread that + // creates the object. + TCefZipReader = record + // Base structure. + base: TCefBase; + + // Moves the cursor to the first file in the archive. Returns true (1) if the + // cursor position was set successfully. + move_to_first_file: function(self: PCefZipReader): Integer; stdcall; + + // Moves the cursor to the next file in the archive. Returns true (1) if the + // cursor position was set successfully. + move_to_next_file: function(self: PCefZipReader): Integer; stdcall; + + // Moves the cursor to the specified file in the archive. If |caseSensitive| + // is true (1) then the search will be case sensitive. Returns true (1) if the + // cursor position was set successfully. + move_to_file: function(self: PCefZipReader; const fileName: PCefString; caseSensitive: Integer): Integer; stdcall; + + // Closes the archive. This should be called directly to ensure that cleanup + // occurs on the correct thread. + close: function(Self: PCefZipReader): Integer; stdcall; + + + // The below functions act on the file at the current cursor position. + + // Returns the name of the file. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_file_name: function(Self: PCefZipReader): PCefStringUserFree; stdcall; + + // Returns the uncompressed size of the file. + get_file_size: function(Self: PCefZipReader): Int64; stdcall; + + // Returns the last modified timestamp for the file. + get_file_last_modified: function(Self: PCefZipReader): LongInt; stdcall; + + // Opens the file for reading of uncompressed data. A read password may + // optionally be specified. + open_file: function(Self: PCefZipReader; const password: PCefString): Integer; stdcall; + + // Closes the file. + close_file: function(Self: PCefZipReader): Integer; stdcall; + + // Read uncompressed file contents into the specified buffer. Returns < 0 if + // an error occurred, 0 if at the end of file, or the number of bytes read. + read_file: function(Self: PCefZipReader; buffer: Pointer; bufferSize: NativeUInt): Integer; stdcall; + + // Returns the current offset in the uncompressed file contents. + tell: function(Self: PCefZipReader): Int64; stdcall; + + // Returns true (1) if at end of the file contents. + eof: function(Self: PCefZipReader): Integer; stdcall; + end; + + // Structure to implement for visiting the DOM. The functions of this structure + // will be called on the render process main thread. + TCefDomVisitor = record + // Base structure. + base: TCefBase; + + // Method executed for visiting the DOM. The document object passed to this + // function represents a snapshot of the DOM at the time this function is + // executed. DOM objects are only valid for the scope of this function. Do not + // keep references to or attempt to access any DOM objects outside the scope + // of this function. + visit: procedure(self: PCefDomVisitor; document: PCefDomDocument); stdcall; + end; + + + // Structure used to represent a DOM document. The functions of this structure + // should only be called on the render process main thread thread. + TCefDomDocument = record + // Base structure. + base: TCefBase; + + // Returns the document type. + get_type: function(self: PCefDomDocument): TCefDomDocumentType; stdcall; + + // Returns the root document node. + get_document: function(self: PCefDomDocument): PCefDomNode; stdcall; + + // Returns the BODY node of an HTML document. + get_body: function(self: PCefDomDocument): PCefDomNode; stdcall; + + // Returns the HEAD node of an HTML document. + get_head: function(self: PCefDomDocument): PCefDomNode; stdcall; + + // Returns the title of an HTML document. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_title: function(self: PCefDomDocument): PCefStringUserFree; stdcall; + + // Returns the document element with the specified ID value. + get_element_by_id: function(self: PCefDomDocument; const id: PCefString): PCefDomNode; stdcall; + + // Returns the node that currently has keyboard focus. + get_focused_node: function(self: PCefDomDocument): PCefDomNode; stdcall; + + // Returns true (1) if a portion of the document is selected. + has_selection: function(self: PCefDomDocument): Integer; stdcall; + + // Returns the selection start node. + get_selection_start_node: function(self: PCefDomDocument): PCefDomNode; stdcall; + + // Returns the selection offset within the start node. + get_selection_start_offset: function(self: PCefDomDocument): Integer; stdcall; + + // Returns the selection end node. + get_selection_end_node: function(self: PCefDomDocument): PCefDomNode; stdcall; + + // Returns the selection offset within the end node. + get_selection_end_offset: function(self: PCefDomDocument): Integer; stdcall; + + // Returns the contents of this selection as markup. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_selection_as_markup: function(self: PCefDomDocument): PCefStringUserFree; stdcall; + + // Returns the contents of this selection as text. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_selection_as_text: function(self: PCefDomDocument): PCefStringUserFree; stdcall; + + // Returns the base URL for the document. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_base_url: function(self: PCefDomDocument): PCefStringUserFree; stdcall; + + // Returns a complete URL based on the document base URL and the specified + // partial URL. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_complete_url: function(self: PCefDomDocument; const partialURL: PCefString): PCefStringUserFree; stdcall; + end; + + + // Structure used to represent a DOM node. The functions of this structure + // should only be called on the render process main thread. + TCefDomNode = record + // Base structure. + base: TCefBase; + + // Returns the type for this node. + get_type: function(self: PCefDomNode): TCefDomNodeType; stdcall; + + // Returns true (1) if this is a text node. + is_text: function(self: PCefDomNode): Integer; stdcall; + + // Returns true (1) if this is an element node. + is_element: function(self: PCefDomNode): Integer; stdcall; + + // Returns true (1) if this is an editable node. + is_editable: function(self: PCefDomNode): Integer; stdcall; + + // Returns true (1) if this is a form control element node. + is_form_control_element: function(self: PCefDomNode): Integer; stdcall; + + // Returns the type of this form control element node. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_form_control_element_type: function(self: PCefDomNode): PCefStringUserFree; stdcall; + + // Returns true (1) if this object is pointing to the same handle as |that| + // object. + is_same: function(self, that: PCefDomNode): Integer; stdcall; + + // Returns the name of this node. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_name: function(self: PCefDomNode): PCefStringUserFree; stdcall; + + // Returns the value of this node. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_value: function(self: PCefDomNode): PCefStringUserFree; stdcall; + + // Set the value of this node. Returns true (1) on success. + set_value: function(self: PCefDomNode; const value: PCefString): Integer; stdcall; + + // Returns the contents of this node as markup. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_as_markup: function(self: PCefDomNode): PCefStringUserFree; stdcall; + + // Returns the document associated with this node. + get_document: function(self: PCefDomNode): PCefDomDocument; stdcall; + + // Returns the parent node. + get_parent: function(self: PCefDomNode): PCefDomNode; stdcall; + + // Returns the previous sibling node. + get_previous_sibling: function(self: PCefDomNode): PCefDomNode; stdcall; + + // Returns the next sibling node. + get_next_sibling: function(self: PCefDomNode): PCefDomNode; stdcall; + + // Returns true (1) if this node has child nodes. + has_children: function(self: PCefDomNode): Integer; stdcall; + + // Return the first child node. + get_first_child: function(self: PCefDomNode): PCefDomNode; stdcall; + + // Returns the last child node. + get_last_child: function(self: PCefDomNode): PCefDomNode; stdcall; + + // Add an event listener to this node for the specified event type. If + // |useCapture| is true (1) then this listener will be considered a capturing + // listener. Capturing listeners will recieve all events of the specified type + // before the events are dispatched to any other event targets beneath the + // current node in the tree. Events which are bubbling upwards through the + // tree will not trigger a capturing listener. Separate calls to this function + // can be used to register the same listener with and without capture. See + // WebCore/dom/EventNames.h for the list of supported event types. + add_event_listener: procedure(self: PCefDomNode; const eventType: PCefString; + listener: PCefDomEventListener; useCapture: Integer); stdcall; + + // The following functions are valid only for element nodes. + + // Returns the tag name of this element. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_element_tag_name: function(self: PCefDomNode): PCefStringUserFree; stdcall; + + // Returns true (1) if this element has attributes. + has_element_attributes: function(self: PCefDomNode): Integer; stdcall; + + // Returns true (1) if this element has an attribute named |attrName|. + has_element_attribute: function(self: PCefDomNode; const attrName: PCefString): Integer; stdcall; + + // Returns the element attribute named |attrName|. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_element_attribute: function(self: PCefDomNode; const attrName: PCefString): PCefStringUserFree; stdcall; + + // Returns a map of all element attributes. + get_element_attributes: procedure(self: PCefDomNode; attrMap: TCefStringMap); stdcall; + + // Set the value for the element attribute named |attrName|. Returns true (1) + // on success. + set_element_attribute: function(self: PCefDomNode; const attrName, value: PCefString): Integer; stdcall; + + // Returns the inner text of the element. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_element_inner_text: function(self: PCefDomNode): PCefStringUserFree; stdcall; + end; + + + // Structure used to represent a DOM event. The functions of this structure + // should only be called on the render process main thread. + TCefDomEvent = record + // Base structure. + base: TCefBase; + + // Returns the event type. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_type: function(self: PCefDomEvent): PCefStringUserFree; stdcall; + + // Returns the event category. + get_category: function(self: PCefDomEvent): TCefDomEventCategory; stdcall; + + // Returns the event processing phase. + get_phase: function(self: PCefDomEvent): TCefDomEventPhase; stdcall; + + // Returns true (1) if the event can bubble up the tree. + can_bubble: function(self: PCefDomEvent): Integer; stdcall; + + // Returns true (1) if the event can be canceled. + can_cancel: function(self: PCefDomEvent): Integer; stdcall; + + // Returns the document associated with this event. + get_document: function(self: PCefDomEvent): PCefDomDocument; stdcall; + + // Returns the target of the event. + get_target: function(self: PCefDomEvent): PCefDomNode; stdcall; + + // Returns the current target of the event. + get_current_target: function(self: PCefDomEvent): PCefDomNode; stdcall; + end; + + // Structure to implement for handling DOM events. The functions of this + // structure will be called on the render process main thread. + TCefDomEventListener = record + // Base structure. + base: TCefBase; + + // Called when an event is received. The event object passed to this function + // contains a snapshot of the DOM at the time this function is executed. DOM + // objects are only valid for the scope of this function. Do not keep + // references to or attempt to access any DOM objects outside the scope of + // this function. + handle_event: procedure(self: PCefDomEventListener; event: PCefDomEvent); stdcall; + end; + + // Structure to implement for visiting cookie values. The functions of this + // structure will always be called on the IO thread. + TCefCookieVisitor = record + // Base structure. + base: TCefBase; + + // Method that will be called once for each cookie. |count| is the 0-based + // index for the current cookie. |total| is the total number of cookies. Set + // |deleteCookie| to true (1) to delete the cookie currently being visited. + // Return false (0) to stop visiting cookies. This function may never be + // called if no cookies are found. + + visit: function(self: PCefCookieVisitor; const cookie: PCefCookie; + count, total: Integer; deleteCookie: PInteger): Integer; stdcall; + end; + + // Structure used for managing cookies. The functions of this structure may be + // called on any thread unless otherwise indicated. + TCefCookieManager = record + // Base structure. + base: TCefBase; + + // Set the schemes supported by this manager. By default only "http" and + // "https" schemes are supported. Must be called before any cookies are + // accessed. + set_supported_schemes: procedure(self: PCefCookieManager; schemes: TCefStringList); stdcall; + + // Visit all cookies. The returned cookies are ordered by longest path, then + // by earliest creation date. Returns false (0) if cookies cannot be accessed. + visit_all_cookies: function(self: PCefCookieManager; visitor: PCefCookieVisitor): Integer; stdcall; + + // Visit a subset of cookies. The results are filtered by the given url + // scheme, host, domain and path. If |includeHttpOnly| is true (1) HTTP-only + // cookies will also be included in the results. The returned cookies are + // ordered by longest path, then by earliest creation date. Returns false (0) + // if cookies cannot be accessed. + visit_url_cookies: function(self: PCefCookieManager; const url: PCefString; + includeHttpOnly: Integer; visitor: PCefCookieVisitor): Integer; stdcall; + + // Sets a cookie given a valid URL and explicit user-provided cookie + // attributes. This function expects each attribute to be well-formed. It will + // check for disallowed characters (e.g. the ';' character is disallowed + // within the cookie value attribute) and will return false (0) without + // setting the cookie if such characters are found. This function must be + // called on the IO thread. + set_cookie: function(self: PCefCookieManager; const url: PCefString; + const cookie: PCefCookie): Integer; stdcall; + + // Delete all cookies that match the specified parameters. If both |url| and + // values |cookie_name| are specified all host and domain cookies matching + // both will be deleted. If only |url| is specified all host cookies (but not + // domain cookies) irrespective of path will be deleted. If |url| is NULL all + // cookies for all hosts and domains will be deleted. Returns false (0) if a + // non- NULL invalid URL is specified or if cookies cannot be accessed. This + // function must be called on the IO thread. + delete_cookies: function(self: PCefCookieManager; + const url, cookie_name: PCefString): Integer; stdcall; + + // Sets the directory path that will be used for storing cookie data. If + // |path| is NULL data will be stored in memory only. Otherwise, data will be + // stored at the specified |path|. To persist session cookies (cookies without + // an expiry date or validity interval) set |persist_session_cookies| to true + // (1). Session cookies are generally intended to be transient and most Web + // browsers do not persist them. Returns false (0) if cookies cannot be + // accessed. + set_storage_path: function(self: PCefCookieManager; + const path: PCefString; persist_session_cookies: Integer): Integer; stdcall; + + // Flush the backing store (if any) to disk and execute the specified + // |handler| on the IO thread when done. Returns false (0) if cookies cannot + // be accessed. + flush_store: function(self: PCefCookieManager; handler: PCefCompletionHandler): Integer; stdcall; + end; + + // Information about a specific web plugin. + TCefWebPluginInfo = record + // Base structure. + base: TCefBase; + + // Returns the plugin name (i.e. Flash). + get_name: function(self: PCefWebPluginInfo): PCefStringUserFree; stdcall; + + // Returns the plugin file path (DLL/bundle/library). + get_path: function(self: PCefWebPluginInfo): PCefStringUserFree; stdcall; + + // Returns the version of the plugin (may be OS-specific). + get_version: function(self: PCefWebPluginInfo): PCefStringUserFree; stdcall; + + // Returns a description of the plugin from the version information. + get_description: function(self: PCefWebPluginInfo): PCefStringUserFree; stdcall; + end; + + // Structure to implement for visiting web plugin information. The functions of + // this structure will be called on the browser process UI thread. + TCefWebPluginInfoVisitor = record + // Base structure. + base: TCefBase; + + // Method that will be called once for each plugin. |count| is the 0-based + // index for the current plugin. |total| is the total number of plugins. + // Return false (0) to stop visiting plugins. This function may never be + // called if no plugins are found. + visit: function(self: PCefWebPluginInfoVisitor; + info: PCefWebPluginInfo; count, total: Integer): Integer; stdcall; + end; + + // Structure to implement for receiving unstable plugin information. The + // functions of this structure will be called on the browser process IO thread. + TCefWebPluginUnstableCallback = record + // Base structure. + base: TCefBase; + + // Method that will be called for the requested plugin. |unstable| will be + // true (1) if the plugin has reached the crash count threshold of 3 times in + // 120 seconds. + is_unstable: procedure(self: PCefWebPluginUnstableCallback; + const path: PCefString; unstable: Integer); stdcall; + end; + + // Structure used to make a URL request. URL requests are not associated with a + // browser instance so no cef_client_t callbacks will be executed. URL requests + // can be created on any valid CEF thread in either the browser or render + // process. Once created the functions of the URL request object must be + // accessed on the same thread that created it. + TCefUrlRequest = record + // Base structure. + base: TCefBase; + + // Returns the request object used to create this URL request. The returned + // object is read-only and should not be modified. + get_request: function(self: PCefUrlRequest): PCefRequest; stdcall; + + // Returns the client. + get_client: function(self: PCefUrlRequest): PCefUrlRequestClient; stdcall; + + // Returns the request status. + get_request_status: function(self: PCefUrlRequest): TCefUrlRequestStatus; stdcall; + + // Returns the request error if status is UR_CANCELED or UR_FAILED, or 0 + // otherwise. + get_request_error: function(self: PCefUrlRequest): Integer; stdcall; + + // Returns the response, or NULL if no response information is available. + // Response information will only be available after the upload has completed. + // The returned object is read-only and should not be modified. + get_response: function(self: PCefUrlRequest): PCefResponse; stdcall; + + // Cancel the request. + cancel: procedure(self: PCefUrlRequest); stdcall; + end; + + // Structure that should be implemented by the cef_urlrequest_t client. The + // functions of this structure will be called on the same thread that created + // the request unless otherwise documented. + TCefUrlrequestClient = record + // Base structure. + base: TCefBase; + + // Notifies the client that the request has completed. Use the + // cef_urlrequest_t::GetRequestStatus function to determine if the request was + // successful or not. + on_request_complete: procedure(self: PCefUrlRequestClient; request: PCefUrlRequest); stdcall; + + // Notifies the client of upload progress. |current| denotes the number of + // bytes sent so far and |total| is the total size of uploading data (or -1 if + // chunked upload is enabled). This function will only be called if the + // UR_FLAG_REPORT_UPLOAD_PROGRESS flag is set on the request. + on_upload_progress: procedure(self: PCefUrlRequestClient; + request: PCefUrlRequest; current, total: UInt64); stdcall; + + // Notifies the client of download progress. |current| denotes the number of + // bytes received up to the call and |total| is the expected total size of the + // response (or -1 if not determined). + on_download_progress: procedure(self: PCefUrlRequestClient; + request: PCefUrlRequest; current, total: UInt64); stdcall; + + // Called when some part of the response is read. |data| contains the current + // bytes received since the last call. This function will not be called if the + // UR_FLAG_NO_DOWNLOAD_DATA flag is set on the request. + on_download_data: procedure(self: PCefUrlRequestClient; + request: PCefUrlRequest; const data: Pointer; data_length: NativeUInt); stdcall; + + // Called on the IO thread when the browser needs credentials from the user. + // |isProxy| indicates whether the host is a proxy server. |host| contains the + // hostname and |port| contains the port number. Return true (1) to continue + // the request and call cef_auth_callback_t::cont() when the authentication + // information is available. Return false (0) to cancel the request. This + // function will only be called for requests initiated from the browser + // process. + get_auth_credentials: function(self: PCefUrlRequestClient; isProxy: Integer; + const host: PCefString; port: Integer; const realm, scheme: PCefString; + callback: PCefAuthCallback): Integer; stdcall; + end; + + // Callback structure for asynchronous continuation of file dialog requests. + TCefFileDialogCallback = record + // Base structure. + base: TCefBase; + + // Continue the file selection with the specified |file_paths|. This may be a + // single value or a list of values depending on the dialog mode. An NULL + // value is treated the same as calling cancel(). + cont: procedure(self: PCefFileDialogCallback; file_paths: TCefStringList); stdcall; + + // Cancel the file selection. + cancel: procedure(self: PCefFileDialogCallback); stdcall; + end; + + // Implement this structure to handle dialog events. The functions of this + // structure will be called on the browser process UI thread. + TCefDialogHandler = record + // Base structure. + base: TCefBase; + + // Called to run a file chooser dialog. |mode| represents the type of dialog + // to display. |title| to the title to be used for the dialog and may be NULL + // to show the default title ("Open" or "Save" depending on the mode). + // |default_file_name| is the default file name to select in the dialog. + // |accept_types| is a list of valid lower-cased MIME types or file extensions + // specified in an input element and is used to restrict selectable files to + // such types. To display a custom dialog return true (1) and execute + // |callback| either inline or at a later time. To display the default dialog + // return false (0). + on_file_dialog: function(self: PCefDialogHandler; browser: PCefBrowser; + mode: TCefFileDialogMode; const title, default_file_name: PCefString; + accept_types: TCefStringList; callback: PCefFileDialogCallback): Integer; stdcall; + end; + + // Implement this structure to handle events when window rendering is disabled. + // The functions of this structure will be called on the UI thread. + TCefRenderHandler = record + // Base structure. + base: TCefBase; + + // Called to retrieve the root window rectangle in screen coordinates. Return + // true (1) if the rectangle was provided. + get_root_screen_rect: function(self: PCefRenderHandler; browser: PCefBrowser; + rect: PCefRect): Integer; stdcall; + + // Called to retrieve the view rectangle which is relative to screen + // coordinates. Return true (1) if the rectangle was provided. + get_view_rect: function(self: PCefRenderHandler; browser: PCefBrowser; + rect: PCefRect): Integer; stdcall; + + // Called to retrieve the translation from view coordinates to actual screen + // coordinates. Return true (1) if the screen coordinates were provided. + get_screen_point: function(self: PCefRenderHandler; browser: PCefBrowser; + viewX, viewY: Integer; screenX, screenY: PInteger): Integer; stdcall; + + // Called to allow the client to fill in the CefScreenInfo object with + // appropriate values. Return true (1) if the |screen_info| structure has been + // modified. + // + // If the screen info rectangle is left NULL the rectangle from GetViewRect + // will be used. If the rectangle is still NULL or invalid popups may not be + // drawn correctly. + get_screen_info: function(self: PCefRenderHandler; browser: PCefBrowser; + screen_info: PCefScreenInfo): Integer; stdcall; + + // Called when the browser wants to show or hide the popup widget. The popup + // should be shown if |show| is true (1) and hidden if |show| is false (0). + on_popup_show: procedure(self: PCefRenderProcessHandler; browser: PCefBrowser; + show: Integer); stdcall; + + // Called when the browser wants to move or resize the popup widget. |rect| + // contains the new location and size. + on_popup_size: procedure(self: PCefRenderProcessHandler; browser: PCefBrowser; + const rect: PCefRect); stdcall; + + // Called when an element should be painted. |type| indicates whether the + // element is the view or the popup widget. |buffer| contains the pixel data + // for the whole image. |dirtyRects| contains the set of rectangles that need + // to be repainted. On Windows |buffer| will be |width|*|height|*4 bytes in + // size and represents a BGRA image with an upper-left origin. + on_paint: procedure(self: PCefRenderProcessHandler; browser: PCefBrowser; + kind: TCefPaintElementType; dirtyRectsCount: NativeUInt; + const dirtyRects: PCefRectArray; const buffer: Pointer; width, height: Integer); stdcall; + + // Called when the browser window's cursor has changed. + on_cursor_change: procedure(self: PCefRenderProcessHandler; browser: PCefBrowser; + cursor: TCefCursorHandle); stdcall; + + // Called when the scroll offset has changed. + on_scroll_offset_changed: procedure(self: PCefRenderProcessHandler; + browser: PCefBrowser); stdcall; + end; + + // Implement this structure to receive geolocation updates. The functions of + // this structure will be called on the browser process UI thread. + TCefGetGeolocationCallback = record + // Base structure. + base: TCefBase; + + // Called with the 'best available' location information or, if the location + // update failed, with error information. + on_location_update: procedure(self: PCefGetGeolocationCallback; + const position: Pcefgeoposition); stdcall; + end; + + // Implement this structure to receive trace notifications. The functions of + // this structure will be called on the browser process UI thread. + + TCefTraceClient = record + // Base structure. + base: TCefBase; + + // Called 0 or more times between CefBeginTracing and OnEndTracingComplete + // with a UTF8 JSON |fragment| of the specified |fragment_size|. Do not keep a + // reference to |fragment|. + + on_trace_data_collected: procedure(self: PCefTraceClient; + const fragment: PAnsiChar; fragment_size: NativeUInt); stdcall; + + // Called in response to CefGetTraceBufferPercentFullAsync. + on_trace_buffer_percent_full_reply: procedure(self: PCefTraceClient; percent_full: Single); stdcall; + + // Called after all processes have sent their trace data. + on_end_tracing_complete: procedure(self: PCefTraceClient); stdcall; + end; + + TCefDragData = record + // Base structure. + base: TCefBase; + + // Returns true (1) if the drag data is a link. + is_link: function(self: PCefDragData): Integer; stdcall; + + // Returns true (1) if the drag data is a text or html fragment. + is_fragment: function(self: PCefDragData): Integer; stdcall; + + // Returns true (1) if the drag data is a file. + is_file: function(self: PCefDragData): Integer; stdcall; + + // Return the link URL that is being dragged. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_link_url: function(self: PCefDragData): PCefStringUserFree; stdcall; + + // Return the title associated with the link being dragged. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_link_title: function(self: PCefDragData): PCefStringUserFree; stdcall; + + // Return the metadata, if any, associated with the link being dragged. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_link_metadata: function(self: PCefDragData): PCefStringUserFree; stdcall; + + // Return the plain text fragment that is being dragged. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_fragment_text: function(self: PCefDragData): PCefStringUserFree; stdcall; + + // Return the text/html fragment that is being dragged. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_fragment_html: function(self: PCefDragData): PCefStringUserFree; stdcall; + + // Return the base URL that the fragment came from. This value is used for + // resolving relative URLs and may be NULL. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_fragment_base_url: function(self: PCefDragData): PCefStringUserFree; stdcall; + + // Return the name of the file being dragged out of the browser window. + // The resulting string must be freed by calling cef_string_userfree_free(). + get_file_name: function(self: PCefDragData): PCefStringUserFree; stdcall; + + // Retrieve the list of file names that are being dragged into the browser + // window. + get_file_names: function(self: PCefDragData; names: TCefStringList): Integer; stdcall; + end; + + // Implement this structure to handle events related to dragging. The functions + // of this structure will be called on the UI thread. + TCefDragHandler = record + // Base structure. + base: TCefBase; + + // Called when an external drag event enters the browser window. |dragData| + // contains the drag event data and |mask| represents the type of drag + // operation. Return false (0) for default drag handling behavior or true (1) + // to cancel the drag event. + on_drag_enter: function(self: PCefDragHandler; browser: PCefBrowser; + dragData: PCefDragData; mask: TCefDragOperations): Integer; stdcall + end; + + // Implement this structure to provide handler implementations. + TCefRequestContextHandler = record + // Base structure. + base: TCefBase; + + // Called on the IO thread to retrieve the cookie manager. The global cookie + // manager will be used if this function returns NULL. + get_cookie_manager: function(self: PCefRequestContextHandler): PCefCookieManager; stdcall; + end; + + // A request context provides request handling for a set of related browser + // objects. A request context is specified when creating a new browser object + // via the cef_browser_host_t static factory functions. Browser objects with + // different request contexts will never be hosted in the same render process. + // Browser objects with the same request context may or may not be hosted in the + // same render process depending on the process model. Browser objects created + // indirectly via the JavaScript window.open function or targeted links will + // share the same render process and the same request context as the source + // browser. When running in single-process mode there is only a single render + // process (the main process) and so all browsers created in single-process mode + // will share the same request context. This will be the first request context + // passed into a cef_browser_host_t static factory function and all other + // request context objects will be ignored. + + TCefRequestContext = record + // Base structure. + base: TCefBase; + + // Returns true (1) if this object is pointing to the same context as |that| + // object. + is_same: function(self, other: PCefRequestContext): Integer; stdcall; + + // Returns true (1) if this object is the global context. + is_global: function(self: PCefRequestContext): Integer; stdcall; + + // Returns the handler for this context if any. + get_handler: function(self: PCefRequestContext): PCefRequestHandler; stdcall; + end; + +//****************************************************************************** +// +// I N T E R F A C E S +// +//****************************************************************************** + + ICefBrowser = interface; + ICefFrame = interface; + ICefRequest = interface; + ICefv8Value = interface; + ICefDomVisitor = interface; + ICefDomDocument = interface; + ICefDomNode = interface; + ICefv8Context = interface; + ICefListValue = interface; + ICefClient = interface; + ICefUrlrequestClient = interface; + ICefBrowserHost = interface; + ICefTask = interface; + ICefTaskRunner = interface; + ICefFileDialogCallback = interface; + ICefRequestContext = interface; + ICefLoadHandler = interface; + + ICefBase = interface + ['{1F9A7B44-DCDC-4477-9180-3ADD44BDEB7B}'] + function Wrap: Pointer; + end; + + ICefRunFileDialogCallback = interface(ICefBase) + ['{59FCECC6-E897-45BA-873B-F09586C4BE47}'] + procedure cont(const browserHost: ICefBrowserHost; filePaths: TStrings); + end; + + TCefRunFileDialogCallbackProc = {$IFDEF DELPHI12_UP}reference to{$ENDIF} + procedure(const browserHost: ICefBrowserHost; filePaths: TStrings); + + ICefBrowserHost = interface(ICefBase) + ['{53AE02FF-EF5D-48C3-A43E-069DA9535424}'] + function GetBrowser: ICefBrowser; + procedure ParentWindowWillClose; + procedure CloseBrowser(forceClose: Boolean); + procedure SetFocus(enable: Boolean); + function GetWindowHandle: TCefWindowHandle; + function GetOpenerWindowHandle: TCefWindowHandle; + function GetRequestContext: ICefRequestContext; + function GetDevToolsUrl(httpScheme: Boolean): ustring; + function GetZoomLevel: Double; + procedure SetZoomLevel(zoomLevel: Double); + procedure RunFileDialog(mode: TCefFileDialogMode; const title, defaultFileName: ustring; + acceptTypes: TStrings; const callback: ICefRunFileDialogCallback); + procedure RunFileDialogProc(mode: TCefFileDialogMode; const title, defaultFileName: ustring; + acceptTypes: TStrings; const callback: TCefRunFileDialogCallbackProc); + procedure StartDownload(const url: ustring); + procedure Print; + procedure Find(identifier: Integer; const searchText: ustring; forward, matchCase, findNext: Boolean); + procedure StopFinding(clearSelection: Boolean); + procedure SetMouseCursorChangeDisabled(disabled: Boolean); + function IsMouseCursorChangeDisabled: Boolean; + function IsWindowRenderingDisabled: Boolean; + procedure WasResized; + procedure WasHidden(hidden: Boolean); + procedure NotifyScreenInfoChanged; + procedure Invalidate(const dirtyRect: PCefRect; kind: TCefPaintElementType); + procedure SendKeyEvent(const event: PCefKeyEvent); + procedure SendMouseClickEvent(const event: PCefMouseEvent; + kind: TCefMouseButtonType; mouseUp: Boolean; clickCount: Integer); + procedure SendMouseMoveEvent(const event: PCefMouseEvent; mouseLeave: Boolean); + procedure SendMouseWheelEvent(const event: PCefMouseEvent; deltaX, deltaY: Integer); + procedure SendFocusEvent(setFocus: Boolean); + procedure SendCaptureLostEvent; + function GetNsTextInputContext: TCefTextInputContext; + procedure HandleKeyEventBeforeTextInputClient(keyEvent: TCefEventHandle); + procedure HandleKeyEventAfterTextInputClient(keyEvent: TCefEventHandle); + + property Browser: ICefBrowser read GetBrowser; + property WindowHandle: TCefWindowHandle read GetWindowHandle; + property OpenerWindowHandle: TCefWindowHandle read GetOpenerWindowHandle; + property ZoomLevel: Double read GetZoomLevel write SetZoomLevel; + end; + + ICefProcessMessage = interface(ICefBase) + ['{E0B1001A-8777-425A-869B-29D40B8B93B1}'] + function IsValid: Boolean; + function IsReadOnly: Boolean; + function Copy: ICefProcessMessage; + function GetName: ustring; + function GetArgumentList: ICefListValue; + property Name: ustring read GetName; + property ArgumentList: ICefListValue read GetArgumentList; + end; + + ICefBrowser = interface(ICefBase) + ['{BA003C2E-CF15-458F-9D4A-FE3CEFCF3EEF}'] + function GetHost: ICefBrowserHost; + function CanGoBack: Boolean; + procedure GoBack; + function CanGoForward: Boolean; + procedure GoForward; + function IsLoading: Boolean; + procedure Reload; + procedure ReloadIgnoreCache; + procedure StopLoad; + function GetIdentifier: Integer; + function IsSame(const that: ICefBrowser): Boolean; + function IsPopup: Boolean; + function HasDocument: Boolean; + function GetMainFrame: ICefFrame; + function GetFocusedFrame: ICefFrame; + function GetFrameByident(identifier: Int64): ICefFrame; + function GetFrame(const name: ustring): ICefFrame; + function GetFrameCount: NativeUInt; + procedure GetFrameIdentifiers(count: PNativeUInt; identifiers: PInt64); + procedure GetFrameNames(names: TStrings); + function SendProcessMessage(targetProcess: TCefProcessId; + message: ICefProcessMessage): Boolean; + property MainFrame: ICefFrame read GetMainFrame; + property FocusedFrame: ICefFrame read GetFocusedFrame; + property FrameCount: NativeUInt read GetFrameCount; + property Host: ICefBrowserHost read GetHost; + property Identifier: Integer read GetIdentifier; + end; + + ICefPostDataElement = interface(ICefBase) + ['{3353D1B8-0300-4ADC-8D74-4FF31C77D13C}'] + function IsReadOnly: Boolean; + procedure SetToEmpty; + procedure SetToFile(const fileName: ustring); + procedure SetToBytes(size: NativeUInt; bytes: Pointer); + function GetType: TCefPostDataElementType; + function GetFile: ustring; + function GetBytesCount: NativeUInt; + function GetBytes(size: NativeUInt; bytes: Pointer): NativeUInt; + end; + + ICefPostData = interface(ICefBase) + ['{1E677630-9339-4732-BB99-D6FE4DE4AEC0}'] + function IsReadOnly: Boolean; + function GetCount: NativeUInt; + function GetElements(Count: NativeUInt): IInterfaceList; // ICefPostDataElement + function RemoveElement(const element: ICefPostDataElement): Integer; + function AddElement(const element: ICefPostDataElement): Integer; + procedure RemoveElements; + end; + + ICefStringMap = interface + ['{A33EBC01-B23A-4918-86A4-E24A243B342F}'] + function GetHandle: TCefStringMap; + function GetSize: Integer; + function Find(const Key: ustring): ustring; + function GetKey(Index: Integer): ustring; + function GetValue(Index: Integer): ustring; + procedure Append(const Key, Value: ustring); + procedure Clear; + + property Handle: TCefStringMap read GetHandle; + property Size: Integer read GetSize; + property Key[index: Integer]: ustring read GetKey; + property Value[index: Integer]: ustring read GetValue; + end; + + ICefStringMultimap = interface + ['{583ED0C2-A9D6-4034-A7C9-20EC7E47F0C7}'] + function GetHandle: TCefStringMultimap; + function GetSize: Integer; + function FindCount(const Key: ustring): Integer; + function GetEnumerate(const Key: ustring; ValueIndex: Integer): ustring; + function GetKey(Index: Integer): ustring; + function GetValue(Index: Integer): ustring; + procedure Append(const Key, Value: ustring); + procedure Clear; + + property Handle: TCefStringMap read GetHandle; + property Size: Integer read GetSize; + property Key[index: Integer]: ustring read GetKey; + property Value[index: Integer]: ustring read GetValue; + property Enumerate[const Key: ustring; ValueIndex: Integer]: ustring read GetEnumerate; + end; + + ICefRequest = interface(ICefBase) + ['{FB4718D3-7D13-4979-9F4C-D7F6C0EC592A}'] + function IsReadOnly: Boolean; + function GetUrl: ustring; + function GetMethod: ustring; + function GetPostData: ICefPostData; + procedure GetHeaderMap(const HeaderMap: ICefStringMultimap); + procedure SetUrl(const value: ustring); + procedure SetMethod(const value: ustring); + procedure SetPostData(const value: ICefPostData); + procedure SetHeaderMap(const HeaderMap: ICefStringMultimap); + function GetFlags: TCefUrlRequestFlags; + procedure SetFlags(flags: TCefUrlRequestFlags); + function GetFirstPartyForCookies: ustring; + procedure SetFirstPartyForCookies(const url: ustring); + procedure Assign(const url, method: ustring; + const postData: ICefPostData; const headerMap: ICefStringMultimap); + function GetResourceType: TCefResourceType; + function GetTransitionType: TCefTransitionType; + property Url: ustring read GetUrl write SetUrl; + property Method: ustring read GetMethod write SetMethod; + property PostData: ICefPostData read GetPostData write SetPostData; + property Flags: TCefUrlRequestFlags read GetFlags write SetFlags; + property FirstPartyForCookies: ustring read GetFirstPartyForCookies write SetFirstPartyForCookies; + property ResourceType: TCefResourceType read GetResourceType; + property TransitionType: TCefTransitionType read GetTransitionType; + end; + + TCefDomVisitorProc = {$IFDEF DELPHI12_UP}reference to{$ENDIF} procedure(const document: ICefDomDocument); + + TCefStringVisitorProc = {$IFDEF DELPHI12_UP}reference to{$ENDIF} procedure(const str: ustring); + + ICefStringVisitor = interface(ICefBase) + ['{63ED4D6C-2FC8-4537-964B-B84C008F6158}'] + procedure Visit(const str: ustring); + end; + + ICefFrame = interface(ICefBase) + ['{8FD3D3A6-EA3A-4A72-8501-0276BD5C3D1D}'] + function IsValid: Boolean; + procedure Undo; + procedure Redo; + procedure Cut; + procedure Copy; + procedure Paste; + procedure Del; + procedure SelectAll; + procedure ViewSource; + procedure GetSource(const visitor: ICefStringVisitor); + procedure GetSourceProc(const proc: TCefStringVisitorProc); + procedure GetText(const visitor: ICefStringVisitor); + procedure GetTextProc(const proc: TCefStringVisitorProc); + procedure LoadRequest(const request: ICefRequest); + procedure LoadUrl(const url: ustring); + procedure LoadString(const str, url: ustring); + procedure ExecuteJavaScript(const code, scriptUrl: ustring; startLine: Integer); + function IsMain: Boolean; + function IsFocused: Boolean; + function GetName: ustring; + function GetIdentifier: Int64; + function GetParent: ICefFrame; + function GetUrl: ustring; + function GetBrowser: ICefBrowser; + function GetV8Context: ICefv8Context; + procedure VisitDom(const visitor: ICefDomVisitor); + procedure VisitDomProc(const proc: TCefDomVisitorProc); + property Name: ustring read GetName; + property Url: ustring read GetUrl; + property Browser: ICefBrowser read GetBrowser; + property Parent: ICefFrame read GetParent; + end; + + + ICefCustomStreamReader = interface(ICefBase) + ['{BBCFF23A-6FE7-4C28-B13E-6D2ACA5C83B7}'] + function Read(ptr: Pointer; size, n: NativeUInt): NativeUInt; + function Seek(offset: Int64; whence: Integer): Integer; + function Tell: Int64; + function Eof: Boolean; + end; + + ICefStreamReader = interface(ICefBase) + ['{DD5361CB-E558-49C5-A4BD-D1CE84ADB277}'] + function Read(ptr: Pointer; size, n: NativeUInt): NativeUInt; + function Seek(offset: Int64; whence: Integer): Integer; + function Tell: Int64; + function Eof: Boolean; + end; + + ICefResponse = interface(ICefBase) + ['{E9C896E4-59A8-4B96-AB5E-6EA3A498B7F1}'] + function IsReadOnly: Boolean; + function GetStatus: Integer; + procedure SetStatus(status: Integer); + function GetStatusText: ustring; + procedure SetStatusText(const StatusText: ustring); + function GetMimeType: ustring; + procedure SetMimeType(const mimetype: ustring); + function GetHeader(const name: ustring): ustring; + procedure GetHeaderMap(const headerMap: ICefStringMultimap); + procedure SetHeaderMap(const headerMap: ICefStringMultimap); + property Status: Integer read GetStatus write SetStatus; + property StatusText: ustring read GetStatusText write SetStatusText; + property MimeType: ustring read GetMimeType write SetMimeType; + end; + + ICefDownloadItem = interface(ICefBase) + ['{B34BD320-A82E-4185-8E84-B98E5EEC803F}'] + function IsValid: Boolean; + function IsInProgress: Boolean; + function IsComplete: Boolean; + function IsCanceled: Boolean; + function GetCurrentSpeed: Int64; + function GetPercentComplete: Integer; + function GetTotalBytes: Int64; + function GetReceivedBytes: Int64; + function GetStartTime: TDateTime; + function GetEndTime: TDateTime; + function GetFullPath: ustring; + function GetId: Integer; + function GetUrl: ustring; + function GetSuggestedFileName: ustring; + function GetContentDisposition: ustring; + function GetMimeType: ustring; + + property CurrentSpeed: Int64 read GetCurrentSpeed; + property PercentComplete: Integer read GetPercentComplete; + property TotalBytes: Int64 read GetTotalBytes; + property ReceivedBytes: Int64 read GetReceivedBytes; + property StartTime: TDateTime read GetStartTime; + property EndTime: TDateTime read GetEndTime; + property FullPath: ustring read GetFullPath; + property Id: Integer read GetId; + property Url: ustring read GetUrl; + property SuggestedFileName: ustring read GetSuggestedFileName; + property ContentDisposition: ustring read GetContentDisposition; + property MimeType: ustring read GetMimeType; + end; + + ICefBeforeDownloadCallback = interface(ICefBase) + ['{5A81AF75-CBA2-444D-AD8E-522160F36433}'] + procedure Cont(const downloadPath: ustring; showDialog: Boolean); + end; + + ICefDownloadItemCallback = interface(ICefBase) + ['{498F103F-BE64-4D5F-86B7-B37EC69E1735}'] + procedure cancel; + end; + + ICefDownloadHandler = interface(ICefBase) + ['{3137F90A-5DC5-43C1-858D-A269F28EF4F1}'] + procedure OnBeforeDownload(const browser: ICefBrowser; const downloadItem: ICefDownloadItem; + const suggestedName: ustring; const callback: ICefBeforeDownloadCallback); + procedure OnDownloadUpdated(const browser: ICefBrowser; const downloadItem: ICefDownloadItem; + const callback: ICefDownloadItemCallback); + end; + + ICefV8Exception = interface(ICefBase) + ['{7E422CF0-05AC-4A60-A029-F45105DCE6A4}'] + function GetMessage: ustring; + function GetSourceLine: ustring; + function GetScriptResourceName: ustring; + function GetLineNumber: Integer; + function GetStartPosition: Integer; + function GetEndPosition: Integer; + function GetStartColumn: Integer; + function GetEndColumn: Integer; + + property Message: ustring read GetMessage; + property SourceLine: ustring read GetSourceLine; + property ScriptResourceName: ustring read GetScriptResourceName; + property LineNumber: Integer read GetLineNumber; + property StartPosition: Integer read GetStartPosition; + property EndPosition: Integer read GetEndPosition; + property StartColumn: Integer read GetStartColumn; + property EndColumn: Integer read GetEndColumn; + end; + + ICefv8Context = interface(ICefBase) + ['{2295A11A-8773-41F2-AD42-308C215062D9}'] + function GetTaskRunner: ICefTaskRunner; + function IsValid: Boolean; + function GetBrowser: ICefBrowser; + function GetFrame: ICefFrame; + function GetGlobal: ICefv8Value; + function Enter: Boolean; + function Exit: Boolean; + function IsSame(const that: ICefv8Context): Boolean; + function Eval(const code: ustring; var retval: ICefv8Value; var exception: ICefV8Exception): Boolean; + property Browser: ICefBrowser read GetBrowser; + property Frame: ICefFrame read GetFrame; + property Global: ICefv8Value read GetGlobal; + end; + + TCefv8ValueArray = array of ICefv8Value; + + ICefv8Handler = interface(ICefBase) + ['{F94CDC60-FDCB-422D-96D5-D2A775BD5D73}'] + function Execute(const name: ustring; const obj: ICefv8Value; + const arguments: TCefv8ValueArray; var retval: ICefv8Value; + var exception: ustring): Boolean; + end; + + ICefV8Accessor = interface(ICefBase) + ['{DCA6D4A2-726A-4E24-AA64-5E8C731D868A}'] + function Get(const name: ustring; const obj: ICefv8Value; + out value: ICefv8Value; const exception: ustring): Boolean; + function Put(const name: ustring; const obj: ICefv8Value; + const value: ICefv8Value; const exception: ustring): Boolean; + end; + + ICefTask = interface(ICefBase) + ['{0D965470-4A86-47CE-BD39-A8770021AD7E}'] + procedure Execute; + end; + + ICefTaskRunner = interface(ICefBase) + ['{6A500FA3-77B7-4418-8EA8-6337EED1337B}'] + function IsSame(const that: ICefTaskRunner): Boolean; + function BelongsToCurrentThread: Boolean; + function BelongsToThread(threadId: TCefThreadId): Boolean; + function PostTask(const task: ICefTask): Boolean; stdcall; + function PostDelayedTask(const task: ICefTask; delayMs: Int64): Boolean; + end; + + ICefv8Value = interface(ICefBase) + ['{52319B8D-75A8-422C-BD4B-16FA08CC7F42}'] + function IsValid: Boolean; + function IsUndefined: Boolean; + function IsNull: Boolean; + function IsBool: Boolean; + function IsInt: Boolean; + function IsUInt: Boolean; + function IsDouble: Boolean; + function IsDate: Boolean; + function IsString: Boolean; + function IsObject: Boolean; + function IsArray: Boolean; + function IsFunction: Boolean; + function IsSame(const that: ICefv8Value): Boolean; + function GetBoolValue: Boolean; + function GetIntValue: Integer; + function GetUIntValue: Cardinal; + function GetDoubleValue: Double; + function GetDateValue: TDateTime; + function GetStringValue: ustring; + function IsUserCreated: Boolean; + function HasException: Boolean; + function GetException: ICefV8Exception; + function ClearException: Boolean; + function WillRethrowExceptions: Boolean; + function SetRethrowExceptions(rethrow: Boolean): Boolean; + function HasValueByKey(const key: ustring): Boolean; + function HasValueByIndex(index: Integer): Boolean; + function DeleteValueByKey(const key: ustring): Boolean; + function DeleteValueByIndex(index: Integer): Boolean; + function GetValueByKey(const key: ustring): ICefv8Value; + function GetValueByIndex(index: Integer): ICefv8Value; + function SetValueByKey(const key: ustring; const value: ICefv8Value; + attribute: TCefV8PropertyAttributes): Boolean; + function SetValueByIndex(index: Integer; const value: ICefv8Value): Boolean; + function SetValueByAccessor(const key: ustring; settings: TCefV8AccessControls; + attribute: TCefV8PropertyAttributes): Boolean; + function GetKeys(const keys: TStrings): Integer; + function SetUserData(const data: ICefv8Value): Boolean; + function GetUserData: ICefv8Value; + function GetExternallyAllocatedMemory: Integer; + function AdjustExternallyAllocatedMemory(changeInBytes: Integer): Integer; + function GetArrayLength: Integer; + function GetFunctionName: ustring; + function GetFunctionHandler: ICefv8Handler; + function ExecuteFunction(const obj: ICefv8Value; + const arguments: TCefv8ValueArray): ICefv8Value; + function ExecuteFunctionWithContext(const context: ICefv8Context; + const obj: ICefv8Value; const arguments: TCefv8ValueArray): ICefv8Value; + end; + + ICefV8StackFrame = interface(ICefBase) + ['{BA1FFBF4-E9F2-4842-A827-DC220F324286}'] + function IsValid: Boolean; + function GetScriptName: ustring; + function GetScriptNameOrSourceUrl: ustring; + function GetFunctionName: ustring; + function GetLineNumber: Integer; + function GetColumn: Integer; + function IsEval: Boolean; + function IsConstructor: Boolean; + + property ScriptName: ustring read GetScriptName; + property ScriptNameOrSourceUrl: ustring read GetScriptNameOrSourceUrl; + property FunctionName: ustring read GetFunctionName; + property LineNumber: Integer read GetLineNumber; + property Column: Integer read GetColumn; + end; + + ICefV8StackTrace = interface(ICefBase) + ['{32111C84-B7F7-4E3A-92B9-7CA1D0ADB613}'] + function IsValid: Boolean; + function GetFrameCount: Integer; + function GetFrame(index: Integer): ICefV8StackFrame; + property FrameCount: Integer read GetFrameCount; + property Frame[index: Integer]: ICefV8StackFrame read GetFrame; + end; + + ICefXmlReader = interface(ICefBase) + ['{0DE686C3-A8D7-45D2-82FD-92F7F4E62A90}'] + function MoveToNextNode: Boolean; + function Close: Boolean; + function HasError: Boolean; + function GetError: ustring; + function GetType: TCefXmlNodeType; + function GetDepth: Integer; + function GetLocalName: ustring; + function GetPrefix: ustring; + function GetQualifiedName: ustring; + function GetNamespaceUri: ustring; + function GetBaseUri: ustring; + function GetXmlLang: ustring; + function IsEmptyElement: Boolean; + function HasValue: Boolean; + function GetValue: ustring; + function HasAttributes: Boolean; + function GetAttributeCount: NativeUInt; + function GetAttributeByIndex(index: Integer): ustring; + function GetAttributeByQName(const qualifiedName: ustring): ustring; + function GetAttributeByLName(const localName, namespaceURI: ustring): ustring; + function GetInnerXml: ustring; + function GetOuterXml: ustring; + function GetLineNumber: Integer; + function MoveToAttributeByIndex(index: Integer): Boolean; + function MoveToAttributeByQName(const qualifiedName: ustring): Boolean; + function MoveToAttributeByLName(const localName, namespaceURI: ustring): Boolean; + function MoveToFirstAttribute: Boolean; + function MoveToNextAttribute: Boolean; + function MoveToCarryingElement: Boolean; + end; + + ICefZipReader = interface(ICefBase) + ['{3B6C591F-9877-42B3-8892-AA7B27DA34A8}'] + function MoveToFirstFile: Boolean; + function MoveToNextFile: Boolean; + function MoveToFile(const fileName: ustring; caseSensitive: Boolean): Boolean; + function Close: Boolean; + function GetFileName: ustring; + function GetFileSize: Int64; + function GetFileLastModified: LongInt; + function OpenFile(const password: ustring): Boolean; + function CloseFile: Boolean; + function ReadFile(buffer: Pointer; bufferSize: NativeUInt): Integer; + function Tell: Int64; + function Eof: Boolean; + end; + + ICefDomEvent = interface(ICefBase) + ['{2CBD2259-ADC6-4187-9008-A666B57695CE}'] + function GetType: ustring; + function GetCategory: TCefDomEventCategory; + function GetPhase: TCefDomEventPhase; + function CanBubble: Boolean; + function CanCancel: Boolean; + function GetDocument: ICefDomDocument; + function GetTarget: ICefDomNode; + function GetCurrentTarget: ICefDomNode; + + property EventType: ustring read GetType; + property Category: TCefDomEventCategory read GetCategory; + property Phase: TCefDomEventPhase read GetPhase; + property Bubble: Boolean read CanBubble; + property Cancel: Boolean read CanCancel; + property Document: ICefDomDocument read GetDocument; + property Target: ICefDomNode read GetTarget; + property CurrentTarget: ICefDomNode read GetCurrentTarget; + end; + + ICefDomEventListener = interface(ICefBase) + ['{68BABB49-1824-42D0-ACCC-FDE9F8D39B88}'] + procedure HandleEvent(const event: ICefDomEvent); + end; + + TCefDomEventListenerProc = {$IFDEF DELPHI12_UP}reference to {$ENDIF}procedure(const event: ICefDomEvent); + + ICefDomNode = interface(ICefBase) + ['{96C03C9E-9C98-491A-8DAD-1947332232D6}'] + function GetType: TCefDomNodeType; + function IsText: Boolean; + function IsElement: Boolean; + function IsEditable: Boolean; + function IsFormControlElement: Boolean; + function GetFormControlElementType: ustring; + function IsSame(const that: ICefDomNode): Boolean; + function GetName: ustring; + function GetValue: ustring; + function SetValue(const value: ustring): Boolean; + function GetAsMarkup: ustring; + function GetDocument: ICefDomDocument; + function GetParent: ICefDomNode; + function GetPreviousSibling: ICefDomNode; + function GetNextSibling: ICefDomNode; + function HasChildren: Boolean; + function GetFirstChild: ICefDomNode; + function GetLastChild: ICefDomNode; + procedure AddEventListener(const eventType: ustring; useCapture: Boolean; + const listener: ICefDomEventListener); + procedure AddEventListenerProc(const eventType: ustring; useCapture: Boolean; + const proc: TCefDomEventListenerProc); + function GetElementTagName: ustring; + function HasElementAttributes: Boolean; + function HasElementAttribute(const attrName: ustring): Boolean; + function GetElementAttribute(const attrName: ustring): ustring; + procedure GetElementAttributes(const attrMap: ICefStringMap); + function SetElementAttribute(const attrName, value: ustring): Boolean; + function GetElementInnerText: ustring; + + property NodeType: TCefDomNodeType read GetType; + property Name: ustring read GetName; + property AsMarkup: ustring read GetAsMarkup; + property Document: ICefDomDocument read GetDocument; + property Parent: ICefDomNode read GetParent; + property PreviousSibling: ICefDomNode read GetPreviousSibling; + property NextSibling: ICefDomNode read GetNextSibling; + property FirstChild: ICefDomNode read GetFirstChild; + property LastChild: ICefDomNode read GetLastChild; + property ElementTagName: ustring read GetElementTagName; + property ElementInnerText: ustring read GetElementInnerText; + end; + + ICefDomDocument = interface(ICefBase) + ['{08E74052-45AF-4F69-A578-98A5C3959426}'] + function GetType: TCefDomDocumentType; + function GetDocument: ICefDomNode; + function GetBody: ICefDomNode; + function GetHead: ICefDomNode; + function GetTitle: ustring; + function GetElementById(const id: ustring): ICefDomNode; + function GetFocusedNode: ICefDomNode; + function HasSelection: Boolean; + function GetSelectionStartNode: ICefDomNode; + function GetSelectionStartOffset: Integer; + function GetSelectionEndNode: ICefDomNode; + function GetSelectionEndOffset: Integer; + function GetSelectionAsMarkup: ustring; + function GetSelectionAsText: ustring; + function GetBaseUrl: ustring; + function GetCompleteUrl(const partialURL: ustring): ustring; + property DocType: TCefDomDocumentType read GetType; + property Document: ICefDomNode read GetDocument; + property Body: ICefDomNode read GetBody; + property Head: ICefDomNode read GetHead; + property Title: ustring read GetTitle; + property FocusedNode: ICefDomNode read GetFocusedNode; + property SelectionStartNode: ICefDomNode read GetSelectionStartNode; + property SelectionStartOffset: Integer read GetSelectionStartOffset; + property SelectionEndNode: ICefDomNode read GetSelectionEndNode; + property SelectionEndOffset: Integer read GetSelectionEndOffset; + property SelectionAsMarkup: ustring read GetSelectionAsMarkup; + property SelectionAsText: ustring read GetSelectionAsText; + property BaseUrl: ustring read GetBaseUrl; + end; + + ICefDomVisitor = interface(ICefBase) + ['{30398428-3196-4531-B968-2DDBED36F6B0}'] + procedure visit(const document: ICefDomDocument); + end; + + ICefCookieVisitor = interface(ICefBase) + ['{8378CF1B-84AB-4FDB-9B86-34DDABCCC402}'] + function visit(const name, value, domain, path: ustring; secure, httponly, + hasExpires: Boolean; const creation, lastAccess, expires: TDateTime; + count, total: Integer; out deleteCookie: Boolean): Boolean; + end; + + ICefResourceBundleHandler = interface(ICefBase) + ['{09C264FD-7E03-41E3-87B3-4234E82B5EA2}'] + function GetLocalizedString(messageId: Integer; out stringVal: ustring): Boolean; + function GetDataResource(resourceId: Integer; out data: Pointer; out dataSize: NativeUInt): Boolean; + end; + + ICefCommandLine = interface(ICefBase) + ['{6B43D21B-0F2C-4B94-B4E6-4AF0D7669D8E}'] + function IsValid: Boolean; + function IsReadOnly: Boolean; + function Copy: ICefCommandLine; + procedure InitFromArgv(argc: Integer; const argv: PPAnsiChar); + procedure InitFromString(const commandLine: ustring); + procedure Reset; + function GetCommandLineString: ustring; + procedure GetArgv(args: TStrings); + function GetProgram: ustring; + procedure SetProgram(const prog: ustring); + function HasSwitches: Boolean; + function HasSwitch(const name: ustring): Boolean; + function GetSwitchValue(const name: ustring): ustring; + procedure GetSwitches(switches: TStrings); + procedure AppendSwitch(const name: ustring); + procedure AppendSwitchWithValue(const name, value: ustring); + function HasArguments: Boolean; + procedure GetArguments(arguments: TStrings); + procedure AppendArgument(const argument: ustring); + procedure PrependWrapper(const wrapper: ustring); + property CommandLineString: ustring read GetCommandLineString; + end; + + ICefBrowserProcessHandler = interface(ICefBase) + ['{27291B7A-C0AE-4EE0-9115-15C810E22F6C}'] + procedure OnContextInitialized; + procedure OnBeforeChildProcessLaunch(const commandLine: ICefCommandLine); + procedure OnRenderProcessThreadCreated(const extraInfo: ICefListValue); + end; + + ICefSchemeRegistrar = interface(ICefBase) + ['{1832FF6E-100B-4E8B-B996-AD633168BEE7}'] + function AddCustomScheme(const schemeName: ustring; IsStandard, IsLocal, + IsDisplayIsolated: Boolean): Boolean; stdcall; + end; + + ICefRenderProcessHandler = interface(IcefBase) + ['{FADEE3BC-BF66-430A-BA5D-1EE3782ECC58}'] + procedure OnRenderThreadCreated(const extraInfo: ICefListValue) ; + procedure OnWebKitInitialized; + procedure OnBrowserCreated(const browser: ICefBrowser); + procedure OnBrowserDestroyed(const browser: ICefBrowser); + function GetLoadHandler: ICefLoadHandler; + procedure OnContextCreated(const browser: ICefBrowser; + const frame: ICefFrame; const context: ICefv8Context); + procedure OnContextReleased(const browser: ICefBrowser; + const frame: ICefFrame; const context: ICefv8Context); + procedure OnUncaughtException(const browser: ICefBrowser; const frame: ICefFrame; + const context: ICefv8Context; const exception: ICefV8Exception; + const stackTrace: ICefV8StackTrace); + procedure OnFocusedNodeChanged(const browser: ICefBrowser; + const frame: ICefFrame; const node: ICefDomNode); + function OnProcessMessageReceived(const browser: ICefBrowser; + sourceProcess: TCefProcessId; const message: ICefProcessMessage): Boolean; + end; + + TOnRegisterCustomSchemes = {$IFDEF DELPHI12_UP}reference to{$ENDIF} procedure(const registrar: ICefSchemeRegistrar); + TOnBeforeCommandLineProcessing = {$IFDEF DELPHI12_UP}reference to{$ENDIF} procedure(const processType: ustring; const commandLine: ICefCommandLine); + + ICefApp = interface(ICefBase) + ['{970CA670-9070-4642-B188-7D8A22DAEED4}'] + procedure OnBeforeCommandLineProcessing(const processType: ustring; + const commandLine: ICefCommandLine); + procedure OnRegisterCustomSchemes(const registrar: ICefSchemeRegistrar); + function GetResourceBundleHandler: ICefResourceBundleHandler; + function GetBrowserProcessHandler: ICefBrowserProcessHandler; + function GetRenderProcessHandler: ICefRenderProcessHandler; + end; + + TCefCookieVisitorProc = {$IFDEF DELPHI12_UP} reference to {$ENDIF} function( + const name, value, domain, path: ustring; secure, httponly, + hasExpires: Boolean; const creation, lastAccess, expires: TDateTime; + count, total: Integer; out deleteCookie: Boolean): Boolean; + + ICefCompletionHandler = interface(ICefBase) + ['{A8ECCFBB-FEE0-446F-AB32-AD69A7478D57}'] + procedure OnComplete; + end; + + TCefCompletionHandlerProc = {$IFDEF DELPHI12_UP} reference to {$ENDIF} procedure; + + ICefCookieManager = Interface(ICefBase) + ['{CC1749E6-9AD3-4283-8430-AF6CBF3E8785}'] + procedure SetSupportedSchemes(schemes: TStrings); + function VisitAllCookies(const visitor: ICefCookieVisitor): Boolean; + function VisitUrlCookies(const url: ustring; + includeHttpOnly: Boolean; const visitor: ICefCookieVisitor): Boolean; + function SetCookie(const url: ustring; const name, value, domain, path: ustring; secure, httponly, + hasExpires: Boolean; const creation, lastAccess, expires: TDateTime): Boolean; + function DeleteCookies(const url, cookieName: ustring): Boolean; + function SetStoragePath(const path: ustring; persistSessionCookies: Boolean): Boolean; + function FlushStore(const handler: ICefCompletionHandler): Boolean; + function FlushStoreProc(const proc: TCefCompletionHandlerProc): Boolean; + end; + + ICefCookieManager2 = interface(ICefCookieManager) + ['{D8DCAFA7-F515-432E-BDE5-6329CB4451B7}'] + function VisitAllCookiesProc(const visitor: TCefCookieVisitorProc): Boolean; + function VisitUrlCookiesProc(const url: ustring; + includeHttpOnly: Boolean; const visitor: TCefCookieVisitorProc): Boolean; + end; + + ICefWebPluginInfo = interface(ICefBase) + ['{AA879E58-F649-44B1-AF9C-655FF5B79A02}'] + function GetName: ustring; + function GetPath: ustring; + function GetVersion: ustring; + function GetDescription: ustring; + + property Name: ustring read GetName; + property Path: ustring read GetPath; + property Version: ustring read GetVersion; + property Description: ustring read GetDescription; + end; + + ICefCallback = interface(ICefBase) + ['{1B8C449F-E2D6-4B78-9BBA-6F47E8BCDF37}'] + procedure Cont; + procedure Cancel; + end; + + ICefResourceHandler = interface(ICefBase) + ['{BD3EA208-AAAD-488C-BFF2-76993022F2B5}'] + function ProcessRequest(const request: ICefRequest; const callback: ICefCallback): Boolean; + procedure GetResponseHeaders(const response: ICefResponse; + out responseLength: Int64; out redirectUrl: ustring); + function ReadResponse(const dataOut: Pointer; bytesToRead: Integer; + var bytesRead: Integer; const callback: ICefCallback): Boolean; + function CanGetCookie(const cookie: PCefCookie): Boolean; + function CanSetCookie(const cookie: PCefCookie): Boolean; + procedure Cancel; + end; + + ICefSchemeHandlerFactory = interface(ICefBase) + ['{4D9B7960-B73B-4EBD-9ABE-6C1C43C245EB}'] + function New(const browser: ICefBrowser; const frame: ICefFrame; + const schemeName: ustring; const request: ICefRequest): ICefResourceHandler; + end; + + ICefAuthCallback = interface(ICefBase) + ['{500C2023-BF4D-4FF7-9C04-165E5C389131}'] + procedure Cont(const username, password: ustring); + procedure Cancel; + end; + + ICefJsDialogCallback = interface(ICefBase) + ['{187B2156-9947-4108-87AB-32E559E1B026}'] + procedure Cont(success: Boolean; const userInput: ustring); + end; + + ICefContextMenuParams = interface(ICefBase) + ['{E31BFA9E-D4E2-49B7-A05D-20018C8794EB}'] + function GetXCoord: Integer; + function GetYCoord: Integer; + function GetTypeFlags: TCefContextMenuTypeFlags; + function GetLinkUrl: ustring; + function GetUnfilteredLinkUrl: ustring; + function GetSourceUrl: ustring; + function HasImageContents: Boolean; + function GetPageUrl: ustring; + function GetFrameUrl: ustring; + function GetFrameCharset: ustring; + function GetMediaType: TCefContextMenuMediaType; + function GetMediaStateFlags: TCefContextMenuMediaStateFlags; + function GetSelectionText: ustring; + function IsEditable: Boolean; + function IsSpeechInputEnabled: Boolean; + function GetEditStateFlags: TCefContextMenuEditStateFlags; + property XCoord: Integer read GetXCoord; + property YCoord: Integer read GetYCoord; + property TypeFlags: TCefContextMenuTypeFlags read GetTypeFlags; + property LinkUrl: ustring read GetLinkUrl; + property UnfilteredLinkUrl: ustring read GetUnfilteredLinkUrl; + property SourceUrl: ustring read GetSourceUrl; + property PageUrl: ustring read GetPageUrl; + property FrameUrl: ustring read GetFrameUrl; + property FrameCharset: ustring read GetFrameCharset; + property MediaType: TCefContextMenuMediaType read GetMediaType; + property MediaStateFlags: TCefContextMenuMediaStateFlags read GetMediaStateFlags; + property SelectionText: ustring read GetSelectionText; + property EditStateFlags: TCefContextMenuEditStateFlags read GetEditStateFlags; + end; + + ICefMenuModel = interface(ICefBase) + ['{40AF19D3-8B4E-44B8-8F89-DEB5907FC495}'] + function Clear: Boolean; + function GetCount: Integer; + function AddSeparator: Boolean; + function AddItem(commandId: Integer; const text: ustring): Boolean; + function AddCheckItem(commandId: Integer; const text: ustring): Boolean; + function AddRadioItem(commandId: Integer; const text: ustring; groupId: Integer): Boolean; + function AddSubMenu(commandId: Integer; const text: ustring): ICefMenuModel; + function InsertSeparatorAt(index: Integer): Boolean; + function InsertItemAt(index, commandId: Integer; const text: ustring): Boolean; + function InsertCheckItemAt(index, commandId: Integer; const text: ustring): Boolean; + function InsertRadioItemAt(index, commandId: Integer; const text: ustring; groupId: Integer): Boolean; + function InsertSubMenuAt(index, commandId: Integer; const text: ustring): ICefMenuModel; + function Remove(commandId: Integer): Boolean; + function RemoveAt(index: Integer): Boolean; + function GetIndexOf(commandId: Integer): Integer; + function GetCommandIdAt(index: Integer): Integer; + function SetCommandIdAt(index, commandId: Integer): Boolean; + function GetLabel(commandId: Integer): ustring; + function GetLabelAt(index: Integer): ustring; + function SetLabel(commandId: Integer; const text: ustring): Boolean; + function SetLabelAt(index: Integer; const text: ustring): Boolean; + function GetType(commandId: Integer): TCefMenuItemType; + function GetTypeAt(index: Integer): TCefMenuItemType; + function GetGroupId(commandId: Integer): Integer; + function GetGroupIdAt(index: Integer): Integer; + function SetGroupId(commandId, groupId: Integer): Boolean; + function SetGroupIdAt(index, groupId: Integer): Boolean; + function GetSubMenu(commandId: Integer): ICefMenuModel; + function GetSubMenuAt(index: Integer): ICefMenuModel; + function IsVisible(commandId: Integer): Boolean; + function isVisibleAt(index: Integer): Boolean; + function SetVisible(commandId: Integer; visible: Boolean): Boolean; + function SetVisibleAt(index: Integer; visible: Boolean): Boolean; + function IsEnabled(commandId: Integer): Boolean; + function IsEnabledAt(index: Integer): Boolean; + function SetEnabled(commandId: Integer; enabled: Boolean): Boolean; + function SetEnabledAt(index: Integer; enabled: Boolean): Boolean; + function IsChecked(commandId: Integer): Boolean; + function IsCheckedAt(index: Integer): Boolean; + function setChecked(commandId: Integer; checked: Boolean): Boolean; + function setCheckedAt(index: Integer; checked: Boolean): Boolean; + function HasAccelerator(commandId: Integer): Boolean; + function HasAcceleratorAt(index: Integer): Boolean; + function SetAccelerator(commandId, keyCode: Integer; shiftPressed, ctrlPressed, altPressed: Boolean): Boolean; + function SetAcceleratorAt(index, keyCode: Integer; shiftPressed, ctrlPressed, altPressed: Boolean): Boolean; + function RemoveAccelerator(commandId: Integer): Boolean; + function RemoveAcceleratorAt(index: Integer): Boolean; + function GetAccelerator(commandId: Integer; out keyCode: Integer; out shiftPressed, ctrlPressed, altPressed: Boolean): Boolean; + function GetAcceleratorAt(index: Integer; out keyCode: Integer; out shiftPressed, ctrlPressed, altPressed: Boolean): Boolean; + end; + + ICefBinaryValue = interface(ICefBase) + ['{974AA40A-9C5C-4726-81F0-9F0D46D7C5B3}'] + function IsValid: Boolean; + function IsOwned: Boolean; + function Copy: ICefBinaryValue; + function GetSize: NativeUInt; + function GetData(buffer: Pointer; bufferSize, dataOffset: NativeUInt): NativeUInt; + end; + + ICefDictionaryValue = interface(ICefBase) + ['{B9638559-54DC-498C-8185-233EEF12BC69}'] + function IsValid: Boolean; + function isOwned: Boolean; + function IsReadOnly: Boolean; + function Copy(excludeEmptyChildren: Boolean): ICefDictionaryValue; + function GetSize: NativeUInt; + function Clear: Boolean; + function HasKey(const key: ustring): Boolean; + function GetKeys(const keys: TStrings): Boolean; + function Remove(const key: ustring): Boolean; + function GetType(const key: ustring): TCefValueType; + function GetBool(const key: ustring): Boolean; + function GetInt(const key: ustring): Integer; + function GetDouble(const key: ustring): Double; + function GetString(const key: ustring): ustring; + function GetBinary(const key: ustring): ICefBinaryValue; + function GetDictionary(const key: ustring): ICefDictionaryValue; + function GetList(const key: ustring): ICefListValue; + function SetNull(const key: ustring): Boolean; + function SetBool(const key: ustring; value: Boolean): Boolean; + function SetInt(const key: ustring; value: Integer): Boolean; + function SetDouble(const key: ustring; value: Double): Boolean; + function SetString(const key, value: ustring): Boolean; + function SetBinary(const key: ustring; const value: ICefBinaryValue): Boolean; + function SetDictionary(const key: ustring; const value: ICefDictionaryValue): Boolean; + function SetList(const key: ustring; const value: ICefListValue): Boolean; + end; + + ICefListValue = interface(ICefBase) + ['{09174B9D-0CC6-4360-BBB0-3CC0117F70F6}'] + function IsValid: Boolean; + function IsOwned: Boolean; + function IsReadOnly: Boolean; + function Copy: ICefListValue; + function SetSize(size: NativeUInt): Boolean; + function GetSize: NativeUInt; + function Clear: Boolean; + function Remove(index: Integer): Boolean; + function GetType(index: Integer): TCefValueType; + function GetBool(index: Integer): Boolean; + function GetInt(index: Integer): Integer; + function GetDouble(index: Integer): Double; + function GetString(index: Integer): ustring; + function GetBinary(index: Integer): ICefBinaryValue; + function GetDictionary(index: Integer): ICefDictionaryValue; + function GetList(index: Integer): ICefListValue; + function SetNull(index: Integer): Boolean; + function SetBool(index: Integer; value: Boolean): Boolean; + function SetInt(index, value: Integer): Boolean; + function SetDouble(index: Integer; value: Double): Boolean; + function SetString(index: Integer; const value: ustring): Boolean; + function SetBinary(index: Integer; const value: ICefBinaryValue): Boolean; + function SetDictionary(index: Integer; const value: ICefDictionaryValue): Boolean; + function SetList(index: Integer; const value: ICefListValue): Boolean; + end; + + ICefLifeSpanHandler = interface(ICefBase) + ['{0A3EB782-A319-4C35-9B46-09B2834D7169}'] + function OnBeforePopup(const browser: ICefBrowser; const frame: ICefFrame; + const targetUrl, targetFrameName: ustring; var popupFeatures: TCefPopupFeatures; + var windowInfo: TCefWindowInfo; var client: ICefClient; var settings: TCefBrowserSettings; + var noJavascriptAccess: Boolean): Boolean; + procedure OnAfterCreated(const browser: ICefBrowser); + procedure OnBeforeClose(const browser: ICefBrowser); + function RunModal(const browser: ICefBrowser): Boolean; + function DoClose(const browser: ICefBrowser): Boolean; + end; + + ICefLoadHandler = interface(ICefBase) + ['{2C63FB82-345D-4A5B-9858-5AE7A85C9F49}'] + procedure OnLoadingStateChange(const browser: ICefBrowser; isLoading, + canGoBack, canGoForward: Boolean); + procedure OnLoadStart(const browser: ICefBrowser; const frame: ICefFrame); + procedure OnLoadEnd(const browser: ICefBrowser; const frame: ICefFrame; httpStatusCode: Integer); + procedure OnLoadError(const browser: ICefBrowser; const frame: ICefFrame; errorCode: Integer; + const errorText, failedUrl: ustring); + end; + + ICefQuotaCallback = interface(ICefBase) + ['{F163D612-CC9C-49CC-ADEA-FB6A32A25485}'] + procedure Cont(allow: Boolean); + procedure Cancel; + end; + + ICefAllowCertificateErrorCallback = interface(ICefBase) + ['{A28E92D1-CF5A-4703-9C2F-C97D88174489}'] + procedure Cont(allow: Boolean); + end; + + ICefRequestHandler = interface(ICefBase) + ['{050877A9-D1F8-4EB3-B58E-50DC3E3D39FD}'] + function OnBeforeBrowse(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest; isRedirect: Boolean): Boolean; + function OnBeforeResourceLoad(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest): Boolean; + function GetResourceHandler(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest): ICefResourceHandler; + procedure OnResourceRedirect(const browser: ICefBrowser; const frame: ICefFrame; + const oldUrl: ustring; var newUrl: ustring); + function GetAuthCredentials(const browser: ICefBrowser; const frame: ICefFrame; + isProxy: Boolean; const host: ustring; port: Integer; const realm, scheme: ustring; + const callback: ICefAuthCallback): Boolean; + function OnQuotaRequest(const browser: ICefBrowser; + const originUrl: ustring; newSize: Int64; const callback: ICefQuotaCallback): Boolean; + procedure OnProtocolExecution(const browser: ICefBrowser; const url: ustring; out allowOsExecution: Boolean); + function OnBeforePluginLoad(const browser: ICefBrowser; const url, policyUrl: ustring; + const info: ICefWebPluginInfo): Boolean; + function OnCertificateError(certError: TCefErrorCode; const requestUrl: ustring; + const callback: ICefAllowCertificateErrorCallback): Boolean; + end; + + ICefDisplayHandler = interface(ICefBase) + ['{1EC7C76D-6969-41D1-B26D-079BCFF054C4}'] + procedure OnAddressChange(const browser: ICefBrowser; const frame: ICefFrame; const url: ustring); + procedure OnTitleChange(const browser: ICefBrowser; const title: ustring); + function OnTooltip(const browser: ICefBrowser; var text: ustring): Boolean; + procedure OnStatusMessage(const browser: ICefBrowser; const value: ustring); + function OnConsoleMessage(const browser: ICefBrowser; const message, source: ustring; line: Integer): Boolean; + end; + + ICefFocusHandler = interface(ICefBase) + ['{BB7FA3FA-7B1A-4ADC-8E50-12A24018DD90}'] + procedure OnTakeFocus(const browser: ICefBrowser; next: Boolean); + function OnSetFocus(const browser: ICefBrowser; source: TCefFocusSource): Boolean; + procedure OnGotFocus(const browser: ICefBrowser); + end; + + ICefKeyboardHandler = interface(ICefBase) + ['{0512F4EC-ED88-44C9-90D3-5C6D03D3B146}'] + function OnPreKeyEvent(const browser: ICefBrowser; const event: PCefKeyEvent; + osEvent: TCefEventHandle; out isKeyboardShortcut: Boolean): Boolean; + function OnKeyEvent(const browser: ICefBrowser; const event: PCefKeyEvent; + osEvent: TCefEventHandle): Boolean; + end; + + ICefJsDialogHandler = interface(ICefBase) + ['{64E18F86-DAC5-4ED1-8589-44DE45B9DB56}'] + function OnJsdialog(const browser: ICefBrowser; const originUrl, acceptLang: ustring; + dialogType: TCefJsDialogType; const messageText, defaultPromptText: ustring; + callback: ICefJsDialogCallback; out suppressMessage: Boolean): Boolean; + function OnBeforeUnloadDialog(const browser: ICefBrowser; + const messageText: ustring; isReload: Boolean; + const callback: ICefJsDialogCallback): Boolean; + procedure OnResetDialogState(const browser: ICefBrowser); + procedure OnDialogClosed(const browser: ICefBrowser); + end; + + ICefContextMenuHandler = interface(ICefBase) + ['{C2951895-4087-49D5-BA18-4D9BA4F5EDD7}'] + procedure OnBeforeContextMenu(const browser: ICefBrowser; const frame: ICefFrame; + const params: ICefContextMenuParams; const model: ICefMenuModel); + function OnContextMenuCommand(const browser: ICefBrowser; const frame: ICefFrame; + const params: ICefContextMenuParams; commandId: Integer; + eventFlags: TCefEventFlags): Boolean; + procedure OnContextMenuDismissed(const browser: ICefBrowser; const frame: ICefFrame); + end; + + ICefDialogHandler = interface(ICefBase) + ['{7763F4B2-8BE1-4E80-AC43-8B825850DC67}'] + function OnFileDialog(const browser: ICefBrowser; mode: TCefFileDialogMode; + const title, defaultFileName: ustring; acceptTypes: TStrings; + const callback: ICefFileDialogCallback): Boolean; + end; + + ICefGeolocationCallback = interface(ICefBase) + ['{272B8E4F-4AE4-4F14-BC4E-5924FA0C149D}'] + procedure Cont(allow: Boolean); + end; + + ICefGeolocationHandler = interface(ICefBase) + ['{1178EE62-BAE7-4E44-932B-EAAC7A18191C}'] + procedure OnRequestGeolocationPermission(const browser: ICefBrowser; + const requestingUrl: ustring; requestId: Integer; const callback: ICefGeolocationCallback); + procedure OnCancelGeolocationPermission(const browser: ICefBrowser; + const requestingUrl: ustring; requestId: Integer); + end; + + ICefRenderHandler = interface(ICefBase) + ['{1FC1C22B-085A-4741-9366-5249B88EC410}'] + function GetRootScreenRect(const browser: ICefBrowser; rect: PCefRect): Boolean; + function GetViewRect(const browser: ICefBrowser; rect: PCefRect): Boolean; + function GetScreenPoint(const browser: ICefBrowser; viewX, viewY: Integer; + screenX, screenY: PInteger): Boolean; + function GetScreenInfo(const browser: ICefBrowser; screenInfo: PCefScreenInfo): Boolean; + procedure OnPopupShow(const browser: ICefBrowser; show: Boolean); + procedure OnPopupSize(const browser: ICefBrowser; const rect: PCefRect); + procedure OnPaint(const browser: ICefBrowser; kind: TCefPaintElementType; + dirtyRectsCount: NativeUInt; const dirtyRects: PCefRectArray; + const buffer: Pointer; width, height: Integer); + procedure OnCursorChange(const browser: ICefBrowser; cursor: TCefCursorHandle); + procedure OnScrollOffsetChanged(const browser: ICefBrowser); + end; + + ICefClient = interface(ICefBase) + ['{1D502075-2FF0-4E13-A112-9E541CD811F4}'] + function GetContextMenuHandler: ICefContextMenuHandler; + function GetDisplayHandler: ICefDisplayHandler; + function GetDownloadHandler: ICefDownloadHandler; + function GetFocusHandler: ICefFocusHandler; + function GetGeolocationHandler: ICefGeolocationHandler; + function GetJsdialogHandler: ICefJsdialogHandler; + function GetKeyboardHandler: ICefKeyboardHandler; + function GetLifeSpanHandler: ICefLifeSpanHandler; + function GetLoadHandler: ICefLoadHandler; + function GetRenderHandler: ICefRenderHandler; + function GetRequestHandler: ICefRequestHandler; + function OnProcessMessageReceived(const browser: ICefBrowser; + sourceProcess: TCefProcessId; const message: ICefProcessMessage): Boolean; + end; + + ICefUrlRequest = interface(ICefBase) + ['{59226AC1-A0FA-4D59-9DF4-A65C42391A67}'] + function GetRequest: ICefRequest; + function GetRequestStatus: TCefUrlRequestStatus; + function GetRequestError: Integer; + function GetResponse: ICefResponse; + procedure Cancel; + end; + + ICefUrlrequestClient = interface(ICefBase) + ['{114155BD-C248-4651-9A4F-26F3F9A4F737}'] + procedure OnRequestComplete(const request: ICefUrlRequest); + procedure OnUploadProgress(const request: ICefUrlRequest; current, total: UInt64); + procedure OnDownloadProgress(const request: ICefUrlRequest; current, total: UInt64); + procedure OnDownloadData(const request: ICefUrlRequest; data: Pointer; dataLength: NativeUInt); + function GetAuthCredentials(isProxy: Boolean; const host: ustring; port: Integer; + const realm, scheme: ustring; const callback: ICefAuthCallback): Boolean; + end; + + ICefWebPluginInfoVisitor = interface(ICefBase) + ['{7523D432-4424-4804-ACAD-E67D2313436E}'] + function Visit(const info: ICefWebPluginInfo; count, total: Integer): Boolean; + end; + + ICefWebPluginUnstableCallback = interface(ICefBase) + ['{67459829-EB47-4B7E-9D69-2EE77DF0E71E}'] + procedure IsUnstable(const path: ustring; unstable: Boolean); + end; + + ICefTraceClient = interface(ICefBase) + ['{B6995953-A56A-46AC-B3D1-D644AEC480A5}'] + procedure OnTraceDataCollected(const fragment: PAnsiChar; fragmentSize: NativeUInt); + procedure OnTraceBufferPercentFullReply(percentFull: Single); + procedure OnEndTracingComplete; + end; + + ICefGetGeolocationCallback = interface(ICefBase) + ['{ACB82FD9-3FFD-43F9-BF1A-A4849BF5B814}'] + procedure OnLocationUpdate(const position: PCefGeoposition); + end; + + ICefFileDialogCallback = interface(ICefBase) + ['{1AF659AB-4522-4E39-9C52-184000D8E3C7}'] + procedure Cont(filePaths: TStrings); + procedure Cancel; + end; + + ICefDragData = interface(ICefBase) + ['{FBB6A487-F633-4055-AB3E-6619EDE75683}'] + function IsLink: Boolean; + function IsFragment: Boolean; + function IsFile: Boolean; + function GetLinkUrl: ustring; + function GetLinkTitle: ustring; + function GetLinkMetadata: ustring; + function GetFragmentText: ustring; + function GetFragmentHtml: ustring; + function GetFragmentBaseUrl: ustring; + function GetFileName: ustring; + function GetFileNames(names: TStrings): Integer; + end; + + ICefDragHandler = interface(ICefBase) + ['{59A89579-5B18-489F-A25C-5CC25FF831FC}'] + function OnDragEnter(const browser: ICefBrowser; const dragData: ICefDragData; + mask: TCefDragOperations): Boolean; + end; + + ICefRequestContextHandler = interface(ICefBase) + ['{1C27B796-CA2E-4FA8-BA25-C5F68FFD3A41}'] + function GetCookieManager: ICefCookieManager; + end; + + ICefRequestContext = interface(ICefBase) + ['{A9305CE5-BD71-4A46-9345-EF2CC2B57AE3}'] + function IsSame(const other: ICefRequestContext): Boolean; + function IsGlobal: Boolean; + function GetHandler: ICefBase; + end; + + ///////////////////////////////////////// + + TCefBaseOwn = class(TInterfacedObject, ICefBase) + private + FData: Pointer; + public + function Wrap: Pointer; + constructor CreateData(size: Cardinal; owned: Boolean = False); virtual; + destructor Destroy; override; + end; + + TCefBaseRef = class(TInterfacedObject, ICefBase) + private + FData: Pointer; + public + constructor Create(data: Pointer); virtual; + destructor Destroy; override; + function Wrap: Pointer; + class function UnWrap(data: Pointer): ICefBase; + end; + + TCefRunFileDialogCallbackOwn = class(TCefBaseOwn, ICefRunFileDialogCallback) + protected + procedure Cont(const browserHost: ICefBrowserHost; filePaths: TStrings); virtual; + public + constructor Create; + end; + + TCefFastRunFileDialogCallback = class(TCefRunFileDialogCallbackOwn) + private + FCallback: TCefRunFileDialogCallbackProc; + protected + procedure Cont(const browserHost: ICefBrowserHost; filePaths: TStrings); override; + public + constructor Create(callback: TCefRunFileDialogCallbackProc); reintroduce; virtual; + end; + + TCefBrowserHostRef = class(TCefBaseRef, ICefBrowserHost) + protected + function GetBrowser: ICefBrowser; + procedure ParentWindowWillClose; + procedure CloseBrowser(forceClose: Boolean); + procedure SetFocus(enable: Boolean); + function GetWindowHandle: TCefWindowHandle; + function GetOpenerWindowHandle: TCefWindowHandle; + function GetRequestContext: ICefRequestContext; + function GetDevToolsUrl(httpScheme: Boolean): ustring; + function GetZoomLevel: Double; + procedure SetZoomLevel(zoomLevel: Double); + procedure RunFileDialog(mode: TCefFileDialogMode; const title, defaultFileName: ustring; + acceptTypes: TStrings; const callback: ICefRunFileDialogCallback); + procedure RunFileDialogProc(mode: TCefFileDialogMode; const title, defaultFileName: ustring; + acceptTypes: TStrings; const callback: TCefRunFileDialogCallbackProc); + procedure Print; + procedure Find(identifier: Integer; const searchText: ustring; forward, matchCase, findNext: Boolean); + procedure StopFinding(clearSelection: Boolean); + procedure StartDownload(const url: ustring); + procedure SetMouseCursorChangeDisabled(disabled: Boolean); + function IsMouseCursorChangeDisabled: Boolean; + function IsWindowRenderingDisabled: Boolean; + procedure WasResized; + procedure NotifyScreenInfoChanged; + procedure WasHidden(hidden: Boolean); + procedure Invalidate(const dirtyRect: PCefRect; kind: TCefPaintElementType); + procedure SendKeyEvent(const event: PCefKeyEvent); + procedure SendMouseClickEvent(const event: PCefMouseEvent; + kind: TCefMouseButtonType; mouseUp: Boolean; clickCount: Integer); + procedure SendMouseMoveEvent(const event: PCefMouseEvent; mouseLeave: Boolean); + procedure SendMouseWheelEvent(const event: PCefMouseEvent; deltaX, deltaY: Integer); + procedure SendFocusEvent(setFocus: Boolean); + procedure SendCaptureLostEvent; + function GetNsTextInputContext: TCefTextInputContext; + procedure HandleKeyEventBeforeTextInputClient(keyEvent: TCefEventHandle); + procedure HandleKeyEventAfterTextInputClient(keyEvent: TCefEventHandle); + public + class function UnWrap(data: Pointer): ICefBrowserHost; + end; + + TCefBrowserRef = class(TCefBaseRef, ICefBrowser) + protected + function GetHost: ICefBrowserHost; + function CanGoBack: Boolean; + procedure GoBack; + function CanGoForward: Boolean; + procedure GoForward; + function IsLoading: Boolean; + procedure Reload; + procedure ReloadIgnoreCache; + procedure StopLoad; + function GetIdentifier: Integer; + function IsSame(const that: ICefBrowser): Boolean; + function IsPopup: Boolean; + function HasDocument: Boolean; + function GetMainFrame: ICefFrame; + function GetFocusedFrame: ICefFrame; + function GetFrameByident(identifier: Int64): ICefFrame; + function GetFrame(const name: ustring): ICefFrame; + function GetFrameCount: NativeUInt; + procedure GetFrameIdentifiers(count: PNativeUInt; identifiers: PInt64); + procedure GetFrameNames(names: TStrings); + function SendProcessMessage(targetProcess: TCefProcessId; + message: ICefProcessMessage): Boolean; + public + class function UnWrap(data: Pointer): ICefBrowser; + end; + + TCefFrameRef = class(TCefBaseRef, ICefFrame) + protected + function IsValid: Boolean; + procedure Undo; + procedure Redo; + procedure Cut; + procedure Copy; + procedure Paste; + procedure Del; + procedure SelectAll; + procedure ViewSource; + procedure GetSource(const visitor: ICefStringVisitor); + procedure GetSourceProc(const proc: TCefStringVisitorProc); + procedure GetText(const visitor: ICefStringVisitor); + procedure GetTextProc(const proc: TCefStringVisitorProc); + procedure LoadRequest(const request: ICefRequest); + procedure LoadUrl(const url: ustring); + procedure LoadString(const str, url: ustring); + procedure ExecuteJavaScript(const code, scriptUrl: ustring; startLine: Integer); + function IsMain: Boolean; + function IsFocused: Boolean; + function GetName: ustring; + function GetIdentifier: Int64; + function GetParent: ICefFrame; + function GetUrl: ustring; + function GetBrowser: ICefBrowser; + function GetV8Context: ICefv8Context; + procedure VisitDom(const visitor: ICefDomVisitor); + procedure VisitDomProc(const proc: TCefDomVisitorProc); + public + class function UnWrap(data: Pointer): ICefFrame; + end; + + TCefPostDataRef = class(TCefBaseRef, ICefPostData) + protected + function IsReadOnly: Boolean; + function GetCount: NativeUInt; + function GetElements(Count: NativeUInt): IInterfaceList; // ICefPostDataElement + function RemoveElement(const element: ICefPostDataElement): Integer; + function AddElement(const element: ICefPostDataElement): Integer; + procedure RemoveElements; + public + class function UnWrap(data: Pointer): ICefPostData; + class function New: ICefPostData; + end; + + TCefPostDataElementRef = class(TCefBaseRef, ICefPostDataElement) + protected + function IsReadOnly: Boolean; + procedure SetToEmpty; + procedure SetToFile(const fileName: ustring); + procedure SetToBytes(size: NativeUInt; bytes: Pointer); + function GetType: TCefPostDataElementType; + function GetFile: ustring; + function GetBytesCount: NativeUInt; + function GetBytes(size: NativeUInt; bytes: Pointer): NativeUInt; + public + class function UnWrap(data: Pointer): ICefPostDataElement; + class function New: ICefPostDataElement; + end; + + TCefRequestRef = class(TCefBaseRef, ICefRequest) + protected + function IsReadOnly: Boolean; + function GetUrl: ustring; + function GetMethod: ustring; + function GetPostData: ICefPostData; + procedure GetHeaderMap(const HeaderMap: ICefStringMultimap); + procedure SetUrl(const value: ustring); + procedure SetMethod(const value: ustring); + procedure SetPostData(const value: ICefPostData); + procedure SetHeaderMap(const HeaderMap: ICefStringMultimap); + function GetFlags: TCefUrlRequestFlags; + procedure SetFlags(flags: TCefUrlRequestFlags); + function GetFirstPartyForCookies: ustring; + procedure SetFirstPartyForCookies(const url: ustring); + function GetResourceType: TCefResourceType; + function GetTransitionType: TCefTransitionType; + procedure Assign(const url, method: ustring; + const postData: ICefPostData; const headerMap: ICefStringMultimap); + public + class function UnWrap(data: Pointer): ICefRequest; + class function New: ICefRequest; + end; + + TCefStreamReaderRef = class(TCefBaseRef, ICefStreamReader) + protected + function Read(ptr: Pointer; size, n: NativeUInt): NativeUInt; + function Seek(offset: Int64; whence: Integer): Integer; + function Tell: Int64; + function Eof: Boolean; + public + class function UnWrap(data: Pointer): ICefStreamReader; + class function CreateForFile(const filename: ustring): ICefStreamReader; + class function CreateForCustomStream(const stream: ICefCustomStreamReader): ICefStreamReader; + class function CreateForStream(const stream: TSTream; owned: Boolean): ICefStreamReader; + class function CreateForData(data: Pointer; size: NativeUInt): ICefStreamReader; + end; + + + TCefV8AccessorGetterProc = {$IFDEF DELPHI12_UP} reference to{$ENDIF} function( + const name: ustring; const obj: ICefv8Value; out value: ICefv8Value; const exception: ustring): Boolean; + + TCefV8AccessorSetterProc = {$IFDEF DELPHI12_UP}reference to {$ENDIF} function( + const name: ustring; const obj, value: ICefv8Value; const exception: ustring): Boolean; + + TCefv8ValueRef = class(TCefBaseRef, ICefv8Value) + protected + function IsValid: Boolean; + function IsUndefined: Boolean; + function IsNull: Boolean; + function IsBool: Boolean; + function IsInt: Boolean; + function IsUInt: Boolean; + function IsDouble: Boolean; + function IsDate: Boolean; + function IsString: Boolean; + function IsObject: Boolean; + function IsArray: Boolean; + function IsFunction: Boolean; + function IsSame(const that: ICefv8Value): Boolean; + function GetBoolValue: Boolean; + function GetIntValue: Integer; + function GetUIntValue: Cardinal; + function GetDoubleValue: Double; + function GetDateValue: TDateTime; + function GetStringValue: ustring; + function IsUserCreated: Boolean; + function HasException: Boolean; + function GetException: ICefV8Exception; + function ClearException: Boolean; + function WillRethrowExceptions: Boolean; + function SetRethrowExceptions(rethrow: Boolean): Boolean; + function HasValueByKey(const key: ustring): Boolean; + function HasValueByIndex(index: Integer): Boolean; + function DeleteValueByKey(const key: ustring): Boolean; + function DeleteValueByIndex(index: Integer): Boolean; + function GetValueByKey(const key: ustring): ICefv8Value; + function GetValueByIndex(index: Integer): ICefv8Value; + function SetValueByKey(const key: ustring; const value: ICefv8Value; + attribute: TCefV8PropertyAttributes): Boolean; + function SetValueByIndex(index: Integer; const value: ICefv8Value): Boolean; + function SetValueByAccessor(const key: ustring; settings: TCefV8AccessControls; + attribute: TCefV8PropertyAttributes): Boolean; + function GetKeys(const keys: TStrings): Integer; + function SetUserData(const data: ICefv8Value): Boolean; + function GetUserData: ICefv8Value; + function GetExternallyAllocatedMemory: Integer; + function AdjustExternallyAllocatedMemory(changeInBytes: Integer): Integer; + function GetArrayLength: Integer; + function GetFunctionName: ustring; + function GetFunctionHandler: ICefv8Handler; + function ExecuteFunction(const obj: ICefv8Value; + const arguments: TCefv8ValueArray): ICefv8Value; + function ExecuteFunctionWithContext(const context: ICefv8Context; + const obj: ICefv8Value; const arguments: TCefv8ValueArray): ICefv8Value; + public + class function UnWrap(data: Pointer): ICefv8Value; + class function NewUndefined: ICefv8Value; + class function NewNull: ICefv8Value; + class function NewBool(value: Boolean): ICefv8Value; + class function NewInt(value: Integer): ICefv8Value; + class function NewUInt(value: Cardinal): ICefv8Value; + class function NewDouble(value: Double): ICefv8Value; + class function NewDate(value: TDateTime): ICefv8Value; + class function NewString(const str: ustring): ICefv8Value; + class function NewObject(const Accessor: ICefV8Accessor): ICefv8Value; + class function NewObjectProc(const getter: TCefV8AccessorGetterProc; + const setter: TCefV8AccessorSetterProc): ICefv8Value; + class function NewArray(len: Integer): ICefv8Value; + class function NewFunction(const name: ustring; const handler: ICefv8Handler): ICefv8Value; + end; + + TCefv8ContextRef = class(TCefBaseRef, ICefv8Context) + protected + function GetTaskRunner: ICefTaskRunner; + function IsValid: Boolean; + function GetBrowser: ICefBrowser; + function GetFrame: ICefFrame; + function GetGlobal: ICefv8Value; + function Enter: Boolean; + function Exit: Boolean; + function IsSame(const that: ICefv8Context): Boolean; + function Eval(const code: ustring; var retval: ICefv8Value; var exception: ICefV8Exception): Boolean; + public + class function UnWrap(data: Pointer): ICefv8Context; + class function Current: ICefv8Context; + class function Entered: ICefv8Context; + end; + + TCefV8StackFrameRef = class(TCefBaseRef, ICefV8StackFrame) + protected + function IsValid: Boolean; + function GetScriptName: ustring; + function GetScriptNameOrSourceUrl: ustring; + function GetFunctionName: ustring; + function GetLineNumber: Integer; + function GetColumn: Integer; + function IsEval: Boolean; + function IsConstructor: Boolean; + public + class function UnWrap(data: Pointer): ICefV8StackFrame; + end; + + TCefV8StackTraceRef = class(TCefBaseRef, ICefV8StackTrace) + protected + function IsValid: Boolean; + function GetFrameCount: Integer; + function GetFrame(index: Integer): ICefV8StackFrame; + public + class function UnWrap(data: Pointer): ICefV8StackTrace; + class function Current(frameLimit: Integer): ICefV8StackTrace; + end; + + TCefv8HandlerRef = class(TCefBaseRef, ICefv8Handler) + protected + function Execute(const name: ustring; const obj: ICefv8Value; + const arguments: TCefv8ValueArray; var retval: ICefv8Value; + var exception: ustring): Boolean; + public + class function UnWrap(data: Pointer): ICefv8Handler; + end; + + TCefClientOwn = class(TCefBaseOwn, ICefClient) + protected + function GetContextMenuHandler: ICefContextMenuHandler; virtual; + function GetDialogHandler: ICefDialogHandler; virtual; + function GetDisplayHandler: ICefDisplayHandler; virtual; + function GetDownloadHandler: ICefDownloadHandler; virtual; + function GetDragHandler: ICefDragHandler; virtual; + function GetFocusHandler: ICefFocusHandler; virtual; + function GetGeolocationHandler: ICefGeolocationHandler; virtual; + function GetJsdialogHandler: ICefJsdialogHandler; virtual; + function GetKeyboardHandler: ICefKeyboardHandler; virtual; + function GetLifeSpanHandler: ICefLifeSpanHandler; virtual; + function GetRenderHandler: ICefRenderHandler; virtual; + function GetLoadHandler: ICefLoadHandler; virtual; + function GetRequestHandler: ICefRequestHandler; virtual; + function OnProcessMessageReceived(const browser: ICefBrowser; + sourceProcess: TCefProcessId; const message: ICefProcessMessage): Boolean; virtual; + public + constructor Create; virtual; + end; + + TCefGeolocationHandlerOwn = class(TCefBaseOwn, ICefGeolocationHandler) + protected + procedure OnRequestGeolocationPermission(const browser: ICefBrowser; + const requestingUrl: ustring; requestId: Integer; + const callback: ICefGeolocationCallback); virtual; + procedure OnCancelGeolocationPermission(const browser: ICefBrowser; + const requestingUrl: ustring; requestId: Integer); virtual; + public + constructor Create; virtual; + end; + + TCefLifeSpanHandlerOwn = class(TCefBaseOwn, ICefLifeSpanHandler) + protected + function OnBeforePopup(const browser: ICefBrowser; const frame: ICefFrame; + const targetUrl, targetFrameName: ustring; var popupFeatures: TCefPopupFeatures; + var windowInfo: TCefWindowInfo; var client: ICefClient; var settings: TCefBrowserSettings; + var noJavascriptAccess: Boolean): Boolean; virtual; + procedure OnAfterCreated(const browser: ICefBrowser); virtual; + procedure OnBeforeClose(const browser: ICefBrowser); virtual; + function RunModal(const browser: ICefBrowser): Boolean; virtual; + function DoClose(const browser: ICefBrowser): Boolean; virtual; + public + constructor Create; virtual; + end; + + TCefLoadHandlerOwn = class(TCefBaseOwn, ICefLoadHandler) + protected + procedure OnLoadingStateChange(const browser: ICefBrowser; isLoading, + canGoBack, canGoForward: Boolean); virtual; + procedure OnLoadStart(const browser: ICefBrowser; const frame: ICefFrame); virtual; + procedure OnLoadEnd(const browser: ICefBrowser; const frame: ICefFrame; httpStatusCode: Integer); virtual; + procedure OnLoadError(const browser: ICefBrowser; const frame: ICefFrame; errorCode: Integer; + const errorText, failedUrl: ustring); virtual; + public + constructor Create; virtual; + end; + + TCefQuotaCallbackRef = class(TCefBaseRef, ICefQuotaCallback) + protected + procedure Cont(allow: Boolean); + procedure Cancel; + public + class function UnWrap(data: Pointer): ICefQuotaCallback; + end; + + TCefAllowCertificateErrorCallbackRef = class(TCefBaseRef, ICefAllowCertificateErrorCallback) + protected + procedure Cont(allow: Boolean); + public + class function UnWrap(data: Pointer): ICefAllowCertificateErrorCallback; + end; + + TCefRequestHandlerOwn = class(TCefBaseOwn, ICefRequestHandler) + protected + function OnBeforeBrowse(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest; isRedirect: Boolean): Boolean; virtual; + function OnBeforeResourceLoad(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest): Boolean; virtual; + function GetResourceHandler(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest): ICefResourceHandler; virtual; + procedure OnResourceRedirect(const browser: ICefBrowser; const frame: ICefFrame; + const oldUrl: ustring; var newUrl: ustring); virtual; + function GetAuthCredentials(const browser: ICefBrowser; const frame: ICefFrame; + isProxy: Boolean; const host: ustring; port: Integer; const realm, scheme: ustring; + const callback: ICefAuthCallback): Boolean; virtual; + function OnQuotaRequest(const browser: ICefBrowser; const originUrl: ustring; + newSize: Int64; const callback: ICefQuotaCallback): Boolean; virtual; + procedure OnProtocolExecution(const browser: ICefBrowser; const url: ustring; out allowOsExecution: Boolean); virtual; + function OnBeforePluginLoad(const browser: ICefBrowser; const url, policyUrl: ustring; + const info: ICefWebPluginInfo): Boolean; virtual; + function OnCertificateError(certError: TCefErrorCode; const requestUrl: ustring; + const callback: ICefAllowCertificateErrorCallback): Boolean; virtual; + procedure OnPluginCrashed(const browser: ICefBrowser; const pluginPath: ustring); virtual; + procedure OnRenderProcessTerminated(const browser: ICefBrowser; status: TCefTerminationStatus); virtual; + public + constructor Create; virtual; + end; + + TCefDisplayHandlerOwn = class(TCefBaseOwn, ICefDisplayHandler) + protected + procedure OnAddressChange(const browser: ICefBrowser; const frame: ICefFrame; const url: ustring); virtual; + procedure OnTitleChange(const browser: ICefBrowser; const title: ustring); virtual; + function OnTooltip(const browser: ICefBrowser; var text: ustring): Boolean; virtual; + procedure OnStatusMessage(const browser: ICefBrowser; const value: ustring); virtual; + function OnConsoleMessage(const browser: ICefBrowser; const message, source: ustring; line: Integer): Boolean; virtual; + public + constructor Create; virtual; + end; + + TCefFocusHandlerOwn = class(TCefBaseOwn, ICefFocusHandler) + protected + procedure OnTakeFocus(const browser: ICefBrowser; next: Boolean); virtual; + function OnSetFocus(const browser: ICefBrowser; source: TCefFocusSource): Boolean; virtual; + procedure OnGotFocus(const browser: ICefBrowser); virtual; + public + constructor Create; virtual; + end; + + TCefKeyboardHandlerOwn = class(TCefBaseOwn, ICefKeyboardHandler) + protected + function OnPreKeyEvent(const browser: ICefBrowser; const event: PCefKeyEvent; + osEvent: TCefEventHandle; out isKeyboardShortcut: Boolean): Boolean; virtual; + function OnKeyEvent(const browser: ICefBrowser; const event: PCefKeyEvent; + osEvent: TCefEventHandle): Boolean; virtual; + public + constructor Create; virtual; + end; + + TCefJsDialogHandlerOwn = class(TCefBaseOwn, ICefJsDialogHandler) + protected + function OnJsdialog(const browser: ICefBrowser; const originUrl, acceptLang: ustring; + dialogType: TCefJsDialogType; const messageText, defaultPromptText: ustring; + callback: ICefJsDialogCallback; out suppressMessage: Boolean): Boolean; virtual; + function OnBeforeUnloadDialog(const browser: ICefBrowser; + const messageText: ustring; isReload: Boolean; + const callback: ICefJsDialogCallback): Boolean; virtual; + procedure OnResetDialogState(const browser: ICefBrowser); virtual; + procedure OnDialogClosed(const browser: ICefBrowser); virtual; + public + constructor Create; virtual; + end; + + TCefContextMenuHandlerOwn = class(TCefBaseOwn, ICefContextMenuHandler) + protected + procedure OnBeforeContextMenu(const browser: ICefBrowser; const frame: ICefFrame; + const params: ICefContextMenuParams; const model: ICefMenuModel); virtual; + function OnContextMenuCommand(const browser: ICefBrowser; const frame: ICefFrame; + const params: ICefContextMenuParams; commandId: Integer; + eventFlags: TCefEventFlags): Boolean; virtual; + procedure OnContextMenuDismissed(const browser: ICefBrowser; const frame: ICefFrame); virtual; + public + constructor Create; virtual; + end; + + TCefDialogHandlerOwn = class(TCefBaseOwn, ICefDialogHandler) + protected + function OnFileDialog(const browser: ICefBrowser; mode: TCefFileDialogMode; + const title, defaultFileName: ustring; acceptTypes: TStrings; + const callback: ICefFileDialogCallback): Boolean; virtual; + public + constructor Create; virtual; + end; + + TCefDownloadHandlerOwn = class(TCefBaseOwn, ICefDownloadHandler) + protected + procedure OnBeforeDownload(const browser: ICefBrowser; const downloadItem: ICefDownloadItem; + const suggestedName: ustring; const callback: ICefBeforeDownloadCallback); virtual; + procedure OnDownloadUpdated(const browser: ICefBrowser; const downloadItem: ICefDownloadItem; + const callback: ICefDownloadItemCallback); virtual; + public + constructor Create; virtual; + end; + + TCefCustomStreamReader = class(TCefBaseOwn, ICefCustomStreamReader) + private + FStream: TStream; + FOwned: Boolean; + protected + function Read(ptr: Pointer; size, n: NativeUInt): NativeUInt; virtual; + function Seek(offset: Int64; whence: Integer): Integer; virtual; + function Tell: Int64; virtual; + function Eof: Boolean; virtual; + public + constructor Create(Stream: TStream; Owned: Boolean); overload; virtual; + constructor Create(const filename: string); overload; virtual; + destructor Destroy; override; + end; + + TCefPostDataElementOwn = class(TCefBaseOwn, ICefPostDataElement) + private + FDataType: TCefPostDataElementType; + FValueByte: Pointer; + FValueStr: TCefString; + FSize: NativeUInt; + FReadOnly: Boolean; + procedure Clear; + protected + function IsReadOnly: Boolean; virtual; + procedure SetToEmpty; virtual; + procedure SetToFile(const fileName: ustring); virtual; + procedure SetToBytes(size: NativeUInt; bytes: Pointer); virtual; + function GetType: TCefPostDataElementType; virtual; + function GetFile: ustring; virtual; + function GetBytesCount: NativeUInt; virtual; + function GetBytes(size: NativeUInt; bytes: Pointer): NativeUInt; virtual; + public + constructor Create(readonly: Boolean); virtual; + end; + + TCefCallbackRef = class(TCefBaseRef, ICefCallback) + protected + procedure Cont; + procedure Cancel; + public + class function UnWrap(data: Pointer): ICefCallback; + end; + + TCefCompletionHandlerOwn = class(TCefBaseOwn, ICefCompletionHandler) + protected + procedure OnComplete; virtual; + public + constructor Create; virtual; + end; + + TCefCompletionHandlerRef = class(TCefBaseRef, ICefCompletionHandler) + protected + procedure OnComplete; + public + class function UnWrap(data: Pointer): ICefCompletionHandler; + end; + + TCefFastCompletionHandler = class(TCefCompletionHandlerOwn) + private + FProc: TCefCompletionHandlerProc; + protected + procedure OnComplete; override; + public + constructor Create(const proc: TCefCompletionHandlerProc); reintroduce; + end; + + TCefResourceHandlerOwn = class(TCefBaseOwn, ICefResourceHandler) + protected + function ProcessRequest(const request: ICefRequest; const callback: ICefCallback): Boolean; virtual; + procedure GetResponseHeaders(const response: ICefResponse; + out responseLength: Int64; out redirectUrl: ustring); virtual; + function ReadResponse(const dataOut: Pointer; bytesToRead: Integer; + var bytesRead: Integer; const callback: ICefCallback): Boolean; virtual; + function CanGetCookie(const cookie: PCefCookie): Boolean; virtual; + function CanSetCookie(const cookie: PCefCookie): Boolean; virtual; + procedure Cancel; virtual; + public + constructor Create(const browser: ICefBrowser; const frame: ICefFrame; + const schemeName: ustring; const request: ICefRequest); virtual; + end; + TCefResourceHandlerClass = class of TCefResourceHandlerOwn; + + TCefSchemeHandlerFactoryOwn = class(TCefBaseOwn, ICefSchemeHandlerFactory) + private + FClass: TCefResourceHandlerClass; + protected + function New(const browser: ICefBrowser; const frame: ICefFrame; + const schemeName: ustring; const request: ICefRequest): ICefResourceHandler; virtual; + public + constructor Create(const AClass: TCefResourceHandlerClass; SyncMainThread: Boolean); virtual; + end; + + TCefv8HandlerOwn = class(TCefBaseOwn, ICefv8Handler) + protected + function Execute(const name: ustring; const obj: ICefv8Value; + const arguments: TCefv8ValueArray; var retval: ICefv8Value; + var exception: ustring): Boolean; virtual; + public + constructor Create; virtual; + end; + + TCefTaskOwn = class(TCefBaseOwn, ICefTask) + protected + procedure Execute; virtual; + public + constructor Create; virtual; + end; + + TCefTaskRef = class(TCefBaseRef, ICefTask) + protected + procedure Execute; virtual; + public + class function UnWrap(data: Pointer): ICefTask; + end; + + TCefTaskRunnerRef = class(TCefBaseRef, ICefTaskRunner) + protected + function IsSame(const that: ICefTaskRunner): Boolean; + function BelongsToCurrentThread: Boolean; + function BelongsToThread(threadId: TCefThreadId): Boolean; + function PostTask(const task: ICefTask): Boolean; stdcall; + function PostDelayedTask(const task: ICefTask; delayMs: Int64): Boolean; + public + class function UnWrap(data: Pointer): ICefTaskRunner; + class function GetForCurrentThread: ICefTaskRunner; + class function GetForThread(threadId: TCefThreadId): ICefTaskRunner; + end; + + TCefStringMapOwn = class(TInterfacedObject, ICefStringMap) + private + FStringMap: TCefStringMap; + protected + function GetHandle: TCefStringMap; virtual; + function GetSize: Integer; virtual; + function Find(const key: ustring): ustring; virtual; + function GetKey(index: Integer): ustring; virtual; + function GetValue(index: Integer): ustring; virtual; + procedure Append(const key, value: ustring); virtual; + procedure Clear; virtual; + public + constructor Create; virtual; + destructor Destroy; override; + end; + + TCefStringMultimapOwn = class(TInterfacedObject, ICefStringMultimap) + private + FStringMap: TCefStringMultimap; + protected + function GetHandle: TCefStringMultimap; virtual; + function GetSize: Integer; virtual; + function FindCount(const Key: ustring): Integer; virtual; + function GetEnumerate(const Key: ustring; ValueIndex: Integer): ustring; virtual; + function GetKey(Index: Integer): ustring; virtual; + function GetValue(Index: Integer): ustring; virtual; + procedure Append(const Key, Value: ustring); virtual; + procedure Clear; virtual; + public + constructor Create; virtual; + destructor Destroy; override; + end; + + TCefXmlReaderRef = class(TCefBaseRef, ICefXmlReader) + protected + function MoveToNextNode: Boolean; + function Close: Boolean; + function HasError: Boolean; + function GetError: ustring; + function GetType: TCefXmlNodeType; + function GetDepth: Integer; + function GetLocalName: ustring; + function GetPrefix: ustring; + function GetQualifiedName: ustring; + function GetNamespaceUri: ustring; + function GetBaseUri: ustring; + function GetXmlLang: ustring; + function IsEmptyElement: Boolean; + function HasValue: Boolean; + function GetValue: ustring; + function HasAttributes: Boolean; + function GetAttributeCount: NativeUInt; + function GetAttributeByIndex(index: Integer): ustring; + function GetAttributeByQName(const qualifiedName: ustring): ustring; + function GetAttributeByLName(const localName, namespaceURI: ustring): ustring; + function GetInnerXml: ustring; + function GetOuterXml: ustring; + function GetLineNumber: Integer; + function MoveToAttributeByIndex(index: Integer): Boolean; + function MoveToAttributeByQName(const qualifiedName: ustring): Boolean; + function MoveToAttributeByLName(const localName, namespaceURI: ustring): Boolean; + function MoveToFirstAttribute: Boolean; + function MoveToNextAttribute: Boolean; + function MoveToCarryingElement: Boolean; + public + class function UnWrap(data: Pointer): ICefXmlReader; + class function New(const stream: ICefStreamReader; + encodingType: TCefXmlEncodingType; const URI: ustring): ICefXmlReader; + end; + + TCefZipReaderRef = class(TCefBaseRef, ICefZipReader) + protected + function MoveToFirstFile: Boolean; + function MoveToNextFile: Boolean; + function MoveToFile(const fileName: ustring; caseSensitive: Boolean): Boolean; + function Close: Boolean; + function GetFileName: ustring; + function GetFileSize: Int64; + function GetFileLastModified: LongInt; + function OpenFile(const password: ustring): Boolean; + function CloseFile: Boolean; + function ReadFile(buffer: Pointer; bufferSize: NativeUInt): Integer; + function Tell: Int64; + function Eof: Boolean; + public + class function UnWrap(data: Pointer): ICefZipReader; + class function New(const stream: ICefStreamReader): ICefZipReader; + end; + + TCefDomVisitorOwn = class(TCefBaseOwn, ICefDomVisitor) + protected + procedure visit(const document: ICefDomDocument); virtual; + public + constructor Create; virtual; + end; + + TCefFastDomVisitor = class(TCefDomVisitorOwn) + private + FProc: TCefDomVisitorProc; + protected + procedure visit(const document: ICefDomDocument); override; + public + constructor Create(const proc: TCefDomVisitorProc); reintroduce; virtual; + end; + + TCefDomDocumentRef = class(TCefBaseRef, ICefDomDocument) + protected + function GetType: TCefDomDocumentType; + function GetDocument: ICefDomNode; + function GetBody: ICefDomNode; + function GetHead: ICefDomNode; + function GetTitle: ustring; + function GetElementById(const id: ustring): ICefDomNode; + function GetFocusedNode: ICefDomNode; + function HasSelection: Boolean; + function GetSelectionStartNode: ICefDomNode; + function GetSelectionStartOffset: Integer; + function GetSelectionEndNode: ICefDomNode; + function GetSelectionEndOffset: Integer; + function GetSelectionAsMarkup: ustring; + function GetSelectionAsText: ustring; + function GetBaseUrl: ustring; + function GetCompleteUrl(const partialURL: ustring): ustring; + public + class function UnWrap(data: Pointer): ICefDomDocument; + end; + + TCefDomNodeRef = class(TCefBaseRef, ICefDomNode) + protected + function GetType: TCefDomNodeType; + function IsText: Boolean; + function IsElement: Boolean; + function IsEditable: Boolean; + function IsFormControlElement: Boolean; + function GetFormControlElementType: ustring; + function IsSame(const that: ICefDomNode): Boolean; + function GetName: ustring; + function GetValue: ustring; + function SetValue(const value: ustring): Boolean; + function GetAsMarkup: ustring; + function GetDocument: ICefDomDocument; + function GetParent: ICefDomNode; + function GetPreviousSibling: ICefDomNode; + function GetNextSibling: ICefDomNode; + function HasChildren: Boolean; + function GetFirstChild: ICefDomNode; + function GetLastChild: ICefDomNode; + procedure AddEventListener(const eventType: ustring; + useCapture: Boolean; const listener: ICefDomEventListener); + procedure AddEventListenerProc(const eventType: ustring; useCapture: Boolean; + const proc: TCefDomEventListenerProc); + function GetElementTagName: ustring; + function HasElementAttributes: Boolean; + function HasElementAttribute(const attrName: ustring): Boolean; + function GetElementAttribute(const attrName: ustring): ustring; + procedure GetElementAttributes(const attrMap: ICefStringMap); + function SetElementAttribute(const attrName, value: ustring): Boolean; + function GetElementInnerText: ustring; + public + class function UnWrap(data: Pointer): ICefDomNode; + end; + + TCefDomEventRef = class(TCefBaseRef, ICefDomEvent) + protected + function GetType: ustring; + function GetCategory: TCefDomEventCategory; + function GetPhase: TCefDomEventPhase; + function CanBubble: Boolean; + function CanCancel: Boolean; + function GetDocument: ICefDomDocument; + function GetTarget: ICefDomNode; + function GetCurrentTarget: ICefDomNode; + public + class function UnWrap(data: Pointer): ICefDomEvent; + end; + + TCefDomEventListenerOwn = class(TCefBaseOwn, ICefDomEventListener) + protected + procedure HandleEvent(const event: ICefDomEvent); virtual; + public + constructor Create; virtual; + end; + + TCefResponseRef = class(TCefBaseRef, ICefResponse) + protected + function IsReadOnly: Boolean; + function GetStatus: Integer; + procedure SetStatus(status: Integer); + function GetStatusText: ustring; + procedure SetStatusText(const StatusText: ustring); + function GetMimeType: ustring; + procedure SetMimeType(const mimetype: ustring); + function GetHeader(const name: ustring): ustring; + procedure GetHeaderMap(const headerMap: ICefStringMultimap); + procedure SetHeaderMap(const headerMap: ICefStringMultimap); + public + class function UnWrap(data: Pointer): ICefResponse; + class function New: ICefResponse; + end; + + TCefFastDomEventListener = class(TCefDomEventListenerOwn) + private + FProc: TCefDomEventListenerProc; + protected + procedure HandleEvent(const event: ICefDomEvent); override; + public + constructor Create(const proc: TCefDomEventListenerProc); reintroduce; virtual; + end; + + TCefFastTaskProc = {$IFDEF DELPHI12_UP}reference to{$ENDIF} procedure; + + TCefFastTask = class(TCefTaskOwn) + private + FMethod: TCefFastTaskProc; + protected + procedure Execute; override; + public + class procedure New(threadId: TCefThreadId; const method: TCefFastTaskProc); + class procedure NewDelayed(threadId: TCefThreadId; Delay: Int64; const method: TCefFastTaskProc); + constructor Create(const method: TCefFastTaskProc); reintroduce; + end; + +{$IFDEF DELPHI14_UP} + TCefRTTIExtension = class(TCefv8HandlerOwn) + private + FValue: TValue; + FCtx: TRttiContext; +{$IFDEF CEF_MULTI_THREADED_MESSAGE_LOOP} + FSyncMainThread: Boolean; +{$ENDIF} + function GetValue(pi: PTypeInfo; const v: ICefv8Value; var ret: TValue): Boolean; + function SetValue(const v: TValue; var ret: ICefv8Value): Boolean; +{$IFDEF CPUX64} + class function StrToPtr(const str: ustring): Pointer; + class function PtrToStr(p: Pointer): ustring; +{$ENDIF} + protected + function Execute(const name: ustring; const obj: ICefv8Value; + const arguments: TCefv8ValueArray; var retval: ICefv8Value; + var exception: ustring): Boolean; override; + public + constructor Create(const value: TValue +{$IFDEF CEF_MULTI_THREADED_MESSAGE_LOOP} + ; SyncMainThread: Boolean +{$ENDIF} +); reintroduce; + destructor Destroy; override; + class procedure Register(const name: string; const value: TValue + {$IFDEF CEF_MULTI_THREADED_MESSAGE_LOOP}; SyncMainThread: Boolean{$ENDIF}); + end; +{$ENDIF} + + TCefV8AccessorOwn = class(TCefBaseOwn, ICefV8Accessor) + protected + function Get(const name: ustring; const obj: ICefv8Value; + out value: ICefv8Value; const exception: ustring): Boolean; virtual; + function Put(const name: ustring; const obj, value: ICefv8Value; + const exception: ustring): Boolean; virtual; + public + constructor Create; virtual; + end; + + TCefFastV8Accessor = class(TCefV8AccessorOwn) + private + FGetter: TCefV8AccessorGetterProc; + FSetter: TCefV8AccessorSetterProc; + protected + function Get(const name: ustring; const obj: ICefv8Value; + out value: ICefv8Value; const exception: ustring): Boolean; override; + function Put(const name: ustring; const obj, value: ICefv8Value; + const exception: ustring): Boolean; override; + public + constructor Create(const getter: TCefV8AccessorGetterProc; + const setter: TCefV8AccessorSetterProc); reintroduce; + end; + + TCefCookieVisitorOwn = class(TCefBaseOwn, ICefCookieVisitor) + protected + function visit(const name, value, domain, path: ustring; secure, httponly, + hasExpires: Boolean; const creation, lastAccess, expires: TDateTime; + count, total: Integer; out deleteCookie: Boolean): Boolean; virtual; + public + constructor Create; virtual; + end; + + TCefFastCookieVisitor = class(TCefCookieVisitorOwn) + private + FVisitor: TCefCookieVisitorProc; + protected + function visit(const name, value, domain, path: ustring; secure, httponly, + hasExpires: Boolean; const creation, lastAccess, expires: TDateTime; + count, total: Integer; out deleteCookie: Boolean): Boolean; override; + public + constructor Create(const visitor: TCefCookieVisitorProc); reintroduce; + end; + + TCefV8ExceptionRef = class(TCefBaseRef, ICefV8Exception) + protected + function GetMessage: ustring; + function GetSourceLine: ustring; + function GetScriptResourceName: ustring; + function GetLineNumber: Integer; + function GetStartPosition: Integer; + function GetEndPosition: Integer; + function GetStartColumn: Integer; + function GetEndColumn: Integer; + public + class function UnWrap(data: Pointer): ICefV8Exception; + end; + + TCefResourceBundleHandlerOwn = class(TCefBaseOwn, ICefResourceBundleHandler) + protected + function GetDataResource(resourceId: Integer; out data: Pointer; + out dataSize: NativeUInt): Boolean; virtual; abstract; + function GetLocalizedString(messageId: Integer; + out stringVal: ustring): Boolean; virtual; abstract; + public + constructor Create; virtual; + end; + + + TGetDataResource = {$IFDEF DELPHI12_UP}reference to{$ENDIF}function( + resourceId: Integer; out data: Pointer; out dataSize: NativeUInt): Boolean; + + TGetLocalizedString = {$IFDEF DELPHI12_UP}reference to{$ENDIF}function( + messageId: Integer; out stringVal: ustring): Boolean; + + TCefFastResourceBundle = class(TCefResourceBundleHandlerOwn) + private + FGetDataResource: TGetDataResource; + FGetLocalizedString: TGetLocalizedString; + protected + function GetDataResource(resourceId: Integer; out data: Pointer; + out dataSize: NativeUInt): Boolean; override; + function GetLocalizedString(messageId: Integer; + out stringVal: ustring): Boolean; override; + public + constructor Create(AGetDataResource: TGetDataResource; + AGetLocalizedString: TGetLocalizedString); reintroduce; + end; + + TCefAppOwn = class(TCefBaseOwn, ICefApp) + protected + procedure OnBeforeCommandLineProcessing(const processType: ustring; + const commandLine: ICefCommandLine); virtual; abstract; + procedure OnRegisterCustomSchemes(const registrar: ICefSchemeRegistrar); virtual; abstract; + function GetResourceBundleHandler: ICefResourceBundleHandler; virtual; abstract; + function GetBrowserProcessHandler: ICefBrowserProcessHandler; virtual; abstract; + function GetRenderProcessHandler: ICefRenderProcessHandler; virtual; abstract; + public + constructor Create; virtual; + end; + + TCefCookieManagerRef = class(TCefBaseRef, ICefCookieManager2) + protected + procedure SetSupportedSchemes(schemes: TStrings); + function VisitAllCookies(const visitor: ICefCookieVisitor): Boolean; + function VisitAllCookiesProc(const visitor: TCefCookieVisitorProc): Boolean; + function VisitUrlCookies(const url: ustring; + includeHttpOnly: Boolean; const visitor: ICefCookieVisitor): Boolean; + function VisitUrlCookiesProc(const url: ustring; + includeHttpOnly: Boolean; const visitor: TCefCookieVisitorProc): Boolean; + function SetCookie(const url: ustring; const name, value, domain, path: ustring; secure, httponly, + hasExpires: Boolean; const creation, lastAccess, expires: TDateTime): Boolean; + function DeleteCookies(const url, cookieName: ustring): Boolean; + function SetStoragePath(const path: ustring; persistSessionCookies: Boolean): Boolean; + function FlushStore(const handler: ICefCompletionHandler): Boolean; + function FlushStoreProc(const proc: TCefCompletionHandlerProc): Boolean; + public + class function UnWrap(data: Pointer): ICefCookieManager2; + class function Global: ICefCookieManager2; + class function New(const path: ustring; persistSessionCookies: Boolean): ICefCookieManager2; + end; + + TCefCookieManagerOwn = class(TCefBaseOwn, ICefCookieManager) + protected + procedure SetSupportedSchemes(schemes: TStrings); virtual; + function VisitAllCookies(const visitor: ICefCookieVisitor): Boolean; virtual; + function VisitUrlCookies(const url: ustring; + includeHttpOnly: Boolean; const visitor: ICefCookieVisitor): Boolean; virtual; + function SetCookie(const url: ustring; const name, value, domain, path: ustring; secure, httponly, + hasExpires: Boolean; const creation, lastAccess, expires: TDateTime): Boolean; virtual; + function DeleteCookies(const url, cookieName: ustring): Boolean; virtual; + function SetStoragePath(const path: ustring; persistSessionCookies: Boolean): Boolean; virtual; + function FlushStore(const handler: ICefCompletionHandler): Boolean; virtual; + function FlushStoreProc(const proc: TCefCompletionHandlerProc): Boolean; virtual; + public + constructor Create; virtual; + end; + + TCefWebPluginInfoRef = class(TCefBaseRef, ICefWebPluginInfo) + protected + function GetName: ustring; + function GetPath: ustring; + function GetVersion: ustring; + function GetDescription: ustring; + public + class function UnWrap(data: Pointer): ICefWebPluginInfo; + end; + + TCefProcessMessageRef = class(TCefBaseRef, ICefProcessMessage) + protected + function IsValid: Boolean; + function IsReadOnly: Boolean; + function Copy: ICefProcessMessage; + function GetName: ustring; + function GetArgumentList: ICefListValue; + public + class function UnWrap(data: Pointer): ICefProcessMessage; + class function New(const name: ustring): ICefProcessMessage; + end; + + TCefStringVisitorOwn = class(TCefBaseOwn, ICefStringVisitor) + protected + procedure Visit(const str: ustring); virtual; + public + constructor Create; virtual; + end; + + TCefFastStringVisitor = class(TCefStringVisitorOwn, ICefStringVisitor) + private + FVisit: TCefStringVisitorProc; + protected + procedure Visit(const str: ustring); override; + public + constructor Create(const callback: TCefStringVisitorProc); reintroduce; + end; + + TCefDownLoadItemRef = class(TCefBaseRef, ICefDownLoadItem) + protected + function IsValid: Boolean; + function IsInProgress: Boolean; + function IsComplete: Boolean; + function IsCanceled: Boolean; + function GetCurrentSpeed: Int64; + function GetPercentComplete: Integer; + function GetTotalBytes: Int64; + function GetReceivedBytes: Int64; + function GetStartTime: TDateTime; + function GetEndTime: TDateTime; + function GetFullPath: ustring; + function GetId: Integer; + function GetUrl: ustring; + function GetSuggestedFileName: ustring; + function GetContentDisposition: ustring; + function GetMimeType: ustring; + public + class function UnWrap(data: Pointer): ICefDownLoadItem; + end; + + TCefBeforeDownloadCallbackRef = class(TCefBaseRef, ICefBeforeDownloadCallback) + protected + procedure Cont(const downloadPath: ustring; showDialog: Boolean); + public + class function UnWrap(data: Pointer): ICefBeforeDownloadCallback; + end; + + TCefDownloadItemCallbackRef = class(TCefBaseRef, ICefDownloadItemCallback) + protected + procedure cancel; + public + class function UnWrap(data: Pointer): ICefDownloadItemCallback; + end; + + TCefAuthCallbackRef = class(TCefBaseRef, ICefAuthCallback) + protected + procedure Cont(const username, password: ustring); + procedure Cancel; + public + class function UnWrap(data: Pointer): ICefAuthCallback; + end; + + TCefJsDialogCallbackRef = class(TCefBaseRef, ICefJsDialogCallback) + protected + procedure Cont(success: Boolean; const userInput: ustring); + public + class function UnWrap(data: Pointer): ICefJsDialogCallback; + end; + + TCefCommandLineRef = class(TCefBaseRef, ICefCommandLine) + protected + function IsValid: Boolean; + function IsReadOnly: Boolean; + function Copy: ICefCommandLine; + procedure InitFromArgv(argc: Integer; const argv: PPAnsiChar); + procedure InitFromString(const commandLine: ustring); + procedure Reset; + function GetCommandLineString: ustring; + procedure GetArgv(args: TStrings); + function GetProgram: ustring; + procedure SetProgram(const prog: ustring); + function HasSwitches: Boolean; + function HasSwitch(const name: ustring): Boolean; + function GetSwitchValue(const name: ustring): ustring; + procedure GetSwitches(switches: TStrings); + procedure AppendSwitch(const name: ustring); + procedure AppendSwitchWithValue(const name, value: ustring); + function HasArguments: Boolean; + procedure GetArguments(arguments: TStrings); + procedure AppendArgument(const argument: ustring); + procedure PrependWrapper(const wrapper: ustring); + public + class function UnWrap(data: Pointer): ICefCommandLine; + class function New: ICefCommandLine; + class function Global: ICefCommandLine; + end; + + TCefSchemeRegistrarRef = class(TCefBaseRef, ICefSchemeRegistrar) + protected + function AddCustomScheme(const schemeName: ustring; IsStandard, IsLocal, + IsDisplayIsolated: Boolean): Boolean; stdcall; + public + class function UnWrap(data: Pointer): ICefSchemeRegistrar; + end; + + TCefGeolocationCallbackRef = class(TCefBaseRef, ICefGeolocationCallback) + protected + procedure Cont(allow: Boolean); + public + class function UnWrap(data: Pointer): ICefGeolocationCallback; + end; + + TCefContextMenuParamsRef = class(TCefBaseRef, ICefContextMenuParams) + protected + function GetXCoord: Integer; + function GetYCoord: Integer; + function GetTypeFlags: TCefContextMenuTypeFlags; + function GetLinkUrl: ustring; + function GetUnfilteredLinkUrl: ustring; + function GetSourceUrl: ustring; + function HasImageContents: Boolean; + function GetPageUrl: ustring; + function GetFrameUrl: ustring; + function GetFrameCharset: ustring; + function GetMediaType: TCefContextMenuMediaType; + function GetMediaStateFlags: TCefContextMenuMediaStateFlags; + function GetSelectionText: ustring; + function IsEditable: Boolean; + function IsSpeechInputEnabled: Boolean; + function GetEditStateFlags: TCefContextMenuEditStateFlags; + public + class function UnWrap(data: Pointer): ICefContextMenuParams; + end; + + TCefMenuModelRef = class(TCefBaseRef, ICefMenuModel) + protected + function Clear: Boolean; + function GetCount: Integer; + function AddSeparator: Boolean; + function AddItem(commandId: Integer; const text: ustring): Boolean; + function AddCheckItem(commandId: Integer; const text: ustring): Boolean; + function AddRadioItem(commandId: Integer; const text: ustring; groupId: Integer): Boolean; + function AddSubMenu(commandId: Integer; const text: ustring): ICefMenuModel; + function InsertSeparatorAt(index: Integer): Boolean; + function InsertItemAt(index, commandId: Integer; const text: ustring): Boolean; + function InsertCheckItemAt(index, commandId: Integer; const text: ustring): Boolean; + function InsertRadioItemAt(index, commandId: Integer; const text: ustring; groupId: Integer): Boolean; + function InsertSubMenuAt(index, commandId: Integer; const text: ustring): ICefMenuModel; + function Remove(commandId: Integer): Boolean; + function RemoveAt(index: Integer): Boolean; + function GetIndexOf(commandId: Integer): Integer; + function GetCommandIdAt(index: Integer): Integer; + function SetCommandIdAt(index, commandId: Integer): Boolean; + function GetLabel(commandId: Integer): ustring; + function GetLabelAt(index: Integer): ustring; + function SetLabel(commandId: Integer; const text: ustring): Boolean; + function SetLabelAt(index: Integer; const text: ustring): Boolean; + function GetType(commandId: Integer): TCefMenuItemType; + function GetTypeAt(index: Integer): TCefMenuItemType; + function GetGroupId(commandId: Integer): Integer; + function GetGroupIdAt(index: Integer): Integer; + function SetGroupId(commandId, groupId: Integer): Boolean; + function SetGroupIdAt(index, groupId: Integer): Boolean; + function GetSubMenu(commandId: Integer): ICefMenuModel; + function GetSubMenuAt(index: Integer): ICefMenuModel; + function IsVisible(commandId: Integer): Boolean; + function isVisibleAt(index: Integer): Boolean; + function SetVisible(commandId: Integer; visible: Boolean): Boolean; + function SetVisibleAt(index: Integer; visible: Boolean): Boolean; + function IsEnabled(commandId: Integer): Boolean; + function IsEnabledAt(index: Integer): Boolean; + function SetEnabled(commandId: Integer; enabled: Boolean): Boolean; + function SetEnabledAt(index: Integer; enabled: Boolean): Boolean; + function IsChecked(commandId: Integer): Boolean; + function IsCheckedAt(index: Integer): Boolean; + function setChecked(commandId: Integer; checked: Boolean): Boolean; + function setCheckedAt(index: Integer; checked: Boolean): Boolean; + function HasAccelerator(commandId: Integer): Boolean; + function HasAcceleratorAt(index: Integer): Boolean; + function SetAccelerator(commandId, keyCode: Integer; shiftPressed, ctrlPressed, altPressed: Boolean): Boolean; + function SetAcceleratorAt(index, keyCode: Integer; shiftPressed, ctrlPressed, altPressed: Boolean): Boolean; + function RemoveAccelerator(commandId: Integer): Boolean; + function RemoveAcceleratorAt(index: Integer): Boolean; + function GetAccelerator(commandId: Integer; out keyCode: Integer; out shiftPressed, ctrlPressed, altPressed: Boolean): Boolean; + function GetAcceleratorAt(index: Integer; out keyCode: Integer; out shiftPressed, ctrlPressed, altPressed: Boolean): Boolean; + public + class function UnWrap(data: Pointer): ICefMenuModel; + end; + + TCefListValueRef = class(TCefBaseRef, ICefListValue) + protected + function IsValid: Boolean; + function IsOwned: Boolean; + function IsReadOnly: Boolean; + function Copy: ICefListValue; + function SetSize(size: NativeUInt): Boolean; + function GetSize: NativeUInt; + function Clear: Boolean; + function Remove(index: Integer): Boolean; + function GetType(index: Integer): TCefValueType; + function GetBool(index: Integer): Boolean; + function GetInt(index: Integer): Integer; + function GetDouble(index: Integer): Double; + function GetString(index: Integer): ustring; + function GetBinary(index: Integer): ICefBinaryValue; + function GetDictionary(index: Integer): ICefDictionaryValue; + function GetList(index: Integer): ICefListValue; + function SetNull(index: Integer): Boolean; + function SetBool(index: Integer; value: Boolean): Boolean; + function SetInt(index, value: Integer): Boolean; + function SetDouble(index: Integer; value: Double): Boolean; + function SetString(index: Integer; const value: ustring): Boolean; + function SetBinary(index: Integer; const value: ICefBinaryValue): Boolean; + function SetDictionary(index: Integer; const value: ICefDictionaryValue): Boolean; + function SetList(index: Integer; const value: ICefListValue): Boolean; + public + class function UnWrap(data: Pointer): ICefListValue; + class function New: ICefListValue; + end; + + TCefBinaryValueRef = class(TCefBaseRef, ICefBinaryValue) + protected + function IsValid: Boolean; + function IsOwned: Boolean; + function Copy: ICefBinaryValue; + function GetSize: NativeUInt; + function GetData(buffer: Pointer; bufferSize, dataOffset: NativeUInt): NativeUInt; + public + class function UnWrap(data: Pointer): ICefBinaryValue; + class function New(const data: Pointer; dataSize: NativeUInt): ICefBinaryValue; + end; + + TCefDictionaryValueRef = class(TCefBaseRef, ICefDictionaryValue) + protected + function IsValid: Boolean; + function isOwned: Boolean; + function IsReadOnly: Boolean; + function Copy(excludeEmptyChildren: Boolean): ICefDictionaryValue; + function GetSize: NativeUInt; + function Clear: Boolean; + function HasKey(const key: ustring): Boolean; + function GetKeys(const keys: TStrings): Boolean; + function Remove(const key: ustring): Boolean; + function GetType(const key: ustring): TCefValueType; + function GetBool(const key: ustring): Boolean; + function GetInt(const key: ustring): Integer; + function GetDouble(const key: ustring): Double; + function GetString(const key: ustring): ustring; + function GetBinary(const key: ustring): ICefBinaryValue; + function GetDictionary(const key: ustring): ICefDictionaryValue; + function GetList(const key: ustring): ICefListValue; + function SetNull(const key: ustring): Boolean; + function SetBool(const key: ustring; value: Boolean): Boolean; + function SetInt(const key: ustring; value: Integer): Boolean; + function SetDouble(const key: ustring; value: Double): Boolean; + function SetString(const key, value: ustring): Boolean; + function SetBinary(const key: ustring; const value: ICefBinaryValue): Boolean; + function SetDictionary(const key: ustring; const value: ICefDictionaryValue): Boolean; + function SetList(const key: ustring; const value: ICefListValue): Boolean; + public + class function UnWrap(data: Pointer): ICefDictionaryValue; + class function New: ICefDictionaryValue; + end; + + TCefBrowserProcessHandlerOwn = class(TCefBaseOwn, ICefBrowserProcessHandler) + protected + procedure OnContextInitialized; virtual; + procedure OnBeforeChildProcessLaunch(const commandLine: ICefCommandLine); virtual; + procedure OnRenderProcessThreadCreated(const extraInfo: ICefListValue); virtual; + public + constructor Create; virtual; + end; + + TCefRenderProcessHandlerOwn = class(TCefBaseOwn, ICefRenderProcessHandler) + protected + procedure OnRenderThreadCreated(const extraInfo: ICefListValue); virtual; + procedure OnWebKitInitialized; virtual; + procedure OnBrowserCreated(const browser: ICefBrowser); virtual; + function GetLoadHandler: ICefLoadHandler; virtual; + procedure OnBrowserDestroyed(const browser: ICefBrowser); virtual; + function OnBeforeNavigation(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest; navigationType: TCefNavigationType; + isRedirect: Boolean): Boolean; virtual; + procedure OnContextCreated(const browser: ICefBrowser; + const frame: ICefFrame; const context: ICefv8Context); virtual; + procedure OnContextReleased(const browser: ICefBrowser; + const frame: ICefFrame; const context: ICefv8Context); virtual; + procedure OnUncaughtException(const browser: ICefBrowser; const frame: ICefFrame; + const context: ICefv8Context; const exception: ICefV8Exception; + const stackTrace: ICefV8StackTrace); virtual; + procedure OnFocusedNodeChanged(const browser: ICefBrowser; + const frame: ICefFrame; const node: ICefDomNode); virtual; + function OnProcessMessageReceived(const browser: ICefBrowser; + sourceProcess: TCefProcessId; const message: ICefProcessMessage): Boolean; virtual; + public + constructor Create; virtual; + end; + + TCefUrlrequestClientOwn = class(TCefBaseOwn, ICefUrlrequestClient) + protected + procedure OnRequestComplete(const request: ICefUrlRequest); virtual; + procedure OnUploadProgress(const request: ICefUrlRequest; current, total: UInt64); virtual; + procedure OnDownloadProgress(const request: ICefUrlRequest; current, total: UInt64); virtual; + procedure OnDownloadData(const request: ICefUrlRequest; data: Pointer; dataLength: NativeUInt); virtual; + function GetAuthCredentials(isProxy: Boolean; const host: ustring; port: Integer; + const realm, scheme: ustring; const callback: ICefAuthCallback): Boolean; virtual; + public + constructor Create; virtual; + end; + + TCefUrlRequestRef = class(TCefBaseRef, ICefUrlRequest) + protected + function GetRequest: ICefRequest; + function GetRequestStatus: TCefUrlRequestStatus; + function GetRequestError: Integer; + function GetResponse: ICefResponse; + procedure Cancel; + public + class function UnWrap(data: Pointer): ICefUrlRequest; + class function New(const request: ICefRequest; const client: ICefUrlRequestClient): ICefUrlRequest; + end; + + TCefWebPluginInfoVisitorOwn = class(TCefBaseOwn, ICefWebPluginInfoVisitor) + protected + function Visit(const info: ICefWebPluginInfo; count, total: Integer): Boolean; virtual; + public + constructor Create; virtual; + end; + + TCefWebPluginInfoVisitorProc = {$IFDEF DELPHI12_UP}reference to{$ENDIF} function(const info: ICefWebPluginInfo; count, total: Integer): Boolean; + TCefWebPluginIsUnstableProc = {$IFDEF DELPHI12_UP}reference to{$ENDIF}procedure(const path: ustring; unstable: Boolean); + + TCefFastWebPluginInfoVisitor = class(TCefWebPluginInfoVisitorOwn) + private + FProc: TCefWebPluginInfoVisitorProc; + protected + function Visit(const info: ICefWebPluginInfo; count, total: Integer): Boolean; override; + public + constructor Create(const proc: TCefWebPluginInfoVisitorProc); reintroduce; + end; + + TCefWebPluginUnstableCallbackOwn = class(TCefBaseOwn, ICefWebPluginUnstableCallback) + protected + procedure IsUnstable(const path: ustring; unstable: Boolean); virtual; + public + constructor Create; virtual; + end; + + TCefFastWebPluginUnstableCallback = class(TCefWebPluginUnstableCallbackOwn) + private + FCallback: TCefWebPluginIsUnstableProc; + protected + procedure IsUnstable(const path: ustring; unstable: Boolean); override; + public + constructor Create(const callback: TCefWebPluginIsUnstableProc); reintroduce; + end; + + TCefTraceClientOwn = class(TCefBaseOwn, ICefTraceClient) + protected + procedure OnTraceDataCollected(const fragment: PAnsiChar; fragmentSize: NativeUInt); virtual; + procedure OnTraceBufferPercentFullReply(percentFull: Single); virtual; + procedure OnEndTracingComplete; virtual; + public + constructor Create; virtual; + end; + + TCefGetGeolocationCallbackOwn = class(TCefBaseOwn, ICefGetGeolocationCallback) + protected + procedure OnLocationUpdate(const position: PCefGeoposition); virtual; + public + constructor Create; virtual; + end; + + TOnLocationUpdate = {$IFDEF DELPHI12_UP}reference to{$ENDIF} procedure(const position: PCefGeoposition); + + TCefFastGetGeolocationCallback = class(TCefGetGeolocationCallbackOwn) + private + FCallback: TOnLocationUpdate; + protected + procedure OnLocationUpdate(const position: PCefGeoposition); override; + public + constructor Create(const callback: TOnLocationUpdate); reintroduce; + end; + + TCefFileDialogCallbackRef = class(TCefBaseRef, ICefFileDialogCallback) + protected + procedure Cont(filePaths: TStrings); + procedure Cancel; + public + class function UnWrap(data: Pointer): ICefFileDialogCallback; + end; + + TCefRenderHandlerOwn = class(TCefBaseOwn, ICefRenderHandler) + protected + function GetRootScreenRect(const browser: ICefBrowser; rect: PCefRect): Boolean; virtual; + function GetViewRect(const browser: ICefBrowser; rect: PCefRect): Boolean; virtual; + function GetScreenPoint(const browser: ICefBrowser; viewX, viewY: Integer; + screenX, screenY: PInteger): Boolean; virtual; + function GetScreenInfo(const browser: ICefBrowser; screenInfo: PCefScreenInfo): Boolean; virtual; + procedure OnPopupShow(const browser: ICefBrowser; show: Boolean); virtual; + procedure OnPopupSize(const browser: ICefBrowser; const rect: PCefRect); virtual; + procedure OnPaint(const browser: ICefBrowser; kind: TCefPaintElementType; + dirtyRectsCount: NativeUInt; const dirtyRects: PCefRectArray; + const buffer: Pointer; width, height: Integer); virtual; + procedure OnCursorChange(const browser: ICefBrowser; cursor: TCefCursorHandle); virtual; + procedure OnScrollOffsetChanged(const browser: ICefBrowser); virtual; + public + constructor Create; virtual; + end; + + TCefDragDataRef = class(TCefBaseRef, ICefDragData) + protected + function IsLink: Boolean; + function IsFragment: Boolean; + function IsFile: Boolean; + function GetLinkUrl: ustring; + function GetLinkTitle: ustring; + function GetLinkMetadata: ustring; + function GetFragmentText: ustring; + function GetFragmentHtml: ustring; + function GetFragmentBaseUrl: ustring; + function GetFileName: ustring; + function GetFileNames(names: TStrings): Integer; + public + class function UnWrap(data: Pointer): ICefDragData; + end; + + TCefDragHandlerOwn = class(TCefBaseOwn, ICefDragHandler) + protected + function OnDragEnter(const browser: ICefBrowser; const dragData: ICefDragData; + mask: TCefDragOperations): Boolean; virtual; + public + constructor Create; virtual; + end; + + TCefRequestContextHandlerOwn = class(TCefBaseOwn, ICefRequestContextHandler) + protected + function GetCookieManager: ICefCookieManager; virtual; + public + constructor Create; virtual; + end; + + TCefRequestContextHandlerRef = class(TCefBaseRef, ICefRequestContextHandler) + protected + function GetCookieManager: ICefCookieManager; + public + class function UnWrap(data: Pointer): ICefRequestContextHandler; + end; + + TCefCookieVisitorRef = class(TCefBaseRef, ICefCookieVisitor) + protected + function visit(const name, value, domain, path: ustring; secure, httponly, + hasExpires: Boolean; const creation, lastAccess, expires: TDateTime; + count, total: Integer; out deleteCookie: Boolean): Boolean; + public + class function UnWrap(data: Pointer): ICefCookieVisitor; + end; + + TCefRequestContextRef = class(TCefBaseRef, ICefRequestContext) + protected + function IsSame(const other: ICefRequestContext): Boolean; + function IsGlobal: Boolean; + function GetHandler: ICefBase; + public + class function UnWrap(data: Pointer): ICefRequestContext; + class function GetGlobalContext: ICefRequestContext; + class function CreateContext(const handler: ICefRequestContextHandler): ICefRequestContext; + end; + + ECefException = class(Exception) + end; + +function CefLoadLibDefault: Boolean; +function CefLoadLib( + const Cache: ustring = ''; + const UserAgent: ustring = ''; + const ProductVersion: ustring = ''; + const Locale: ustring = ''; + const LogFile: ustring = ''; + const BrowserSubprocessPath: ustring = ''; + LogSeverity: TCefLogSeverity = LOGSEVERITY_DISABLE; + JavaScriptFlags: ustring = ''; + ResourcesDirPath: ustring = ''; + LocalesDirPath: ustring = ''; + SingleProcess: Boolean = False; + CommandLineArgsDisabled: Boolean = False; + PackLoadingDisabled: Boolean = False; + RemoteDebuggingPort: Integer = 0; + ReleaseDCheck: Boolean = False; + UncaughtExceptionStackSize: Integer = 0; + ContextSafetyImplementation: Integer = 0; + PersistSessionCookies: Boolean = False; + IgnoreCertificateErrors: Boolean = False): Boolean; +function CefGetObject(ptr: Pointer): TObject; +function CefStringAlloc(const str: ustring): TCefString; + +function CefString(const str: ustring): TCefString; overload; +function CefString(const str: PCefString): ustring; overload; +function CefUserFreeString(const str: ustring): PCefStringUserFree; + +function CefStringClearAndGet(var str: TCefString): ustring; +procedure CefStringFree(const str: PCefString); +function CefStringFreeAndGet(const str: PCefStringUserFree): ustring; +procedure CefStringSet(const str: PCefString; const value: ustring); +function CefBrowserHostCreate(windowInfo: PCefWindowInfo; const client: ICefClient; + const url: ustring; const settings: PCefBrowserSettings; + const requestContext: ICefRequestContext = nil): Boolean; +function CefBrowserHostCreateSync(windowInfo: PCefWindowInfo; const client: ICefClient; + const url: ustring; const settings: PCefBrowserSettings; + const requestContext: ICefRequestContext = nil): ICefBrowser; +{$IFNDEF CEF_MULTI_THREADED_MESSAGE_LOOP} +procedure CefDoMessageLoopWork; +procedure CefRunMessageLoop; +procedure CefQuitMessageLoop; +procedure CefSetOsModalLoop(loop: Boolean); +{$ENDIF} +procedure CefShutDown; + +function CefRegisterSchemeHandlerFactory(const SchemeName, HostName: ustring; + SyncMainThread: Boolean; const handler: TCefResourceHandlerClass): Boolean; +function CefClearSchemeHandlerFactories: Boolean; + +function CefAddCrossOriginWhitelistEntry(const SourceOrigin, TargetProtocol, + TargetDomain: ustring; AllowTargetSubdomains: Boolean): Boolean; +function CefRemoveCrossOriginWhitelistEntry( + const SourceOrigin, TargetProtocol, TargetDomain: ustring; + AllowTargetSubdomains: Boolean): Boolean; +function CefClearCrossOriginWhitelist: Boolean; + +function CefRegisterExtension(const name, code: ustring; + const Handler: ICefv8Handler): Boolean; +function CefCurrentlyOn(ThreadId: TCefThreadId): Boolean; +procedure CefPostTask(ThreadId: TCefThreadId; const task: ICefTask); +procedure CefPostDelayedTask(ThreadId: TCefThreadId; const task: ICefTask; delayMs: Int64); +function CefGetData(const i: ICefBase): Pointer; +function CefParseUrl(const url: ustring; var parts: TUrlParts): Boolean; +function CefCreateUrl(var parts: TUrlParts): ustring; + +procedure CefVisitWebPluginInfo(const visitor: ICefWebPluginInfoVisitor); +procedure CefVisitWebPluginInfoProc(const visitor: TCefWebPluginInfoVisitorProc); +procedure CefRefreshWebPlugins; +procedure CefAddWebPluginPath(const path: ustring); +procedure CefAddWebPluginDirectory(const dir: ustring); +procedure CefRemoveWebPluginPath(const path: ustring); +procedure CefUnregisterInternalWebPlugin(const path: ustring); +procedure CefForceWebPluginShutdown(const path: ustring); +procedure CefRegisterWebPluginCrash(const path: ustring); +procedure CefIsWebPluginUnstable(const path: ustring; + const callback: ICefWebPluginUnstableCallback); +procedure CefIsWebPluginUnstableProc(const path: ustring; + const callback: TCefWebPluginIsUnstableProc); + +function CefGetPath(key: TCefPathKey; out path: ustring): Boolean; + +function CefBeginTracing(const client: ICefTraceClient; const categories: ustring): Boolean; +function CefGetTraceBufferPercentFullAsync: Integer; +function CefEndTracingAsync: Boolean; +function CefNowFromSystemTraceTime: Int64; + +function CefGetGeolocation(const callback: ICefGetGeolocationCallback): Boolean; + +var + CefLibrary: string = {$IFDEF MSWINDOWS}'libcef.dll'{$ELSE}'libcef.dylib'{$ENDIF}; + CefCache: ustring = ''; + CefUserAgent: ustring = ''; + CefProductVersion: ustring = ''; + CefLocale: ustring = ''; + CefLogFile: ustring = ''; + CefLogSeverity: TCefLogSeverity = LOGSEVERITY_DISABLE; + CefJavaScriptFlags: ustring = ''; + CefResourcesDirPath: ustring = ''; + CefLocalesDirPath: ustring = ''; + CefPackLoadingDisabled: Boolean = False; + CefSingleProcess: Boolean = True; + CefBrowserSubprocessPath: ustring = ''; + CefCommandLineArgsDisabled: Boolean = False; + CefRemoteDebuggingPort: Integer = 0; + CefGetDataResource: TGetDataResource = nil; + CefGetLocalizedString: TGetLocalizedString = nil; + CefReleaseDCheck: Boolean = False; + CefUncaughtExceptionStackSize: Integer = 0; + CefContextSafetyImplementation: Integer = 0; + CefPersistSessionCookies: Boolean = False; + CefIgnoreCertificateErrors: Boolean = False; + + CefResourceBundleHandler: ICefResourceBundleHandler = nil; + CefBrowserProcessHandler: ICefBrowserProcessHandler = nil; + CefRenderProcessHandler: ICefRenderProcessHandler = nil; + CefOnBeforeCommandLineProcessing: TOnBeforeCommandLineProcessing = nil; + CefOnRegisterCustomSchemes: TOnRegisterCustomSchemes = nil; + +implementation + +function CefColorGetA(color: TCefColor): Byte; +begin + Result := (((color) shr 24) and $FF) +end; + +function CefColorGetR(color: TCefColor): Byte; +begin + Result := (((color) shr 16) and $FF); +end; + +function CefColorGetG(color: TCefColor): Byte; +begin + Result := (((color) shr 8) and $FF); +end; + +function CefColorGetB(color: TCefColor): Byte; +begin + Result := (((color) shr 0) and $FF); +end; + +function CefColorSetARGB(a, r, g, b: Byte): TCefColor; +begin + Result := (a shl 24) or (r shl 16) or (g shl 8) or (b shl 0); +end; + + +type + TInternalApp = class(TCefAppOwn) + protected + procedure OnBeforeCommandLineProcessing(const processType: ustring; + const commandLine: ICefCommandLine); override; + procedure OnRegisterCustomSchemes(const registrar: ICefSchemeRegistrar); override; + function GetResourceBundleHandler: ICefResourceBundleHandler; override; + function GetBrowserProcessHandler: ICefBrowserProcessHandler; override; + function GetRenderProcessHandler: ICefRenderProcessHandler; override; + end; + + procedure TInternalApp.OnBeforeCommandLineProcessing(const processType: ustring; + const commandLine: ICefCommandLine); + begin + if Assigned(CefOnBeforeCommandLineProcessing) then + CefOnBeforeCommandLineProcessing(processType, commandLine); + end; + + procedure TInternalApp.OnRegisterCustomSchemes(const registrar: ICefSchemeRegistrar); + begin + if Assigned(CefOnRegisterCustomSchemes) then + CefOnRegisterCustomSchemes(registrar); + end; + + function TInternalApp.GetResourceBundleHandler: ICefResourceBundleHandler; + begin + Result := CefResourceBundleHandler; + end; + + function TInternalApp.GetBrowserProcessHandler: ICefBrowserProcessHandler; + begin + result := CefBrowserProcessHandler; + end; + + function TInternalApp.GetRenderProcessHandler: ICefRenderProcessHandler; + begin + Result := CefRenderProcessHandler; + end; + +{$IFDEF MSWINDOWS} +function TzSpecificLocalTimeToSystemTime( + lpTimeZoneInformation: PTimeZoneInformation; + lpLocalTime, lpUniversalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll'; + +function SystemTimeToTzSpecificLocalTime( + lpTimeZoneInformation: PTimeZoneInformation; + lpUniversalTime, lpLocalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll'; +{$ENDIF} + +var +// These functions set string values. If |copy| is true (1) the value will be +// copied instead of referenced. It is up to the user to properly manage +// the lifespan of references. + + cef_string_wide_set: function(const src: PWideChar; src_len: NativeUInt; output: PCefStringWide; copy: Integer): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_utf8_set: function(const src: PAnsiChar; src_len: NativeUInt; output: PCefStringUtf8; copy: Integer): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_utf16_set: function(const src: PChar16; src_len: NativeUInt; output: PCefStringUtf16; copy: Integer): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_set: function(const src: PCefChar; src_len: NativeUInt; output: PCefString; copy: Integer): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // These functions clear string values. The structure itself is not freed. + + cef_string_wide_clear: procedure(str: PCefStringWide); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_utf8_clear: procedure(str: PCefStringUtf8); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_utf16_clear: procedure(str: PCefStringUtf16); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_clear: procedure(str: PCefString); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // These functions compare two string values with the same results as strcmp(). + + cef_string_wide_cmp: function(const str1, str2: PCefStringWide): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_utf8_cmp: function(const str1, str2: PCefStringUtf8): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_utf16_cmp: function(const str1, str2: PCefStringUtf16): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // These functions convert between UTF-8, -16, and -32 strings. They are + // potentially slow so unnecessary conversions should be avoided. The best + // possible result will always be written to |output| with the boolean return + // value indicating whether the conversion is 100% valid. + + cef_string_wide_to_utf8: function(const src: PWideChar; src_len: NativeUInt; output: PCefStringUtf8): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_utf8_to_wide: function(const src: PAnsiChar; src_len: NativeUInt; output: PCefStringWide): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + cef_string_wide_to_utf16: function (const src: PWideChar; src_len: NativeUInt; output: PCefStringUtf16): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_utf16_to_wide: function(const src: PChar16; src_len: NativeUInt; output: PCefStringWide): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + cef_string_utf8_to_utf16: function(const src: PAnsiChar; src_len: NativeUInt; output: PCefStringUtf16): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_utf16_to_utf8: function(const src: PChar16; src_len: NativeUInt; output: PCefStringUtf8): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + cef_string_to_utf8: function(const src: PCefChar; src_len: NativeUInt; output: PCefStringUtf8): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_from_utf8: function(const src: PAnsiChar; src_len: NativeUInt; output: PCefString): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_to_utf16: function(const src: PCefChar; src_len: NativeUInt; output: PCefStringUtf16): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_from_utf16: function(const src: PChar16; src_len: NativeUInt; output: PCefString): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_to_wide: function(const src: PCefChar; src_len: NativeUInt; output: PCefStringWide): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_from_wide: function(const src: PWideChar; src_len: NativeUInt; output: PCefString): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // These functions convert an ASCII string, typically a hardcoded constant, to a + // Wide/UTF16 string. Use instead of the UTF8 conversion routines if you know + // the string is ASCII. + + cef_string_ascii_to_wide: function(const src: PAnsiChar; src_len: NativeUInt; output: PCefStringWide): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_ascii_to_utf16: function(const src: PAnsiChar; src_len: NativeUInt; output: PCefStringUtf16): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_from_ascii: function(const src: PAnsiChar; src_len: NativeUInt; output: PCefString): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // These functions allocate a new string structure. They must be freed by + // calling the associated free function. + + cef_string_userfree_wide_alloc: function(): PCefStringUserFreeWide; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_userfree_utf8_alloc: function(): PCefStringUserFreeUtf8; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_userfree_utf16_alloc: function(): PCefStringUserFreeUtf16; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_userfree_alloc: function(): PCefStringUserFree; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // These functions free the string structure allocated by the associated + // alloc function. Any string contents will first be cleared. + + cef_string_userfree_wide_free: procedure(str: PCefStringUserFreeWide); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_userfree_utf8_free: procedure(str: PCefStringUserFreeUtf8); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_userfree_utf16_free: procedure(str: PCefStringUserFreeUtf16); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_userfree_free: procedure(str: PCefStringUserFree); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + +// Convenience macros for copying values. +function cef_string_wide_copy(const src: PWideChar; src_len: NativeUInt; output: PCefStringWide): Integer; +begin + Result := cef_string_wide_set(src, src_len, output, ord(True)) +end; + +function cef_string_utf8_copy(const src: PAnsiChar; src_len: NativeUInt; output: PCefStringUtf8): Integer; +begin + Result := cef_string_utf8_set(src, src_len, output, ord(True)) +end; + +function cef_string_utf16_copy(const src: PChar16; src_len: NativeUInt; output: PCefStringUtf16): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; +begin + Result := cef_string_utf16_set(src, src_len, output, ord(True)) +end; + +function cef_string_copy(const src: PCefChar; src_len: NativeUInt; output: PCefString): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; +begin + Result := cef_string_set(src, src_len, output, ord(True)); +end; + +var + // Create a new browser window using the window parameters specified by + // |windowInfo|. All values will be copied internally and the actual window will + // be created on the UI thread. If |request_context| is NULL the global request + // context will be used. This function can be called on any browser process + // thread and will not block. + cef_browser_host_create_browser: function( + const windowInfo: PCefWindowInfo; client: PCefClient; + const url: PCefString; const settings: PCefBrowserSettings; + request_context: Pcefrequestcontext): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Create a new browser window using the window parameters specified by + // |windowInfo|. If |request_context| is NULL the global request context will be + // used. This function can only be called on the browser process UI thread. + cef_browser_host_create_browser_sync: function( + const windowInfo: PCefWindowInfo; client: PCefClient; + const url: PCefString; const settings: PCefBrowserSettings; + request_context: Pcefrequestcontext): PCefBrowser; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Perform a single iteration of CEF message loop processing. This function is + // used to integrate the CEF message loop into an existing application message + // loop. Care must be taken to balance performance against excessive CPU usage. + // This function should only be called on the main application thread and only + // if cef_initialize() is called with a CefSettings.multi_threaded_message_loop + // value of false (0). This function will not block. + cef_do_message_loop_work: procedure(); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Run the CEF message loop. Use this function instead of an application- + // provided message loop to get the best balance between performance and CPU + // usage. This function should only be called on the main application thread and + // only if cef_initialize() is called with a + // CefSettings.multi_threaded_message_loop value of false (0). This function + // will block until a quit message is received by the system. + cef_run_message_loop: procedure; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Quit the CEF message loop that was started by calling cef_run_message_loop(). + // This function should only be called on the main application thread and only + // if cef_run_message_loop() was used. + cef_quit_message_loop: procedure; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Set to true (1) before calling Windows APIs like TrackPopupMenu that enter a + // modal message loop. Set to false (0) after exiting the modal message loop. + cef_set_osmodal_loop: procedure(osModalLoop: Integer); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // This function should be called from the application entry point function to + // execute a secondary process. It can be used to run secondary processes from + // the browser client executable (default behavior) or from a separate + // executable specified by the CefSettings.browser_subprocess_path value. If + // called for the browser process (identified by no "type" command-line value) + // it will return immediately with a value of -1. If called for a recognized + // secondary process it will block until the process should exit and then return + // the process exit code. The |application| parameter may be NULL. + cef_execute_process: function(const args: PCefMainArgs; application: PCefApp): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // This function should be called on the main application thread to initialize + // the CEF browser process. The |application| parameter may be NULL. A return + // value of true (1) indicates that it succeeded and false (0) indicates that it + // failed. + cef_initialize: function(const args: PCefMainArgs; const settings: PCefSettings; application: PCefApp): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // This function should be called on the main application thread to shut down + // the CEF browser process before the application exits. + cef_shutdown: procedure(); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Allocate a new string map. + cef_string_map_alloc: function(): TCefStringMap; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + //function cef_string_map_size(map: TCefStringMap): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + cef_string_map_size: function(map: TCefStringMap): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Return the value assigned to the specified key. + cef_string_map_find: function(map: TCefStringMap; const key: PCefString; var value: TCefString): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Return the key at the specified zero-based string map index. + cef_string_map_key: function(map: TCefStringMap; index: Integer; var key: TCefString): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Return the value at the specified zero-based string map index. + cef_string_map_value: function(map: TCefStringMap; index: Integer; var value: TCefString): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Append a new key/value pair at the end of the string map. + cef_string_map_append: function(map: TCefStringMap; const key, value: PCefString): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Clear the string map. + cef_string_map_clear: procedure(map: TCefStringMap); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Free the string map. + cef_string_map_free: procedure(map: TCefStringMap); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Allocate a new string map. + cef_string_list_alloc: function(): TCefStringList; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Return the number of elements in the string list. + cef_string_list_size: function(list: TCefStringList): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Retrieve the value at the specified zero-based string list index. Returns + // true (1) if the value was successfully retrieved. + cef_string_list_value: function(list: TCefStringList; index: Integer; value: PCefString): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Append a new value at the end of the string list. + cef_string_list_append: procedure(list: TCefStringList; const value: PCefString); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Clear the string list. + cef_string_list_clear: procedure(list: TCefStringList); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Free the string list. + cef_string_list_free: procedure(list: TCefStringList); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Creates a copy of an existing string list. + cef_string_list_copy: function(list: TCefStringList): TCefStringList; + + + // Register a new V8 extension with the specified JavaScript extension code and + // handler. Functions implemented by the handler are prototyped using the + // keyword 'native'. The calling of a native function is restricted to the scope + // in which the prototype of the native function is defined. This function may + // only be called on the render process main thread. + // + // Example JavaScript extension code: + // + // // create the 'example' global object if it doesn't already exist. + // if (!example) + // example = {}; + // // create the 'example.test' global object if it doesn't already exist. + // if (!example.test) + // example.test = {}; + // (function() { + // // Define the function 'example.test.myfunction'. + // example.test.myfunction = function() { + // // Call CefV8Handler::Execute() with the function name 'MyFunction' + // // and no arguments. + // native function MyFunction(); + // return MyFunction(); + // }; + // // Define the getter function for parameter 'example.test.myparam'. + // example.test.__defineGetter__('myparam', function() { + // // Call CefV8Handler::Execute() with the function name 'GetMyParam' + // // and no arguments. + // native function GetMyParam(); + // return GetMyParam(); + // }); + // // Define the setter function for parameter 'example.test.myparam'. + // example.test.__defineSetter__('myparam', function(b) { + // // Call CefV8Handler::Execute() with the function name 'SetMyParam' + // // and a single argument. + // native function SetMyParam(); + // if(b) SetMyParam(b); + // }); + // + // // Extension definitions can also contain normal JavaScript variables + // // and functions. + // var myint = 0; + // example.test.increment = function() { + // myint += 1; + // return myint; + // }; + // })(); + // + // Example usage in the page: + // + // // Call the function. + // example.test.myfunction(); + // // Set the parameter. + // example.test.myparam = value; + // // Get the parameter. + // value = example.test.myparam; + // // Call another function. + // example.test.increment(); + // + cef_register_extension: function(const extension_name, + javascript_code: PCefString; handler: PCefv8Handler): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Register a scheme handler factory for the specified |scheme_name| and + // optional |domain_name|. An NULL |domain_name| value for a standard scheme + // will cause the factory to match all domain names. The |domain_name| value + // will be ignored for non-standard schemes. If |scheme_name| is a built-in + // scheme and no handler is returned by |factory| then the built-in scheme + // handler factory will be called. If |scheme_name| is a custom scheme then also + // implement the cef_app_t::on_register_custom_schemes() function in all + // processes. This function may be called multiple times to change or remove the + // factory that matches the specified |scheme_name| and optional |domain_name|. + // Returns false (0) if an error occurs. This function may be called on any + // thread in the browser process. + cef_register_scheme_handler_factory: function( + const scheme_name, domain_name: PCefString; + factory: PCefSchemeHandlerFactory): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Clear all registered scheme handler factories. Returns false (0) on error. + // This function may be called on any thread in the browser process. + cef_clear_scheme_handler_factories: function: Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Add an entry to the cross-origin access whitelist. + // + // The same-origin policy restricts how scripts hosted from different origins + // (scheme + domain + port) can communicate. By default, scripts can only access + // resources with the same origin. Scripts hosted on the HTTP and HTTPS schemes + // (but no other schemes) can use the "Access-Control-Allow-Origin" header to + // allow cross-origin requests. For example, https://source.example.com can make + // XMLHttpRequest requests on http://target.example.com if the + // http://target.example.com request returns an "Access-Control-Allow-Origin: + // https://source.example.com" response header. + // + // Scripts in separate frames or iframes and hosted from the same protocol and + // domain suffix can execute cross-origin JavaScript if both pages set the + // document.domain value to the same domain suffix. For example, + // scheme://foo.example.com and scheme://bar.example.com can communicate using + // JavaScript if both domains set document.domain="example.com". + // + // This function is used to allow access to origins that would otherwise violate + // the same-origin policy. Scripts hosted underneath the fully qualified + // |source_origin| URL (like http://www.example.com) will be allowed access to + // all resources hosted on the specified |target_protocol| and |target_domain|. + // If |target_domain| is non-NULL and |allow_target_subdomains| if false (0) + // only exact domain matches will be allowed. If |target_domain| contains a top- + // level domain component (like "example.com") and |allow_target_subdomains| is + // true (1) sub-domain matches will be allowed. If |target_domain| is NULL and + // |allow_target_subdomains| if true (1) all domains and IP addresses will be + // allowed. + // + // This function cannot be used to bypass the restrictions on local or display + // isolated schemes. See the comments on CefRegisterCustomScheme for more + // information. + // + // This function may be called on any thread. Returns false (0) if + // |source_origin| is invalid or the whitelist cannot be accessed. + + cef_add_cross_origin_whitelist_entry: function(const source_origin, target_protocol, + target_domain: PCefString; allow_target_subdomains: Integer): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Remove an entry from the cross-origin access whitelist. Returns false (0) if + // |source_origin| is invalid or the whitelist cannot be accessed. + cef_remove_cross_origin_whitelist_entry: function( + const source_origin, target_protocol, target_domain: PCefString; + allow_target_subdomains: Integer): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Remove all entries from the cross-origin access whitelist. Returns false (0) + // if the whitelist cannot be accessed. + cef_clear_cross_origin_whitelist: function: Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Returns true (1) if called on the specified thread. Equivalent to using + // cef_task_runner_t::GetForThread(threadId)->belongs_to_current_thread(). + cef_currently_on: function(threadId: TCefThreadId): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Post a task for execution on the specified thread. Equivalent to using + // cef_task_runner_t::GetForThread(threadId)->PostTask(task). + cef_post_task: function(threadId: TCefThreadId; task: PCefTask): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Post a task for delayed execution on the specified thread. Equivalent to + // using cef_task_runner_t::GetForThread(threadId)->PostDelayedTask(task, + // delay_ms). + cef_post_delayed_task: function(threadId: TCefThreadId; + task: PCefTask; delay_ms: Int64): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Parse the specified |url| into its component parts. Returns false (0) if the + // URL is NULL or invalid. + cef_parse_url: function(const url: PCefString; var parts: TCefUrlParts): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Creates a URL from the specified |parts|, which must contain a non-NULL spec + // or a non-NULL host and path (at a minimum), but not both. Returns false (0) + // if |parts| isn't initialized as described. + cef_create_url: function(parts: PCefUrlParts; url: PCefString): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Create a new TCefRequest object. + cef_request_create: function(): PCefRequest; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Create a new TCefPostData object. + cef_post_data_create: function(): PCefPostData; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Create a new cef_post_data_Element object. + cef_post_data_element_create: function(): PCefPostDataElement; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Create a new cef_stream_reader_t object from a file. + cef_stream_reader_create_for_file: function(const fileName: PCefString): PCefStreamReader; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Create a new cef_stream_reader_t object from data. + cef_stream_reader_create_for_data: function(data: Pointer; size: NativeUInt): PCefStreamReader; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Create a new cef_stream_reader_t object from a custom handler. + cef_stream_reader_create_for_handler: function(handler: PCefReadHandler): PCefStreamReader; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Create a new cef_stream_writer_t object for a file. + cef_stream_writer_create_for_file: function(const fileName: PCefString): PCefStreamWriter; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Create a new cef_stream_writer_t object for a custom handler. + cef_stream_writer_create_for_handler: function(handler: PCefWriteHandler): PCefStreamWriter; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Returns the current (top) context object in the V8 context stack. + cef_v8context_get_current_context: function(): PCefv8Context; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Returns the entered (bottom) context object in the V8 context stack. + cef_v8context_get_entered_context: function(): PCefv8Context; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Returns true (1) if V8 is currently inside a context. + cef_v8context_in_context: function(): Integer; + + // Create a new cef_v8value_t object of type undefined. + cef_v8value_create_undefined: function(): PCefv8Value; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Create a new cef_v8value_t object of type null. + cef_v8value_create_null: function(): PCefv8Value; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Create a new cef_v8value_t object of type bool. + cef_v8value_create_bool: function(value: Integer): PCefv8Value; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Create a new cef_v8value_t object of type int. + cef_v8value_create_int: function(value: Integer): PCefv8Value; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Create a new cef_v8value_t object of type unsigned int. + cef_v8value_create_uint: function(value: Cardinal): PCefv8Value; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Create a new cef_v8value_t object of type double. + cef_v8value_create_double: function(value: Double): PCefv8Value; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Create a new cef_v8value_t object of type Date. This function should only be + // called from within the scope of a cef_v8context_tHandler, cef_v8handler_t or + // cef_v8accessor_t callback, or in combination with calling enter() and exit() + // on a stored cef_v8context_t reference. + cef_v8value_create_date: function(const value: PCefTime): PCefv8Value; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Create a new cef_v8value_t object of type string. + cef_v8value_create_string: function(const value: PCefString): PCefv8Value; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Create a new cef_v8value_t object of type object with optional accessor. This + // function should only be called from within the scope of a + // cef_v8context_tHandler, cef_v8handler_t or cef_v8accessor_t callback, or in + // combination with calling enter() and exit() on a stored cef_v8context_t + // reference. + cef_v8value_create_object: function(accessor: PCefV8Accessor): PCefv8Value; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Create a new cef_v8value_t object of type array with the specified |length|. + // If |length| is negative the returned array will have length 0. This function + // should only be called from within the scope of a cef_v8context_tHandler, + // cef_v8handler_t or cef_v8accessor_t callback, or in combination with calling + // enter() and exit() on a stored cef_v8context_t reference. + cef_v8value_create_array: function(length: Integer): PCefv8Value; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + // Create a new cef_v8value_t object of type function. + cef_v8value_create_function: function(const name: PCefString; handler: PCefv8Handler): PCefv8Value; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Returns the stack trace for the currently active context. |frame_limit| is + // the maximum number of frames that will be captured. + cef_v8stack_trace_get_current: function(frame_limit: Integer): PCefV8StackTrace; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Create a new cef_xml_reader_t object. The returned object's functions can + // only be called from the thread that created the object. + cef_xml_reader_create: function(stream: PCefStreamReader; + encodingType: TCefXmlEncodingType; const URI: PCefString): PCefXmlReader; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Create a new cef_zip_reader_t object. The returned object's functions can + // only be called from the thread that created the object. + cef_zip_reader_create: function(stream: PCefStreamReader): PCefZipReader; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Allocate a new string multimap. + cef_string_multimap_alloc: function: TCefStringMultimap; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Return the number of elements in the string multimap. + cef_string_multimap_size: function(map: TCefStringMultimap): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Return the number of values with the specified key. + cef_string_multimap_find_count: function(map: TCefStringMultimap; const key: PCefString): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Return the value_index-th value with the specified key. + cef_string_multimap_enumerate: function(map: TCefStringMultimap; + const key: PCefString; value_index: Integer; var value: TCefString): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Return the key at the specified zero-based string multimap index. + cef_string_multimap_key: function(map: TCefStringMultimap; index: Integer; var key: TCefString): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Return the value at the specified zero-based string multimap index. + cef_string_multimap_value: function(map: TCefStringMultimap; index: Integer; var value: TCefString): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Append a new key/value pair at the end of the string multimap. + cef_string_multimap_append: function(map: TCefStringMultimap; const key, value: PCefString): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Clear the string multimap. + cef_string_multimap_clear: procedure(map: TCefStringMultimap); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Free the string multimap. + cef_string_multimap_free: procedure(map: TCefStringMultimap); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + cef_build_revision: function: Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Returns the global cookie manager. By default data will be stored at + // CefSettings.cache_path if specified or in memory otherwise. + cef_cookie_manager_get_global_manager: function(): PCefCookieManager; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Creates a new cookie manager. If |path| is NULL data will be stored in memory + // only. Otherwise, data will be stored at the specified |path|. To persist + // session cookies (cookies without an expiry date or validity interval) set + // |persist_session_cookies| to true (1). Session cookies are generally intended + // to be transient and most Web browsers do not persist them. Returns NULL if + // creation fails. + cef_cookie_manager_create_manager: function(const path: PCefString; + persist_session_cookies: Integer): PCefCookieManager; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Create a new cef_command_line_t instance. + cef_command_line_create: function(): PCefCommandLine; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Returns the singleton global cef_command_line_t object. The returned object + // will be read-only. + cef_command_line_get_global: function(): PCefCommandLine; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + + // Create a new cef_process_message_t object with the specified name. + cef_process_message_create: function(const name: PCefString): PCefProcessMessage; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Creates a new object that is not owned by any other object. The specified + // |data| will be copied. + cef_binary_value_create: function(const data: Pointer; data_size: NativeUInt): PCefBinaryValue; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Creates a new object that is not owned by any other object. + cef_dictionary_value_create: function: PCefDictionaryValue; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Creates a new object that is not owned by any other object. + cef_list_value_create: function: PCefListValue; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Retrieve the path associated with the specified |key|. Returns true (1) on + // success. Can be called on any thread in the browser process. + cef_get_path: function(key: TCefPathKey; path: PCefString): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Launches the process specified via |command_line|. Returns true (1) upon + // success. Must be called on the browser process TID_PROCESS_LAUNCHER thread. + // + // Unix-specific notes: - All file descriptors open in the parent process will + // be closed in the + // child process except for stdin, stdout, and stderr. + // - If the first argument on the command line does not contain a slash, + // PATH will be searched. (See man execvp.) + cef_launch_process: function(command_line: PCefCommandLine): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Create a new cef_response_t object. + cef_response_create: function: PCefResponse; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Create a new URL request. Only GET, POST, HEAD, DELETE and PUT request + // functions are supported. Multiple post data elements are not supported and + // elements of type PDE_TYPE_FILE are only supported for requests originating + // from the browser process. Requests originating from the render process will + // receive the same handling as requests originating from Web content -- if the + // response contains Content-Disposition or Mime-Type header values that would + // not normally be rendered then the response may receive special handling + // inside the browser (for example, via the file download code path instead of + // the URL request code path). The |request| object will be marked as read-only + // after calling this function. + cef_urlrequest_create: function(request: PCefRequest; client: PCefUrlRequestClient): PCefUrlRequest; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Visit web plugin information. + cef_visit_web_plugin_info: procedure(visitor: PCefWebPluginInfoVisitor); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Cause the plugin list to refresh the next time it is accessed regardless of + // whether it has already been loaded. Can be called on any thread in the + // browser process. + cef_refresh_web_plugins: procedure; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Add a plugin path (directory + file). This change may not take affect until + // after cef_refresh_web_plugins() is called. Can be called on any thread in the + // browser process. + cef_add_web_plugin_path: procedure(const path: PCefString); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Add a plugin directory. This change may not take affect until after + // cef_refresh_web_plugins() is called. Can be called on any thread in the + // browser process. + cef_add_web_plugin_directory: procedure(const dir: PCefString); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Remove a plugin path (directory + file). This change may not take affect + // until after cef_refresh_web_plugins() is called. Can be called on any thread + // in the browser process. + cef_remove_web_plugin_path: procedure(const path: PCefString); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Unregister an internal plugin. This may be undone the next time + // cef_refresh_web_plugins() is called. Can be called on any thread in the + // browser process. + cef_unregister_internal_web_plugin: procedure(const path: PCefString); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Force a plugin to shutdown. Can be called on any thread in the browser + // process but will be executed on the IO thread. + cef_force_web_plugin_shutdown: procedure(const path: PCefString); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Register a plugin crash. Can be called on any thread in the browser process + // but will be executed on the IO thread. + cef_register_web_plugin_crash: procedure(const path: PCefString); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Query if a plugin is unstable. Can be called on any thread in the browser + // process. + cef_is_web_plugin_unstable: procedure(const path: PCefString; + callback: PCefWebPluginUnstableCallback); {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Request a one-time geolocation update. This function bypasses any user + // permission checks so should only be used by code that is allowed to access + // location information. + cef_get_geolocation: function(callback: PCefGetGeolocationCallback): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Returns the task runner for the current thread. Only CEF threads will have + // task runners. An NULL reference will be returned if this function is called + // on an invalid thread. + cef_task_runner_get_for_current_thread: function: PCefTaskRunner; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Returns the task runner for the specified CEF thread. + cef_task_runner_get_for_thread: function(threadId: TCefThreadId): PCefTaskRunner; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + + + // Start tracing events on all processes. Tracing begins immediately locally, + // and asynchronously on child processes as soon as they receive the + // BeginTracing request. + // + // If CefBeginTracing was called previously, or if a CefEndTracingAsync call is + // pending, CefBeginTracing will fail and return false (0). + // + // |categories| is a comma-delimited list of category wildcards. A category can + // have an optional '-' prefix to make it an excluded category. Having both + // included and excluded categories in the same list is not supported. + // + // Example: "test_MyTest*" Example: "test_MyTest*,test_OtherStuff" Example: + // "-excluded_category1,-excluded_category2" + // + // This function must be called on the browser process UI thread. + + cef_begin_tracing: function(client: PCefTraceClient; + const categories: PCefString): Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Get the maximum trace buffer percent full state across all processes. + // + // cef_trace_client_t::OnTraceBufferPercentFullReply will be called + // asynchronously after the value is determined. When any child process reaches + // 100% full tracing will end automatically and + // cef_trace_client_t::OnEndTracingComplete will be called. This function fails + // and returns false (0) if trace is ending or disabled, no cef_trace_client_t + // was passed to CefBeginTracing, or if a previous call to + // CefGetTraceBufferPercentFullAsync is pending. + // + // This function must be called on the browser process UI thread. + + cef_get_trace_buffer_percent_full_async: function: Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Stop tracing events on all processes. + // + // This function will fail and return false (0) if a previous call to + // CefEndTracingAsync is already pending or if CefBeginTracing was not called. + // + // This function must be called on the browser process UI thread. + + cef_end_tracing_async: function: Integer; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Returns the current system trace time or, if none is defined, the current + // high-res time. Can be used by clients to synchronize with the time + // information in trace events. + cef_now_from_system_trace_time: function: Int64; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + + // Returns the global context object. + cef_request_context_get_global_context: function(): PCefRequestContext; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + + // Creates a new context object with the specified handler. + cef_request_context_create_context: function(handler: PCefRequestContextHandler): PCefRequestContext; {$IFDEF CPUX64}stdcall{$ELSE}cdecl{$ENDIF}; + +var + LibHandle: THandle = 0; + CefIsMainProcess: Boolean = False; + +function CefLoadLibDefault: Boolean; +begin + if LibHandle = 0 then + Result := CefLoadLib(CefCache, CefUserAgent, CefProductVersion, CefLocale, CefLogFile, + CefBrowserSubprocessPath, CefLogSeverity, + CefJavaScriptFlags, CefResourcesDirPath, CefLocalesDirPath, CefSingleProcess, + CefCommandLineArgsDisabled, CefPackLoadingDisabled, CefRemoteDebuggingPort, + CefReleaseDCheck, CefUncaughtExceptionStackSize, CefContextSafetyImplementation, + CefPersistSessionCookies, CefIgnoreCertificateErrors) else + Result := True; +end; + +function CefLoadLib(const Cache, UserAgent, ProductVersion, Locale, LogFile, BrowserSubprocessPath: ustring; + LogSeverity: TCefLogSeverity; JavaScriptFlags, ResourcesDirPath, LocalesDirPath: ustring; + SingleProcess, CommandLineArgsDisabled, PackLoadingDisabled: Boolean; RemoteDebuggingPort: Integer; + ReleaseDCheck: Boolean; UncaughtExceptionStackSize: Integer; ContextSafetyImplementation: Integer; + PersistSessionCookies: Boolean; IgnoreCertificateErrors: Boolean): Boolean; +var + settings: TCefSettings; + app: ICefApp; + errcode: Integer; +begin + if LibHandle = 0 then + begin + // deactivate FPU exception FPU & SSE2 + SetExceptionMask([exInvalidOp, exDenormalized, exZeroDivide, exOverflow, exUnderflow, exPrecision]); + + LibHandle := LoadLibrary(PChar(CefLibrary)); + if LibHandle = 0 then + RaiseLastOSError; + + cef_string_wide_set := GetProcAddress(LibHandle, 'cef_string_wide_set'); + cef_string_utf8_set := GetProcAddress(LibHandle, 'cef_string_utf8_set'); + cef_string_utf16_set := GetProcAddress(LibHandle, 'cef_string_utf16_set'); + cef_string_wide_clear := GetProcAddress(LibHandle, 'cef_string_wide_clear'); + cef_string_utf8_clear := GetProcAddress(LibHandle, 'cef_string_utf8_clear'); + cef_string_utf16_clear := GetProcAddress(LibHandle, 'cef_string_utf16_clear'); + cef_string_wide_cmp := GetProcAddress(LibHandle, 'cef_string_wide_cmp'); + cef_string_utf8_cmp := GetProcAddress(LibHandle, 'cef_string_utf8_cmp'); + cef_string_utf16_cmp := GetProcAddress(LibHandle, 'cef_string_utf16_cmp'); + cef_string_wide_to_utf8 := GetProcAddress(LibHandle, 'cef_string_wide_to_utf8'); + cef_string_utf8_to_wide := GetProcAddress(LibHandle, 'cef_string_utf8_to_wide'); + cef_string_wide_to_utf16 := GetProcAddress(LibHandle, 'cef_string_wide_to_utf16'); + cef_string_utf16_to_wide := GetProcAddress(LibHandle, 'cef_string_utf16_to_wide'); + cef_string_utf8_to_utf16 := GetProcAddress(LibHandle, 'cef_string_utf8_to_utf16'); + cef_string_utf16_to_utf8 := GetProcAddress(LibHandle, 'cef_string_utf16_to_utf8'); + cef_string_ascii_to_wide := GetProcAddress(LibHandle, 'cef_string_ascii_to_wide'); + cef_string_ascii_to_utf16 := GetProcAddress(LibHandle, 'cef_string_ascii_to_utf16'); + cef_string_userfree_wide_alloc := GetProcAddress(LibHandle, 'cef_string_userfree_wide_alloc'); + cef_string_userfree_utf8_alloc := GetProcAddress(LibHandle, 'cef_string_userfree_utf8_alloc'); + cef_string_userfree_utf16_alloc := GetProcAddress(LibHandle, 'cef_string_userfree_utf16_alloc'); + cef_string_userfree_wide_free := GetProcAddress(LibHandle, 'cef_string_userfree_wide_free'); + cef_string_userfree_utf8_free := GetProcAddress(LibHandle, 'cef_string_userfree_utf8_free'); + cef_string_userfree_utf16_free := GetProcAddress(LibHandle, 'cef_string_userfree_utf16_free'); + +{$IFDEF CEF_STRING_TYPE_UTF8} + cef_string_set := cef_string_utf8_set; + cef_string_clear := cef_string_utf8_clear; + cef_string_userfree_alloc := cef_string_userfree_utf8_alloc; + cef_string_userfree_free := cef_string_userfree_utf8_free; + cef_string_from_ascii := cef_string_utf8_copy; + cef_string_to_utf8 := cef_string_utf8_copy; + cef_string_from_utf8 := cef_string_utf8_copy; + cef_string_to_utf16 := cef_string_utf8_to_utf16; + cef_string_from_utf16 := cef_string_utf16_to_utf8; + cef_string_to_wide := cef_string_utf8_to_wide; + cef_string_from_wide := cef_string_wide_to_utf8; +{$ENDIF} + +{$IFDEF CEF_STRING_TYPE_UTF16} + cef_string_set := cef_string_utf16_set; + cef_string_clear := cef_string_utf16_clear; + cef_string_userfree_alloc := cef_string_userfree_utf16_alloc; + cef_string_userfree_free := cef_string_userfree_utf16_free; + cef_string_from_ascii := cef_string_ascii_to_utf16; + cef_string_to_utf8 := cef_string_utf16_to_utf8; + cef_string_from_utf8 := cef_string_utf8_to_utf16; + cef_string_to_utf16 := cef_string_utf16_copy; + cef_string_from_utf16 := cef_string_utf16_copy; + cef_string_to_wide := cef_string_utf16_to_wide; + cef_string_from_wide := cef_string_wide_to_utf16; +{$ENDIF} + +{$IFDEF CEF_STRING_TYPE_WIDE} + cef_string_set := cef_string_wide_set; + cef_string_clear := cef_string_wide_clear; + cef_string_userfree_alloc := cef_string_userfree_wide_alloc; + cef_string_userfree_free := cef_string_userfree_wide_free; + cef_string_from_ascii := cef_string_ascii_to_wide; + cef_string_to_utf8 := cef_string_wide_to_utf8; + cef_string_from_utf8 := cef_string_utf8_to_wide; + cef_string_to_utf16 := cef_string_wide_to_utf16; + cef_string_from_utf16 := cef_string_utf16_to_wide; + cef_string_to_wide := cef_string_wide_copy; + cef_string_from_wide := cef_string_wide_copy; +{$ENDIF} + + cef_string_map_alloc := GetProcAddress(LibHandle, 'cef_string_map_alloc'); + cef_string_map_size := GetProcAddress(LibHandle, 'cef_string_map_size'); + cef_string_map_find := GetProcAddress(LibHandle, 'cef_string_map_find'); + cef_string_map_key := GetProcAddress(LibHandle, 'cef_string_map_key'); + cef_string_map_value := GetProcAddress(LibHandle, 'cef_string_map_value'); + cef_string_map_append := GetProcAddress(LibHandle, 'cef_string_map_append'); + cef_string_map_clear := GetProcAddress(LibHandle, 'cef_string_map_clear'); + cef_string_map_free := GetProcAddress(LibHandle, 'cef_string_map_free'); + cef_string_list_alloc := GetProcAddress(LibHandle, 'cef_string_list_alloc'); + cef_string_list_size := GetProcAddress(LibHandle, 'cef_string_list_size'); + cef_string_list_value := GetProcAddress(LibHandle, 'cef_string_list_value'); + cef_string_list_append := GetProcAddress(LibHandle, 'cef_string_list_append'); + cef_string_list_clear := GetProcAddress(LibHandle, 'cef_string_list_clear'); + cef_string_list_free := GetProcAddress(LibHandle, 'cef_string_list_free'); + cef_string_list_copy := GetProcAddress(LibHandle, 'cef_string_list_copy'); + cef_initialize := GetProcAddress(LibHandle, 'cef_initialize'); + cef_execute_process := GetProcAddress(LibHandle, 'cef_execute_process'); + cef_shutdown := GetProcAddress(LibHandle, 'cef_shutdown'); + cef_do_message_loop_work := GetProcAddress(LibHandle, 'cef_do_message_loop_work'); + cef_run_message_loop := GetProcAddress(LibHandle, 'cef_run_message_loop'); + cef_quit_message_loop := GetProcAddress(LibHandle, 'cef_quit_message_loop'); + cef_set_osmodal_loop := GetProcAddress(LibHandle, 'cef_set_osmodal_loop'); + cef_register_extension := GetProcAddress(LibHandle, 'cef_register_extension'); + cef_register_scheme_handler_factory := GetProcAddress(LibHandle, 'cef_register_scheme_handler_factory'); + cef_clear_scheme_handler_factories := GetProcAddress(LibHandle, 'cef_clear_scheme_handler_factories'); + cef_add_cross_origin_whitelist_entry := GetProcAddress(LibHandle, 'cef_add_cross_origin_whitelist_entry'); + cef_remove_cross_origin_whitelist_entry := GetProcAddress(LibHandle, 'cef_remove_cross_origin_whitelist_entry'); + cef_clear_cross_origin_whitelist := GetProcAddress(LibHandle, 'cef_clear_cross_origin_whitelist'); + cef_currently_on := GetProcAddress(LibHandle, 'cef_currently_on'); + cef_post_task := GetProcAddress(LibHandle, 'cef_post_task'); + cef_post_delayed_task := GetProcAddress(LibHandle, 'cef_post_delayed_task'); + cef_parse_url := GetProcAddress(LibHandle, 'cef_parse_url'); + cef_create_url := GetProcAddress(LibHandle, 'cef_create_url'); + cef_browser_host_create_browser := GetProcAddress(LibHandle, 'cef_browser_host_create_browser'); + cef_browser_host_create_browser_sync := GetProcAddress(LibHandle, 'cef_browser_host_create_browser_sync'); + cef_request_create := GetProcAddress(LibHandle, 'cef_request_create'); + cef_post_data_create := GetProcAddress(LibHandle, 'cef_post_data_create'); + cef_post_data_element_create := GetProcAddress(LibHandle, 'cef_post_data_element_create'); + cef_stream_reader_create_for_file := GetProcAddress(LibHandle, 'cef_stream_reader_create_for_file'); + cef_stream_reader_create_for_data := GetProcAddress(LibHandle, 'cef_stream_reader_create_for_data'); + cef_stream_reader_create_for_handler := GetProcAddress(LibHandle, 'cef_stream_reader_create_for_handler'); + cef_stream_writer_create_for_file := GetProcAddress(LibHandle, 'cef_stream_writer_create_for_file'); + cef_stream_writer_create_for_handler := GetProcAddress(LibHandle, 'cef_stream_writer_create_for_handler'); + cef_v8context_get_current_context := GetProcAddress(LibHandle, 'cef_v8context_get_current_context'); + cef_v8context_get_entered_context := GetProcAddress(LibHandle, 'cef_v8context_get_entered_context'); + cef_v8context_in_context := GetProcAddress(LibHandle, 'cef_v8context_in_context'); + cef_v8value_create_undefined := GetProcAddress(LibHandle, 'cef_v8value_create_undefined'); + cef_v8value_create_null := GetProcAddress(LibHandle, 'cef_v8value_create_null'); + cef_v8value_create_bool := GetProcAddress(LibHandle, 'cef_v8value_create_bool'); + cef_v8value_create_int := GetProcAddress(LibHandle, 'cef_v8value_create_int'); + cef_v8value_create_uint := GetProcAddress(LibHandle, 'cef_v8value_create_uint'); + cef_v8value_create_double := GetProcAddress(LibHandle, 'cef_v8value_create_double'); + cef_v8value_create_date := GetProcAddress(LibHandle, 'cef_v8value_create_date'); + cef_v8value_create_string := GetProcAddress(LibHandle, 'cef_v8value_create_string'); + cef_v8value_create_object := GetProcAddress(LibHandle, 'cef_v8value_create_object'); + cef_v8value_create_array := GetProcAddress(LibHandle, 'cef_v8value_create_array'); + cef_v8value_create_function := GetProcAddress(LibHandle, 'cef_v8value_create_function'); + cef_v8stack_trace_get_current := GetProcAddress(LibHandle, 'cef_v8stack_trace_get_current'); + cef_xml_reader_create := GetProcAddress(LibHandle, 'cef_xml_reader_create'); + cef_zip_reader_create := GetProcAddress(LibHandle, 'cef_zip_reader_create'); + + cef_string_multimap_alloc := GetProcAddress(LibHandle, 'cef_string_multimap_alloc'); + cef_string_multimap_size := GetProcAddress(LibHandle, 'cef_string_multimap_size'); + cef_string_multimap_find_count := GetProcAddress(LibHandle, 'cef_string_multimap_find_count'); + cef_string_multimap_enumerate := GetProcAddress(LibHandle, 'cef_string_multimap_enumerate'); + cef_string_multimap_key := GetProcAddress(LibHandle, 'cef_string_multimap_key'); + cef_string_multimap_value := GetProcAddress(LibHandle, 'cef_string_multimap_value'); + cef_string_multimap_append := GetProcAddress(LibHandle, 'cef_string_multimap_append'); + cef_string_multimap_clear := GetProcAddress(LibHandle, 'cef_string_multimap_clear'); + cef_string_multimap_free := GetProcAddress(LibHandle, 'cef_string_multimap_free'); + cef_build_revision := GetProcAddress(LibHandle, 'cef_build_revision'); + + cef_cookie_manager_get_global_manager := GetProcAddress(LibHandle, 'cef_cookie_manager_get_global_manager'); + cef_cookie_manager_create_manager := GetProcAddress(LibHandle, 'cef_cookie_manager_create_manager'); + + cef_command_line_create := GetProcAddress(LibHandle, 'cef_command_line_create'); + cef_command_line_get_global := GetProcAddress(LibHandle, 'cef_command_line_get_global'); + + cef_process_message_create := GetProcAddress(LibHandle, 'cef_process_message_create'); + + cef_binary_value_create := GetProcAddress(LibHandle, 'cef_binary_value_create'); + + cef_dictionary_value_create := GetProcAddress(LibHandle, 'cef_dictionary_value_create'); + + cef_list_value_create := GetProcAddress(LibHandle, 'cef_list_value_create'); + + cef_get_path := GetProcAddress(LibHandle, 'cef_get_path'); + + cef_launch_process := GetProcAddress(LibHandle, 'cef_launch_process'); + + cef_response_create := GetProcAddress(LibHandle, 'cef_response_create'); + + cef_urlrequest_create := GetProcAddress(LibHandle, 'cef_urlrequest_create'); + + cef_visit_web_plugin_info := GetProcAddress(LibHandle, 'cef_visit_web_plugin_info'); + cef_refresh_web_plugins := GetProcAddress(LibHandle, 'cef_refresh_web_plugins'); + cef_add_web_plugin_path := GetProcAddress(LibHandle, 'cef_add_web_plugin_path'); + cef_add_web_plugin_directory := GetProcAddress(LibHandle, 'cef_add_web_plugin_directory'); + cef_remove_web_plugin_path := GetProcAddress(LibHandle, 'cef_remove_web_plugin_path'); + cef_unregister_internal_web_plugin := GetProcAddress(LibHandle, 'cef_unregister_internal_web_plugin'); + cef_force_web_plugin_shutdown := GetProcAddress(LibHandle, 'cef_force_web_plugin_shutdown'); + cef_register_web_plugin_crash := GetProcAddress(LibHandle, 'cef_register_web_plugin_crash'); + cef_is_web_plugin_unstable := GetProcAddress(LibHandle, 'cef_is_web_plugin_unstable'); + + cef_get_geolocation := GetProcAddress(LibHandle, 'cef_get_geolocation'); + + cef_task_runner_get_for_current_thread := GetProcAddress(LibHandle, 'cef_task_runner_get_for_current_thread'); + cef_task_runner_get_for_thread := GetProcAddress(LibHandle, 'cef_task_runner_get_for_thread'); + + cef_begin_tracing := GetProcAddress(LibHandle, 'cef_begin_tracing'); + cef_get_trace_buffer_percent_full_async := GetProcAddress(LibHandle, 'cef_get_trace_buffer_percent_full_async'); + cef_end_tracing_async := GetProcAddress(LibHandle, 'cef_end_tracing_async'); + cef_now_from_system_trace_time := GetProcAddress(LibHandle, 'cef_now_from_system_trace_time'); + cef_request_context_get_global_context := GetProcAddress(LibHandle, 'cef_request_context_get_global_context'); + cef_request_context_create_context := GetProcAddress(LibHandle, 'cef_request_context_create_context'); + + if not ( + Assigned(cef_string_wide_set) and + Assigned(cef_string_utf8_set) and + Assigned(cef_string_utf16_set) and + Assigned(cef_string_wide_clear) and + Assigned(cef_string_utf8_clear) and + Assigned(cef_string_utf16_clear) and + Assigned(cef_string_wide_cmp) and + Assigned(cef_string_utf8_cmp) and + Assigned(cef_string_utf16_cmp) and + Assigned(cef_string_wide_to_utf8) and + Assigned(cef_string_utf8_to_wide) and + Assigned(cef_string_wide_to_utf16) and + Assigned(cef_string_utf16_to_wide) and + Assigned(cef_string_utf8_to_utf16) and + Assigned(cef_string_utf16_to_utf8) and + Assigned(cef_string_ascii_to_wide) and + Assigned(cef_string_ascii_to_utf16) and + Assigned(cef_string_userfree_wide_alloc) and + Assigned(cef_string_userfree_utf8_alloc) and + Assigned(cef_string_userfree_utf16_alloc) and + Assigned(cef_string_userfree_wide_free) and + Assigned(cef_string_userfree_utf8_free) and + Assigned(cef_string_userfree_utf16_free) and + Assigned(cef_string_map_alloc) and + Assigned(cef_string_map_size) and + Assigned(cef_string_map_find) and + Assigned(cef_string_map_key) and + Assigned(cef_string_map_value) and + Assigned(cef_string_map_append) and + Assigned(cef_string_map_clear) and + Assigned(cef_string_map_free) and + Assigned(cef_string_list_alloc) and + Assigned(cef_string_list_size) and + Assigned(cef_string_list_value) and + Assigned(cef_string_list_append) and + Assigned(cef_string_list_clear) and + Assigned(cef_string_list_free) and + Assigned(cef_string_list_copy) and + Assigned(cef_initialize) and + Assigned(cef_execute_process) and + Assigned(cef_shutdown) and + Assigned(cef_do_message_loop_work) and + Assigned(cef_run_message_loop) and + Assigned(cef_quit_message_loop) and + Assigned(cef_set_osmodal_loop) and + Assigned(cef_register_extension) and + Assigned(cef_register_scheme_handler_factory) and + Assigned(cef_clear_scheme_handler_factories) and + Assigned(cef_add_cross_origin_whitelist_entry) and + Assigned(cef_remove_cross_origin_whitelist_entry) and + Assigned(cef_clear_cross_origin_whitelist) and + Assigned(cef_currently_on) and + Assigned(cef_post_task) and + Assigned(cef_post_delayed_task) and + Assigned(cef_parse_url) and + Assigned(cef_create_url) and + Assigned(cef_browser_host_create_browser) and + Assigned(cef_browser_host_create_browser_sync) and + Assigned(cef_request_create) and + Assigned(cef_post_data_create) and + Assigned(cef_post_data_element_create) and + Assigned(cef_stream_reader_create_for_file) and + Assigned(cef_stream_reader_create_for_data) and + Assigned(cef_stream_reader_create_for_handler) and + Assigned(cef_stream_writer_create_for_file) and + Assigned(cef_stream_writer_create_for_handler) and + Assigned(cef_v8context_get_current_context) and + Assigned(cef_v8context_get_entered_context) and + Assigned(cef_v8context_in_context) and + Assigned(cef_v8value_create_undefined) and + Assigned(cef_v8value_create_null) and + Assigned(cef_v8value_create_bool) and + Assigned(cef_v8value_create_int) and + Assigned(cef_v8value_create_uint) and + Assigned(cef_v8value_create_double) and + Assigned(cef_v8value_create_date) and + Assigned(cef_v8value_create_string) and + Assigned(cef_v8value_create_object) and + Assigned(cef_v8value_create_array) and + Assigned(cef_v8value_create_function) and + Assigned(cef_v8stack_trace_get_current) and + Assigned(cef_xml_reader_create) and + Assigned(cef_zip_reader_create) and + Assigned(cef_string_multimap_alloc) and + Assigned(cef_string_multimap_size) and + Assigned(cef_string_multimap_find_count) and + Assigned(cef_string_multimap_enumerate) and + Assigned(cef_string_multimap_key) and + Assigned(cef_string_multimap_value) and + Assigned(cef_string_multimap_append) and + Assigned(cef_string_multimap_clear) and + Assigned(cef_string_multimap_free) and + Assigned(cef_build_revision) and + Assigned(cef_cookie_manager_get_global_manager) and + Assigned(cef_cookie_manager_create_manager) and + Assigned(cef_command_line_create) and + Assigned(cef_command_line_get_global) and + Assigned(cef_process_message_create) and + Assigned(cef_binary_value_create) and + Assigned(cef_dictionary_value_create) and + Assigned(cef_list_value_create) and + Assigned(cef_get_path) and + Assigned(cef_launch_process) and + Assigned(cef_response_create) and + Assigned(cef_urlrequest_create) and + Assigned(cef_visit_web_plugin_info) and + Assigned(cef_refresh_web_plugins) and + Assigned(cef_add_web_plugin_path) and + Assigned(cef_add_web_plugin_directory) and + Assigned(cef_remove_web_plugin_path) and + Assigned(cef_unregister_internal_web_plugin) and + Assigned(cef_force_web_plugin_shutdown) and + Assigned(cef_register_web_plugin_crash) and + Assigned(cef_is_web_plugin_unstable) and + Assigned(cef_get_geolocation) and + Assigned(cef_task_runner_get_for_current_thread) and + Assigned(cef_task_runner_get_for_thread) and + Assigned(cef_begin_tracing) and + Assigned(cef_get_trace_buffer_percent_full_async) and + Assigned(cef_end_tracing_async) and + Assigned(cef_now_from_system_trace_time) and + Assigned(cef_request_context_get_global_context) and + Assigned(cef_request_context_create_context) + ) then raise ECefException.Create('Invalid CEF Library version'); + + FillChar(settings, SizeOf(settings), 0); + settings.size := SizeOf(settings); + settings.single_process := SingleProcess; + +{$IFNDEF CEF_MULTI_THREADED_MESSAGE_LOOP} + settings.multi_threaded_message_loop := False; +{$ELSE} + settings.multi_threaded_message_loop := True; +{$ENDIF} + settings.cache_path := CefString(Cache); + settings.persist_session_cookies := PersistSessionCookies; + settings.browser_subprocess_path := CefString(BrowserSubprocessPath); + settings.command_line_args_disabled := CommandLineArgsDisabled; + settings.user_agent := cefstring(UserAgent); + settings.product_version := CefString(ProductVersion); + settings.locale := CefString(Locale); + settings.log_file := CefString(LogFile); + settings.log_severity := LogSeverity; + settings.release_dcheck_enabled := ReleaseDCheck; + settings.javascript_flags := CefString(JavaScriptFlags); + settings.resources_dir_path := CefString(ResourcesDirPath); + settings.locales_dir_path := CefString(LocalesDirPath); + settings.pack_loading_disabled := PackLoadingDisabled; + settings.remote_debugging_port := RemoteDebuggingPort; + settings.uncaught_exception_stack_size := UncaughtExceptionStackSize; + settings.context_safety_implementation := ContextSafetyImplementation; + settings.ignore_certificate_errors := IgnoreCertificateErrors; + app := TInternalApp.Create; + errcode := cef_execute_process(@HInstance, CefGetData(app)); + if errcode >= 0 then + begin + Result := False; + Exit; + end; + cef_initialize(@HInstance, @settings, CefGetData(app)); + CefIsMainProcess := True; + end; + Result := True; +end; + +{$IFNDEF CEF_MULTI_THREADED_MESSAGE_LOOP} +procedure CefDoMessageLoopWork; +begin + if LibHandle > 0 then + cef_do_message_loop_work; +end; + +procedure CefRunMessageLoop; +begin + if LibHandle > 0 then + cef_run_message_loop; +end; + +procedure CefQuitMessageLoop; +begin + cef_quit_message_loop; +end; + +procedure CefSetOsModalLoop(loop: Boolean); +begin + cef_set_osmodal_loop(Ord(loop)); +end; +{$ENDIF} + +procedure CefShutDown; +begin + if LibHandle <> 0 then + begin + if CefIsMainProcess then + cef_shutdown; + FreeLibrary(LibHandle); + LibHandle := 0; + end; +end; + +function CefString(const str: ustring): TCefString; +begin + Result.str := PChar16(PWideChar(str)); + Result.length := Length(str); + Result.dtor := nil; +end; + +function CefString(const str: PCefString): ustring; +begin + if str <> nil then + SetString(Result, str.str, str.length) else + Result := ''; +end; + +procedure _free_string(str: PChar16); stdcall; +begin + if str <> nil then + FreeMem(str); +end; + +function CefUserFreeString(const str: ustring): PCefStringUserFree; +begin + Result := cef_string_userfree_alloc; + Result.length := Length(str); + GetMem(Result.str, Result.length * SizeOf(TCefChar)); + Move(PCefChar(str)^, Result.str^, Result.length * SizeOf(TCefChar)); + Result.dtor := @_free_string; +end; + +function CefStringAlloc(const str: ustring): TCefString; +begin + FillChar(Result, SizeOf(Result), 0); + if str <> '' then + cef_string_from_wide(PWideChar(str), Length(str), @Result); +end; + +procedure CefStringSet(const str: PCefString; const value: ustring); +begin + if str <> nil then + cef_string_set(PWideChar(value), Length(value), str, 1); +end; + +function CefStringClearAndGet(var str: TCefString): ustring; +begin + Result := CefString(@str); + cef_string_clear(@str); +end; + +function CefStringFreeAndGet(const str: PCefStringUserFree): ustring; +begin + if str <> nil then + begin + Result := CefString(PCefString(str)); + cef_string_userfree_free(str); + end else + Result := ''; +end; + +procedure CefStringFree(const str: PCefString); +begin + if str <> nil then + cef_string_clear(str); +end; + +function CefRegisterSchemeHandlerFactory(const SchemeName, HostName: ustring; + SyncMainThread: Boolean; const handler: TCefResourceHandlerClass): Boolean; +var + s, h: TCefString; +begin + CefLoadLibDefault; + s := CefString(SchemeName); + h := CefString(HostName); + Result := cef_register_scheme_handler_factory( + @s, + @h, + CefGetData(TCefSchemeHandlerFactoryOwn.Create(handler, SyncMainThread) as ICefBase)) <> 0; +end; + +function CefClearSchemeHandlerFactories: Boolean; +begin + CefLoadLibDefault; + Result := cef_clear_scheme_handler_factories <> 0; +end; + +function CefAddCrossOriginWhitelistEntry(const SourceOrigin, TargetProtocol, + TargetDomain: ustring; AllowTargetSubdomains: Boolean): Boolean; +var + so, tp, td: TCefString; +begin + CefLoadLibDefault; + so := CefString(SourceOrigin); + tp := CefString(TargetProtocol); + td := CefString(TargetDomain); + Result := cef_add_cross_origin_whitelist_entry(@so, @tp, @td, Ord(AllowTargetSubdomains)) <> 0; +end; + +function CefRemoveCrossOriginWhitelistEntry( + const SourceOrigin, TargetProtocol, TargetDomain: ustring; + AllowTargetSubdomains: Boolean): Boolean; +var + so, tp, td: TCefString; +begin + CefLoadLibDefault; + so := CefString(SourceOrigin); + tp := CefString(TargetProtocol); + td := CefString(TargetDomain); + Result := cef_remove_cross_origin_whitelist_entry(@so, @tp, @td, Ord(AllowTargetSubdomains)) <> 0; +end; + +function CefClearCrossOriginWhitelist: Boolean; +begin + CefLoadLibDefault; + Result := cef_clear_cross_origin_whitelist <> 0; +end; + +function CefRegisterExtension(const name, code: ustring; + const Handler: ICefv8Handler): Boolean; +var + n, c: TCefString; +begin + CefLoadLibDefault; + n := CefString(name); + c := CefString(code); + Result := cef_register_extension(@n, @c, CefGetData(handler)) <> 0; +end; + +function CefCurrentlyOn(ThreadId: TCefThreadId): Boolean; +begin + Result := cef_currently_on(ThreadId) <> 0; +end; + +procedure CefPostTask(ThreadId: TCefThreadId; const task: ICefTask); +begin + cef_post_task(ThreadId, CefGetData(task)); +end; + +procedure CefPostDelayedTask(ThreadId: TCefThreadId; const task: ICefTask; delayMs: Int64); +begin + cef_post_delayed_task(ThreadId, CefGetData(task), delayMs); +end; + +function CefGetData(const i: ICefBase): Pointer; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +begin + if i <> nil then + Result := i.Wrap else + Result := nil; +end; + +function CefGetObject(ptr: Pointer): TObject; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF} +begin + Dec(PByte(ptr), SizeOf(Pointer)); + Result := TObject(PPointer(ptr)^); +end; + +function CefParseUrl(const url: ustring; var parts: TUrlParts): Boolean; +var + u: TCefString; + p: TCefUrlParts; +begin + FillChar(p, sizeof(p), 0); + u := CefString(url); + Result := cef_parse_url(@u, p) <> 0; + if Result then + begin + //parts.spec := CefString(@p.spec); + parts.scheme := CefString(@p.scheme); + parts.username := CefString(@p.username); + parts.password := CefString(@p.password); + parts.host := CefString(@p.host); + parts.port := CefString(@p.port); + parts.path := CefString(@p.path); + parts.query := CefString(@p.query); + end; +end; + +function CefCreateUrl(var parts: TUrlParts): ustring; +var + p: TCefUrlParts; + u: TCefString; +begin + FillChar(p, sizeof(p), 0); + p.spec := CefString(parts.spec); + p.scheme := CefString(parts.scheme); + p.username := CefString(parts.username); + p.password := CefString(parts.password); + p.host := CefString(parts.host); + p.port := CefString(parts.port); + p.path := CefString(parts.path); + p.query := CefString(parts.query); + FillChar(u, SizeOf(u), 0); + if cef_create_url(@p, @u) <> 0 then + Result := CefString(@u) else + Result := ''; +end; + +function CefBrowserHostCreate(windowInfo: PCefWindowInfo; const client: ICefClient; + const url: ustring; const settings: PCefBrowserSettings; + const requestContext: ICefRequestContext): Boolean; +var + u: TCefString; +begin + CefLoadLibDefault; + u := CefString(url); + Result := cef_browser_host_create_browser(windowInfo, CefGetData(client), @u, + settings, CefGetData(requestContext)) <> 0; +end; + +function CefBrowserHostCreateSync(windowInfo: PCefWindowInfo; const client: ICefClient; + const url: ustring; const settings: PCefBrowserSettings; + const requestContext: ICefRequestContext): ICefBrowser; +var + u: TCefString; +begin + CefLoadLibDefault; + u := CefString(url); + Result := TCefBrowserRef.UnWrap(cef_browser_host_create_browser_sync(windowInfo, + CefGetData(client), @u, settings, CefGetData(requestContext))); +end; + +procedure CefVisitWebPluginInfo(const visitor: ICefWebPluginInfoVisitor); +begin + cef_visit_web_plugin_info(CefGetData(visitor)); +end; + +procedure CefVisitWebPluginInfoProc(const visitor: TCefWebPluginInfoVisitorProc); +begin + CefVisitWebPluginInfo(TCefFastWebPluginInfoVisitor.Create(visitor)); +end; + +procedure CefRefreshWebPlugins; +begin + cef_refresh_web_plugins(); +end; + +procedure CefAddWebPluginPath(const path: ustring); +var + p: TCefString; +begin + p := CefString(path); + cef_add_web_plugin_path(@p); +end; + +procedure CefAddWebPluginDirectory(const dir: ustring); +var + d: TCefString; +begin + d := CefString(dir); + cef_add_web_plugin_directory(@d); +end; + +procedure CefRemoveWebPluginPath(const path: ustring); +var + p: TCefString; +begin + p := CefString(path); + cef_remove_web_plugin_path(@p); +end; + +procedure CefUnregisterInternalWebPlugin(const path: ustring); +var + p: TCefString; +begin + p := CefString(path); + cef_unregister_internal_web_plugin(@p); +end; + +procedure CefForceWebPluginShutdown(const path: ustring); +var + p: TCefString; +begin + p := CefString(path); + cef_force_web_plugin_shutdown(@p); +end; + +procedure CefRegisterWebPluginCrash(const path: ustring); +var + p: TCefString; +begin + p := CefString(path); + cef_register_web_plugin_crash(@p); +end; + +procedure CefIsWebPluginUnstable(const path: ustring; + const callback: ICefWebPluginUnstableCallback); +var + p: TCefString; +begin + p := CefString(path); + cef_is_web_plugin_unstable(@p, CefGetData(callback)); +end; + +procedure CefIsWebPluginUnstableProc(const path: ustring; + const callback: TCefWebPluginIsUnstableProc); +begin + CefIsWebPluginUnstable(path, TCefFastWebPluginUnstableCallback.Create(callback)); +end; + +function CefGetPath(key: TCefPathKey; out path: ustring): Boolean; +var + p: TCefString; +begin + p := CefString(''); + Result := cef_get_path(key, @p) <> 0; + path := CefStringClearAndGet(p); +end; + +function CefBeginTracing(const client: ICefTraceClient; const categories: ustring): Boolean; +var + c: TCefString; +begin + c := CefString(categories); + Result := cef_begin_tracing(CefGetData(client), @c) <> 0; +end; + +function CefGetTraceBufferPercentFullAsync: Integer; +begin + Result := cef_get_trace_buffer_percent_full_async(); +end; + +function CefEndTracingAsync: Boolean; +begin + Result := cef_end_tracing_async() <> 0; +end; + +function CefNowFromSystemTraceTime: Int64; +begin + Result := cef_now_from_system_trace_time(); +end; + +function CefGetGeolocation(const callback: ICefGetGeolocationCallback): Boolean; +begin + Result := cef_get_geolocation(CefGetData(callback)) <> 0; +end; + +{$IFDEF MSWINDOWS} +function CefTimeToSystemTime(const dt: TCefTime): TSystemTime; +begin + Result.wYear := dt.year; + Result.wMonth := dt.month; + Result.wDayOfWeek := dt.day_of_week; + Result.wDay := dt.day_of_month; + Result.wHour := dt.hour; + Result.wMinute := dt.minute; + Result.wSecond := dt.second; + Result.wMilliseconds := dt.millisecond; +end; + +function SystemTimeToCefTime(const dt: TSystemTime): TCefTime; +begin + Result.year := dt.wYear; + Result.month := dt.wMonth; + Result.day_of_week := dt.wDayOfWeek; + Result.day_of_month := dt.wDay; + Result.hour := dt.wHour; + Result.minute := dt.wMinute; + Result.second := dt.wSecond; + Result.millisecond := dt.wMilliseconds; +end; + +function CefTimeToDateTime(const dt: TCefTime): TDateTime; +var + st: TSystemTime; +begin + st := CefTimeToSystemTime(dt); + SystemTimeToTzSpecificLocalTime(nil, @st, @st); + Result := SystemTimeToDateTime(st); +end; + +function DateTimeToCefTime(dt: TDateTime): TCefTime; +var + st: TSystemTime; +begin + DateTimeToSystemTime(dt, st); + TzSpecificLocalTimeToSystemTime(nil, @st, @st); + Result := SystemTimeToCefTime(st); +end; +{$ELSE} + +function CefTimeToDateTime(const dt: TCefTime): TDateTime; +begin + Result := + EncodeDate(dt.year, dt.month, dt.day_of_month) + + EncodeTime(dt.hour, dt.minute, dt.second, dt.millisecond); +end; + +function DateTimeToCefTime(dt: TDateTime): TCefTime; +var + Year, Month, Day, Hour, Min, Sec, MSec: Word; +begin + DecodeDate(dt, Year, Month, Day); + DecodeTime(dt, Hour, Min, Sec, MSec); + Result.year := Year; + Result.month := Month; + Result.day_of_week := DayOfWeek(dt); + Result.day_of_month := Month; + Result.hour := Hour; + Result.minute := Min; + Result.second := Sec; + Result.millisecond := MSec; +end; + +{$ENDIF} + +{ cef_base } + +function cef_base_add_ref(self: PCefBase): Integer; stdcall; +begin + Result := TCefBaseOwn(CefGetObject(self))._AddRef; +end; + +function cef_base_release(self: PCefBase): Integer; stdcall; +begin + Result := TCefBaseOwn(CefGetObject(self))._Release; +end; + +function cef_base_get_refct(self: PCefBase): Integer; stdcall; +begin + Result := TCefBaseOwn(CefGetObject(self)).FRefCount; +end; + +function cef_base_add_ref_owned(self: PCefBase): Integer; stdcall; +begin + Result := 1; +end; + +function cef_base_release_owned(self: PCefBase): Integer; stdcall; +begin + Result := 1; +end; + +function cef_base_get_refct_owned(self: PCefBase): Integer; stdcall; +begin + Result := 1; +end; + +{ cef_client } + +function cef_client_get_context_menu_handler(self: PCefClient): PCefContextMenuHandler; stdcall; +begin + with TCefClientOwn(CefGetObject(self)) do + Result := CefGetData(GetContextMenuHandler); +end; + +function cef_client_get_dialog_handler(self: PCefClient): PCefDialogHandler; stdcall; +begin + with TCefClientOwn(CefGetObject(self)) do + Result := CefGetData(GetDialogHandler); +end; + +function cef_client_get_display_handler(self: PCefClient): PCefDisplayHandler; stdcall; +begin + with TCefClientOwn(CefGetObject(self)) do + Result := CefGetData(GetDisplayHandler); +end; + +function cef_client_get_download_handler(self: PCefClient): PCefDownloadHandler; stdcall; +begin + with TCefClientOwn(CefGetObject(self)) do + Result := CefGetData(GetDownloadHandler); +end; + +function cef_client_get_drag_handler(self: PCefClient): PCefDragHandler; stdcall; +begin + with TCefClientOwn(CefGetObject(self)) do + Result := CefGetData(GetDragHandler); +end; + +function cef_client_get_focus_handler(self: PCefClient): PCefFocusHandler; stdcall; +begin + with TCefClientOwn(CefGetObject(self)) do + Result := CefGetData(GetFocusHandler); +end; + +function cef_client_get_geolocation_handler(self: PCefClient): PCefGeolocationHandler; stdcall; +begin + with TCefClientOwn(CefGetObject(self)) do + Result := CefGetData(GetGeolocationHandler); +end; + +function cef_client_get_jsdialog_handler(self: PCefClient): PCefJsDialogHandler; stdcall; +begin + with TCefClientOwn(CefGetObject(self)) do + Result := CefGetData(GetJsdialogHandler); +end; + +function cef_client_get_keyboard_handler(self: PCefClient): PCefKeyboardHandler; stdcall; +begin + with TCefClientOwn(CefGetObject(self)) do + Result := CefGetData(GetKeyboardHandler); +end; + +function cef_client_get_life_span_handler(self: PCefClient): PCefLifeSpanHandler; stdcall; +begin + with TCefClientOwn(CefGetObject(self)) do + Result := CefGetData(GetLifeSpanHandler); +end; + +function cef_client_get_load_handler(self: PCefClient): PCefLoadHandler; stdcall; +begin + with TCefClientOwn(CefGetObject(self)) do + Result := CefGetData(GetLoadHandler); +end; + +function cef_client_get_get_render_handler(self: PCefClient): PCefRenderHandler; stdcall; +begin + with TCefClientOwn(CefGetObject(self)) do + Result := CefGetData(GetRenderHandler); +end; + +function cef_client_get_request_handler(self: PCefClient): PCefRequestHandler; stdcall; +begin + with TCefClientOwn(CefGetObject(self)) do + Result := CefGetData(GetRequestHandler); +end; + +function cef_client_on_process_message_received(self: PCefClient; browser: PCefBrowser; + source_process: TCefProcessId; message: PCefProcessMessage): Integer; stdcall; +begin + with TCefClientOwn(CefGetObject(self)) do + Result := Ord(OnProcessMessageReceived(TCefBrowserRef.UnWrap(browser), source_process, + TCefProcessMessageRef.UnWrap(message))); +end; + +{ cef_geolocation_handler } + +procedure cef_geolocation_handler_on_request_geolocation_permission(self: PCefGeolocationHandler; + browser: PCefBrowser; const requesting_url: PCefString; request_id: Integer; + callback: PCefGeolocationCallback); stdcall; +begin + with TCefGeolocationHandlerOwn(CefGetObject(self)) do + OnRequestGeolocationPermission(TCefBrowserRef.UnWrap(browser), CefString(requesting_url), + request_id, TCefGeolocationCallbackRef.UnWrap(callback)); +end; + +procedure cef_geolocation_handler_on_cancel_geolocation_permission(self: PCefGeolocationHandler; + browser: PCefBrowser; const requesting_url: PCefString; request_id: Integer); stdcall; +begin + with TCefGeolocationHandlerOwn(CefGetObject(self)) do + OnCancelGeolocationPermission(TCefBrowserRef.UnWrap(browser), CefString(requesting_url), request_id); +end; + +{ cef_life_span_handler } + +//function cef_life_span_handler_on_before_popup(self: PCefLifeSpanHandler; parentBrowser: PCefBrowser; +// const popupFeatures: PCefPopupFeatures; windowInfo: PCefWindowInfo; const url: PCefString; +// var client: PCefClient; settings: PCefBrowserSettings): Integer; stdcall; +function cef_life_span_handler_on_before_popup(self: PCefLifeSpanHandler; + browser: PCefBrowser; frame: PCefFrame; const target_url, target_frame_name: PCefString; + const popupFeatures: PCefPopupFeatures; windowInfo: PCefWindowInfo; var client: PCefClient; + settings: PCefBrowserSettings; no_javascript_access: PInteger): Integer; stdcall; +var + _url, _frame: ustring; + _client: ICefClient; + _nojs: Boolean; +begin + _url := CefString(target_url); + _frame := CefString(target_frame_name); + _client := TCefClientOwn(CefGetObject(client)) as ICefClient; + _nojs := no_javascript_access^ <> 0; + with TCefLifeSpanHandlerOwn(CefGetObject(self)) do + Result := Ord(OnBeforePopup( + TCefBrowserRef.UnWrap(browser), + TCefFrameRef.UnWrap(frame), + _url, + _frame, + popupFeatures^, + windowInfo^, + _client, + settings^, + _nojs + )); + CefStringSet(target_url, _url); + CefStringSet(target_frame_name, _frame); + client := CefGetData(_client); + no_javascript_access^ := Ord(_nojs); + _client := nil; +end; + +procedure cef_life_span_handler_on_after_created(self: PCefLifeSpanHandler; browser: PCefBrowser); stdcall; +begin + with TCefLifeSpanHandlerOwn(CefGetObject(self)) do + OnAfterCreated(TCefBrowserRef.UnWrap(browser)); +end; + +procedure cef_life_span_handler_on_before_close(self: PCefLifeSpanHandler; browser: PCefBrowser); stdcall; +begin + with TCefLifeSpanHandlerOwn(CefGetObject(self)) do + OnBeforeClose(TCefBrowserRef.UnWrap(browser)); +end; + +function cef_life_span_handler_run_modal(self: PCefLifeSpanHandler; browser: PCefBrowser): Integer; stdcall; +begin + with TCefLifeSpanHandlerOwn(CefGetObject(self)) do + Result := Ord(RunModal(TCefBrowserRef.UnWrap(browser))); +end; + +function cef_life_span_handler_do_close(self: PCefLifeSpanHandler; browser: PCefBrowser): Integer; stdcall; +begin + + with TCefLifeSpanHandlerOwn(CefGetObject(self)) do + Result := Ord(DoClose(TCefBrowserRef.UnWrap(browser))); +end; + + +{ cef_load_handler } + +procedure cef_load_handler_on_loading_state_change(self: PCefLoadHandler; + browser: PCefBrowser; isLoading, canGoBack, canGoForward: Integer); stdcall; +begin + with TCefLoadHandlerOwn(CefGetObject(self)) do + OnLoadingStateChange(TCefBrowserRef.UnWrap(browser), + isLoading <> 0, canGoBack <> 0, canGoForward <> 0); +end; + +procedure cef_load_handler_on_load_start(self: PCefLoadHandler; + browser: PCefBrowser; frame: PCefFrame); stdcall; +begin + with TCefLoadHandlerOwn(CefGetObject(self)) do + OnLoadStart(TCefBrowserRef.UnWrap(browser), TCefFrameRef.UnWrap(frame)); +end; + +procedure cef_load_handler_on_load_end(self: PCefLoadHandler; + browser: PCefBrowser; frame: PCefFrame; httpStatusCode: Integer); stdcall; +begin + with TCefLoadHandlerOwn(CefGetObject(self)) do + OnLoadEnd(TCefBrowserRef.UnWrap(browser), TCefFrameRef.UnWrap(frame), httpStatusCode); +end; + +procedure cef_load_handler_on_load_error(self: PCefLoadHandler; browser: PCefBrowser; + frame: PCefFrame; errorCode: Integer; const errorText, failedUrl: PCefString); stdcall; +begin + with TCefLoadHandlerOwn(CefGetObject(self)) do + OnLoadError(TCefBrowserRef.UnWrap(browser), TCefFrameRef.UnWrap(frame), + errorCode, CefString(errorText), CefString(failedUrl)); +end; + +{ cef_request_handler } + + function cef_request_handler_on_before_browse(self: PCefRequestHandler; + browser: PCefBrowser; frame: PCefFrame; request: PCefRequest; + is_redirect: Integer): Integer; stdcall; + begin + with TCefRequestHandlerOwn(CefGetObject(self)) do + Result := Ord(OnBeforeBrowse( + TCefBrowserRef.UnWrap(browser), + TCefFrameRef.UnWrap(frame), + TCefRequestRef.UnWrap(request), + is_redirect <> 0)); +end; + + function cef_request_handler_on_before_resource_load(self: PCefRequestHandler; + browser: PCefBrowser; frame: PCefFrame; request: PCefRequest): Integer; stdcall; +begin + with TCefRequestHandlerOwn(CefGetObject(self)) do + Result := Ord(OnBeforeResourceLoad( + TCefBrowserRef.UnWrap(browser), + TCefFrameRef.UnWrap(frame), + TCefRequestRef.UnWrap(request))); +end; + +function cef_request_handler_get_resource_handler(self: PCefRequestHandler; + browser: PCefBrowser; frame: PCefFrame; request: PCefRequest): PCefResourceHandler; stdcall; +begin + with TCefRequestHandlerOwn(CefGetObject(self)) do + Result := CefGetData(GetResourceHandler(TCefBrowserRef.UnWrap(browser), + TCefFrameRef.UnWrap(frame), TCefRequestRef.UnWrap(request))); +end; + +procedure cef_request_handler_on_resource_redirect(self: PCefRequestHandler; + browser: PCefBrowser; frame: PCefFrame; const old_url: PCefString; new_url: PCefString); stdcall; +var + url: ustring; +begin + url := CefString(new_url); + with TCefRequestHandlerOwn(CefGetObject(self)) do + OnResourceRedirect(TCefBrowserRef.UnWrap(browser), TCefFrameRef.UnWrap(frame), + CefString(old_url), url); + if url <> '' then + CefStringSet(new_url, url); +end; + +function cef_request_handler_get_auth_credentials(self: PCefRequestHandler; + browser: PCefBrowser; frame: PCefFrame; isProxy: Integer; const host: PCefString; + port: Integer; const realm, scheme: PCefString; callback: PCefAuthCallback): Integer; stdcall; +begin + with TCefRequestHandlerOwn(CefGetObject(self)) do + Result := Ord(GetAuthCredentials( + TCefBrowserRef.UnWrap(browser), TCefFrameRef.UnWrap(frame), isProxy <> 0, + CefString(host), port, CefString(realm), CefString(scheme), TCefAuthCallbackRef.UnWrap(callback))); +end; + +function cef_request_handler_on_quota_request(self: PCefRequestHandler; browser: PCefBrowser; + const origin_url: PCefString; new_size: Int64; callback: PCefQuotaCallback): Integer; stdcall; +begin + with TCefRequestHandlerOwn(CefGetObject(self)) do + Result := Ord(OnQuotaRequest(TCefBrowserRef.UnWrap(browser), + CefString(origin_url), new_size, TCefQuotaCallbackRef.UnWrap(callback))); +end; + +procedure cef_request_handler_on_protocol_execution(self: PCefRequestHandler; + browser: PCefBrowser; const url: PCefString; allow_os_execution: PInteger); stdcall; +var + allow: Boolean; +begin + allow := allow_os_execution^ <> 0; + with TCefRequestHandlerOwn(CefGetObject(self)) do + OnProtocolExecution( + TCefBrowserRef.UnWrap(browser), + CefString(url), allow); + allow_os_execution^ := Ord(allow); +end; + +function cef_request_handler_on_before_plugin_load(self: PCefRequestHandler; browser: PCefBrowser; + const url, policy_url: PCefString; info: PCefWebPluginInfo): Integer; stdcall; +begin + with TCefRequestHandlerOwn(CefGetObject(self)) do + Result := Ord(OnBeforePluginLoad(TCefBrowserRef.UnWrap(browser), + CefString(url), CefString(policy_url), TCefWebPluginInfoRef.UnWrap(info))); +end; + +function cef_request_handler_on_certificate_error(self: PCefRequestHandler; + cert_error: TCefErrorCode; const request_url: PCefString; + callback: PCefAllowCertificateErrorCallback): Integer; stdcall; +begin + with TCefRequestHandlerOwn(CefGetObject(self)) do + Result := Ord(OnCertificateError(cert_error, CefString(request_url), + TCefAllowCertificateErrorCallbackRef.UnWrap(callback))); +end; + +procedure cef_request_handler_on_plugin_crashed(self: PCefRequestHandler; + browser: PCefBrowser; const plugin_path: PCefString); stdcall; +begin + with TCefRequestHandlerOwn(CefGetObject(self)) do + OnPluginCrashed(TCefBrowserRef.UnWrap(browser), CefString(plugin_path)); +end; + +procedure cef_request_handler_on_render_process_terminated(self: PCefRequestHandler; + browser: PCefBrowser; status: TCefTerminationStatus); stdcall; +begin + with TCefRequestHandlerOwn(CefGetObject(self)) do + OnRenderProcessTerminated(TCefBrowserRef.UnWrap(browser), status); +end; + +{ cef_display_handler } + +procedure cef_display_handler_on_address_change(self: PCefDisplayHandler; + browser: PCefBrowser; frame: PCefFrame; const url: PCefString); stdcall; +begin + with TCefDisplayHandlerOwn(CefGetObject(self)) do + OnAddressChange( + TCefBrowserRef.UnWrap(browser), + TCefFrameRef.UnWrap(frame), + cefstring(url)) +end; + +procedure cef_display_handler_on_title_change(self: PCefDisplayHandler; + browser: PCefBrowser; const title: PCefString); stdcall; +begin + with TCefDisplayHandlerOwn(CefGetObject(self)) do + OnTitleChange(TCefBrowserRef.UnWrap(browser), CefString(title)); +end; + +function cef_display_handler_on_tooltip(self: PCefDisplayHandler; + browser: PCefBrowser; text: PCefString): Integer; stdcall; +var + t: ustring; +begin + t := CefStringClearAndGet(text^); + with TCefDisplayHandlerOwn(CefGetObject(self)) do + Result := Ord(OnTooltip( + TCefBrowserRef.UnWrap(browser), t)); + text^ := CefStringAlloc(t); +end; + +procedure cef_display_handler_on_status_message(self: PCefDisplayHandler; + browser: PCefBrowser; const value: PCefString); stdcall; +begin + with TCefDisplayHandlerOwn(CefGetObject(self)) do + OnStatusMessage(TCefBrowserRef.UnWrap(browser), CefString(value)); +end; + +function cef_display_handler_on_console_message(self: PCefDisplayHandler; + browser: PCefBrowser; const message: PCefString; + const source: PCefString; line: Integer): Integer; stdcall; +begin + with TCefDisplayHandlerOwn(CefGetObject(self)) do + Result := Ord(OnConsoleMessage(TCefBrowserRef.UnWrap(browser), + CefString(message), CefString(source), line)); +end; + +{ cef_focus_handler } + +procedure cef_focus_handler_on_take_focus(self: PCefFocusHandler; + browser: PCefBrowser; next: Integer); stdcall; +begin + with TCefFocusHandlerOwn(CefGetObject(self)) do + OnTakeFocus(TCefBrowserRef.UnWrap(browser), next <> 0); +end; + +function cef_focus_handler_on_set_focus(self: PCefFocusHandler; + browser: PCefBrowser; source: TCefFocusSource): Integer; stdcall; +begin + with TCefFocusHandlerOwn(CefGetObject(self)) do + Result := Ord(OnSetFocus(TCefBrowserRef.UnWrap(browser), source)) +end; + +procedure cef_focus_handler_on_got_focus(self: PCefFocusHandler; browser: PCefBrowser); stdcall; +begin + with TCefFocusHandlerOwn(CefGetObject(self)) do + OnGotFocus(TCefBrowserRef.UnWrap(browser)); +end; + +{ cef_keyboard_handler } + +function cef_keyboard_handler_on_pre_key_event(self: PCefKeyboardHandler; + browser: PCefBrowser; const event: PCefKeyEvent; + os_event: TCefEventHandle; is_keyboard_shortcut: PInteger): Integer; stdcall; +var + ks: Boolean; +begin + ks := is_keyboard_shortcut^ <> 0; + with TCefKeyboardHandlerOwn(CefGetObject(self)) do + Result := Ord(OnPreKeyEvent(TCefBrowserRef.UnWrap(browser), event, os_event, ks)); + is_keyboard_shortcut^ := Ord(ks); +end; + +function cef_keyboard_handler_on_key_event(self: PCefKeyboardHandler; + browser: PCefBrowser; const event: PCefKeyEvent; os_event: TCefEventHandle): Integer; stdcall; +begin + with TCefKeyboardHandlerOwn(CefGetObject(self)) do + Result := Ord(OnKeyEvent(TCefBrowserRef.UnWrap(browser), event, os_event)); +end; + +{ cef_jsdialog_handler } + +function cef_jsdialog_handler_on_jsdialog(self: PCefJsDialogHandler; + browser: PCefBrowser; const origin_url, accept_lang: PCefString; + dialog_type: TCefJsDialogType; const message_text, default_prompt_text: PCefString; + callback: PCefJsDialogCallback; suppress_message: PInteger): Integer; stdcall; +var + sm: Boolean; +begin + sm := suppress_message^ <> 0; + with TCefJsDialogHandlerOwn(CefGetObject(self)) do + Result := Ord(OnJsdialog(TCefBrowserRef.UnWrap(browser), CefString(origin_url), + CefString(accept_lang), dialog_type, CefString(message_text), + CefString(default_prompt_text), TCefJsDialogCallbackRef.UnWrap(callback), sm)); + suppress_message^ := Ord(sm); +end; + +function cef_jsdialog_handler_on_before_unload_dialog(self: PCefJsDialogHandler; + browser: PCefBrowser; const message_text: PCefString; is_reload: Integer; + callback: PCefJsDialogCallback): Integer; stdcall; +begin + with TCefJsDialogHandlerOwn(CefGetObject(self)) do + Result := Ord(OnBeforeUnloadDialog(TCefBrowserRef.UnWrap(browser), CefString(message_text), + is_reload <> 0, TCefJsDialogCallbackRef.UnWrap(callback))); +end; + +procedure cef_jsdialog_handler_on_reset_dialog_state(self: PCefJsDialogHandler; + browser: PCefBrowser); stdcall; +begin + with TCefJsDialogHandlerOwn(CefGetObject(self)) do + OnResetDialogState(TCefBrowserRef.UnWrap(browser)); +end; + +procedure cef_jsdialog_handler_on_dialog_closed(self: PCefJsDialogHandler; + browser: PCefBrowser); stdcall; +begin + with TCefJsDialogHandlerOwn(CefGetObject(self)) do + OnDialogClosed(TCefBrowserRef.UnWrap(browser)); +end; + + +{ cef_context_menu_handler } + +procedure cef_context_menu_handler_on_before_context_menu(self: PCefContextMenuHandler; + browser: PCefBrowser; frame: PCefFrame; params: PCefContextMenuParams; + model: PCefMenuModel); stdcall; +begin + with TCefContextMenuHandlerOwn(CefGetObject(self)) do + OnBeforeContextMenu(TCefBrowserRef.UnWrap(browser), TCefFrameRef.UnWrap(frame), + TCefContextMenuParamsRef.UnWrap(params), TCefMenuModelRef.UnWrap(model)); +end; + +function cef_context_menu_handler_on_context_menu_command(self: PCefContextMenuHandler; + browser: PCefBrowser; frame: PCefFrame; params: PCefContextMenuParams; + command_id: Integer; event_flags: Integer): Integer; stdcall; +begin + with TCefContextMenuHandlerOwn(CefGetObject(self)) do + Result := Ord(OnContextMenuCommand(TCefBrowserRef.UnWrap(browser), TCefFrameRef.UnWrap(frame), + TCefContextMenuParamsRef.UnWrap(params), command_id, TCefEventFlags(Pointer(@event_flags)^))); +end; + +procedure cef_context_menu_handler_on_context_menu_dismissed(self: PCefContextMenuHandler; + browser: PCefBrowser; frame: PCefFrame); stdcall; +begin + with TCefContextMenuHandlerOwn(CefGetObject(self)) do + OnContextMenuDismissed(TCefBrowserRef.UnWrap(browser), TCefFrameRef.UnWrap(frame)); +end; + +{ cef_stream_reader } + +function cef_stream_reader_read(self: PCefReadHandler; ptr: Pointer; size, n: NativeUInt): NativeUInt; stdcall; +begin + with TCefCustomStreamReader(CefGetObject(self)) do + Result := Read(ptr, size, n); +end; + +function cef_stream_reader_seek(self: PCefReadHandler; offset: Int64; whence: Integer): Integer; stdcall; +begin + with TCefCustomStreamReader(CefGetObject(self)) do + Result := Seek(offset, whence); +end; + +function cef_stream_reader_tell(self: PCefReadHandler): Int64; stdcall; +begin + with TCefCustomStreamReader(CefGetObject(self)) do + Result := Tell; +end; + +function cef_stream_reader_eof(self: PCefReadHandler): Integer; stdcall; +begin + with TCefCustomStreamReader(CefGetObject(self)) do + Result := Ord(eof); +end; + +{ cef_post_data_element } + +function cef_post_data_element_is_read_only(self: PCefPostDataElement): Integer; stdcall; +begin + with TCefPostDataElementOwn(CefGetObject(self)) do + Result := Ord(IsReadOnly) +end; + +procedure cef_post_data_element_set_to_empty(self: PCefPostDataElement); stdcall; +begin + with TCefPostDataElementOwn(CefGetObject(self)) do + SetToEmpty; +end; + +procedure cef_post_data_element_set_to_file(self: PCefPostDataElement; const fileName: PCefString); stdcall; +begin + with TCefPostDataElementOwn(CefGetObject(self)) do + SetToFile(CefString(fileName)); +end; + +procedure cef_post_data_element_set_to_bytes(self: PCefPostDataElement; size: NativeUInt; const bytes: Pointer); stdcall; +begin + with TCefPostDataElementOwn(CefGetObject(self)) do + SetToBytes(size, bytes); +end; + +function cef_post_data_element_get_type(self: PCefPostDataElement): TCefPostDataElementType; stdcall; +begin + with TCefPostDataElementOwn(CefGetObject(self)) do + Result := GetType; +end; + +function cef_post_data_element_get_file(self: PCefPostDataElement): PCefStringUserFree; stdcall; +begin + with TCefPostDataElementOwn(CefGetObject(self)) do + Result := CefUserFreeString(GetFile); +end; + +function cef_post_data_element_get_bytes_count(self: PCefPostDataElement): NativeUInt; stdcall; +begin + with TCefPostDataElementOwn(CefGetObject(self)) do + Result := GetBytesCount; +end; + +function cef_post_data_element_get_bytes(self: PCefPostDataElement; size: NativeUInt; bytes: Pointer): NativeUInt; stdcall; +begin + with TCefPostDataElementOwn(CefGetObject(self)) do + Result := GetBytes(size, bytes) +end; + +{ cef_v8_handler } + +function cef_v8_handler_execute(self: PCefv8Handler; + const name: PCefString; obj: PCefv8Value; argumentsCount: NativeUInt; + const arguments: PPCefV8Value; var retval: PCefV8Value; + var exception: TCefString): Integer; stdcall; +var + args: TCefv8ValueArray; + i: NativeInt; + ret: ICefv8Value; + exc: ustring; +begin + SetLength(args, argumentsCount); + for i := 0 to argumentsCount - 1 do + args[i] := TCefv8ValueRef.UnWrap(arguments[i]); + + Result := -Ord(TCefv8HandlerOwn(CefGetObject(self)).Execute( + CefString(name), TCefv8ValueRef.UnWrap(obj), args, ret, exc)); + retval := CefGetData(ret); + ret := nil; + exception := CefString(exc); +end; + +{ cef_task } + +procedure cef_task_execute(self: PCefTask); stdcall; +begin + TCefTaskOwn(CefGetObject(self)).Execute(); +end; + +{ cef_download_handler } + +procedure cef_download_handler_on_before_download(self: PCefDownloadHandler; + browser: PCefBrowser; download_item: PCefDownloadItem; + const suggested_name: PCefString; callback: PCefBeforeDownloadCallback); stdcall; +begin + TCefDownloadHandlerOwn(CefGetObject(self)). + OnBeforeDownload(TCefBrowserRef.UnWrap(browser), + TCefDownLoadItemRef.UnWrap(download_item), CefString(suggested_name), + TCefBeforeDownloadCallbackRef.UnWrap(callback)); +end; + +procedure cef_download_handler_on_download_updated(self: PCefDownloadHandler; + browser: PCefBrowser; download_item: PCefDownloadItem; callback: PCefDownloadItemCallback); stdcall; +begin + TCefDownloadHandlerOwn(CefGetObject(self)). + OnDownloadUpdated(TCefBrowserRef.UnWrap(browser), + TCefDownLoadItemRef.UnWrap(download_item), + TCefDownloadItemCallbackRef.UnWrap(callback)); +end; + +{ cef_dom_visitor } + +procedure cef_dom_visitor_visite(self: PCefDomVisitor; document: PCefDomDocument); stdcall; +begin + TCefDomVisitorOwn(CefGetObject(self)).visit(TCefDomDocumentRef.UnWrap(document)); +end; + +{ cef_dom_event_listener } + +procedure cef_dom_event_listener_handle_event(self: PCefDomEventListener; event: PCefDomEvent); stdcall; +begin + TCefDomEventListenerOwn(CefGetObject(self)).HandleEvent(TCefDomEventRef.UnWrap(event)); +end; + +{ cef_v8_accessor } + +function cef_v8_accessor_get(self: PCefV8Accessor; const name: PCefString; + obj: PCefv8Value; out retval: PCefv8Value; exception: PCefString): Integer; stdcall; +var + ret: ICefv8Value; +begin + Result := Ord(TCefV8AccessorOwn(CefGetObject(self)).Get(CefString(name), + TCefv8ValueRef.UnWrap(obj), ret, CefString(exception))); + retval := CefGetData(ret); +end; + + +function cef_v8_accessor_put(self: PCefV8Accessor; const name: PCefString; + obj: PCefv8Value; value: PCefv8Value; exception: PCefString): Integer; stdcall; +begin + Result := Ord(TCefV8AccessorOwn(CefGetObject(self)).Put(CefString(name), + TCefv8ValueRef.UnWrap(obj), TCefv8ValueRef.UnWrap(value), CefString(exception))); +end; + +{ cef_cookie_visitor } + +function cef_cookie_visitor_visit(self: PCefCookieVisitor; const cookie: PCefCookie; + count, total: Integer; deleteCookie: PInteger): Integer; stdcall; +var + delete: Boolean; + exp: TDateTime; +begin + delete := False; + if cookie.has_expires then + exp := CefTimeToDateTime(cookie.expires) else + exp := 0; + Result := Ord(TCefCookieVisitorOwn(CefGetObject(self)).visit(CefString(@cookie.name), + CefString(@cookie.value), CefString(@cookie.domain), CefString(@cookie.path), + cookie.secure, cookie.httponly, cookie.has_expires, CefTimeToDateTime(cookie.creation), + CefTimeToDateTime(cookie.last_access), exp, count, total, delete)); + deleteCookie^ := Ord(delete); +end; + +{ cef_resource_bundle_handler } + +function cef_resource_bundle_handler_get_localized_string(self: PCefResourceBundleHandler; + message_id: Integer; string_val: PCefString): Integer; stdcall; +var + str: ustring; +begin + Result := Ord(TCefResourceBundleHandlerOwn(CefGetObject(self)). + GetLocalizedString(message_id, str)); + if Result <> 0 then + string_val^ := CefString(str); +end; + +function cef_resource_bundle_handler_get_data_resource(self: PCefResourceBundleHandler; + resource_id: Integer; var data: Pointer; var data_size: NativeUInt): Integer; stdcall; +begin + Result := Ord(TCefResourceBundleHandlerOwn(CefGetObject(self)). + GetDataResource(resource_id, data, data_size)); +end; + +{ cef_app } + +procedure cef_app_on_before_command_line_processing(self: PCefApp; + const process_type: PCefString; command_line: PCefCommandLine); stdcall; +begin + with TCefAppOwn(CefGetObject(self)) do + OnBeforeCommandLineProcessing(CefString(process_type), + TCefCommandLineRef.UnWrap(command_line)); +end; + +procedure cef_app_on_register_custom_schemes(self: PCefApp; registrar: PCefSchemeRegistrar); stdcall; +begin + with TCefAppOwn(CefGetObject(self)) do + OnRegisterCustomSchemes(TCefSchemeRegistrarRef.UnWrap(registrar)); +end; + +function cef_app_get_resource_bundle_handler(self: PCefApp): PCefResourceBundleHandler; stdcall; +begin + Result := CefGetData(TCefAppOwn(CefGetObject(self)).GetResourceBundleHandler()); +end; + +function cef_app_get_browser_process_handler(self: PCefApp): PCefBrowserProcessHandler; stdcall; +begin + Result := CefGetData(TCefAppOwn(CefGetObject(self)).GetBrowserProcessHandler()); +end; + +function cef_app_get_render_process_handler(self: PCefApp): PCefRenderProcessHandler; stdcall; +begin + Result := CefGetData(TCefAppOwn(CefGetObject(self)).GetRenderProcessHandler()); +end; + +{ cef_string_visitor_visit } + +procedure cef_string_visitor_visit(self: PCefStringVisitor; const str: PCefString); stdcall; +begin + TCefStringVisitorOwn(CefGetObject(self)).Visit(CefString(str)); +end; + +{ cef_browser_process_handler } + +procedure cef_browser_process_handler_on_context_initialized(self: PCefBrowserProcessHandler); stdcall; +begin + with TCefBrowserProcessHandlerOwn(CefGetObject(self)) do + OnContextInitialized; +end; + +procedure cef_browser_process_handler_on_before_child_process_launch( + self: PCefBrowserProcessHandler; command_line: PCefCommandLine); stdcall; +begin + with TCefBrowserProcessHandlerOwn(CefGetObject(self)) do + OnBeforeChildProcessLaunch(TCefCommandLineRef.UnWrap(command_line)); +end; + +procedure cef_browser_process_handler_on_render_process_thread_created( + self: PCefBrowserProcessHandler; extra_info: PCefListValue); stdcall; +begin + with TCefBrowserProcessHandlerOwn(CefGetObject(self)) do + OnRenderProcessThreadCreated(TCefListValueRef.UnWrap(extra_info)); +end; + +{ cef_render_process_handler } + +procedure cef_render_process_handler_on_render_thread_created( + self: PCefRenderProcessHandler; extra_info: PCefListValue); stdcall; +begin + with TCefRenderProcessHandlerOwn(CefGetObject(Self)) do + OnRenderThreadCreated(TCefListValueRef.UnWrap(extra_info)); +end; + +procedure cef_render_process_handler_on_web_kit_initialized(self: PCefRenderProcessHandler); stdcall; +begin + with TCefRenderProcessHandlerOwn(CefGetObject(Self)) do + OnWebKitInitialized; +end; + +procedure cef_render_process_handler_on_browser_created(self: PCefRenderProcessHandler; + browser: PCefBrowser); stdcall; +begin + with TCefRenderProcessHandlerOwn(CefGetObject(Self)) do + OnBrowserCreated(TCefBrowserRef.UnWrap(browser)); +end; + +procedure cef_render_process_handler_on_browser_destroyed(self: PCefRenderProcessHandler; + browser: PCefBrowser); stdcall; +begin + with TCefRenderProcessHandlerOwn(CefGetObject(Self)) do + OnBrowserDestroyed(TCefBrowserRef.UnWrap(browser)); +end; + +function cef_render_process_handler_get_load_handler(self: PCefRenderProcessHandler): PCefLoadHandler; stdcall; +begin + with TCefRenderProcessHandlerOwn(CefGetObject(Self)) do + Result := CefGetData(GetLoadHandler()); +end; + +function cef_render_process_handler_on_before_navigation(self: PCefRenderProcessHandler; + browser: PCefBrowser; frame: PCefFrame; request: PCefRequest; + navigation_type: TCefNavigationType; is_redirect: Integer): Integer; stdcall; +begin + with TCefRenderProcessHandlerOwn(CefGetObject(Self)) do + Result := Ord(OnBeforeNavigation(TCefBrowserRef.UnWrap(browser), + TCefFrameRef.UnWrap(frame), TCefRequestRef.UnWrap(request), + navigation_type, is_redirect <> 0)); +end; + +procedure cef_render_process_handler_on_context_created(self: PCefRenderProcessHandler; + browser: PCefBrowser; frame: PCefFrame; context: PCefv8Context); stdcall; +begin + with TCefRenderProcessHandlerOwn(CefGetObject(Self)) do + OnContextCreated(TCefBrowserRef.UnWrap(browser), TCefFrameRef.UnWrap(frame), TCefv8ContextRef.UnWrap(context)); +end; + +procedure cef_render_process_handler_on_context_released(self: PCefRenderProcessHandler; + browser: PCefBrowser; frame: PCefFrame; context: PCefv8Context); stdcall; +begin + with TCefRenderProcessHandlerOwn(CefGetObject(Self)) do + OnContextReleased(TCefBrowserRef.UnWrap(browser), TCefFrameRef.UnWrap(frame), TCefv8ContextRef.UnWrap(context)); +end; + +procedure cef_render_process_handler_on_uncaught_exception(self: PCefRenderProcessHandler; + browser: PCefBrowser; frame: PCefFrame; context: PCefv8Context; + exception: PCefV8Exception; stackTrace: PCefV8StackTrace); stdcall; +begin + with TCefRenderProcessHandlerOwn(CefGetObject(Self)) do + OnUncaughtException(TCefBrowserRef.UnWrap(browser), TCefFrameRef.UnWrap(frame), + TCefv8ContextRef.UnWrap(context), TCefV8ExceptionRef.UnWrap(exception), + TCefV8StackTraceRef.UnWrap(stackTrace)); +end; + +procedure cef_render_process_handler_on_focused_node_changed(self: PCefRenderProcessHandler; + browser: PCefBrowser; frame: PCefFrame; node: PCefDomNode); stdcall; +begin + with TCefRenderProcessHandlerOwn(CefGetObject(Self)) do + OnFocusedNodeChanged(TCefBrowserRef.UnWrap(browser), TCefFrameRef.UnWrap(frame), + TCefDomNodeRef.UnWrap(node)); +end; + +function cef_render_process_handler_on_process_message_received(self: PCefRenderProcessHandler; + browser: PCefBrowser; source_process: TCefProcessId; + message: PCefProcessMessage): Integer; stdcall; +begin + with TCefRenderProcessHandlerOwn(CefGetObject(Self)) do + Result := Ord(OnProcessMessageReceived(TCefBrowserRef.UnWrap(browser), source_process, + TCefProcessMessageRef.UnWrap(message))); +end; + +{ cef_url_request_client } + +procedure cef_url_request_client_on_request_complete(self: PCefUrlRequestClient; request: PCefUrlRequest); stdcall; +begin + with TCefUrlrequestClientOwn(CefGetObject(self)) do + OnRequestComplete(TCefUrlRequestRef.UnWrap(request)); +end; + +procedure cef_url_request_client_on_upload_progress(self: PCefUrlRequestClient; + request: PCefUrlRequest; current, total: UInt64); stdcall; +begin + with TCefUrlrequestClientOwn(CefGetObject(self)) do + OnUploadProgress(TCefUrlRequestRef.UnWrap(request), current, total); +end; + +procedure cef_url_request_client_on_download_progress(self: PCefUrlRequestClient; + request: PCefUrlRequest; current, total: UInt64); stdcall; +begin + with TCefUrlrequestClientOwn(CefGetObject(self)) do + OnDownloadProgress(TCefUrlRequestRef.UnWrap(request), current, total); +end; + +procedure cef_url_request_client_on_download_data(self: PCefUrlRequestClient; + request: PCefUrlRequest; const data: Pointer; data_length: NativeUInt); stdcall; +begin + with TCefUrlrequestClientOwn(CefGetObject(self)) do + OnDownloadData(TCefUrlRequestRef.UnWrap(request), data, data_length); +end; + +function cef_url_request_client_get_auth_credentials(self: PCefUrlRequestClient; + isProxy: Integer; const host: PCefString; port: Integer; + const realm, scheme: PCefString; callback: PCefAuthCallback): Integer; stdcall; +begin + with TCefUrlrequestClientOwn(CefGetObject(self)) do + Result := Ord(GetAuthCredentials(isProxy <> 0, CefString(host), port, + CefString(realm), CefString(scheme), TCefAuthCallbackRef.UnWrap(callback))); +end; + +{ cef_scheme_handler_factory } + +function cef_scheme_handler_factory_create(self: PCefSchemeHandlerFactory; + browser: PCefBrowser; frame: PCefFrame; const scheme_name: PCefString; + request: PCefRequest): PCefResourceHandler; stdcall; +begin + with TCefSchemeHandlerFactoryOwn(CefGetObject(self)) do + Result := CefGetData(New(TCefBrowserRef.UnWrap(browser), TCefFrameRef.UnWrap(frame), + CefString(scheme_name), TCefRequestRef.UnWrap(request))); +end; + +{ cef_resource_handler } + +function cef_resource_handler_process_request(self: PCefResourceHandler; + request: PCefRequest; callback: PCefCallback): Integer; stdcall; +begin + with TCefResourceHandlerOwn(CefGetObject(self)) do + Result := Ord(ProcessRequest(TCefRequestRef.UnWrap(request), TCefCallbackRef.UnWrap(callback))); +end; + +procedure cef_resource_handler_get_response_headers(self: PCefResourceHandler; + response: PCefResponse; response_length: PInt64; redirectUrl: PCefString); stdcall; +var + ru: ustring; +begin + ru := ''; + with TCefResourceHandlerOwn(CefGetObject(self)) do + GetResponseHeaders(TCefResponseRef.UnWrap(response), response_length^, ru); + if ru <> '' then + CefStringSet(redirectUrl, ru); +end; + +function cef_resource_handler_read_response(self: PCefResourceHandler; + data_out: Pointer; bytes_to_read: Integer; bytes_read: PInteger; + callback: PCefCallback): Integer; stdcall; +begin + with TCefResourceHandlerOwn(CefGetObject(self)) do + Result := Ord(ReadResponse(data_out, bytes_to_read, bytes_read^, TCefCallbackRef.UnWrap(callback))); +end; + +function cef_resource_handler_can_get_cookie(self: PCefResourceHandler; + const cookie: PCefCookie): Integer; stdcall; +begin + with TCefResourceHandlerOwn(CefGetObject(self)) do + Result := Ord(CanGetCookie(cookie)); +end; + +function cef_resource_handler_can_set_cookie(self: PCefResourceHandler; + const cookie: PCefCookie): Integer; stdcall; +begin + with TCefResourceHandlerOwn(CefGetObject(self)) do + Result := Ord(CanSetCookie(cookie)); +end; + +procedure cef_resource_handler_cancel(self: PCefResourceHandler); stdcall; +begin + with TCefResourceHandlerOwn(CefGetObject(self)) do + Cancel; +end; + + { cef_web_plugin_info_visitor } + + function cef_web_plugin_info_visitor_visit(self: PCefWebPluginInfoVisitor; + info: PCefWebPluginInfo; count, total: Integer): Integer; stdcall; +begin + with TCefWebPluginInfoVisitorOwn(CefGetObject(self)) do + Result := Ord(Visit(TCefWebPluginInfoRef.UnWrap(info), count, total)); +end; + + { cef_web_plugin_unstable_callback } + + procedure cef_web_plugin_unstable_callback_is_unstable( + self: PCefWebPluginUnstableCallback; const path: PCefString; unstable: Integer); stdcall; +begin + with TCefWebPluginUnstableCallbackOwn(CefGetObject(self)) do + IsUnstable(CefString(path), unstable <> 0); +end; + + { cef_run_file_dialog_callback } + +procedure cef_run_file_dialog_callback_cont(self: PCefRunFileDialogCallback; + browser_host: PCefBrowserHost; file_paths: TCefStringList); stdcall; +var + list: TStringList; + i: Integer; + str: TCefString; +begin + list := TStringList.Create; + try + for i := 0 to cef_string_list_size(file_paths) - 1 do + begin + FillChar(str, SizeOf(str), 0); + cef_string_list_value(file_paths, i, @str); + list.Add(CefStringClearAndGet(str)); + end; + with TCefRunFileDialogCallbackOwn(CefGetObject(self)) do + cont(TCefBrowserHostRef.UnWrap(browser_host), list); + finally + list.Free; + end; +end; + + { cef_trace_client } + + procedure cef_trace_client_on_trace_data_collected(self: PCefTraceClient; + const fragment: PAnsiChar; fragment_size: NativeUInt); stdcall; +begin + with TCefTraceClientOwn(CefGetObject(self)) do + OnTraceDataCollected(fragment, fragment_size); +end; + +procedure cef_trace_client_on_trace_buffer_percent_full_reply( + self: PCefTraceClient; percent_full: Single); stdcall; +begin + with TCefTraceClientOwn(CefGetObject(self)) do + OnTraceBufferPercentFullReply(percent_full); +end; + +procedure cef_trace_client_on_end_tracing_complete(self: PCefTraceClient); stdcall; +begin + with TCefTraceClientOwn(CefGetObject(self)) do + OnEndTracingComplete; +end; + +{ cef_get_geolocation_callback } + +procedure cef_get_geolocation_callback_on_location_update( + self: PCefGetGeolocationCallback; const position: PCefGeoposition); stdcall; +begin + with TCefGetGeolocationCallbackOwn(CefGetObject(self)) do + OnLocationUpdate(position); +end; + +{ cef_dialog_handler } + +function cef_dialog_handler_on_file_dialog(self: PCefDialogHandler; browser: PCefBrowser; + mode: TCefFileDialogMode; const title, default_file_name: PCefString; + accept_types: TCefStringList; callback: PCefFileDialogCallback): Integer; stdcall; +var + list: TStringList; + i: Integer; + str: TCefString; +begin + list := TStringList.Create; + try + for i := 0 to cef_string_list_size(accept_types) - 1 do + begin + FillChar(str, SizeOf(str), 0); + cef_string_list_value(accept_types, i, @str); + list.Add(CefStringClearAndGet(str)); + end; + + with TCefDialogHandlerOwn(CefGetObject(self)) do + Result := Ord(OnFileDialog(TCefBrowserRef.UnWrap(browser), mode, CefString(title), + CefString(default_file_name), list, TCefFileDialogCallbackRef.UnWrap(callback))); + finally + list.Free; + end; +end; + +{ cef_render_handler } + +function cef_render_handler_get_root_screen_rect(self: PCefRenderHandler; + browser: PCefBrowser; rect: PCefRect): Integer; stdcall; +begin + with TCefRenderHandlerOwn(CefGetObject(self)) do + Result := Ord(GetRootScreenRect(TCefBrowserRef.UnWrap(browser), rect)); +end; + +function cef_render_handler_get_view_rect(self: PCefRenderHandler; + browser: PCefBrowser; rect: PCefRect): Integer; stdcall; +begin + with TCefRenderHandlerOwn(CefGetObject(self)) do + Result := Ord(GetViewRect(TCefBrowserRef.UnWrap(browser), rect)); +end; + +function cef_render_handler_get_screen_point(self: PCefRenderHandler; + browser: PCefBrowser; viewX, viewY: Integer; screenX, screenY: PInteger): Integer; stdcall; +begin + with TCefRenderHandlerOwn(CefGetObject(self)) do + Result := Ord(GetScreenPoint(TCefBrowserRef.UnWrap(browser), viewX, viewY, screenX, screenY)); +end; + +function cef_render_handler_get_screen_info(self: PCefRenderHandler; + browser: PCefBrowser; screen_info: PCefScreenInfo): Integer; stdcall; +begin + with TCefRenderHandlerOwn(CefGetObject(self)) do + Result := Ord(GetScreenInfo(TCefBrowserRef.UnWrap(browser), screen_info)); +end; + +procedure cef_render_handler_on_popup_show(self: PCefRenderProcessHandler; + browser: PCefBrowser; show: Integer); stdcall; +begin + with TCefRenderHandlerOwn(CefGetObject(self)) do + OnPopupShow(TCefBrowserRef.UnWrap(browser), show <> 0); +end; + +procedure cef_render_handler_on_popup_size(self: PCefRenderProcessHandler; + browser: PCefBrowser; const rect: PCefRect); stdcall; +begin + with TCefRenderHandlerOwn(CefGetObject(self)) do + OnPopupSize(TCefBrowserRef.UnWrap(browser), rect); +end; + +procedure cef_render_handler_on_paint(self: PCefRenderProcessHandler; + browser: PCefBrowser; kind: TCefPaintElementType; dirtyRectsCount: NativeUInt; + const dirtyRects: PCefRectArray; const buffer: Pointer; width, height: Integer); stdcall; +begin + with TCefRenderHandlerOwn(CefGetObject(self)) do + OnPaint(TCefBrowserRef.UnWrap(browser), kind, dirtyRectsCount, dirtyRects, + buffer, width, height); +end; + +procedure cef_render_handler_on_cursor_change(self: PCefRenderProcessHandler; + browser: PCefBrowser; cursor: TCefCursorHandle); stdcall; +begin + with TCefRenderHandlerOwn(CefGetObject(self)) do + OnCursorChange(TCefBrowserRef.UnWrap(browser), cursor); +end; + +procedure cef_render_handler_on_scroll_offset_changed(self: PCefRenderProcessHandler; + browser: PCefBrowser); stdcall; +begin + with TCefRenderHandlerOwn(CefGetObject(self)) do + OnScrollOffsetChanged(TCefBrowserRef.UnWrap(browser)); +end; + +{ cef_completion_handler } + +procedure cef_completion_handler_on_complete(self: PCefCompletionHandler); stdcall; +begin + with TCefCompletionHandlerOwn(CefGetObject(self)) do + OnComplete(); +end; + +{ cef_drag_handler } + +function cef_drag_handler_on_drag_enter(self: PCefDragHandler; browser: PCefBrowser; + dragData: PCefDragData; mask: TCefDragOperations): Integer; stdcall; +begin + with TCefDragHandlerOwn(CefGetObject(self)) do + Result := Ord(OnDragEnter(TCefBrowserRef.UnWrap(browser), TCefDragDataRef.UnWrap(dragData), mask)); +end; + +{ cef_request_context_handler } + +function cef_request_context_handler_get_cookie_manager(self: PCefRequestContextHandler): PCefCookieManager; stdcall; +begin + with TCefRequestContextHandlerOwn(CefGetObject(self)) do + Result := CefGetData(GetCookieManager()); +end; + +{ cef_cookie_manager } + +procedure cef_cookie_manager_set_supported_schemes(self: PCefCookieManager; schemes: TCefStringList); stdcall; +var + list: TStringList; + i: Integer; + str: TCefString; +begin + list := TStringList.Create; + try + for i := 0 to cef_string_list_size(schemes) - 1 do + begin + FillChar(str, SizeOf(str), 0); + cef_string_list_value(schemes, i, @str); + list.Add(CefStringClearAndGet(str)); + end; + with TCefCookieManagerOwn(CefGetObject(self)) do + SetSupportedSchemes(list); + finally + list.Free; + end; +end; + +function cef_cookie_manager_visit_all_cookies(self: PCefCookieManager; visitor: PCefCookieVisitor): Integer; stdcall; +begin + with TCefCookieManagerOwn(CefGetObject(self)) do + Result := Ord(VisitAllCookies(TCefCookieVisitorRef.UnWrap(visitor))); +end; + +function cef_cookie_manager_visit_url_cookies(self: PCefCookieManager; const url: PCefString; includeHttpOnly: Integer; visitor: PCefCookieVisitor): Integer; stdcall; +begin + with TCefCookieManagerOwn(CefGetObject(self)) do + Result := Ord(VisitUrlCookies(CefString(url), includeHttpOnly <> 0, TCefCookieVisitorRef.UnWrap(visitor))); +end; + +function cef_cookie_manager_set_cookie(self: PCefCookieManager; const url: PCefString; const cookie: PCefCookie): Integer; stdcall; +begin + with TCefCookieManagerOwn(CefGetObject(self)) do + Result := Ord(SetCookie(CefString(url), CefString(@cookie.name), CefString(@cookie.value), + CefString(@cookie.domain), CefString(@cookie.path), cookie.secure, cookie.httponly, + cookie.has_expires, CefTimeToDateTime(cookie.creation), + CefTimeToDateTime(cookie.last_access), CefTimeToDateTime(cookie.expires))); +end; + +function cef_cookie_manager_delete_cookies(self: PCefCookieManager; const url, cookie_name: PCefString): Integer; stdcall; +begin + with TCefCookieManagerOwn(CefGetObject(self)) do + Result := Ord(DeleteCookies(CefString(url), CefString(cookie_name))); +end; + +function cef_cookie_manager_set_storage_path(self: PCefCookieManager; const path: PCefString; persist_session_cookies: Integer): Integer; stdcall; +begin + with TCefCookieManagerOwn(CefGetObject(self)) do + Result := Ord(SetStoragePath(CefString(path), persist_session_cookies <> 0)); +end; + +function cef_cookie_manager_flush_store(self: PCefCookieManager; handler: PCefCompletionHandler): Integer; stdcall; +begin + with TCefCookieManagerOwn(CefGetObject(self)) do + Result := Ord(FlushStore(TCefCompletionHandlerRef.UnWrap(handler))); +end; + +{ TCefBaseOwn } + +constructor TCefBaseOwn.CreateData(size: Cardinal; owned: Boolean); +begin + GetMem(FData, size + SizeOf(Pointer)); + PPointer(FData)^ := Self; + Inc(PByte(FData), SizeOf(Pointer)); + FillChar(FData^, size, 0); + PCefBase(FData)^.size := size; + if owned then + begin + PCefBase(FData)^.add_ref := @cef_base_add_ref_owned; + PCefBase(FData)^.release := @cef_base_release_owned; + PCefBase(FData)^.get_refct := @cef_base_get_refct_owned; + end else + begin + PCefBase(FData)^.add_ref := @cef_base_add_ref; + PCefBase(FData)^.release := @cef_base_release; + PCefBase(FData)^.get_refct := @cef_base_get_refct; + end; +end; + +destructor TCefBaseOwn.Destroy; +begin + Dec(PByte(FData), SizeOf(Pointer)); + FreeMem(FData); + inherited; +end; + +function TCefBaseOwn.Wrap: Pointer; +begin + Result := FData; + if Assigned(PCefBase(FData)^.add_ref) then + PCefBase(FData)^.add_ref(PCefBase(FData)); +end; + +{ TCefBaseRef } + +constructor TCefBaseRef.Create(data: Pointer); +begin + Assert(data <> nil); + FData := data; +end; + +destructor TCefBaseRef.Destroy; +begin + if Assigned(PCefBase(FData)^.release) then + PCefBase(FData)^.release(PCefBase(FData)); + inherited; +end; + +class function TCefBaseRef.UnWrap(data: Pointer): ICefBase; +begin + if data <> nil then + Result := Create(data) as ICefBase else + Result := nil; +end; + +function TCefBaseRef.Wrap: Pointer; +begin + Result := FData; + if Assigned(PCefBase(FData)^.add_ref) then + PCefBase(FData)^.add_ref(PCefBase(FData)); +end; + +{ TCefBrowserRef } + +function TCefBrowserRef.GetHost: ICefBrowserHost; +begin + Result := TCefBrowserHostRef.UnWrap(PCefBrowser(FData)^.get_host(PCefBrowser(FData))); +end; + +function TCefBrowserRef.CanGoBack: Boolean; +begin + Result := PCefBrowser(FData)^.can_go_back(PCefBrowser(FData)) <> 0; +end; + +function TCefBrowserRef.CanGoForward: Boolean; +begin + Result := PCefBrowser(FData)^.can_go_forward(PCefBrowser(FData)) <> 0; +end; + +function TCefBrowserRef.GetFocusedFrame: ICefFrame; +begin + Result := TCefFrameRef.UnWrap(PCefBrowser(FData)^.get_focused_frame(PCefBrowser(FData))) +end; + +function TCefBrowserRef.GetFrameByident(identifier: Int64): ICefFrame; +begin + Result := TCefFrameRef.UnWrap(PCefBrowser(FData)^.get_frame_byident(PCefBrowser(FData), identifier)); +end; + +function TCefBrowserRef.GetFrame(const name: ustring): ICefFrame; +var + n: TCefString; +begin + n := CefString(name); + Result := TCefFrameRef.UnWrap(PCefBrowser(FData)^.get_frame(PCefBrowser(FData), @n)); +end; + +function TCefBrowserRef.GetFrameCount: NativeUInt; +begin + Result := PCefBrowser(FData)^.get_frame_count(PCefBrowser(FData)); +end; + +procedure TCefBrowserRef.GetFrameIdentifiers(count: PNativeUInt; identifiers: PInt64); +begin + PCefBrowser(FData)^.get_frame_identifiers(PCefBrowser(FData), count, identifiers); +end; + +procedure TCefBrowserRef.GetFrameNames(names: TStrings); +var + list: TCefStringList; + i: Integer; + str: TCefString; +begin + list := cef_string_list_alloc; + try + PCefBrowser(FData)^.get_frame_names(PCefBrowser(FData), list); + FillChar(str, SizeOf(str), 0); + for i := 0 to cef_string_list_size(list) - 1 do + begin + FillChar(str, SizeOf(str), 0); + cef_string_list_value(list, i, @str); + names.Add(CefStringClearAndGet(str)); + end; + finally + cef_string_list_free(list); + end; +end; + +function TCefBrowserRef.SendProcessMessage(targetProcess: TCefProcessId; + message: ICefProcessMessage): Boolean; +begin + Result := PCefBrowser(FData)^.send_process_message(PCefBrowser(FData), targetProcess, CefGetData(message)) <> 0; +end; + +function TCefBrowserRef.GetMainFrame: ICefFrame; +begin + Result := TCefFrameRef.UnWrap(PCefBrowser(FData)^.get_main_frame(PCefBrowser(FData))) +end; + +procedure TCefBrowserRef.GoBack; +begin + PCefBrowser(FData)^.go_back(PCefBrowser(FData)); +end; + +procedure TCefBrowserRef.GoForward; +begin + PCefBrowser(FData)^.go_forward(PCefBrowser(FData)); +end; + +function TCefBrowserRef.IsLoading: Boolean; +begin + Result := PCefBrowser(FData)^.is_loading(PCefBrowser(FData)) <> 0; +end; + +function TCefBrowserRef.HasDocument: Boolean; +begin + Result := PCefBrowser(FData)^.has_document(PCefBrowser(FData)) <> 0; +end; + +function TCefBrowserRef.IsPopup: Boolean; +begin + Result := PCefBrowser(FData)^.is_popup(PCefBrowser(FData)) <> 0; +end; + +function TCefBrowserRef.IsSame(const that: ICefBrowser): Boolean; +begin + Result := PCefBrowser(FData)^.is_same(PCefBrowser(FData), CefGetData(that)) <> 0; +end; + +procedure TCefBrowserRef.Reload; +begin + PCefBrowser(FData)^.reload(PCefBrowser(FData)); +end; + +procedure TCefBrowserRef.ReloadIgnoreCache; +begin + PCefBrowser(FData)^.reload_ignore_cache(PCefBrowser(FData)); +end; + +procedure TCefBrowserRef.StopLoad; +begin + PCefBrowser(FData)^.stop_load(PCefBrowser(FData)); +end; + +function TCefBrowserRef.GetIdentifier: Integer; +begin + Result := PCefBrowser(FData)^.get_identifier(PCefBrowser(FData)); +end; + +class function TCefBrowserRef.UnWrap(data: Pointer): ICefBrowser; +begin + if data <> nil then + Result := Create(data) as ICefBrowser else + Result := nil; +end; + +{ TCefFrameRef } + +function TCefFrameRef.IsValid: Boolean; +begin + Result := PCefFrame(FData)^.is_valid(PCefFrame(FData)) <> 0; +end; + +procedure TCefFrameRef.Copy; +begin + PCefFrame(FData)^.copy(PCefFrame(FData)); +end; + +procedure TCefFrameRef.Cut; +begin + PCefFrame(FData)^.cut(PCefFrame(FData)); +end; + +procedure TCefFrameRef.Del; +begin + PCefFrame(FData)^.del(PCefFrame(FData)); +end; + +procedure TCefFrameRef.ExecuteJavaScript(const code, scriptUrl: ustring; + startLine: Integer); +var + j, s: TCefString; +begin + j := CefString(code); + s := CefString(scriptUrl); + PCefFrame(FData)^.execute_java_script(PCefFrame(FData), @j, @s, startline); +end; + +function TCefFrameRef.GetBrowser: ICefBrowser; +begin + Result := TCefBrowserRef.UnWrap(PCefFrame(FData)^.get_browser(PCefFrame(FData))); +end; + +function TCefFrameRef.GetIdentifier: Int64; +begin + Result := PCefFrame(FData)^.get_identifier(PCefFrame(FData)); +end; + +function TCefFrameRef.GetName: ustring; +begin + Result := CefStringFreeAndGet(PCefFrame(FData)^.get_name(PCefFrame(FData))); +end; + +function TCefFrameRef.GetParent: ICefFrame; +begin + Result := TCefFrameRef.UnWrap(PCefFrame(FData)^.get_parent(PCefFrame(FData))); +end; + +procedure TCefFrameRef.GetSource(const visitor: ICefStringVisitor); +begin + PCefFrame(FData)^.get_source(PCefFrame(FData), CefGetData(visitor)); +end; + +procedure TCefFrameRef.GetSourceProc(const proc: TCefStringVisitorProc); +begin + GetSource(TCefFastStringVisitor.Create(proc)); +end; + +procedure TCefFrameRef.getText(const visitor: ICefStringVisitor); +begin + PCefFrame(FData)^.get_text(PCefFrame(FData), CefGetData(visitor)); +end; + +procedure TCefFrameRef.GetTextProc(const proc: TCefStringVisitorProc); +begin + GetText(TCefFastStringVisitor.Create(proc)); +end; + +function TCefFrameRef.GetUrl: ustring; +begin + Result := CefStringFreeAndGet(PCefFrame(FData)^.get_url(PCefFrame(FData))); +end; + +function TCefFrameRef.GetV8Context: ICefv8Context; +begin + Result := TCefv8ContextRef.UnWrap(PCefFrame(FData)^.get_v8context(PCefFrame(FData))); +end; + +function TCefFrameRef.IsFocused: Boolean; +begin + Result := PCefFrame(FData)^.is_focused(PCefFrame(FData)) <> 0; +end; + +function TCefFrameRef.IsMain: Boolean; +begin + Result := PCefFrame(FData)^.is_main(PCefFrame(FData)) <> 0; +end; + +procedure TCefFrameRef.LoadRequest(const request: ICefRequest); +begin + PCefFrame(FData)^.load_request(PCefFrame(FData), CefGetData(request)); +end; + +procedure TCefFrameRef.LoadString(const str, url: ustring); +var + s, u: TCefString; +begin + s := CefString(str); + u := CefString(url); + PCefFrame(FData)^.load_string(PCefFrame(FData), @s, @u); +end; + +procedure TCefFrameRef.LoadUrl(const url: ustring); +var + u: TCefString; +begin + u := CefString(url); + PCefFrame(FData)^.load_url(PCefFrame(FData), @u); + +end; + +procedure TCefFrameRef.Paste; +begin + PCefFrame(FData)^.paste(PCefFrame(FData)); +end; + +procedure TCefFrameRef.Redo; +begin + PCefFrame(FData)^.redo(PCefFrame(FData)); +end; + +procedure TCefFrameRef.SelectAll; +begin + PCefFrame(FData)^.select_all(PCefFrame(FData)); +end; + +procedure TCefFrameRef.Undo; +begin + PCefFrame(FData)^.undo(PCefFrame(FData)); +end; + +procedure TCefFrameRef.ViewSource; +begin + PCefFrame(FData)^.view_source(PCefFrame(FData)); +end; + +procedure TCefFrameRef.VisitDom(const visitor: ICefDomVisitor); +begin + PCefFrame(FData)^.visit_dom(PCefFrame(FData), CefGetData(visitor)); +end; + +procedure TCefFrameRef.VisitDomProc(const proc: TCefDomVisitorProc); +begin + VisitDom(TCefFastDomVisitor.Create(proc) as ICefDomVisitor); +end; + +class function TCefFrameRef.UnWrap(data: Pointer): ICefFrame; +begin + if data <> nil then + Result := Create(data) as ICefFrame else + Result := nil; +end; + +{ TCefCustomStreamReader } + +constructor TCefCustomStreamReader.Create(Stream: TStream; Owned: Boolean); +begin + inherited CreateData(SizeOf(TCefReadHandler)); + FStream := stream; + FOwned := Owned; + with PCefReadHandler(FData)^ do + begin + read := cef_stream_reader_read; + seek := cef_stream_reader_seek; + tell := cef_stream_reader_tell; + eof := cef_stream_reader_eof; + end; +end; + +constructor TCefCustomStreamReader.Create(const filename: string); +begin + Create(TFileStream.Create(filename, fmOpenRead or fmShareDenyWrite), True); +end; + +destructor TCefCustomStreamReader.Destroy; +begin + if FOwned then + FStream.Free; + inherited; +end; + +function TCefCustomStreamReader.Eof: Boolean; +begin + Result := FStream.Position = FStream.size; +end; + +function TCefCustomStreamReader.Read(ptr: Pointer; size, n: NativeUInt): NativeUInt; +begin + result := NativeUInt(FStream.Read(ptr^, n * size)) div size; +end; + +function TCefCustomStreamReader.Seek(offset: Int64; whence: Integer): Integer; +begin + Result := FStream.Seek(offset, whence); +end; + +function TCefCustomStreamReader.Tell: Int64; +begin + Result := FStream.Position; +end; + +{ TCefPostDataRef } + +function TCefPostDataRef.IsReadOnly: Boolean; +begin + Result := PCefPostData(FData)^.is_read_only(PCefPostData(FData)) <> 0; +end; + +function TCefPostDataRef.AddElement( + const element: ICefPostDataElement): Integer; +begin + Result := PCefPostData(FData)^.add_element(PCefPostData(FData), CefGetData(element)); +end; + +function TCefPostDataRef.GetCount: NativeUInt; +begin + Result := PCefPostData(FData)^.get_element_count(PCefPostData(FData)) +end; + +function TCefPostDataRef.GetElements(Count: NativeUInt): IInterfaceList; +var + items: PCefPostDataElementArray; + i: Integer; +begin + Result := TInterfaceList.Create; + GetMem(items, SizeOf(PCefPostDataElement) * Count); + FillChar(items^, SizeOf(PCefPostDataElement) * Count, 0); + try + PCefPostData(FData)^.get_elements(PCefPostData(FData), @Count, items); + for i := 0 to Count - 1 do + Result.Add(TCefPostDataElementRef.UnWrap(items[i])); + finally + FreeMem(items); + end; +end; + +class function TCefPostDataRef.New: ICefPostData; +begin + Result := UnWrap(cef_post_data_create); +end; + +function TCefPostDataRef.RemoveElement( + const element: ICefPostDataElement): Integer; +begin + Result := PCefPostData(FData)^.remove_element(PCefPostData(FData), CefGetData(element)); +end; + +procedure TCefPostDataRef.RemoveElements; +begin + PCefPostData(FData)^.remove_elements(PCefPostData(FData)); +end; + +class function TCefPostDataRef.UnWrap(data: Pointer): ICefPostData; +begin + if data <> nil then + Result := Create(data) as ICefPostData else + Result := nil; +end; + +{ TCefPostDataElementRef } + +function TCefPostDataElementRef.IsReadOnly: Boolean; +begin + Result := PCefPostDataElement(FData)^.is_read_only(PCefPostDataElement(FData)) <> 0; +end; + +function TCefPostDataElementRef.GetBytes(size: NativeUInt; + bytes: Pointer): NativeUInt; +begin + Result := PCefPostDataElement(FData)^.get_bytes(PCefPostDataElement(FData), size, bytes); +end; + +function TCefPostDataElementRef.GetBytesCount: NativeUInt; +begin + Result := PCefPostDataElement(FData)^.get_bytes_count(PCefPostDataElement(FData)); +end; + +function TCefPostDataElementRef.GetFile: ustring; +begin + Result := CefStringFreeAndGet(PCefPostDataElement(FData)^.get_file(PCefPostDataElement(FData))); +end; + +function TCefPostDataElementRef.GetType: TCefPostDataElementType; +begin + Result := PCefPostDataElement(FData)^.get_type(PCefPostDataElement(FData)); +end; + +class function TCefPostDataElementRef.New: ICefPostDataElement; +begin + Result := UnWrap(cef_post_data_element_create); +end; + +procedure TCefPostDataElementRef.SetToBytes(size: NativeUInt; bytes: Pointer); +begin + PCefPostDataElement(FData)^.set_to_bytes(PCefPostDataElement(FData), size, bytes); +end; + +procedure TCefPostDataElementRef.SetToEmpty; +begin + PCefPostDataElement(FData)^.set_to_empty(PCefPostDataElement(FData)); +end; + +procedure TCefPostDataElementRef.SetToFile(const fileName: ustring); +var + f: TCefString; +begin + f := CefString(fileName); + PCefPostDataElement(FData)^.set_to_file(PCefPostDataElement(FData), @f); +end; + +class function TCefPostDataElementRef.UnWrap(data: Pointer): ICefPostDataElement; +begin + if data <> nil then + Result := Create(data) as ICefPostDataElement else + Result := nil; +end; + +{ TCefPostDataElementOwn } + +procedure TCefPostDataElementOwn.Clear; +begin + case FDataType of + PDE_TYPE_BYTES: + if (FValueByte <> nil) then + begin + FreeMem(FValueByte); + FValueByte := nil; + end; + PDE_TYPE_FILE: + CefStringFree(@FValueStr) + end; + FDataType := PDE_TYPE_EMPTY; + FSize := 0; +end; + +constructor TCefPostDataElementOwn.Create(readonly: Boolean); +begin + inherited CreateData(SizeOf(TCefPostDataElement)); + FReadOnly := readonly; + FDataType := PDE_TYPE_EMPTY; + FValueByte := nil; + FillChar(FValueStr, SizeOf(FValueStr), 0); + FSize := 0; + with PCefPostDataElement(FData)^ do + begin + is_read_only := cef_post_data_element_is_read_only; + set_to_empty := cef_post_data_element_set_to_empty; + set_to_file := cef_post_data_element_set_to_file; + set_to_bytes := cef_post_data_element_set_to_bytes; + get_type := cef_post_data_element_get_type; + get_file := cef_post_data_element_get_file; + get_bytes_count := cef_post_data_element_get_bytes_count; + get_bytes := cef_post_data_element_get_bytes; + end; +end; + +function TCefPostDataElementOwn.GetBytes(size: NativeUInt; + bytes: Pointer): NativeUInt; +begin + if (FDataType = PDE_TYPE_BYTES) and (FValueByte <> nil) then + begin + if size > FSize then + Result := FSize else + Result := size; + Move(FValueByte^, bytes^, Result); + end else + Result := 0; +end; + +function TCefPostDataElementOwn.GetBytesCount: NativeUInt; +begin + if (FDataType = PDE_TYPE_BYTES) then + Result := FSize else + Result := 0; +end; + +function TCefPostDataElementOwn.GetFile: ustring; +begin + if (FDataType = PDE_TYPE_FILE) then + Result := CefString(@FValueStr) else + Result := ''; +end; + +function TCefPostDataElementOwn.GetType: TCefPostDataElementType; +begin + Result := FDataType; +end; + +function TCefPostDataElementOwn.IsReadOnly: Boolean; +begin + Result := FReadOnly; +end; + +procedure TCefPostDataElementOwn.SetToBytes(size: NativeUInt; bytes: Pointer); +begin + Clear; + if (size > 0) and (bytes <> nil) then + begin + GetMem(FValueByte, size); + Move(bytes^, FValueByte, size); + FSize := size; + end else + begin + FValueByte := nil; + FSize := 0; + end; + FDataType := PDE_TYPE_BYTES; +end; + +procedure TCefPostDataElementOwn.SetToEmpty; +begin + Clear; +end; + +procedure TCefPostDataElementOwn.SetToFile(const fileName: ustring); +begin + Clear; + FSize := 0; + FValueStr := CefStringAlloc(fileName); + FDataType := PDE_TYPE_FILE; +end; + +{ TCefRequestRef } + +function TCefRequestRef.IsReadOnly: Boolean; +begin + Result := PCefRequest(FData).is_read_only(PCefRequest(FData)) <> 0; +end; + +procedure TCefRequestRef.Assign(const url, method: ustring; + const postData: ICefPostData; const headerMap: ICefStringMultimap); +var + u, m: TCefString; +begin + u := cefstring(url); + m := cefstring(method); + PCefRequest(FData).set_(PCefRequest(FData), @u, @m, CefGetData(postData), headerMap.Handle); +end; + +function TCefRequestRef.GetFirstPartyForCookies: ustring; +begin + Result := CefStringFreeAndGet(PCefRequest(FData).get_first_party_for_cookies(PCefRequest(FData))); +end; + +function TCefRequestRef.GetFlags: TCefUrlRequestFlags; +begin + Byte(Result) := PCefRequest(FData)^.get_flags(PCefRequest(FData)); +end; + +procedure TCefRequestRef.GetHeaderMap(const HeaderMap: ICefStringMultimap); +begin + PCefRequest(FData)^.get_header_map(PCefRequest(FData), HeaderMap.Handle); +end; + +function TCefRequestRef.GetMethod: ustring; +begin + Result := CefStringFreeAndGet(PCefRequest(FData)^.get_method(PCefRequest(FData))) +end; + +function TCefRequestRef.GetPostData: ICefPostData; +begin + Result := TCefPostDataRef.UnWrap(PCefRequest(FData)^.get_post_data(PCefRequest(FData))); +end; + +function TCefRequestRef.GetResourceType: TCefResourceType; +begin + Result := PCefRequest(FData)^.get_resource_type(FData); +end; + +function TCefRequestRef.GetTransitionType: TCefTransitionType; +begin + Result := PCefRequest(FData)^.get_transition_type(FData); +end; + +function TCefRequestRef.GetUrl: ustring; +begin + Result := CefStringFreeAndGet(PCefRequest(FData)^.get_url(PCefRequest(FData))) +end; + +class function TCefRequestRef.New: ICefRequest; +begin + Result := UnWrap(cef_request_create); +end; + +procedure TCefRequestRef.SetFirstPartyForCookies(const url: ustring); +var + str: TCefString; +begin + str := CefString(url); + PCefRequest(FData).set_first_party_for_cookies(PCefRequest(FData), @str); +end; + +procedure TCefRequestRef.SetFlags(flags: TCefUrlRequestFlags); +begin + PCefRequest(FData)^.set_flags(PCefRequest(FData), PByte(@flags)^); +end; + +procedure TCefRequestRef.SetHeaderMap(const HeaderMap: ICefStringMultimap); +begin + PCefRequest(FData)^.set_header_map(PCefRequest(FData), HeaderMap.Handle); +end; + +procedure TCefRequestRef.SetMethod(const value: ustring); +var + v: TCefString; +begin + v := CefString(value); + PCefRequest(FData)^.set_method(PCefRequest(FData), @v); +end; + +procedure TCefRequestRef.SetPostData(const value: ICefPostData); +begin + if value <> nil then + PCefRequest(FData)^.set_post_data(PCefRequest(FData), CefGetData(value)); +end; + +procedure TCefRequestRef.SetUrl(const value: ustring); +var + v: TCefString; +begin + v := CefString(value); + PCefRequest(FData)^.set_url(PCefRequest(FData), @v); +end; + +class function TCefRequestRef.UnWrap(data: Pointer): ICefRequest; +begin + if data <> nil then + Result := Create(data) as ICefRequest else + Result := nil; +end; + +{ TCefStreamReaderRef } + +class function TCefStreamReaderRef.CreateForCustomStream( + const stream: ICefCustomStreamReader): ICefStreamReader; +begin + Result := UnWrap(cef_stream_reader_create_for_handler(CefGetData(stream))) +end; + +class function TCefStreamReaderRef.CreateForData(data: Pointer; size: NativeUInt): ICefStreamReader; +begin + Result := UnWrap(cef_stream_reader_create_for_data(data, size)) +end; + +class function TCefStreamReaderRef.CreateForFile(const filename: ustring): ICefStreamReader; +var + f: TCefString; +begin + f := CefString(filename); + Result := UnWrap(cef_stream_reader_create_for_file(@f)) +end; + +class function TCefStreamReaderRef.CreateForStream(const stream: TSTream; + owned: Boolean): ICefStreamReader; +begin + Result := CreateForCustomStream(TCefCustomStreamReader.Create(stream, owned) as ICefCustomStreamReader); +end; + +function TCefStreamReaderRef.Eof: Boolean; +begin + Result := PCefStreamReader(FData)^.eof(PCefStreamReader(FData)) <> 0; +end; + +function TCefStreamReaderRef.Read(ptr: Pointer; size, n: NativeUInt): NativeUInt; +begin + Result := PCefStreamReader(FData)^.read(PCefStreamReader(FData), ptr, size, n); +end; + +function TCefStreamReaderRef.Seek(offset: Int64; whence: Integer): Integer; +begin + Result := PCefStreamReader(FData)^.seek(PCefStreamReader(FData), offset, whence); +end; + +function TCefStreamReaderRef.Tell: Int64; +begin + Result := PCefStreamReader(FData)^.tell(PCefStreamReader(FData)); +end; + +class function TCefStreamReaderRef.UnWrap(data: Pointer): ICefStreamReader; +begin + if data <> nil then + Result := Create(data) as ICefStreamReader else + Result := nil; +end; + +{ TCefv8ValueRef } + +function TCefv8ValueRef.AdjustExternallyAllocatedMemory( + changeInBytes: Integer): Integer; +begin + Result := PCefV8Value(FData)^.adjust_externally_allocated_memory(PCefV8Value(FData), changeInBytes); +end; + +class function TCefv8ValueRef.NewArray(len: Integer): ICefv8Value; +begin + Result := UnWrap(cef_v8value_create_array(len)); +end; + +class function TCefv8ValueRef.NewBool(value: Boolean): ICefv8Value; +begin + Result := UnWrap(cef_v8value_create_bool(Ord(value))); +end; + +class function TCefv8ValueRef.NewDate(value: TDateTime): ICefv8Value; +var + dt: TCefTime; +begin + dt := DateTimeToCefTime(value); + Result := UnWrap(cef_v8value_create_date(@dt)); +end; + +class function TCefv8ValueRef.NewDouble(value: Double): ICefv8Value; +begin + Result := UnWrap(cef_v8value_create_double(value)); +end; + +class function TCefv8ValueRef.NewFunction(const name: ustring; + const handler: ICefv8Handler): ICefv8Value; +var + n: TCefString; +begin + n := CefString(name); + Result := UnWrap(cef_v8value_create_function(@n, CefGetData(handler))); +end; + +class function TCefv8ValueRef.NewInt(value: Integer): ICefv8Value; +begin + Result := UnWrap(cef_v8value_create_int(value)); +end; + +class function TCefv8ValueRef.NewUInt(value: Cardinal): ICefv8Value; +begin + Result := UnWrap(cef_v8value_create_uint(value)); +end; + +class function TCefv8ValueRef.NewNull: ICefv8Value; +begin + Result := UnWrap(cef_v8value_create_null); +end; + +class function TCefv8ValueRef.NewObject(const Accessor: ICefV8Accessor): ICefv8Value; +begin + Result := UnWrap(cef_v8value_create_object(CefGetData(Accessor))); +end; + +class function TCefv8ValueRef.NewObjectProc(const getter: TCefV8AccessorGetterProc; + const setter: TCefV8AccessorSetterProc): ICefv8Value; +begin + Result := NewObject(TCefFastV8Accessor.Create(getter, setter) as ICefV8Accessor); +end; + +class function TCefv8ValueRef.NewString(const str: ustring): ICefv8Value; +var + s: TCefString; +begin + s := CefString(str); + Result := UnWrap(cef_v8value_create_string(@s)); +end; + +class function TCefv8ValueRef.NewUndefined: ICefv8Value; +begin + Result := UnWrap(cef_v8value_create_undefined); +end; + +function TCefv8ValueRef.DeleteValueByIndex(index: Integer): Boolean; +begin + Result := PCefV8Value(FData)^.delete_value_byindex(PCefV8Value(FData), index) <> 0; +end; + +function TCefv8ValueRef.DeleteValueByKey(const key: ustring): Boolean; +var + k: TCefString; +begin + k := CefString(key); + Result := PCefV8Value(FData)^.delete_value_bykey(PCefV8Value(FData), @k) <> 0; +end; + +function TCefv8ValueRef.ExecuteFunction(const obj: ICefv8Value; + const arguments: TCefv8ValueArray): ICefv8Value; +var + args: PPCefV8Value; + i: Integer; +begin + GetMem(args, SizeOf(PCefV8Value) * Length(arguments)); + try + for i := 0 to Length(arguments) - 1 do + args[i] := CefGetData(arguments[i]); + Result := TCefv8ValueRef.UnWrap(PCefV8Value(FData)^.execute_function(PCefV8Value(FData), + CefGetData(obj), Length(arguments), args)); + finally + FreeMem(args); + end; +end; + +function TCefv8ValueRef.ExecuteFunctionWithContext(const context: ICefv8Context; + const obj: ICefv8Value; const arguments: TCefv8ValueArray): ICefv8Value; +var + args: PPCefV8Value; + i: Integer; +begin + GetMem(args, SizeOf(PCefV8Value) * Length(arguments)); + try + for i := 0 to Length(arguments) - 1 do + args[i] := CefGetData(arguments[i]); + Result := TCefv8ValueRef.UnWrap(PCefV8Value(FData)^.execute_function_with_context(PCefV8Value(FData), + CefGetData(context), CefGetData(obj), Length(arguments), args)); + finally + FreeMem(args); + end; +end; + +function TCefv8ValueRef.GetArrayLength: Integer; +begin + Result := PCefV8Value(FData)^.get_array_length(PCefV8Value(FData)); +end; + +function TCefv8ValueRef.GetBoolValue: Boolean; +begin + Result := PCefV8Value(FData)^.get_bool_value(PCefV8Value(FData)) <> 0; +end; + +function TCefv8ValueRef.GetDateValue: TDateTime; +begin + Result := CefTimeToDateTime(PCefV8Value(FData)^.get_date_value(PCefV8Value(FData))); +end; + +function TCefv8ValueRef.GetDoubleValue: Double; +begin + Result := PCefV8Value(FData)^.get_double_value(PCefV8Value(FData)); +end; + +function TCefv8ValueRef.GetExternallyAllocatedMemory: Integer; +begin + Result := PCefV8Value(FData)^.get_externally_allocated_memory(PCefV8Value(FData)); +end; + +function TCefv8ValueRef.GetFunctionHandler: ICefv8Handler; +begin + Result := TCefv8HandlerRef.UnWrap(PCefV8Value(FData)^.get_function_handler(PCefV8Value(FData))); +end; + +function TCefv8ValueRef.GetFunctionName: ustring; +begin + Result := CefStringFreeAndGet(PCefV8Value(FData)^.get_function_name(PCefV8Value(FData))) +end; + +function TCefv8ValueRef.GetIntValue: Integer; +begin + Result := PCefV8Value(FData)^.get_int_value(PCefV8Value(FData)) +end; + +function TCefv8ValueRef.GetUIntValue: Cardinal; +begin + Result := PCefV8Value(FData)^.get_uint_value(PCefV8Value(FData)) +end; + +function TCefv8ValueRef.GetKeys(const keys: TStrings): Integer; +var + list: TCefStringList; + i: Integer; + str: TCefString; +begin + list := cef_string_list_alloc; + try + Result := PCefV8Value(FData)^.get_keys(PCefV8Value(FData), list); + FillChar(str, SizeOf(str), 0); + for i := 0 to cef_string_list_size(list) - 1 do + begin + FillChar(str, SizeOf(str), 0); + cef_string_list_value(list, i, @str); + keys.Add(CefStringClearAndGet(str)); + end; + finally + cef_string_list_free(list); + end; +end; + +function TCefv8ValueRef.SetUserData(const data: ICefv8Value): Boolean; +begin + Result := PCefV8Value(FData)^.set_user_data(PCefV8Value(FData), CefGetData(data)) <> 0; +end; + +function TCefv8ValueRef.GetStringValue: ustring; +begin + Result := CefStringFreeAndGet(PCefV8Value(FData)^.get_string_value(PCefV8Value(FData))); +end; + +function TCefv8ValueRef.IsUserCreated: Boolean; +begin + Result := PCefV8Value(FData)^.is_user_created(PCefV8Value(FData)) <> 0; +end; + +function TCefv8ValueRef.IsValid: Boolean; +begin + Result := PCefV8Value(FData)^.is_valid(PCefV8Value(FData)) <> 0; +end; + +function TCefv8ValueRef.HasException: Boolean; +begin + Result := PCefV8Value(FData)^.has_exception(PCefV8Value(FData)) <> 0; +end; + +function TCefv8ValueRef.GetException: ICefV8Exception; +begin + Result := TCefV8ExceptionRef.UnWrap(PCefV8Value(FData)^.get_exception(PCefV8Value(FData))); +end; + +function TCefv8ValueRef.ClearException: Boolean; +begin + Result := PCefV8Value(FData)^.clear_exception(PCefV8Value(FData)) <> 0; +end; + +function TCefv8ValueRef.WillRethrowExceptions: Boolean; +begin + Result := PCefV8Value(FData)^.will_rethrow_exceptions(PCefV8Value(FData)) <> 0; +end; + +function TCefv8ValueRef.SetRethrowExceptions(rethrow: Boolean): Boolean; +begin + Result := PCefV8Value(FData)^.set_rethrow_exceptions(PCefV8Value(FData), Ord(rethrow)) <> 0; +end; + +function TCefv8ValueRef.GetUserData: ICefv8Value; +begin + Result := TCefv8ValueRef.UnWrap(PCefV8Value(FData)^.get_user_data(PCefV8Value(FData))); +end; + +function TCefv8ValueRef.GetValueByIndex(index: Integer): ICefv8Value; +begin + Result := TCefv8ValueRef.UnWrap(PCefV8Value(FData)^.get_value_byindex(PCefV8Value(FData), index)) +end; + +function TCefv8ValueRef.GetValueByKey(const key: ustring): ICefv8Value; +var + k: TCefString; +begin + k := CefString(key); + Result := TCefv8ValueRef.UnWrap(PCefV8Value(FData)^.get_value_bykey(PCefV8Value(FData), @k)) +end; + +function TCefv8ValueRef.HasValueByIndex(index: Integer): Boolean; +begin + Result := PCefV8Value(FData)^.has_value_byindex(PCefV8Value(FData), index) <> 0; +end; + +function TCefv8ValueRef.HasValueByKey(const key: ustring): Boolean; +var + k: TCefString; +begin + k := CefString(key); + Result := PCefV8Value(FData)^.has_value_bykey(PCefV8Value(FData), @k) <> 0; +end; + +function TCefv8ValueRef.IsArray: Boolean; +begin + Result := PCefV8Value(FData)^.is_array(PCefV8Value(FData)) <> 0; +end; + +function TCefv8ValueRef.IsBool: Boolean; +begin + Result := PCefV8Value(FData)^.is_bool(PCefV8Value(FData)) <> 0; +end; + +function TCefv8ValueRef.IsDate: Boolean; +begin + Result := PCefV8Value(FData)^.is_date(PCefV8Value(FData)) <> 0; +end; + +function TCefv8ValueRef.IsDouble: Boolean; +begin + Result := PCefV8Value(FData)^.is_double(PCefV8Value(FData)) <> 0; +end; + +function TCefv8ValueRef.IsFunction: Boolean; +begin + Result := PCefV8Value(FData)^.is_function(PCefV8Value(FData)) <> 0; +end; + +function TCefv8ValueRef.IsInt: Boolean; +begin + Result := PCefV8Value(FData)^.is_int(PCefV8Value(FData)) <> 0; +end; + +function TCefv8ValueRef.IsUInt: Boolean; +begin + Result := PCefV8Value(FData)^.is_uint(PCefV8Value(FData)) <> 0; +end; + +function TCefv8ValueRef.IsNull: Boolean; +begin + Result := PCefV8Value(FData)^.is_null(PCefV8Value(FData)) <> 0; +end; + +function TCefv8ValueRef.IsObject: Boolean; +begin + Result := PCefV8Value(FData)^.is_object(PCefV8Value(FData)) <> 0; +end; + +function TCefv8ValueRef.IsSame(const that: ICefv8Value): Boolean; +begin + Result := PCefV8Value(FData)^.is_same(PCefV8Value(FData), CefGetData(that)) <> 0; +end; + +function TCefv8ValueRef.IsString: Boolean; +begin + Result := PCefV8Value(FData)^.is_string(PCefV8Value(FData)) <> 0; +end; + +function TCefv8ValueRef.IsUndefined: Boolean; +begin + Result := PCefV8Value(FData)^.is_undefined(PCefV8Value(FData)) <> 0; +end; + +function TCefv8ValueRef.SetValueByAccessor(const key: ustring; + settings: TCefV8AccessControls; attribute: TCefV8PropertyAttributes): Boolean; +var + k: TCefString; +begin + k := CefString(key); + Result:= PCefV8Value(FData)^.set_value_byaccessor(PCefV8Value(FData), @k, + PByte(@settings)^, PByte(@attribute)^) <> 0; +end; + +function TCefv8ValueRef.SetValueByIndex(index: Integer; + const value: ICefv8Value): Boolean; +begin + Result:= PCefV8Value(FData)^.set_value_byindex(PCefV8Value(FData), index, CefGetData(value)) <> 0; +end; + +function TCefv8ValueRef.SetValueByKey(const key: ustring; + const value: ICefv8Value; attribute: TCefV8PropertyAttributes): Boolean; +var + k: TCefString; +begin + k := CefString(key); + Result:= PCefV8Value(FData)^.set_value_bykey(PCefV8Value(FData), @k, + CefGetData(value), PByte(@attribute)^) <> 0; +end; + +class function TCefv8ValueRef.UnWrap(data: Pointer): ICefv8Value; +begin + if data <> nil then + Result := Create(data) as ICefv8Value else + Result := nil; +end; + +{ TCefv8HandlerRef } + +function TCefv8HandlerRef.Execute(const name: ustring; const obj: ICefv8Value; + const arguments: TCefv8ValueArray; var retval: ICefv8Value; + var exception: ustring): Boolean; +var + args: array of PCefV8Value; + i: Integer; + ret: PCefV8Value; + exc: TCefString; + n: TCefString; +begin + SetLength(args, Length(arguments)); + for i := 0 to Length(arguments) - 1 do + args[i] := CefGetData(arguments[i]); + ret := nil; + FillChar(exc, SizeOf(exc), 0); + n := CefString(name); + Result := PCefv8Handler(FData)^.execute(PCefv8Handler(FData), @n, + CefGetData(obj), Length(arguments), @args, ret, exc) <> 0; + retval := TCefv8ValueRef.UnWrap(ret); + exception := CefStringClearAndGet(exc); +end; + +class function TCefv8HandlerRef.UnWrap(data: Pointer): ICefv8Handler; +begin + if data <> nil then + Result := Create(data) as ICefv8Handler else + Result := nil; +end; + +{ TCefv8HandlerOwn } + +constructor TCefv8HandlerOwn.Create; +begin + inherited CreateData(SizeOf(TCefv8Handler)); + with PCefv8Handler(FData)^ do + execute := cef_v8_handler_execute; +end; + +function TCefv8HandlerOwn.Execute(const name: ustring; const obj: ICefv8Value; + const arguments: TCefv8ValueArray; var retval: ICefv8Value; + var exception: ustring): Boolean; +begin + Result := False; +end; + +{ TCefTaskOwn } + +constructor TCefTaskOwn.Create; +begin + inherited CreateData(SizeOf(TCefTask)); + with PCefTask(FData)^ do + execute := cef_task_execute; +end; + +procedure TCefTaskOwn.Execute; +begin + +end; + +{ TCefStringMapOwn } + +procedure TCefStringMapOwn.Append(const key, value: ustring); +var + k, v: TCefString; +begin + k := CefString(key); + v := CefString(value); + cef_string_map_append(FStringMap, @k, @v); +end; + +procedure TCefStringMapOwn.Clear; +begin + cef_string_map_clear(FStringMap); +end; + +constructor TCefStringMapOwn.Create; +begin + FStringMap := cef_string_map_alloc; +end; + +destructor TCefStringMapOwn.Destroy; +begin + cef_string_map_free(FStringMap); +end; + +function TCefStringMapOwn.Find(const key: ustring): ustring; +var + str, k: TCefString; +begin + FillChar(str, SizeOf(str), 0); + k := CefString(key); + cef_string_map_find(FStringMap, @k, str); + Result := CefString(@str); +end; + +function TCefStringMapOwn.GetHandle: TCefStringMap; +begin + Result := FStringMap; +end; + +function TCefStringMapOwn.GetKey(index: Integer): ustring; +var + str: TCefString; +begin + FillChar(str, SizeOf(str), 0); + cef_string_map_key(FStringMap, index, str); + Result := CefString(@str); +end; + +function TCefStringMapOwn.GetSize: Integer; +begin + Result := cef_string_map_size(FStringMap); +end; + +function TCefStringMapOwn.GetValue(index: Integer): ustring; +var + str: TCefString; +begin + FillChar(str, SizeOf(str), 0); + cef_string_map_value(FStringMap, index, str); + Result := CefString(@str); +end; + +{ TCefStringMultimapOwn } + +procedure TCefStringMultimapOwn.Append(const Key, Value: ustring); +var + k, v: TCefString; +begin + k := CefString(key); + v := CefString(value); + cef_string_multimap_append(FStringMap, @k, @v); +end; + +procedure TCefStringMultimapOwn.Clear; +begin + cef_string_multimap_clear(FStringMap); +end; + +constructor TCefStringMultimapOwn.Create; +begin + FStringMap := cef_string_multimap_alloc; +end; + +destructor TCefStringMultimapOwn.Destroy; +begin + cef_string_multimap_free(FStringMap); + inherited; +end; + +function TCefStringMultimapOwn.FindCount(const Key: ustring): Integer; +var + k: TCefString; +begin + k := CefString(Key); + Result := cef_string_multimap_find_count(FStringMap, @k); +end; + +function TCefStringMultimapOwn.GetEnumerate(const Key: ustring; + ValueIndex: Integer): ustring; +var + k, v: TCefString; +begin + k := CefString(Key); + FillChar(v, SizeOf(v), 0); + cef_string_multimap_enumerate(FStringMap, @k, ValueIndex, v); + Result := CefString(@v); +end; + +function TCefStringMultimapOwn.GetHandle: TCefStringMultimap; +begin + Result := FStringMap; +end; + +function TCefStringMultimapOwn.GetKey(Index: Integer): ustring; +var + str: TCefString; +begin + FillChar(str, SizeOf(str), 0); + cef_string_multimap_key(FStringMap, index, str); + Result := CefString(@str); +end; + +function TCefStringMultimapOwn.GetSize: Integer; +begin + Result := cef_string_multimap_size(FStringMap); +end; + +function TCefStringMultimapOwn.GetValue(Index: Integer): ustring; +var + str: TCefString; +begin + FillChar(str, SizeOf(str), 0); + cef_string_multimap_value(FStringMap, index, str); + Result := CefString(@str); +end; + +{ TCefDownloadHandlerOwn } + +constructor TCefDownloadHandlerOwn.Create; +begin + inherited CreateData(SizeOf(TCefDownloadHandler)); + with PCefDownloadHandler(FData)^ do + begin + on_before_download := cef_download_handler_on_before_download; + on_download_updated := cef_download_handler_on_download_updated; + end; +end; + +procedure TCefDownloadHandlerOwn.OnBeforeDownload(const browser: ICefBrowser; + const downloadItem: ICefDownloadItem; const suggestedName: ustring; + const callback: ICefBeforeDownloadCallback); +begin + +end; + +procedure TCefDownloadHandlerOwn.OnDownloadUpdated(const browser: ICefBrowser; + const downloadItem: ICefDownloadItem; + const callback: ICefDownloadItemCallback); +begin + +end; + +{ TCefXmlReaderRef } + +function TCefXmlReaderRef.Close: Boolean; +begin + Result := PCefXmlReader(FData).close(FData) <> 0; +end; + +class function TCefXmlReaderRef.New(const stream: ICefStreamReader; + encodingType: TCefXmlEncodingType; const URI: ustring): ICefXmlReader; +var + u: TCefString; +begin + u := CefString(URI); + Result := UnWrap(cef_xml_reader_create(CefGetData(stream), encodingType, @u)); +end; + +function TCefXmlReaderRef.GetAttributeByIndex(index: Integer): ustring; +begin + Result := CefStringFreeAndGet(PCefXmlReader(FData).get_attribute_byindex(FData, index)); +end; + +function TCefXmlReaderRef.GetAttributeByLName(const localName, + namespaceURI: ustring): ustring; +var + l, n: TCefString; +begin + l := CefString(localName); + n := CefString(namespaceURI); + Result := CefStringFreeAndGet(PCefXmlReader(FData).get_attribute_bylname(FData, @l, @n)); +end; + +function TCefXmlReaderRef.GetAttributeByQName( + const qualifiedName: ustring): ustring; +var + q: TCefString; +begin + q := CefString(qualifiedName); + Result := CefStringFreeAndGet(PCefXmlReader(FData).get_attribute_byqname(FData, @q)); +end; + +function TCefXmlReaderRef.GetAttributeCount: NativeUInt; +begin + Result := PCefXmlReader(FData).get_attribute_count(FData); +end; + +function TCefXmlReaderRef.GetBaseUri: ustring; +begin + Result := CefStringFreeAndGet(PCefXmlReader(FData).get_base_uri(FData)); +end; + +function TCefXmlReaderRef.GetDepth: Integer; +begin + Result := PCefXmlReader(FData).get_depth(FData); +end; + +function TCefXmlReaderRef.GetError: ustring; +begin + Result := CefStringFreeAndGet(PCefXmlReader(FData).get_error(FData)); +end; + +function TCefXmlReaderRef.GetInnerXml: ustring; +begin + Result := CefStringFreeAndGet(PCefXmlReader(FData).get_inner_xml(FData)); +end; + +function TCefXmlReaderRef.GetLineNumber: Integer; +begin + Result := PCefXmlReader(FData).get_line_number(FData); +end; + +function TCefXmlReaderRef.GetLocalName: ustring; +begin + Result := CefStringFreeAndGet(PCefXmlReader(FData).get_local_name(FData)); +end; + +function TCefXmlReaderRef.GetNamespaceUri: ustring; +begin + Result := CefStringFreeAndGet(PCefXmlReader(FData).get_namespace_uri(FData)); +end; + +function TCefXmlReaderRef.GetOuterXml: ustring; +begin + Result := CefStringFreeAndGet(PCefXmlReader(FData).get_outer_xml(FData)); +end; + +function TCefXmlReaderRef.GetPrefix: ustring; +begin + Result := CefStringFreeAndGet(PCefXmlReader(FData).get_prefix(FData)); +end; + +function TCefXmlReaderRef.GetQualifiedName: ustring; +begin + Result := CefStringFreeAndGet(PCefXmlReader(FData).get_qualified_name(FData)); +end; + +function TCefXmlReaderRef.GetType: TCefXmlNodeType; +begin + Result := PCefXmlReader(FData).get_type(FData); +end; + +function TCefXmlReaderRef.GetValue: ustring; +begin + Result := CefStringFreeAndGet(PCefXmlReader(FData).get_value(FData)); +end; + +function TCefXmlReaderRef.GetXmlLang: ustring; +begin + Result := CefStringFreeAndGet(PCefXmlReader(FData).get_xml_lang(FData)); +end; + +function TCefXmlReaderRef.HasAttributes: Boolean; +begin + Result := PCefXmlReader(FData).has_attributes(FData) <> 0; +end; + +function TCefXmlReaderRef.HasError: Boolean; +begin + Result := PCefXmlReader(FData).has_error(FData) <> 0; +end; + +function TCefXmlReaderRef.HasValue: Boolean; +begin + Result := PCefXmlReader(FData).has_value(FData) <> 0; +end; + +function TCefXmlReaderRef.IsEmptyElement: Boolean; +begin + Result := PCefXmlReader(FData).is_empty_element(FData) <> 0; +end; + +function TCefXmlReaderRef.MoveToAttributeByIndex(index: Integer): Boolean; +begin + Result := PCefXmlReader(FData).move_to_attribute_byindex(FData, index) <> 0; +end; + +function TCefXmlReaderRef.MoveToAttributeByLName(const localName, + namespaceURI: ustring): Boolean; +var + l, n: TCefString; +begin + l := CefString(localName); + n := CefString(namespaceURI); + Result := PCefXmlReader(FData).move_to_attribute_bylname(FData, @l, @n) <> 0; +end; + +function TCefXmlReaderRef.MoveToAttributeByQName( + const qualifiedName: ustring): Boolean; +var + q: TCefString; +begin + q := CefString(qualifiedName); + Result := PCefXmlReader(FData).move_to_attribute_byqname(FData, @q) <> 0; +end; + +function TCefXmlReaderRef.MoveToCarryingElement: Boolean; +begin + Result := PCefXmlReader(FData).move_to_carrying_element(FData) <> 0; +end; + +function TCefXmlReaderRef.MoveToFirstAttribute: Boolean; +begin + Result := PCefXmlReader(FData).move_to_first_attribute(FData) <> 0; +end; + +function TCefXmlReaderRef.MoveToNextAttribute: Boolean; +begin + Result := PCefXmlReader(FData).move_to_next_attribute(FData) <> 0; +end; + +function TCefXmlReaderRef.MoveToNextNode: Boolean; +begin + Result := PCefXmlReader(FData).move_to_next_node(FData) <> 0; +end; + +class function TCefXmlReaderRef.UnWrap(data: Pointer): ICefXmlReader; +begin + if data <> nil then + Result := Create(data) as ICefXmlReader else + Result := nil; +end; + +{ TCefZipReaderRef } + +function TCefZipReaderRef.Close: Boolean; +begin + Result := PCefZipReader(FData).close(FData) <> 0; +end; + +function TCefZipReaderRef.CloseFile: Boolean; +begin + Result := PCefZipReader(FData).close_file(FData) <> 0; +end; + +class function TCefZipReaderRef.New(const stream: ICefStreamReader): ICefZipReader; +begin + Result := UnWrap(cef_zip_reader_create(CefGetData(stream))); +end; + +function TCefZipReaderRef.Eof: Boolean; +begin + Result := PCefZipReader(FData).eof(FData) <> 0; +end; + +function TCefZipReaderRef.GetFileLastModified: LongInt; +begin + Result := PCefZipReader(FData).get_file_last_modified(FData); +end; + +function TCefZipReaderRef.GetFileName: ustring; +begin + Result := CefStringFreeAndGet(PCefZipReader(FData).get_file_name(FData)); +end; + +function TCefZipReaderRef.GetFileSize: Int64; +begin + Result := PCefZipReader(FData).get_file_size(FData); +end; + +function TCefZipReaderRef.MoveToFile(const fileName: ustring; + caseSensitive: Boolean): Boolean; +var + f: TCefString; +begin + f := CefString(fileName); + Result := PCefZipReader(FData).move_to_file(FData, @f, Ord(caseSensitive)) <> 0; +end; + +function TCefZipReaderRef.MoveToFirstFile: Boolean; +begin + Result := PCefZipReader(FData).move_to_first_file(FData) <> 0; +end; + +function TCefZipReaderRef.MoveToNextFile: Boolean; +begin + Result := PCefZipReader(FData).move_to_next_file(FData) <> 0; +end; + +function TCefZipReaderRef.OpenFile(const password: ustring): Boolean; +var + p: TCefString; +begin + p := CefString(password); + Result := PCefZipReader(FData).open_file(FData, @p) <> 0; +end; + +function TCefZipReaderRef.ReadFile(buffer: Pointer; + bufferSize: NativeUInt): Integer; +begin + Result := PCefZipReader(FData).read_file(FData, buffer, buffersize); +end; + +function TCefZipReaderRef.Tell: Int64; +begin + Result := PCefZipReader(FData).tell(FData); +end; + +class function TCefZipReaderRef.UnWrap(data: Pointer): ICefZipReader; +begin + if data <> nil then + Result := Create(data) as ICefZipReader else + Result := nil; +end; + +{ TCefFastTask } + +constructor TCefFastTask.Create(const method: TCefFastTaskProc); +begin + inherited Create; + FMethod := method; +end; + +procedure TCefFastTask.Execute; +begin + FMethod(); +end; + +class procedure TCefFastTask.New(threadId: TCefThreadId; const method: TCefFastTaskProc); +begin + CefPostTask(threadId, Create(method)); +end; + +class procedure TCefFastTask.NewDelayed(threadId: TCefThreadId; + Delay: Int64; const method: TCefFastTaskProc); +begin + CefPostDelayedTask(threadId, Create(method), Delay); +end; + +{ TCefv8ContextRef } + +class function TCefv8ContextRef.Current: ICefv8Context; +begin + Result := UnWrap(cef_v8context_get_current_context) +end; + +function TCefv8ContextRef.Enter: Boolean; +begin + Result := PCefv8Context(FData)^.enter(PCefv8Context(FData)) <> 0; +end; + +class function TCefv8ContextRef.Entered: ICefv8Context; +begin + Result := UnWrap(cef_v8context_get_entered_context) +end; + +function TCefv8ContextRef.Exit: Boolean; +begin + Result := PCefv8Context(FData)^.exit(PCefv8Context(FData)) <> 0; +end; + +function TCefv8ContextRef.GetBrowser: ICefBrowser; +begin + Result := TCefBrowserRef.UnWrap(PCefv8Context(FData)^.get_browser(PCefv8Context(FData))); +end; + +function TCefv8ContextRef.GetFrame: ICefFrame; +begin + Result := TCefFrameRef.UnWrap(PCefv8Context(FData)^.get_frame(PCefv8Context(FData))) +end; + +function TCefv8ContextRef.GetGlobal: ICefv8Value; +begin + Result := TCefv8ValueRef.UnWrap(PCefv8Context(FData)^.get_global(PCefv8Context(FData))); +end; + +function TCefv8ContextRef.GetTaskRunner: ICefTaskRunner; +begin + Result := TCefTaskRunnerRef.UnWrap(PCefv8Context(FData)^.get_task_runner(FData)); +end; + +function TCefv8ContextRef.IsSame(const that: ICefv8Context): Boolean; +begin + Result := PCefv8Context(FData)^.is_same(PCefv8Context(FData), CefGetData(that)) <> 0; +end; + +function TCefv8ContextRef.IsValid: Boolean; +begin + Result := PCefv8Context(FData)^.is_valid(FData) <> 0; +end; + +function TCefv8ContextRef.Eval(const code: ustring; var retval: ICefv8Value; + var exception: ICefV8Exception): Boolean; +var + c: TCefString; + r: PCefv8Value; + e: PCefV8Exception; +begin + c := CefString(code); + r := nil; e := nil; + Result := PCefv8Context(FData)^.eval(PCefv8Context(FData), @c, r, e) <> 0; + retval := TCefv8ValueRef.UnWrap(r); + exception := TCefV8ExceptionRef.UnWrap(e); +end; + +class function TCefv8ContextRef.UnWrap(data: Pointer): ICefv8Context; +begin + if data <> nil then + Result := Create(data) as ICefv8Context else + Result := nil; +end; + +{ TCefDomVisitorOwn } + +constructor TCefDomVisitorOwn.Create; +begin + inherited CreateData(SizeOf(TCefDomVisitor)); + with PCefDomVisitor(FData)^ do + visit := cef_dom_visitor_visite; +end; + +procedure TCefDomVisitorOwn.visit(const document: ICefDomDocument); +begin + +end; + +{ TCefFastDomVisitor } + +constructor TCefFastDomVisitor.Create(const proc: TCefDomVisitorProc); +begin + inherited Create; + FProc := proc; +end; + +procedure TCefFastDomVisitor.visit(const document: ICefDomDocument); +begin + FProc(document); +end; + +{ TCefDomDocumentRef } + +function TCefDomDocumentRef.GetBaseUrl: ustring; +begin + Result := CefStringFreeAndGet(PCefDomDocument(FData)^.get_base_url(PCefDomDocument(FData))) +end; + +function TCefDomDocumentRef.GetBody: ICefDomNode; +begin + Result := TCefDomNodeRef.UnWrap(PCefDomDocument(FData)^.get_body(PCefDomDocument(FData))); +end; + +function TCefDomDocumentRef.GetCompleteUrl(const partialURL: ustring): ustring; +var + p: TCefString; +begin + p := CefString(partialURL); + Result := CefStringFreeAndGet(PCefDomDocument(FData)^.get_complete_url(PCefDomDocument(FData), @p)); +end; + +function TCefDomDocumentRef.GetDocument: ICefDomNode; +begin + Result := TCefDomNodeRef.UnWrap(PCefDomDocument(FData)^.get_document(PCefDomDocument(FData))); +end; + +function TCefDomDocumentRef.GetElementById(const id: ustring): ICefDomNode; +var + i: TCefString; +begin + i := CefString(id); + Result := TCefDomNodeRef.UnWrap(PCefDomDocument(FData)^.get_element_by_id(PCefDomDocument(FData), @i)); +end; + +function TCefDomDocumentRef.GetFocusedNode: ICefDomNode; +begin + Result := TCefDomNodeRef.UnWrap(PCefDomDocument(FData)^.get_focused_node(PCefDomDocument(FData))); +end; + +function TCefDomDocumentRef.GetHead: ICefDomNode; +begin + Result := TCefDomNodeRef.UnWrap(PCefDomDocument(FData)^.get_head(PCefDomDocument(FData))); +end; + +function TCefDomDocumentRef.GetSelectionAsMarkup: ustring; +begin + Result := CefStringFreeAndGet(PCefDomDocument(FData)^.get_selection_as_markup(PCefDomDocument(FData))); +end; + +function TCefDomDocumentRef.GetSelectionAsText: ustring; +begin + Result := CefStringFreeAndGet(PCefDomDocument(FData)^.get_selection_as_text(PCefDomDocument(FData))); +end; + +function TCefDomDocumentRef.GetSelectionEndNode: ICefDomNode; +begin + Result := TCefDomNodeRef.UnWrap(PCefDomDocument(FData)^.get_selection_end_node(PCefDomDocument(FData))); +end; + +function TCefDomDocumentRef.GetSelectionEndOffset: Integer; +begin + Result := PCefDomDocument(FData)^.get_selection_end_offset(PCefDomDocument(FData)); +end; + +function TCefDomDocumentRef.GetSelectionStartNode: ICefDomNode; +begin + Result := TCefDomNodeRef.UnWrap(PCefDomDocument(FData)^.get_selection_start_node(PCefDomDocument(FData))); +end; + +function TCefDomDocumentRef.GetSelectionStartOffset: Integer; +begin + Result := PCefDomDocument(FData)^.get_selection_start_offset(PCefDomDocument(FData)); +end; + +function TCefDomDocumentRef.GetTitle: ustring; +begin + Result := CefStringFreeAndGet(PCefDomDocument(FData)^.get_title(PCefDomDocument(FData))); +end; + +function TCefDomDocumentRef.GetType: TCefDomDocumentType; +begin + Result := PCefDomDocument(FData)^.get_type(PCefDomDocument(FData)); +end; + +function TCefDomDocumentRef.HasSelection: Boolean; +begin + Result := PCefDomDocument(FData)^.has_selection(PCefDomDocument(FData)) <> 0; +end; + +class function TCefDomDocumentRef.UnWrap(data: Pointer): ICefDomDocument; +begin + if data <> nil then + Result := Create(data) as ICefDomDocument else + Result := nil; +end; + +{ TCefDomNodeRef } + +procedure TCefDomNodeRef.AddEventListener(const eventType: ustring; + useCapture: Boolean; const listener: ICefDomEventListener); +var + et: TCefString; +begin + et := CefString(eventType); + PCefDomNode(FData)^.add_event_listener(PCefDomNode(FData), @et, CefGetData(listener), Ord(useCapture)); +end; + +procedure TCefDomNodeRef.AddEventListenerProc(const eventType: ustring; useCapture: Boolean; + const proc: TCefDomEventListenerProc); +begin + AddEventListener(eventType, useCapture, TCefFastDomEventListener.Create(proc) as ICefDomEventListener); +end; + +function TCefDomNodeRef.GetAsMarkup: ustring; +begin + Result := CefStringFreeAndGet(PCefDomNode(FData)^.get_as_markup(PCefDomNode(FData))); +end; + +function TCefDomNodeRef.GetDocument: ICefDomDocument; +begin + Result := TCefDomDocumentRef.UnWrap(PCefDomNode(FData)^.get_document(PCefDomNode(FData))); +end; + +function TCefDomNodeRef.GetElementAttribute(const attrName: ustring): ustring; +var + p: TCefString; +begin + p := CefString(attrName); + Result := CefStringFreeAndGet(PCefDomNode(FData)^.get_element_attribute(PCefDomNode(FData), @p)); +end; + +procedure TCefDomNodeRef.GetElementAttributes(const attrMap: ICefStringMap); +begin + PCefDomNode(FData)^.get_element_attributes(PCefDomNode(FData), attrMap.Handle); +end; + +function TCefDomNodeRef.GetElementInnerText: ustring; +begin + Result := CefStringFreeAndGet(PCefDomNode(FData)^.get_element_inner_text(PCefDomNode(FData))); +end; + +function TCefDomNodeRef.GetElementTagName: ustring; +begin + Result := CefStringFreeAndGet(PCefDomNode(FData)^.get_element_tag_name(PCefDomNode(FData))); +end; + +function TCefDomNodeRef.GetFirstChild: ICefDomNode; +begin + Result := TCefDomNodeRef.UnWrap(PCefDomNode(FData)^.get_first_child(PCefDomNode(FData))); +end; + +function TCefDomNodeRef.GetFormControlElementType: ustring; +begin + Result := CefStringFreeAndGet(PCefDomNode(FData)^.get_form_control_element_type(PCefDomNode(FData))); +end; + +function TCefDomNodeRef.GetLastChild: ICefDomNode; +begin + Result := TCefDomNodeRef.UnWrap(PCefDomNode(FData)^.get_last_child(PCefDomNode(FData))); +end; + +function TCefDomNodeRef.GetName: ustring; +begin + Result := CefStringFreeAndGet(PCefDomNode(FData)^.get_name(PCefDomNode(FData))); +end; + +function TCefDomNodeRef.GetNextSibling: ICefDomNode; +begin + Result := TCefDomNodeRef.UnWrap(PCefDomNode(FData)^.get_next_sibling(PCefDomNode(FData))); +end; + +function TCefDomNodeRef.GetParent: ICefDomNode; +begin + Result := TCefDomNodeRef.UnWrap(PCefDomNode(FData)^.get_parent(PCefDomNode(FData))); +end; + +function TCefDomNodeRef.GetPreviousSibling: ICefDomNode; +begin + Result := TCefDomNodeRef.UnWrap(PCefDomNode(FData)^.get_previous_sibling(PCefDomNode(FData))); +end; + +function TCefDomNodeRef.GetType: TCefDomNodeType; +begin + Result := PCefDomNode(FData)^.get_type(PCefDomNode(FData)); +end; + +function TCefDomNodeRef.GetValue: ustring; +begin + Result := CefStringFreeAndGet(PCefDomNode(FData)^.get_value(PCefDomNode(FData))); +end; + +function TCefDomNodeRef.HasChildren: Boolean; +begin + Result := PCefDomNode(FData)^.has_children(PCefDomNode(FData)) <> 0; +end; + +function TCefDomNodeRef.HasElementAttribute(const attrName: ustring): Boolean; +var + p: TCefString; +begin + p := CefString(attrName); + Result := PCefDomNode(FData)^.has_element_attribute(PCefDomNode(FData), @p) <> 0; +end; + +function TCefDomNodeRef.HasElementAttributes: Boolean; +begin + Result := PCefDomNode(FData)^.has_element_attributes(PCefDomNode(FData)) <> 0; +end; + +function TCefDomNodeRef.IsEditable: Boolean; +begin + Result := PCefDomNode(FData)^.is_editable(PCefDomNode(FData)) <> 0; +end; + +function TCefDomNodeRef.IsElement: Boolean; +begin + Result := PCefDomNode(FData)^.is_element(PCefDomNode(FData)) <> 0; +end; + +function TCefDomNodeRef.IsFormControlElement: Boolean; +begin + Result := PCefDomNode(FData)^.is_form_control_element(PCefDomNode(FData)) <> 0; +end; + +function TCefDomNodeRef.IsSame(const that: ICefDomNode): Boolean; +begin + Result := PCefDomNode(FData)^.is_same(PCefDomNode(FData), CefGetData(that)) <> 0; +end; + +function TCefDomNodeRef.IsText: Boolean; +begin + Result := PCefDomNode(FData)^.is_text(PCefDomNode(FData)) <> 0; +end; + +function TCefDomNodeRef.SetElementAttribute(const attrName, + value: ustring): Boolean; +var + p1, p2: TCefString; +begin + p1 := CefString(attrName); + p2 := CefString(value); + Result := PCefDomNode(FData)^.set_element_attribute(PCefDomNode(FData), @p1, @p2) <> 0; +end; + +function TCefDomNodeRef.SetValue(const value: ustring): Boolean; +var + p: TCefString; +begin + p := CefString(value); + Result := PCefDomNode(FData)^.set_value(PCefDomNode(FData), @p) <> 0; +end; + +class function TCefDomNodeRef.UnWrap(data: Pointer): ICefDomNode; +begin + if data <> nil then + Result := Create(data) as ICefDomNode else + Result := nil; +end; + +{ TCefDomEventListenerOwn } + +constructor TCefDomEventListenerOwn.Create; +begin + inherited CreateData(SizeOf(TCefDomEventListener)); + with PCefDomEventListener(FData)^ do + handle_event := cef_dom_event_listener_handle_event; +end; + +procedure TCefDomEventListenerOwn.HandleEvent(const event: ICefDomEvent); +begin + +end; + +{ TCefDomEventRef } + +function TCefDomEventRef.CanBubble: Boolean; +begin + Result := PCefDomEvent(FData)^.can_bubble(PCefDomEvent(FData)) <> 0; +end; + +function TCefDomEventRef.CanCancel: Boolean; +begin + Result := PCefDomEvent(FData)^.can_cancel(PCefDomEvent(FData)) <> 0; +end; + +function TCefDomEventRef.GetCategory: TCefDomEventCategory; +begin + Result := PCefDomEvent(FData)^.get_category(PCefDomEvent(FData)); +end; + +function TCefDomEventRef.GetCurrentTarget: ICefDomNode; +begin + Result := TCefDomNodeRef.UnWrap(PCefDomEvent(FData)^.get_current_target(PCefDomEvent(FData))); +end; + +function TCefDomEventRef.GetDocument: ICefDomDocument; +begin + Result := TCefDomDocumentRef.UnWrap(PCefDomEvent(FData)^.get_document(PCefDomEvent(FData))); +end; + +function TCefDomEventRef.GetPhase: TCefDomEventPhase; +begin + Result := PCefDomEvent(FData)^.get_phase(PCefDomEvent(FData)); +end; + +function TCefDomEventRef.GetTarget: ICefDomNode; +begin + Result := TCefDomNodeRef.UnWrap(PCefDomEvent(FData)^.get_target(PCefDomEvent(FData))); +end; + +function TCefDomEventRef.GetType: ustring; +begin + Result := CefStringFreeAndGet(PCefDomEvent(FData)^.get_type(PCefDomEvent(FData))); +end; + +class function TCefDomEventRef.UnWrap(data: Pointer): ICefDomEvent; +begin + if data <> nil then + Result := Create(data) as ICefDomEvent else + Result := nil; +end; + +{ TCefFastDomEventListener } + +constructor TCefFastDomEventListener.Create( + const proc: TCefDomEventListenerProc); +begin + inherited Create; + FProc := proc; +end; + +procedure TCefFastDomEventListener.HandleEvent(const event: ICefDomEvent); +begin + inherited; + FProc(event); +end; + +{ TCefResponseRef } + +class function TCefResponseRef.New: ICefResponse; +begin + Result := UnWrap(cef_response_create); +end; + +function TCefResponseRef.GetHeader(const name: ustring): ustring; +var + n: TCefString; +begin + n := CefString(name); + Result := CefStringFreeAndGet(PCefResponse(FData)^.get_header(PCefResponse(FData), @n)); +end; + +procedure TCefResponseRef.GetHeaderMap(const headerMap: ICefStringMultimap); +begin + PCefResponse(FData)^.get_header_map(PCefResponse(FData), headermap.Handle); +end; + +function TCefResponseRef.GetMimeType: ustring; +begin + Result := CefStringFreeAndGet(PCefResponse(FData)^.get_mime_type(PCefResponse(FData))); +end; + +function TCefResponseRef.GetStatus: Integer; +begin + Result := PCefResponse(FData)^.get_status(PCefResponse(FData)); +end; + +function TCefResponseRef.GetStatusText: ustring; +begin + Result := CefStringFreeAndGet(PCefResponse(FData)^.get_status_text(PCefResponse(FData))); +end; + +function TCefResponseRef.IsReadOnly: Boolean; +begin + Result := PCefResponse(FData)^.is_read_only(PCefResponse(FData)) <> 0; +end; + +procedure TCefResponseRef.SetHeaderMap(const headerMap: ICefStringMultimap); +begin + PCefResponse(FData)^.set_header_map(PCefResponse(FData), headerMap.Handle); +end; + +procedure TCefResponseRef.SetMimeType(const mimetype: ustring); +var + txt: TCefString; +begin + txt := CefString(mimetype); + PCefResponse(FData)^.set_mime_type(PCefResponse(FData), @txt); +end; + +procedure TCefResponseRef.SetStatus(status: Integer); +begin + PCefResponse(FData)^.set_status(PCefResponse(FData), status); +end; + +procedure TCefResponseRef.SetStatusText(const StatusText: ustring); +var + txt: TCefString; +begin + txt := CefString(StatusText); + PCefResponse(FData)^.set_status_text(PCefResponse(FData), @txt); +end; + +class function TCefResponseRef.UnWrap(data: Pointer): ICefResponse; +begin + if data <> nil then + Result := Create(data) as ICefResponse else + Result := nil; +end; + +{ TCefRTTIExtension } + +{$IFDEF DELPHI14_UP} + +constructor TCefRTTIExtension.Create(const value: TValue +{$IFDEF CEF_MULTI_THREADED_MESSAGE_LOOP} +; SyncMainThread: Boolean +{$ENDIF} +); +begin + inherited Create; + FCtx := TRttiContext.Create; +{$IFDEF CEF_MULTI_THREADED_MESSAGE_LOOP} + FSyncMainThread := SyncMainThread; +{$ENDIF} + FValue := value; +end; + +destructor TCefRTTIExtension.Destroy; +begin + FCtx.Free; + inherited; +end; + +function TCefRTTIExtension.GetValue(pi: PTypeInfo; const v: ICefv8Value; var ret: TValue): Boolean; + function ProcessInt: Boolean; + var + sv: record + case byte of + 0: (ub: Byte); + 1: (sb: ShortInt); + 2: (uw: Word); + 3: (sw: SmallInt); + 4: (si: Integer); + 5: (ui: Cardinal); + end; + pd: PTypeData; + begin + pd := GetTypeData(pi); + if (v.IsInt or v.IsBool) and (v.GetIntValue >= pd.MinValue) and (v.GetIntValue <= pd.MaxValue) then + begin + case pd.OrdType of + otSByte: sv.sb := v.GetIntValue; + otUByte: sv.ub := v.GetIntValue; + otSWord: sv.sw := v.GetIntValue; + otUWord: sv.uw := v.GetIntValue; + otSLong: sv.si := v.GetIntValue; + otULong: sv.ui := v.GetIntValue; + end; + TValue.Make(@sv, pi, ret); + end else + Exit(False); + Result := True; + end; + + function ProcessInt64: Boolean; + var + i: Int64; + begin + i := StrToInt64(v.GetStringValue); // hack + TValue.Make(@i, pi, ret); + Result := True; + end; + + function ProcessUString: Boolean; + var + vus: string; + begin + if v.IsString then + begin + vus := v.GetStringValue; + TValue.Make(@vus, pi, ret); + end else + Exit(False); + Result := True; + end; + + function ProcessLString: Boolean; + var + vas: AnsiString; + begin + if v.IsString then + begin + vas := AnsiString(v.GetStringValue); + TValue.Make(@vas, pi, ret); + end else + Exit(False); + Result := True; + end; + + function ProcessWString: Boolean; + var + vws: WideString; + begin + if v.IsString then + begin + vws := v.GetStringValue; + TValue.Make(@vws, pi, ret); + end else + Exit(False); + Result := True; + end; + + function ProcessFloat: Boolean; + var + sv: record + case byte of + 0: (fs: Single); + 1: (fd: Double); + 2: (fe: Extended); + 3: (fc: Comp); + 4: (fcu: Currency); + end; + begin + if v.IsDouble or v.IsInt then + begin + case GetTypeData(pi).FloatType of + ftSingle: sv.fs := v.GetDoubleValue; + ftDouble: sv.fd := v.GetDoubleValue; + ftExtended: sv.fe := v.GetDoubleValue; + ftComp: sv.fc := v.GetDoubleValue; + ftCurr: sv.fcu := v.GetDoubleValue; + end; + TValue.Make(@sv, pi, ret); + end else + if v.IsDate then + begin + sv.fd := v.GetDateValue; + TValue.Make(@sv, pi, ret); + end else + Exit(False); + Result := True; + end; + + function ProcessSet: Boolean; + var + sv: record + case byte of + 0: (ub: Byte); + 1: (sb: ShortInt); + 2: (uw: Word); + 3: (sw: SmallInt); + 4: (si: Integer); + 5: (ui: Cardinal); + end; + begin + if v.IsInt then + begin + case GetTypeData(pi).OrdType of + otSByte: sv.sb := v.GetIntValue; + otUByte: sv.ub := v.GetIntValue; + otSWord: sv.sw := v.GetIntValue; + otUWord: sv.uw := v.GetIntValue; + otSLong: sv.si := v.GetIntValue; + otULong: sv.ui := v.GetIntValue; + end; + TValue.Make(@sv, pi, ret); + end else + Exit(False); + Result := True; + end; + + function ProcessVariant: Boolean; + var + vr: Variant; + i: Integer; + vl: TValue; + begin + VarClear(vr); + if v.IsString then vr := v.GetStringValue else + if v.IsBool then vr := v.GetBoolValue else + if v.IsInt then vr := v.GetIntValue else + if v.IsDouble then vr := v.GetDoubleValue else + if v.IsUndefined then TVarData(vr).VType := varEmpty else + if v.IsNull then TVarData(vr).VType := varNull else + if v.IsArray then + begin + vr := VarArrayCreate([0, v.GetArrayLength], varVariant); + for i := 0 to v.GetArrayLength - 1 do + begin + if not GetValue(pi, v.GetValueByIndex(i), vl) then Exit(False); + VarArrayPut(vr, vl.AsVariant, i); + end; + end else + Exit(False); + TValue.Make(@vr, pi, ret); + Result := True; + end; + + function ProcessObject: Boolean; + var + ud: ICefv8Value; + i: Pointer; + td: PTypeData; + rt: TRttiType; + begin + if v.IsObject then + begin + ud := v.GetUserData; + if (ud = nil) then Exit(False); +{$IFDEF CPUX64} + rt := StrToPtr(ud.GetValueByIndex(0).GetStringValue); +{$ELSE} + rt := TRttiType(ud.GetValueByIndex(0).GetIntValue); +{$ENDIF} + td := GetTypeData(rt.Handle); + + if (rt.TypeKind = tkClass) and td.ClassType.InheritsFrom(GetTypeData(pi).ClassType) then + begin +{$IFDEF CPUX64} + i := StrToPtr(ud.GetValueByIndex(1).GetStringValue); +{$ELSE} + i := Pointer(ud.GetValueByIndex(1).GetIntValue); +{$ENDIF} + + TValue.Make(@i, pi, ret); + end else + Exit(False); + end else + Exit(False); + Result := True; + end; + + function ProcessClass: Boolean; + var + ud: ICefv8Value; + i: Pointer; + rt: TRttiType; + begin + if v.IsObject then + begin + ud := v.GetUserData; + if (ud = nil) then Exit(False); +{$IFDEF CPUX64} + rt := StrToPtr(ud.GetValueByIndex(0).GetStringValue); +{$ELSE} + rt := TRttiType(ud.GetValueByIndex(0).GetIntValue); +{$ENDIF} + + if (rt.TypeKind = tkClassRef) then + begin +{$IFDEF CPUX64} + i := StrToPtr(ud.GetValueByIndex(1).GetStringValue); +{$ELSE} + i := Pointer(ud.GetValueByIndex(1).GetIntValue); +{$ENDIF} + TValue.Make(@i, pi, ret); + end else + Exit(False); + end else + Exit(False); + Result := True; + end; + + function ProcessRecord: Boolean; + var + r: TRttiField; + f: TValue; + rec: Pointer; + begin + if v.IsObject then + begin + TValue.Make(nil, pi, ret); +{$IFDEF DELPHI15_UP} + rec := TValueData(ret).FValueData.GetReferenceToRawData; +{$ELSE} + rec := IValueData(TValueData(ret).FHeapData).GetReferenceToRawData; +{$ENDIF} + for r in FCtx.GetType(pi).GetFields do + begin + if not GetValue(r.FieldType.Handle, v.GetValueByKey(r.Name), f) then + Exit(False); + r.SetValue(rec, f); + end; + Result := True; + end else + Result := False; + end; + + function ProcessInterface: Boolean; + begin + if pi = TypeInfo(ICefV8Value) then + begin + TValue.Make(@v, pi, ret); + Result := True; + end else + Result := False; // todo + end; +begin + case pi.Kind of + tkInteger, tkEnumeration: Result := ProcessInt; + tkInt64: Result := ProcessInt64; + tkUString: Result := ProcessUString; + tkLString: Result := ProcessLString; + tkWString: Result := ProcessWString; + tkFloat: Result := ProcessFloat; + tkSet: Result := ProcessSet; + tkVariant: Result := ProcessVariant; + tkClass: Result := ProcessObject; + tkClassRef: Result := ProcessClass; + tkRecord: Result := ProcessRecord; + tkInterface: Result := ProcessInterface; + else + Result := False; + end; +end; + +function TCefRTTIExtension.SetValue(const v: TValue; var ret: ICefv8Value): Boolean; + + function ProcessRecord: Boolean; + var + rf: TRttiField; + vl: TValue; + ud, v8: ICefv8Value; + rec: Pointer; + rt: TRttiType; + begin + ud := TCefv8ValueRef.NewArray(1); + rt := FCtx.GetType(v.TypeInfo); +{$IFDEF CPUX64} + ud.SetValueByIndex(0, TCefv8ValueRef.NewString(PtrToStr(rt))); +{$ELSE} + ud.SetValueByIndex(0, TCefv8ValueRef.NewInt(Integer(rt))); +{$ENDIF} + ret := TCefv8ValueRef.NewObject(nil); + ret.SetUserData(ud); + +{$IFDEF DELPHI15_UP} + rec := TValueData(v).FValueData.GetReferenceToRawData; +{$ELSE} + rec := IValueData(TValueData(v).FHeapData).GetReferenceToRawData; +{$ENDIF} +{$IFDEF CEF_MULTI_THREADED_MESSAGE_LOOP} + if FSyncMainThread then + begin + v8 := ret; + TThread.Synchronize(nil, procedure + var + rf: TRttiField; + o: ICefv8Value; + begin + for rf in rt.GetFields do + begin + vl := rf.GetValue(rec); + SetValue(vl, o); + v8.SetValueByKey(rf.Name, o, []); + end; + end) + end else +{$ENDIF} + for rf in FCtx.GetType(v.TypeInfo).GetFields do + begin + vl := rf.GetValue(rec); + if not SetValue(vl, v8) then + Exit(False); + ret.SetValueByKey(rf.Name, v8, []); + end; + Result := True; + end; + + function ProcessObject: Boolean; + var + m: TRttiMethod; + p: TRttiProperty; + fl: TRttiField; + f: ICefv8Value; + _r, _g, _s, ud: ICefv8Value; + _a: TCefv8ValueArray; + rt: TRttiType; + begin + rt := FCtx.GetType(v.TypeInfo); + + ud := TCefv8ValueRef.NewArray(2); +{$IFDEF CPUX64} + ud.SetValueByIndex(0, TCefv8ValueRef.NewString(PtrToStr(rt))); + ud.SetValueByIndex(1, TCefv8ValueRef.NewString(PtrToStr(v.AsObject))); +{$ELSE} + ud.SetValueByIndex(0, TCefv8ValueRef.NewInt(Integer(rt))); + ud.SetValueByIndex(1, TCefv8ValueRef.NewInt(Integer(v.AsObject))); +{$ENDIF} + ret := TCefv8ValueRef.NewObject(nil); // todo + ret.SetUserData(ud); + + for m in rt.GetMethods do + if m.Visibility > mvProtected then + begin + f := TCefv8ValueRef.NewFunction(m.Name, Self); + ret.SetValueByKey(m.Name, f, []); + end; + + for p in rt.GetProperties do + if (p.Visibility > mvProtected) then + begin + if _g = nil then _g := ret.GetValueByKey('__defineGetter__'); + if _s = nil then _s := ret.GetValueByKey('__defineSetter__'); + SetLength(_a, 2); + _a[0] := TCefv8ValueRef.NewString(p.Name); + if p.IsReadable then + begin + _a[1] := TCefv8ValueRef.NewFunction('$pg' + p.Name, Self); + _r := _g.ExecuteFunction(ret, _a); + end; + if p.IsWritable then + begin + _a[1] := TCefv8ValueRef.NewFunction('$ps' + p.Name, Self); + _r := _s.ExecuteFunction(ret, _a); + end; + end; + + for fl in rt.GetFields do + if (fl.Visibility > mvProtected) then + begin + if _g = nil then _g := ret.GetValueByKey('__defineGetter__'); + if _s = nil then _s := ret.GetValueByKey('__defineSetter__'); + + SetLength(_a, 2); + _a[0] := TCefv8ValueRef.NewString(fl.Name); + _a[1] := TCefv8ValueRef.NewFunction('$vg' + fl.Name, Self); + _r := _g.ExecuteFunction(ret, _a); + _a[1] := TCefv8ValueRef.NewFunction('$vs' + fl.Name, Self); + _r := _s.ExecuteFunction(ret, _a); + end; + + Result := True; + end; + + function ProcessClass: Boolean; + var + m: TRttiMethod; + f, ud: ICefv8Value; + c: TClass; + rt: TRttiType; + begin + c := v.AsClass; + rt := FCtx.GetType(c); + + ud := TCefv8ValueRef.NewArray(2); +{$IFDEF CPUX64} + ud.SetValueByIndex(0, TCefv8ValueRef.NewString(PtrToStr(rt))); + ud.SetValueByIndex(1, TCefv8ValueRef.NewString(PtrToStr(c))); +{$ELSE} + ud.SetValueByIndex(0, TCefv8ValueRef.NewInt(Integer(rt))); + ud.SetValueByIndex(1, TCefv8ValueRef.NewInt(Integer(c))); +{$ENDIF} + ret := TCefv8ValueRef.NewObject(nil); // todo + ret.SetUserData(ud); + + if c <> nil then + begin + for m in rt.GetMethods do + if (m.Visibility > mvProtected) and (m.MethodKind in [mkClassProcedure, mkClassFunction]) then + begin + f := TCefv8ValueRef.NewFunction(m.Name, Self); + ret.SetValueByKey(m.Name, f, []); + end; + end; + + Result := True; + end; + + function ProcessVariant: Boolean; + var + vr: Variant; + begin + vr := v.AsVariant; + case TVarData(vr).VType of + varSmallint, varInteger, varShortInt: + ret := TCefv8ValueRef.NewInt(vr); + varByte, varWord, varLongWord: + ret := TCefv8ValueRef.NewUInt(vr); + varUString, varOleStr, varString: + ret := TCefv8ValueRef.NewString(vr); + varSingle, varDouble, varCurrency, varUInt64, varInt64: + ret := TCefv8ValueRef.NewDouble(vr); + varBoolean: + ret := TCefv8ValueRef.NewBool(vr); + varNull: + ret := TCefv8ValueRef.NewNull; + varEmpty: + ret := TCefv8ValueRef.NewUndefined; + else + ret := nil; + Exit(False) + end; + Result := True; + end; + + function ProcessInterface: Boolean; + var + m: TRttiMethod; + f: ICefv8Value; + ud: ICefv8Value; + rt: TRttiType; + begin + rt := FCtx.GetType(v.TypeInfo); + + ud := TCefv8ValueRef.NewArray(2); +{$IFDEF CPUX64} + ud.SetValueByIndex(0, TCefv8ValueRef.NewString(PtrToStr(rt))); + ud.SetValueByIndex(1, TCefv8ValueRef.NewString(PtrToStr(Pointer(v.AsInterface)))); +{$ELSE} + ud.SetValueByIndex(0, TCefv8ValueRef.NewInt(Integer(rt))); + ud.SetValueByIndex(1, TCefv8ValueRef.NewInt(Integer(v.AsInterface))); +{$ENDIF} + ret := TCefv8ValueRef.NewObject(nil); + ret.SetUserData(ud); + + for m in rt.GetMethods do + if m.Visibility > mvProtected then + begin + f := TCefv8ValueRef.NewFunction(m.Name, Self); + ret.SetValueByKey(m.Name, f, []); + end; + + Result := True; + end; + + function ProcessFloat: Boolean; + begin + if v.TypeInfo = TypeInfo(TDateTime) then + ret := TCefv8ValueRef.NewDate(TValueData(v).FAsDouble) else + ret := TCefv8ValueRef.NewDouble(v.AsExtended); + Result := True; + end; + +begin + case v.TypeInfo.Kind of + tkUString, tkLString, tkWString, tkChar, tkWChar: + ret := TCefv8ValueRef.NewString(v.AsString); + tkInteger: ret := TCefv8ValueRef.NewInt(v.AsInteger); + tkEnumeration: + if v.TypeInfo = TypeInfo(Boolean) then + ret := TCefv8ValueRef.NewBool(v.AsBoolean) else + ret := TCefv8ValueRef.NewInt(TValueData(v).FAsSLong); + tkFloat: if not ProcessFloat then Exit(False); + tkInt64: ret := TCefv8ValueRef.NewDouble(v.AsInt64); + tkClass: if not ProcessObject then Exit(False); + tkClassRef: if not ProcessClass then Exit(False); + tkRecord: if not ProcessRecord then Exit(False); + tkVariant: if not ProcessVariant then Exit(False); + tkInterface: if not ProcessInterface then Exit(False); + else + Exit(False) + end; + Result := True; +end; + +class procedure TCefRTTIExtension.Register(const name: string; + const value: TValue{$IFDEF CEF_MULTI_THREADED_MESSAGE_LOOP}; SyncMainThread: Boolean{$ENDIF}); +begin + CefRegisterExtension(name, + format('__defineSetter__(''%s'', function(v){native function $s();$s(v)});__defineGetter__(''%0:s'', function(){native function $g();return $g()});', [name]), + TCefRTTIExtension.Create(value +{$IFDEF CEF_MULTI_THREADED_MESSAGE_LOOP} + , SyncMainThread +{$ENDIF} + ) as ICefv8Handler); +end; + +{$IFDEF CPUX64} +class function TCefRTTIExtension.StrToPtr(const str: ustring): Pointer; +begin + HexToBin(PWideChar(str), @Result, SizeOf(Result)); +end; + +class function TCefRTTIExtension.PtrToStr(p: Pointer): ustring; +begin + SetLength(Result, SizeOf(p)*2); + BinToHex(@p, PWideChar(Result), SizeOf(p)); +end; +{$ENDIF} + +function TCefRTTIExtension.Execute(const name: ustring; const obj: ICefv8Value; + const arguments: TCefv8ValueArray; var retval: ICefv8Value; + var exception: ustring): Boolean; +var + p: PChar; + ud: ICefv8Value; + rt: TRttiType; + val: TObject; + cls: TClass; + m: TRttiMethod; + pr: TRttiProperty; + vl: TRttiField; + args: array of TValue; + prm: TArray; + i: Integer; + ret: TValue; +begin + Result := True; + p := PChar(name); + m := nil; + if obj <> nil then + begin + ud := obj.GetUserData; + if ud <> nil then + begin +{$IFDEF CPUX64} + rt := StrToPtr(ud.GetValueByIndex(0).GetStringValue); +{$ELSE} + rt := TRttiType(ud.GetValueByIndex(0).GetIntValue); +{$ENDIF} + case rt.TypeKind of + tkClass: + begin +{$IFDEF CPUX64} + val := StrToPtr(ud.GetValueByIndex(1).GetStringValue); +{$ELSE} + val := TObject(ud.GetValueByIndex(1).GetIntValue); +{$ENDIF} + cls := GetTypeData(rt.Handle).ClassType; + + if p^ = '$' then + begin + inc(p); + case p^ of + 'p': + begin + inc(p); + case p^ of + 'g': + begin + inc(p); + pr := rt.GetProperty(p); +{$IFDEF CEF_MULTI_THREADED_MESSAGE_LOOP} + if FSyncMainThread then + begin + TThread.Synchronize(nil, procedure begin + ret := pr.GetValue(val); + end); + Exit(SetValue(ret, retval)); + end else +{$ENDIF} + Exit(SetValue(pr.GetValue(val), retval)); + end; + 's': + begin + inc(p); + pr := rt.GetProperty(p); + if GetValue(pr.PropertyType.Handle, arguments[0], ret) then + begin +{$IFDEF CEF_MULTI_THREADED_MESSAGE_LOOP} + if FSyncMainThread then + TThread.Synchronize(nil, procedure begin + pr.SetValue(val, ret) end) else +{$ENDIF} + pr.SetValue(val, ret); + Exit(True); + end else + Exit(False); + end; + end; + end; + 'v': + begin + inc(p); + case p^ of + 'g': + begin + inc(p); + vl := rt.GetField(p); +{$IFDEF CEF_MULTI_THREADED_MESSAGE_LOOP} + if FSyncMainThread then + begin + TThread.Synchronize(nil, procedure begin + ret := vl.GetValue(val); + end); + Exit(SetValue(ret, retval)); + end else +{$ENDIF} + Exit(SetValue(vl.GetValue(val), retval)); + end; + 's': + begin + inc(p); + vl := rt.GetField(p); + if GetValue(vl.FieldType.Handle, arguments[0], ret) then + begin +{$IFDEF CEF_MULTI_THREADED_MESSAGE_LOOP} + if FSyncMainThread then + TThread.Synchronize(nil, procedure begin + vl.SetValue(val, ret) end) else +{$ENDIF} + vl.SetValue(val, ret); + Exit(True); + end else + Exit(False); + end; + end; + end; + end; + end else + m := rt.GetMethod(name); + end; + tkClassRef: + begin + val := nil; +{$IFDEF CPUX64} + cls := StrToPtr(ud.GetValueByIndex(1).GetStringValue); +{$ELSE} + cls := TClass(ud.GetValueByIndex(1).GetIntValue); +{$ENDIF} + m := FCtx.GetType(cls).GetMethod(name); + end; + else + m := nil; + cls := nil; + val := nil; + end; + + prm := m.GetParameters; + i := Length(prm); + if i = Length(arguments) then + begin + SetLength(args, i); + for i := 0 to i - 1 do + if not GetValue(prm[i].ParamType.Handle, arguments[i], args[i]) then + Exit(False); + + case m.MethodKind of + mkClassProcedure, mkClassFunction: +{$IFDEF CEF_MULTI_THREADED_MESSAGE_LOOP} + if FSyncMainThread then + TThread.Synchronize(nil, procedure begin + ret := m.Invoke(cls, args) end) else +{$ENDIF} + ret := m.Invoke(cls, args); + mkProcedure, mkFunction: + if (val <> nil) then + begin +{$IFDEF CEF_MULTI_THREADED_MESSAGE_LOOP} + if FSyncMainThread then + TThread.Synchronize(nil, procedure begin + ret := m.Invoke(val, args) end) else +{$ENDIF} + ret := m.Invoke(val, args); + end else + Exit(False) + else + Exit(False); + end; + + if m.MethodKind in [mkClassFunction, mkFunction] then + if not SetValue(ret, retval) then + Exit(False); + end else + Exit(False); + end else + if p^ = '$' then + begin + inc(p); + case p^ of + 'g': SetValue(FValue, retval); + 's': GetValue(FValue.TypeInfo, arguments[0], FValue); + else + Exit(False); + end; + end else + Exit(False); + end else + Exit(False); +end; +{$ENDIF} + +{ TCefV8AccessorOwn } + +constructor TCefV8AccessorOwn.Create; +begin + inherited CreateData(SizeOf(TCefV8Accessor)); + PCefV8Accessor(FData)^.get := cef_v8_accessor_get; + PCefV8Accessor(FData)^.put := cef_v8_accessor_put; +end; + +function TCefV8AccessorOwn.Get(const name: ustring; const obj: ICefv8Value; + out value: ICefv8Value; const exception: ustring): Boolean; +begin + Result := False; +end; + +function TCefV8AccessorOwn.Put(const name: ustring; const obj, + value: ICefv8Value; const exception: ustring): Boolean; +begin + Result := False; +end; + +{ TCefFastV8Accessor } + +constructor TCefFastV8Accessor.Create( + const getter: TCefV8AccessorGetterProc; + const setter: TCefV8AccessorSetterProc); +begin + FGetter := getter; + FSetter := setter; +end; + +function TCefFastV8Accessor.Get(const name: ustring; const obj: ICefv8Value; + out value: ICefv8Value; const exception: ustring): Boolean; +begin + if Assigned(FGetter) then + Result := FGetter(name, obj, value, exception) else + Result := False; +end; + +function TCefFastV8Accessor.Put(const name: ustring; const obj, + value: ICefv8Value; const exception: ustring): Boolean; +begin + if Assigned(FSetter) then + Result := FSetter(name, obj, value, exception) else + Result := False; +end; + +{ TCefCookieVisitorOwn } + +constructor TCefCookieVisitorOwn.Create; +begin + inherited CreateData(SizeOf(TCefCookieVisitor)); + PCefCookieVisitor(FData)^.visit := cef_cookie_visitor_visit; +end; + +function TCefCookieVisitorOwn.visit(const name, value, domain, path: ustring; + secure, httponly, hasExpires: Boolean; const creation, lastAccess, expires: TDateTime; + count, total: Integer; out deleteCookie: Boolean): Boolean; +begin + Result := True; +end; + +{ TCefFastCookieVisitor } + +constructor TCefFastCookieVisitor.Create(const visitor: TCefCookieVisitorProc); +begin + inherited Create; + FVisitor := visitor; +end; + +function TCefFastCookieVisitor.visit(const name, value, domain, path: ustring; + secure, httponly, hasExpires: Boolean; const creation, lastAccess, + expires: TDateTime; count, total: Integer; out deleteCookie: Boolean): Boolean; +begin + Result := FVisitor(name, value, domain, path, secure, httponly, hasExpires, + creation, lastAccess, expires, count, total, deleteCookie); +end; + +{ TCefClientOwn } + +constructor TCefClientOwn.Create; +begin + inherited CreateData(SizeOf(TCefClient)); + with PCefClient(FData)^ do + begin + get_context_menu_handler := cef_client_get_context_menu_handler; + get_dialog_handler := cef_client_get_dialog_handler; + get_display_handler := cef_client_get_display_handler; + get_download_handler := cef_client_get_download_handler; + get_drag_handler := cef_client_get_drag_handler; + get_focus_handler := cef_client_get_focus_handler; + get_geolocation_handler := cef_client_get_geolocation_handler; + get_jsdialog_handler := cef_client_get_jsdialog_handler; + get_keyboard_handler := cef_client_get_keyboard_handler; + get_life_span_handler := cef_client_get_life_span_handler; + get_load_handler := cef_client_get_load_handler; + get_render_handler := cef_client_get_get_render_handler; + get_request_handler := cef_client_get_request_handler; + on_process_message_received := cef_client_on_process_message_received; + end; +end; + +function TCefClientOwn.GetContextMenuHandler: ICefContextMenuHandler; +begin + Result := nil; +end; + +function TCefClientOwn.GetDialogHandler: ICefDialogHandler; +begin + Result := nil; +end; + +function TCefClientOwn.GetDisplayHandler: ICefDisplayHandler; +begin + Result := nil; +end; + +function TCefClientOwn.GetDownloadHandler: ICefDownloadHandler; +begin + Result := nil; +end; + +function TCefClientOwn.GetDragHandler: ICefDragHandler; +begin + Result := nil; +end; + +function TCefClientOwn.GetFocusHandler: ICefFocusHandler; +begin + Result := nil; +end; + +function TCefClientOwn.GetGeolocationHandler: ICefGeolocationHandler; +begin + Result := nil; +end; + +function TCefClientOwn.GetJsdialogHandler: ICefJsDialogHandler; +begin + Result := nil; +end; + +function TCefClientOwn.GetKeyboardHandler: ICefKeyboardHandler; +begin + Result := nil; +end; + +function TCefClientOwn.GetLifeSpanHandler: ICefLifeSpanHandler; +begin + Result := nil; +end; + +function TCefClientOwn.GetLoadHandler: ICefLoadHandler; +begin + Result := nil; +end; + +function TCefClientOwn.GetRenderHandler: ICefRenderHandler; +begin + Result := nil; +end; + +function TCefClientOwn.GetRequestHandler: ICefRequestHandler; +begin + Result := nil; +end; + +function TCefClientOwn.OnProcessMessageReceived(const browser: ICefBrowser; + sourceProcess: TCefProcessId; const message: ICefProcessMessage): Boolean; +begin + Result := False; +end; + +{ TCefGeolocationHandlerOwn } + +constructor TCefGeolocationHandlerOwn.Create; +begin + inherited CreateData(SizeOf(TCefGeolocationHandler)); + with PCefGeolocationHandler(FData)^ do + begin + on_request_geolocation_permission := cef_geolocation_handler_on_request_geolocation_permission; + on_cancel_geolocation_permission := cef_geolocation_handler_on_cancel_geolocation_permission; + end; +end; + + procedure TCefGeolocationHandlerOwn.OnRequestGeolocationPermission( + const browser: ICefBrowser; const requestingUrl: ustring; requestId: Integer; + const callback: ICefGeolocationCallback); +begin + +end; + +procedure TCefGeolocationHandlerOwn.OnCancelGeolocationPermission( + const browser: ICefBrowser; const requestingUrl: ustring; requestId: Integer); +begin + +end; + +{ TCefLifeSpanHandlerOwn } + +constructor TCefLifeSpanHandlerOwn.Create; +begin + inherited CreateData(SizeOf(TCefLifeSpanHandler)); + with PCefLifeSpanHandler(FData)^ do + begin + on_before_popup := @cef_life_span_handler_on_before_popup; + on_after_created := @cef_life_span_handler_on_after_created; + on_before_close := @cef_life_span_handler_on_before_close; + run_modal := @cef_life_span_handler_run_modal; + do_close := @cef_life_span_handler_do_close; + end; +end; + +procedure TCefLifeSpanHandlerOwn.OnAfterCreated(const browser: ICefBrowser); +begin + +end; + +procedure TCefLifeSpanHandlerOwn.OnBeforeClose(const browser: ICefBrowser); +begin + +end; + +function TCefLifeSpanHandlerOwn.OnBeforePopup(const browser: ICefBrowser; + const frame: ICefFrame; const targetUrl, targetFrameName: ustring; + var popupFeatures: TCefPopupFeatures; var windowInfo: TCefWindowInfo; + var client: ICefClient; var settings: TCefBrowserSettings; + var noJavascriptAccess: Boolean): Boolean; +begin + Result := False; +end; + +function TCefLifeSpanHandlerOwn.DoClose(const browser: ICefBrowser): Boolean; +begin + Result := False; +end; + +function TCefLifeSpanHandlerOwn.RunModal(const browser: ICefBrowser): Boolean; +begin + Result := False; +end; + + +{ TCefLoadHandlerOwn } + +constructor TCefLoadHandlerOwn.Create; +begin + inherited CreateData(SizeOf(TCefLoadHandler)); + with PCefLoadHandler(FData)^ do + begin + on_loading_state_change := cef_load_handler_on_loading_state_change; + on_load_start := cef_load_handler_on_load_start; + on_load_end := cef_load_handler_on_load_end; + on_load_error := cef_load_handler_on_load_error; + end; +end; + +procedure TCefLoadHandlerOwn.OnLoadEnd(const browser: ICefBrowser; + const frame: ICefFrame; httpStatusCode: Integer); +begin + +end; + +procedure TCefLoadHandlerOwn.OnLoadError(const browser: ICefBrowser; + const frame: ICefFrame; errorCode: Integer; const errorText, failedUrl: ustring); +begin + +end; + +procedure TCefLoadHandlerOwn.OnLoadingStateChange(const browser: ICefBrowser; + isLoading, canGoBack, canGoForward: Boolean); +begin + +end; + +procedure TCefLoadHandlerOwn.OnLoadStart(const browser: ICefBrowser; + const frame: ICefFrame); +begin + +end; + +{ TCefRequestHandlerOwn } + +constructor TCefRequestHandlerOwn.Create; +begin + inherited CreateData(SizeOf(TCefRequestHandler)); + with PCefRequestHandler(FData)^ do + begin + on_before_browse := cef_request_handler_on_before_browse; + on_before_resource_load := cef_request_handler_on_before_resource_load; + get_resource_handler := cef_request_handler_get_resource_handler; + on_resource_redirect := cef_request_handler_on_resource_redirect; + get_auth_credentials := cef_request_handler_get_auth_credentials; + on_quota_request := cef_request_handler_on_quota_request; + on_protocol_execution := cef_request_handler_on_protocol_execution; + on_certificate_error := cef_request_handler_on_certificate_error; + on_before_plugin_load := cef_request_handler_on_before_plugin_load; + on_plugin_crashed := cef_request_handler_on_plugin_crashed; + on_render_process_terminated := cef_request_handler_on_render_process_terminated; + end; +end; + +function TCefRequestHandlerOwn.GetAuthCredentials(const browser: ICefBrowser; const frame: ICefFrame; + isProxy: Boolean; const host: ustring; port: Integer; const realm, scheme: ustring; + const callback: ICefAuthCallback): Boolean; +begin + Result := False; +end; + +function TCefRequestHandlerOwn.OnBeforeBrowse(const browser: ICefBrowser; + const frame: ICefFrame; const request: ICefRequest; + isRedirect: Boolean): Boolean; +begin + Result := False; +end; + +function TCefRequestHandlerOwn.OnBeforePluginLoad(const browser: ICefBrowser; + const url, policyUrl: ustring; const info: ICefWebPluginInfo): Boolean; +begin + Result := False; +end; + +function TCefRequestHandlerOwn.OnBeforeResourceLoad(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest): Boolean; +begin + Result := False; +end; + +function TCefRequestHandlerOwn.OnCertificateError(certError: TCefErrorCode; + const requestUrl: ustring; + const callback: ICefAllowCertificateErrorCallback): Boolean; +begin + Result := False; +end; + +function TCefRequestHandlerOwn.GetResourceHandler(const browser: ICefBrowser; + const frame: ICefFrame; const request: ICefRequest): ICefResourceHandler; +begin + Result := nil; +end; + +procedure TCefRequestHandlerOwn.OnPluginCrashed(const browser: ICefBrowser; + const pluginPath: ustring); +begin + +end; + +procedure TCefRequestHandlerOwn.OnProtocolExecution(const browser: ICefBrowser; + const url: ustring; out allowOsExecution: Boolean); +begin + +end; + +function TCefRequestHandlerOwn.OnQuotaRequest(const browser: ICefBrowser; + const originUrl: ustring; newSize: Int64; + const callback: ICefQuotaCallback): Boolean; +begin + Result := False; +end; + +procedure TCefRequestHandlerOwn.OnRenderProcessTerminated( + const browser: ICefBrowser; status: TCefTerminationStatus); +begin + +end; + +procedure TCefRequestHandlerOwn.OnResourceRedirect(const browser: ICefBrowser; + const frame: ICefFrame; const oldUrl: ustring; var newUrl: ustring); +begin + +end; + +{ TCefDisplayHandlerOwn } + +constructor TCefDisplayHandlerOwn.Create; +begin + inherited CreateData(SizeOf(TCefDisplayHandler)); + with PCefDisplayHandler(FData)^ do + begin + on_address_change := cef_display_handler_on_address_change; + on_title_change := cef_display_handler_on_title_change; + on_tooltip := cef_display_handler_on_tooltip; + on_status_message := cef_display_handler_on_status_message; + on_console_message := cef_display_handler_on_console_message; + end; +end; + +procedure TCefDisplayHandlerOwn.OnAddressChange(const browser: ICefBrowser; + const frame: ICefFrame; const url: ustring); +begin + +end; + +function TCefDisplayHandlerOwn.OnConsoleMessage(const browser: ICefBrowser; + const message, source: ustring; line: Integer): Boolean; +begin + Result := False; +end; + +procedure TCefDisplayHandlerOwn.OnStatusMessage(const browser: ICefBrowser; + const value: ustring); +begin + +end; + +procedure TCefDisplayHandlerOwn.OnTitleChange(const browser: ICefBrowser; + const title: ustring); +begin + +end; + +function TCefDisplayHandlerOwn.OnTooltip(const browser: ICefBrowser; + var text: ustring): Boolean; +begin + Result := False; +end; + +{ TCefFocusHandlerOwn } + +constructor TCefFocusHandlerOwn.Create; +begin + inherited CreateData(SizeOf(TCefFocusHandler)); + with PCefFocusHandler(FData)^ do + begin + on_take_focus := cef_focus_handler_on_take_focus; + on_set_focus := cef_focus_handler_on_set_focus; + on_got_focus := cef_focus_handler_on_got_focus; + end; +end; + +function TCefFocusHandlerOwn.OnSetFocus(const browser: ICefBrowser; + source: TCefFocusSource): Boolean; +begin + Result := False; +end; + +procedure TCefFocusHandlerOwn.OnGotFocus(const browser: ICefBrowser); +begin + +end; + +procedure TCefFocusHandlerOwn.OnTakeFocus(const browser: ICefBrowser; + next: Boolean); +begin + +end; + +{ TCefKeyboardHandlerOwn } + +constructor TCefKeyboardHandlerOwn.Create; +begin + inherited CreateData(SizeOf(TCefKeyboardHandler)); + with PCefKeyboardHandler(FData)^ do + begin + on_pre_key_event := cef_keyboard_handler_on_pre_key_event; + on_key_event := cef_keyboard_handler_on_key_event; + end; +end; + +function TCefKeyboardHandlerOwn.OnPreKeyEvent(const browser: ICefBrowser; + const event: PCefKeyEvent; osEvent: TCefEventHandle; + out isKeyboardShortcut: Boolean): Boolean; +begin + Result := False; +end; + +function TCefKeyboardHandlerOwn.OnKeyEvent(const browser: ICefBrowser; + const event: PCefKeyEvent; osEvent: TCefEventHandle): Boolean; +begin + Result := False; +end; + +{ TCefJsDialogHandlerOwn } + +constructor TCefJsDialogHandlerOwn.Create; +begin + inherited CreateData(SizeOf(TCefJsDialogHandler)); + with PCefJsDialogHandler(FData)^ do + begin + on_jsdialog := cef_jsdialog_handler_on_jsdialog; + on_before_unload_dialog := cef_jsdialog_handler_on_before_unload_dialog; + on_reset_dialog_state := cef_jsdialog_handler_on_reset_dialog_state; + on_dialog_closed := cef_jsdialog_handler_on_dialog_closed; + end; +end; + +function TCefJsDialogHandlerOwn.OnJsdialog(const browser: ICefBrowser; + const originUrl, acceptLang: ustring; dialogType: TCefJsDialogType; + const messageText, defaultPromptText: ustring; callback: ICefJsDialogCallback; + out suppressMessage: Boolean): Boolean; +begin + Result := False; +end; + +function TCefJsDialogHandlerOwn.OnBeforeUnloadDialog(const browser: ICefBrowser; + const messageText: ustring; isReload: Boolean; const callback: ICefJsDialogCallback): Boolean; +begin + Result := False; +end; + +procedure TCefJsDialogHandlerOwn.OnDialogClosed(const browser: ICefBrowser); +begin + +end; + +procedure TCefJsDialogHandlerOwn.OnResetDialogState(const browser: ICefBrowser); +begin + +end; + +{ TCefContextMenuHandlerOwn } + +constructor TCefContextMenuHandlerOwn.Create; +begin + inherited CreateData(SizeOf(TCefContextMenuHandler)); + with PCefContextMenuHandler(FData)^ do + begin + on_before_context_menu := cef_context_menu_handler_on_before_context_menu; + on_context_menu_command := cef_context_menu_handler_on_context_menu_command; + on_context_menu_dismissed := cef_context_menu_handler_on_context_menu_dismissed; + end; +end; + +procedure TCefContextMenuHandlerOwn.OnBeforeContextMenu( + const browser: ICefBrowser; const frame: ICefFrame; + const params: ICefContextMenuParams; const model: ICefMenuModel); +begin + +end; + +function TCefContextMenuHandlerOwn.OnContextMenuCommand( + const browser: ICefBrowser; const frame: ICefFrame; + const params: ICefContextMenuParams; commandId: Integer; + eventFlags: TCefEventFlags): Boolean; +begin + Result := False; +end; + +procedure TCefContextMenuHandlerOwn.OnContextMenuDismissed( + const browser: ICefBrowser; const frame: ICefFrame); +begin + +end; + +{ TCefV8ExceptionRef } + +function TCefV8ExceptionRef.GetEndColumn: Integer; +begin + Result := PCefV8Exception(FData)^.get_end_column(FData); +end; + +function TCefV8ExceptionRef.GetEndPosition: Integer; +begin + Result := PCefV8Exception(FData)^.get_end_position(FData); +end; + +function TCefV8ExceptionRef.GetLineNumber: Integer; +begin + Result := PCefV8Exception(FData)^.get_line_number(FData); +end; + +function TCefV8ExceptionRef.GetMessage: ustring; +begin + Result := CefStringFreeAndGet(PCefV8Exception(FData)^.get_message(FData)); +end; + +function TCefV8ExceptionRef.GetScriptResourceName: ustring; +begin + Result := CefStringFreeAndGet(PCefV8Exception(FData)^.get_script_resource_name(FData)); +end; + +function TCefV8ExceptionRef.GetSourceLine: ustring; +begin + Result := CefStringFreeAndGet(PCefV8Exception(FData)^.get_source_line(FData)); +end; + +function TCefV8ExceptionRef.GetStartColumn: Integer; +begin + Result := PCefV8Exception(FData)^.get_start_column(FData); +end; + +function TCefV8ExceptionRef.GetStartPosition: Integer; +begin + Result := PCefV8Exception(FData)^.get_start_position(FData); +end; + +class function TCefV8ExceptionRef.UnWrap(data: Pointer): ICefV8Exception; +begin + if data <> nil then + Result := Create(data) as ICefV8Exception else + Result := nil; +end; + +{ TCefResourceBundleHandlerOwn } + +constructor TCefResourceBundleHandlerOwn.Create; +begin + inherited CreateData(SizeOf(TCefResourceBundleHandler)); + with PCefResourceBundleHandler(FData)^ do + begin + get_localized_string := cef_resource_bundle_handler_get_localized_string; + get_data_resource := cef_resource_bundle_handler_get_data_resource; + end; +end; + +{ TCefFastResourceBundle } + +constructor TCefFastResourceBundle.Create(AGetDataResource: TGetDataResource; + AGetLocalizedString: TGetLocalizedString); +begin + inherited Create; + FGetDataResource := AGetDataResource; + FGetLocalizedString := AGetLocalizedString; +end; + +function TCefFastResourceBundle.GetDataResource(resourceId: Integer; + out data: Pointer; out dataSize: NativeUInt): Boolean; +begin + if Assigned(FGetDataResource) then + Result := FGetDataResource(resourceId, data, dataSize) else + Result := False; +end; + +function TCefFastResourceBundle.GetLocalizedString(messageId: Integer; + out stringVal: ustring): Boolean; +begin + if Assigned(FGetLocalizedString) then + Result := FGetLocalizedString(messageId, stringVal) else + Result := False; +end; + +{ TCefAppOwn } + +constructor TCefAppOwn.Create; +begin + inherited CreateData(SizeOf(TCefApp)); + with PCefApp(FData)^ do + begin + on_before_command_line_processing := cef_app_on_before_command_line_processing; + on_register_custom_schemes := cef_app_on_register_custom_schemes; + get_resource_bundle_handler := cef_app_get_resource_bundle_handler; + get_browser_process_handler := cef_app_get_browser_process_handler; + get_render_process_handler := cef_app_get_render_process_handler; + end; +end; + +{ TCefCookieManagerRef } + +class function TCefCookieManagerRef.New(const path: ustring; + persistSessionCookies: Boolean): ICefCookieManager2; +var + pth: TCefString; +begin + pth := CefString(path); + Result := UnWrap(cef_cookie_manager_create_manager(@pth, Ord(persistSessionCookies))); +end; + +function TCefCookieManagerRef.DeleteCookies(const url, + cookieName: ustring): Boolean; +var + u, n: TCefString; +begin + u := CefString(url); + n := CefString(cookieName); + Result := PCefCookieManager(FData).delete_cookies( + PCefCookieManager(FData), @u, @n) <> 0; +end; + +function TCefCookieManagerRef.FlushStore( + const handler: ICefCompletionHandler): Boolean; +begin + Result := PCefCookieManager(FData).flush_store(PCefCookieManager(FData), + CefGetData(handler)) <> 0; +end; + +function TCefCookieManagerRef.FlushStoreProc( + const proc: TCefCompletionHandlerProc): Boolean; +begin + Result := FlushStore(TCefFastCompletionHandler.Create(proc)) +end; + +class function TCefCookieManagerRef.Global: ICefCookieManager2; +begin + Result := UnWrap(cef_cookie_manager_get_global_manager()); +end; + +function TCefCookieManagerRef.SetCookie(const url, name, value, domain, + path: ustring; secure, httponly, hasExpires: Boolean; const creation, + lastAccess, expires: TDateTime): Boolean; +var + str: TCefString; + cook: TCefCookie; +begin + str := CefString(url); + cook.name := CefString(name); + cook.value := CefString(value); + cook.domain := CefString(domain); + cook.path := CefString(path); + cook.secure := secure; + cook.httponly := httponly; + cook.creation := DateTimeToCefTime(creation); + cook.last_access := DateTimeToCefTime(lastAccess); + cook.has_expires := hasExpires; + if hasExpires then + cook.expires := DateTimeToCefTime(expires) else + FillChar(cook.expires, SizeOf(TCefTime), 0); + Result := PCefCookieManager(FData).set_cookie( + PCefCookieManager(FData), @str, @cook) <> 0; +end; + +function TCefCookieManagerRef.SetStoragePath(const path: ustring; persistSessionCookies: Boolean): Boolean; +var + p: TCefString; +begin + p := CefString(path); + Result := PCefCookieManager(FData)^.set_storage_path( + PCefCookieManager(FData), @p, Ord(persistSessionCookies)) <> 0; +end; + +procedure TCefCookieManagerRef.SetSupportedSchemes(schemes: TStrings); +var + list: TCefStringList; + i: Integer; + item: TCefString; +begin + list := cef_string_list_alloc(); + try + if (schemes <> nil) then + for i := 0 to schemes.Count - 1 do + begin + item := CefString(schemes[i]); + cef_string_list_append(list, @item); + end; + PCefCookieManager(FData).set_supported_schemes( + PCefCookieManager(FData), list); + finally + cef_string_list_free(list); + end; +end; + +class function TCefCookieManagerRef.UnWrap(data: Pointer): ICefCookieManager2; +begin + if data <> nil then + Result := Create(data) as ICefCookieManager2 else + Result := nil; +end; + +function TCefCookieManagerRef.VisitAllCookies( + const visitor: ICefCookieVisitor): Boolean; +begin + Result := PCefCookieManager(FData).visit_all_cookies( + PCefCookieManager(FData), CefGetData(visitor)) <> 0; +end; + +function TCefCookieManagerRef.VisitAllCookiesProc( + const visitor: TCefCookieVisitorProc): Boolean; +begin + Result := VisitAllCookies( + TCefFastCookieVisitor.Create(visitor) as ICefCookieVisitor); +end; + +function TCefCookieManagerRef.VisitUrlCookies(const url: ustring; + includeHttpOnly: Boolean; const visitor: ICefCookieVisitor): Boolean; +var + str: TCefString; +begin + str := CefString(url); + Result := PCefCookieManager(FData).visit_url_cookies(PCefCookieManager(FData), @str, Ord(includeHttpOnly), CefGetData(visitor)) <> 0; +end; + +function TCefCookieManagerRef.VisitUrlCookiesProc(const url: ustring; + includeHttpOnly: Boolean; const visitor: TCefCookieVisitorProc): Boolean; +begin + Result := VisitUrlCookies(url, includeHttpOnly, + TCefFastCookieVisitor.Create(visitor) as ICefCookieVisitor); +end; + +{ TCefWebPluginInfoRef } + +function TCefWebPluginInfoRef.GetDescription: ustring; +begin + Result := CefStringFreeAndGet(PCefWebPluginInfo(FData)^.get_description(PCefWebPluginInfo(FData))); +end; + +function TCefWebPluginInfoRef.GetName: ustring; +begin + Result := CefStringFreeAndGet(PCefWebPluginInfo(FData)^.get_name(PCefWebPluginInfo(FData))); +end; + +function TCefWebPluginInfoRef.GetPath: ustring; +begin + Result := CefStringFreeAndGet(PCefWebPluginInfo(FData)^.get_path(PCefWebPluginInfo(FData))); +end; + +function TCefWebPluginInfoRef.GetVersion: ustring; +begin + Result := CefStringFreeAndGet(PCefWebPluginInfo(FData)^.get_version(PCefWebPluginInfo(FData))); +end; + +class function TCefWebPluginInfoRef.UnWrap(data: Pointer): ICefWebPluginInfo; +begin + if data <> nil then + Result := Create(data) as ICefWebPluginInfo else + Result := nil; +end; + +{ TCefBrowserHostRef } + +procedure TCefBrowserHostRef.Find(identifier: Integer; + const searchText: ustring; forward, matchCase, findNext: Boolean); +var + st: TCefString; +begin + st := CefString(searchText); + PCefBrowserHost(FData).find(FData, Ord(identifier), @st, Ord(forward), Ord(matchCase), Ord(findNext)); +end; + +function TCefBrowserHostRef.GetBrowser: ICefBrowser; +begin + Result := TCefBrowserRef.UnWrap(PCefBrowserHost(FData).get_browser(PCefBrowserHost(FData))); +end; + +procedure TCefBrowserHostRef.ParentWindowWillClose; +begin + PCefBrowserHost(FData).parent_window_will_close(PCefBrowserHost(FData)); +end; + +procedure TCefBrowserHostRef.Print; +begin + PCefBrowserHost(FData).print(FData); +end; + +procedure TCefBrowserHostRef.RunFileDialog(mode: TCefFileDialogMode; + const title, defaultFileName: ustring; acceptTypes: TStrings; + const callback: ICefRunFileDialogCallback); +var + t, f: TCefString; + list: TCefStringList; + item: TCefString; + i: Integer; +begin + t := CefString(title); + f := CefString(defaultFileName); + list := cef_string_list_alloc(); + try + for i := 0 to acceptTypes.Count - 1 do + begin + item := CefString(acceptTypes[i]); + cef_string_list_append(list, @item); + end; + PCefBrowserHost(FData).run_file_dialog(PCefBrowserHost(FData), mode, @t, @f, + list, CefGetData(callback)); + finally + cef_string_list_free(list); + end; +end; + +procedure TCefBrowserHostRef.RunFileDialogProc(mode: TCefFileDialogMode; + const title, defaultFileName: ustring; acceptTypes: TStrings; + const callback: TCefRunFileDialogCallbackProc); +begin + RunFileDialog(mode, title, defaultFileName, acceptTypes, + TCefFastRunFileDialogCallback.Create(callback)); +end; + +procedure TCefBrowserHostRef.CloseBrowser(forceClose: Boolean); +begin + PCefBrowserHost(FData).close_browser(PCefBrowserHost(FData), Ord(forceClose)); +end; + +procedure TCefBrowserHostRef.SendCaptureLostEvent; +begin + PCefBrowserHost(FData).send_capture_lost_event(FData); +end; + +procedure TCefBrowserHostRef.SendFocusEvent(setFocus: Boolean); +begin + PCefBrowserHost(FData).send_focus_event(FData, Ord(setFocus)); +end; + +procedure TCefBrowserHostRef.SendKeyEvent(const event: PCefKeyEvent); +begin + PCefBrowserHost(FData).send_key_event(FData, event); +end; + +procedure TCefBrowserHostRef.SendMouseClickEvent(const event: PCefMouseEvent; + kind: TCefMouseButtonType; mouseUp: Boolean; clickCount: Integer); +begin + PCefBrowserHost(FData).send_mouse_click_event(FData, event, kind, Ord(mouseUp), clickCount); +end; + +procedure TCefBrowserHostRef.SendMouseMoveEvent(const event: PCefMouseEvent; + mouseLeave: Boolean); +begin + PCefBrowserHost(FData).send_mouse_move_event(FData, event, Ord(mouseLeave)); +end; + +procedure TCefBrowserHostRef.SendMouseWheelEvent(const event: PCefMouseEvent; + deltaX, deltaY: Integer); +begin + PCefBrowserHost(FData).send_mouse_wheel_event(FData, event, deltaX, deltaY); +end; + +procedure TCefBrowserHostRef.SetFocus(enable: Boolean); +begin + PCefBrowserHost(FData).set_focus(PCefBrowserHost(FData), Ord(enable)); +end; + +procedure TCefBrowserHostRef.SetMouseCursorChangeDisabled(disabled: Boolean); +begin + PCefBrowserHost(FData).set_mouse_cursor_change_disabled(PCefBrowserHost(FData), Ord(disabled)); +end; + +function TCefBrowserHostRef.GetWindowHandle: TCefWindowHandle; +begin + Result := PCefBrowserHost(FData).get_window_handle(PCefBrowserHost(FData)) +end; + +function TCefBrowserHostRef.GetOpenerWindowHandle: TCefWindowHandle; +begin + Result := PCefBrowserHost(FData).get_opener_window_handle(PCefBrowserHost(FData)); +end; + +function TCefBrowserHostRef.GetRequestContext: ICefRequestContext; +begin + Result := TCefRequestContextRef.UnWrap(PCefBrowserHost(FData).get_request_context(PCefBrowserHost(FData))); +end; + +function TCefBrowserHostRef.GetDevToolsUrl(httpScheme: Boolean): ustring; +begin + Result := CefStringFreeAndGet(PCefBrowserHost(FData).get_dev_tools_url(PCefBrowserHost(FData), Ord(httpScheme))); +end; + +function TCefBrowserHostRef.GetNsTextInputContext: TCefTextInputContext; +begin + Result := PCefBrowserHost(FData).get_nstext_input_context(PCefBrowserHost(FData)); +end; + +function TCefBrowserHostRef.GetZoomLevel: Double; +begin + Result := PCefBrowserHost(FData).get_zoom_level(PCefBrowserHost(FData)); +end; + +procedure TCefBrowserHostRef.HandleKeyEventAfterTextInputClient( + keyEvent: TCefEventHandle); +begin + PCefBrowserHost(FData).handle_key_event_after_text_input_client(PCefBrowserHost(FData), keyEvent); +end; + +procedure TCefBrowserHostRef.HandleKeyEventBeforeTextInputClient( + keyEvent: TCefEventHandle); +begin + PCefBrowserHost(FData).handle_key_event_before_text_input_client(PCefBrowserHost(FData), keyEvent); +end; + +procedure TCefBrowserHostRef.Invalidate(const dirtyRect: PCefRect; + kind: TCefPaintElementType); +begin + PCefBrowserHost(FData).invalidate(FData, dirtyRect, kind); +end; + +function TCefBrowserHostRef.IsMouseCursorChangeDisabled: Boolean; +begin + Result := PCefBrowserHost(FData).is_mouse_cursor_change_disabled(FData) <> 0 +end; + +function TCefBrowserHostRef.IsWindowRenderingDisabled: Boolean; +begin + Result := PCefBrowserHost(FData).is_window_rendering_disabled(FData) <> 0 +end; + +procedure TCefBrowserHostRef.NotifyScreenInfoChanged; +begin + PCefBrowserHost(FData).notify_screen_info_changed(PCefBrowserHost(FData)); +end; + +procedure TCefBrowserHostRef.SetZoomLevel(zoomLevel: Double); +begin + PCefBrowserHost(FData).set_zoom_level(PCefBrowserHost(FData), zoomLevel); +end; + +procedure TCefBrowserHostRef.StartDownload(const url: ustring); +var + u: TCefString; +begin + u := CefString(url); + PCefBrowserHost(FData).start_download(PCefBrowserHost(FData), @u); +end; + +procedure TCefBrowserHostRef.StopFinding(clearSelection: Boolean); +begin + PCefBrowserHost(FData).stop_finding(FData, Ord(clearSelection)); +end; + +class function TCefBrowserHostRef.UnWrap(data: Pointer): ICefBrowserHost; +begin + if data <> nil then + Result := Create(data) as ICefBrowserHost else + Result := nil; +end; + +procedure TCefBrowserHostRef.WasHidden(hidden: Boolean); +begin + PCefBrowserHost(FData).was_hidden(FData, Ord(hidden)); +end; + +procedure TCefBrowserHostRef.WasResized; +begin + PCefBrowserHost(FData).was_resized(FData); +end; + +{ TCefProcessMessageRef } + +function TCefProcessMessageRef.Copy: ICefProcessMessage; +begin + Result := UnWrap(PCefProcessMessage(FData)^.copy(PCefProcessMessage(FData))); +end; + +function TCefProcessMessageRef.GetArgumentList: ICefListValue; +begin + Result := TCefListValueRef.UnWrap(PCefProcessMessage(FData)^.get_argument_list(PCefProcessMessage(FData))); +end; + +function TCefProcessMessageRef.GetName: ustring; +begin + Result := CefStringFreeAndGet(PCefProcessMessage(FData)^.get_name(PCefProcessMessage(FData))); +end; + +function TCefProcessMessageRef.IsReadOnly: Boolean; +begin + Result := PCefProcessMessage(FData)^.is_read_only(PCefProcessMessage(FData)) <> 0; +end; + +function TCefProcessMessageRef.IsValid: Boolean; +begin + Result := PCefProcessMessage(FData)^.is_valid(PCefProcessMessage(FData)) <> 0; +end; + +class function TCefProcessMessageRef.New(const name: ustring): ICefProcessMessage; +var + n: TCefString; +begin + n := CefString(name); + Result := UnWrap(cef_process_message_create(@n)); +end; + +class function TCefProcessMessageRef.UnWrap(data: Pointer): ICefProcessMessage; +begin + if data <> nil then + Result := Create(data) as ICefProcessMessage else + Result := nil; +end; + +{ TCefStringVisitorOwn } + +constructor TCefStringVisitorOwn.Create; +begin + inherited CreateData(SizeOf(TCefStringVisitor)); + with PCefStringVisitor(FData)^ do + visit := cef_string_visitor_visit; +end; + +procedure TCefStringVisitorOwn.Visit(const str: ustring); +begin + +end; + +{ TCefFastStringVisitor } + +constructor TCefFastStringVisitor.Create( + const callback: TCefStringVisitorProc); +begin + inherited Create; + FVisit := callback; +end; + +procedure TCefFastStringVisitor.Visit(const str: ustring); +begin + FVisit(str); +end; + +{ TCefDownLoadItemRef } + +function TCefDownLoadItemRef.GetContentDisposition: ustring; +begin + Result := CefStringFreeAndGet(PCefDownloadItem(FData)^.get_content_disposition(PCefDownloadItem(FData))); +end; + +function TCefDownLoadItemRef.GetCurrentSpeed: Int64; +begin + Result := PCefDownloadItem(FData)^.get_current_speed(PCefDownloadItem(FData)); +end; + +function TCefDownLoadItemRef.GetEndTime: TDateTime; +begin + Result := CefTimeToDateTime(PCefDownloadItem(FData)^.get_end_time(PCefDownloadItem(FData))); +end; + +function TCefDownLoadItemRef.GetFullPath: ustring; +begin + Result := CefStringFreeAndGet(PCefDownloadItem(FData)^.get_full_path(PCefDownloadItem(FData))); +end; + +function TCefDownLoadItemRef.GetId: Integer; +begin + Result := PCefDownloadItem(FData)^.get_id(PCefDownloadItem(FData)); +end; + +function TCefDownLoadItemRef.GetMimeType: ustring; +begin + Result := CefStringFreeAndGet(PCefDownloadItem(FData)^.get_mime_type(PCefDownloadItem(FData))); +end; + +function TCefDownLoadItemRef.GetPercentComplete: Integer; +begin + Result := PCefDownloadItem(FData)^.get_percent_complete(PCefDownloadItem(FData)); +end; + +function TCefDownLoadItemRef.GetReceivedBytes: Int64; +begin + Result := PCefDownloadItem(FData)^.get_received_bytes(PCefDownloadItem(FData)); +end; + +function TCefDownLoadItemRef.GetStartTime: TDateTime; +begin + Result := CefTimeToDateTime(PCefDownloadItem(FData)^.get_start_time(PCefDownloadItem(FData))); +end; + +function TCefDownLoadItemRef.GetSuggestedFileName: ustring; +begin + Result := CefStringFreeAndGet(PCefDownloadItem(FData)^.get_suggested_file_name(PCefDownloadItem(FData))); +end; + +function TCefDownLoadItemRef.GetTotalBytes: Int64; +begin + Result := PCefDownloadItem(FData)^.get_total_bytes(PCefDownloadItem(FData)); +end; + +function TCefDownLoadItemRef.GetUrl: ustring; +begin + Result := CefStringFreeAndGet(PCefDownloadItem(FData)^.get_url(PCefDownloadItem(FData))); +end; + +function TCefDownLoadItemRef.IsCanceled: Boolean; +begin + Result := PCefDownloadItem(FData)^.is_canceled(PCefDownloadItem(FData)) <> 0; +end; + +function TCefDownLoadItemRef.IsComplete: Boolean; +begin + Result := PCefDownloadItem(FData)^.is_complete(PCefDownloadItem(FData)) <> 0; +end; + +function TCefDownLoadItemRef.IsInProgress: Boolean; +begin + Result := PCefDownloadItem(FData)^.is_in_progress(PCefDownloadItem(FData)) <> 0; +end; + +function TCefDownLoadItemRef.IsValid: Boolean; +begin + Result := PCefDownloadItem(FData)^.is_valid(PCefDownloadItem(FData)) <> 0; +end; + +class function TCefDownLoadItemRef.UnWrap(data: Pointer): ICefDownLoadItem; +begin + if data <> nil then + Result := Create(data) as ICefDownLoadItem else + Result := nil; +end; + +{ TCefBeforeDownloadCallbackRef } + +procedure TCefBeforeDownloadCallbackRef.Cont(const downloadPath: ustring; + showDialog: Boolean); +var + dp: TCefString; +begin + dp := CefString(downloadPath); + PCefBeforeDownloadCallback(FData).cont(PCefBeforeDownloadCallback(FData), @dp, Ord(showDialog)); +end; + +class function TCefBeforeDownloadCallbackRef.UnWrap( + data: Pointer): ICefBeforeDownloadCallback; +begin + if data <> nil then + Result := Create(data) as ICefBeforeDownloadCallback else + Result := nil; +end; + +{ TCefDownloadItemCallbackRef } + +procedure TCefDownloadItemCallbackRef.cancel; +begin + PCefDownloadItemCallback(FData).cancel(PCefDownloadItemCallback(FData)); +end; + +class function TCefDownloadItemCallbackRef.UnWrap( + data: Pointer): ICefDownloadItemCallback; +begin + if data <> nil then + Result := Create(data) as ICefDownloadItemCallback else + Result := nil; +end; + +{ TCefAuthCallbackRef } + +procedure TCefAuthCallbackRef.Cancel; +begin + PCefAuthCallback(FData).cancel(PCefAuthCallback(FData)); +end; + +procedure TCefAuthCallbackRef.Cont(const username, password: ustring); +var + u, p: TCefString; +begin + u := CefString(username); + p := CefString(password); + PCefAuthCallback(FData).cont(PCefAuthCallback(FData), @u, @p); +end; + +class function TCefAuthCallbackRef.UnWrap(data: Pointer): ICefAuthCallback; +begin + if data <> nil then + Result := Create(data) as ICefAuthCallback else + Result := nil; +end; + +{ TCefJsDialogCallbackRef } + +procedure TCefJsDialogCallbackRef.Cont(success: Boolean; + const userInput: ustring); +var + ui: TCefString; +begin + ui := CefString(userInput); + PCefJsDialogCallback(FData).cont(PCefJsDialogCallback(FData), Ord(success), @ui); +end; + +class function TCefJsDialogCallbackRef.UnWrap( + data: Pointer): ICefJsDialogCallback; +begin + if data <> nil then + Result := Create(data) as ICefJsDialogCallback else + Result := nil; +end; + +{ TCefCommandLineRef } + +procedure TCefCommandLineRef.AppendArgument(const argument: ustring); +var + a: TCefString; +begin + a := CefString(argument); + PCefCommandLine(FData).append_argument(PCefCommandLine(FData), @a); +end; + +procedure TCefCommandLineRef.AppendSwitch(const name: ustring); +var + n: TCefString; +begin + n := CefString(name); + PCefCommandLine(FData).append_switch(PCefCommandLine(FData), @n); +end; + +procedure TCefCommandLineRef.AppendSwitchWithValue(const name, value: ustring); +var + n, v: TCefString; +begin + n := CefString(name); + v := CefString(value); + PCefCommandLine(FData).append_switch_with_value(PCefCommandLine(FData), @n, @v); +end; + +function TCefCommandLineRef.Copy: ICefCommandLine; +begin + Result := UnWrap(PCefCommandLine(FData).copy(PCefCommandLine(FData))); +end; + +procedure TCefCommandLineRef.GetArguments(arguments: TStrings); +var + list: TCefStringList; + i: Integer; + str: TCefString; +begin + list := cef_string_list_alloc; + try + PCefCommandLine(FData).get_arguments(PCefCommandLine(FData), list); + for i := 0 to cef_string_list_size(list) - 1 do + begin + FillChar(str, SizeOf(str), 0); + cef_string_list_value(list, i, @str); + arguments.Add(CefStringClearAndGet(str)); + end; + finally + cef_string_list_free(list); + end; +end; + +procedure TCefCommandLineRef.GetArgv(args: TStrings); +var + list: TCefStringList; + i: Integer; + str: TCefString; +begin + list := cef_string_list_alloc; + try + PCefCommandLine(FData).get_argv(FData, list); + for i := 0 to cef_string_list_size(list) - 1 do + begin + FillChar(str, SizeOf(str), 0); + cef_string_list_value(list, i, @str); + args.Add(CefStringClearAndGet(str)); + end; + finally + cef_string_list_free(list); + end; +end; + +function TCefCommandLineRef.GetCommandLineString: ustring; +begin + Result := CefStringFreeAndGet(PCefCommandLine(FData).get_command_line_string(PCefCommandLine(FData))); +end; + +function TCefCommandLineRef.GetProgram: ustring; +begin + Result := CefStringFreeAndGet(PCefCommandLine(FData).get_program(PCefCommandLine(FData))); +end; + +procedure TCefCommandLineRef.GetSwitches(switches: TStrings); +var + list: TCefStringList; + i: Integer; + str: TCefString; +begin + list := cef_string_list_alloc; + try + PCefCommandLine(FData).get_switches(PCefCommandLine(FData), list); + for i := 0 to cef_string_list_size(list) - 1 do + begin + FillChar(str, SizeOf(str), 0); + cef_string_list_value(list, i, @str); + switches.Add(CefStringClearAndGet(str)); + end; + finally + cef_string_list_free(list); + end; +end; + +function TCefCommandLineRef.GetSwitchValue(const name: ustring): ustring; +var + n: TCefString; +begin + n := CefString(name); + Result := CefStringFreeAndGet(PCefCommandLine(FData).get_switch_value(PCefCommandLine(FData), @n)); +end; + +class function TCefCommandLineRef.Global: ICefCommandLine; +begin + Result := UnWrap(cef_command_line_get_global); +end; + +function TCefCommandLineRef.HasArguments: Boolean; +begin + Result := PCefCommandLine(FData).has_arguments(PCefCommandLine(FData)) <> 0; +end; + +function TCefCommandLineRef.HasSwitch(const name: ustring): Boolean; +var + n: TCefString; +begin + n := CefString(name); + Result := PCefCommandLine(FData).has_switch(PCefCommandLine(FData), @n) <> 0; +end; + +function TCefCommandLineRef.HasSwitches: Boolean; +begin + Result := PCefCommandLine(FData).has_switches(PCefCommandLine(FData)) <> 0; +end; + +procedure TCefCommandLineRef.InitFromArgv(argc: Integer; + const argv: PPAnsiChar); +begin + PCefCommandLine(FData).init_from_argv(PCefCommandLine(FData), argc, argv); +end; + +procedure TCefCommandLineRef.InitFromString(const commandLine: ustring); +var + cl: TCefString; +begin + cl := CefString(commandLine); + PCefCommandLine(FData).init_from_string(PCefCommandLine(FData), @cl); +end; + +function TCefCommandLineRef.IsReadOnly: Boolean; +begin + Result := PCefCommandLine(FData).is_read_only(PCefCommandLine(FData)) <> 0; +end; + +function TCefCommandLineRef.IsValid: Boolean; +begin + Result := PCefCommandLine(FData).is_valid(PCefCommandLine(FData)) <> 0; +end; + +class function TCefCommandLineRef.New: ICefCommandLine; +begin + Result := UnWrap(cef_command_line_create); +end; + +procedure TCefCommandLineRef.PrependWrapper(const wrapper: ustring); +var + w: TCefString; +begin + w := CefString(wrapper); + PCefCommandLine(FData).prepend_wrapper(PCefCommandLine(FData), @w); +end; + +procedure TCefCommandLineRef.Reset; +begin + PCefCommandLine(FData).reset(PCefCommandLine(FData)); +end; + +procedure TCefCommandLineRef.SetProgram(const prog: ustring); +var + p: TCefString; +begin + p := CefString(prog); + PCefCommandLine(FData).set_program(PCefCommandLine(FData), @p); +end; + +class function TCefCommandLineRef.UnWrap(data: Pointer): ICefCommandLine; +begin + if data <> nil then + Result := Create(data) as ICefCommandLine else + Result := nil; +end; + +{ TCefSchemeRegistrarRef } + +function TCefSchemeRegistrarRef.AddCustomScheme(const schemeName: ustring; + IsStandard, IsLocal, IsDisplayIsolated: Boolean): Boolean; +var + sn: TCefString; +begin + sn := CefString(schemeName); + Result := PCefSchemeRegistrar(FData).add_custom_scheme(PCefSchemeRegistrar(FData), + @sn, Ord(IsStandard), Ord(IsLocal), Ord(IsDisplayIsolated)) <> 0; +end; + +class function TCefSchemeRegistrarRef.UnWrap( + data: Pointer): ICefSchemeRegistrar; +begin + if data <> nil then + Result := Create(data) as ICefSchemeRegistrar else + Result := nil; +end; + +{ TCefGeolocationCallbackRef } + +procedure TCefGeolocationCallbackRef.Cont(allow: Boolean); +begin + PCefGeolocationCallback(FData).cont(PCefGeolocationCallback(FData), Ord(allow)); +end; + +class function TCefGeolocationCallbackRef.UnWrap( + data: Pointer): ICefGeolocationCallback; +begin + if data <> nil then + Result := Create(data) as ICefGeolocationCallback else + Result := nil; +end; + +{ TCefContextMenuParamsRef } + +function TCefContextMenuParamsRef.GetEditStateFlags: TCefContextMenuEditStateFlags; +begin + Byte(Result) := PCefContextMenuParams(FData).get_edit_state_flags(PCefContextMenuParams(FData)); +end; + +function TCefContextMenuParamsRef.GetFrameCharset: ustring; +begin + Result := CefStringFreeAndGet(PCefContextMenuParams(FData).get_frame_charset(PCefContextMenuParams(FData))); +end; + +function TCefContextMenuParamsRef.GetFrameUrl: ustring; +begin + Result := CefStringFreeAndGet(PCefContextMenuParams(FData).get_frame_url(PCefContextMenuParams(FData))); +end; + +function TCefContextMenuParamsRef.GetLinkUrl: ustring; +begin + Result := CefStringFreeAndGet(PCefContextMenuParams(FData).get_link_url(PCefContextMenuParams(FData))); +end; + +function TCefContextMenuParamsRef.GetMediaStateFlags: TCefContextMenuMediaStateFlags; +begin + Word(Result) := PCefContextMenuParams(FData).get_media_state_flags(PCefContextMenuParams(FData)); +end; + +function TCefContextMenuParamsRef.GetMediaType: TCefContextMenuMediaType; +begin + Result := PCefContextMenuParams(FData).get_media_type(PCefContextMenuParams(FData)); +end; + +function TCefContextMenuParamsRef.GetPageUrl: ustring; +begin + Result := CefStringFreeAndGet(PCefContextMenuParams(FData).get_page_url(PCefContextMenuParams(FData))); +end; + +function TCefContextMenuParamsRef.GetSelectionText: ustring; +begin + Result := CefStringFreeAndGet(PCefContextMenuParams(FData).get_selection_text(PCefContextMenuParams(FData))); +end; + +function TCefContextMenuParamsRef.GetSourceUrl: ustring; +begin + Result := CefStringFreeAndGet(PCefContextMenuParams(FData).get_source_url(PCefContextMenuParams(FData))); +end; + +function TCefContextMenuParamsRef.GetTypeFlags: TCefContextMenuTypeFlags; +begin + Byte(Result) := PCefContextMenuParams(FData).get_type_flags(PCefContextMenuParams(FData)); +end; + +function TCefContextMenuParamsRef.GetUnfilteredLinkUrl: ustring; +begin + Result := CefStringFreeAndGet(PCefContextMenuParams(FData).get_unfiltered_link_url(PCefContextMenuParams(FData))); +end; + +function TCefContextMenuParamsRef.GetXCoord: Integer; +begin + Result := PCefContextMenuParams(FData).get_xcoord(PCefContextMenuParams(FData)); +end; + +function TCefContextMenuParamsRef.GetYCoord: Integer; +begin + Result := PCefContextMenuParams(FData).get_ycoord(PCefContextMenuParams(FData)); +end; + +function TCefContextMenuParamsRef.IsEditable: Boolean; +begin + Result := PCefContextMenuParams(FData).is_editable(PCefContextMenuParams(FData)) <> 0; +end; + +function TCefContextMenuParamsRef.HasImageContents: Boolean; +begin + Result := PCefContextMenuParams(FData).has_image_contents(PCefContextMenuParams(FData)) <> 0; +end; + +function TCefContextMenuParamsRef.IsSpeechInputEnabled: Boolean; +begin + Result := PCefContextMenuParams(FData).is_speech_input_enabled(PCefContextMenuParams(FData)) <> 0; +end; + +class function TCefContextMenuParamsRef.UnWrap( + data: Pointer): ICefContextMenuParams; +begin + if data <> nil then + Result := Create(data) as ICefContextMenuParams else + Result := nil; +end; + +{ TCefMenuModelRef } + +function TCefMenuModelRef.AddCheckItem(commandId: Integer; + const text: ustring): Boolean; +var + t: TCefString; +begin + t := CefString(text); + Result := PCefMenuModel(FData).add_check_item(PCefMenuModel(FData), commandId, @t) <> 0; +end; + +function TCefMenuModelRef.AddItem(commandId: Integer; + const text: ustring): Boolean; +var + t: TCefString; +begin + t := CefString(text); + Result := PCefMenuModel(FData).add_item(PCefMenuModel(FData), commandId, @t) <> 0; +end; + +function TCefMenuModelRef.AddRadioItem(commandId: Integer; const text: ustring; + groupId: Integer): Boolean; +var + t: TCefString; +begin + t := CefString(text); + Result := PCefMenuModel(FData).add_radio_item(PCefMenuModel(FData), commandId, @t, groupId) <> 0; +end; + +function TCefMenuModelRef.AddSeparator: Boolean; +begin + Result := PCefMenuModel(FData).add_separator(PCefMenuModel(FData)) <> 0; +end; + +function TCefMenuModelRef.AddSubMenu(commandId: Integer; + const text: ustring): ICefMenuModel; +var + t: TCefString; +begin + t := CefString(text); + Result := TCefMenuModelRef.UnWrap(PCefMenuModel(FData).add_sub_menu(PCefMenuModel(FData), commandId, @t)); +end; + +function TCefMenuModelRef.Clear: Boolean; +begin + Result := PCefMenuModel(FData).clear(PCefMenuModel(FData)) <> 0; +end; + +function TCefMenuModelRef.GetAccelerator(commandId: Integer; + out keyCode: Integer; out shiftPressed, ctrlPressed, + altPressed: Boolean): Boolean; +var + sp, cp, ap: Integer; +begin + Result := PCefMenuModel(FData).get_accelerator(PCefMenuModel(FData), + commandId, @keyCode, @sp, @cp, @ap) <> 0; + shiftPressed := sp <> 0; + ctrlPressed := cp <> 0; + altPressed := ap <> 0; +end; + +function TCefMenuModelRef.GetAcceleratorAt(index: Integer; out keyCode: Integer; + out shiftPressed, ctrlPressed, altPressed: Boolean): Boolean; +var + sp, cp, ap: Integer; +begin + Result := PCefMenuModel(FData).get_accelerator_at(PCefMenuModel(FData), + index, @keyCode, @sp, @cp, @ap) <> 0; + shiftPressed := sp <> 0; + ctrlPressed := cp <> 0; + altPressed := ap <> 0; +end; + +function TCefMenuModelRef.GetCommandIdAt(index: Integer): Integer; +begin + Result := PCefMenuModel(FData).get_command_id_at(PCefMenuModel(FData), index); +end; + +function TCefMenuModelRef.GetCount: Integer; +begin + Result := PCefMenuModel(FData).get_count(PCefMenuModel(FData)); +end; + +function TCefMenuModelRef.GetGroupId(commandId: Integer): Integer; +begin + Result := PCefMenuModel(FData).get_group_id(PCefMenuModel(FData), commandId); +end; + +function TCefMenuModelRef.GetGroupIdAt(index: Integer): Integer; +begin + Result := PCefMenuModel(FData).get_group_id(PCefMenuModel(FData), index); +end; + +function TCefMenuModelRef.GetIndexOf(commandId: Integer): Integer; +begin + Result := PCefMenuModel(FData).get_index_of(PCefMenuModel(FData), commandId); +end; + +function TCefMenuModelRef.GetLabel(commandId: Integer): ustring; +begin + Result := CefStringFreeAndGet(PCefMenuModel(FData).get_label(PCefMenuModel(FData), commandId)); +end; + +function TCefMenuModelRef.GetLabelAt(index: Integer): ustring; +begin + Result := CefStringFreeAndGet(PCefMenuModel(FData).get_label_at(PCefMenuModel(FData), index)); +end; + +function TCefMenuModelRef.GetSubMenu(commandId: Integer): ICefMenuModel; +begin + Result := TCefMenuModelRef.UnWrap(PCefMenuModel(FData).get_sub_menu(PCefMenuModel(FData), commandId)); +end; + +function TCefMenuModelRef.GetSubMenuAt(index: Integer): ICefMenuModel; +begin + Result := TCefMenuModelRef.UnWrap(PCefMenuModel(FData).get_sub_menu_at(PCefMenuModel(FData), index)); +end; + +function TCefMenuModelRef.GetType(commandId: Integer): TCefMenuItemType; +begin + Result := PCefMenuModel(FData).get_type(PCefMenuModel(FData), commandId); +end; + +function TCefMenuModelRef.GetTypeAt(index: Integer): TCefMenuItemType; +begin + Result := PCefMenuModel(FData).get_type_at(PCefMenuModel(FData), index); +end; + +function TCefMenuModelRef.HasAccelerator(commandId: Integer): Boolean; +begin + Result := PCefMenuModel(FData).has_accelerator(PCefMenuModel(FData), commandId) <> 0; +end; + +function TCefMenuModelRef.HasAcceleratorAt(index: Integer): Boolean; +begin + Result := PCefMenuModel(FData).has_accelerator_at(PCefMenuModel(FData), index) <> 0; +end; + +function TCefMenuModelRef.InsertCheckItemAt(index, commandId: Integer; + const text: ustring): Boolean; +var + t: TCefString; +begin + t := CefString(text); + Result := PCefMenuModel(FData).insert_check_item_at(PCefMenuModel(FData), index, commandId, @t) <> 0; +end; + +function TCefMenuModelRef.InsertItemAt(index, commandId: Integer; + const text: ustring): Boolean; +var + t: TCefString; +begin + t := CefString(text); + Result := PCefMenuModel(FData).insert_item_at(PCefMenuModel(FData), index, commandId, @t) <> 0; +end; + +function TCefMenuModelRef.InsertRadioItemAt(index, commandId: Integer; + const text: ustring; groupId: Integer): Boolean; +var + t: TCefString; +begin + t := CefString(text); + Result := PCefMenuModel(FData).insert_radio_item_at(PCefMenuModel(FData), + index, commandId, @t, groupId) <> 0; +end; + +function TCefMenuModelRef.InsertSeparatorAt(index: Integer): Boolean; +begin + Result := PCefMenuModel(FData).insert_separator_at(PCefMenuModel(FData), index) <> 0; +end; + +function TCefMenuModelRef.InsertSubMenuAt(index, commandId: Integer; + const text: ustring): ICefMenuModel; +var + t: TCefString; +begin + t := CefString(text); + Result := TCefMenuModelRef.UnWrap(PCefMenuModel(FData).insert_sub_menu_at( + PCefMenuModel(FData), index, commandId, @t)); +end; + +function TCefMenuModelRef.IsChecked(commandId: Integer): Boolean; +begin + Result := PCefMenuModel(FData).is_checked(PCefMenuModel(FData), commandId) <> 0; +end; + +function TCefMenuModelRef.IsCheckedAt(index: Integer): Boolean; +begin + Result := PCefMenuModel(FData).is_checked_at(PCefMenuModel(FData), index) <> 0; +end; + +function TCefMenuModelRef.IsEnabled(commandId: Integer): Boolean; +begin + Result := PCefMenuModel(FData).is_enabled(PCefMenuModel(FData), commandId) <> 0; +end; + +function TCefMenuModelRef.IsEnabledAt(index: Integer): Boolean; +begin + Result := PCefMenuModel(FData).is_enabled_at(PCefMenuModel(FData), index) <> 0; +end; + +function TCefMenuModelRef.IsVisible(commandId: Integer): Boolean; +begin + Result := PCefMenuModel(FData).is_visible(PCefMenuModel(FData), commandId) <> 0; +end; + +function TCefMenuModelRef.isVisibleAt(index: Integer): Boolean; +begin + Result := PCefMenuModel(FData).is_visible_at(PCefMenuModel(FData), index) <> 0; +end; + +function TCefMenuModelRef.Remove(commandId: Integer): Boolean; +begin + Result := PCefMenuModel(FData).remove(PCefMenuModel(FData), commandId) <> 0; +end; + +function TCefMenuModelRef.RemoveAccelerator(commandId: Integer): Boolean; +begin + Result := PCefMenuModel(FData).remove_accelerator(PCefMenuModel(FData), commandId) <> 0; +end; + +function TCefMenuModelRef.RemoveAcceleratorAt(index: Integer): Boolean; +begin + Result := PCefMenuModel(FData).remove_accelerator_at(PCefMenuModel(FData), index) <> 0; +end; + +function TCefMenuModelRef.RemoveAt(index: Integer): Boolean; +begin + Result := PCefMenuModel(FData).remove_at(PCefMenuModel(FData), index) <> 0; +end; + +function TCefMenuModelRef.SetAccelerator(commandId, keyCode: Integer; + shiftPressed, ctrlPressed, altPressed: Boolean): Boolean; +begin + Result := PCefMenuModel(FData).set_accelerator(PCefMenuModel(FData), + commandId, keyCode, Ord(shiftPressed), Ord(ctrlPressed), Ord(altPressed)) <> 0; +end; + +function TCefMenuModelRef.SetAcceleratorAt(index, keyCode: Integer; + shiftPressed, ctrlPressed, altPressed: Boolean): Boolean; +begin + Result := PCefMenuModel(FData).set_accelerator_at(PCefMenuModel(FData), + index, keyCode, Ord(shiftPressed), Ord(ctrlPressed), Ord(altPressed)) <> 0; +end; + +function TCefMenuModelRef.setChecked(commandId: Integer; + checked: Boolean): Boolean; +begin + Result := PCefMenuModel(FData).set_checked(PCefMenuModel(FData), + commandId, Ord(checked)) <> 0; +end; + +function TCefMenuModelRef.setCheckedAt(index: Integer; + checked: Boolean): Boolean; +begin + Result := PCefMenuModel(FData).set_checked_at(PCefMenuModel(FData), index, Ord(checked)) <> 0; +end; + +function TCefMenuModelRef.SetCommandIdAt(index, commandId: Integer): Boolean; +begin + Result := PCefMenuModel(FData).set_command_id_at(PCefMenuModel(FData), index, commandId) <> 0; +end; + +function TCefMenuModelRef.SetEnabled(commandId: Integer; + enabled: Boolean): Boolean; +begin + Result := PCefMenuModel(FData).set_enabled(PCefMenuModel(FData), commandId, Ord(enabled)) <> 0; +end; + +function TCefMenuModelRef.SetEnabledAt(index: Integer; + enabled: Boolean): Boolean; +begin + Result := PCefMenuModel(FData).set_enabled_at(PCefMenuModel(FData), index, Ord(enabled)) <> 0; +end; + +function TCefMenuModelRef.SetGroupId(commandId, groupId: Integer): Boolean; +begin + Result := PCefMenuModel(FData).set_group_id(PCefMenuModel(FData), commandId, groupId) <> 0; +end; + +function TCefMenuModelRef.SetGroupIdAt(index, groupId: Integer): Boolean; +begin + Result := PCefMenuModel(FData).set_group_id_at(PCefMenuModel(FData), index, groupId) <> 0; +end; + +function TCefMenuModelRef.SetLabel(commandId: Integer; + const text: ustring): Boolean; +var + t: TCefString; +begin + t := CefString(text); + Result := PCefMenuModel(FData).set_label(PCefMenuModel(FData), commandId, @t) <> 0; +end; + +function TCefMenuModelRef.SetLabelAt(index: Integer; + const text: ustring): Boolean; +var + t: TCefString; +begin + t := CefString(text); + Result := PCefMenuModel(FData).set_label_at(PCefMenuModel(FData), index, @t) <> 0; +end; + +function TCefMenuModelRef.SetVisible(commandId: Integer; + visible: Boolean): Boolean; +begin + Result := PCefMenuModel(FData).set_visible(PCefMenuModel(FData), commandId, Ord(visible)) <> 0; +end; + +function TCefMenuModelRef.SetVisibleAt(index: Integer; + visible: Boolean): Boolean; +begin + Result := PCefMenuModel(FData).set_visible_at(PCefMenuModel(FData), index, Ord(visible)) <> 0; +end; + +class function TCefMenuModelRef.UnWrap(data: Pointer): ICefMenuModel; +begin + if data <> nil then + Result := Create(data) as ICefMenuModel else + Result := nil; +end; + +{ TCefListValueRef } + +function TCefListValueRef.Clear: Boolean; +begin + Result := PCefListValue(FData).clear(PCefListValue(FData)) <> 0; +end; + +function TCefListValueRef.Copy: ICefListValue; +begin + Result := UnWrap(PCefListValue(FData).copy(PCefListValue(FData))); +end; + +class function TCefListValueRef.New: ICefListValue; +begin + UnWrap(cef_list_value_create); +end; + +function TCefListValueRef.GetBinary(index: Integer): ICefBinaryValue; +begin + Result := TCefBinaryValueRef.UnWrap(PCefListValue(FData).get_binary(PCefListValue(FData), index)); +end; + +function TCefListValueRef.GetBool(index: Integer): Boolean; +begin + Result := PCefListValue(FData).get_bool(PCefListValue(FData), index) <> 0; +end; + +function TCefListValueRef.GetDictionary(index: Integer): ICefDictionaryValue; +begin + Result := TCefDictionaryValueRef.UnWrap(PCefListValue(FData).get_dictionary(PCefListValue(FData), index)); +end; + +function TCefListValueRef.GetDouble(index: Integer): Double; +begin + Result := PCefListValue(FData).get_double(PCefListValue(FData), index); +end; + +function TCefListValueRef.GetInt(index: Integer): Integer; +begin + Result := PCefListValue(FData).get_int(PCefListValue(FData), index); +end; + +function TCefListValueRef.GetList(index: Integer): ICefListValue; +begin + Result := UnWrap(PCefListValue(FData).get_list(PCefListValue(FData), index)); +end; + +function TCefListValueRef.GetSize: NativeUInt; +begin + Result := PCefListValue(FData).get_size(PCefListValue(FData)); +end; + +function TCefListValueRef.GetString(index: Integer): ustring; +begin + Result := CefStringFreeAndGet(PCefListValue(FData).get_string(PCefListValue(FData), index)); +end; + +function TCefListValueRef.GetType(index: Integer): TCefValueType; +begin + Result := PCefListValue(FData).get_type(PCefListValue(FData), index); +end; + +function TCefListValueRef.IsOwned: Boolean; +begin + Result := PCefListValue(FData).is_owned(PCefListValue(FData)) <> 0; +end; + +function TCefListValueRef.IsReadOnly: Boolean; +begin + Result := PCefListValue(FData).is_read_only(PCefListValue(FData)) <> 0; +end; + +function TCefListValueRef.IsValid: Boolean; +begin + Result := PCefListValue(FData).is_valid(PCefListValue(FData)) <> 0; +end; + +function TCefListValueRef.Remove(index: Integer): Boolean; +begin + Result := PCefListValue(FData).remove(PCefListValue(FData), index) <> 0; +end; + +function TCefListValueRef.SetBinary(index: Integer; + const value: ICefBinaryValue): Boolean; +begin + Result := PCefListValue(FData).set_binary(PCefListValue(FData), index, CefGetData(value)) <> 0; +end; + +function TCefListValueRef.SetBool(index: Integer; value: Boolean): Boolean; +begin + Result := PCefListValue(FData).set_bool(PCefListValue(FData), index, Ord(value)) <> 0; +end; + +function TCefListValueRef.SetDictionary(index: Integer; + const value: ICefDictionaryValue): Boolean; +begin + Result := PCefListValue(FData).set_dictionary(PCefListValue(FData), index, CefGetData(value)) <> 0; +end; + +function TCefListValueRef.SetDouble(index: Integer; value: Double): Boolean; +begin + Result := PCefListValue(FData).set_double(PCefListValue(FData), index, value) <> 0; +end; + +function TCefListValueRef.SetInt(index, value: Integer): Boolean; +begin + Result := PCefListValue(FData).set_int(PCefListValue(FData), index, value) <> 0; +end; + +function TCefListValueRef.SetList(index: Integer; + const value: ICefListValue): Boolean; +begin + Result := PCefListValue(FData).set_list(PCefListValue(FData), index, CefGetData(value)) <> 0; +end; + +function TCefListValueRef.SetNull(index: Integer): Boolean; +begin + Result := PCefListValue(FData).set_null(PCefListValue(FData), index) <> 0; +end; + +function TCefListValueRef.SetSize(size: NativeUInt): Boolean; +begin + Result := PCefListValue(FData).set_size(PCefListValue(FData), size) <> 0; +end; + +function TCefListValueRef.SetString(index: Integer; + const value: ustring): Boolean; +var + v: TCefString; +begin + v := CefString(value); + Result := PCefListValue(FData).set_string(PCefListValue(FData), index, @v) <> 0; +end; + +class function TCefListValueRef.UnWrap(data: Pointer): ICefListValue; +begin + if data <> nil then + Result := Create(data) as ICefListValue else + Result := nil; +end; + +{ TCefBinaryValueRef } + +function TCefBinaryValueRef.Copy: ICefBinaryValue; +begin + Result := UnWrap(PCefBinaryValue(FData).copy(PCefBinaryValue(FData))); +end; + +function TCefBinaryValueRef.GetData(buffer: Pointer; bufferSize, + dataOffset: NativeUInt): NativeUInt; +begin + Result := PCefBinaryValue(FData).get_data(PCefBinaryValue(FData), buffer, bufferSize, dataOffset); +end; + +function TCefBinaryValueRef.GetSize: NativeUInt; +begin + Result := PCefBinaryValue(FData).get_size(PCefBinaryValue(FData)); +end; + +function TCefBinaryValueRef.IsOwned: Boolean; +begin + Result := PCefBinaryValue(FData).is_owned(PCefBinaryValue(FData)) <> 0; +end; + +function TCefBinaryValueRef.IsValid: Boolean; +begin + Result := PCefBinaryValue(FData).is_valid(PCefBinaryValue(FData)) <> 0; +end; + +class function TCefBinaryValueRef.New(const data: Pointer; dataSize: NativeUInt): ICefBinaryValue; +begin + Result := UnWrap(cef_binary_value_create(data, dataSize)); +end; + +class function TCefBinaryValueRef.UnWrap(data: Pointer): ICefBinaryValue; +begin + if data <> nil then + Result := Create(data) as ICefBinaryValue else + Result := nil; +end; + +{ TCefDictionaryValueRef } + +function TCefDictionaryValueRef.Clear: Boolean; +begin + Result := PCefDictionaryValue(FData).clear(PCefDictionaryValue(FData)) <> 0; +end; + +function TCefDictionaryValueRef.Copy( + excludeEmptyChildren: Boolean): ICefDictionaryValue; +begin + Result := UnWrap(PCefDictionaryValue(FData).copy(PCefDictionaryValue(FData), Ord(excludeEmptyChildren))); +end; + +function TCefDictionaryValueRef.GetBinary(const key: ustring): ICefBinaryValue; +var + k: TCefString; +begin + k := CefString(key); + Result := TCefBinaryValueRef.UnWrap(PCefDictionaryValue(FData).get_binary(PCefDictionaryValue(FData), @k)); +end; + +function TCefDictionaryValueRef.GetBool(const key: ustring): Boolean; +var + k: TCefString; +begin + k := CefString(key); + Result := PCefDictionaryValue(FData).get_bool(PCefDictionaryValue(FData), @k) <> 0; +end; + +function TCefDictionaryValueRef.GetDictionary( + const key: ustring): ICefDictionaryValue; +var + k: TCefString; +begin + k := CefString(key); + Result := UnWrap(PCefDictionaryValue(FData).get_dictionary(PCefDictionaryValue(FData), @k)); +end; + +function TCefDictionaryValueRef.GetDouble(const key: ustring): Double; +var + k: TCefString; +begin + k := CefString(key); + Result := PCefDictionaryValue(FData).get_double(PCefDictionaryValue(FData), @k); +end; + +function TCefDictionaryValueRef.GetInt(const key: ustring): Integer; +var + k: TCefString; +begin + k := CefString(key); + Result := PCefDictionaryValue(FData).get_int(PCefDictionaryValue(FData), @k); +end; + +function TCefDictionaryValueRef.GetKeys(const keys: TStrings): Boolean; +var + list: TCefStringList; + i: Integer; + str: TCefString; +begin + list := cef_string_list_alloc; + try + Result := PCefDictionaryValue(FData).get_keys(PCefDictionaryValue(FData), list) <> 0; + FillChar(str, SizeOf(str), 0); + for i := 0 to cef_string_list_size(list) - 1 do + begin + FillChar(str, SizeOf(str), 0); + cef_string_list_value(list, i, @str); + keys.Add(CefStringClearAndGet(str)); + end; + finally + cef_string_list_free(list); + end; +end; + +function TCefDictionaryValueRef.GetList(const key: ustring): ICefListValue; +var + k: TCefString; +begin + k := CefString(key); + Result := TCefListValueRef.UnWrap(PCefDictionaryValue(FData).get_list(PCefDictionaryValue(FData), @k)); +end; + +function TCefDictionaryValueRef.GetSize: NativeUInt; +begin + Result := PCefDictionaryValue(FData).get_size(PCefDictionaryValue(FData)); +end; + +function TCefDictionaryValueRef.GetString(const key: ustring): ustring; +var + k: TCefString; +begin + k := CefString(key); + Result := CefStringFreeAndGet(PCefDictionaryValue(FData).get_string(PCefDictionaryValue(FData), @k)); +end; + +function TCefDictionaryValueRef.GetType(const key: ustring): TCefValueType; +var + k: TCefString; +begin + k := CefString(key); + Result := PCefDictionaryValue(FData).get_type(PCefDictionaryValue(FData), @k); +end; + +function TCefDictionaryValueRef.HasKey(const key: ustring): Boolean; +var + k: TCefString; +begin + k := CefString(key); + Result := PCefDictionaryValue(FData).has_key(PCefDictionaryValue(FData), @k) <> 0; +end; + +function TCefDictionaryValueRef.isOwned: Boolean; +begin + Result := PCefDictionaryValue(FData).is_owned(PCefDictionaryValue(FData)) <> 0; +end; + +function TCefDictionaryValueRef.IsReadOnly: Boolean; +begin + Result := PCefDictionaryValue(FData).is_read_only(PCefDictionaryValue(FData)) <> 0; +end; + +function TCefDictionaryValueRef.IsValid: Boolean; +begin + Result := PCefDictionaryValue(FData).is_valid(PCefDictionaryValue(FData)) <> 0; +end; + +class function TCefDictionaryValueRef.New: ICefDictionaryValue; +begin + Result := UnWrap(cef_dictionary_value_create); +end; + +function TCefDictionaryValueRef.Remove(const key: ustring): Boolean; +var + k: TCefString; +begin + k := CefString(key); + Result := PCefDictionaryValue(FData).remove(PCefDictionaryValue(FData), @k) <> 0; +end; + +function TCefDictionaryValueRef.SetBinary(const key: ustring; + const value: ICefBinaryValue): Boolean; +var + k: TCefString; +begin + k := CefString(key); + Result := PCefDictionaryValue(FData).set_binary(PCefDictionaryValue(FData), @k, CefGetData(value)) <> 0; +end; + +function TCefDictionaryValueRef.SetBool(const key: ustring; + value: Boolean): Boolean; +var + k: TCefString; +begin + k := CefString(key); + Result := PCefDictionaryValue(FData).set_bool(PCefDictionaryValue(FData), @k, Ord(value)) <> 0; +end; + +function TCefDictionaryValueRef.SetDictionary(const key: ustring; + const value: ICefDictionaryValue): Boolean; +var + k: TCefString; +begin + k := CefString(key); + Result := PCefDictionaryValue(FData).set_dictionary(PCefDictionaryValue(FData), @k, CefGetData(value)) <> 0; +end; + +function TCefDictionaryValueRef.SetDouble(const key: ustring; + value: Double): Boolean; +var + k: TCefString; +begin + k := CefString(key); + Result := PCefDictionaryValue(FData).set_double(PCefDictionaryValue(FData), @k, value) <> 0; +end; + +function TCefDictionaryValueRef.SetInt(const key: ustring; + value: Integer): Boolean; +var + k: TCefString; +begin + k := CefString(key); + Result := PCefDictionaryValue(FData).set_int(PCefDictionaryValue(FData), @k, value) <> 0; +end; + +function TCefDictionaryValueRef.SetList(const key: ustring; + const value: ICefListValue): Boolean; +var + k: TCefString; +begin + k := CefString(key); + Result := PCefDictionaryValue(FData).set_list(PCefDictionaryValue(FData), @k, CefGetData(value)) <> 0; +end; + +function TCefDictionaryValueRef.SetNull(const key: ustring): Boolean; +var + k: TCefString; +begin + k := CefString(key); + Result := PCefDictionaryValue(FData).set_null(PCefDictionaryValue(FData), @k) <> 0; +end; + +function TCefDictionaryValueRef.SetString(const key, value: ustring): Boolean; +var + k, v: TCefString; +begin + k := CefString(key); + v := CefString(value); + Result := PCefDictionaryValue(FData).set_string(PCefDictionaryValue(FData), @k, @v) <> 0; +end; + +class function TCefDictionaryValueRef.UnWrap( + data: Pointer): ICefDictionaryValue; +begin + if data <> nil then + Result := Create(data) as ICefDictionaryValue else + Result := nil; +end; + +{ TCefBrowserProcessHandlerOwn } + +constructor TCefBrowserProcessHandlerOwn.Create; +begin + inherited CreateData(SizeOf(TCefBrowserProcessHandler)); + with PCefBrowserProcessHandler(FData)^ do + begin + on_context_initialized := cef_browser_process_handler_on_context_initialized; + on_before_child_process_launch := cef_browser_process_handler_on_before_child_process_launch; + on_render_process_thread_created := cef_browser_process_handler_on_render_process_thread_created; + end; +end; + +procedure TCefBrowserProcessHandlerOwn.OnBeforeChildProcessLaunch( + const commandLine: ICefCommandLine); +begin + +end; + +procedure TCefBrowserProcessHandlerOwn.OnContextInitialized; +begin + +end; + +procedure TCefBrowserProcessHandlerOwn.OnRenderProcessThreadCreated( + const extraInfo: ICefListValue); +begin + +end; + +{ TCefRenderProcessHandlerOwn } + +constructor TCefRenderProcessHandlerOwn.Create; +begin + inherited CreateData(SizeOf(TCefRenderProcessHandler)); + with PCefRenderProcessHandler(FData)^ do + begin + on_render_thread_created := cef_render_process_handler_on_render_thread_created; + on_web_kit_initialized := cef_render_process_handler_on_web_kit_initialized; + on_browser_created := cef_render_process_handler_on_browser_created; + on_browser_destroyed := cef_render_process_handler_on_browser_destroyed; + get_load_handler := cef_render_process_handler_get_load_handler; + on_before_navigation := cef_render_process_handler_on_before_navigation; + on_context_created := cef_render_process_handler_on_context_created; + on_context_released := cef_render_process_handler_on_context_released; + on_uncaught_exception := cef_render_process_handler_on_uncaught_exception; + on_focused_node_changed := cef_render_process_handler_on_focused_node_changed; + on_process_message_received := cef_render_process_handler_on_process_message_received; + end; +end; + +function TCefRenderProcessHandlerOwn.GetLoadHandler: ICefLoadHandler; +begin + Result := nil; +end; + +function TCefRenderProcessHandlerOwn.OnBeforeNavigation( + const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest; navigationType: TCefNavigationType; + isRedirect: Boolean): Boolean; +begin + Result := False; +end; + +procedure TCefRenderProcessHandlerOwn.OnBrowserCreated( + const browser: ICefBrowser); +begin + +end; + +procedure TCefRenderProcessHandlerOwn.OnBrowserDestroyed( + const browser: ICefBrowser); +begin + +end; + +procedure TCefRenderProcessHandlerOwn.OnContextCreated( + const browser: ICefBrowser; const frame: ICefFrame; + const context: ICefv8Context); +begin + +end; + +procedure TCefRenderProcessHandlerOwn.OnContextReleased( + const browser: ICefBrowser; const frame: ICefFrame; + const context: ICefv8Context); +begin + +end; + +procedure TCefRenderProcessHandlerOwn.OnFocusedNodeChanged( + const browser: ICefBrowser; const frame: ICefFrame; const node: ICefDomNode); +begin + +end; + +function TCefRenderProcessHandlerOwn.OnProcessMessageReceived( + const browser: ICefBrowser; sourceProcess: TCefProcessId; + const message: ICefProcessMessage): Boolean; +begin + Result := False; +end; + +procedure TCefRenderProcessHandlerOwn.OnRenderThreadCreated(const extraInfo: ICefListValue); +begin + +end; + +procedure TCefRenderProcessHandlerOwn.OnUncaughtException( + const browser: ICefBrowser; const frame: ICefFrame; + const context: ICefv8Context; const exception: ICefV8Exception; + const stackTrace: ICefV8StackTrace); +begin + +end; + +procedure TCefRenderProcessHandlerOwn.OnWebKitInitialized; +begin + +end; + +{ TCefResourceHandlerOwn } + +procedure TCefResourceHandlerOwn.Cancel; +begin + +end; + +function TCefResourceHandlerOwn.CanGetCookie(const cookie: PCefCookie): Boolean; +begin + Result := False; +end; + +function TCefResourceHandlerOwn.CanSetCookie(const cookie: PCefCookie): Boolean; +begin + Result := False; +end; + +constructor TCefResourceHandlerOwn.Create(const browser: ICefBrowser; + const frame: ICefFrame; const schemeName: ustring; + const request: ICefRequest); +begin + inherited CreateData(SizeOf(TCefResourceHandler)); + with PCefResourceHandler(FData)^ do + begin + process_request := cef_resource_handler_process_request; + get_response_headers := cef_resource_handler_get_response_headers; + read_response := cef_resource_handler_read_response; + can_get_cookie := cef_resource_handler_can_get_cookie; + can_set_cookie := cef_resource_handler_can_set_cookie; + cancel:= cef_resource_handler_cancel; + end; +end; + +procedure TCefResourceHandlerOwn.GetResponseHeaders( + const response: ICefResponse; out responseLength: Int64; + out redirectUrl: ustring); +begin + +end; + +function TCefResourceHandlerOwn.ProcessRequest(const request: ICefRequest; + const callback: ICefCallback): Boolean; +begin + Result := False; +end; + +function TCefResourceHandlerOwn.ReadResponse(const dataOut: Pointer; + bytesToRead: Integer; var bytesRead: Integer; + const callback: ICefCallback): Boolean; +begin + Result := False; +end; + +{ TCefSchemeHandlerFactoryOwn } + +constructor TCefSchemeHandlerFactoryOwn.Create( + const AClass: TCefResourceHandlerClass; SyncMainThread: Boolean); +begin + inherited CreateData(SizeOf(TCefSchemeHandlerFactory)); + FClass := AClass; + with PCefSchemeHandlerFactory(FData)^ do + create := cef_scheme_handler_factory_create; +end; + +function TCefSchemeHandlerFactoryOwn.New(const browser: ICefBrowser; + const frame: ICefFrame; const schemeName: ustring; + const request: ICefRequest): ICefResourceHandler; +begin + Result := FClass.Create(browser, frame, schemeName, request); +end; + +{ TCefCallbackRef } + +procedure TCefCallbackRef.Cancel; +begin + PCefCallback(FData)^.cancel(PCefCallback(FData)); +end; + +procedure TCefCallbackRef.Cont; +begin + PCefCallback(FData)^.cont(PCefCallback(FData)); +end; + +class function TCefCallbackRef.UnWrap(data: Pointer): ICefCallback; +begin + if data <> nil then + Result := Create(data) as ICefCallback else + Result := nil; +end; + + +{ TCefUrlrequestClientOwn } + +constructor TCefUrlrequestClientOwn.Create; +begin + inherited CreateData(SizeOf(TCefUrlrequestClient)); + with PCefUrlrequestClient(FData)^ do + begin + on_request_complete := cef_url_request_client_on_request_complete; + on_upload_progress := cef_url_request_client_on_upload_progress; + on_download_progress := cef_url_request_client_on_download_progress; + on_download_data := cef_url_request_client_on_download_data; + get_auth_credentials := cef_url_request_client_get_auth_credentials; + end; +end; + +function TCefUrlrequestClientOwn.GetAuthCredentials(isProxy: Boolean; + const host: ustring; port: Integer; const realm, scheme: ustring; + const callback: ICefAuthCallback): Boolean; +begin + Result := False; +end; + +procedure TCefUrlrequestClientOwn.OnDownloadData(const request: ICefUrlRequest; + data: Pointer; dataLength: NativeUInt); +begin + +end; + +procedure TCefUrlrequestClientOwn.OnDownloadProgress( + const request: ICefUrlRequest; current, total: UInt64); +begin + +end; + +procedure TCefUrlrequestClientOwn.OnRequestComplete( + const request: ICefUrlRequest); +begin + +end; + +procedure TCefUrlrequestClientOwn.OnUploadProgress( + const request: ICefUrlRequest; current, total: UInt64); +begin + +end; + +{ TCefUrlRequestRef } + +procedure TCefUrlRequestRef.Cancel; +begin + PCefUrlRequest(FData).cancel(PCefUrlRequest(FData)); +end; + +class function TCefUrlRequestRef.New(const request: ICefRequest; + const client: ICefUrlRequestClient): ICefUrlRequest; +begin + Result := UnWrap(cef_urlrequest_create(CefGetData(request), CefGetData(client))); +end; + +function TCefUrlRequestRef.GetRequest: ICefRequest; +begin + Result := TCefRequestRef.UnWrap(PCefUrlRequest(FData).get_request(PCefUrlRequest(FData))); +end; + +function TCefUrlRequestRef.GetRequestError: Integer; +begin + Result := PCefUrlRequest(FData).get_request_error(PCefUrlRequest(FData)); +end; + +function TCefUrlRequestRef.GetRequestStatus: TCefUrlRequestStatus; +begin + Result := PCefUrlRequest(FData).get_request_status(PCefUrlRequest(FData)); +end; + +function TCefUrlRequestRef.GetResponse: ICefResponse; +begin + Result := TCefResponseRef.UnWrap(PCefUrlRequest(FData).get_response(PCefUrlRequest(FData))); +end; + +class function TCefUrlRequestRef.UnWrap(data: Pointer): ICefUrlRequest; +begin + if data <> nil then + Result := Create(data) as ICefUrlRequest else + Result := nil; +end; + + +{ TCefWebPluginInfoVisitorOwn } + +constructor TCefWebPluginInfoVisitorOwn.Create; +begin + inherited CreateData(SizeOf(TCefWebPluginInfoVisitor)); + PCefWebPluginInfoVisitor(FData).visit := cef_web_plugin_info_visitor_visit; +end; + +function TCefWebPluginInfoVisitorOwn.Visit(const info: ICefWebPluginInfo; count, + total: Integer): Boolean; +begin + Result := False; +end; + +{ TCefFastWebPluginInfoVisitor } + +constructor TCefFastWebPluginInfoVisitor.Create( + const proc: TCefWebPluginInfoVisitorProc); +begin + inherited Create; + FProc := proc; +end; + +function TCefFastWebPluginInfoVisitor.Visit(const info: ICefWebPluginInfo; + count, total: Integer): Boolean; +begin + Result := FProc(info, count, total); +end; + +{ TCefQuotaCallbackRef } + +procedure TCefQuotaCallbackRef.Cancel; +begin + PCefQuotaCallback(FData).cancel(FData); +end; + +procedure TCefQuotaCallbackRef.Cont(allow: Boolean); +begin + PCefQuotaCallback(FData).cont(FData, Ord(allow)); +end; + +class function TCefQuotaCallbackRef.UnWrap(data: Pointer): ICefQuotaCallback; +begin + if data <> nil then + Result := Create(data) as ICefQuotaCallback else + Result := nil; +end; + +{ TCefV8StackFrameRef } + +function TCefV8StackFrameRef.GetColumn: Integer; +begin + Result := PCefV8StackFrame(FData).get_column(FData); +end; + +function TCefV8StackFrameRef.GetFunctionName: ustring; +begin + Result := CefStringFreeAndGet(PCefV8StackFrame(FData).get_function_name(FData)); +end; + +function TCefV8StackFrameRef.GetLineNumber: Integer; +begin + Result := PCefV8StackFrame(FData).get_line_number(FData); +end; + +function TCefV8StackFrameRef.GetScriptName: ustring; +begin + Result := CefStringFreeAndGet(PCefV8StackFrame(FData).get_script_name(FData)); +end; + +function TCefV8StackFrameRef.GetScriptNameOrSourceUrl: ustring; +begin + Result := CefStringFreeAndGet(PCefV8StackFrame(FData).get_script_name_or_source_url(FData)); +end; + +function TCefV8StackFrameRef.IsConstructor: Boolean; +begin + Result := PCefV8StackFrame(FData).is_constructor(FData) <> 0; +end; + +function TCefV8StackFrameRef.IsEval: Boolean; +begin + Result := PCefV8StackFrame(FData).is_eval(FData) <> 0; +end; + +function TCefV8StackFrameRef.IsValid: Boolean; +begin + Result := PCefV8StackFrame(FData).is_valid(FData) <> 0; +end; + +class function TCefV8StackFrameRef.UnWrap(data: Pointer): ICefV8StackFrame; +begin + if data <> nil then + Result := Create(data) as ICefV8StackFrame else + Result := nil; +end; + +{ TCefV8StackTraceRef } + +class function TCefV8StackTraceRef.Current(frameLimit: Integer): ICefV8StackTrace; +begin + Result := UnWrap(cef_v8stack_trace_get_current(frameLimit)); +end; + +function TCefV8StackTraceRef.GetFrame(index: Integer): ICefV8StackFrame; +begin + Result := TCefV8StackFrameRef.UnWrap(PCefV8StackTrace(FData).get_frame(FData, index)); +end; + +function TCefV8StackTraceRef.GetFrameCount: Integer; +begin + Result := PCefV8StackTrace(FData).get_frame_count(FData); +end; + +function TCefV8StackTraceRef.IsValid: Boolean; +begin + Result := PCefV8StackTrace(FData).is_valid(FData) <> 0; +end; + +class function TCefV8StackTraceRef.UnWrap(data: Pointer): ICefV8StackTrace; +begin + if data <> nil then + Result := Create(data) as ICefV8StackTrace else + Result := nil; +end; + +{ TCefWebPluginUnstableCallbackOwn } + +constructor TCefWebPluginUnstableCallbackOwn.Create; +begin + inherited CreateData(SizeOf(TCefWebPluginUnstableCallback)); + PCefWebPluginUnstableCallback(FData).is_unstable := cef_web_plugin_unstable_callback_is_unstable; +end; + +procedure TCefWebPluginUnstableCallbackOwn.IsUnstable(const path: ustring; + unstable: Boolean); +begin + +end; + +{ TCefFastWebPluginUnstableCallback } + +constructor TCefFastWebPluginUnstableCallback.Create( + const callback: TCefWebPluginIsUnstableProc); +begin + FCallback := callback; +end; + +procedure TCefFastWebPluginUnstableCallback.IsUnstable(const path: ustring; + unstable: Boolean); +begin + FCallback(path, unstable); +end; + +{ TCefRunFileDialogCallbackOwn } + +procedure TCefRunFileDialogCallbackOwn.Cont(const browserHost: ICefBrowserHost; + filePaths: TStrings); +begin + +end; + +constructor TCefRunFileDialogCallbackOwn.Create; +begin + inherited CreateData(SizeOf(TCefRunFileDialogCallback)); + with PCefRunFileDialogCallback(FData)^ do + cont := cef_run_file_dialog_callback_cont; +end; + +{ TCefFastRunFileDialogCallback } + +procedure TCefFastRunFileDialogCallback.Cont(const browserHost: ICefBrowserHost; + filePaths: TStrings); +begin + FCallback(browserHost, filePaths); +end; + +constructor TCefFastRunFileDialogCallback.Create( + callback: TCefRunFileDialogCallbackProc); +begin + inherited Create; + FCallback := callback; +end; + +{ TCefTaskRef } + +procedure TCefTaskRef.Execute; +begin + PCefTask(FData).execute(FData); +end; + +class function TCefTaskRef.UnWrap(data: Pointer): ICefTask; +begin + if data <> nil then + Result := Create(data) as ICefTask else + Result := nil; +end; + +{ TCefTaskRunnerRef } + +function TCefTaskRunnerRef.BelongsToCurrentThread: Boolean; +begin + Result := PCefTaskRunner(FData).belongs_to_current_thread(FData) <> 0; +end; + +function TCefTaskRunnerRef.BelongsToThread(threadId: TCefThreadId): Boolean; +begin + Result := PCefTaskRunner(FData).belongs_to_thread(FData, threadId) <> 0; +end; + +class function TCefTaskRunnerRef.GetForCurrentThread: ICefTaskRunner; +begin + Result := UnWrap(cef_task_runner_get_for_current_thread()); +end; + +class function TCefTaskRunnerRef.GetForThread(threadId: TCefThreadId): ICefTaskRunner; +begin + Result := UnWrap(cef_task_runner_get_for_thread(threadId)); +end; + +function TCefTaskRunnerRef.IsSame(const that: ICefTaskRunner): Boolean; +begin + Result := PCefTaskRunner(FData).is_same(FData, CefGetData(that)) <> 0; +end; + +function TCefTaskRunnerRef.PostDelayedTask(const task: ICefTask; + delayMs: Int64): Boolean; +begin + Result := PCefTaskRunner(FData).post_delayed_task(FData, CefGetData(task), delayMs) <> 0; +end; + +function TCefTaskRunnerRef.PostTask(const task: ICefTask): Boolean; +begin + Result := PCefTaskRunner(FData).post_task(FData, CefGetData(task)) <> 0; +end; + +class function TCefTaskRunnerRef.UnWrap(data: Pointer): ICefTaskRunner; +begin + if data <> nil then + Result := Create(data) as ICefTaskRunner else + Result := nil; +end; + +{ TCefTraceClientOwn } + +constructor TCefTraceClientOwn.Create; +begin + inherited CreateData(SizeOf(TCefTraceClient)); + with PCefTraceClient(FData)^ do + begin + on_trace_data_collected := cef_trace_client_on_trace_data_collected; + on_trace_buffer_percent_full_reply := cef_trace_client_on_trace_buffer_percent_full_reply; + on_end_tracing_complete := cef_trace_client_on_end_tracing_complete; + end; +end; + +procedure TCefTraceClientOwn.OnEndTracingComplete; +begin + +end; + +procedure TCefTraceClientOwn.OnTraceBufferPercentFullReply(percentFull: Single); +begin + +end; + +procedure TCefTraceClientOwn.OnTraceDataCollected(const fragment: PAnsiChar; + fragmentSize: NativeUInt); +begin + +end; + +{ TCefGetGeolocationCallbackOwn } + +constructor TCefGetGeolocationCallbackOwn.Create; +begin + inherited CreateData(SizeOf(TCefGetGeolocationCallback)); + with PCefGetGeolocationCallback(FData)^ do + on_location_update := cef_get_geolocation_callback_on_location_update; +end; + +procedure TCefGetGeolocationCallbackOwn.OnLocationUpdate( + const position: PCefGeoposition); +begin + +end; + +{ TCefFastGetGeolocationCallback } + +constructor TCefFastGetGeolocationCallback.Create( + const callback: TOnLocationUpdate); +begin + inherited Create; + FCallback := callback; +end; + +procedure TCefFastGetGeolocationCallback.OnLocationUpdate( + const position: PCefGeoposition); +begin + FCallback(position); +end; + +{ TCefFileDialogCallbackRef } + +procedure TCefFileDialogCallbackRef.Cancel; +begin + PCefFileDialogCallback(FData).cancel(FData); +end; + +procedure TCefFileDialogCallbackRef.Cont(filePaths: TStrings); +var + list: TCefStringList; + i: Integer; + str: TCefString; +begin + list := cef_string_list_alloc; + try + for i := 0 to filePaths.Count - 1 do + begin + str := CefString(filePaths[i]); + cef_string_list_append(list, @str); + end; + PCefFileDialogCallback(FData).cont(FData, list); + finally + cef_string_list_free(list); + end; +end; + +class function TCefFileDialogCallbackRef.UnWrap( + data: Pointer): ICefFileDialogCallback; +begin + if data <> nil then + Result := Create(data) as ICefFileDialogCallback else + Result := nil; +end; + +{ TCefDialogHandlerOwn } + +constructor TCefDialogHandlerOwn.Create; +begin + CreateData(SizeOf(TCefDialogHandler)); + with PCefDialogHandler(FData)^ do + on_file_dialog := cef_dialog_handler_on_file_dialog; +end; + +function TCefDialogHandlerOwn.OnFileDialog(const browser: ICefBrowser; + mode: TCefFileDialogMode; const title, defaultFileName: ustring; + acceptTypes: TStrings; const callback: ICefFileDialogCallback): Boolean; +begin + Result := False; +end; + +{ TCefRenderHandlerOwn } + +constructor TCefRenderHandlerOwn.Create; +begin + CreateData(SizeOf(TCefRenderHandler), False); + with PCefRenderHandler(FData)^ do + begin + get_root_screen_rect := cef_render_handler_get_root_screen_rect; + get_view_rect := cef_render_handler_get_view_rect; + get_screen_point := cef_render_handler_get_screen_point; + on_popup_show := cef_render_handler_on_popup_show; + on_popup_size := cef_render_handler_on_popup_size; + on_paint := cef_render_handler_on_paint; + on_cursor_change := cef_render_handler_on_cursor_change; + on_scroll_offset_changed := cef_render_handler_on_scroll_offset_changed; + end; +end; + +function TCefRenderHandlerOwn.GetRootScreenRect(const browser: ICefBrowser; + rect: PCefRect): Boolean; +begin + Result := False; +end; + +function TCefRenderHandlerOwn.GetScreenInfo(const browser: ICefBrowser; + screenInfo: PCefScreenInfo): Boolean; +begin + Result := False; +end; + +function TCefRenderHandlerOwn.GetScreenPoint(const browser: ICefBrowser; viewX, + viewY: Integer; screenX, screenY: PInteger): Boolean; +begin + Result := False; +end; + +function TCefRenderHandlerOwn.GetViewRect(const browser: ICefBrowser; + rect: PCefRect): Boolean; +begin + Result := False; +end; + +procedure TCefRenderHandlerOwn.OnCursorChange(const browser: ICefBrowser; + cursor: TCefCursorHandle); +begin + +end; + +procedure TCefRenderHandlerOwn.OnPaint(const browser: ICefBrowser; + kind: TCefPaintElementType; dirtyRectsCount: NativeUInt; + const dirtyRects: PCefRectArray; const buffer: Pointer; width, height: Integer); +begin + +end; + +procedure TCefRenderHandlerOwn.OnPopupShow(const browser: ICefBrowser; + show: Boolean); +begin + +end; + +procedure TCefRenderHandlerOwn.OnPopupSize(const browser: ICefBrowser; + const rect: PCefRect); +begin + +end; + +procedure TCefRenderHandlerOwn.OnScrollOffsetChanged( + const browser: ICefBrowser); +begin + +end; + +{ TCefCompletionHandlerOwn } + +constructor TCefCompletionHandlerOwn.Create; +begin + inherited CreateData(SizeOf(TCefCompletionHandler)); + with PCefCompletionHandler(FData)^ do + on_complete := cef_completion_handler_on_complete; +end; + +procedure TCefCompletionHandlerOwn.OnComplete; +begin + +end; + +{ TCefFastCompletionHandler } + +constructor TCefFastCompletionHandler.Create( + const proc: TCefCompletionHandlerProc); +begin + inherited Create; + FProc := proc; +end; + +procedure TCefFastCompletionHandler.OnComplete; +begin + FProc(); +end; + +{ TCefAllowCertificateErrorCallbackRef } + +procedure TCefAllowCertificateErrorCallbackRef.Cont(allow: Boolean); +begin + PCefAllowCertificateErrorCallback(FData).cont(FData, Ord(allow)); +end; + +class function TCefAllowCertificateErrorCallbackRef.UnWrap( + data: Pointer): ICefAllowCertificateErrorCallback; +begin + if data <> nil then + Result := Create(data) as ICefAllowCertificateErrorCallback else + Result := nil; +end; + +{ TCefDragDataRef } + +function TCefDragDataRef.GetFileName: ustring; +begin + Result := CefStringFreeAndGet(PCefDragData(FData).get_file_name(FData)); +end; + +function TCefDragDataRef.GetFileNames(names: TStrings): Integer; +var + list: TCefStringList; + i: Integer; + str: TCefString; +begin + list := cef_string_list_alloc; + try + Result := PCefDragData(FData).get_file_names(FData, list); + for i := 0 to cef_string_list_size(list) - 1 do + begin + FillChar(str, SizeOf(str), 0); + cef_string_list_value(list, i, @str); + names.Add(CefStringClearAndGet(str)); + end; + finally + cef_string_list_free(list); + end; +end; + +function TCefDragDataRef.GetFragmentBaseUrl: ustring; +begin + Result := CefStringFreeAndGet(PCefDragData(FData).get_fragment_base_url(FData)); +end; + +function TCefDragDataRef.GetFragmentHtml: ustring; +begin + Result := CefStringFreeAndGet(PCefDragData(FData).get_fragment_html(FData)); +end; + +function TCefDragDataRef.GetFragmentText: ustring; +begin + Result := CefStringFreeAndGet(PCefDragData(FData).get_fragment_text(FData)); +end; + +function TCefDragDataRef.GetLinkMetadata: ustring; +begin + Result := CefStringFreeAndGet(PCefDragData(FData).get_link_metadata(FData)); +end; + +function TCefDragDataRef.GetLinkTitle: ustring; +begin + Result := CefStringFreeAndGet(PCefDragData(FData).get_link_title(FData)); +end; + +function TCefDragDataRef.GetLinkUrl: ustring; +begin + Result := CefStringFreeAndGet(PCefDragData(FData).get_link_url(FData)); +end; + +function TCefDragDataRef.IsFile: Boolean; +begin + Result := PCefDragData(FData).is_file(FData) <> 0; +end; + +function TCefDragDataRef.IsFragment: Boolean; +begin + Result := PCefDragData(FData).is_fragment(FData) <> 0; +end; + +function TCefDragDataRef.IsLink: Boolean; +begin + Result := PCefDragData(FData).is_link(FData) <> 0; +end; + +class function TCefDragDataRef.UnWrap(data: Pointer): ICefDragData; +begin + if data <> nil then + Result := Create(data) as ICefDragData else + Result := nil; +end; + +{ TCefDragHandlerOwn } + +constructor TCefDragHandlerOwn.Create; +begin + CreateData(SizeOf(TCefDragHandler), False); + with PCefDragHandler(FData)^ do + on_drag_enter := cef_drag_handler_on_drag_enter; +end; + +function TCefDragHandlerOwn.OnDragEnter(const browser: ICefBrowser; + const dragData: ICefDragData; mask: TCefDragOperations): Boolean; +begin + Result := False; +end; + +{ TCefRequestContextHandlerOwn } + +constructor TCefRequestContextHandlerOwn.Create; +begin + CreateData(SizeOf(TCefRequestContextHandler), False); + with PCefRequestContextHandler(FData)^ do + get_cookie_manager := cef_request_context_handler_get_cookie_manager; +end; + +function TCefRequestContextHandlerOwn.GetCookieManager: ICefCookieManager; +begin + Result := nil; +end; + +{ TCefCookieManagerOwn } + +constructor TCefCookieManagerOwn.Create; +begin + CreateData(SizeOf(TCefCookieManager), False); + with PCefCookieManager(FData)^ do + begin + set_supported_schemes := cef_cookie_manager_set_supported_schemes; + visit_all_cookies := cef_cookie_manager_visit_all_cookies; + visit_url_cookies := cef_cookie_manager_visit_url_cookies; + set_cookie := cef_cookie_manager_set_cookie; + delete_cookies := cef_cookie_manager_delete_cookies; + set_storage_path := cef_cookie_manager_set_storage_path; + flush_store := cef_cookie_manager_flush_store; + end; +end; + +function TCefCookieManagerOwn.DeleteCookies(const url, + cookieName: ustring): Boolean; +begin + Result := False; +end; + +function TCefCookieManagerOwn.FlushStore( + const handler: ICefCompletionHandler): Boolean; +begin + Result := False; +end; + +function TCefCookieManagerOwn.FlushStoreProc( + const proc: TCefCompletionHandlerProc): Boolean; +begin + Result := False; +end; + +function TCefCookieManagerOwn.SetCookie(const url, name, value, domain, + path: ustring; secure, httponly, hasExpires: Boolean; const creation, + lastAccess, expires: TDateTime): Boolean; +begin + Result := False; +end; + +function TCefCookieManagerOwn.SetStoragePath(const path: ustring; + persistSessionCookies: Boolean): Boolean; +begin + Result := False; +end; + +procedure TCefCookieManagerOwn.SetSupportedSchemes(schemes: TStrings); +begin + +end; + +function TCefCookieManagerOwn.VisitAllCookies( + const visitor: ICefCookieVisitor): Boolean; +begin + Result := False; +end; + +function TCefCookieManagerOwn.VisitUrlCookies(const url: ustring; + includeHttpOnly: Boolean; const visitor: ICefCookieVisitor): Boolean; +begin + Result := False; +end; + +{ TCefCookieVisitorRef } + +class function TCefCookieVisitorRef.UnWrap(data: Pointer): ICefCookieVisitor; +begin + if data <> nil then + Result := Create(data) as ICefCookieVisitor else + Result := nil; +end; + +function TCefCookieVisitorRef.visit(const name, value, domain, path: ustring; + secure, httponly, hasExpires: Boolean; const creation, lastAccess, + expires: TDateTime; count, total: Integer; + out deleteCookie: Boolean): Boolean; +var + c: TCefCookie; + d: Integer; +begin + d := Ord(False); + FillChar(c, SizeOf(c), 0); + c.name := CefString(name); + c.value := CefString(value); + c.domain := CefString(domain); + c.path := CefString(path); + c.secure := secure; + c.httponly := httponly; + c.creation := DateTimeToCefTime(creation); + c.last_access := DateTimeToCefTime(lastAccess); + c.has_expires := hasExpires; + c.expires := DateTimeToCefTime(expires); + Result := PCefCookieVisitor(FData).visit(FData, @c, count, total, @d) <> 0; +end; + +{ TCefCompletionHandlerRef } + +procedure TCefCompletionHandlerRef.OnComplete; +begin + PCefCompletionHandler(FData).on_complete(FData); +end; + +class function TCefCompletionHandlerRef.UnWrap( + data: Pointer): ICefCompletionHandler; +begin + if data <> nil then + Result := Create(data) as ICefCompletionHandler else + Result := nil; +end; + +{ TCefRequestContextRef } + +function TCefRequestContextRef.IsSame(const other: ICefRequestContext): Boolean; +begin + Result := PCefRequestContext(FData).is_same(FData, CefGetData(other)) <> 0; +end; + +function TCefRequestContextRef.IsGlobal: Boolean; +begin + Result := PCefRequestContext(FData).is_global(FData) <> 0; +end; + +function TCefRequestContextRef.GetHandler: ICefBase; +begin + Result := TCefBaseRef.UnWrap(PCefRequestContext(FData).get_handler(FData)); +end; + +class function TCefRequestContextRef.UnWrap(data: Pointer): ICefRequestContext; +begin + if data <> nil then + Result := Create(data) as ICefRequestContext else + Result := nil; +end; + +class function TCefRequestContextRef.GetGlobalContext: ICefRequestContext; +begin + Result := UnWrap(cef_request_context_get_global_context()); +end; + +class function TCefRequestContextRef.CreateContext(const handler: ICefRequestContextHandler): ICefRequestContext; +begin + Result := UnWrap(cef_request_context_create_context(CefGetData(handler))); +end; + +{ TCefRequestContextHandlerRef } + +function TCefRequestContextHandlerRef.GetCookieManager: ICefCookieManager; +begin + Result := TCefCookieManagerRef.UnWrap(PCefRequestContextHandler(FData).get_cookie_manager(FData)); +end; + +class function TCefRequestContextHandlerRef.UnWrap(data: Pointer): ICefRequestContextHandler; +begin + if data <> nil then + Result := Create(data) as ICefRequestContextHandler else + Result := nil; +end; + + +initialization + IsMultiThread := True; + +finalization + CefShutDown; + +end. diff --git a/src/thirdparty/cefvcl.pas b/src/thirdparty/cefvcl.pas new file mode 100644 index 0000000..45ef6ab --- /dev/null +++ b/src/thirdparty/cefvcl.pas @@ -0,0 +1,1818 @@ +(* + * Delphi Chromium Embedded 3 + * + * Usage allowed under the restrictions of the Lesser GNU General Public License + * or alternatively the restrictions of the Mozilla Public License 1.1 + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for + * the specific language governing rights and limitations under the License. + * + * Unit owner : Henri Gourvest + * Web site : http://www.progdigy.com + * Repository : http://code.google.com/p/delphichromiumembedded/ + * Group : http://groups.google.com/group/delphichromiumembedded + * + * Embarcadero Technologies, Inc is not permitted to use or redistribute + * this source code without explicit permission. + * + *) + +unit cefvcl; + +{$I cef.inc} + +interface +uses + Windows, Messages, Classes, + cefgui, ceflib, +{$ifdef DELPHI16_UP} + Vcl.Controls, Vcl.Graphics +{$else} + Controls, Graphics +{$endif}; + +type + TCustomChromium = class(TWinControl, IChromiumEvents) + private + FHandler: ICefClient; + FBrowser: ICefBrowser; + FBrowserId: Integer; + FDefaultUrl: ustring; + + FOnProcessMessageReceived: TOnProcessMessageReceived; + FOnLoadStart: TOnLoadStart; + FOnLoadEnd: TOnLoadEnd; + FOnLoadError: TOnLoadError; + FOnRenderProcessTerminated: TOnRenderProcessTerminated; + FOnPluginCrashed: TOnPluginCrashed; + FOnTakeFocus: TOnTakeFocus; + FOnSetFocus: TOnSetFocus; + FOnGotFocus: TOnGotFocus; + FOnBeforeContextMenu: TOnBeforeContextMenu; + FOnContextMenuCommand: TOnContextMenuCommand; + FOnContextMenuDismissed: TOnContextMenuDismissed; + FOnPreKeyEvent: TOnPreKeyEvent; + FOnKeyEvent: TOnKeyEvent; + FOnLoadingStateChange: TOnLoadingStateChange; + FOnAddressChange: TOnAddressChange; + FOnTitleChange: TOnTitleChange; + FOnTooltip: TOnTooltip; + FOnStatusMessage: TOnStatusMessage; + FOnConsoleMessage: TOnConsoleMessage; + FOnBeforeDownload: TOnBeforeDownload; + FOnDownloadUpdated: TOnDownloadUpdated; + FOnRequestGeolocationPermission: TOnRequestGeolocationPermission; + FOnCancelGeolocationPermission: TOnCancelGeolocationPermission; + FOnJsdialog: TOnJsdialog; + FOnBeforeUnloadDialog: TOnBeforeUnloadDialog; + FOnResetDialogState: TOnResetDialogState; + FOnDialogClosed: TOnDialogClosed; + FOnBeforePopup: TOnBeforePopup; + FOnAfterCreated: TOnAfterCreated; + FOnBeforeClose: TOnBeforeClose; + FOnRunModal: TOnRunModal; + FOnClose: TOnClose; + FOnBeforeBrowse: TOnBeforeBrowse; + FOnBeforeResourceLoad: TOnBeforeResourceLoad; + FOnGetResourceHandler: TOnGetResourceHandler; + FOnResourceRedirect: TOnResourceRedirect; + FOnGetAuthCredentials: TOnGetAuthCredentials; + FOnQuotaRequest: TOnQuotaRequest; + FOnGetCookieManager: TOnGetCookieManager; + FOnProtocolExecution: TOnProtocolExecution; + FOnBeforePluginLoad: TOnBeforePluginLoad; + FOnFileDialog: TOnFileDialog; + FOnDragEnter: TOnDragEnter; + + FOptions: TChromiumOptions; + FUserStyleSheetLocation: ustring; + FDefaultEncoding: ustring; + FFontOptions: TChromiumFontOptions; + + procedure GetSettings(var settings: TCefBrowserSettings); + procedure CreateBrowser; + protected + procedure WndProc(var Message: TMessage); override; + procedure CreateWindowHandle(const Params: TCreateParams); override; + procedure Loaded; override; + procedure Resize; override; + + function doOnProcessMessageReceived(const browser: ICefBrowser; + sourceProcess: TCefProcessId; const message: ICefProcessMessage): Boolean; virtual; + + procedure doOnLoadStart(const browser: ICefBrowser; const frame: ICefFrame); virtual; + procedure doOnLoadEnd(const browser: ICefBrowser; const frame: ICefFrame; httpStatusCode: Integer); virtual; + procedure doOnLoadError(const browser: ICefBrowser; const frame: ICefFrame; errorCode: Integer; + const errorText, failedUrl: ustring); virtual; + procedure doOnRenderProcessTerminated(const browser: ICefBrowser; status: TCefTerminationStatus); virtual; + procedure doOnPluginCrashed(const browser: ICefBrowser; const pluginPath: ustring); virtual; + + procedure doOnTakeFocus(const browser: ICefBrowser; next: Boolean); virtual; + function doOnSetFocus(const browser: ICefBrowser; source: TCefFocusSource): Boolean; virtual; + procedure doOnGotFocus(const browser: ICefBrowser); virtual; + + procedure doOnBeforeContextMenu(const browser: ICefBrowser; const frame: ICefFrame; + const params: ICefContextMenuParams; const model: ICefMenuModel); virtual; + function doOnContextMenuCommand(const browser: ICefBrowser; const frame: ICefFrame; + const params: ICefContextMenuParams; commandId: Integer; + eventFlags: TCefEventFlags): Boolean; virtual; + procedure doOnContextMenuDismissed(const browser: ICefBrowser; const frame: ICefFrame); virtual; + + function doOnPreKeyEvent(const browser: ICefBrowser; const event: PCefKeyEvent; + osEvent: TCefEventHandle; out isKeyboardShortcut: Boolean): Boolean; virtual; + function doOnKeyEvent(const browser: ICefBrowser; const event: PCefKeyEvent; + osEvent: TCefEventHandle): Boolean; virtual; + + procedure doOnLoadingStateChange(const browser: ICefBrowser; isLoading, canGoBack, canGoForward: Boolean); virtual; + procedure doOnAddressChange(const browser: ICefBrowser; const frame: ICefFrame; const url: ustring); virtual; + procedure doOnTitleChange(const browser: ICefBrowser; const title: ustring); virtual; + function doOnTooltip(const browser: ICefBrowser; var text: ustring): Boolean; virtual; + procedure doOnStatusMessage(const browser: ICefBrowser; const value: ustring); virtual; + function doOnConsoleMessage(const browser: ICefBrowser; const message, source: ustring; line: Integer): Boolean; virtual; + + procedure doOnBeforeDownload(const browser: ICefBrowser; const downloadItem: ICefDownloadItem; + const suggestedName: ustring; const callback: ICefBeforeDownloadCallback); virtual; + procedure doOnDownloadUpdated(const browser: ICefBrowser; const downloadItem: ICefDownloadItem; + const callback: ICefDownloadItemCallback); virtual; + + procedure doOnRequestGeolocationPermission(const browser: ICefBrowser; + const requestingUrl: ustring; requestId: Integer; const callback: ICefGeolocationCallback); virtual; + procedure doOnCancelGeolocationPermission(const browser: ICefBrowser; + const requestingUrl: ustring; requestId: Integer); virtual; + + function doOnJsdialog(const browser: ICefBrowser; const originUrl, acceptLang: ustring; + dialogType: TCefJsDialogType; const messageText, defaultPromptText: ustring; + callback: ICefJsDialogCallback; out suppressMessage: Boolean): Boolean; virtual; + function doOnBeforeUnloadDialog(const browser: ICefBrowser; + const messageText: ustring; isReload: Boolean; + const callback: ICefJsDialogCallback): Boolean; virtual; + procedure doOnResetDialogState(const browser: ICefBrowser); virtual; + procedure doOnDialogClosed(const browser: ICefBrowser); virtual; + + function doOnBeforePopup(const browser: ICefBrowser; + const frame: ICefFrame; const targetUrl, targetFrameName: ustring; + var popupFeatures: TCefPopupFeatures; var windowInfo: TCefWindowInfo; + var client: ICefClient; var settings: TCefBrowserSettings; + var noJavascriptAccess: Boolean): Boolean; virtual; + procedure doOnAfterCreated(const browser: ICefBrowser); virtual; + procedure doOnBeforeClose(const browser: ICefBrowser); virtual; + function doOnRunModal(const browser: ICefBrowser): Boolean; virtual; + function doOnClose(const browser: ICefBrowser): Boolean; virtual; + + function doOnBeforeBrowse(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest; isRedirect: Boolean): Boolean; virtual; + function doOnBeforeResourceLoad(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest): Boolean; virtual; + function doOnGetResourceHandler(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest): ICefResourceHandler; virtual; + procedure doOnResourceRedirect(const browser: ICefBrowser; const frame: ICefFrame; + const oldUrl: ustring; var newUrl: ustring); virtual; + function doOnGetAuthCredentials(const browser: ICefBrowser; const frame: ICefFrame; + isProxy: Boolean; const host: ustring; port: Integer; const realm, scheme: ustring; + const callback: ICefAuthCallback): Boolean; virtual; + function doOnQuotaRequest(const browser: ICefBrowser; const originUrl: ustring; + newSize: Int64; const callback: ICefQuotaCallback): Boolean; virtual; + function doOnGetCookieManager: ICefCookieManager; virtual; + procedure doOnProtocolExecution(const browser: ICefBrowser; + const url: ustring; out allowOsExecution: Boolean); virtual; + function doOnBeforePluginLoad(const browser: ICefBrowser; const url, + policyUrl: ustring; const info: ICefWebPluginInfo): Boolean; virtual; + + function doOnFileDialog(const browser: ICefBrowser; mode: TCefFileDialogMode; + const title, defaultFileName: ustring; acceptTypes: TStrings; + const callback: ICefFileDialogCallback): Boolean; + + function doOnGetRootScreenRect(const browser: ICefBrowser; rect: PCefRect): Boolean; + function doOnGetViewRect(const browser: ICefBrowser; rect: PCefRect): Boolean; + function doOnGetScreenPoint(const browser: ICefBrowser; viewX, viewY: Integer; + screenX, screenY: PInteger): Boolean; + function doOnGetScreenInfo(const browser: ICefBrowser; screenInfo: PCefScreenInfo): Boolean; + procedure doOnPopupShow(const browser: ICefBrowser; show: Boolean); + procedure doOnPopupSize(const browser: ICefBrowser; const rect: PCefRect); + procedure doOnPaint(const browser: ICefBrowser; kind: TCefPaintElementType; + dirtyRectsCount: NativeUInt; const dirtyRects: PCefRectArray; + const buffer: Pointer; width, height: Integer); + procedure doOnCursorChange(const browser: ICefBrowser; cursor: TCefCursorHandle); + procedure doOnScrollOffsetChanged(const browser: ICefBrowser); + + function doOnDragEnter(const browser: ICefBrowser; const dragData: ICefDragData; + mask: TCefDragOperations): Boolean; + + property OnProcessMessageReceived: TOnProcessMessageReceived read FOnProcessMessageReceived write FOnProcessMessageReceived; + property OnLoadStart: TOnLoadStart read FOnLoadStart write FOnLoadStart; + property OnLoadEnd: TOnLoadEnd read FOnLoadEnd write FOnLoadEnd; + property OnLoadError: TOnLoadError read FOnLoadError write FOnLoadError; + property OnRenderProcessTerminated: TOnRenderProcessTerminated read FOnRenderProcessTerminated write FOnRenderProcessTerminated; + property OnPluginCrashed: TOnPluginCrashed read FOnPluginCrashed write FOnPluginCrashed; + property OnTakeFocus: TOnTakeFocus read FOnTakeFocus write FOnTakeFocus; + property OnSetFocus: TOnSetFocus read FOnSetFocus write FOnSetFocus; + property OnGotFocus: TOnGotFocus read FOnGotFocus write FOnGotFocus; + property OnBeforeContextMenu: TOnBeforeContextMenu read FOnBeforeContextMenu write FOnBeforeContextMenu; + property OnContextMenuCommand: TOnContextMenuCommand read FOnContextMenuCommand write FOnContextMenuCommand; + property OnContextMenuDismissed: TOnContextMenuDismissed read FOnContextMenuDismissed write FOnContextMenuDismissed; + property OnPreKeyEvent: TOnPreKeyEvent read FOnPreKeyEvent write FOnPreKeyEvent; + property OnKeyEvent: TOnKeyEvent read FOnKeyEvent write FOnKeyEvent; + property OnLoadingStateChange: TOnLoadingStateChange read FOnLoadingStateChange write FOnLoadingStateChange; + property OnAddressChange: TOnAddressChange read FOnAddressChange write FOnAddressChange; + property OnTitleChange: TOnTitleChange read FOnTitleChange write FOnTitleChange; + property OnTooltip: TOnTooltip read FOnTooltip write FOnTooltip; + property OnStatusMessage: TOnStatusMessage read FOnStatusMessage write FOnStatusMessage; + property OnConsoleMessage: TOnConsoleMessage read FOnConsoleMessage write FOnConsoleMessage; + property OnBeforeDownload: TOnBeforeDownload read FOnBeforeDownload write FOnBeforeDownload; + property OnDownloadUpdated: TOnDownloadUpdated read FOnDownloadUpdated write FOnDownloadUpdated; + property OnRequestGeolocationPermission: TOnRequestGeolocationPermission read FOnRequestGeolocationPermission write FOnRequestGeolocationPermission; + property OnCancelGeolocationPermission: TOnCancelGeolocationPermission read FOnCancelGeolocationPermission write FOnCancelGeolocationPermission; + property OnJsdialog: TOnJsdialog read FOnJsdialog write FOnJsdialog; + property OnBeforeUnloadDialog: TOnBeforeUnloadDialog read FOnBeforeUnloadDialog write FOnBeforeUnloadDialog; + property OnResetDialogState: TOnResetDialogState read FOnResetDialogState write FOnResetDialogState; + property OnDialogClosed: TOnDialogClosed read FOnDialogClosed write FOnDialogClosed; + property OnBeforePopup: TOnBeforePopup read FOnBeforePopup write FOnBeforePopup; + property OnAfterCreated: TOnAfterCreated read FOnAfterCreated write FOnAfterCreated; + property OnBeforeClose: TOnBeforeClose read FOnBeforeClose write FOnBeforeClose; + property OnRunModal: TOnRunModal read FOnRunModal write FOnRunModal; + property OnClose: TOnClose read FOnClose write FOnClose; + property OnBeforeBrowse: TOnBeforeBrowse read FOnBeforeBrowse write FOnBeforeBrowse; + property OnBeforeResourceLoad: TOnBeforeResourceLoad read FOnBeforeResourceLoad write FOnBeforeResourceLoad; + property OnGetResourceHandler: TOnGetResourceHandler read FOnGetResourceHandler write FOnGetResourceHandler; + property OnResourceRedirect: TOnResourceRedirect read FOnResourceRedirect write FOnResourceRedirect; + property OnGetAuthCredentials: TOnGetAuthCredentials read FOnGetAuthCredentials write FOnGetAuthCredentials; + property OnQuotaRequest: TOnQuotaRequest read FOnQuotaRequest write FOnQuotaRequest; + property OnGetCookieManager: TOnGetCookieManager read FOnGetCookieManager write FOnGetCookieManager; + property OnProtocolExecution: TOnProtocolExecution read FOnProtocolExecution write FOnProtocolExecution; + property OnBeforePluginLoad: TOnBeforePluginLoad read FOnBeforePluginLoad write FOnBeforePluginLoad; + property OnFileDialog: TOnFileDialog read FOnFileDialog write FOnFileDialog; + property OnDragEnter: TOnDragEnter read FOnDragEnter write FOnDragEnter; + + property DefaultUrl: ustring read FDefaultUrl write FDefaultUrl; + property Options: TChromiumOptions read FOptions write FOptions; + property FontOptions: TChromiumFontOptions read FFontOptions; + property DefaultEncoding: ustring read FDefaultEncoding write FDefaultEncoding; + property UserStyleSheetLocation: ustring read FUserStyleSheetLocation write FUserStyleSheetLocation; + property BrowserId: Integer read FBrowserId; + property Browser: ICefBrowser read FBrowser; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Load(const url: ustring); + procedure ReCreateBrowser(const url: string); + end; + + TCustomChromiumOSR = class(TComponent, IChromiumEvents) + private + FHandler: ICefClient; + FBrowser: ICefBrowser; + FBrowserId: Integer; + FDefaultUrl: ustring; + + FOnProcessMessageReceived: TOnProcessMessageReceived; + FOnLoadStart: TOnLoadStart; + FOnLoadEnd: TOnLoadEnd; + FOnLoadError: TOnLoadError; + FOnRenderProcessTerminated: TOnRenderProcessTerminated; + FOnPluginCrashed: TOnPluginCrashed; + FOnTakeFocus: TOnTakeFocus; + FOnSetFocus: TOnSetFocus; + FOnGotFocus: TOnGotFocus; + FOnBeforeContextMenu: TOnBeforeContextMenu; + FOnContextMenuCommand: TOnContextMenuCommand; + FOnContextMenuDismissed: TOnContextMenuDismissed; + FOnPreKeyEvent: TOnPreKeyEvent; + FOnKeyEvent: TOnKeyEvent; + FOnLoadingStateChange: TOnLoadingStateChange; + FOnAddressChange: TOnAddressChange; + FOnTitleChange: TOnTitleChange; + FOnTooltip: TOnTooltip; + FOnStatusMessage: TOnStatusMessage; + FOnConsoleMessage: TOnConsoleMessage; + FOnBeforeDownload: TOnBeforeDownload; + FOnDownloadUpdated: TOnDownloadUpdated; + FOnRequestGeolocationPermission: TOnRequestGeolocationPermission; + FOnCancelGeolocationPermission: TOnCancelGeolocationPermission; + FOnJsdialog: TOnJsdialog; + FOnBeforeUnloadDialog: TOnBeforeUnloadDialog; + FOnResetDialogState: TOnResetDialogState; + FOnDialogClosed: TOnDialogClosed; + FOnBeforePopup: TOnBeforePopup; + FOnAfterCreated: TOnAfterCreated; + FOnBeforeClose: TOnBeforeClose; + FOnRunModal: TOnRunModal; + FOnClose: TOnClose; + FOnBeforeBrowse: TOnBeforeBrowse; + FOnBeforeResourceLoad: TOnBeforeResourceLoad; + FOnGetResourceHandler: TOnGetResourceHandler; + FOnResourceRedirect: TOnResourceRedirect; + FOnGetAuthCredentials: TOnGetAuthCredentials; + FOnQuotaRequest: TOnQuotaRequest; + FOnGetCookieManager: TOnGetCookieManager; + FOnProtocolExecution: TOnProtocolExecution; + FOnBeforePluginLoad: TOnBeforePluginLoad; + FOnFileDialog: TOnFileDialog; + + FOnGetRootScreenRect: TOnGetRootScreenRect; + FOnGetViewRect: TOnGetViewRect; + FOnGetScreenPoint: TOnGetScreenPoint; + FOnGetScreenInfo: TOnGetScreenInfo; + FOnPopupShow: TOnPopupShow; + FOnPopupSize: TOnPopupSize; + FOnPaint: TOnPaint; + FOnCursorChange: TOnCursorChange; + FOnScrollOffsetChanged: TOnScrollOffsetChanged; + + FOnDragEnter: TOnDragEnter; + + FOptions: TChromiumOptions; + FUserStyleSheetLocation: ustring; + FDefaultEncoding: ustring; + FFontOptions: TChromiumFontOptions; + + procedure GetSettings(var settings: TCefBrowserSettings); + procedure CreateBrowser; + protected + procedure Loaded; override; + + function doOnProcessMessageReceived(const browser: ICefBrowser; + sourceProcess: TCefProcessId; const message: ICefProcessMessage): Boolean; virtual; + + procedure doOnLoadStart(const browser: ICefBrowser; const frame: ICefFrame); virtual; + procedure doOnLoadEnd(const browser: ICefBrowser; const frame: ICefFrame; httpStatusCode: Integer); virtual; + procedure doOnLoadError(const browser: ICefBrowser; const frame: ICefFrame; errorCode: Integer; + const errorText, failedUrl: ustring); virtual; + procedure doOnRenderProcessTerminated(const browser: ICefBrowser; status: TCefTerminationStatus); virtual; + procedure doOnPluginCrashed(const browser: ICefBrowser; const pluginPath: ustring); virtual; + + procedure doOnTakeFocus(const browser: ICefBrowser; next: Boolean); virtual; + function doOnSetFocus(const browser: ICefBrowser; source: TCefFocusSource): Boolean; virtual; + procedure doOnGotFocus(const browser: ICefBrowser); virtual; + + procedure doOnBeforeContextMenu(const browser: ICefBrowser; const frame: ICefFrame; + const params: ICefContextMenuParams; const model: ICefMenuModel); virtual; + function doOnContextMenuCommand(const browser: ICefBrowser; const frame: ICefFrame; + const params: ICefContextMenuParams; commandId: Integer; + eventFlags: TCefEventFlags): Boolean; virtual; + procedure doOnContextMenuDismissed(const browser: ICefBrowser; const frame: ICefFrame); virtual; + + function doOnPreKeyEvent(const browser: ICefBrowser; const event: PCefKeyEvent; + osEvent: TCefEventHandle; out isKeyboardShortcut: Boolean): Boolean; virtual; + function doOnKeyEvent(const browser: ICefBrowser; const event: PCefKeyEvent; + osEvent: TCefEventHandle): Boolean; virtual; + + procedure doOnLoadingStateChange(const browser: ICefBrowser; isLoading, canGoBack, canGoForward: Boolean); virtual; + procedure doOnAddressChange(const browser: ICefBrowser; const frame: ICefFrame; const url: ustring); virtual; + procedure doOnTitleChange(const browser: ICefBrowser; const title: ustring); virtual; + function doOnTooltip(const browser: ICefBrowser; var text: ustring): Boolean; virtual; + procedure doOnStatusMessage(const browser: ICefBrowser; const value: ustring); virtual; + function doOnConsoleMessage(const browser: ICefBrowser; const message, source: ustring; line: Integer): Boolean; virtual; + + procedure doOnBeforeDownload(const browser: ICefBrowser; const downloadItem: ICefDownloadItem; + const suggestedName: ustring; const callback: ICefBeforeDownloadCallback); virtual; + procedure doOnDownloadUpdated(const browser: ICefBrowser; const downloadItem: ICefDownloadItem; + const callback: ICefDownloadItemCallback); virtual; + + procedure doOnRequestGeolocationPermission(const browser: ICefBrowser; + const requestingUrl: ustring; requestId: Integer; const callback: ICefGeolocationCallback); virtual; + procedure doOnCancelGeolocationPermission(const browser: ICefBrowser; + const requestingUrl: ustring; requestId: Integer); virtual; + + function doOnJsdialog(const browser: ICefBrowser; const originUrl, acceptLang: ustring; + dialogType: TCefJsDialogType; const messageText, defaultPromptText: ustring; + callback: ICefJsDialogCallback; out suppressMessage: Boolean): Boolean; virtual; + function doOnBeforeUnloadDialog(const browser: ICefBrowser; + const messageText: ustring; isReload: Boolean; + const callback: ICefJsDialogCallback): Boolean; virtual; + procedure doOnResetDialogState(const browser: ICefBrowser); virtual; + procedure doOnDialogClosed(const browser: ICefBrowser); virtual; + + function doOnBeforePopup(const browser: ICefBrowser; + const frame: ICefFrame; const targetUrl, targetFrameName: ustring; + var popupFeatures: TCefPopupFeatures; var windowInfo: TCefWindowInfo; + var client: ICefClient; var settings: TCefBrowserSettings; + var noJavascriptAccess: Boolean): Boolean; virtual; + procedure doOnAfterCreated(const browser: ICefBrowser); virtual; + procedure doOnBeforeClose(const browser: ICefBrowser); virtual; + function doOnRunModal(const browser: ICefBrowser): Boolean; virtual; + function doOnClose(const browser: ICefBrowser): Boolean; virtual; + + function doOnBeforeBrowse(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest; isRedirect: Boolean): Boolean; virtual; + function doOnBeforeResourceLoad(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest): Boolean; virtual; + function doOnGetResourceHandler(const browser: ICefBrowser; const frame: ICefFrame; + const request: ICefRequest): ICefResourceHandler; virtual; + procedure doOnResourceRedirect(const browser: ICefBrowser; const frame: ICefFrame; + const oldUrl: ustring; var newUrl: ustring); virtual; + function doOnGetAuthCredentials(const browser: ICefBrowser; const frame: ICefFrame; + isProxy: Boolean; const host: ustring; port: Integer; const realm, scheme: ustring; + const callback: ICefAuthCallback): Boolean; virtual; + function doOnQuotaRequest(const browser: ICefBrowser; const originUrl: ustring; + newSize: Int64; const callback: ICefQuotaCallback): Boolean; virtual; + function doOnGetCookieManager: ICefCookieManager; virtual; + procedure doOnProtocolExecution(const browser: ICefBrowser; + const url: ustring; out allowOsExecution: Boolean); virtual; + function doOnBeforePluginLoad(const browser: ICefBrowser; const url, + policyUrl: ustring; const info: ICefWebPluginInfo): Boolean; virtual; + + function doOnFileDialog(const browser: ICefBrowser; mode: TCefFileDialogMode; + const title, defaultFileName: ustring; acceptTypes: TStrings; + const callback: ICefFileDialogCallback): Boolean; + + function doOnGetRootScreenRect(const browser: ICefBrowser; rect: PCefRect): Boolean; + function doOnGetViewRect(const browser: ICefBrowser; rect: PCefRect): Boolean; + function doOnGetScreenPoint(const browser: ICefBrowser; viewX, viewY: Integer; + screenX, screenY: PInteger): Boolean; + function doOnGetScreenInfo(const browser: ICefBrowser; screenInfo: PCefScreenInfo): Boolean; + procedure doOnPopupShow(const browser: ICefBrowser; show: Boolean); + procedure doOnPopupSize(const browser: ICefBrowser; const rect: PCefRect); + procedure doOnPaint(const browser: ICefBrowser; kind: TCefPaintElementType; + dirtyRectsCount: NativeUInt; const dirtyRects: PCefRectArray; + const buffer: Pointer; width, height: Integer); + procedure doOnCursorChange(const browser: ICefBrowser; cursor: TCefCursorHandle); + procedure doOnScrollOffsetChanged(const browser: ICefBrowser); + + function doOnDragEnter(const browser: ICefBrowser; const dragData: ICefDragData; + mask: TCefDragOperations): Boolean; + + property OnProcessMessageReceived: TOnProcessMessageReceived read FOnProcessMessageReceived write FOnProcessMessageReceived; + property OnLoadStart: TOnLoadStart read FOnLoadStart write FOnLoadStart; + property OnLoadEnd: TOnLoadEnd read FOnLoadEnd write FOnLoadEnd; + property OnLoadError: TOnLoadError read FOnLoadError write FOnLoadError; + property OnRenderProcessTerminated: TOnRenderProcessTerminated read FOnRenderProcessTerminated write FOnRenderProcessTerminated; + property OnPluginCrashed: TOnPluginCrashed read FOnPluginCrashed write FOnPluginCrashed; + property OnTakeFocus: TOnTakeFocus read FOnTakeFocus write FOnTakeFocus; + property OnSetFocus: TOnSetFocus read FOnSetFocus write FOnSetFocus; + property OnGotFocus: TOnGotFocus read FOnGotFocus write FOnGotFocus; + property OnBeforeContextMenu: TOnBeforeContextMenu read FOnBeforeContextMenu write FOnBeforeContextMenu; + property OnContextMenuCommand: TOnContextMenuCommand read FOnContextMenuCommand write FOnContextMenuCommand; + property OnContextMenuDismissed: TOnContextMenuDismissed read FOnContextMenuDismissed write FOnContextMenuDismissed; + property OnPreKeyEvent: TOnPreKeyEvent read FOnPreKeyEvent write FOnPreKeyEvent; + property OnKeyEvent: TOnKeyEvent read FOnKeyEvent write FOnKeyEvent; + property OnLoadingStateChange: TOnLoadingStateChange read FOnLoadingStateChange write FOnLoadingStateChange; + property OnAddressChange: TOnAddressChange read FOnAddressChange write FOnAddressChange; + property OnTitleChange: TOnTitleChange read FOnTitleChange write FOnTitleChange; + property OnTooltip: TOnTooltip read FOnTooltip write FOnTooltip; + property OnStatusMessage: TOnStatusMessage read FOnStatusMessage write FOnStatusMessage; + property OnConsoleMessage: TOnConsoleMessage read FOnConsoleMessage write FOnConsoleMessage; + property OnBeforeDownload: TOnBeforeDownload read FOnBeforeDownload write FOnBeforeDownload; + property OnDownloadUpdated: TOnDownloadUpdated read FOnDownloadUpdated write FOnDownloadUpdated; + property OnRequestGeolocationPermission: TOnRequestGeolocationPermission read FOnRequestGeolocationPermission write FOnRequestGeolocationPermission; + property OnCancelGeolocationPermission: TOnCancelGeolocationPermission read FOnCancelGeolocationPermission write FOnCancelGeolocationPermission; + property OnJsdialog: TOnJsdialog read FOnJsdialog write FOnJsdialog; + property OnBeforeUnloadDialog: TOnBeforeUnloadDialog read FOnBeforeUnloadDialog write FOnBeforeUnloadDialog; + property OnResetDialogState: TOnResetDialogState read FOnResetDialogState write FOnResetDialogState; + property OnDialogClosed: TOnDialogClosed read FOnDialogClosed write FOnDialogClosed; + property OnBeforePopup: TOnBeforePopup read FOnBeforePopup write FOnBeforePopup; + property OnAfterCreated: TOnAfterCreated read FOnAfterCreated write FOnAfterCreated; + property OnBeforeClose: TOnBeforeClose read FOnBeforeClose write FOnBeforeClose; + property OnRunModal: TOnRunModal read FOnRunModal write FOnRunModal; + property OnClose: TOnClose read FOnClose write FOnClose; + property OnBeforeBrowse: TOnBeforeBrowse read FOnBeforeBrowse write FOnBeforeBrowse; + property OnBeforeResourceLoad: TOnBeforeResourceLoad read FOnBeforeResourceLoad write FOnBeforeResourceLoad; + property OnGetResourceHandler: TOnGetResourceHandler read FOnGetResourceHandler write FOnGetResourceHandler; + property OnResourceRedirect: TOnResourceRedirect read FOnResourceRedirect write FOnResourceRedirect; + property OnGetAuthCredentials: TOnGetAuthCredentials read FOnGetAuthCredentials write FOnGetAuthCredentials; + property OnQuotaRequest: TOnQuotaRequest read FOnQuotaRequest write FOnQuotaRequest; + property OnGetCookieManager: TOnGetCookieManager read FOnGetCookieManager write FOnGetCookieManager; + property OnProtocolExecution: TOnProtocolExecution read FOnProtocolExecution write FOnProtocolExecution; + property OnBeforePluginLoad: TOnBeforePluginLoad read FOnBeforePluginLoad write FOnBeforePluginLoad; + property OnFileDialog: TOnFileDialog read FOnFileDialog write FOnFileDialog; + property OnGetRootScreenRect: TOnGetRootScreenRect read FOnGetRootScreenRect write FOnGetRootScreenRect; + property OnGetViewRect: TOnGetViewRect read FOnGetViewRect write FOnGetViewRect; + property OnGetScreenPoint: TOnGetScreenPoint read FOnGetScreenPoint write FOnGetScreenPoint; + property OnGetScreenInfo: TOnGetScreenInfo read FOnGetScreenInfo write FOnGetScreenInfo; + property OnPopupShow: TOnPopupShow read FOnPopupShow write FOnPopupShow; + property OnPopupSize: TOnPopupSize read FOnPopupSize write FOnPopupSize; + property OnPaint: TOnPaint read FOnPaint write FOnPaint; + property OnCursorChange: TOnCursorChange read FOnCursorChange write FOnCursorChange; + property OnScrollOffsetChanged: TOnScrollOffsetChanged read FOnScrollOffsetChanged write FOnScrollOffsetChanged; + property OnDragEnter: TOnDragEnter read FOnDragEnter write FOnDragEnter; + + property DefaultUrl: ustring read FDefaultUrl write FDefaultUrl; + property Options: TChromiumOptions read FOptions write FOptions; + property FontOptions: TChromiumFontOptions read FFontOptions; + property DefaultEncoding: ustring read FDefaultEncoding write FDefaultEncoding; + property UserStyleSheetLocation: ustring read FUserStyleSheetLocation write FUserStyleSheetLocation; + property BrowserId: Integer read FBrowserId; + property Browser: ICefBrowser read FBrowser; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure Load(const url: ustring); + procedure ReCreateBrowser(const url: string); + end; + + TChromium = class(TCustomChromium) + public + property BrowserId; + property Browser; + published + property Color; + property Constraints; + property TabStop; + property Align; + property Anchors; + property DefaultUrl; + property TabOrder; + property Visible; + + property OnProcessMessageReceived; + property OnLoadStart; + property OnLoadEnd; + property OnLoadError; + property OnRenderProcessTerminated; + property OnPluginCrashed; + property OnTakeFocus; + property OnSetFocus; + property OnGotFocus; + property OnBeforeContextMenu; + property OnContextMenuCommand; + property OnContextMenuDismissed; + property OnPreKeyEvent; + property OnKeyEvent; + property OnLoadingStateChange; + property OnAddressChange; + property OnTitleChange; + property OnTooltip; + property OnStatusMessage; + property OnConsoleMessage; + property OnBeforeDownload; + property OnDownloadUpdated; + property OnRequestGeolocationPermission; + property OnCancelGeolocationPermission; + property OnJsdialog; + property OnBeforeUnloadDialog; + property OnResetDialogState; + property OnDialogClosed; + property OnBeforePopup; + property OnAfterCreated; + property OnBeforeClose; + property OnRunModal; + property OnClose; + property OnBeforeBrowse; + property OnBeforeResourceLoad; + property OnGetResourceHandler; + property OnResourceRedirect; + property OnGetAuthCredentials; + property OnGetCookieManager; + property OnProtocolExecution; + property OnFileDialog; + property OnDragEnter; + + property Options; + property FontOptions; + property DefaultEncoding; + property UserStyleSheetLocation; + end; + + TChromiumOSR = class(TCustomChromiumOSR) + public + property BrowserId; + property Browser; + published + property DefaultUrl; + + property OnProcessMessageReceived; + property OnLoadStart; + property OnLoadEnd; + property OnLoadError; + property OnRenderProcessTerminated; + property OnPluginCrashed; + property OnTakeFocus; + property OnSetFocus; + property OnGotFocus; + property OnBeforeContextMenu; + property OnContextMenuCommand; + property OnContextMenuDismissed; + property OnPreKeyEvent; + property OnKeyEvent; + property OnLoadingStateChange; + property OnAddressChange; + property OnTitleChange; + property OnTooltip; + property OnStatusMessage; + property OnConsoleMessage; + property OnBeforeDownload; + property OnDownloadUpdated; + property OnRequestGeolocationPermission; + property OnCancelGeolocationPermission; + property OnJsdialog; + property OnBeforeUnloadDialog; + property OnResetDialogState; + property OnDialogClosed; + property OnBeforePopup; + property OnAfterCreated; + property OnBeforeClose; + property OnRunModal; + property OnClose; + property OnBeforeBrowse; + property OnBeforeResourceLoad; + property OnGetResourceHandler; + property OnResourceRedirect; + property OnGetAuthCredentials; + property OnGetCookieManager; + property OnProtocolExecution; + property OnFileDialog; + property OnGetRootScreenRect; + property OnGetViewRect; + property OnGetScreenPoint; + property OnPopupShow; + property OnPopupSize; + property OnPaint; + property OnCursorChange; + property OnScrollOffsetChanged; + property OnDragEnter; + + property Options; + property FontOptions; + property DefaultEncoding; + property UserStyleSheetLocation; + end; + + implementation +{$IFNDEF CEF_MULTI_THREADED_MESSAGE_LOOP} + uses +{$IFDEF DELPHI16_UP} + Vcl.AppEvnts; +{$ELSE} + AppEvnts; +{$ENDIF} + +var + CefInstances: Integer = 0; + CefTimer: UINT = 0; +{$ENDIF} + +type + TVCLClientHandler = class(TCustomClientHandler) + public + constructor Create(const crm: IChromiumEvents; renderer: Boolean); override; + destructor Destroy; override; + end; + +{ TVCLClientHandler } + +{$IFNDEF CEF_MULTI_THREADED_MESSAGE_LOOP} +var + looping: Boolean = False; + +procedure TimerProc(hwnd: HWND; uMsg: UINT; idEvent: Pointer; dwTime: DWORD); stdcall; +begin + if looping then Exit; + if CefInstances > 0 then + begin + looping := True; + try + CefDoMessageLoopWork; + finally + looping := False; + end; + end; +end; +{$ENDIF} + +constructor TVCLClientHandler.Create(const crm: IChromiumEvents; renderer: Boolean); +begin + inherited Create(crm, renderer); +{$IFNDEF CEF_MULTI_THREADED_MESSAGE_LOOP} + if CefInstances = 0 then + CefTimer := SetTimer(0, 0, 10, @TimerProc); + InterlockedIncrement(CefInstances); +{$ENDIF} +end; + +destructor TVCLClientHandler.Destroy; +begin +{$IFNDEF CEF_MULTI_THREADED_MESSAGE_LOOP} + InterlockedDecrement(CefInstances); + if CefInstances = 0 then + KillTimer(0, CefTimer); +{$ENDIF} + inherited; +end; + +{ TCustomChromium } + +constructor TCustomChromium.Create(AOwner: TComponent); +begin + inherited; + FDefaultUrl := 'about:blank'; + + if not (csDesigning in ComponentState) then + FHandler := TVCLClientHandler.Create(Self, False); + + FOptions := TChromiumOptions.Create; + FFontOptions := TChromiumFontOptions.Create; + + FUserStyleSheetLocation := ''; + FDefaultEncoding := ''; + FBrowserId := 0; + FBrowser := nil; +end; + +procedure TCustomChromium.CreateBrowser; +var + info: TCefWindowInfo; + settings: TCefBrowserSettings; + rect: TRect; +begin + if not (csDesigning in ComponentState) then + begin + FillChar(info, SizeOf(info), 0); + rect := GetClientRect; + info.Style := WS_CHILD or WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or WS_TABSTOP; + info.parent_window := Handle; + info.x := rect.left; + info.y := rect.top; + info.Width := rect.right - rect.left; + info.Height := rect.bottom - rect.top; + FillChar(settings, SizeOf(TCefBrowserSettings), 0); + settings.size := SizeOf(TCefBrowserSettings); + GetSettings(settings); +{$IFDEF CEF_MULTI_THREADED_MESSAGE_LOOP} + CefBrowserHostCreate(@info, FHandler, FDefaultUrl, @settings, + TCefRequestContextRef.CreateContext((FHandler as ICefClientHandler).GetRequestContextHandler)); +{$ELSE} + CefLoadLibDefault; + FBrowser := CefBrowserHostCreateSync(@info, FHandler, '', @settings, + TCefRequestContextRef.CreateContext((FHandler as ICefClientHandler).GetRequestContextHandler)); + FBrowserId := FBrowser.Identifier; +{$ENDIF} + end; +end; + +procedure TCustomChromium.CreateWindowHandle(const Params: TCreateParams); +begin + inherited; + CreateBrowser; +end; + +destructor TCustomChromium.Destroy; +begin + if FBrowser <> nil then + begin + FBrowser.StopLoad; + FBrowser.Host.ParentWindowWillClose; + end; + if FHandler <> nil then + (FHandler as ICefClientHandler).Disconnect; + FHandler := nil; + FBrowser := nil; + FFontOptions.Free; + FOptions.Free; + inherited; +end; + +procedure TCustomChromium.GetSettings(var settings: TCefBrowserSettings); +begin + Assert(settings.size >= SizeOf(settings)); + settings.standard_font_family := CefString(FFontOptions.StandardFontFamily); + settings.fixed_font_family := CefString(FFontOptions.FixedFontFamily); + settings.serif_font_family := CefString(FFontOptions.SerifFontFamily); + settings.sans_serif_font_family := CefString(FFontOptions.SansSerifFontFamily); + settings.cursive_font_family := CefString(FFontOptions.CursiveFontFamily); + settings.fantasy_font_family := CefString(FFontOptions.FantasyFontFamily); + settings.default_font_size := FFontOptions.DefaultFontSize; + settings.default_fixed_font_size := FFontOptions.DefaultFixedFontSize; + settings.minimum_font_size := FFontOptions.MinimumFontSize; + settings.minimum_logical_font_size := FFontOptions.MinimumLogicalFontSize; + settings.remote_fonts := FFontOptions.RemoteFonts; + settings.default_encoding := CefString(DefaultEncoding); + settings.user_style_sheet_location := CefString(UserStyleSheetLocation); + + settings.javascript := FOptions.Javascript; + settings.javascript_open_windows := FOptions.JavascriptOpenWindows; + settings.javascript_close_windows := FOptions.JavascriptCloseWindows; + settings.javascript_access_clipboard := FOptions.JavascriptAccessClipboard; + settings.javascript_dom_paste := FOptions.JavascriptDomPaste; + settings.caret_browsing := FOptions.CaretBrowsing; + settings.java := FOptions.Java; + settings.plugins := FOptions.Plugins; + settings.universal_access_from_file_urls := FOptions.UniversalAccessFromFileUrls; + settings.file_access_from_file_urls := FOptions.FileAccessFromFileUrls; + settings.web_security := FOptions.WebSecurity; + settings.image_loading := FOptions.ImageLoading; + settings.image_shrink_standalone_to_fit := FOptions.ImageShrinkStandaloneToFit; + settings.text_area_resize := FOptions.TextAreaResize; + settings.tab_to_links := FOptions.TabToLinks; + settings.author_and_user_styles := FOptions.AuthorAndUserStyles; + settings.local_storage := FOptions.LocalStorage; + settings.databases := FOptions.Databases; + settings.application_cache := FOptions.ApplicationCache; + settings.webgl := FOptions.Webgl; + settings.accelerated_compositing := FOptions.AcceleratedCompositing; +end; + +procedure TCustomChromium.Load(const url: ustring); +var + frm: ICefFrame; +begin + HandleNeeded; + if FBrowser <> nil then + begin + frm := FBrowser.MainFrame; + if frm <> nil then + frm.LoadUrl(url); + end; +end; + +procedure TCustomChromium.Loaded; +begin + inherited; + Load(FDefaultUrl); +end; + +procedure TCustomChromium.ReCreateBrowser(const url: string); +begin + if (FBrowser <> nil) and (FBrowserId <> 0) then + begin + FBrowser.Host.ParentWindowWillClose; + SendMessage(FBrowser.Host.WindowHandle, WM_CLOSE, 0, 0); + SendMessage(FBrowser.Host.WindowHandle, WM_DESTROY, 0, 0); + FBrowserId := 0; + FBrowser := nil; + + CreateBrowser; + Load(url); + end; +end; + +procedure TCustomChromium.Resize; +var + brws: ICefBrowser; + rect: TRect; + hdwp: THandle; +begin + inherited; + if not (csDesigning in ComponentState) then + begin + brws := FBrowser; + if (brws <> nil) and (brws.Host.WindowHandle <> INVALID_HANDLE_VALUE) then + begin + rect := GetClientRect; + hdwp := BeginDeferWindowPos(1); + try + hdwp := DeferWindowPos(hdwp, brws.Host.WindowHandle, 0, + rect.left, rect.top, rect.right - rect.left, rect.bottom - rect.top, + SWP_NOZORDER); + finally + EndDeferWindowPos(hdwp); + end; + end; + end; +end; + +procedure TCustomChromium.WndProc(var Message: TMessage); +begin + case Message.Msg of + WM_SETFOCUS: + begin + if (FBrowser <> nil) and (FBrowser.Host.WindowHandle <> 0) then + PostMessage(FBrowser.Host.WindowHandle, WM_SETFOCUS, Message.WParam, 0); + inherited WndProc(Message); + end; + WM_ERASEBKGND: + if (csDesigning in ComponentState) or (FBrowser = nil) then + inherited WndProc(Message); + CM_WANTSPECIALKEY: + if not (TWMKey(Message).CharCode in [VK_LEFT .. VK_DOWN]) then + Message.Result := 1 else + inherited WndProc(Message); + WM_GETDLGCODE: + Message.Result := DLGC_WANTARROWS or DLGC_WANTCHARS; + else + inherited WndProc(Message); + end; +end; + +function TCustomChromium.doOnClose(const browser: ICefBrowser): Boolean; +begin + Result := False; + if Assigned(FOnClose) then + FOnClose(Self, browser, Result); +end; + +procedure TCustomChromium.doOnAddressChange(const browser: ICefBrowser; + const frame: ICefFrame; const url: ustring); +begin + if Assigned(FOnAddressChange) then + FOnAddressChange(Self, browser, frame, url); +end; + +procedure TCustomChromium.doOnAfterCreated(const browser: ICefBrowser); +begin + if Assigned(FOnAfterCreated) then + FOnAfterCreated(Self, browser); +end; + +procedure TCustomChromium.doOnBeforeClose(const browser: ICefBrowser); +begin + if Assigned(FOnBeforeClose) then + FOnBeforeClose(Self, browser); +end; + +procedure TCustomChromium.doOnBeforeContextMenu(const browser: ICefBrowser; + const frame: ICefFrame; const params: ICefContextMenuParams; + const model: ICefMenuModel); +begin + if Assigned(FOnBeforeContextMenu) then + FOnBeforeContextMenu(Self, browser, frame, params, model); +end; + +procedure TCustomChromium.doOnBeforeDownload(const browser: ICefBrowser; + const downloadItem: ICefDownloadItem; const suggestedName: ustring; + const callback: ICefBeforeDownloadCallback); +begin + if Assigned(FOnBeforeDownload) then + FOnBeforeDownload(Self, browser, downloadItem, suggestedName, callback); +end; + +function TCustomChromium.doOnBeforePluginLoad(const browser: ICefBrowser; + const url, policyUrl: ustring; const info: ICefWebPluginInfo): Boolean; +begin + Result := False; + if Assigned(FOnBeforePluginLoad) then + FOnBeforePluginLoad(Self, browser, url, policyUrl, info, Result); +end; + +function TCustomChromium.doOnBeforePopup(const browser: ICefBrowser; + const frame: ICefFrame; const targetUrl, targetFrameName: ustring; + var popupFeatures: TCefPopupFeatures; var windowInfo: TCefWindowInfo; + var client: ICefClient; var settings: TCefBrowserSettings; + var noJavascriptAccess: Boolean): Boolean; +begin + Result := False; + if Assigned(FOnBeforePopup) then + FOnBeforePopup(Self, browser, frame, targetUrl, targetFrameName, popupFeatures, + windowInfo, client, settings, noJavascriptAccess, Result); +end; + +function TCustomChromium.doOnBeforeBrowse(const browser: ICefBrowser; + const frame: ICefFrame; const request: ICefRequest; isRedirect: Boolean): Boolean; +begin + Result := False; + if Assigned(FOnBeforeBrowse) then + FOnBeforeBrowse(Self, browser, frame, request, isRedirect, Result); +end; + +function TCustomChromium.doOnBeforeResourceLoad(const browser: ICefBrowser; + const frame: ICefFrame; const request: ICefRequest): Boolean; +begin + Result := False; + if Assigned(FOnBeforeResourceLoad) then + FOnBeforeResourceLoad(Self, browser, frame, request, Result); +end; + +function TCustomChromium.doOnBeforeUnloadDialog(const browser: ICefBrowser; + const messageText: ustring; isReload: Boolean; + const callback: ICefJsDialogCallback): Boolean; +begin + Result := False; + if Assigned(FOnBeforeUnloadDialog) then + FOnBeforeUnloadDialog(Self, browser, messageText, isReload, callback, Result); +end; + +procedure TCustomChromium.doOnCancelGeolocationPermission( + const browser: ICefBrowser; const requestingUrl: ustring; requestId: Integer); +begin + if Assigned(FOnCancelGeolocationPermission) then + FOnCancelGeolocationPermission(Self, browser, requestingUrl, requestId); +end; + +function TCustomChromium.doOnConsoleMessage(const browser: ICefBrowser; + const message, source: ustring; line: Integer): Boolean; +begin + Result := False; + if Assigned(FOnConsoleMessage) then + FOnConsoleMessage(Self, browser, message, source, line, Result); +end; + +function TCustomChromium.doOnContextMenuCommand(const browser: ICefBrowser; + const frame: ICefFrame; const params: ICefContextMenuParams; + commandId: Integer; eventFlags: TCefEventFlags): Boolean; +begin + Result := False; + if Assigned(FOnContextMenuCommand) then + FOnContextMenuCommand(Self, browser, frame, params, commandId, eventFlags, Result); +end; + +procedure TCustomChromium.doOnContextMenuDismissed(const browser: ICefBrowser; + const frame: ICefFrame); +begin + if Assigned(FOnContextMenuDismissed) then + FOnContextMenuDismissed(Self, browser, frame); +end; + +procedure TCustomChromium.doOnCursorChange(const browser: ICefBrowser; + cursor: TCefCursorHandle); +begin + +end; + +procedure TCustomChromium.doOnDialogClosed(const browser: ICefBrowser); +begin + if Assigned(FOnDialogClosed) then + FOnDialogClosed(Self, browser); +end; + +procedure TCustomChromium.doOnDownloadUpdated(const browser: ICefBrowser; + const downloadItem: ICefDownloadItem; + const callback: ICefDownloadItemCallback); +begin + if Assigned(FOnDownloadUpdated) then + FOnDownloadUpdated(Self, browser, downloadItem, callback); +end; + +function TCustomChromium.doOnDragEnter(const browser: ICefBrowser; + const dragData: ICefDragData; mask: TCefDragOperations): Boolean; +begin + Result := False; + if Assigned(FOnDragEnter) then + FOnDragEnter(Self, browser, dragData, mask, Result); +end; + +function TCustomChromium.doOnFileDialog(const browser: ICefBrowser; + mode: TCefFileDialogMode; const title, defaultFileName: ustring; + acceptTypes: TStrings; const callback: ICefFileDialogCallback): Boolean; +begin + Result := False; + if Assigned(FOnFileDialog) then + FOnFileDialog(Self, browser, mode, title, defaultFileName, acceptTypes, + callback, Result); +end; + +function TCustomChromium.doOnGetAuthCredentials(const browser: ICefBrowser; + const frame: ICefFrame; isProxy: Boolean; const host: ustring; port: Integer; + const realm, scheme: ustring; const callback: ICefAuthCallback): Boolean; +begin + Result := False; + if Assigned(FOnGetAuthCredentials) then + FOnGetAuthCredentials(Self, browser, frame, isProxy, host, + port, realm, scheme, callback, Result); +end; + +function TCustomChromium.doOnGetCookieManager: ICefCookieManager; +begin + if Assigned(FOnGetCookieManager) then + FOnGetCookieManager(Self, Result) else + Result := nil; +end; + +function TCustomChromium.doOnGetResourceHandler(const browser: ICefBrowser; + const frame: ICefFrame; const request: ICefRequest): ICefResourceHandler; +begin + if Assigned(FOnGetResourceHandler) then + FOnGetResourceHandler(Self, browser, frame, request, Result) else + Result := nil; +end; + +function TCustomChromium.doOnGetRootScreenRect(const browser: ICefBrowser; + rect: PCefRect): Boolean; +begin + Result := False; +end; + +function TCustomChromium.doOnGetScreenInfo(const browser: ICefBrowser; + screenInfo: PCefScreenInfo): Boolean; +begin + Result := False; +end; + +function TCustomChromium.doOnGetScreenPoint(const browser: ICefBrowser; viewX, + viewY: Integer; screenX, screenY: PInteger): Boolean; +begin + Result := False; +end; + +function TCustomChromium.doOnGetViewRect(const browser: ICefBrowser; + rect: PCefRect): Boolean; +begin + Result := False; +end; + +procedure TCustomChromium.doOnGotFocus(const browser: ICefBrowser); +begin + if Assigned(FOnGotFocus) then + FOnGotFocus(Self, browser) +end; + +function TCustomChromium.doOnJsdialog(const browser: ICefBrowser; + const originUrl, acceptLang: ustring; dialogType: TCefJsDialogType; + const messageText, defaultPromptText: ustring; callback: ICefJsDialogCallback; + out suppressMessage: Boolean): Boolean; +begin + Result := False; + if Assigned(FOnJsdialog) then + FOnJsdialog(Self, browser, originUrl, acceptLang, dialogType, + messageText, defaultPromptText, callback, suppressMessage, Result); +end; + +function TCustomChromium.doOnKeyEvent(const browser: ICefBrowser; + const event: PCefKeyEvent; osEvent: TCefEventHandle): Boolean; +begin + Result := False; + if Assigned(FOnKeyEvent) then + FOnKeyEvent(Self, browser, event, osEvent, Result); +end; + +procedure TCustomChromium.doOnLoadEnd(const browser: ICefBrowser; + const frame: ICefFrame; httpStatusCode: Integer); +begin + if Assigned(FOnLoadEnd) then + FOnLoadEnd(Self, browser, frame, httpStatusCode); +end; + +procedure TCustomChromium.doOnLoadError(const browser: ICefBrowser; + const frame: ICefFrame; errorCode: Integer; const errorText, + failedUrl: ustring); +begin + if Assigned(FOnLoadError) then + FOnLoadError(Self, browser, frame, errorCode, errorText, failedUrl); +end; + +procedure TCustomChromium.doOnLoadingStateChange(const browser: ICefBrowser; + isLoading, canGoBack, canGoForward: Boolean); +begin + if Assigned(FOnLoadingStateChange) then + FOnLoadingStateChange(Self, browser, isLoading, canGoBack, canGoForward); +end; + +procedure TCustomChromium.doOnLoadStart(const browser: ICefBrowser; + const frame: ICefFrame); +begin + if Assigned(FOnLoadStart) then + FOnLoadStart(Self, browser, frame); +end; + +procedure TCustomChromium.doOnPaint(const browser: ICefBrowser; + kind: TCefPaintElementType; dirtyRectsCount: NativeUInt; + const dirtyRects: PCefRectArray; const buffer: Pointer; width, height: Integer); +begin + +end; + +procedure TCustomChromium.doOnPluginCrashed(const browser: ICefBrowser; + const pluginPath: ustring); +begin + if Assigned(FOnPluginCrashed) then + FOnPluginCrashed(Self, browser, pluginPath); +end; + +procedure TCustomChromium.doOnPopupShow(const browser: ICefBrowser; + show: Boolean); +begin + +end; + +procedure TCustomChromium.doOnPopupSize(const browser: ICefBrowser; + const rect: PCefRect); +begin + +end; + +function TCustomChromium.doOnPreKeyEvent(const browser: ICefBrowser; + const event: PCefKeyEvent; osEvent: TCefEventHandle; + out isKeyboardShortcut: Boolean): Boolean; +begin + Result := False; + if Assigned(FOnPreKeyEvent) then + FOnPreKeyEvent(Self, browser, event, osEvent, isKeyboardShortcut, Result); +end; + +function TCustomChromium.doOnProcessMessageReceived(const browser: ICefBrowser; + sourceProcess: TCefProcessId; const message: ICefProcessMessage): Boolean; +begin + Result := False; + if Assigned(FOnProcessMessageReceived) then + FOnProcessMessageReceived(Self, browser, sourceProcess, message, Result); +end; + +procedure TCustomChromium.doOnProtocolExecution(const browser: ICefBrowser; + const url: ustring; out allowOsExecution: Boolean); +begin + if Assigned(FOnProtocolExecution) then + FOnProtocolExecution(Self, browser, url, allowOsExecution); +end; + +function TCustomChromium.doOnQuotaRequest(const browser: ICefBrowser; + const originUrl: ustring; newSize: Int64; + const callback: ICefQuotaCallback): Boolean; +begin + Result := False; + if Assigned(FOnQuotaRequest) then + FOnQuotaRequest(Self, browser, originUrl, newSize, callback, Result); +end; + +procedure TCustomChromium.doOnRenderProcessTerminated(const browser: ICefBrowser; + status: TCefTerminationStatus); +begin + if Assigned(FOnRenderProcessTerminated) then + FOnRenderProcessTerminated(Self, browser, status); +end; + +procedure TCustomChromium.doOnRequestGeolocationPermission( + const browser: ICefBrowser; const requestingUrl: ustring; requestId: Integer; + const callback: ICefGeolocationCallback); +begin + if Assigned(FOnRequestGeolocationPermission) then + FOnRequestGeolocationPermission(Self, browser, requestingUrl, requestId, callback); +end; + +procedure TCustomChromium.doOnResetDialogState(const browser: ICefBrowser); +begin + if Assigned(FOnResetDialogState) then + FOnResetDialogState(Self, browser); +end; + +procedure TCustomChromium.doOnResourceRedirect(const browser: ICefBrowser; + const frame: ICefFrame; const oldUrl: ustring; var newUrl: ustring); +begin + if Assigned(FOnResourceRedirect) then + FOnResourceRedirect(Self, browser, frame, oldUrl, newUrl); +end; + +procedure TCustomChromium.doOnScrollOffsetChanged(const browser: ICefBrowser); +begin + +end; + +function TCustomChromium.doOnSetFocus(const browser: ICefBrowser; + source: TCefFocusSource): Boolean; +begin + Result := False; + if Assigned(FOnSetFocus) then + FOnSetFocus(Self, browser, source, Result); +end; + +procedure TCustomChromium.doOnStatusMessage(const browser: ICefBrowser; + const value: ustring); +begin + if Assigned(FOnStatusMessage) then + FOnStatusMessage(Self, browser, value); +end; + +procedure TCustomChromium.doOnTakeFocus(const browser: ICefBrowser; + next: Boolean); +begin + if Assigned(FOnTakeFocus) then + FOnTakeFocus(Self, browser, next); +end; + +procedure TCustomChromium.doOnTitleChange(const browser: ICefBrowser; + const title: ustring); +begin + if Assigned(FOnTitleChange) then + FOnTitleChange(Self, browser, title); +end; + +function TCustomChromium.doOnTooltip(const browser: ICefBrowser; + var text: ustring): Boolean; +begin + Result := False; + if Assigned(FOnTooltip) then + FOnTooltip(Self, browser, text, Result); +end; + +function TCustomChromium.doOnRunModal(const browser: ICefBrowser): Boolean; +begin + Result := False; + if Assigned(FOnRunModal) then + FOnRunModal(Self, browser, Result); +end; + +{ TCustomChromiumOSR } + +constructor TCustomChromiumOSR.Create(AOwner: TComponent); +begin + inherited; + FDefaultUrl := 'about:blank'; + + if not (csDesigning in ComponentState) then + FHandler := TVCLClientHandler.Create(Self, True); + + FOptions := TChromiumOptions.Create; + FFontOptions := TChromiumFontOptions.Create; + + FUserStyleSheetLocation := ''; + FDefaultEncoding := ''; + FBrowserId := 0; + FBrowser := nil; +end; + +procedure TCustomChromiumOSR.CreateBrowser; +var + info: TCefWindowInfo; + settings: TCefBrowserSettings; +begin + if not (csDesigning in ComponentState) then + begin + FillChar(info, SizeOf(info), 0); + info.window_rendering_disabled := True; + FillChar(settings, SizeOf(TCefBrowserSettings), 0); + settings.size := SizeOf(TCefBrowserSettings); + GetSettings(settings); +{$IFDEF CEF_MULTI_THREADED_MESSAGE_LOOP} + CefBrowserHostCreate(@info, FHandler, FDefaultUrl, @settings); +{$ELSE} + FBrowser := CefBrowserHostCreateSync(@info, FHandler, '', @settings); + FBrowserId := FBrowser.Identifier; +{$ENDIF} + end; +end; + +destructor TCustomChromiumOSR.Destroy; +begin + if FBrowser <> nil then + FBrowser.Host.ParentWindowWillClose; + if FHandler <> nil then + (FHandler as ICefClientHandler).Disconnect; + FHandler := nil; + FBrowser := nil; + FFontOptions.Free; + FOptions.Free; + inherited; +end; + +procedure TCustomChromiumOSR.GetSettings(var settings: TCefBrowserSettings); +begin + Assert(settings.size >= SizeOf(settings)); + settings.standard_font_family := CefString(FFontOptions.StandardFontFamily); + settings.fixed_font_family := CefString(FFontOptions.FixedFontFamily); + settings.serif_font_family := CefString(FFontOptions.SerifFontFamily); + settings.sans_serif_font_family := CefString(FFontOptions.SansSerifFontFamily); + settings.cursive_font_family := CefString(FFontOptions.CursiveFontFamily); + settings.fantasy_font_family := CefString(FFontOptions.FantasyFontFamily); + settings.default_font_size := FFontOptions.DefaultFontSize; + settings.default_fixed_font_size := FFontOptions.DefaultFixedFontSize; + settings.minimum_font_size := FFontOptions.MinimumFontSize; + settings.minimum_logical_font_size := FFontOptions.MinimumLogicalFontSize; + settings.remote_fonts := FFontOptions.RemoteFonts; + settings.default_encoding := CefString(DefaultEncoding); + settings.user_style_sheet_location := CefString(UserStyleSheetLocation); + + settings.javascript := FOptions.Javascript; + settings.javascript_open_windows := FOptions.JavascriptOpenWindows; + settings.javascript_close_windows := FOptions.JavascriptCloseWindows; + settings.javascript_access_clipboard := FOptions.JavascriptAccessClipboard; + settings.javascript_dom_paste := FOptions.JavascriptDomPaste; + settings.caret_browsing := FOptions.CaretBrowsing; + settings.java := FOptions.Java; + settings.plugins := FOptions.Plugins; + settings.universal_access_from_file_urls := FOptions.UniversalAccessFromFileUrls; + settings.file_access_from_file_urls := FOptions.FileAccessFromFileUrls; + settings.web_security := FOptions.WebSecurity; + settings.image_loading := FOptions.ImageLoading; + settings.image_shrink_standalone_to_fit := FOptions.ImageShrinkStandaloneToFit; + settings.text_area_resize := FOptions.TextAreaResize; + settings.tab_to_links := FOptions.TabToLinks; + settings.author_and_user_styles := FOptions.AuthorAndUserStyles; + settings.local_storage := FOptions.LocalStorage; + settings.databases := FOptions.Databases; + settings.application_cache := FOptions.ApplicationCache; + settings.webgl := FOptions.Webgl; + settings.accelerated_compositing := FOptions.AcceleratedCompositing; +end; + +procedure TCustomChromiumOSR.Load(const url: ustring); +var + frm: ICefFrame; +begin + if FBrowser <> nil then + begin + frm := FBrowser.MainFrame; + if frm <> nil then + frm.LoadUrl(url); + end; +end; + +procedure TCustomChromiumOSR.Loaded; +begin + inherited; + CreateBrowser; + Load(FDefaultUrl); +end; + +procedure TCustomChromiumOSR.ReCreateBrowser(const url: string); +begin + if (FBrowser <> nil) and (FBrowserId <> 0) then + begin + FBrowser.Host.ParentWindowWillClose; + SendMessage(FBrowser.Host.WindowHandle, WM_CLOSE, 0, 0); + SendMessage(FBrowser.Host.WindowHandle, WM_DESTROY, 0, 0); + FBrowserId := 0; + FBrowser := nil; + + CreateBrowser; + Load(url); + end; +end; + +function TCustomChromiumOSR.doOnClose(const browser: ICefBrowser): Boolean; +begin + Result := False; + if Assigned(FOnClose) then + FOnClose(Self, browser, Result); +end; + +procedure TCustomChromiumOSR.doOnAddressChange(const browser: ICefBrowser; + const frame: ICefFrame; const url: ustring); +begin + if Assigned(FOnAddressChange) then + FOnAddressChange(Self, browser, frame, url); +end; + +procedure TCustomChromiumOSR.doOnAfterCreated(const browser: ICefBrowser); +begin + if Assigned(FOnAfterCreated) then + FOnAfterCreated(Self, browser); +end; + +procedure TCustomChromiumOSR.doOnBeforeClose(const browser: ICefBrowser); +begin + if Assigned(FOnBeforeClose) then + FOnBeforeClose(Self, browser); +end; + +procedure TCustomChromiumOSR.doOnBeforeContextMenu(const browser: ICefBrowser; + const frame: ICefFrame; const params: ICefContextMenuParams; + const model: ICefMenuModel); +begin + if Assigned(FOnBeforeContextMenu) then + FOnBeforeContextMenu(Self, browser, frame, params, model); +end; + +procedure TCustomChromiumOSR.doOnBeforeDownload(const browser: ICefBrowser; + const downloadItem: ICefDownloadItem; const suggestedName: ustring; + const callback: ICefBeforeDownloadCallback); +begin + if Assigned(FOnBeforeDownload) then + FOnBeforeDownload(Self, browser, downloadItem, suggestedName, callback); +end; + +function TCustomChromiumOSR.doOnBeforePluginLoad(const browser: ICefBrowser; + const url, policyUrl: ustring; const info: ICefWebPluginInfo): Boolean; +begin + Result := False; + if Assigned(FOnBeforePluginLoad) then + FOnBeforePluginLoad(Self, browser, url, policyUrl, info, Result); +end; + +function TCustomChromiumOSR.doOnBeforePopup(const browser: ICefBrowser; + const frame: ICefFrame; const targetUrl, targetFrameName: ustring; + var popupFeatures: TCefPopupFeatures; var windowInfo: TCefWindowInfo; + var client: ICefClient; var settings: TCefBrowserSettings; + var noJavascriptAccess: Boolean): Boolean; +begin + Result := False; + if Assigned(FOnBeforePopup) then + FOnBeforePopup(Self, browser, frame, targetUrl, targetFrameName, popupFeatures, + windowInfo, client, settings, noJavascriptAccess, Result); +end; + +function TCustomChromiumOSR.doOnBeforeBrowse(const browser: ICefBrowser; + const frame: ICefFrame; const request: ICefRequest; isRedirect: Boolean): Boolean; +begin + Result := False; + if Assigned(FOnBeforeBrowse) then + FOnBeforeBrowse(Self, browser, frame, request, isRedirect, Result); +end; + +function TCustomChromiumOSR.doOnBeforeResourceLoad(const browser: ICefBrowser; + const frame: ICefFrame; const request: ICefRequest): Boolean; +begin + Result := False; + if Assigned(FOnBeforeResourceLoad) then + FOnBeforeResourceLoad(Self, browser, frame, request, Result); +end; + +function TCustomChromiumOSR.doOnBeforeUnloadDialog(const browser: ICefBrowser; + const messageText: ustring; isReload: Boolean; + const callback: ICefJsDialogCallback): Boolean; +begin + Result := False; + if Assigned(FOnBeforeUnloadDialog) then + FOnBeforeUnloadDialog(Self, browser, messageText, isReload, callback, Result); +end; + +procedure TCustomChromiumOSR.doOnCancelGeolocationPermission( + const browser: ICefBrowser; const requestingUrl: ustring; requestId: Integer); +begin + if Assigned(FOnCancelGeolocationPermission) then + FOnCancelGeolocationPermission(Self, browser, requestingUrl, requestId); +end; + +function TCustomChromiumOSR.doOnConsoleMessage(const browser: ICefBrowser; + const message, source: ustring; line: Integer): Boolean; +begin + Result := False; + if Assigned(FOnConsoleMessage) then + FOnConsoleMessage(Self, browser, message, source, line, Result); +end; + +function TCustomChromiumOSR.doOnContextMenuCommand(const browser: ICefBrowser; + const frame: ICefFrame; const params: ICefContextMenuParams; + commandId: Integer; eventFlags: TCefEventFlags): Boolean; +begin + Result := False; + if Assigned(FOnContextMenuCommand) then + FOnContextMenuCommand(Self, browser, frame, params, commandId, eventFlags, Result); +end; + +procedure TCustomChromiumOSR.doOnContextMenuDismissed(const browser: ICefBrowser; + const frame: ICefFrame); +begin + if Assigned(FOnContextMenuDismissed) then + FOnContextMenuDismissed(Self, browser, frame); +end; + +procedure TCustomChromiumOSR.doOnCursorChange(const browser: ICefBrowser; + cursor: TCefCursorHandle); +begin + if Assigned(FOnCursorChange) then + FOnCursorChange(Self, browser, cursor); +end; + +procedure TCustomChromiumOSR.doOnDialogClosed(const browser: ICefBrowser); +begin + if Assigned(FOnDialogClosed) then + FOnDialogClosed(Self, browser); +end; + +procedure TCustomChromiumOSR.doOnDownloadUpdated(const browser: ICefBrowser; + const downloadItem: ICefDownloadItem; + const callback: ICefDownloadItemCallback); +begin + if Assigned(FOnDownloadUpdated) then + FOnDownloadUpdated(Self, browser, downloadItem, callback); +end; + +function TCustomChromiumOSR.doOnDragEnter(const browser: ICefBrowser; + const dragData: ICefDragData; mask: TCefDragOperations): Boolean; +begin + Result := False; + if Assigned(FOnDragEnter) then + FOnDragEnter(Self, browser, dragData, mask, Result); +end; + +function TCustomChromiumOSR.doOnFileDialog(const browser: ICefBrowser; + mode: TCefFileDialogMode; const title, defaultFileName: ustring; + acceptTypes: TStrings; const callback: ICefFileDialogCallback): Boolean; +begin + Result := False; + if Assigned(FOnFileDialog) then + FOnFileDialog(Self, browser, mode, title, defaultFileName, acceptTypes, + callback, Result); +end; + +function TCustomChromiumOSR.doOnGetAuthCredentials(const browser: ICefBrowser; + const frame: ICefFrame; isProxy: Boolean; const host: ustring; port: Integer; + const realm, scheme: ustring; const callback: ICefAuthCallback): Boolean; +begin + Result := False; + if Assigned(FOnGetAuthCredentials) then + FOnGetAuthCredentials(Self, browser, frame, isProxy, host, + port, realm, scheme, callback, Result); +end; + +function TCustomChromiumOSR.doOnGetCookieManager: ICefCookieManager; +begin + if Assigned(FOnGetCookieManager) then + FOnGetCookieManager(Self, Result) else + Result := nil; +end; + +function TCustomChromiumOSR.doOnGetResourceHandler(const browser: ICefBrowser; + const frame: ICefFrame; const request: ICefRequest): ICefResourceHandler; +begin + if Assigned(FOnGetResourceHandler) then + FOnGetResourceHandler(Self, browser, frame, request, Result) else + Result := nil; +end; + +function TCustomChromiumOSR.doOnGetRootScreenRect(const browser: ICefBrowser; + rect: PCefRect): Boolean; +begin + Result := False; + if Assigned(FOnGetRootScreenRect) then + FOnGetRootScreenRect(Self, browser, rect, Result); +end; + +function TCustomChromiumOSR.doOnGetScreenInfo(const browser: ICefBrowser; + screenInfo: PCefScreenInfo): Boolean; +begin + Result := False; + if Assigned(FOnGetScreenInfo) then + FOnGetScreenInfo(Self, browser, screenInfo, Result); +end; + +function TCustomChromiumOSR.doOnGetScreenPoint(const browser: ICefBrowser; viewX, + viewY: Integer; screenX, screenY: PInteger): Boolean; +begin + Result := False; + if Assigned(FOnGetScreenPoint) then + FOnGetScreenPoint(Self, browser, viewX, viewY, screenX, screenY, Result); +end; + +function TCustomChromiumOSR.doOnGetViewRect(const browser: ICefBrowser; + rect: PCefRect): Boolean; +begin + Result := False; + if Assigned(FOnGetViewRect) then + FOnGetViewRect(Self, browser, rect, Result); +end; + +procedure TCustomChromiumOSR.doOnGotFocus(const browser: ICefBrowser); +begin + if Assigned(FOnGotFocus) then + FOnGotFocus(Self, browser) +end; + +function TCustomChromiumOSR.doOnJsdialog(const browser: ICefBrowser; + const originUrl, acceptLang: ustring; dialogType: TCefJsDialogType; + const messageText, defaultPromptText: ustring; callback: ICefJsDialogCallback; + out suppressMessage: Boolean): Boolean; +begin + Result := False; + if Assigned(FOnJsdialog) then + FOnJsdialog(Self, browser, originUrl, acceptLang, dialogType, + messageText, defaultPromptText, callback, suppressMessage, Result); +end; + +function TCustomChromiumOSR.doOnKeyEvent(const browser: ICefBrowser; + const event: PCefKeyEvent; osEvent: TCefEventHandle): Boolean; +begin + Result := False; + if Assigned(FOnKeyEvent) then + FOnKeyEvent(Self, browser, event, osEvent, Result); +end; + +procedure TCustomChromiumOSR.doOnLoadEnd(const browser: ICefBrowser; + const frame: ICefFrame; httpStatusCode: Integer); +begin + if Assigned(FOnLoadEnd) then + FOnLoadEnd(Self, browser, frame, httpStatusCode); +end; + +procedure TCustomChromiumOSR.doOnLoadError(const browser: ICefBrowser; + const frame: ICefFrame; errorCode: Integer; const errorText, + failedUrl: ustring); +begin + if Assigned(FOnLoadError) then + FOnLoadError(Self, browser, frame, errorCode, errorText, failedUrl); +end; + +procedure TCustomChromiumOSR.doOnLoadingStateChange(const browser: ICefBrowser; + isLoading, canGoBack, canGoForward: Boolean); +begin + if Assigned(FOnLoadingStateChange) then + FOnLoadingStateChange(Self, browser, isLoading, canGoBack, canGoForward); +end; + +procedure TCustomChromiumOSR.doOnLoadStart(const browser: ICefBrowser; + const frame: ICefFrame); +begin + if Assigned(FOnLoadStart) then + FOnLoadStart(Self, browser, frame); +end; + +procedure TCustomChromiumOSR.doOnPaint(const browser: ICefBrowser; + kind: TCefPaintElementType; dirtyRectsCount: NativeUInt; + const dirtyRects: PCefRectArray; const buffer: Pointer; width, height: Integer); +begin + if Assigned(FOnPaint) then + FOnPaint(Self, browser, kind, dirtyRectsCount, dirtyRects, buffer, width, height); +end; + +procedure TCustomChromiumOSR.doOnPluginCrashed(const browser: ICefBrowser; + const pluginPath: ustring); +begin + if Assigned(FOnPluginCrashed) then + FOnPluginCrashed(Self, browser, pluginPath); +end; + +procedure TCustomChromiumOSR.doOnPopupShow(const browser: ICefBrowser; + show: Boolean); +begin + if Assigned(FOnPopupShow) then + FOnPopupShow(Self, browser, show); +end; + +procedure TCustomChromiumOSR.doOnPopupSize(const browser: ICefBrowser; + const rect: PCefRect); +begin + if Assigned(FOnPopupSize) then + FOnPopupSize(Self, browser, rect); +end; + +function TCustomChromiumOSR.doOnPreKeyEvent(const browser: ICefBrowser; + const event: PCefKeyEvent; osEvent: TCefEventHandle; + out isKeyboardShortcut: Boolean): Boolean; +begin + Result := False; + if Assigned(FOnPreKeyEvent) then + FOnPreKeyEvent(Self, browser, event, osEvent, isKeyboardShortcut, Result); +end; + +function TCustomChromiumOSR.doOnProcessMessageReceived(const browser: ICefBrowser; + sourceProcess: TCefProcessId; const message: ICefProcessMessage): Boolean; +begin + Result := False; + if Assigned(FOnProcessMessageReceived) then + FOnProcessMessageReceived(Self, browser, sourceProcess, message, Result); +end; + +procedure TCustomChromiumOSR.doOnProtocolExecution(const browser: ICefBrowser; + const url: ustring; out allowOsExecution: Boolean); +begin + if Assigned(FOnProtocolExecution) then + FOnProtocolExecution(Self, browser, url, allowOsExecution); +end; + +function TCustomChromiumOSR.doOnQuotaRequest(const browser: ICefBrowser; + const originUrl: ustring; newSize: Int64; + const callback: ICefQuotaCallback): Boolean; +begin + Result := False; + if Assigned(FOnQuotaRequest) then + FOnQuotaRequest(Self, browser, originUrl, newSize, callback, Result); +end; + +procedure TCustomChromiumOSR.doOnRenderProcessTerminated(const browser: ICefBrowser; + status: TCefTerminationStatus); +begin + if Assigned(FOnRenderProcessTerminated) then + FOnRenderProcessTerminated(Self, browser, status); +end; + +procedure TCustomChromiumOSR.doOnRequestGeolocationPermission( + const browser: ICefBrowser; const requestingUrl: ustring; requestId: Integer; + const callback: ICefGeolocationCallback); +begin + if Assigned(FOnRequestGeolocationPermission) then + FOnRequestGeolocationPermission(Self, browser, requestingUrl, requestId, callback); +end; + +procedure TCustomChromiumOSR.doOnResetDialogState(const browser: ICefBrowser); +begin + if Assigned(FOnResetDialogState) then + FOnResetDialogState(Self, browser); +end; + +procedure TCustomChromiumOSR.doOnResourceRedirect(const browser: ICefBrowser; + const frame: ICefFrame; const oldUrl: ustring; var newUrl: ustring); +begin + if Assigned(FOnResourceRedirect) then + FOnResourceRedirect(Self, browser, frame, oldUrl, newUrl); +end; + +procedure TCustomChromiumOSR.doOnScrollOffsetChanged( + const browser: ICefBrowser); +begin + if Assigned(FOnScrollOffsetChanged) then + FOnScrollOffsetChanged(Self, browser); +end; + +function TCustomChromiumOSR.doOnSetFocus(const browser: ICefBrowser; + source: TCefFocusSource): Boolean; +begin + Result := False; + if Assigned(FOnSetFocus) then + FOnSetFocus(Self, browser, source, Result); +end; + +procedure TCustomChromiumOSR.doOnStatusMessage(const browser: ICefBrowser; + const value: ustring); +begin + if Assigned(FOnStatusMessage) then + FOnStatusMessage(Self, browser, value); +end; + +procedure TCustomChromiumOSR.doOnTakeFocus(const browser: ICefBrowser; + next: Boolean); +begin + if Assigned(FOnTakeFocus) then + FOnTakeFocus(Self, browser, next); +end; + +procedure TCustomChromiumOSR.doOnTitleChange(const browser: ICefBrowser; + const title: ustring); +begin + if Assigned(FOnTitleChange) then + FOnTitleChange(Self, browser, title); +end; + +function TCustomChromiumOSR.doOnTooltip(const browser: ICefBrowser; + var text: ustring): Boolean; +begin + Result := False; + if Assigned(FOnTooltip) then + FOnTooltip(Self, browser, text, Result); +end; + +function TCustomChromiumOSR.doOnRunModal(const browser: ICefBrowser): Boolean; +begin + Result := False; + if Assigned(FOnRunModal) then + FOnRunModal(Self, browser, Result); +end; + + +end. diff --git a/src/thirdparty/superobject.pas b/src/thirdparty/superobject.pas new file mode 100644 index 0000000..9fe8e80 --- /dev/null +++ b/src/thirdparty/superobject.pas @@ -0,0 +1,7616 @@ +(* + * Super Object Toolkit + * + * Usage allowed under the restrictions of the Lesser GNU General Public License + * or alternatively the restrictions of the Mozilla Public License 1.1 + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for + * the specific language governing rights and limitations under the License. + * + * Embarcadero Technologies Inc is not permitted to use or redistribute + * this source code without explicit permission. + * + * Unit owner : Henri Gourvest + * Web site : http://www.progdigy.com + * + * This unit is inspired from the json c lib: + * Michael Clark + * http://oss.metaparadigm.com/json-c/ + * + * CHANGES: + * v1.2 + * + support of currency data type + * + right trim unquoted string + * + read Unicode Files and streams (Litle Endian with BOM) + * + Fix bug on javadate functions + windows nt compatibility + * + Now you can force to parse only the canonical syntax of JSON using the stric parameter + * + Delphi 2010 RTTI marshalling + * v1.1 + * + Double licence MPL or LGPL. + * + Delphi 2009 compatibility & Unicode support. + * + AsString return a string instead of PChar. + * + Escaped and Unascaped JSON serialiser. + * + Missed FormFeed added \f + * - Removed @ trick, uses forcepath() method instead. + * + Fixed parse error with uppercase E symbol in numbers. + * + Fixed possible buffer overflow when enlarging array. + * + Added "delete", "pack", "insert" methods for arrays and/or objects + * + Multi parametters when calling methods + * + Delphi Enumerator (for obj1 in obj2 do ...) + * + Format method ex: obj.format('<%name%>%tab[1]%') + * + ParseFile and ParseStream methods + * + Parser now understand hexdecimal c syntax ex: \xFF + * + Null Object Design Patern (ex: for obj in values.N['path'] do ...) + * v1.0 + * + renamed class + * + interfaced object + * + added a new data type: the method + * + parser can now evaluate properties and call methods + * - removed obselet rpc class + * - removed "find" method, now you can use "parse" method instead + * v0.6 + * + refactoring + * v0.5 + * + new find method to get or set value using a path syntax + * ex: obj.s['obj.prop[1]'] := 'string value'; + * obj.a['@obj.array'].b[n] := true; // @ -> create property if necessary + * v0.4 + * + bug corrected: AVL tree badly balanced. + * v0.3 + * + New validator partially based on the Kwalify syntax. + * + extended syntax to parse unquoted fields. + * + Freepascal compatibility win32/64 Linux32/64. + * + JavaToDelphiDateTime and DelphiToJavaDateTime improved for UTC. + * + new TJsonObject.Compare function. + * v0.2 + * + Hashed string list replaced with a faster AVL tree + * + JsonInt data type can be changed to int64 + * + JavaToDelphiDateTime and DelphiToJavaDateTime helper fonctions + * + from json-c v0.7 + * + Add escaping of backslash to json output + * + Add escaping of foward slash on tokenizing and output + * + Changes to internal tokenizer from using recursion to + * using a depth state structure to allow incremental parsing + * v0.1 + * + first release + *) + + {$define NEED_FORMATSETTINGS} + +{$IFDEF FPC} + {$MODE OBJFPC}{$H+} +{$ENDIF} + +{$DEFINE SUPER_METHOD} +{$DEFINE WINDOWSNT_COMPATIBILITY} +{.$DEFINE DEBUG} // track memory leack + + +{$if defined(FPC) or defined(VER170) or defined(VER180) or defined(VER190) or defined(VER200) or defined(VER210)} + {$DEFINE HAVE_INLINE} +{$ifend} + +{$if defined(VER210) or defined(VER220) or defined(VER230)} + {$define HAVE_RTTI} +{$ifend} + +{$if defined(VER230)} + {$define NEED_FORMATSETTINGS} +{$ifend} + +{$if defined(FPC) and defined(VER2_6)} + {$define NEED_FORMATSETTINGS} +{$ifend} + +{$OVERFLOWCHECKS OFF} +{$RANGECHECKS OFF} + +unit superobject; + +interface +uses + Classes +{$IFDEF HAVE_RTTI} + ,Generics.Collections, RTTI, TypInfo +{$ENDIF} + ; + +type +{$IFNDEF FPC} +{$IFDEF CPUX64} + PtrInt = Int64; + PtrUInt = UInt64; +{$ELSE} + PtrInt = longint; + PtrUInt = Longword; +{$ENDIF} +{$ENDIF} + SuperInt = Int64; + +{$if (sizeof(Char) = 1)} + SOChar = WideChar; + SOIChar = Word; + PSOChar = PWideChar; +{$IFDEF FPC} + SOString = UnicodeString; +{$ELSE} + SOString = WideString; +{$ENDIF} +{$else} + SOChar = Char; + SOIChar = Word; + PSOChar = PChar; + SOString = string; +{$ifend} + +const + SUPER_ARRAY_LIST_DEFAULT_SIZE = 32; + SUPER_TOKENER_MAX_DEPTH = 32; + + SUPER_AVL_MAX_DEPTH = sizeof(longint) * 8; + SUPER_AVL_MASK_HIGH_BIT = not ((not longword(0)) shr 1); + +type + // forward declarations + TSuperObject = class; + ISuperObject = interface; + TSuperArray = class; + +(* AVL Tree + * This is a "special" autobalanced AVL tree + * It use a hash value for fast compare + *) + +{$IFDEF SUPER_METHOD} + TSuperMethod = procedure(const This, Params: ISuperObject; var Result: ISuperObject); +{$ENDIF} + + + TSuperAvlBitArray = set of 0..SUPER_AVL_MAX_DEPTH - 1; + + TSuperAvlSearchType = (stEQual, stLess, stGreater); + TSuperAvlSearchTypes = set of TSuperAvlSearchType; + TSuperAvlIterator = class; + + TSuperAvlEntry = class + private + FGt, FLt: TSuperAvlEntry; + FBf: integer; + FHash: Cardinal; + FName: SOString; + FPtr: Pointer; + function GetValue: ISuperObject; + procedure SetValue(const val: ISuperObject); + public + class function Hash(const k: SOString): Cardinal; virtual; + constructor Create(const AName: SOString; Obj: Pointer); virtual; + property Name: SOString read FName; + property Ptr: Pointer read FPtr; + property Value: ISuperObject read GetValue write SetValue; + end; + + TSuperAvlTree = class + private + FRoot: TSuperAvlEntry; + FCount: Integer; + function balance(bal: TSuperAvlEntry): TSuperAvlEntry; + protected + procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); virtual; + function CompareNodeNode(node1, node2: TSuperAvlEntry): integer; virtual; + function CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer; virtual; + function Insert(h: TSuperAvlEntry): TSuperAvlEntry; virtual; + function Search(const k: SOString; st: TSuperAvlSearchTypes = [stEqual]): TSuperAvlEntry; virtual; + public + constructor Create; virtual; + destructor Destroy; override; + function IsEmpty: boolean; + procedure Clear(all: boolean = false); virtual; + procedure Pack(all: boolean); + function Delete(const k: SOString): ISuperObject; + function GetEnumerator: TSuperAvlIterator; + property count: Integer read FCount; + end; + + TSuperTableString = class(TSuperAvlTree) + protected + procedure doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); override; + procedure PutO(const k: SOString; const value: ISuperObject); + function GetO(const k: SOString): ISuperObject; + procedure PutS(const k: SOString; const value: SOString); + function GetS(const k: SOString): SOString; + procedure PutI(const k: SOString; value: SuperInt); + function GetI(const k: SOString): SuperInt; + procedure PutD(const k: SOString; value: Double); + function GetD(const k: SOString): Double; + procedure PutB(const k: SOString; value: Boolean); + function GetB(const k: SOString): Boolean; +{$IFDEF SUPER_METHOD} + procedure PutM(const k: SOString; value: TSuperMethod); + function GetM(const k: SOString): TSuperMethod; +{$ENDIF} + procedure PutN(const k: SOString; const value: ISuperObject); + function GetN(const k: SOString): ISuperObject; + procedure PutC(const k: SOString; value: Currency); + function GetC(const k: SOString): Currency; + public + property O[const k: SOString]: ISuperObject read GetO write PutO; default; + property S[const k: SOString]: SOString read GetS write PutS; + property I[const k: SOString]: SuperInt read GetI write PutI; + property D[const k: SOString]: Double read GetD write PutD; + property B[const k: SOString]: Boolean read GetB write PutB; +{$IFDEF SUPER_METHOD} + property M[const k: SOString]: TSuperMethod read GetM write PutM; +{$ENDIF} + property N[const k: SOString]: ISuperObject read GetN write PutN; + property C[const k: SOString]: Currency read GetC write PutC; + + function GetValues: ISuperObject; + function GetNames: ISuperObject; + function Find(const k: SOString; var value: ISuperObject): Boolean; + function Exists(const k: SOString): Boolean; + end; + + TSuperAvlIterator = class + private + FTree: TSuperAvlTree; + FBranch: TSuperAvlBitArray; + FDepth: LongInt; + FPath: array[0..SUPER_AVL_MAX_DEPTH - 2] of TSuperAvlEntry; + public + constructor Create(tree: TSuperAvlTree); virtual; + procedure Search(const k: SOString; st: TSuperAvlSearchTypes = [stEQual]); + procedure First; + procedure Last; + function GetIter: TSuperAvlEntry; + procedure Next; + procedure Prior; + // delphi enumerator + function MoveNext: Boolean; + property Current: TSuperAvlEntry read GetIter; + end; + + TSuperObjectArray = array[0..(high(Integer) div sizeof(TSuperObject))-1] of ISuperObject; + PSuperObjectArray = ^TSuperObjectArray; + + TSuperArray = class + private + FArray: PSuperObjectArray; + FLength: Integer; + FSize: Integer; + procedure Expand(max: Integer); + protected + function GetO(const index: integer): ISuperObject; + procedure PutO(const index: integer; const Value: ISuperObject); + function GetB(const index: integer): Boolean; + procedure PutB(const index: integer; Value: Boolean); + function GetI(const index: integer): SuperInt; + procedure PutI(const index: integer; Value: SuperInt); + function GetD(const index: integer): Double; + procedure PutD(const index: integer; Value: Double); + function GetC(const index: integer): Currency; + procedure PutC(const index: integer; Value: Currency); + function GetS(const index: integer): SOString; + procedure PutS(const index: integer; const Value: SOString); +{$IFDEF SUPER_METHOD} + function GetM(const index: integer): TSuperMethod; + procedure PutM(const index: integer; Value: TSuperMethod); +{$ENDIF} + function GetN(const index: integer): ISuperObject; + procedure PutN(const index: integer; const Value: ISuperObject); + public + constructor Create; virtual; + destructor Destroy; override; + function Add(const Data: ISuperObject): Integer; overload; + function Add(Data: SuperInt): Integer; overload; + function Add(const Data: SOString): Integer; overload; + function Add(Data: Boolean): Integer; overload; + function Add(Data: Double): Integer; overload; + function AddC(const Data: Currency): Integer; + function Delete(index: Integer): ISuperObject; + procedure Insert(index: Integer; const value: ISuperObject); + procedure Clear(all: boolean = false); + procedure Pack(all: boolean); + property Length: Integer read FLength; + + property N[const index: integer]: ISuperObject read GetN write PutN; + property O[const index: integer]: ISuperObject read GetO write PutO; default; + property B[const index: integer]: boolean read GetB write PutB; + property I[const index: integer]: SuperInt read GetI write PutI; + property D[const index: integer]: Double read GetD write PutD; + property C[const index: integer]: Currency read GetC write PutC; + property S[const index: integer]: SOString read GetS write PutS; +{$IFDEF SUPER_METHOD} + property M[const index: integer]: TSuperMethod read GetM write PutM; +{$ENDIF} + end; + + TSuperWriter = class + public + // abstact methods to overide + function Append(buf: PSOChar; Size: Integer): Integer; overload; virtual; abstract; + function Append(buf: PSOChar): Integer; overload; virtual; abstract; + procedure Reset; virtual; abstract; + end; + + TSuperWriterString = class(TSuperWriter) + private + FBuf: PSOChar; + FBPos: integer; + FSize: integer; + public + function Append(buf: PSOChar; Size: Integer): Integer; overload; override; + function Append(buf: PSOChar): Integer; overload; override; + procedure Reset; override; + procedure TrimRight; + constructor Create; virtual; + destructor Destroy; override; + function GetString: SOString; + property Data: PSOChar read FBuf; + property Size: Integer read FSize; + property Position: integer read FBPos; + end; + + TSuperWriterStream = class(TSuperWriter) + private + FStream: TStream; + public + function Append(buf: PSOChar): Integer; override; + procedure Reset; override; + constructor Create(AStream: TStream); reintroduce; virtual; + end; + + TSuperAnsiWriterStream = class(TSuperWriterStream) + public + function Append(buf: PSOChar; Size: Integer): Integer; override; + end; + + TSuperUnicodeWriterStream = class(TSuperWriterStream) + public + function Append(buf: PSOChar; Size: Integer): Integer; override; + end; + + TSuperWriterFake = class(TSuperWriter) + private + FSize: Integer; + public + function Append(buf: PSOChar; Size: Integer): Integer; override; + function Append(buf: PSOChar): Integer; override; + procedure Reset; override; + constructor Create; reintroduce; virtual; + property size: integer read FSize; + end; + + TSuperWriterSock = class(TSuperWriter) + private + FSocket: longint; + FSize: Integer; + public + function Append(buf: PSOChar; Size: Integer): Integer; override; + function Append(buf: PSOChar): Integer; override; + procedure Reset; override; + constructor Create(ASocket: longint); reintroduce; virtual; + property Socket: longint read FSocket; + property Size: Integer read FSize; + end; + + TSuperTokenizerError = ( + teSuccess, + teContinue, + teDepth, + teParseEof, + teParseUnexpected, + teParseNull, + teParseBoolean, + teParseNumber, + teParseArray, + teParseObjectKeyName, + teParseObjectKeySep, + teParseObjectValueSep, + teParseString, + teParseComment, + teEvalObject, + teEvalArray, + teEvalMethod, + teEvalInt + ); + + TSuperTokenerState = ( + tsEatws, + tsStart, + tsFinish, + tsNull, + tsCommentStart, + tsComment, + tsCommentEol, + tsCommentEnd, + tsString, + tsStringEscape, + tsIdentifier, + tsEscapeUnicode, + tsEscapeHexadecimal, + tsBoolean, + tsNumber, + tsArray, + tsArrayAdd, + tsArraySep, + tsObjectFieldStart, + tsObjectField, + tsObjectUnquotedField, + tsObjectFieldEnd, + tsObjectValue, + tsObjectValueAdd, + tsObjectSep, + tsEvalProperty, + tsEvalArray, + tsEvalMethod, + tsParamValue, + tsParamPut, + tsMethodValue, + tsMethodPut + ); + + PSuperTokenerSrec = ^TSuperTokenerSrec; + TSuperTokenerSrec = record + state, saved_state: TSuperTokenerState; + obj: ISuperObject; + current: ISuperObject; + field_name: SOString; + parent: ISuperObject; + gparent: ISuperObject; + end; + + TSuperTokenizer = class + public + str: PSOChar; + pb: TSuperWriterString; + depth, is_double, floatcount, st_pos, char_offset: Integer; + err: TSuperTokenizerError; + ucs_char: Word; + quote_char: SOChar; + stack: array[0..SUPER_TOKENER_MAX_DEPTH-1] of TSuperTokenerSrec; + line, col: Integer; + public + constructor Create; virtual; + destructor Destroy; override; + procedure ResetLevel(adepth: integer); + procedure Reset; + end; + + // supported object types + TSuperType = ( + stNull, + stBoolean, + stDouble, + stCurrency, + stInt, + stObject, + stArray, + stString +{$IFDEF SUPER_METHOD} + ,stMethod +{$ENDIF} + ); + + TSuperValidateError = ( + veRuleMalformated, + veFieldIsRequired, + veInvalidDataType, + veFieldNotFound, + veUnexpectedField, + veDuplicateEntry, + veValueNotInEnum, + veInvalidLength, + veInvalidRange + ); + + TSuperFindOption = ( + foCreatePath, + foPutValue, + foDelete +{$IFDEF SUPER_METHOD} + ,foCallMethod +{$ENDIF} + ); + + TSuperFindOptions = set of TSuperFindOption; + TSuperCompareResult = (cpLess, cpEqu, cpGreat, cpError); + TSuperOnValidateError = procedure(sender: Pointer; error: TSuperValidateError; const objpath: SOString); + + TSuperEnumerator = class + private + FObj: ISuperObject; + FObjEnum: TSuperAvlIterator; + FCount: Integer; + public + constructor Create(const obj: ISuperObject); virtual; + destructor Destroy; override; + function MoveNext: Boolean; + function GetCurrent: ISuperObject; + property Current: ISuperObject read GetCurrent; + end; + + ISuperObject = interface + ['{4B86A9E3-E094-4E5A-954A-69048B7B6327}'] + function GetEnumerator: TSuperEnumerator; + function GetDataType: TSuperType; + function GetProcessing: boolean; + procedure SetProcessing(value: boolean); + function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject; + function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString; + + function GetO(const path: SOString): ISuperObject; + procedure PutO(const path: SOString; const Value: ISuperObject); + function GetB(const path: SOString): Boolean; + procedure PutB(const path: SOString; Value: Boolean); + function GetI(const path: SOString): SuperInt; + procedure PutI(const path: SOString; Value: SuperInt); + function GetD(const path: SOString): Double; + procedure PutC(const path: SOString; Value: Currency); + function GetC(const path: SOString): Currency; + procedure PutD(const path: SOString; Value: Double); + function GetS(const path: SOString): SOString; + procedure PutS(const path: SOString; const Value: SOString); +{$IFDEF SUPER_METHOD} + function GetM(const path: SOString): TSuperMethod; + procedure PutM(const path: SOString; Value: TSuperMethod); +{$ENDIF} + function GetA(const path: SOString): TSuperArray; + + // Null Object Design patern + function GetN(const path: SOString): ISuperObject; + procedure PutN(const path: SOString; const Value: ISuperObject); + + // Writers + function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; + function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload; + function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload; + function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload; + function CalcSize(indent: boolean = false; escape: boolean = true): integer; + + // convert + function AsBoolean: Boolean; + function AsInteger: SuperInt; + function AsDouble: Double; + function AsCurrency: Currency; + function AsString: SOString; + function AsArray: TSuperArray; + function AsObject: TSuperTableString; +{$IFDEF SUPER_METHOD} + function AsMethod: TSuperMethod; +{$ENDIF} + function AsJSon(indent: boolean = false; escape: boolean = true): SOString; + + procedure Clear(all: boolean = false); + procedure Pack(all: boolean = false); + + property N[const path: SOString]: ISuperObject read GetN write PutN; + property O[const path: SOString]: ISuperObject read GetO write PutO; default; + property B[const path: SOString]: boolean read GetB write PutB; + property I[const path: SOString]: SuperInt read GetI write PutI; + property D[const path: SOString]: Double read GetD write PutD; + property C[const path: SOString]: Currency read GetC write PutC; + property S[const path: SOString]: SOString read GetS write PutS; +{$IFDEF SUPER_METHOD} + property M[const path: SOString]: TSuperMethod read GetM write PutM; +{$ENDIF} + property A[const path: SOString]: TSuperArray read GetA; + +{$IFDEF SUPER_METHOD} + function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload; + function call(const path, param: SOString): ISuperObject; overload; +{$ENDIF} + + // clone a node + function Clone: ISuperObject; + function Delete(const path: SOString): ISuperObject; + // merges tow objects of same type, if reference is true then nodes are not cloned + procedure Merge(const obj: ISuperObject; reference: boolean = false); overload; + procedure Merge(const str: SOString); overload; + + // validate methods + function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; + function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; + + // compare + function Compare(const obj: ISuperObject): TSuperCompareResult; overload; + function Compare(const str: SOString): TSuperCompareResult; overload; + + // the data type + function IsType(AType: TSuperType): boolean; + property DataType: TSuperType read GetDataType; + property Processing: boolean read GetProcessing write SetProcessing; + + function GetDataPtr: Pointer; + procedure SetDataPtr(const Value: Pointer); + property DataPtr: Pointer read GetDataPtr write SetDataPtr; + end; + + TSuperObject = class(TObject, ISuperObject) + private + FRefCount: Integer; + FProcessing: boolean; + FDataType: TSuperType; + FDataPtr: Pointer; +{.$if true} + FO: record + case TSuperType of + stBoolean: (c_boolean: boolean); + stDouble: (c_double: double); + stCurrency: (c_currency: Currency); + stInt: (c_int: SuperInt); + stObject: (c_object: TSuperTableString); + stArray: (c_array: TSuperArray); +{$IFDEF SUPER_METHOD} + stMethod: (c_method: TSuperMethod); +{$ENDIF} + end; +{.$ifend} + FOString: SOString; + function GetDataType: TSuperType; + function GetDataPtr: Pointer; + procedure SetDataPtr(const Value: Pointer); + protected +{$IFDEF FPC} + function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid: tguid; out obj): longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; +{$ELSE} + function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; +{$ENDIF} + function _AddRef: Integer; virtual; stdcall; + function _Release: Integer; virtual; stdcall; + + function GetO(const path: SOString): ISuperObject; + procedure PutO(const path: SOString; const Value: ISuperObject); + function GetB(const path: SOString): Boolean; + procedure PutB(const path: SOString; Value: Boolean); + function GetI(const path: SOString): SuperInt; + procedure PutI(const path: SOString; Value: SuperInt); + function GetD(const path: SOString): Double; + procedure PutD(const path: SOString; Value: Double); + procedure PutC(const path: SOString; Value: Currency); + function GetC(const path: SOString): Currency; + function GetS(const path: SOString): SOString; + procedure PutS(const path: SOString; const Value: SOString); +{$IFDEF SUPER_METHOD} + function GetM(const path: SOString): TSuperMethod; + procedure PutM(const path: SOString; Value: TSuperMethod); +{$ENDIF} + function GetA(const path: SOString): TSuperArray; + function Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; virtual; + public + function GetEnumerator: TSuperEnumerator; + procedure AfterConstruction; override; + procedure BeforeDestruction; override; + class function NewInstance: TObject; override; + property RefCount: Integer read FRefCount; + + function GetProcessing: boolean; + procedure SetProcessing(value: boolean); + + // Writers + function SaveTo(stream: TStream; indent: boolean = false; escape: boolean = true): integer; overload; + function SaveTo(const FileName: string; indent: boolean = false; escape: boolean = true): integer; overload; + function SaveTo(socket: longint; indent: boolean = false; escape: boolean = true): integer; overload; + function CalcSize(indent: boolean = false; escape: boolean = true): integer; + function AsJSon(indent: boolean = false; escape: boolean = true): SOString; + + // parser ... owned! + class function ParseString(s: PSOChar; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = []; + const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; + class function ParseStream(stream: TStream; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = []; + const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; + class function ParseFile(const FileName: string; strict: Boolean; partial: boolean = true; const this: ISuperObject = nil; options: TSuperFindOptions = []; + const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; + class function ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer; strict: Boolean; const this: ISuperObject = nil; + options: TSuperFindOptions = []; const put: ISuperObject = nil; dt: TSuperType = stNull): ISuperObject; + + // constructors / destructor + constructor Create(jt: TSuperType = stObject); overload; virtual; + constructor Create(b: boolean); overload; virtual; + constructor Create(i: SuperInt); overload; virtual; + constructor Create(d: double); overload; virtual; + constructor CreateCurrency(c: Currency); overload; virtual; + constructor Create(const s: SOString); overload; virtual; +{$IFDEF SUPER_METHOD} + constructor Create(m: TSuperMethod); overload; virtual; +{$ENDIF} + destructor Destroy; override; + + // convert + function AsBoolean: Boolean; virtual; + function AsInteger: SuperInt; virtual; + function AsDouble: Double; virtual; + function AsCurrency: Currency; virtual; + function AsString: SOString; virtual; + function AsArray: TSuperArray; virtual; + function AsObject: TSuperTableString; virtual; +{$IFDEF SUPER_METHOD} + function AsMethod: TSuperMethod; virtual; +{$ENDIF} + procedure Clear(all: boolean = false); virtual; + procedure Pack(all: boolean = false); virtual; + function GetN(const path: SOString): ISuperObject; + procedure PutN(const path: SOString; const Value: ISuperObject); + function ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject; + function Format(const str: SOString; BeginSep: SOChar = '%'; EndSep: SOChar = '%'): SOString; + + property N[const path: SOString]: ISuperObject read GetN write PutN; + property O[const path: SOString]: ISuperObject read GetO write PutO; default; + property B[const path: SOString]: boolean read GetB write PutB; + property I[const path: SOString]: SuperInt read GetI write PutI; + property D[const path: SOString]: Double read GetD write PutD; + property C[const path: SOString]: Currency read GetC write PutC; + property S[const path: SOString]: SOString read GetS write PutS; +{$IFDEF SUPER_METHOD} + property M[const path: SOString]: TSuperMethod read GetM write PutM; +{$ENDIF} + property A[const path: SOString]: TSuperArray read GetA; + + {$IFDEF SUPER_METHOD} + function call(const path: SOString; const param: ISuperObject = nil): ISuperObject; overload; virtual; + function call(const path, param: SOString): ISuperObject; overload; virtual; +{$ENDIF} + // clone a node + function Clone: ISuperObject; virtual; + function Delete(const path: SOString): ISuperObject; + // merges tow objects of same type, if reference is true then nodes are not cloned + procedure Merge(const obj: ISuperObject; reference: boolean = false); overload; + procedure Merge(const str: SOString); overload; + + // validate methods + function Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; + function Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; overload; + + // compare + function Compare(const obj: ISuperObject): TSuperCompareResult; overload; + function Compare(const str: SOString): TSuperCompareResult; overload; + + // the data type + function IsType(AType: TSuperType): boolean; + property DataType: TSuperType read GetDataType; + // a data pointer to link to something ele, a treeview for example + property DataPtr: Pointer read GetDataPtr write SetDataPtr; + property Processing: boolean read GetProcessing; + end; + +{$IFDEF HAVE_RTTI} + TSuperRttiContext = class; + + TSerialFromJson = function(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean; + TSerialToJson = function(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject; + + TSuperAttribute = class(TCustomAttribute) + private + FName: string; + public + constructor Create(const AName: string); + property Name: string read FName; + end; + + SOName = class(TSuperAttribute); + SODefault = class(TSuperAttribute); + + + TSuperRttiContext = class + private + class function GetFieldName(r: TRttiField): string; + class function GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject; + public + Context: TRttiContext; + SerialFromJson: TDictionary; + SerialToJson: TDictionary; + constructor Create; virtual; + destructor Destroy; override; + function FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject; var Value: TValue): Boolean; virtual; + function ToJson(var value: TValue; const index: ISuperObject): ISuperObject; virtual; + function AsType(const obj: ISuperObject): T; + function AsJson(const obj: T; const index: ISuperObject = nil): ISuperObject; + end; + + TSuperObjectHelper = class helper for TObject + public + function ToJson(ctx: TSuperRttiContext = nil): ISuperObject; + constructor FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil); overload; + constructor FromJson(const str: string; ctx: TSuperRttiContext = nil); overload; + end; +{$ENDIF} + + TSuperObjectIter = record + key: SOString; + val: ISuperObject; + Ite: TSuperAvlIterator; + end; + +function ObjectIsError(obj: TSuperObject): boolean; +function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean; +function ObjectGetType(const obj: ISuperObject): TSuperType; +function ObjectIsNull(const obj: ISuperObject): Boolean; + +function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean; +function ObjectFindNext(var F: TSuperObjectIter): boolean; +procedure ObjectFindClose(var F: TSuperObjectIter); + +function SO(const s: SOString = '{}'): ISuperObject; overload; +function SO(const value: Variant): ISuperObject; overload; +function SO(const Args: array of const): ISuperObject; overload; + +function SA(const Args: array of const): ISuperObject; overload; + +function JavaToDelphiDateTime(const dt: int64): TDateTime; +function DelphiToJavaDateTime(const dt: TDateTime): int64; +function TryObjectToDate(const obj: ISuperObject; var dt: TDateTime): Boolean; +function ISO8601DateToJavaDateTime(const str: SOString; var ms: Int64): Boolean; +function ISO8601DateToDelphiDateTime(const str: SOString; var dt: TDateTime): Boolean; +function DelphiDateTimeToISO8601Date(dt: TDateTime): SOString; +function UUIDToString(const g: TGUID): SOString; +function StringToUUID(const str: SOString; var g: TGUID): Boolean; + +{$IFDEF HAVE_RTTI} + +type + TSuperInvokeResult = ( + irSuccess, + irMethothodError, // method don't exist + irParamError, // invalid parametters + irError // other error + ); + +function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue; const method: string; const params: ISuperObject; var Return: ISuperObject): TSuperInvokeResult; overload; +function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext = nil): ISuperObject; overload; +function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext = nil): ISuperObject; overload; +{$ENDIF} + +implementation +uses sysutils, +{$IFDEF UNIX} + baseunix, unix, DateUtils +{$ELSE} + Windows +{$ENDIF} +{$IFDEF FPC} + ,sockets +{$ELSE} + ,WinSock +{$ENDIF}; + +{$IFDEF DEBUG} +var + debugcount: integer = 0; +{$ENDIF} + +const + super_number_chars_set = ['0'..'9','.','+','-','e','E']; + super_hex_chars: PSOChar = '0123456789abcdef'; + super_hex_chars_set = ['0'..'9','a'..'f','A'..'F']; + + ESC_BS: PSOChar = '\b'; + ESC_LF: PSOChar = '\n'; + ESC_CR: PSOChar = '\r'; + ESC_TAB: PSOChar = '\t'; + ESC_FF: PSOChar = '\f'; + ESC_QUOT: PSOChar = '\"'; + ESC_SL: PSOChar = '\\'; + ESC_SR: PSOChar = '\/'; + ESC_ZERO: PSOChar = '\u0000'; + + TOK_CRLF: PSOChar = #13#10; + TOK_SP: PSOChar = #32; + TOK_BS: PSOChar = #8; + TOK_TAB: PSOChar = #9; + TOK_LF: PSOChar = #10; + TOK_FF: PSOChar = #12; + TOK_CR: PSOChar = #13; +// TOK_SL: PSOChar = '\'; +// TOK_SR: PSOChar = '/'; + TOK_NULL: PSOChar = 'null'; + TOK_CBL: PSOChar = '{'; // curly bracket left + TOK_CBR: PSOChar = '}'; // curly bracket right + TOK_ARL: PSOChar = '['; + TOK_ARR: PSOChar = ']'; + TOK_ARRAY: PSOChar = '[]'; + TOK_OBJ: PSOChar = '{}'; // empty object + TOK_COM: PSOChar = ','; // Comma + TOK_DQT: PSOChar = '"'; // Double Quote + TOK_TRUE: PSOChar = 'true'; + TOK_FALSE: PSOChar = 'false'; + +{$if (sizeof(Char) = 1)} +function StrLComp(const Str1, Str2: PSOChar; MaxLen: Cardinal): Integer; +var + P1, P2: PWideChar; + I: Cardinal; + C1, C2: WideChar; +begin + P1 := Str1; + P2 := Str2; + I := 0; + while I < MaxLen do + begin + C1 := P1^; + C2 := P2^; + + if (C1 <> C2) or (C1 = #0) then + begin + Result := Ord(C1) - Ord(C2); + Exit; + end; + + Inc(P1); + Inc(P2); + Inc(I); + end; + Result := 0; +end; + +function StrComp(const Str1, Str2: PSOChar): Integer; +var + P1, P2: PWideChar; + C1, C2: WideChar; +begin + P1 := Str1; + P2 := Str2; + while True do + begin + C1 := P1^; + C2 := P2^; + + if (C1 <> C2) or (C1 = #0) then + begin + Result := Ord(C1) - Ord(C2); + Exit; + end; + + Inc(P1); + Inc(P2); + end; +end; + +function StrLen(const Str: PSOChar): Cardinal; +var + p: PSOChar; +begin + Result := 0; + if Str <> nil then + begin + p := Str; + while p^ <> #0 do inc(p); + Result := (p - Str); + end; +end; +{$ifend} + +function FloatToJson(const value: Double): SOString; +var + p: PSOChar; +begin + Result := FloatToStr(value); + if {$if defined(NEED_FORMATSETTINGS)}FormatSettings.{$ifend}DecimalSeparator <> '.' then + begin + p := PSOChar(Result); + while p^ <> #0 do + if p^ <> SOChar({$if defined(NEED_FORMATSETTINGS)}FormatSettings.{$ifend}DecimalSeparator) then + inc(p) else + begin + p^ := '.'; + Exit; + end; + end; +end; + +function CurrToJson(const value: Currency): SOString; +var + p: PSOChar; +begin + Result := CurrToStr(value); + if {$if defined(NEED_FORMATSETTINGS)}FormatSettings.{$ifend}DecimalSeparator <> '.' then + begin + p := PSOChar(Result); + while p^ <> #0 do + if p^ <> SOChar({$if defined(NEED_FORMATSETTINGS)}FormatSettings.{$ifend}DecimalSeparator) then + inc(p) else + begin + p^ := '.'; + Exit; + end; + end; +end; + +{$IFDEF UNIX} +function GetTimeBias: integer; +var + TimeVal: TTimeVal; + TimeZone: TTimeZone; +begin + fpGetTimeOfDay(@TimeVal, @TimeZone); + Result := TimeZone.tz_minuteswest; +end; +{$ELSE} +function GetTimeBias: integer; +var + tzi : TTimeZoneInformation; +begin + case GetTimeZoneInformation(tzi) of + TIME_ZONE_ID_UNKNOWN : Result := tzi.Bias; + TIME_ZONE_ID_STANDARD: Result := tzi.Bias + tzi.StandardBias; + TIME_ZONE_ID_DAYLIGHT: Result := tzi.Bias + tzi.DaylightBias; + else + Result := 0; + end; +end; +{$ENDIF} + +{$IFDEF UNIX} +type + ptm = ^tm; + tm = record + tm_sec: Integer; (* Seconds: 0-59 (K&R says 0-61?) *) + tm_min: Integer; (* Minutes: 0-59 *) + tm_hour: Integer; (* Hours since midnight: 0-23 *) + tm_mday: Integer; (* Day of the month: 1-31 *) + tm_mon: Integer; (* Months *since* january: 0-11 *) + tm_year: Integer; (* Years since 1900 *) + tm_wday: Integer; (* Days since Sunday (0-6) *) + tm_yday: Integer; (* Days since Jan. 1: 0-365 *) + tm_isdst: Integer; (* +1 Daylight Savings Time, 0 No DST, -1 don't know *) + end; + +function mktime(p: ptm): LongInt; cdecl; external; +function gmtime(const t: PLongint): ptm; cdecl; external; +function localtime (const t: PLongint): ptm; cdecl; external; + +function DelphiToJavaDateTime(const dt: TDateTime): Int64; +var + p: ptm; + l, ms: Integer; + v: Int64; +begin + v := Round((dt - 25569) * 86400000); + ms := v mod 1000; + l := v div 1000; + p := localtime(@l); + Result := Int64(mktime(p)) * 1000 + ms; +end; + +function JavaToDelphiDateTime(const dt: int64): TDateTime; +var + p: ptm; + l, ms: Integer; +begin + l := dt div 1000; + ms := dt mod 1000; + p := gmtime(@l); + Result := EncodeDateTime(p^.tm_year+1900, p^.tm_mon+1, p^.tm_mday, p^.tm_hour, p^.tm_min, p^.tm_sec, ms); +end; +{$ELSE} + +{$IFDEF WINDOWSNT_COMPATIBILITY} +function DayLightCompareDate(const date: PSystemTime; + const compareDate: PSystemTime): Integer; +var + limit_day, dayinsecs, weekofmonth: Integer; + First: Word; +begin + if (date^.wMonth < compareDate^.wMonth) then + begin + Result := -1; (* We are in a month before the date limit. *) + Exit; + end; + + if (date^.wMonth > compareDate^.wMonth) then + begin + Result := 1; (* We are in a month after the date limit. *) + Exit; + end; + + (* if year is 0 then date is in day-of-week format, otherwise + * it's absolute date. + *) + if (compareDate^.wYear = 0) then + begin + (* compareDate.wDay is interpreted as number of the week in the month + * 5 means: the last week in the month *) + weekofmonth := compareDate^.wDay; + (* calculate the day of the first DayOfWeek in the month *) + First := (6 + compareDate^.wDayOfWeek - date^.wDayOfWeek + date^.wDay) mod 7 + 1; + limit_day := First + 7 * (weekofmonth - 1); + (* check needed for the 5th weekday of the month *) + if (limit_day > MonthDays[(date^.wMonth=2) and IsLeapYear(date^.wYear)][date^.wMonth]) then + dec(limit_day, 7); + end + else + limit_day := compareDate^.wDay; + + (* convert to seconds *) + limit_day := ((limit_day * 24 + compareDate^.wHour) * 60 + compareDate^.wMinute ) * 60; + dayinsecs := ((date^.wDay * 24 + date^.wHour) * 60 + date^.wMinute ) * 60 + date^.wSecond; + (* and compare *) + + if dayinsecs < limit_day then + Result := -1 else + if dayinsecs > limit_day then + Result := 1 else + Result := 0; (* date is equal to the date limit. *) +end; + +function CompTimeZoneID(const pTZinfo: PTimeZoneInformation; + lpFileTime: PFileTime; islocal: Boolean): LongWord; +var + ret: Integer; + beforeStandardDate, afterDaylightDate: Boolean; + llTime: Int64; + SysTime: TSystemTime; + ftTemp: TFileTime; +begin + llTime := 0; + + if (pTZinfo^.DaylightDate.wMonth <> 0) then + begin + (* if year is 0 then date is in day-of-week format, otherwise + * it's absolute date. + *) + if ((pTZinfo^.StandardDate.wMonth = 0) or + ((pTZinfo^.StandardDate.wYear = 0) and + ((pTZinfo^.StandardDate.wDay < 1) or + (pTZinfo^.StandardDate.wDay > 5) or + (pTZinfo^.DaylightDate.wDay < 1) or + (pTZinfo^.DaylightDate.wDay > 5)))) then + begin + SetLastError(ERROR_INVALID_PARAMETER); + Result := TIME_ZONE_ID_INVALID; + Exit; + end; + + if (not islocal) then + begin + llTime := PInt64(lpFileTime)^; + dec(llTime, Int64(pTZinfo^.Bias + pTZinfo^.DaylightBias) * 600000000); + PInt64(@ftTemp)^ := llTime; + lpFileTime := @ftTemp; + end; + + FileTimeToSystemTime(lpFileTime^, SysTime); + + (* check for daylight savings *) + ret := DayLightCompareDate(@SysTime, @pTZinfo^.StandardDate); + if (ret = -2) then + begin + Result := TIME_ZONE_ID_INVALID; + Exit; + end; + + beforeStandardDate := ret < 0; + + if (not islocal) then + begin + dec(llTime, Int64(pTZinfo^.StandardBias - pTZinfo^.DaylightBias) * 600000000); + PInt64(@ftTemp)^ := llTime; + FileTimeToSystemTime(lpFileTime^, SysTime); + end; + + ret := DayLightCompareDate(@SysTime, @pTZinfo^.DaylightDate); + if (ret = -2) then + begin + Result := TIME_ZONE_ID_INVALID; + Exit; + end; + + afterDaylightDate := ret >= 0; + + Result := TIME_ZONE_ID_STANDARD; + if( pTZinfo^.DaylightDate.wMonth < pTZinfo^.StandardDate.wMonth ) then + begin + (* Northern hemisphere *) + if( beforeStandardDate and afterDaylightDate) then + Result := TIME_ZONE_ID_DAYLIGHT; + end else (* Down south *) + if( beforeStandardDate or afterDaylightDate) then + Result := TIME_ZONE_ID_DAYLIGHT; + end else + (* No transition date *) + Result := TIME_ZONE_ID_UNKNOWN; +end; + +function GetTimezoneBias(const pTZinfo: PTimeZoneInformation; + lpFileTime: PFileTime; islocal: Boolean; pBias: PLongint): Boolean; +var + bias: LongInt; + tzid: LongWord; +begin + bias := pTZinfo^.Bias; + tzid := CompTimeZoneID(pTZinfo, lpFileTime, islocal); + + if( tzid = TIME_ZONE_ID_INVALID) then + begin + Result := False; + Exit; + end; + if (tzid = TIME_ZONE_ID_DAYLIGHT) then + inc(bias, pTZinfo^.DaylightBias) + else if (tzid = TIME_ZONE_ID_STANDARD) then + inc(bias, pTZinfo^.StandardBias); + pBias^ := bias; + Result := True; +end; + +function SystemTimeToTzSpecificLocalTime( + lpTimeZoneInformation: PTimeZoneInformation; + lpUniversalTime, lpLocalTime: PSystemTime): BOOL; +var + ft: TFileTime; + lBias: LongInt; + llTime: Int64; + tzinfo: TTimeZoneInformation; +begin + if (lpTimeZoneInformation <> nil) then + tzinfo := lpTimeZoneInformation^ else + if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then + begin + Result := False; + Exit; + end; + + if (not SystemTimeToFileTime(lpUniversalTime^, ft)) then + begin + Result := False; + Exit; + end; + llTime := PInt64(@ft)^; + if (not GetTimezoneBias(@tzinfo, @ft, False, @lBias)) then + begin + Result := False; + Exit; + end; + (* convert minutes to 100-nanoseconds-ticks *) + dec(llTime, Int64(lBias) * 600000000); + PInt64(@ft)^ := llTime; + Result := FileTimeToSystemTime(ft, lpLocalTime^); +end; + +function TzSpecificLocalTimeToSystemTime( + const lpTimeZoneInformation: PTimeZoneInformation; + const lpLocalTime: PSystemTime; lpUniversalTime: PSystemTime): BOOL; +var + ft: TFileTime; + lBias: LongInt; + t: Int64; + tzinfo: TTimeZoneInformation; +begin + if (lpTimeZoneInformation <> nil) then + tzinfo := lpTimeZoneInformation^ + else + if (GetTimeZoneInformation(tzinfo) = TIME_ZONE_ID_INVALID) then + begin + Result := False; + Exit; + end; + + if (not SystemTimeToFileTime(lpLocalTime^, ft)) then + begin + Result := False; + Exit; + end; + t := PInt64(@ft)^; + if (not GetTimezoneBias(@tzinfo, @ft, True, @lBias)) then + begin + Result := False; + Exit; + end; + (* convert minutes to 100-nanoseconds-ticks *) + inc(t, Int64(lBias) * 600000000); + PInt64(@ft)^ := t; + Result := FileTimeToSystemTime(ft, lpUniversalTime^); +end; +{$ELSE} +function TzSpecificLocalTimeToSystemTime( + lpTimeZoneInformation: PTimeZoneInformation; + lpLocalTime, lpUniversalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll'; + +function SystemTimeToTzSpecificLocalTime( + lpTimeZoneInformation: PTimeZoneInformation; + lpUniversalTime, lpLocalTime: PSystemTime): BOOL; stdcall; external 'kernel32.dll'; +{$ENDIF} + +function JavaToDelphiDateTime(const dt: int64): TDateTime; +var + t: TSystemTime; +begin + DateTimeToSystemTime(25569 + (dt / 86400000), t); + SystemTimeToTzSpecificLocalTime(nil, @t, @t); + Result := SystemTimeToDateTime(t); +end; + +function DelphiToJavaDateTime(const dt: TDateTime): int64; +var + t: TSystemTime; +begin + DateTimeToSystemTime(dt, t); + TzSpecificLocalTimeToSystemTime(nil, @t, @t); + Result := Round((SystemTimeToDateTime(t) - 25569) * 86400000) +end; +{$ENDIF} + +function ISO8601DateToJavaDateTime(const str: SOString; var ms: Int64): Boolean; +type + TState = ( + stStart, stYear, stMonth, stWeek, stWeekDay, stDay, stDayOfYear, + stHour, stMin, stSec, stMs, stUTC, stGMTH, stGMTM, + stGMTend, stEnd); + + TPerhaps = (yes, no, perhaps); + TDateTimeInfo = record + year: Word; + month: Word; + week: Word; + weekday: Word; + day: Word; + dayofyear: Integer; + hour: Word; + minute: Word; + second: Word; + ms: Word; + bias: Integer; + end; + +var + p: PSOChar; + state: TState; + pos, v: Word; + sep: TPerhaps; + inctz, havetz, havedate: Boolean; + st: TDateTimeInfo; + DayTable: PDayTable; + + function get(var v: Word; c: SOChar): Boolean; {$IFDEF HAVE_INLINE} inline;{$ENDIF} + begin + if (c < #256) and (AnsiChar(c) in ['0'..'9']) then + begin + Result := True; + v := v * 10 + Ord(c) - Ord('0'); + end else + Result := False; + end; + +label + error; +begin + p := PSOChar(str); + sep := perhaps; + state := stStart; + pos := 0; + FillChar(st, SizeOf(st), 0); + havedate := True; + inctz := False; + havetz := False; + + while true do + case state of + stStart: + case p^ of + '0'..'9': state := stYear; + 'T', 't': + begin + state := stHour; + pos := 0; + inc(p); + havedate := False; + end; + else + goto error; + end; + stYear: + case pos of + 0..1,3: + if get(st.year, p^) then + begin + Inc(pos); + Inc(p); + end else + goto error; + 2: case p^ of + '0'..'9': + begin + st.year := st.year * 10 + ord(p^) - ord('0'); + Inc(pos); + Inc(p); + end; + ':': + begin + havedate := false; + st.hour := st.year; + st.year := 0; + inc(p); + pos := 0; + state := stMin; + sep := yes; + end; + else + goto error; + end; + 4: case p^ of + '-': begin + pos := 0; + Inc(p); + sep := yes; + state := stMonth; + end; + '0'..'9': + begin + sep := no; + pos := 0; + state := stMonth; + end; + 'W', 'w' : + begin + pos := 0; + Inc(p); + state := stWeek; + end; + 'T', 't', ' ': + begin + state := stHour; + pos := 0; + inc(p); + st.month := 1; + st.day := 1; + end; + #0: + begin + st.month := 1; + st.day := 1; + state := stEnd; + end; + else + goto error; + end; + end; + stMonth: + case pos of + 0: case p^ of + '0'..'9': + begin + st.month := ord(p^) - ord('0'); + Inc(pos); + Inc(p); + end; + 'W', 'w': + begin + pos := 0; + Inc(p); + state := stWeek; + end; + else + goto error; + end; + 1: if get(st.month, p^) then + begin + Inc(pos); + Inc(p); + end else + goto error; + 2: case p^ of + '-': + if (sep in [yes, perhaps]) then + begin + pos := 0; + Inc(p); + state := stDay; + sep := yes; + end else + goto error; + '0'..'9': + if sep in [no, perhaps] then + begin + pos := 0; + state := stDay; + sep := no; + end else + begin + st.dayofyear := st.month * 10 + Ord(p^) - Ord('0'); + st.month := 0; + inc(p); + pos := 3; + state := stDayOfYear; + end; + 'T', 't', ' ': + begin + state := stHour; + pos := 0; + inc(p); + st.day := 1; + end; + #0: + begin + st.day := 1; + state := stEnd; + end; + else + goto error; + end; + end; + stDay: + case pos of + 0: if get(st.day, p^) then + begin + Inc(pos); + Inc(p); + end else + goto error; + 1: if get(st.day, p^) then + begin + Inc(pos); + Inc(p); + end else + if sep in [no, perhaps] then + begin + st.dayofyear := st.month * 10 + st.day; + st.day := 0; + st.month := 0; + state := stDayOfYear; + end else + goto error; + + 2: case p^ of + 'T', 't', ' ': + begin + pos := 0; + Inc(p); + state := stHour; + end; + #0: state := stEnd; + else + goto error; + end; + end; + stDayOfYear: + begin + if (st.dayofyear <= 0) then goto error; + case p^ of + 'T', 't', ' ': + begin + pos := 0; + Inc(p); + state := stHour; + end; + #0: state := stEnd; + else + goto error; + end; + end; + stWeek: + begin + case pos of + 0..1: if get(st.week, p^) then + begin + inc(pos); + inc(p); + end else + goto error; + 2: case p^ of + '-': if (sep in [yes, perhaps]) then + begin + Inc(p); + state := stWeekDay; + sep := yes; + end else + goto error; + '1'..'7': + if sep in [no, perhaps] then + begin + state := stWeekDay; + sep := no; + end else + goto error; + else + goto error; + end; + end; + end; + stWeekDay: + begin + if (st.week > 0) and get(st.weekday, p^) then + begin + inc(p); + v := st.year - 1; + v := ((v * 365) + (v div 4) - (v div 100) + (v div 400)) mod 7 + 1; + st.dayofyear := (st.weekday - v) + ((st.week) * 7) + 1; + if v <= 4 then dec(st.dayofyear, 7); + case p^ of + 'T', 't', ' ': + begin + pos := 0; + Inc(p); + state := stHour; + end; + #0: state := stEnd; + else + goto error; + end; + end else + goto error; + end; + stHour: + case pos of + 0: case p^ of + '0'..'9': + if get(st.hour, p^) then + begin + inc(pos); + inc(p); + end else + goto error; + '-': + begin + inc(p); + state := stMin; + end; + else + goto error; + end; + 1: if get(st.hour, p^) then + begin + inc(pos); + inc(p); + end else + goto error; + 2: case p^ of + ':': if sep in [yes, perhaps] then + begin + sep := yes; + pos := 0; + Inc(p); + state := stMin; + end else + goto error; + ',', '.': + begin + Inc(p); + state := stMs; + end; + '+': + if havedate then + begin + state := stGMTH; + pos := 0; + v := 0; + inc(p); + end else + goto error; + '-': + if havedate then + begin + state := stGMTH; + pos := 0; + v := 0; + inc(p); + inctz := True; + end else + goto error; + 'Z', 'z': + if havedate then + state := stUTC else + goto error; + '0'..'9': + if sep in [no, perhaps] then + begin + pos := 0; + state := stMin; + sep := no; + end else + goto error; + #0: state := stEnd; + else + goto error; + end; + end; + stMin: + case pos of + 0: case p^ of + '0'..'9': + if get(st.minute, p^) then + begin + inc(pos); + inc(p); + end else + goto error; + '-': + begin + inc(p); + state := stSec; + end; + else + goto error; + end; + 1: if get(st.minute, p^) then + begin + inc(pos); + inc(p); + end else + goto error; + 2: case p^ of + ':': if sep in [yes, perhaps] then + begin + pos := 0; + Inc(p); + state := stSec; + sep := yes; + end else + goto error; + ',', '.': + begin + Inc(p); + state := stMs; + end; + '+': + if havedate then + begin + state := stGMTH; + pos := 0; + v := 0; + inc(p); + end else + goto error; + '-': + if havedate then + begin + state := stGMTH; + pos := 0; + v := 0; + inc(p); + inctz := True; + end else + goto error; + 'Z', 'z': + if havedate then + state := stUTC else + goto error; + '0'..'9': + if sep in [no, perhaps] then + begin + pos := 0; + state := stSec; + end else + goto error; + #0: state := stEnd; + else + goto error; + end; + end; + stSec: + case pos of + 0..1: if get(st.second, p^) then + begin + inc(pos); + inc(p); + end else + goto error; + 2: case p^ of + ',', '.': + begin + Inc(p); + state := stMs; + end; + '+': + if havedate then + begin + state := stGMTH; + pos := 0; + v := 0; + inc(p); + end else + goto error; + '-': + if havedate then + begin + state := stGMTH; + pos := 0; + v := 0; + inc(p); + inctz := True; + end else + goto error; + 'Z', 'z': + if havedate then + state := stUTC else + goto error; + #0: state := stEnd; + else + goto error; + end; + end; + stMs: + case p^ of + '0'..'9': + begin + st.ms := st.ms * 10 + ord(p^) - ord('0'); + inc(p); + end; + '+': + if havedate then + begin + state := stGMTH; + pos := 0; + v := 0; + inc(p); + end else + goto error; + '-': + if havedate then + begin + state := stGMTH; + pos := 0; + v := 0; + inc(p); + inctz := True; + end else + goto error; + 'Z', 'z': + if havedate then + state := stUTC else + goto error; + #0: state := stEnd; + else + goto error; + end; + stUTC: // = GMT 0 + begin + havetz := True; + inc(p); + if p^ = #0 then + Break else + goto error; + end; + stGMTH: + begin + havetz := True; + case pos of + 0..1: if get(v, p^) then + begin + inc(p); + inc(pos); + end else + goto error; + 2: + begin + st.bias := v * 60; + case p^ of + ':': if sep in [yes, perhaps] then + begin + state := stGMTM; + inc(p); + pos := 0; + v := 0; + sep := yes; + end else + goto error; + '0'..'9': + if sep in [no, perhaps] then + begin + state := stGMTM; + pos := 1; + sep := no; + inc(p); + v := ord(p^) - ord('0'); + end else + goto error; + #0: state := stGMTend; + else + goto error; + end; + + end; + end; + end; + stGMTM: + case pos of + 0..1: if get(v, p^) then + begin + inc(p); + inc(pos); + end else + goto error; + 2: case p^ of + #0: + begin + state := stGMTend; + inc(st.Bias, v); + end; + else + goto error; + end; + end; + stGMTend: + begin + if not inctz then + st.Bias := -st.bias; + Break; + end; + stEnd: + begin + + Break; + end; + end; + + if (st.hour >= 24) or (st.minute >= 60) or (st.second >= 60) or (st.ms >= 1000) or (st.week > 53) + then goto error; + + if not havetz then + st.bias := GetTimeBias; + + ms := st.ms + st.second * 1000 + (st.minute + st.bias) * 60000 + st.hour * 3600000; + if havedate then + begin + DayTable := @MonthDays[IsLeapYear(st.year)]; + if st.month <> 0 then + begin + if not (st.month in [1..12]) or (DayTable^[st.month] < st.day) then + goto error; + + for v := 1 to st.month - 1 do + Inc(ms, DayTable^[v] * 86400000); + end; + dec(st.year); + ms := ms + (int64((st.year * 365) + (st.year div 4) - (st.year div 100) + + (st.year div 400) + st.day + st.dayofyear - 719163) * 86400000); + end; + + Result := True; + Exit; +error: + Result := False; +end; + +function ISO8601DateToDelphiDateTime(const str: SOString; var dt: TDateTime): Boolean; +var + ms: Int64; +begin + Result := ISO8601DateToJavaDateTime(str, ms); + if Result then + dt := JavaToDelphiDateTime(ms) +end; + +function DelphiDateTimeToISO8601Date(dt: TDateTime): SOString; +var + year, month, day, hour, min, sec, msec: Word; + tzh: SmallInt; + tzm: Word; + sign: SOChar; + bias: Integer; +begin + DecodeDate(dt, year, month, day); + DecodeTime(dt, hour, min, sec, msec); + bias := GetTimeBias; + tzh := Abs(bias) div 60; + tzm := Abs(bias) - tzh * 60; + if Bias > 0 then + sign := '-' else + sign := '+'; + Result := Format('%.4d-%.2d-%.2dT%.2d:%.2d:%.2d,%d%s%.2d:%.2d', + [year, month, day, hour, min, sec, msec, sign, tzh, tzm]); +end; + +function TryObjectToDate(const obj: ISuperObject; var dt: TDateTime): Boolean; +var + i: Int64; +begin + case ObjectGetType(obj) of + stInt: + begin + dt := JavaToDelphiDateTime(obj.AsInteger); + Result := True; + end; + stString: + begin + if ISO8601DateToJavaDateTime(obj.AsString, i) then + begin + dt := JavaToDelphiDateTime(i); + Result := True; + end else + Result := TryStrToDateTime(obj.AsString, dt); + end; + else + Result := False; + end; +end; + +function SO(const s: SOString): ISuperObject; overload; +begin + Result := TSuperObject.ParseString(PSOChar(s), False); +end; + +function SA(const Args: array of const): ISuperObject; overload; +type + TByteArray = array[0..sizeof(integer) - 1] of byte; + PByteArray = ^TByteArray; +var + j: Integer; + intf: IInterface; +begin + Result := TSuperObject.Create(stArray); + for j := 0 to length(Args) - 1 do + with Result.AsArray do + case TVarRec(Args[j]).VType of + vtInteger : Add(TSuperObject.Create(TVarRec(Args[j]).VInteger)); + vtInt64 : Add(TSuperObject.Create(TVarRec(Args[j]).VInt64^)); + vtBoolean : Add(TSuperObject.Create(TVarRec(Args[j]).VBoolean)); + vtChar : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VChar))); + vtWideChar: Add(TSuperObject.Create(SOChar(TVarRec(Args[j]).VWideChar))); + vtExtended: Add(TSuperObject.Create(TVarRec(Args[j]).VExtended^)); + vtCurrency: Add(TSuperObject.CreateCurrency(TVarRec(Args[j]).VCurrency^)); + vtString : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VString^))); + vtPChar : Add(TSuperObject.Create(SOString(TVarRec(Args[j]).VPChar^))); + vtAnsiString: Add(TSuperObject.Create(SOString(AnsiString(TVarRec(Args[j]).VAnsiString)))); + vtWideString: Add(TSuperObject.Create(SOString(PWideChar(TVarRec(Args[j]).VWideString)))); + vtInterface: + if TVarRec(Args[j]).VInterface = nil then + Add(nil) else + if IInterface(TVarRec(Args[j]).VInterface).QueryInterface(ISuperObject, intf) = 0 then + Add(ISuperObject(intf)) else + Add(nil); + vtPointer : + if TVarRec(Args[j]).VPointer = nil then + Add(nil) else + Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer))); + vtVariant: + Add(SO(TVarRec(Args[j]).VVariant^)); + vtObject: + if TVarRec(Args[j]).VPointer = nil then + Add(nil) else + Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer))); + vtClass: + if TVarRec(Args[j]).VPointer = nil then + Add(nil) else + Add(TSuperObject.Create(PtrInt(TVarRec(Args[j]).VPointer))); +{$if declared(vtUnicodeString)} + vtUnicodeString: + Add(TSuperObject.Create(SOString(string(TVarRec(Args[j]).VUnicodeString)))); +{$ifend} + else + assert(false); + end; +end; + +function SO(const Args: array of const): ISuperObject; overload; +var + j: Integer; + arr: ISuperObject; +begin + Result := TSuperObject.Create(stObject); + arr := SA(Args); + with arr.AsArray do + for j := 0 to (Length div 2) - 1 do + Result.AsObject.PutO(O[j*2].AsString, O[(j*2) + 1]); +end; + +function SO(const value: Variant): ISuperObject; overload; +begin + with TVarData(value) do + case VType of + varNull: Result := nil; + varEmpty: Result := nil; + varSmallInt: Result := TSuperObject.Create(VSmallInt); + varInteger: Result := TSuperObject.Create(VInteger); + varSingle: Result := TSuperObject.Create(VSingle); + varDouble: Result := TSuperObject.Create(VDouble); + varCurrency: Result := TSuperObject.CreateCurrency(VCurrency); + varDate: Result := TSuperObject.Create(DelphiToJavaDateTime(vDate)); + varOleStr: Result := TSuperObject.Create(SOString(VOleStr)); + varBoolean: Result := TSuperObject.Create(VBoolean); + varShortInt: Result := TSuperObject.Create(VShortInt); + varByte: Result := TSuperObject.Create(VByte); + varWord: Result := TSuperObject.Create(VWord); + varLongWord: Result := TSuperObject.Create(VLongWord); + varInt64: Result := TSuperObject.Create(VInt64); + varString: Result := TSuperObject.Create(SOString(AnsiString(VString))); +{$if declared(varUString)} + {$IFDEF FPC} + varUString: Result := TSuperObject.Create(SOString(UnicodeString(VString))); + {$ELSE} + varUString: Result := TSuperObject.Create(SOString(string(VUString))); + {$ENDIF} +{$ifend} + else + raise Exception.CreateFmt('Unsuported variant data type: %d', [VType]); + end; +end; + +function ObjectIsError(obj: TSuperObject): boolean; +begin + Result := PtrUInt(obj) > PtrUInt(-4000); +end; + +function ObjectIsType(const obj: ISuperObject; typ: TSuperType): boolean; +begin + if obj <> nil then + Result := typ = obj.DataType else + Result := typ = stNull; +end; + +function ObjectGetType(const obj: ISuperObject): TSuperType; +begin + if obj <> nil then + Result := obj.DataType else + Result := stNull; +end; + +function ObjectIsNull(const obj: ISuperObject): Boolean; +begin + Result := ObjectIsType(obj, stNull); +end; + +function ObjectFindFirst(const obj: ISuperObject; var F: TSuperObjectIter): boolean; +var + i: TSuperAvlEntry; +begin + if ObjectIsType(obj, stObject) then + begin + F.Ite := TSuperAvlIterator.Create(obj.AsObject); + F.Ite.First; + i := F.Ite.GetIter; + if i <> nil then + begin + f.key := i.Name; + f.val := i.Value; + Result := true; + end else + Result := False; + end else + Result := False; +end; + +function ObjectFindNext(var F: TSuperObjectIter): boolean; +var + i: TSuperAvlEntry; +begin + F.Ite.Next; + i := F.Ite.GetIter; + if i <> nil then + begin + f.key := i.FName; + f.val := i.Value; + Result := true; + end else + Result := False; +end; + +procedure ObjectFindClose(var F: TSuperObjectIter); +begin + F.Ite.Free; + F.val := nil; +end; + +function UuidFromString(p: PSOChar; Uuid: PGUID): Boolean; +const + hex2bin: array[48..102] of Byte = ( + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, + 0,10,11,12,13,14,15, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0,10,11,12,13,14,15); +type + TState = (stEatSpaces, stStart, stHEX, stBracket, stEnd); + TUUID = record + case byte of + 0: (guid: TGUID); + 1: (bytes: array[0..15] of Byte); + 2: (words: array[0..7] of Word); + 3: (ints: array[0..3] of Cardinal); + 4: (i64s: array[0..1] of UInt64); + end; + + function ishex(const c: SOChar): Boolean; {$IFDEF HAVE_INLINE} inline;{$ENDIF} + begin + result := (c < #256) and (AnsiChar(c) in ['0'..'9', 'a'..'z', 'A'..'Z']) + end; +var + pos: Byte; + state, saved: TState; + bracket, separator: Boolean; +label + redo; +begin + FillChar(Uuid^, SizeOf(TGUID), 0); + saved := stStart; + state := stEatSpaces; + bracket := false; + separator := false; + pos := 0; + while true do +redo: + case state of + stEatSpaces: + begin + while true do + case p^ of + ' ', #13, #10, #9: inc(p); + else + state := saved; + goto redo; + end; + end; + stStart: + case p^ of + '{': + begin + bracket := true; + inc(p); + state := stEatSpaces; + saved := stHEX; + pos := 0; + end; + else + state := stHEX; + end; + stHEX: + case pos of + 0..7: + if ishex(p^) then + begin + Uuid^.D1 := (Uuid^.D1 * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 8: + if (p^ = '-') then + begin + separator := true; + inc(p); + inc(pos) + end else + inc(pos); + 13,18,23: + if separator then + begin + if p^ <> '-' then + begin + Result := False; + Exit; + end; + inc(p); + inc(pos); + end else + inc(pos); + 9..12: + if ishex(p^) then + begin + TUUID(Uuid^).words[2] := (TUUID(Uuid^).words[2] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 14..17: + if ishex(p^) then + begin + TUUID(Uuid^).words[3] := (TUUID(Uuid^).words[3] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 19..20: + if ishex(p^) then + begin + TUUID(Uuid^).bytes[8] := (TUUID(Uuid^).bytes[8] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 21..22: + if ishex(p^) then + begin + TUUID(Uuid^).bytes[9] := (TUUID(Uuid^).bytes[9] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 24..25: + if ishex(p^) then + begin + TUUID(Uuid^).bytes[10] := (TUUID(Uuid^).bytes[10] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 26..27: + if ishex(p^) then + begin + TUUID(Uuid^).bytes[11] := (TUUID(Uuid^).bytes[11] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 28..29: + if ishex(p^) then + begin + TUUID(Uuid^).bytes[12] := (TUUID(Uuid^).bytes[12] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 30..31: + if ishex(p^) then + begin + TUUID(Uuid^).bytes[13] := (TUUID(Uuid^).bytes[13] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 32..33: + if ishex(p^) then + begin + TUUID(Uuid^).bytes[14] := (TUUID(Uuid^).bytes[14] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 34..35: + if ishex(p^) then + begin + TUUID(Uuid^).bytes[15] := (TUUID(Uuid^).bytes[15] * 16) + hex2bin[Ord(p^)]; + inc(p); + inc(pos); + end else + begin + Result := False; + Exit; + end; + 36: if bracket then + begin + state := stEatSpaces; + saved := stBracket; + end else + begin + state := stEatSpaces; + saved := stEnd; + end; + end; + stBracket: + begin + if p^ <> '}' then + begin + Result := False; + Exit; + end; + inc(p); + state := stEatSpaces; + saved := stEnd; + end; + stEnd: + begin + if p^ <> #0 then + begin + Result := False; + Exit; + end; + Break; + end; + end; + Result := True; +end; + +function UUIDToString(const g: TGUID): SOString; +begin + Result := format('%.8x%.4x%.4x%.2x%.2x%.2x%.2x%.2x%.2x%.2x%.2x', + [g.D1, g.D2, g.D3, + g.D4[0], g.D4[1], g.D4[2], + g.D4[3], g.D4[4], g.D4[5], + g.D4[6], g.D4[7]]); +end; + +function StringToUUID(const str: SOString; var g: TGUID): Boolean; +begin + Result := UuidFromString(PSOChar(str), @g); +end; + +{$IFDEF HAVE_RTTI} + +function serialtoboolean(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject; +begin + Result := TSuperObject.Create(TValueData(value).FAsSLong <> 0); +end; + +function serialtodatetime(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject; +begin + Result := TSuperObject.Create(DelphiToJavaDateTime(TValueData(value).FAsDouble)); +end; + +function serialtoguid(ctx: TSuperRttiContext; var value: TValue; const index: ISuperObject): ISuperObject; +var + g: TGUID; +begin + value.ExtractRawData(@g); + Result := TSuperObject.Create( + format('%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x', + [g.D1, g.D2, g.D3, + g.D4[0], g.D4[1], g.D4[2], + g.D4[3], g.D4[4], g.D4[5], + g.D4[6], g.D4[7]]) + ); +end; + +function serialfromboolean(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean; +var + o: ISuperObject; +begin + case ObjectGetType(obj) of + stBoolean: + begin + TValueData(Value).FAsSLong := obj.AsInteger; + Result := True; + end; + stInt: + begin + TValueData(Value).FAsSLong := ord(obj.AsInteger <> 0); + Result := True; + end; + stString: + begin + o := SO(obj.AsString); + if not ObjectIsType(o, stString) then + Result := serialfromboolean(ctx, SO(obj.AsString), Value) else + Result := False; + end; + else + Result := False; + end; +end; + +function serialfromdatetime(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean; +var + dt: TDateTime; + i: Int64; +begin + case ObjectGetType(obj) of + stInt: + begin + TValueData(Value).FAsDouble := JavaToDelphiDateTime(obj.AsInteger); + Result := True; + end; + stString: + begin + if ISO8601DateToJavaDateTime(obj.AsString, i) then + begin + TValueData(Value).FAsDouble := JavaToDelphiDateTime(i); + Result := True; + end else + if TryStrToDateTime(obj.AsString, dt) then + begin + TValueData(Value).FAsDouble := dt; + Result := True; + end else + Result := False; + end; + else + Result := False; + end; +end; + +function serialfromguid(ctx: TSuperRttiContext; const obj: ISuperObject; var Value: TValue): Boolean; +begin + case ObjectGetType(obj) of + stNull: + begin + FillChar(Value.GetReferenceToRawData^, SizeOf(TGUID), 0); + Result := True; + end; + stString: Result := UuidFromString(PSOChar(obj.AsString), Value.GetReferenceToRawData); + else + Result := False; + end; +end; + +function SOInvoke(const obj: TValue; const method: string; const params: ISuperObject; ctx: TSuperRttiContext): ISuperObject; overload; +var + owned: Boolean; +begin + if ctx = nil then + begin + ctx := TSuperRttiContext.Create; + owned := True; + end else + owned := False; + try + if TrySOInvoke(ctx, obj, method, params, Result) <> irSuccess then + raise Exception.Create('Invalid method call'); + finally + if owned then + ctx.Free; + end; +end; + +function SOInvoke(const obj: TValue; const method: string; const params: string; ctx: TSuperRttiContext): ISuperObject; overload; +begin + Result := SOInvoke(obj, method, so(params), ctx) +end; + +function TrySOInvoke(var ctx: TSuperRttiContext; const obj: TValue; + const method: string; const params: ISuperObject; + var Return: ISuperObject): TSuperInvokeResult; +var + t: TRttiInstanceType; + m: TRttiMethod; + a: TArray; + ps: TArray; + v: TValue; + index: ISuperObject; + + function GetParams: Boolean; + var + i: Integer; + begin + case ObjectGetType(params) of + stArray: + for i := 0 to Length(ps) - 1 do + if (pfOut in ps[i].Flags) then + TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else + if not ctx.FromJson(ps[i].ParamType.Handle, params.AsArray[i], a[i]) then + Exit(False); + stObject: + for i := 0 to Length(ps) - 1 do + if (pfOut in ps[i].Flags) then + TValue.Make(nil, ps[i].ParamType.Handle, a[i]) else + if not ctx.FromJson(ps[i].ParamType.Handle, params.AsObject[ps[i].Name], a[i]) then + Exit(False); + stNull: ; + else + Exit(False); + end; + Result := True; + end; + + procedure SetParams; + var + i: Integer; + begin + case ObjectGetType(params) of + stArray: + for i := 0 to Length(ps) - 1 do + if (ps[i].Flags * [pfVar, pfOut]) <> [] then + params.AsArray[i] := ctx.ToJson(a[i], index); + stObject: + for i := 0 to Length(ps) - 1 do + if (ps[i].Flags * [pfVar, pfOut]) <> [] then + params.AsObject[ps[i].Name] := ctx.ToJson(a[i], index); + end; + end; + +begin + Result := irSuccess; + index := SO; + case obj.Kind of + tkClass: + begin + t := TRttiInstanceType(ctx.Context.GetType(obj.AsObject.ClassType)); + m := t.GetMethod(method); + if m = nil then Exit(irMethothodError); + ps := m.GetParameters; + SetLength(a, Length(ps)); + if not GetParams then Exit(irParamError); + if m.IsClassMethod then + begin + v := m.Invoke(obj.AsObject.ClassType, a); + Return := ctx.ToJson(v, index); + SetParams; + end else + begin + v := m.Invoke(obj, a); + Return := ctx.ToJson(v, index); + SetParams; + end; + end; + tkClassRef: + begin + t := TRttiInstanceType(ctx.Context.GetType(obj.AsClass)); + m := t.GetMethod(method); + if m = nil then Exit(irMethothodError); + ps := m.GetParameters; + SetLength(a, Length(ps)); + + if not GetParams then Exit(irParamError); + if m.IsClassMethod then + begin + v := m.Invoke(obj, a); + Return := ctx.ToJson(v, index); + SetParams; + end else + Exit(irError); + end; + else + Exit(irError); + end; +end; + +{$ENDIF} + +{ TSuperEnumerator } + +constructor TSuperEnumerator.Create(const obj: ISuperObject); +begin + FObj := obj; + FCount := -1; + if ObjectIsType(FObj, stObject) then + FObjEnum := FObj.AsObject.GetEnumerator else + FObjEnum := nil; +end; + +destructor TSuperEnumerator.Destroy; +begin + if FObjEnum <> nil then + FObjEnum.Free; +end; + +function TSuperEnumerator.MoveNext: Boolean; +begin + case ObjectGetType(FObj) of + stObject: Result := FObjEnum.MoveNext; + stArray: + begin + inc(FCount); + if FCount < FObj.AsArray.Length then + Result := True else + Result := False; + end; + else + Result := false; + end; +end; + +function TSuperEnumerator.GetCurrent: ISuperObject; +begin + case ObjectGetType(FObj) of + stObject: Result := FObjEnum.Current.Value; + stArray: Result := FObj.AsArray.GetO(FCount); + else + Result := FObj; + end; +end; + +{ TSuperObject } + +constructor TSuperObject.Create(jt: TSuperType); +begin + inherited Create; +{$IFDEF DEBUG} + InterlockedIncrement(debugcount); +{$ENDIF} + + FProcessing := false; + FDataPtr := nil; + FDataType := jt; + case FDataType of + stObject: FO.c_object := TSuperTableString.Create; + stArray: FO.c_array := TSuperArray.Create; + stString: FOString := ''; + else + FO.c_object := nil; + end; +end; + +constructor TSuperObject.Create(b: boolean); +begin + Create(stBoolean); + FO.c_boolean := b; +end; + +constructor TSuperObject.Create(i: SuperInt); +begin + Create(stInt); + FO.c_int := i; +end; + +constructor TSuperObject.Create(d: double); +begin + Create(stDouble); + FO.c_double := d; +end; + +constructor TSuperObject.CreateCurrency(c: Currency); +begin + Create(stCurrency); + FO.c_currency := c; +end; + +destructor TSuperObject.Destroy; +begin +{$IFDEF DEBUG} + InterlockedDecrement(debugcount); +{$ENDIF} + case FDataType of + stObject: FO.c_object.Free; + stArray: FO.c_array.Free; + end; + inherited; +end; + +function TSuperObject.Write(writer: TSuperWriter; indent: boolean; escape: boolean; level: integer): Integer; +function DoEscape(str: PSOChar; len: Integer): Integer; +var + pos, start_offset: Integer; + c: SOChar; + buf: array[0..5] of SOChar; +type + TByteChar = record + case integer of + 0: (a, b: Byte); + 1: (c: WideChar); + end; + begin + if str = nil then + begin + Result := 0; + exit; + end; + pos := 0; start_offset := 0; + with writer do + while pos < len do + begin + c := str[pos]; + case c of + #8,#9,#10,#12,#13,'"','\','/': + begin + if(pos - start_offset > 0) then + Append(str + start_offset, pos - start_offset); + + if(c = #8) then Append(ESC_BS, 2) + else if (c = #9) then Append(ESC_TAB, 2) + else if (c = #10) then Append(ESC_LF, 2) + else if (c = #12) then Append(ESC_FF, 2) + else if (c = #13) then Append(ESC_CR, 2) + else if (c = '"') then Append(ESC_QUOT, 2) + else if (c = '\') then Append(ESC_SL, 2) + else if (c = '/') then Append(ESC_SR, 2); + inc(pos); + start_offset := pos; + end; + else + if (SOIChar(c) > 255) then + begin + if(pos - start_offset > 0) then + Append(str + start_offset, pos - start_offset); + buf[0] := '\'; + buf[1] := 'u'; + buf[2] := super_hex_chars[TByteChar(c).b shr 4]; + buf[3] := super_hex_chars[TByteChar(c).b and $f]; + buf[4] := super_hex_chars[TByteChar(c).a shr 4]; + buf[5] := super_hex_chars[TByteChar(c).a and $f]; + Append(@buf, 6); + inc(pos); + start_offset := pos; + end else + if (c < #32) or (c > #127) then + begin + if(pos - start_offset > 0) then + Append(str + start_offset, pos - start_offset); + buf[0] := '\'; + buf[1] := 'u'; + buf[2] := '0'; + buf[3] := '0'; + buf[4] := super_hex_chars[ord(c) shr 4]; + buf[5] := super_hex_chars[ord(c) and $f]; + Append(buf, 6); + inc(pos); + start_offset := pos; + end else + inc(pos); + end; + end; + if(pos - start_offset > 0) then + writer.Append(str + start_offset, pos - start_offset); + Result := 0; + end; + +function DoMinimalEscape(str: PSOChar; len: Integer): Integer; +var + pos, start_offset: Integer; + c: SOChar; +type + TByteChar = record + case integer of + 0: (a, b: Byte); + 1: (c: WideChar); + end; + begin + if str = nil then + begin + Result := 0; + exit; + end; + pos := 0; start_offset := 0; + with writer do + while pos < len do + begin + c := str[pos]; + case c of + #0: + begin + if(pos - start_offset > 0) then + Append(str + start_offset, pos - start_offset); + Append(ESC_ZERO, 6); + inc(pos); + start_offset := pos; + end; + '"': + begin + if(pos - start_offset > 0) then + Append(str + start_offset, pos - start_offset); + Append(ESC_QUOT, 2); + inc(pos); + start_offset := pos; + end; + '\': + begin + if(pos - start_offset > 0) then + Append(str + start_offset, pos - start_offset); + Append(ESC_SL, 2); + inc(pos); + start_offset := pos; + end; + else + inc(pos); + end; + end; + if(pos - start_offset > 0) then + writer.Append(str + start_offset, pos - start_offset); + Result := 0; + end; + + + procedure _indent(i: shortint; r: boolean); + begin + inc(level, i); + if r then + with writer do + begin +{$IFDEF MSWINDOWS} + Append(TOK_CRLF, 2); +{$ELSE} + Append(TOK_LF, 1); +{$ENDIF} + for i := 0 to level - 1 do + Append(TOK_SP, 1); + end; + end; +var + k,j: Integer; + iter: TSuperObjectIter; + st: AnsiString; + val: ISuperObject; +const + ENDSTR_A: PSOChar = '": '; + ENDSTR_B: PSOChar = '":'; +begin + + if FProcessing then + begin + Result := writer.Append(TOK_NULL, 4); + Exit; + end; + + FProcessing := true; + with writer do + try + case FDataType of + stObject: + if FO.c_object.FCount > 0 then + begin + k := 0; + Append(TOK_CBL, 1); + if indent then _indent(1, false); + if ObjectFindFirst(Self, iter) then + repeat + {$IFDEF SUPER_METHOD} + if (iter.val = nil) or not ObjectIsType(iter.val, stMethod) then + begin + {$ENDIF} + if (iter.val = nil) or (not iter.val.Processing) then + begin + if(k <> 0) then + Append(TOK_COM, 1); + if indent then _indent(0, true); + Append(TOK_DQT, 1); + if escape then + doEscape(PSOChar(iter.key), Length(iter.key)) else + DoMinimalEscape(PSOChar(iter.key), Length(iter.key)); + if indent then + Append(ENDSTR_A, 3) else + Append(ENDSTR_B, 2); + if(iter.val = nil) then + Append(TOK_NULL, 4) else + iter.val.write(writer, indent, escape, level); + inc(k); + end; + {$IFDEF SUPER_METHOD} + end; + {$ENDIF} + until not ObjectFindNext(iter); + ObjectFindClose(iter); + if indent then _indent(-1, true); + Result := Append(TOK_CBR, 1); + end else + Result := Append(TOK_OBJ, 2); + stBoolean: + begin + if (FO.c_boolean) then + Result := Append(TOK_TRUE, 4) else + Result := Append(TOK_FALSE, 5); + end; + stInt: + begin + str(FO.c_int, st); + Result := Append(PSOChar(SOString(st))); + end; + stDouble: + Result := Append(PSOChar(FloatToJson(FO.c_double))); + stCurrency: + begin + Result := Append(PSOChar(CurrToJson(FO.c_currency))); + end; + stString: + begin + Append(TOK_DQT, 1); + if escape then + doEscape(PSOChar(FOString), Length(FOString)) else + DoMinimalEscape(PSOChar(FOString), Length(FOString)); + Append(TOK_DQT, 1); + Result := 0; + end; + stArray: + if FO.c_array.FLength > 0 then + begin + Append(TOK_ARL, 1); + if indent then _indent(1, true); + k := 0; + j := 0; + while k < FO.c_array.FLength do + begin + + val := FO.c_array.GetO(k); + {$IFDEF SUPER_METHOD} + if not ObjectIsType(val, stMethod) then + begin + {$ENDIF} + if (val = nil) or (not val.Processing) then + begin + if (j <> 0) then + Append(TOK_COM, 1); + if(val = nil) then + Append(TOK_NULL, 4) else + val.write(writer, indent, escape, level); + inc(j); + end; + {$IFDEF SUPER_METHOD} + end; + {$ENDIF} + inc(k); + end; + if indent then _indent(-1, false); + Result := Append(TOK_ARR, 1); + end else + Result := Append(TOK_ARRAY, 2); + stNull: + Result := Append(TOK_NULL, 4); + else + Result := 0; + end; + finally + FProcessing := false; + end; +end; + +function TSuperObject.IsType(AType: TSuperType): boolean; +begin + Result := AType = FDataType; +end; + +function TSuperObject.AsBoolean: boolean; +begin + case FDataType of + stBoolean: Result := FO.c_boolean; + stInt: Result := (FO.c_int <> 0); + stDouble: Result := (FO.c_double <> 0); + stCurrency: Result := (FO.c_currency <> 0); + stString: Result := (Length(FOString) <> 0); + stNull: Result := False; + else + Result := True; + end; +end; + +function TSuperObject.AsInteger: SuperInt; +var + code: integer; + cint: SuperInt; +begin + case FDataType of + stInt: Result := FO.c_int; + stDouble: Result := round(FO.c_double); + stCurrency: Result := round(FO.c_currency); + stBoolean: Result := ord(FO.c_boolean); + stString: + begin + Val(FOString, cint, code); + if code = 0 then + Result := cint else + Result := 0; + end; + else + Result := 0; + end; +end; + +function TSuperObject.AsDouble: Double; +var + code: integer; + cdouble: double; +begin + case FDataType of + stDouble: Result := FO.c_double; + stCurrency: Result := FO.c_currency; + stInt: Result := FO.c_int; + stBoolean: Result := ord(FO.c_boolean); + stString: + begin + Val(FOString, cdouble, code); + if code = 0 then + Result := cdouble else + Result := 0.0; + end; + else + Result := 0.0; + end; +end; + +function TSuperObject.AsCurrency: Currency; +var + code: integer; + cdouble: double; +begin + case FDataType of + stDouble: Result := FO.c_double; + stCurrency: Result := FO.c_currency; + stInt: Result := FO.c_int; + stBoolean: Result := ord(FO.c_boolean); + stString: + begin + Val(FOString, cdouble, code); + if code = 0 then + Result := cdouble else + Result := 0.0; + end; + else + Result := 0.0; + end; +end; + +function TSuperObject.AsString: SOString; +begin + case FDataType of + stString: Result := FOString; + stNull: Result := ''; + else + Result := AsJSon(false, false); + end; +end; + +function TSuperObject.GetEnumerator: TSuperEnumerator; +begin + Result := TSuperEnumerator.Create(Self); +end; + +procedure TSuperObject.AfterConstruction; +begin + InterlockedDecrement(FRefCount); +end; + +procedure TSuperObject.BeforeDestruction; +begin + if RefCount <> 0 then + raise Exception.Create('Invalid pointer'); +end; + +function TSuperObject.AsArray: TSuperArray; +begin + if FDataType = stArray then + Result := FO.c_array else + Result := nil; +end; + +function TSuperObject.AsObject: TSuperTableString; +begin + if FDataType = stObject then + Result := FO.c_object else + Result := nil; +end; + +function TSuperObject.AsJSon(indent, escape: boolean): SOString; +var + pb: TSuperWriterString; +begin + pb := TSuperWriterString.Create; + try + if(Write(pb, indent, escape, 0) < 0) then + begin + Result := ''; + Exit; + end; + if pb.FBPos > 0 then + Result := pb.FBuf else + Result := ''; + finally + pb.Free; + end; +end; + +class function TSuperObject.ParseString(s: PSOChar; strict: Boolean; partial: boolean; const this: ISuperObject; + options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject; +var + tok: TSuperTokenizer; + obj: ISuperObject; +begin + tok := TSuperTokenizer.Create; + obj := ParseEx(tok, s, -1, strict, this, options, put, dt); + if(tok.err <> teSuccess) or (not partial and (s[tok.char_offset] <> #0)) then + Result := nil else + Result := obj; + tok.Free; +end; + +class function TSuperObject.ParseStream(stream: TStream; strict: Boolean; + partial: boolean; const this: ISuperObject; options: TSuperFindOptions; + const put: ISuperObject; dt: TSuperType): ISuperObject; +const + BUFFER_SIZE = 1024; +var + tok: TSuperTokenizer; + buffera: array[0..BUFFER_SIZE-1] of AnsiChar; + bufferw: array[0..BUFFER_SIZE-1] of SOChar; + bom: array[0..1] of byte; + unicode: boolean; + j, size: Integer; + st: string; +begin + st := ''; + tok := TSuperTokenizer.Create; + + if (stream.Read(bom, sizeof(bom)) = 2) and (bom[0] = $FF) and (bom[1] = $FE) then + begin + unicode := true; + size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar); + end else + begin + unicode := false; + stream.Seek(0, soFromBeginning); + size := stream.Read(buffera, BUFFER_SIZE); + end; + + while size > 0 do + begin + if not unicode then + for j := 0 to size - 1 do + bufferw[j] := SOChar(buffera[j]); + ParseEx(tok, bufferw, size, strict, this, options, put, dt); + + if tok.err = teContinue then + begin + if not unicode then + size := stream.Read(buffera, BUFFER_SIZE) else + size := stream.Read(bufferw, BUFFER_SIZE * SizeOf(SoChar)) div SizeOf(SoChar); + end else + Break; + end; + if(tok.err <> teSuccess) or (not partial and (st[tok.char_offset] <> #0)) then + Result := nil else + Result := tok.stack[tok.depth].current; + tok.Free; +end; + +class function TSuperObject.ParseFile(const FileName: string; strict: Boolean; + partial: boolean; const this: ISuperObject; options: TSuperFindOptions; + const put: ISuperObject; dt: TSuperType): ISuperObject; +var + stream: TFileStream; +begin + stream := TFileStream.Create(FileName, fmOpenRead, fmShareDenyWrite); + try + Result := ParseStream(stream, strict, partial, this, options, put, dt); + finally + stream.Free; + end; +end; + +class function TSuperObject.ParseEx(tok: TSuperTokenizer; str: PSOChar; len: integer; + strict: Boolean; const this: ISuperObject; options: TSuperFindOptions; const put: ISuperObject; dt: TSuperType): ISuperObject; + +const + spaces = [#32,#8,#9,#10,#12,#13]; + delimiters = ['"', '.', '[', ']', '{', '}', '(', ')', ',', ':', #0]; + reserved = delimiters + spaces; + path = ['a'..'z', 'A'..'Z', '.', '_']; + + function hexdigit(x: SOChar): byte; {$IFDEF HAVE_INLINE} inline;{$ENDIF} + begin + if x <= '9' then + Result := byte(x) - byte('0') else + Result := (byte(x) and 7) + 9; + end; + function min(v1, v2: integer): integer;{$IFDEF HAVE_INLINE} inline;{$ENDIF} + begin if v1 < v2 then result := v1 else result := v2 end; + +var + obj: ISuperObject; + v: SOChar; +{$IFDEF SUPER_METHOD} + sm: TSuperMethod; +{$ENDIF} + numi: SuperInt; + numd: Double; + code: integer; + TokRec: PSuperTokenerSrec; + evalstack: integer; + p: PSOChar; + + function IsEndDelimiter(v: AnsiChar): Boolean; + begin + if tok.depth > 0 then + case tok.stack[tok.depth - 1].state of + tsArrayAdd: Result := v in [',', ']', #0]; + tsObjectValueAdd: Result := v in [',', '}', #0]; + else + Result := v = #0; + end else + Result := v = #0; + end; + +label out, redo_char; +begin + evalstack := 0; + obj := nil; + Result := nil; + TokRec := @tok.stack[tok.depth]; + + tok.char_offset := 0; + tok.err := teSuccess; + + repeat + if (tok.char_offset = len) then + begin + if (tok.depth = 0) and (TokRec^.state = tsEatws) and + (TokRec^.saved_state = tsFinish) then + tok.err := teSuccess else + tok.err := teContinue; + goto out; + end; + + v := str^; + + case v of + #10: + begin + inc(tok.line); + tok.col := 0; + end; + #9: inc(tok.col, 4); + else + inc(tok.col); + end; + +redo_char: + case TokRec^.state of + tsEatws: + begin + if (SOIChar(v) < 256) and (AnsiChar(v) in spaces) then {nop} else + if (v = '/') then + begin + tok.pb.Reset; + tok.pb.Append(@v, 1); + TokRec^.state := tsCommentStart; + end else begin + TokRec^.state := TokRec^.saved_state; + goto redo_char; + end + end; + + tsStart: + case v of + '"', + '''': + begin + TokRec^.state := tsString; + tok.pb.Reset; + tok.quote_char := v; + end; + '-': + begin + TokRec^.state := tsNumber; + tok.pb.Reset; + tok.is_double := 0; + tok.floatcount := -1; + goto redo_char; + end; + + '0'..'9': + begin + if (tok.depth = 0) then + case ObjectGetType(this) of + stObject: + begin + TokRec^.state := tsIdentifier; + TokRec^.current := this; + goto redo_char; + end; + end; + TokRec^.state := tsNumber; + tok.pb.Reset; + tok.is_double := 0; + tok.floatcount := -1; + goto redo_char; + end; + '{': + begin + TokRec^.state := tsEatws; + TokRec^.saved_state := tsObjectFieldStart; + TokRec^.current := TSuperObject.Create(stObject); + end; + '[': + begin + TokRec^.state := tsEatws; + TokRec^.saved_state := tsArray; + TokRec^.current := TSuperObject.Create(stArray); + end; +{$IFDEF SUPER_METHOD} + '(': + begin + if (tok.depth = 0) and ObjectIsType(this, stMethod) then + begin + TokRec^.current := this; + TokRec^.state := tsParamValue; + end; + end; +{$ENDIF} + 'N', + 'n': + begin + TokRec^.state := tsNull; + tok.pb.Reset; + tok.st_pos := 0; + goto redo_char; + end; + 'T', + 't', + 'F', + 'f': + begin + TokRec^.state := tsBoolean; + tok.pb.Reset; + tok.st_pos := 0; + goto redo_char; + end; + else + TokRec^.state := tsIdentifier; + tok.pb.Reset; + goto redo_char; + end; + + tsFinish: + begin + if(tok.depth = 0) then goto out; + obj := TokRec^.current; + tok.ResetLevel(tok.depth); + dec(tok.depth); + TokRec := @tok.stack[tok.depth]; + goto redo_char; + end; + + tsNull: + begin + tok.pb.Append(@v, 1); + if (StrLComp(TOK_NULL, PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then + begin + if (tok.st_pos = 4) then + if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then + TokRec^.state := tsIdentifier else + begin + TokRec^.current := TSuperObject.Create(stNull); + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + goto redo_char; + end; + end else + begin + TokRec^.state := tsIdentifier; + tok.pb.FBuf[tok.st_pos] := #0; + dec(tok.pb.FBPos); + goto redo_char; + end; + inc(tok.st_pos); + end; + + tsCommentStart: + begin + if(v = '*') then + begin + TokRec^.state := tsComment; + end else + if (v = '/') then + begin + TokRec^.state := tsCommentEol; + end else + begin + tok.err := teParseComment; + goto out; + end; + tok.pb.Append(@v, 1); + end; + + tsComment: + begin + if(v = '*') then + TokRec^.state := tsCommentEnd; + tok.pb.Append(@v, 1); + end; + + tsCommentEol: + begin + if (v = #10) then + TokRec^.state := tsEatws else + tok.pb.Append(@v, 1); + end; + + tsCommentEnd: + begin + tok.pb.Append(@v, 1); + if (v = '/') then + TokRec^.state := tsEatws else + TokRec^.state := tsComment; + end; + + tsString: + begin + if (v = tok.quote_char) then + begin + TokRec^.current := TSuperObject.Create(SOString(tok.pb.GetString)); + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + end else + if (v = '\') then + begin + TokRec^.saved_state := tsString; + TokRec^.state := tsStringEscape; + end else + begin + tok.pb.Append(@v, 1); + end + end; + + tsEvalProperty: + begin + if (TokRec^.current = nil) and (foCreatePath in options) then + begin + TokRec^.current := TSuperObject.Create(stObject); + TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current) + end else + if not ObjectIsType(TokRec^.current, stObject) then + begin + tok.err := teEvalObject; + goto out; + end; + tok.pb.Reset; + TokRec^.state := tsIdentifier; + goto redo_char; + end; + + tsEvalArray: + begin + if (TokRec^.current = nil) and (foCreatePath in options) then + begin + TokRec^.current := TSuperObject.Create(stArray); + TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current) + end else + if not ObjectIsType(TokRec^.current, stArray) then + begin + tok.err := teEvalArray; + goto out; + end; + tok.pb.Reset; + TokRec^.state := tsParamValue; + goto redo_char; + end; +{$IFDEF SUPER_METHOD} + tsEvalMethod: + begin + if ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then + begin + tok.pb.Reset; + TokRec^.obj := TSuperObject.Create(stArray); + TokRec^.state := tsMethodValue; + goto redo_char; + end else + begin + tok.err := teEvalMethod; + goto out; + end; + end; + + tsMethodValue: + begin + case v of + ')': + TokRec^.state := tsIdentifier; + else + if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then + begin + tok.err := teDepth; + goto out; + end; + inc(evalstack); + TokRec^.state := tsMethodPut; + inc(tok.depth); + tok.ResetLevel(tok.depth); + TokRec := @tok.stack[tok.depth]; + goto redo_char; + end; + end; + + tsMethodPut: + begin + TokRec^.obj.AsArray.Add(obj); + case v of + ',': + begin + tok.pb.Reset; + TokRec^.saved_state := tsMethodValue; + TokRec^.state := tsEatws; + end; + ')': + begin + if TokRec^.obj.AsArray.Length = 1 then + TokRec^.obj := TokRec^.obj.AsArray.GetO(0); + dec(evalstack); + tok.pb.Reset; + TokRec^.saved_state := tsIdentifier; + TokRec^.state := tsEatws; + end; + else + tok.err := teEvalMethod; + goto out; + end; + end; +{$ENDIF} + tsParamValue: + begin + case v of + ']': + TokRec^.state := tsIdentifier; + else + if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then + begin + tok.err := teDepth; + goto out; + end; + inc(evalstack); + TokRec^.state := tsParamPut; + inc(tok.depth); + tok.ResetLevel(tok.depth); + TokRec := @tok.stack[tok.depth]; + goto redo_char; + end; + end; + + tsParamPut: + begin + dec(evalstack); + TokRec^.obj := obj; + tok.pb.Reset; + TokRec^.saved_state := tsIdentifier; + TokRec^.state := tsEatws; + if v <> ']' then + begin + tok.err := teEvalArray; + goto out; + end; + end; + + tsIdentifier: + begin + if (this = nil) then + begin + if (SOIChar(v) < 256) and IsEndDelimiter(AnsiChar(v)) then + begin + if not strict then + begin + tok.pb.TrimRight; + TokRec^.current := TSuperObject.Create(tok.pb.Fbuf); + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + goto redo_char; + end else + begin + tok.err := teParseString; + goto out; + end; + end else + if (v = '\') then + begin + TokRec^.saved_state := tsIdentifier; + TokRec^.state := tsStringEscape; + end else + tok.pb.Append(@v, 1); + end else + begin + if (SOIChar(v) < 256) and (AnsiChar(v) in reserved) then + begin + TokRec^.gparent := TokRec^.parent; + if TokRec^.current = nil then + TokRec^.parent := this else + TokRec^.parent := TokRec^.current; + + case ObjectGetType(TokRec^.parent) of + stObject: + case v of + '.': + begin + TokRec^.state := tsEvalProperty; + if tok.pb.FBPos > 0 then + TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); + end; + '[': + begin + TokRec^.state := tsEvalArray; + if tok.pb.FBPos > 0 then + TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); + end; + '(': + begin + TokRec^.state := tsEvalMethod; + if tok.pb.FBPos > 0 then + TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); + end; + else + if tok.pb.FBPos > 0 then + TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); + if (foPutValue in options) and (evalstack = 0) then + begin + TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, put); + TokRec^.current := put + end else + if (foDelete in options) and (evalstack = 0) then + begin + TokRec^.current := TokRec^.parent.AsObject.Delete(tok.pb.Fbuf); + end else + if (TokRec^.current = nil) and (foCreatePath in options) then + begin + TokRec^.current := TSuperObject.Create(dt); + TokRec^.parent.AsObject.PutO(tok.pb.Fbuf, TokRec^.current); + end; + TokRec^.current := TokRec^.parent.AsObject.GetO(tok.pb.Fbuf); + TokRec^.state := tsFinish; + goto redo_char; + end; + stArray: + begin + if TokRec^.obj <> nil then + begin + if not ObjectIsType(TokRec^.obj, stInt) or (TokRec^.obj.AsInteger < 0) then + begin + tok.err := teEvalInt; + TokRec^.obj := nil; + goto out; + end; + numi := TokRec^.obj.AsInteger; + TokRec^.obj := nil; + + TokRec^.current := TokRec^.parent.AsArray.GetO(numi); + case v of + '.': + if (TokRec^.current = nil) and (foCreatePath in options) then + begin + TokRec^.current := TSuperObject.Create(stObject); + TokRec^.parent.AsArray.PutO(numi, TokRec^.current); + end else + if (TokRec^.current = nil) then + begin + tok.err := teEvalObject; + goto out; + end; + '[': + begin + if (TokRec^.current = nil) and (foCreatePath in options) then + begin + TokRec^.current := TSuperObject.Create(stArray); + TokRec^.parent.AsArray.Add(TokRec^.current); + end else + if (TokRec^.current = nil) then + begin + tok.err := teEvalArray; + goto out; + end; + TokRec^.state := tsEvalArray; + end; + '(': TokRec^.state := tsEvalMethod; + else + if (foPutValue in options) and (evalstack = 0) then + begin + TokRec^.parent.AsArray.PutO(numi, put); + TokRec^.current := put; + end else + if (foDelete in options) and (evalstack = 0) then + begin + TokRec^.current := TokRec^.parent.AsArray.Delete(numi); + end else + TokRec^.current := TokRec^.parent.AsArray.GetO(numi); + TokRec^.state := tsFinish; + goto redo_char + end; + end else + begin + case v of + '.': + begin + if (foPutValue in options) then + begin + TokRec^.current := TSuperObject.Create(stObject); + TokRec^.parent.AsArray.Add(TokRec^.current); + end else + TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1); + end; + '[': + begin + if (foPutValue in options) then + begin + TokRec^.current := TSuperObject.Create(stArray); + TokRec^.parent.AsArray.Add(TokRec^.current); + end else + TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1); + TokRec^.state := tsEvalArray; + end; + '(': + begin + if not (foPutValue in options) then + TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1) else + TokRec^.current := nil; + + TokRec^.state := tsEvalMethod; + end; + else + if (foPutValue in options) and (evalstack = 0) then + begin + TokRec^.parent.AsArray.Add(put); + TokRec^.current := put; + end else + if tok.pb.FBPos = 0 then + TokRec^.current := TokRec^.parent.AsArray.GetO(TokRec^.parent.AsArray.FLength - 1); + TokRec^.state := tsFinish; + goto redo_char + end; + end; + end; +{$IFDEF SUPER_METHOD} + stMethod: + case v of + '.': + begin + TokRec^.current := nil; + sm := TokRec^.parent.AsMethod; + sm(TokRec^.gparent, TokRec^.obj, TokRec^.current); + TokRec^.obj := nil; + end; + '[': + begin + TokRec^.current := nil; + sm := TokRec^.parent.AsMethod; + sm(TokRec^.gparent, TokRec^.obj, TokRec^.current); + TokRec^.state := tsEvalArray; + TokRec^.obj := nil; + end; + '(': + begin + TokRec^.current := nil; + sm := TokRec^.parent.AsMethod; + sm(TokRec^.gparent, TokRec^.obj, TokRec^.current); + TokRec^.state := tsEvalMethod; + TokRec^.obj := nil; + end; + else + if not (foPutValue in options) or (evalstack > 0) then + begin + TokRec^.current := nil; + sm := TokRec^.parent.AsMethod; + sm(TokRec^.gparent, TokRec^.obj, TokRec^.current); + TokRec^.obj := nil; + TokRec^.state := tsFinish; + goto redo_char + end else + begin + tok.err := teEvalMethod; + TokRec^.obj := nil; + goto out; + end; + end; +{$ENDIF} + end; + end else + tok.pb.Append(@v, 1); + end; + end; + + tsStringEscape: + case v of + 'b', + 'n', + 'r', + 't', + 'f': + begin + if(v = 'b') then tok.pb.Append(TOK_BS, 1) + else if(v = 'n') then tok.pb.Append(TOK_LF, 1) + else if(v = 'r') then tok.pb.Append(TOK_CR, 1) + else if(v = 't') then tok.pb.Append(TOK_TAB, 1) + else if(v = 'f') then tok.pb.Append(TOK_FF, 1); + TokRec^.state := TokRec^.saved_state; + end; + 'u': + begin + tok.ucs_char := 0; + tok.st_pos := 0; + TokRec^.state := tsEscapeUnicode; + end; + 'x': + begin + tok.ucs_char := 0; + tok.st_pos := 0; + TokRec^.state := tsEscapeHexadecimal; + end + else + tok.pb.Append(@v, 1); + TokRec^.state := TokRec^.saved_state; + end; + + tsEscapeUnicode: + begin + if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then + begin + inc(tok.ucs_char, (Word(hexdigit(v)) shl ((3-tok.st_pos)*4))); + inc(tok.st_pos); + if (tok.st_pos = 4) then + begin + tok.pb.Append(@tok.ucs_char, 1); + TokRec^.state := TokRec^.saved_state; + end + end else + begin + tok.err := teParseString; + goto out; + end + end; + tsEscapeHexadecimal: + begin + if ((SOIChar(v) < 256) and (AnsiChar(v) in super_hex_chars_set)) then + begin + inc(tok.ucs_char, (Word(hexdigit(v)) shl ((1-tok.st_pos)*4))); + inc(tok.st_pos); + if (tok.st_pos = 2) then + begin + tok.pb.Append(@tok.ucs_char, 1); + TokRec^.state := TokRec^.saved_state; + end + end else + begin + tok.err := teParseString; + goto out; + end + end; + tsBoolean: + begin + tok.pb.Append(@v, 1); + if (StrLComp('true', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 4)) = 0) then + begin + if (tok.st_pos = 4) then + if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then + TokRec^.state := tsIdentifier else + begin + TokRec^.current := TSuperObject.Create(true); + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + goto redo_char; + end + end else + if (StrLComp('false', PSOChar(tok.pb.FBuf), min(tok.st_pos + 1, 5)) = 0) then + begin + if (tok.st_pos = 5) then + if (((SOIChar(v) < 256) and (AnsiChar(v) in path)) or (SOIChar(v) >= 256)) then + TokRec^.state := tsIdentifier else + begin + TokRec^.current := TSuperObject.Create(false); + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + goto redo_char; + end + end else + begin + TokRec^.state := tsIdentifier; + tok.pb.FBuf[tok.st_pos] := #0; + dec(tok.pb.FBPos); + goto redo_char; + end; + inc(tok.st_pos); + end; + + tsNumber: + begin + if (SOIChar(v) < 256) and (AnsiChar(v) in super_number_chars_set) then + begin + tok.pb.Append(@v, 1); + if (SOIChar(v) < 256) then + case v of + '.': begin + tok.is_double := 1; + tok.floatcount := 0; + end; + 'e','E': + begin + tok.is_double := 1; + tok.floatcount := -1; + end; + '0'..'9': + begin + + if (tok.is_double = 1) and (tok.floatcount >= 0) then + begin + inc(tok.floatcount); + if tok.floatcount > 4 then + tok.floatcount := -1; + end; + end; + end; + end else + begin + if (tok.is_double = 0) then + begin + val(tok.pb.FBuf, numi, code); + if ObjectIsType(this, stArray) then + begin + if (foPutValue in options) and (evalstack = 0) then + begin + this.AsArray.PutO(numi, put); + TokRec^.current := put; + end else + if (foDelete in options) and (evalstack = 0) then + TokRec^.current := this.AsArray.Delete(numi) else + TokRec^.current := this.AsArray.GetO(numi); + end else + TokRec^.current := TSuperObject.Create(numi); + + end else + if (tok.is_double <> 0) then + begin + if tok.floatcount >= 0 then + begin + p := tok.pb.FBuf; + while p^ <> '.' do inc(p); + for code := 0 to tok.floatcount - 1 do + begin + p^ := p[1]; + inc(p); + end; + p^ := #0; + val(tok.pb.FBuf, numi, code); + case tok.floatcount of + 0: numi := numi * 10000; + 1: numi := numi * 1000; + 2: numi := numi * 100; + 3: numi := numi * 10; + end; + TokRec^.current := TSuperObject.CreateCurrency(PCurrency(@numi)^); + end else + begin + val(tok.pb.FBuf, numd, code); + TokRec^.current := TSuperObject.Create(numd); + end; + end else + begin + tok.err := teParseNumber; + goto out; + end; + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + goto redo_char; + end + end; + + tsArray: + begin + if (v = ']') then + begin + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + end else + begin + if(tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then + begin + tok.err := teDepth; + goto out; + end; + TokRec^.state := tsArrayAdd; + inc(tok.depth); + tok.ResetLevel(tok.depth); + TokRec := @tok.stack[tok.depth]; + goto redo_char; + end + end; + + tsArrayAdd: + begin + TokRec^.current.AsArray.Add(obj); + TokRec^.saved_state := tsArraySep; + TokRec^.state := tsEatws; + goto redo_char; + end; + + tsArraySep: + begin + if (v = ']') then + begin + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + end else + if (v = ',') then + begin + TokRec^.saved_state := tsArray; + TokRec^.state := tsEatws; + end else + begin + tok.err := teParseArray; + goto out; + end + end; + + tsObjectFieldStart: + begin + if (v = '}') then + begin + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + end else + if (SOIChar(v) < 256) and (AnsiChar(v) in ['"', '''']) then + begin + tok.quote_char := v; + tok.pb.Reset; + TokRec^.state := tsObjectField; + end else + if not((SOIChar(v) < 256) and ((AnsiChar(v) in reserved) or strict)) then + begin + TokRec^.state := tsObjectUnquotedField; + tok.pb.Reset; + goto redo_char; + end else + begin + tok.err := teParseObjectKeyName; + goto out; + end + end; + + tsObjectField: + begin + if (v = tok.quote_char) then + begin + TokRec^.field_name := tok.pb.FBuf; + TokRec^.saved_state := tsObjectFieldEnd; + TokRec^.state := tsEatws; + end else + if (v = '\') then + begin + TokRec^.saved_state := tsObjectField; + TokRec^.state := tsStringEscape; + end else + begin + tok.pb.Append(@v, 1); + end + end; + + tsObjectUnquotedField: + begin + if (SOIChar(v) < 256) and (AnsiChar(v) in [':', #0]) then + begin + TokRec^.field_name := tok.pb.FBuf; + TokRec^.saved_state := tsObjectFieldEnd; + TokRec^.state := tsEatws; + goto redo_char; + end else + if (v = '\') then + begin + TokRec^.saved_state := tsObjectUnquotedField; + TokRec^.state := tsStringEscape; + end else + tok.pb.Append(@v, 1); + end; + + tsObjectFieldEnd: + begin + if (v = ':') then + begin + TokRec^.saved_state := tsObjectValue; + TokRec^.state := tsEatws; + end else + begin + tok.err := teParseObjectKeySep; + goto out; + end + end; + + tsObjectValue: + begin + if (tok.depth >= SUPER_TOKENER_MAX_DEPTH-1) then + begin + tok.err := teDepth; + goto out; + end; + TokRec^.state := tsObjectValueAdd; + inc(tok.depth); + tok.ResetLevel(tok.depth); + TokRec := @tok.stack[tok.depth]; + goto redo_char; + end; + + tsObjectValueAdd: + begin + TokRec^.current.AsObject.PutO(TokRec^.field_name, obj); + TokRec^.field_name := ''; + TokRec^.saved_state := tsObjectSep; + TokRec^.state := tsEatws; + goto redo_char; + end; + + tsObjectSep: + begin + if (v = '}') then + begin + TokRec^.saved_state := tsFinish; + TokRec^.state := tsEatws; + end else + if (v = ',') then + begin + TokRec^.saved_state := tsObjectFieldStart; + TokRec^.state := tsEatws; + end else + begin + tok.err := teParseObjectValueSep; + goto out; + end + end; + end; + inc(str); + inc(tok.char_offset); + until v = #0; + + if(TokRec^.state <> tsFinish) and + (TokRec^.saved_state <> tsFinish) then + tok.err := teParseEof; + + out: + if(tok.err in [teSuccess]) then + begin +{$IFDEF SUPER_METHOD} + if (foCallMethod in options) and ObjectIsType(TokRec^.current, stMethod) and assigned(TokRec^.current.AsMethod) then + begin + sm := TokRec^.current.AsMethod; + sm(TokRec^.parent, put, Result); + end else +{$ENDIF} + Result := TokRec^.current; + end else + Result := nil; +end; + +procedure TSuperObject.PutO(const path: SOString; const Value: ISuperObject); +begin + ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], Value); +end; + +procedure TSuperObject.PutB(const path: SOString; Value: Boolean); +begin + ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); +end; + +procedure TSuperObject.PutD(const path: SOString; Value: Double); +begin + ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); +end; + +procedure TSuperObject.PutC(const path: SOString; Value: Currency); +begin + ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.CreateCurrency(Value)); +end; + +procedure TSuperObject.PutI(const path: SOString; Value: SuperInt); +begin + ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); +end; + +procedure TSuperObject.PutS(const path: SOString; const Value: SOString); +begin + ParseString(PSOChar(path), true, False, self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); +end; + + +{$IFDEF FPC} +function TSuperObject.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid: tguid; out obj): longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; +{$ELSE} +function TSuperObject.QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; +{$ENDIF} +begin + if GetInterface(IID, Obj) then + Result := 0 + else + Result := E_NOINTERFACE; +end; + +function TSuperObject.SaveTo(stream: TStream; indent, escape: boolean): integer; +var + pb: TSuperWriterStream; +begin + if escape then + pb := TSuperAnsiWriterStream.Create(stream) else + pb := TSuperUnicodeWriterStream.Create(stream); + + if(Write(pb, indent, escape, 0) < 0) then + begin + pb.Reset; + pb.Free; + Result := 0; + Exit; + end; + Result := stream.Size; + pb.Free; +end; + +function TSuperObject.CalcSize(indent, escape: boolean): integer; +var + pb: TSuperWriterFake; +begin + pb := TSuperWriterFake.Create; + if(Write(pb, indent, escape, 0) < 0) then + begin + pb.Free; + Result := 0; + Exit; + end; + Result := pb.FSize; + pb.Free; +end; + +function TSuperObject.SaveTo(socket: Integer; indent, escape: boolean): integer; +var + pb: TSuperWriterSock; +begin + pb := TSuperWriterSock.Create(socket); + if(Write(pb, indent, escape, 0) < 0) then + begin + pb.Free; + Result := 0; + Exit; + end; + Result := pb.FSize; + pb.Free; +end; + +constructor TSuperObject.Create(const s: SOString); +begin + Create(stString); + FOString := s; +end; + +procedure TSuperObject.Clear(all: boolean); +begin + if FProcessing then exit; + FProcessing := true; + try + case FDataType of + stBoolean: FO.c_boolean := false; + stDouble: FO.c_double := 0.0; + stCurrency: FO.c_currency := 0.0; + stInt: FO.c_int := 0; + stObject: FO.c_object.Clear(all); + stArray: FO.c_array.Clear(all); + stString: FOString := ''; +{$IFDEF SUPER_METHOD} + stMethod: FO.c_method := nil; +{$ENDIF} + end; + finally + FProcessing := false; + end; +end; + +procedure TSuperObject.Pack(all: boolean = false); +begin + if FProcessing then exit; + FProcessing := true; + try + case FDataType of + stObject: FO.c_object.Pack(all); + stArray: FO.c_array.Pack(all); + end; + finally + FProcessing := false; + end; +end; + +function TSuperObject.GetN(const path: SOString): ISuperObject; +begin + Result := ParseString(PSOChar(path), False, true, self); + if Result = nil then + Result := TSuperObject.Create(stNull); +end; + +procedure TSuperObject.PutN(const path: SOString; const Value: ISuperObject); +begin + if Value = nil then + ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], TSuperObject.Create(stNull)) else + ParseString(PSOChar(path), False, True, self, [foCreatePath, foPutValue], Value); +end; + +function TSuperObject.Delete(const path: SOString): ISuperObject; +begin + Result := ParseString(PSOChar(path), False, true, self, [foDelete]); +end; + +function TSuperObject.Clone: ISuperObject; +var + ite: TSuperObjectIter; + arr: TSuperArray; + j: integer; +begin + case FDataType of + stBoolean: Result := TSuperObject.Create(FO.c_boolean); + stDouble: Result := TSuperObject.Create(FO.c_double); + stCurrency: Result := TSuperObject.CreateCurrency(FO.c_currency); + stInt: Result := TSuperObject.Create(FO.c_int); + stString: Result := TSuperObject.Create(FOString); +{$IFDEF SUPER_METHOD} + stMethod: Result := TSuperObject.Create(FO.c_method); +{$ENDIF} + stObject: + begin + Result := TSuperObject.Create(stObject); + if ObjectFindFirst(self, ite) then + with Result.AsObject do + repeat + PutO(ite.key, ite.val.Clone); + until not ObjectFindNext(ite); + ObjectFindClose(ite); + end; + stArray: + begin + Result := TSuperObject.Create(stArray); + arr := AsArray; + with Result.AsArray do + for j := 0 to arr.Length - 1 do + Add(arr.GetO(j).Clone); + end; + else + Result := nil; + end; +end; + +procedure TSuperObject.Merge(const obj: ISuperObject; reference: boolean); +var + prop1, prop2: ISuperObject; + ite: TSuperObjectIter; + arr: TSuperArray; + j: integer; +begin + if ObjectIsType(obj, FDataType) then + case FDataType of + stBoolean: FO.c_boolean := obj.AsBoolean; + stDouble: FO.c_double := obj.AsDouble; + stCurrency: FO.c_currency := obj.AsCurrency; + stInt: FO.c_int := obj.AsInteger; + stString: FOString := obj.AsString; +{$IFDEF SUPER_METHOD} + stMethod: FO.c_method := obj.AsMethod; +{$ENDIF} + stObject: + begin + if ObjectFindFirst(obj, ite) then + with FO.c_object do + repeat + prop1 := FO.c_object.GetO(ite.key); + if (prop1 <> nil) and (ite.val <> nil) and (prop1.DataType = ite.val.DataType) then + prop1.Merge(ite.val) else + if reference then + PutO(ite.key, ite.val) else + if ite.val <> nil then + PutO(ite.key, ite.val.Clone) else + PutO(ite.key, nil) + + until not ObjectFindNext(ite); + ObjectFindClose(ite); + end; + stArray: + begin + arr := obj.AsArray; + with FO.c_array do + for j := 0 to arr.Length - 1 do + begin + prop1 := GetO(j); + prop2 := arr.GetO(j); + if (prop1 <> nil) and (prop2 <> nil) and (prop1.DataType = prop2.DataType) then + prop1.Merge(prop2) else + if reference then + PutO(j, prop2) else + if prop2 <> nil then + PutO(j, prop2.Clone) else + PutO(j, nil); + end; + end; + end; +end; + +procedure TSuperObject.Merge(const str: SOString); +begin + Merge(TSuperObject.ParseString(PSOChar(str), False), true); +end; + +class function TSuperObject.NewInstance: TObject; +begin + Result := inherited NewInstance; + TSuperObject(Result).FRefCount := 1; +end; + +function TSuperObject.ForcePath(const path: SOString; dataType: TSuperType = stObject): ISuperObject; +begin + Result := ParseString(PSOChar(path), False, True, Self, [foCreatePath], nil, dataType); +end; + +function TSuperObject.Format(const str: SOString; BeginSep: SOChar; EndSep: SOChar): SOString; +var + p1, p2: PSOChar; +begin + Result := ''; + p2 := PSOChar(str); + p1 := p2; + while true do + if p2^ = BeginSep then + begin + if p2 > p1 then + Result := Result + Copy(p1, 0, p2-p1); + inc(p2); + p1 := p2; + while true do + if p2^ = EndSep then Break else + if p2^ = #0 then Exit else + inc(p2); + Result := Result + GetS(copy(p1, 0, p2-p1)); + inc(p2); + p1 := p2; + end + else if p2^ = #0 then + begin + if p2 > p1 then + Result := Result + Copy(p1, 0, p2-p1); + Break; + end else + inc(p2); +end; + +function TSuperObject.GetO(const path: SOString): ISuperObject; +begin + Result := ParseString(PSOChar(path), False, True, Self); +end; + +function TSuperObject.GetA(const path: SOString): TSuperArray; +var + obj: ISuperObject; +begin + obj := ParseString(PSOChar(path), False, True, Self); + if obj <> nil then + Result := obj.AsArray else + Result := nil; +end; + +function TSuperObject.GetB(const path: SOString): Boolean; +var + obj: ISuperObject; +begin + obj := GetO(path); + if obj <> nil then + Result := obj.AsBoolean else + Result := false; +end; + +function TSuperObject.GetD(const path: SOString): Double; +var + obj: ISuperObject; +begin + obj := GetO(path); + if obj <> nil then + Result := obj.AsDouble else + Result := 0.0; +end; + +function TSuperObject.GetC(const path: SOString): Currency; +var + obj: ISuperObject; +begin + obj := GetO(path); + if obj <> nil then + Result := obj.AsCurrency else + Result := 0.0; +end; + +function TSuperObject.GetI(const path: SOString): SuperInt; +var + obj: ISuperObject; +begin + obj := GetO(path); + if obj <> nil then + Result := obj.AsInteger else + Result := 0; +end; + +function TSuperObject.GetDataPtr: Pointer; +begin + Result := FDataPtr; +end; + +function TSuperObject.GetDataType: TSuperType; +begin + Result := FDataType +end; + +function TSuperObject.GetS(const path: SOString): SOString; +var + obj: ISuperObject; +begin + obj := GetO(path); + if obj <> nil then + Result := obj.AsString else + Result := ''; +end; + +function TSuperObject.SaveTo(const FileName: string; indent, escape: boolean): integer; +var + stream: TFileStream; +begin + stream := TFileStream.Create(FileName, fmCreate); + try + Result := SaveTo(stream, indent, escape); + finally + stream.Free; + end; +end; + +function TSuperObject.Validate(const rules: SOString; const defs: SOString = ''; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; +begin + Result := Validate(TSuperObject.ParseString(PSOChar(rules), False), TSuperObject.ParseString(PSOChar(defs), False), callback, sender); +end; + +function TSuperObject.Validate(const rules: ISuperObject; const defs: ISuperObject = nil; callback: TSuperOnValidateError = nil; sender: Pointer = nil): boolean; +type + TDataType = (dtUnknown, dtStr, dtInt, dtFloat, dtNumber, dtText, dtBool, + dtMap, dtSeq, dtScalar, dtAny); +var + datatypes: ISuperObject; + names: ISuperObject; + + function FindInheritedProperty(const prop: PSOChar; p: ISuperObject): ISuperObject; + var + o: ISuperObject; + e: TSuperAvlEntry; + begin + o := p[prop]; + if o <> nil then + result := o else + begin + o := p['inherit']; + if (o <> nil) and ObjectIsType(o, stString) then + begin + e := names.AsObject.Search(o.AsString); + if (e <> nil) then + Result := FindInheritedProperty(prop, e.Value) else + Result := nil; + end else + Result := nil; + end; + end; + + function FindDataType(o: ISuperObject): TDataType; + var + e: TSuperAvlEntry; + obj: ISuperObject; + begin + obj := FindInheritedProperty('type', o); + if obj <> nil then + begin + e := datatypes.AsObject.Search(obj.AsString); + if e <> nil then + Result := TDataType(e.Value.AsInteger) else + Result := dtUnknown; + end else + Result := dtUnknown; + end; + + procedure GetNames(o: ISuperObject); + var + obj: ISuperObject; + f: TSuperObjectIter; + begin + obj := o['name']; + if ObjectIsType(obj, stString) then + names[obj.AsString] := o; + + case FindDataType(o) of + dtMap: + begin + obj := o['mapping']; + if ObjectIsType(obj, stObject) then + begin + if ObjectFindFirst(obj, f) then + repeat + if ObjectIsType(f.val, stObject) then + GetNames(f.val); + until not ObjectFindNext(f); + ObjectFindClose(f); + end; + end; + dtSeq: + begin + obj := o['sequence']; + if ObjectIsType(obj, stObject) then + GetNames(obj); + end; + end; + end; + + function FindInheritedField(const prop: SOString; p: ISuperObject): ISuperObject; + var + o: ISuperObject; + e: TSuperAvlEntry; + begin + o := p['mapping']; + if ObjectIsType(o, stObject) then + begin + o := o.AsObject.GetO(prop); + if o <> nil then + begin + Result := o; + Exit; + end; + end; + + o := p['inherit']; + if ObjectIsType(o, stString) then + begin + e := names.AsObject.Search(o.AsString); + if (e <> nil) then + Result := FindInheritedField(prop, e.Value) else + Result := nil; + end else + Result := nil; + end; + + function InheritedFieldExist(const obj: ISuperObject; p: ISuperObject; const name: SOString = ''): boolean; + var + o: ISuperObject; + e: TSuperAvlEntry; + j: TSuperAvlIterator; + begin + Result := true; + o := p['mapping']; + if ObjectIsType(o, stObject) then + begin + j := TSuperAvlIterator.Create(o.AsObject); + try + j.First; + e := j.GetIter; + while e <> nil do + begin + if obj.AsObject.Search(e.Name) = nil then + begin + Result := False; + if assigned(callback) then + callback(sender, veFieldNotFound, name + '.' + e.Name); + end; + j.Next; + e := j.GetIter; + end; + + finally + j.Free; + end; + end; + + o := p['inherit']; + if ObjectIsType(o, stString) then + begin + e := names.AsObject.Search(o.AsString); + if (e <> nil) then + Result := InheritedFieldExist(obj, e.Value, name) and Result; + end; + end; + + function getInheritedBool(f: PSOChar; p: ISuperObject; default: boolean = false): boolean; + var + o: ISuperObject; + begin + o := FindInheritedProperty(f, p); + case ObjectGetType(o) of + stBoolean: Result := o.AsBoolean; + stNull: Result := Default; + else + Result := default; + if assigned(callback) then + callback(sender, veRuleMalformated, f); + end; + end; + + procedure GetInheritedFieldList(list: ISuperObject; p: ISuperObject); + var + o: ISuperObject; + e: TSuperAvlEntry; + i: TSuperAvlIterator; + begin + Result := true; + o := p['mapping']; + if ObjectIsType(o, stObject) then + begin + i := TSuperAvlIterator.Create(o.AsObject); + try + i.First; + e := i.GetIter; + while e <> nil do + begin + if list.AsObject.Search(e.Name) = nil then + list[e.Name] := e.Value; + i.Next; + e := i.GetIter; + end; + + finally + i.Free; + end; + end; + + o := p['inherit']; + if ObjectIsType(o, stString) then + begin + e := names.AsObject.Search(o.AsString); + if (e <> nil) then + GetInheritedFieldList(list, e.Value); + end; + end; + + function CheckEnum(o: ISuperObject; p: ISuperObject; name: SOString = ''): boolean; + var + enum: ISuperObject; + i: integer; + begin + Result := false; + enum := FindInheritedProperty('enum', p); + case ObjectGetType(enum) of + stArray: + for i := 0 to enum.AsArray.Length - 1 do + if (o.AsString = enum.AsArray[i].AsString) then + begin + Result := true; + exit; + end; + stNull: Result := true; + else + Result := false; + if assigned(callback) then + callback(sender, veRuleMalformated, ''); + Exit; + end; + + if (not Result) and assigned(callback) then + callback(sender, veValueNotInEnum, name); + end; + + function CheckLength(len: integer; p: ISuperObject; const objpath: SOString): boolean; + var + length, o: ISuperObject; + begin + result := true; + length := FindInheritedProperty('length', p); + case ObjectGetType(length) of + stObject: + begin + o := length.AsObject.GetO('min'); + if (o <> nil) and (o.AsInteger > len) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidLength, objpath); + end; + o := length.AsObject.GetO('max'); + if (o <> nil) and (o.AsInteger < len) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidLength, objpath); + end; + o := length.AsObject.GetO('minex'); + if (o <> nil) and (o.AsInteger >= len) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidLength, objpath); + end; + o := length.AsObject.GetO('maxex'); + if (o <> nil) and (o.AsInteger <= len) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidLength, objpath); + end; + end; + stNull: ; + else + Result := false; + if assigned(callback) then + callback(sender, veRuleMalformated, ''); + end; + end; + + function CheckRange(obj: ISuperObject; p: ISuperObject; const objpath: SOString): boolean; + var + length, o: ISuperObject; + begin + result := true; + length := FindInheritedProperty('range', p); + case ObjectGetType(length) of + stObject: + begin + o := length.AsObject.GetO('min'); + if (o <> nil) and (o.Compare(obj) = cpGreat) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidRange, objpath); + end; + o := length.AsObject.GetO('max'); + if (o <> nil) and (o.Compare(obj) = cpLess) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidRange, objpath); + end; + o := length.AsObject.GetO('minex'); + if (o <> nil) and (o.Compare(obj) in [cpGreat, cpEqu]) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidRange, objpath); + end; + o := length.AsObject.GetO('maxex'); + if (o <> nil) and (o.Compare(obj) in [cpLess, cpEqu]) then + begin + Result := false; + if assigned(callback) then + callback(sender, veInvalidRange, objpath); + end; + end; + stNull: ; + else + Result := false; + if assigned(callback) then + callback(sender, veRuleMalformated, ''); + end; + end; + + + function process(o: ISuperObject; p: ISuperObject; objpath: SOString = ''): boolean; + var + ite: TSuperAvlIterator; + ent: TSuperAvlEntry; + p2, o2, sequence: ISuperObject; + s: SOString; + i: integer; + uniquelist, fieldlist: ISuperObject; + begin + Result := true; + if (o = nil) then + begin + if getInheritedBool('required', p) then + begin + if assigned(callback) then + callback(sender, veFieldIsRequired, objpath); + result := false; + end; + end else + case FindDataType(p) of + dtStr: + case ObjectGetType(o) of + stString: + begin + Result := Result and CheckLength(Length(o.AsString), p, objpath); + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtBool: + case ObjectGetType(o) of + stBoolean: + begin + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtInt: + case ObjectGetType(o) of + stInt: + begin + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtFloat: + case ObjectGetType(o) of + stDouble, stCurrency: + begin + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtMap: + case ObjectGetType(o) of + stObject: + begin + // all objects have and match a rule ? + ite := TSuperAvlIterator.Create(o.AsObject); + try + ite.First; + ent := ite.GetIter; + while ent <> nil do + begin + p2 := FindInheritedField(ent.Name, p); + if ObjectIsType(p2, stObject) then + result := process(ent.Value, p2, objpath + '.' + ent.Name) and result else + begin + if assigned(callback) then + callback(sender, veUnexpectedField, objpath + '.' + ent.Name); + result := false; // field have no rule + end; + ite.Next; + ent := ite.GetIter; + end; + finally + ite.Free; + end; + + // all expected field exists ? + Result := InheritedFieldExist(o, p, objpath) and Result; + end; + stNull: {nop}; + else + result := false; + if assigned(callback) then + callback(sender, veRuleMalformated, objpath); + end; + dtSeq: + case ObjectGetType(o) of + stArray: + begin + sequence := FindInheritedProperty('sequence', p); + if sequence <> nil then + case ObjectGetType(sequence) of + stObject: + begin + for i := 0 to o.AsArray.Length - 1 do + result := process(o.AsArray.GetO(i), sequence, objpath + '[' + IntToStr(i) + ']') and result; + if getInheritedBool('unique', sequence) then + begin + // type is unique ? + uniquelist := TSuperObject.Create(stObject); + try + for i := 0 to o.AsArray.Length - 1 do + begin + s := o.AsArray.GetO(i).AsString; + if (s <> '') then + begin + if uniquelist.AsObject.Search(s) = nil then + uniquelist[s] := nil else + begin + Result := False; + if Assigned(callback) then + callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + ']'); + end; + end; + end; + finally + uniquelist := nil; + end; + end; + + // field is unique ? + if (FindDataType(sequence) = dtMap) then + begin + fieldlist := TSuperObject.Create(stObject); + try + GetInheritedFieldList(fieldlist, sequence); + ite := TSuperAvlIterator.Create(fieldlist.AsObject); + try + ite.First; + ent := ite.GetIter; + while ent <> nil do + begin + if getInheritedBool('unique', ent.Value) then + begin + uniquelist := TSuperObject.Create(stObject); + try + for i := 0 to o.AsArray.Length - 1 do + begin + o2 := o.AsArray.GetO(i); + if o2 <> nil then + begin + s := o2.AsObject.GetO(ent.Name).AsString; + if (s <> '') then + if uniquelist.AsObject.Search(s) = nil then + uniquelist[s] := nil else + begin + Result := False; + if Assigned(callback) then + callback(sender, veDuplicateEntry, objpath + '[' + IntToStr(i) + '].' + ent.name); + end; + end; + end; + finally + uniquelist := nil; + end; + end; + ite.Next; + ent := ite.GetIter; + end; + finally + ite.Free; + end; + finally + fieldlist := nil; + end; + end; + + + end; + stNull: {nop}; + else + result := false; + if assigned(callback) then + callback(sender, veRuleMalformated, objpath); + end; + Result := Result and CheckLength(o.AsArray.Length, p, objpath); + + end; + else + result := false; + if assigned(callback) then + callback(sender, veRuleMalformated, objpath); + end; + dtNumber: + case ObjectGetType(o) of + stInt, + stDouble, stCurrency: + begin + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtText: + case ObjectGetType(o) of + stInt, + stDouble, + stCurrency, + stString: + begin + result := result and CheckLength(Length(o.AsString), p, objpath); + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtScalar: + case ObjectGetType(o) of + stBoolean, + stDouble, + stCurrency, + stInt, + stString: + begin + result := result and CheckLength(Length(o.AsString), p, objpath); + Result := Result and CheckRange(o, p, objpath); + end; + else + if assigned(callback) then + callback(sender, veInvalidDataType, objpath); + result := false; + end; + dtAny:; + else + if assigned(callback) then + callback(sender, veRuleMalformated, objpath); + result := false; + end; + Result := Result and CheckEnum(o, p, objpath) + + end; +var + j: integer; + +begin + Result := False; + datatypes := TSuperObject.Create(stObject); + names := TSuperObject.Create; + try + datatypes.I['str'] := ord(dtStr); + datatypes.I['int'] := ord(dtInt); + datatypes.I['float'] := ord(dtFloat); + datatypes.I['number'] := ord(dtNumber); + datatypes.I['text'] := ord(dtText); + datatypes.I['bool'] := ord(dtBool); + datatypes.I['map'] := ord(dtMap); + datatypes.I['seq'] := ord(dtSeq); + datatypes.I['scalar'] := ord(dtScalar); + datatypes.I['any'] := ord(dtAny); + + if ObjectIsType(defs, stArray) then + for j := 0 to defs.AsArray.Length - 1 do + if ObjectIsType(defs.AsArray[j], stObject) then + GetNames(defs.AsArray[j]) else + begin + if assigned(callback) then + callback(sender, veRuleMalformated, ''); + Exit; + end; + + + if ObjectIsType(rules, stObject) then + GetNames(rules) else + begin + if assigned(callback) then + callback(sender, veRuleMalformated, ''); + Exit; + end; + + Result := process(self, rules); + + finally + datatypes := nil; + names := nil; + end; +end; + +function TSuperObject._AddRef: Integer; stdcall; +begin + Result := InterlockedIncrement(FRefCount); +end; + +function TSuperObject._Release: Integer; stdcall; +begin + Result := InterlockedDecrement(FRefCount); + if Result = 0 then + Destroy; +end; + +function TSuperObject.Compare(const str: SOString): TSuperCompareResult; +begin + Result := Compare(TSuperObject.ParseString(PSOChar(str), False)); +end; + +function TSuperObject.Compare(const obj: ISuperObject): TSuperCompareResult; + function GetIntCompResult(const i: int64): TSuperCompareResult; + begin + if i < 0 then result := cpLess else + if i = 0 then result := cpEqu else + Result := cpGreat; + end; + + function GetDblCompResult(const d: double): TSuperCompareResult; + begin + if d < 0 then result := cpLess else + if d = 0 then result := cpEqu else + Result := cpGreat; + end; + +begin + case DataType of + stBoolean: + case ObjectGetType(obj) of + stBoolean: Result := GetIntCompResult(ord(FO.c_boolean) - ord(obj.AsBoolean)); + stDouble: Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsDouble); + stCurrency:Result := GetDblCompResult(ord(FO.c_boolean) - obj.AsCurrency); + stInt: Result := GetIntCompResult(ord(FO.c_boolean) - obj.AsInteger); + stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); + else + Result := cpError; + end; + stDouble: + case ObjectGetType(obj) of + stBoolean: Result := GetDblCompResult(FO.c_double - ord(obj.AsBoolean)); + stDouble: Result := GetDblCompResult(FO.c_double - obj.AsDouble); + stCurrency:Result := GetDblCompResult(FO.c_double - obj.AsCurrency); + stInt: Result := GetDblCompResult(FO.c_double - obj.AsInteger); + stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); + else + Result := cpError; + end; + stCurrency: + case ObjectGetType(obj) of + stBoolean: Result := GetDblCompResult(FO.c_currency - ord(obj.AsBoolean)); + stDouble: Result := GetDblCompResult(FO.c_currency - obj.AsDouble); + stCurrency:Result := GetDblCompResult(FO.c_currency - obj.AsCurrency); + stInt: Result := GetDblCompResult(FO.c_currency - obj.AsInteger); + stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); + else + Result := cpError; + end; + stInt: + case ObjectGetType(obj) of + stBoolean: Result := GetIntCompResult(FO.c_int - ord(obj.AsBoolean)); + stDouble: Result := GetDblCompResult(FO.c_int - obj.AsDouble); + stCurrency:Result := GetDblCompResult(FO.c_int - obj.AsCurrency); + stInt: Result := GetIntCompResult(FO.c_int - obj.AsInteger); + stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); + else + Result := cpError; + end; + stString: + case ObjectGetType(obj) of + stBoolean, + stDouble, + stCurrency, + stInt, + stString: Result := GetIntCompResult(StrComp(PSOChar(AsString), PSOChar(obj.AsString))); + else + Result := cpError; + end; + else + Result := cpError; + end; +end; + +{$IFDEF SUPER_METHOD} +function TSuperObject.AsMethod: TSuperMethod; +begin + if FDataType = stMethod then + Result := FO.c_method else + Result := nil; +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +constructor TSuperObject.Create(m: TSuperMethod); +begin + Create(stMethod); + FO.c_method := m; +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +function TSuperObject.GetM(const path: SOString): TSuperMethod; +var + v: ISuperObject; +begin + v := ParseString(PSOChar(path), False, True, Self); + if (v <> nil) and (ObjectGetType(v) = stMethod) then + Result := v.AsMethod else + Result := nil; +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +procedure TSuperObject.PutM(const path: SOString; Value: TSuperMethod); +begin + ParseString(PSOChar(path), False, True, Self, [foCreatePath, foPutValue], TSuperObject.Create(Value)); +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +function TSuperObject.call(const path: SOString; const param: ISuperObject): ISuperObject; +begin + Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], param); +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +function TSuperObject.call(const path, param: SOString): ISuperObject; +begin + Result := ParseString(PSOChar(path), False, True, Self, [foCallMethod], TSuperObject.ParseString(PSOChar(param), False)); +end; +{$ENDIF} + +function TSuperObject.GetProcessing: boolean; +begin + Result := FProcessing; +end; + +procedure TSuperObject.SetDataPtr(const Value: Pointer); +begin + FDataPtr := Value; +end; + +procedure TSuperObject.SetProcessing(value: boolean); +begin + FProcessing := value; +end; + +{ TSuperArray } + +function TSuperArray.Add(const Data: ISuperObject): Integer; +begin + Result := FLength; + PutO(Result, data); +end; + +function TSuperArray.Add(Data: SuperInt): Integer; +begin + Result := Add(TSuperObject.Create(Data)); +end; + +function TSuperArray.Add(const Data: SOString): Integer; +begin + Result := Add(TSuperObject.Create(Data)); +end; + +function TSuperArray.Add(Data: Boolean): Integer; +begin + Result := Add(TSuperObject.Create(Data)); +end; + +function TSuperArray.Add(Data: Double): Integer; +begin + Result := Add(TSuperObject.Create(Data)); +end; + +function TSuperArray.AddC(const Data: Currency): Integer; +begin + Result := Add(TSuperObject.CreateCurrency(Data)); +end; + +function TSuperArray.Delete(index: Integer): ISuperObject; +begin + if (Index >= 0) and (Index < FLength) then + begin + Result := FArray^[index]; + FArray^[index] := nil; + Dec(FLength); + if Index < FLength then + begin + Move(FArray^[index + 1], FArray^[index], + (FLength - index) * SizeOf(Pointer)); + Pointer(FArray^[FLength]) := nil; + end; + end; +end; + +procedure TSuperArray.Insert(index: Integer; const value: ISuperObject); +begin + if (Index >= 0) then + if (index < FLength) then + begin + if FLength = FSize then + Expand(index); + if Index < FLength then + Move(FArray^[index], FArray^[index + 1], + (FLength - index) * SizeOf(Pointer)); + Pointer(FArray^[index]) := nil; + FArray^[index] := value; + Inc(FLength); + end else + PutO(index, value); +end; + +procedure TSuperArray.Clear(all: boolean); +var + j: Integer; +begin + for j := 0 to FLength - 1 do + if FArray^[j] <> nil then + begin + if all then + FArray^[j].Clear(all); + FArray^[j] := nil; + end; + FLength := 0; +end; + +procedure TSuperArray.Pack(all: boolean); +var + PackedCount, StartIndex, EndIndex, j: Integer; +begin + if FLength > 0 then + begin + PackedCount := 0; + StartIndex := 0; + repeat + while (StartIndex < FLength) and (FArray^[StartIndex] = nil) do + Inc(StartIndex); + if StartIndex < FLength then + begin + EndIndex := StartIndex; + while (EndIndex < FLength) and (FArray^[EndIndex] <> nil) do + Inc(EndIndex); + + Dec(EndIndex); + + if StartIndex > PackedCount then + Move(FArray^[StartIndex], FArray^[PackedCount], (EndIndex - StartIndex + 1) * SizeOf(Pointer)); + + Inc(PackedCount, EndIndex - StartIndex + 1); + StartIndex := EndIndex + 1; + end; + until StartIndex >= FLength; + FillChar(FArray^[PackedCount], (FLength - PackedCount) * sizeof(Pointer), 0); + FLength := PackedCount; + if all then + for j := 0 to FLength - 1 do + FArray^[j].Pack(all); + end; +end; + +constructor TSuperArray.Create; +begin + inherited Create; + FSize := SUPER_ARRAY_LIST_DEFAULT_SIZE; + FLength := 0; + GetMem(FArray, sizeof(Pointer) * FSize); + FillChar(FArray^, sizeof(Pointer) * FSize, 0); +end; + +destructor TSuperArray.Destroy; +begin + Clear; + FreeMem(FArray); + inherited; +end; + +procedure TSuperArray.Expand(max: Integer); +var + new_size: Integer; +begin + if (max < FSize) then + Exit; + if max < (FSize shl 1) then + new_size := (FSize shl 1) else + new_size := max + 1; + ReallocMem(FArray, new_size * sizeof(Pointer)); + FillChar(FArray^[FSize], (new_size - FSize) * sizeof(Pointer), 0); + FSize := new_size; +end; + +function TSuperArray.GetO(const index: Integer): ISuperObject; +begin + if(index >= FLength) then + Result := nil else + Result := FArray^[index]; +end; + +function TSuperArray.GetB(const index: integer): Boolean; +var + obj: ISuperObject; +begin + obj := GetO(index); + if obj <> nil then + Result := obj.AsBoolean else + Result := false; +end; + +function TSuperArray.GetD(const index: integer): Double; +var + obj: ISuperObject; +begin + obj := GetO(index); + if obj <> nil then + Result := obj.AsDouble else + Result := 0.0; +end; + +function TSuperArray.GetI(const index: integer): SuperInt; +var + obj: ISuperObject; +begin + obj := GetO(index); + if obj <> nil then + Result := obj.AsInteger else + Result := 0; +end; + +function TSuperArray.GetS(const index: integer): SOString; +var + obj: ISuperObject; +begin + obj := GetO(index); + if obj <> nil then + Result := obj.AsString else + Result := ''; +end; + +procedure TSuperArray.PutO(const index: Integer; const Value: ISuperObject); +begin + Expand(index); + FArray^[index] := value; + if(FLength <= index) then FLength := index + 1; +end; + +function TSuperArray.GetN(const index: integer): ISuperObject; +begin + Result := GetO(index); + if Result = nil then + Result := TSuperObject.Create(stNull); +end; + +procedure TSuperArray.PutN(const index: integer; const Value: ISuperObject); +begin + if Value <> nil then + PutO(index, Value) else + PutO(index, TSuperObject.Create(stNull)); +end; + +procedure TSuperArray.PutB(const index: integer; Value: Boolean); +begin + PutO(index, TSuperObject.Create(Value)); +end; + +procedure TSuperArray.PutD(const index: integer; Value: Double); +begin + PutO(index, TSuperObject.Create(Value)); +end; + +function TSuperArray.GetC(const index: integer): Currency; +var + obj: ISuperObject; +begin + obj := GetO(index); + if obj <> nil then + Result := obj.AsCurrency else + Result := 0.0; +end; + +procedure TSuperArray.PutC(const index: integer; Value: Currency); +begin + PutO(index, TSuperObject.CreateCurrency(Value)); +end; + +procedure TSuperArray.PutI(const index: integer; Value: SuperInt); +begin + PutO(index, TSuperObject.Create(Value)); +end; + +procedure TSuperArray.PutS(const index: integer; const Value: SOString); +begin + PutO(index, TSuperObject.Create(Value)); +end; + +{$IFDEF SUPER_METHOD} +function TSuperArray.GetM(const index: integer): TSuperMethod; +var + v: ISuperObject; +begin + v := GetO(index); + if (ObjectGetType(v) = stMethod) then + Result := v.AsMethod else + Result := nil; +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +procedure TSuperArray.PutM(const index: integer; Value: TSuperMethod); +begin + PutO(index, TSuperObject.Create(Value)); +end; +{$ENDIF} + +{ TSuperWriterString } + +function TSuperWriterString.Append(buf: PSOChar; Size: Integer): Integer; + function max(a, b: Integer): integer; begin if a > b then Result := a else Result := b end; +begin + Result := size; + if Size > 0 then + begin + if (FSize - FBPos <= size) then + begin + FSize := max(FSize * 2, FBPos + size + 8); + ReallocMem(FBuf, FSize * SizeOf(SOChar)); + end; + // fast move + case size of + 1: FBuf[FBPos] := buf^; + 2: PInteger(@FBuf[FBPos])^ := PInteger(buf)^; + 4: PInt64(@FBuf[FBPos])^ := PInt64(buf)^; + else + move(buf^, FBuf[FBPos], size * SizeOf(SOChar)); + end; + inc(FBPos, size); + FBuf[FBPos] := #0; + end; +end; + +function TSuperWriterString.Append(buf: PSOChar): Integer; +begin + Result := Append(buf, strlen(buf)); +end; + +constructor TSuperWriterString.Create; +begin + inherited; + FSize := 32; + FBPos := 0; + GetMem(FBuf, FSize * SizeOf(SOChar)); +end; + +destructor TSuperWriterString.Destroy; +begin + inherited; + if FBuf <> nil then + FreeMem(FBuf) +end; + +function TSuperWriterString.GetString: SOString; +begin + SetString(Result, FBuf, FBPos); +end; + +procedure TSuperWriterString.Reset; +begin + FBuf[0] := #0; + FBPos := 0; +end; + +procedure TSuperWriterString.TrimRight; +begin + while (FBPos > 0) and (FBuf[FBPos-1] < #256) and (AnsiChar(FBuf[FBPos-1]) in [#32, #13, #10]) do + begin + dec(FBPos); + FBuf[FBPos] := #0; + end; +end; + +{ TSuperWriterStream } + +function TSuperWriterStream.Append(buf: PSOChar): Integer; +begin + Result := Append(buf, StrLen(buf)); +end; + +constructor TSuperWriterStream.Create(AStream: TStream); +begin + inherited Create; + FStream := AStream; +end; + +procedure TSuperWriterStream.Reset; +begin + FStream.Size := 0; +end; + +{ TSuperWriterStream } + +function TSuperAnsiWriterStream.Append(buf: PSOChar; Size: Integer): Integer; +var + Buffer: array[0..1023] of AnsiChar; + pBuffer: PAnsiChar; + i: Integer; +begin + if Size = 1 then + Result := FStream.Write(buf^, Size) else + begin + if Size > SizeOf(Buffer) then + GetMem(pBuffer, Size) else + pBuffer := @Buffer; + try + for i := 0 to Size - 1 do + pBuffer[i] := AnsiChar(buf[i]); + Result := FStream.Write(pBuffer^, Size); + finally + if pBuffer <> @Buffer then + FreeMem(pBuffer); + end; + end; +end; + +{ TSuperUnicodeWriterStream } + +function TSuperUnicodeWriterStream.Append(buf: PSOChar; Size: Integer): Integer; +begin + Result := FStream.Write(buf^, Size * 2); +end; + +{ TSuperWriterFake } + +function TSuperWriterFake.Append(buf: PSOChar; Size: Integer): Integer; +begin + inc(FSize, Size); + Result := FSize; +end; + +function TSuperWriterFake.Append(buf: PSOChar): Integer; +begin + inc(FSize, Strlen(buf)); + Result := FSize; +end; + +constructor TSuperWriterFake.Create; +begin + inherited Create; + FSize := 0; +end; + +procedure TSuperWriterFake.Reset; +begin + FSize := 0; +end; + +{ TSuperWriterSock } + +function TSuperWriterSock.Append(buf: PSOChar; Size: Integer): Integer; +var + Buffer: array[0..1023] of AnsiChar; + pBuffer: PAnsiChar; + i: Integer; +begin + if Size = 1 then +{$IFDEF FPC} + Result := fpsend(FSocket, buf, size, 0) else +{$ELSE} + Result := send(FSocket, buf^, size, 0) else +{$ENDIF} + begin + if Size > SizeOf(Buffer) then + GetMem(pBuffer, Size) else + pBuffer := @Buffer; + try + for i := 0 to Size - 1 do + pBuffer[i] := AnsiChar(buf[i]); +{$IFDEF FPC} + Result := fpsend(FSocket, pBuffer, size, 0); +{$ELSE} + Result := send(FSocket, pBuffer^, size, 0); +{$ENDIF} + finally + if pBuffer <> @Buffer then + FreeMem(pBuffer); + end; + end; + inc(FSize, Result); +end; + +function TSuperWriterSock.Append(buf: PSOChar): Integer; +begin + Result := Append(buf, StrLen(buf)); +end; + +constructor TSuperWriterSock.Create(ASocket: Integer); +begin + inherited Create; + FSocket := ASocket; + FSize := 0; +end; + +procedure TSuperWriterSock.Reset; +begin + FSize := 0; +end; + +{ TSuperTokenizer } + +constructor TSuperTokenizer.Create; +begin + pb := TSuperWriterString.Create; + line := 1; + col := 0; + Reset; +end; + +destructor TSuperTokenizer.Destroy; +begin + Reset; + pb.Free; + inherited; +end; + +procedure TSuperTokenizer.Reset; +var + i: integer; +begin + for i := depth downto 0 do + ResetLevel(i); + depth := 0; + err := teSuccess; +end; + +procedure TSuperTokenizer.ResetLevel(adepth: integer); +begin + stack[adepth].state := tsEatws; + stack[adepth].saved_state := tsStart; + stack[adepth].current := nil; + stack[adepth].field_name := ''; + stack[adepth].obj := nil; + stack[adepth].parent := nil; + stack[adepth].gparent := nil; +end; + +{ TSuperAvlTree } + +constructor TSuperAvlTree.Create; +begin + FRoot := nil; + FCount := 0; +end; + +destructor TSuperAvlTree.Destroy; +begin + Clear; + inherited; +end; + +function TSuperAvlTree.IsEmpty: boolean; +begin + result := FRoot = nil; +end; + +function TSuperAvlTree.balance(bal: TSuperAvlEntry): TSuperAvlEntry; +var + deep, old: TSuperAvlEntry; + bf: integer; +begin + if (bal.FBf > 0) then + begin + deep := bal.FGt; + if (deep.FBf < 0) then + begin + old := bal; + bal := deep.FLt; + old.FGt := bal.FLt; + deep.FLt := bal.FGt; + bal.FLt := old; + bal.FGt := deep; + bf := bal.FBf; + if (bf <> 0) then + begin + if (bf > 0) then + begin + old.FBf := -1; + deep.FBf := 0; + end else + begin + deep.FBf := 1; + old.FBf := 0; + end; + bal.FBf := 0; + end else + begin + old.FBf := 0; + deep.FBf := 0; + end; + end else + begin + bal.FGt := deep.FLt; + deep.FLt := bal; + if (deep.FBf = 0) then + begin + deep.FBf := -1; + bal.FBf := 1; + end else + begin + deep.FBf := 0; + bal.FBf := 0; + end; + bal := deep; + end; + end else + begin + (* "Less than" subtree is deeper. *) + + deep := bal.FLt; + if (deep.FBf > 0) then + begin + old := bal; + bal := deep.FGt; + old.FLt := bal.FGt; + deep.FGt := bal.FLt; + bal.FGt := old; + bal.FLt := deep; + + bf := bal.FBf; + if (bf <> 0) then + begin + if (bf < 0) then + begin + old.FBf := 1; + deep.FBf := 0; + end else + begin + deep.FBf := -1; + old.FBf := 0; + end; + bal.FBf := 0; + end else + begin + old.FBf := 0; + deep.FBf := 0; + end; + end else + begin + bal.FLt := deep.FGt; + deep.FGt := bal; + if (deep.FBf = 0) then + begin + deep.FBf := 1; + bal.FBf := -1; + end else + begin + deep.FBf := 0; + bal.FBf := 0; + end; + bal := deep; + end; + end; + Result := bal; +end; + +function TSuperAvlTree.Insert(h: TSuperAvlEntry): TSuperAvlEntry; +var + unbal, parentunbal, hh, parent: TSuperAvlEntry; + depth, unbaldepth: longint; + cmp: integer; + unbalbf: integer; + branch: TSuperAvlBitArray; + p: Pointer; +begin + inc(FCount); + h.FLt := nil; + h.FGt := nil; + h.FBf := 0; + branch := []; + + if (FRoot = nil) then + FRoot := h + else + begin + unbal := nil; + parentunbal := nil; + depth := 0; + unbaldepth := 0; + hh := FRoot; + parent := nil; + repeat + if (hh.FBf <> 0) then + begin + unbal := hh; + parentunbal := parent; + unbaldepth := depth; + end; + if hh.FHash <> h.FHash then + begin + if hh.FHash < h.FHash then cmp := -1 else + if hh.FHash > h.FHash then cmp := 1 else + cmp := 0; + end else + cmp := CompareNodeNode(h, hh); + if (cmp = 0) then + begin + Result := hh; + //exchange data + p := hh.Ptr; + hh.FPtr := h.Ptr; + h.FPtr := p; + doDeleteEntry(h, false); + dec(FCount); + exit; + end; + parent := hh; + if (cmp > 0) then + begin + hh := hh.FGt; + include(branch, depth); + end else + begin + hh := hh.FLt; + exclude(branch, depth); + end; + inc(depth); + until (hh = nil); + + if (cmp < 0) then + parent.FLt := h else + parent.FGt := h; + + depth := unbaldepth; + + if (unbal = nil) then + hh := FRoot + else + begin + if depth in branch then + cmp := 1 else + cmp := -1; + inc(depth); + unbalbf := unbal.FBf; + if (cmp < 0) then + dec(unbalbf) else + inc(unbalbf); + if cmp < 0 then + hh := unbal.FLt else + hh := unbal.FGt; + if ((unbalbf <> -2) and (unbalbf <> 2)) then + begin + unbal.FBf := unbalbf; + unbal := nil; + end; + end; + + if (hh <> nil) then + while (h <> hh) do + begin + if depth in branch then + cmp := 1 else + cmp := -1; + inc(depth); + if (cmp < 0) then + begin + hh.FBf := -1; + hh := hh.FLt; + end else (* cmp > 0 *) + begin + hh.FBf := 1; + hh := hh.FGt; + end; + end; + + if (unbal <> nil) then + begin + unbal := balance(unbal); + if (parentunbal = nil) then + FRoot := unbal + else + begin + depth := unbaldepth - 1; + if depth in branch then + cmp := 1 else + cmp := -1; + if (cmp < 0) then + parentunbal.FLt := unbal else + parentunbal.FGt := unbal; + end; + end; + end; + result := h; +end; + +function TSuperAvlTree.Search(const k: SOString; st: TSuperAvlSearchTypes): TSuperAvlEntry; +var + cmp, target_cmp: integer; + match_h, h: TSuperAvlEntry; + ha: Cardinal; +begin + ha := TSuperAvlEntry.Hash(k); + + match_h := nil; + h := FRoot; + + if (stLess in st) then + target_cmp := 1 else + if (stGreater in st) then + target_cmp := -1 else + target_cmp := 0; + + while (h <> nil) do + begin + if h.FHash < ha then cmp := -1 else + if h.FHash > ha then cmp := 1 else + cmp := 0; + + if cmp = 0 then + cmp := CompareKeyNode(PSOChar(k), h); + if (cmp = 0) then + begin + if (stEqual in st) then + begin + match_h := h; + break; + end; + cmp := -target_cmp; + end + else + if (target_cmp <> 0) then + if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) = 0 then + match_h := h; + if cmp < 0 then + h := h.FLt else + h := h.FGt; + end; + result := match_h; +end; + +function TSuperAvlTree.Delete(const k: SOString): ISuperObject; +var + depth, rm_depth: longint; + branch: TSuperAvlBitArray; + h, parent, child, path, rm, parent_rm: TSuperAvlEntry; + cmp, cmp_shortened_sub_with_path, reduced_depth, bf: integer; + ha: Cardinal; +begin + ha := TSuperAvlEntry.Hash(k); + cmp_shortened_sub_with_path := 0; + branch := []; + + depth := 0; + h := FRoot; + parent := nil; + while true do + begin + if (h = nil) then + exit; + if h.FHash < ha then cmp := -1 else + if h.FHash > ha then cmp := 1 else + cmp := 0; + + if cmp = 0 then + cmp := CompareKeyNode(k, h); + if (cmp = 0) then + break; + parent := h; + if (cmp > 0) then + begin + h := h.FGt; + include(branch, depth) + end else + begin + h := h.FLt; + exclude(branch, depth) + end; + inc(depth); + cmp_shortened_sub_with_path := cmp; + end; + rm := h; + parent_rm := parent; + rm_depth := depth; + + if (h.FBf < 0) then + begin + child := h.FLt; + exclude(branch, depth); + cmp := -1; + end else + begin + child := h.FGt; + include(branch, depth); + cmp := 1; + end; + inc(depth); + + if (child <> nil) then + begin + cmp := -cmp; + repeat + parent := h; + h := child; + if (cmp < 0) then + begin + child := h.FLt; + exclude(branch, depth); + end else + begin + child := h.FGt; + include(branch, depth); + end; + inc(depth); + until (child = nil); + + if (parent = rm) then + cmp_shortened_sub_with_path := -cmp else + cmp_shortened_sub_with_path := cmp; + + if cmp > 0 then + child := h.FLt else + child := h.FGt; + end; + + if (parent = nil) then + FRoot := child else + if (cmp_shortened_sub_with_path < 0) then + parent.FLt := child else + parent.FGt := child; + + if parent = rm then + path := h else + path := parent; + + if (h <> rm) then + begin + h.FLt := rm.FLt; + h.FGt := rm.FGt; + h.FBf := rm.FBf; + if (parent_rm = nil) then + FRoot := h + else + begin + depth := rm_depth - 1; + if (depth in branch) then + parent_rm.FGt := h else + parent_rm.FLt := h; + end; + end; + + if (path <> nil) then + begin + h := FRoot; + parent := nil; + depth := 0; + while (h <> path) do + begin + if (depth in branch) then + begin + child := h.FGt; + h.FGt := parent; + end else + begin + child := h.FLt; + h.FLt := parent; + end; + inc(depth); + parent := h; + h := child; + end; + + reduced_depth := 1; + cmp := cmp_shortened_sub_with_path; + while true do + begin + if (reduced_depth <> 0) then + begin + bf := h.FBf; + if (cmp < 0) then + inc(bf) else + dec(bf); + if ((bf = -2) or (bf = 2)) then + begin + h := balance(h); + bf := h.FBf; + end else + h.FBf := bf; + reduced_depth := integer(bf = 0); + end; + if (parent = nil) then + break; + child := h; + h := parent; + dec(depth); + if depth in branch then + cmp := 1 else + cmp := -1; + if (cmp < 0) then + begin + parent := h.FLt; + h.FLt := child; + end else + begin + parent := h.FGt; + h.FGt := child; + end; + end; + FRoot := h; + end; + if rm <> nil then + begin + Result := rm.GetValue; + doDeleteEntry(rm, false); + dec(FCount); + end; +end; + +procedure TSuperAvlTree.Pack(all: boolean); +var + node1, node2: TSuperAvlEntry; + list: TList; + i: Integer; +begin + node1 := FRoot; + list := TList.Create; + while node1 <> nil do + begin + if (node1.FLt = nil) then + begin + node2 := node1.FGt; + if (node1.FPtr = nil) then + list.Add(node1) else + if all then + node1.Value.Pack(all); + end + else + begin + node2 := node1.FLt; + node1.FLt := node2.FGt; + node2.FGt := node1; + end; + node1 := node2; + end; + for i := 0 to list.Count - 1 do + Delete(TSuperAvlEntry(list[i]).FName); + list.Free; +end; + +procedure TSuperAvlTree.Clear(all: boolean); +var + node1, node2: TSuperAvlEntry; +begin + node1 := FRoot; + while node1 <> nil do + begin + if (node1.FLt = nil) then + begin + node2 := node1.FGt; + doDeleteEntry(node1, all); + end + else + begin + node2 := node1.FLt; + node1.FLt := node2.FGt; + node2.FGt := node1; + end; + node1 := node2; + end; + FRoot := nil; + FCount := 0; +end; + +function TSuperAvlTree.CompareKeyNode(const k: SOString; h: TSuperAvlEntry): integer; +begin + Result := StrComp(PSOChar(k), PSOChar(h.FName)); +end; + +function TSuperAvlTree.CompareNodeNode(node1, node2: TSuperAvlEntry): integer; +begin + Result := StrComp(PSOChar(node1.FName), PSOChar(node2.FName)); +end; + +{ TSuperAvlIterator } + +(* Initialize depth to invalid value, to indicate iterator is +** invalid. (Depth is zero-base.) It's not necessary to initialize +** iterators prior to passing them to the "start" function. +*) + +constructor TSuperAvlIterator.Create(tree: TSuperAvlTree); +begin + FDepth := not 0; + FTree := tree; +end; + +procedure TSuperAvlIterator.Search(const k: SOString; st: TSuperAvlSearchTypes); +var + h: TSuperAvlEntry; + d: longint; + cmp, target_cmp: integer; + ha: Cardinal; +begin + ha := TSuperAvlEntry.Hash(k); + h := FTree.FRoot; + d := 0; + FDepth := not 0; + if (h = nil) then + exit; + + if (stLess in st) then + target_cmp := 1 else + if (stGreater in st) then + target_cmp := -1 else + target_cmp := 0; + + while true do + begin + if h.FHash < ha then cmp := -1 else + if h.FHash > ha then cmp := 1 else + cmp := 0; + + if cmp = 0 then + cmp := FTree.CompareKeyNode(k, h); + if (cmp = 0) then + begin + if (stEqual in st) then + begin + FDepth := d; + break; + end; + cmp := -target_cmp; + end + else + if (target_cmp <> 0) then + if ((cmp xor target_cmp) and SUPER_AVL_MASK_HIGH_BIT) = 0 then + FDepth := d; + if cmp < 0 then + h := h.FLt else + h := h.FGt; + if (h = nil) then + break; + if (cmp > 0) then + include(FBranch, d) else + exclude(FBranch, d); + FPath[d] := h; + inc(d); + end; +end; + +procedure TSuperAvlIterator.First; +var + h: TSuperAvlEntry; +begin + h := FTree.FRoot; + FDepth := not 0; + FBranch := []; + while (h <> nil) do + begin + if (FDepth <> not 0) then + FPath[FDepth] := h; + inc(FDepth); + h := h.FLt; + end; +end; + +procedure TSuperAvlIterator.Last; +var + h: TSuperAvlEntry; +begin + h := FTree.FRoot; + FDepth := not 0; + FBranch := [0..SUPER_AVL_MAX_DEPTH - 1]; + while (h <> nil) do + begin + if (FDepth <> not 0) then + FPath[FDepth] := h; + inc(FDepth); + h := h.FGt; + end; +end; + +function TSuperAvlIterator.MoveNext: boolean; +begin + if FDepth = not 0 then + First else + Next; + Result := GetIter <> nil; +end; + +function TSuperAvlIterator.GetIter: TSuperAvlEntry; +begin + if (FDepth = not 0) then + begin + result := nil; + exit; + end; + if FDepth = 0 then + Result := FTree.FRoot else + Result := FPath[FDepth - 1]; +end; + +procedure TSuperAvlIterator.Next; +var + h: TSuperAvlEntry; +begin + if (FDepth <> not 0) then + begin + if FDepth = 0 then + h := FTree.FRoot.FGt else + h := FPath[FDepth - 1].FGt; + + if (h = nil) then + repeat + if (FDepth = 0) then + begin + FDepth := not 0; + break; + end; + dec(FDepth); + until (not (FDepth in FBranch)) + else + begin + include(FBranch, FDepth); + FPath[FDepth] := h; + inc(FDepth); + while true do + begin + h := h.FLt; + if (h = nil) then + break; + exclude(FBranch, FDepth); + FPath[FDepth] := h; + inc(FDepth); + end; + end; + end; +end; + +procedure TSuperAvlIterator.Prior; +var + h: TSuperAvlEntry; +begin + if (FDepth <> not 0) then + begin + if FDepth = 0 then + h := FTree.FRoot.FLt else + h := FPath[FDepth - 1].FLt; + if (h = nil) then + repeat + if (FDepth = 0) then + begin + FDepth := not 0; + break; + end; + dec(FDepth); + until (FDepth in FBranch) + else + begin + exclude(FBranch, FDepth); + FPath[FDepth] := h; + inc(FDepth); + while true do + begin + h := h.FGt; + if (h = nil) then + break; + include(FBranch, FDepth); + FPath[FDepth] := h; + inc(FDepth); + end; + end; + end; +end; + +procedure TSuperAvlTree.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); +begin + Entry.Free; +end; + +function TSuperAvlTree.GetEnumerator: TSuperAvlIterator; +begin + Result := TSuperAvlIterator.Create(Self); +end; + +{ TSuperAvlEntry } + +constructor TSuperAvlEntry.Create(const AName: SOString; Obj: Pointer); +begin + FName := AName; + FPtr := Obj; + FHash := Hash(FName); +end; + +function TSuperAvlEntry.GetValue: ISuperObject; +begin + Result := ISuperObject(FPtr) +end; + +class function TSuperAvlEntry.Hash(const k: SOString): Cardinal; +var + h: cardinal; + i: Integer; +begin + h := 0; + for i := 1 to Length(k) do + h := h*129 + ord(k[i]) + $9e370001; + Result := h; +end; + +procedure TSuperAvlEntry.SetValue(const val: ISuperObject); +begin + ISuperObject(FPtr) := val; +end; + +{ TSuperTableString } + +function TSuperTableString.GetValues: ISuperObject; +var + ite: TSuperAvlIterator; + obj: TSuperAvlEntry; +begin + Result := TSuperObject.Create(stArray); + ite := TSuperAvlIterator.Create(Self); + try + ite.First; + obj := ite.GetIter; + while obj <> nil do + begin + Result.AsArray.Add(obj.Value); + ite.Next; + obj := ite.GetIter; + end; + finally + ite.Free; + end; +end; + +function TSuperTableString.GetNames: ISuperObject; +var + ite: TSuperAvlIterator; + obj: TSuperAvlEntry; +begin + Result := TSuperObject.Create(stArray); + ite := TSuperAvlIterator.Create(Self); + try + ite.First; + obj := ite.GetIter; + while obj <> nil do + begin + Result.AsArray.Add(TSuperObject.Create(obj.FName)); + ite.Next; + obj := ite.GetIter; + end; + finally + ite.Free; + end; +end; + +procedure TSuperTableString.doDeleteEntry(Entry: TSuperAvlEntry; all: boolean); +begin + if Entry.Ptr <> nil then + begin + if all then Entry.Value.Clear(true); + Entry.Value := nil; + end; + inherited; +end; + +function TSuperTableString.Find(const k: SOString; var value: ISuperObject): Boolean; +var + e: TSuperAvlEntry; +begin + e := Search(k); + if e <> nil then + begin + value := e.Value; + Result := True; + end else + Result := False; +end; + +function TSuperTableString.Exists(const k: SOString): Boolean; +begin + Result := Search(k) <> nil; +end; + +function TSuperTableString.GetO(const k: SOString): ISuperObject; +var + e: TSuperAvlEntry; +begin + e := Search(k); + if e <> nil then + Result := e.Value else + Result := nil +end; + +procedure TSuperTableString.PutO(const k: SOString; const value: ISuperObject); +var + entry: TSuperAvlEntry; +begin + entry := Insert(TSuperAvlEntry.Create(k, Pointer(value))); + if entry.FPtr <> nil then + ISuperObject(entry.FPtr)._AddRef; +end; + +procedure TSuperTableString.PutS(const k: SOString; const value: SOString); +begin + PutO(k, TSuperObject.Create(Value)); +end; + +function TSuperTableString.GetS(const k: SOString): SOString; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj.AsString else + Result := ''; +end; + +procedure TSuperTableString.PutI(const k: SOString; value: SuperInt); +begin + PutO(k, TSuperObject.Create(Value)); +end; + +function TSuperTableString.GetI(const k: SOString): SuperInt; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj.AsInteger else + Result := 0; +end; + +procedure TSuperTableString.PutD(const k: SOString; value: Double); +begin + PutO(k, TSuperObject.Create(Value)); +end; + +procedure TSuperTableString.PutC(const k: SOString; value: Currency); +begin + PutO(k, TSuperObject.CreateCurrency(Value)); +end; + +function TSuperTableString.GetC(const k: SOString): Currency; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj.AsCurrency else + Result := 0.0; +end; + +function TSuperTableString.GetD(const k: SOString): Double; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj.AsDouble else + Result := 0.0; +end; + +procedure TSuperTableString.PutB(const k: SOString; value: Boolean); +begin + PutO(k, TSuperObject.Create(Value)); +end; + +function TSuperTableString.GetB(const k: SOString): Boolean; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj.AsBoolean else + Result := False; +end; + +{$IFDEF SUPER_METHOD} +procedure TSuperTableString.PutM(const k: SOString; value: TSuperMethod); +begin + PutO(k, TSuperObject.Create(Value)); +end; +{$ENDIF} + +{$IFDEF SUPER_METHOD} +function TSuperTableString.GetM(const k: SOString): TSuperMethod; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj.AsMethod else + Result := nil; +end; +{$ENDIF} + +procedure TSuperTableString.PutN(const k: SOString; const value: ISuperObject); +begin + if value <> nil then + PutO(k, TSuperObject.Create(stNull)) else + PutO(k, value); +end; + +function TSuperTableString.GetN(const k: SOString): ISuperObject; +var + obj: ISuperObject; +begin + obj := GetO(k); + if obj <> nil then + Result := obj else + Result := TSuperObject.Create(stNull); +end; + + +{$IFDEF HAVE_RTTI} + +{ TSuperAttribute } + +constructor TSuperAttribute.Create(const AName: string); +begin + FName := AName; +end; + +{ TSuperRttiContext } + +constructor TSuperRttiContext.Create; +begin + Context := TRttiContext.Create; + SerialFromJson := TDictionary.Create; + SerialToJson := TDictionary.Create; + + SerialFromJson.Add(TypeInfo(Boolean), serialfromboolean); + SerialFromJson.Add(TypeInfo(TDateTime), serialfromdatetime); + SerialFromJson.Add(TypeInfo(TGUID), serialfromguid); + SerialToJson.Add(TypeInfo(Boolean), serialtoboolean); + SerialToJson.Add(TypeInfo(TDateTime), serialtodatetime); + SerialToJson.Add(TypeInfo(TGUID), serialtoguid); +end; + +destructor TSuperRttiContext.Destroy; +begin + SerialFromJson.Free; + SerialToJson.Free; + Context.Free; +end; + +class function TSuperRttiContext.GetFieldName(r: TRttiField): string; +var + o: TCustomAttribute; +begin + for o in r.GetAttributes do + if o is SOName then + Exit(SOName(o).Name); + Result := r.Name; +end; + +class function TSuperRttiContext.GetFieldDefault(r: TRttiField; const obj: ISuperObject): ISuperObject; +var + o: TCustomAttribute; +begin + if not ObjectIsType(obj, stNull) then Exit(obj); + for o in r.GetAttributes do + if o is SODefault then + Exit(SO(SODefault(o).Name)); + Result := obj; +end; + +function TSuperRttiContext.AsType(const obj: ISuperObject): T; +var + ret: TValue; +begin + if FromJson(TypeInfo(T), obj, ret) then + Result := ret.AsType else + raise exception.Create('Marshalling error'); +end; + +function TSuperRttiContext.AsJson(const obj: T; const index: ISuperObject = nil): ISuperObject; +var + v: TValue; +begin + TValue.Make(@obj, TypeInfo(T), v); + if index <> nil then + Result := ToJson(v, index) else + Result := ToJson(v, so); +end; + +function TSuperRttiContext.FromJson(TypeInfo: PTypeInfo; const obj: ISuperObject; + var Value: TValue): Boolean; + + procedure FromChar; + begin + if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then + begin + Value := string(AnsiString(obj.AsString)[1]); + Result := True; + end else + Result := False; + end; + + procedure FromWideChar; + begin + if ObjectIsType(obj, stString) and (Length(obj.AsString) = 1) then + begin + Value := obj.AsString[1]; + Result := True; + end else + Result := False; + end; + + procedure FromInt64; + var + i: Int64; + begin + case ObjectGetType(obj) of + stInt: + begin + TValue.Make(nil, TypeInfo, Value); + TValueData(Value).FAsSInt64 := obj.AsInteger; + Result := True; + end; + stString: + begin + if TryStrToInt64(obj.AsString, i) then + begin + TValue.Make(nil, TypeInfo, Value); + TValueData(Value).FAsSInt64 := i; + Result := True; + end else + Result := False; + end; + else + Result := False; + end; + end; + + procedure FromInt(const obj: ISuperObject); + var + TypeData: PTypeData; + i: Integer; + o: ISuperObject; + begin + case ObjectGetType(obj) of + stInt, stBoolean: + begin + i := obj.AsInteger; + TypeData := GetTypeData(TypeInfo); + if TypeData.MaxValue > TypeData.MinValue then + Result := (i >= TypeData.MinValue) and (i <= TypeData.MaxValue) else + Result := (i >= TypeData.MinValue) and (i <= Int64(PCardinal(@TypeData.MaxValue)^)); + if Result then + TValue.Make(@i, TypeInfo, Value); + end; + stString: + begin + o := SO(obj.AsString); + if not ObjectIsType(o, stString) then + FromInt(o) else + Result := False; + end; + else + Result := False; + end; + end; + + procedure fromSet; + var + i: Integer; + begin + case ObjectGetType(obj) of + stInt: + begin + TValue.Make(nil, TypeInfo, Value); + TValueData(Value).FAsSLong := obj.AsInteger; + Result := True; + end; + stString: + begin + if TryStrToInt(obj.AsString, i) then + begin + TValue.Make(nil, TypeInfo, Value); + TValueData(Value).FAsSLong := i; + Result := True; + end else + Result := False; + end; + else + Result := False; + end; + end; + + procedure FromFloat(const obj: ISuperObject); + var + o: ISuperObject; + begin + case ObjectGetType(obj) of + stInt, stDouble, stCurrency: + begin + TValue.Make(nil, TypeInfo, Value); + case GetTypeData(TypeInfo).FloatType of + ftSingle: TValueData(Value).FAsSingle := obj.AsDouble; + ftDouble: TValueData(Value).FAsDouble := obj.AsDouble; + ftExtended: TValueData(Value).FAsExtended := obj.AsDouble; + ftComp: TValueData(Value).FAsSInt64 := obj.AsInteger; + ftCurr: TValueData(Value).FAsCurr := obj.AsCurrency; + end; + Result := True; + end; + stString: + begin + o := SO(obj.AsString); + if not ObjectIsType(o, stString) then + FromFloat(o) else + Result := False; + end + else + Result := False; + end; + end; + + procedure FromString; + begin + case ObjectGetType(obj) of + stObject, stArray: + Result := False; + stnull: + begin + Value := ''; + Result := True; + end; + else + Value := obj.AsString; + Result := True; + end; + end; + + procedure FromClass; + var + f: TRttiField; + v: TValue; + begin + case ObjectGetType(obj) of + stObject: + begin + Result := True; + if Value.Kind <> tkClass then + Value := GetTypeData(TypeInfo).ClassType.Create; + for f in Context.GetType(Value.AsObject.ClassType).GetFields do + if f.FieldType <> nil then + begin + v := TValue.Empty; + Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v); + if Result then + f.SetValue(Value.AsObject, v) else + Exit; + end; + end; + stNull: + begin + Value := nil; + Result := True; + end + else + // error + Value := nil; + Result := False; + end; + end; + + procedure FromRecord; + var + f: TRttiField; + p: Pointer; + v: TValue; + begin + Result := True; + TValue.Make(nil, TypeInfo, Value); + for f in Context.GetType(TypeInfo).GetFields do + begin + if ObjectIsType(obj, stObject) and (f.FieldType <> nil) then + begin +{$IFDEF VER210} + p := IValueData(TValueData(Value).FHeapData).GetReferenceToRawData; +{$ELSE} + p := TValueData(Value).FValueData.GetReferenceToRawData; +{$ENDIF} + Result := FromJson(f.FieldType.Handle, GetFieldDefault(f, obj.AsObject[GetFieldName(f)]), v); + if Result then + f.SetValue(p, v) else + begin + //Writeln(f.Name); + Exit; + end; + end else + begin + Result := False; + Exit; + end; + end; + end; + + procedure FromDynArray; + var + i: Integer; + p: Pointer; + pb: PByte; + val: TValue; + typ: PTypeData; + el: PTypeInfo; + begin + case ObjectGetType(obj) of + stArray: + begin + i := obj.AsArray.Length; + p := nil; + DynArraySetLength(p, TypeInfo, 1, @i); + pb := p; + typ := GetTypeData(TypeInfo); + if typ.elType <> nil then + el := typ.elType^ else + el := typ.elType2^; + + Result := True; + for i := 0 to i - 1 do + begin + Result := FromJson(el, obj.AsArray[i], val); + if not Result then + Break; + val.ExtractRawData(pb); + val := TValue.Empty; + Inc(pb, typ.elSize); + end; + if Result then + TValue.MakeWithoutCopy(@p, TypeInfo, Value) else + DynArrayClear(p, TypeInfo); + end; + stNull: + begin + TValue.MakeWithoutCopy(nil, TypeInfo, Value); + Result := True; + end; + else + i := 1; + p := nil; + DynArraySetLength(p, TypeInfo, 1, @i); + pb := p; + typ := GetTypeData(TypeInfo); + if typ.elType <> nil then + el := typ.elType^ else + el := typ.elType2^; + + Result := FromJson(el, obj, val); + val.ExtractRawData(pb); + val := TValue.Empty; + + if Result then + TValue.MakeWithoutCopy(@p, TypeInfo, Value) else + DynArrayClear(p, TypeInfo); + end; + end; + + procedure FromArray; + var + ArrayData: PArrayTypeData; + idx: Integer; + function ProcessDim(dim: Byte; const o: ISuperobject): Boolean; + var + i: Integer; + v: TValue; + a: PTypeData; + begin + if ObjectIsType(o, stArray) and (ArrayData.Dims[dim-1] <> nil) then + begin + a := @GetTypeData(ArrayData.Dims[dim-1]^).ArrayData; + if (a.MaxValue - a.MinValue + 1) <> o.AsArray.Length then + begin + Result := False; + Exit; + end; + Result := True; + if dim = ArrayData.DimCount then + for i := a.MinValue to a.MaxValue do + begin + Result := FromJson(ArrayData.ElType^, o.AsArray[i], v); + if not Result then + Exit; + Value.SetArrayElement(idx, v); + inc(idx); + end + else + for i := a.MinValue to a.MaxValue do + begin + Result := ProcessDim(dim + 1, o.AsArray[i]); + if not Result then + Exit; + end; + end else + Result := False; + end; + var + i: Integer; + v: TValue; + begin + TValue.Make(nil, TypeInfo, Value); + ArrayData := @GetTypeData(TypeInfo).ArrayData; + idx := 0; + if ArrayData.DimCount = 1 then + begin + if ObjectIsType(obj, stArray) and (obj.AsArray.Length = ArrayData.ElCount) then + begin + Result := True; + for i := 0 to ArrayData.ElCount - 1 do + begin + Result := FromJson(ArrayData.ElType^, obj.AsArray[i], v); + if not Result then + Exit; + Value.SetArrayElement(idx, v); + v := TValue.Empty; + inc(idx); + end; + end else + Result := False; + end else + Result := ProcessDim(1, obj); + end; + + procedure FromClassRef; + var + r: TRttiType; + begin + if ObjectIsType(obj, stString) then + begin + r := Context.FindType(obj.AsString); + if r <> nil then + begin + Value := TRttiInstanceType(r).MetaclassType; + Result := True; + end else + Result := False; + end else + Result := False; + end; + + procedure FromUnknown; + begin + case ObjectGetType(obj) of + stBoolean: + begin + Value := obj.AsBoolean; + Result := True; + end; + stDouble: + begin + Value := obj.AsDouble; + Result := True; + end; + stCurrency: + begin + Value := obj.AsCurrency; + Result := True; + end; + stInt: + begin + Value := obj.AsInteger; + Result := True; + end; + stString: + begin + Value := obj.AsString; + Result := True; + end + else + Value := nil; + Result := False; + end; + end; + + procedure FromInterface; + const soguid: TGuid = '{4B86A9E3-E094-4E5A-954A-69048B7B6327}'; + var + o: ISuperObject; + begin + if CompareMem(@GetTypeData(TypeInfo).Guid, @soguid, SizeOf(TGUID)) then + begin + if obj <> nil then + TValue.Make(@obj, TypeInfo, Value) else + begin + o := TSuperObject.Create(stNull); + TValue.Make(@o, TypeInfo, Value); + end; + Result := True; + end else + Result := False; + end; +var + Serial: TSerialFromJson; +begin + + if TypeInfo <> nil then + begin + if not SerialFromJson.TryGetValue(TypeInfo, Serial) then + case TypeInfo.Kind of + tkChar: FromChar; + tkInt64: FromInt64; + tkEnumeration, tkInteger: FromInt(obj); + tkSet: fromSet; + tkFloat: FromFloat(obj); + tkString, tkLString, tkUString, tkWString: FromString; + tkClass: FromClass; + tkMethod: ; + tkWChar: FromWideChar; + tkRecord: FromRecord; + tkPointer: ; + tkInterface: FromInterface; + tkArray: FromArray; + tkDynArray: FromDynArray; + tkClassRef: FromClassRef; + else + FromUnknown + end else + begin + TValue.Make(nil, TypeInfo, Value); + Result := Serial(Self, obj, Value); + end; + end else + Result := False; +end; + +function TSuperRttiContext.ToJson(var value: TValue; const index: ISuperObject): ISuperObject; + procedure ToInt64; + begin + Result := TSuperObject.Create(SuperInt(Value.AsInt64)); + end; + + procedure ToChar; + begin + Result := TSuperObject.Create(string(Value.AsType)); + end; + + procedure ToInteger; + begin + Result := TSuperObject.Create(TValueData(Value).FAsSLong); + end; + + procedure ToFloat; + begin + case Value.TypeData.FloatType of + ftSingle: Result := TSuperObject.Create(TValueData(Value).FAsSingle); + ftDouble: Result := TSuperObject.Create(TValueData(Value).FAsDouble); + ftExtended: Result := TSuperObject.Create(TValueData(Value).FAsExtended); + ftComp: Result := TSuperObject.Create(TValueData(Value).FAsSInt64); + ftCurr: Result := TSuperObject.CreateCurrency(TValueData(Value).FAsCurr); + end; + end; + + procedure ToString; + begin + Result := TSuperObject.Create(string(Value.AsType)); + end; + + procedure ToClass; + var + o: ISuperObject; + f: TRttiField; + v: TValue; + begin + if TValueData(Value).FAsObject <> nil then + begin + o := index[IntToStr(Integer(Value.AsObject))]; + if o = nil then + begin + Result := TSuperObject.Create(stObject); + index[IntToStr(Integer(Value.AsObject))] := Result; + for f in Context.GetType(Value.AsObject.ClassType).GetFields do + if f.FieldType <> nil then + begin + v := f.GetValue(Value.AsObject); + Result.AsObject[GetFieldName(f)] := ToJson(v, index); + end + end else + Result := o; + end else + Result := nil; + end; + + procedure ToWChar; + begin + Result := TSuperObject.Create(string(Value.AsType)); + end; + + procedure ToVariant; + begin + Result := SO(Value.AsVariant); + end; + + procedure ToRecord; + var + f: TRttiField; + v: TValue; + begin + Result := TSuperObject.Create(stObject); + for f in Context.GetType(Value.TypeInfo).GetFields do + begin +{$IFDEF VER210} + v := f.GetValue(IValueData(TValueData(Value).FHeapData).GetReferenceToRawData); +{$ELSE} + v := f.GetValue(TValueData(Value).FValueData.GetReferenceToRawData); +{$ENDIF} + Result.AsObject[GetFieldName(f)] := ToJson(v, index); + end; + end; + + procedure ToArray; + var + idx: Integer; + ArrayData: PArrayTypeData; + + procedure ProcessDim(dim: Byte; const o: ISuperObject); + var + dt: PTypeData; + i: Integer; + o2: ISuperObject; + v: TValue; + begin + if ArrayData.Dims[dim-1] = nil then Exit; + dt := GetTypeData(ArrayData.Dims[dim-1]^); + if Dim = ArrayData.DimCount then + for i := dt.MinValue to dt.MaxValue do + begin + v := Value.GetArrayElement(idx); + o.AsArray.Add(toJSon(v, index)); + inc(idx); + end + else + for i := dt.MinValue to dt.MaxValue do + begin + o2 := TSuperObject.Create(stArray); + o.AsArray.Add(o2); + ProcessDim(dim + 1, o2); + end; + end; + var + i: Integer; + v: TValue; + begin + Result := TSuperObject.Create(stArray); + ArrayData := @Value.TypeData.ArrayData; + idx := 0; + if ArrayData.DimCount = 1 then + for i := 0 to ArrayData.ElCount - 1 do + begin + v := Value.GetArrayElement(i); + Result.AsArray.Add(toJSon(v, index)) + end + else + ProcessDim(1, Result); + end; + + procedure ToDynArray; + var + i: Integer; + v: TValue; + begin + Result := TSuperObject.Create(stArray); + for i := 0 to Value.GetArrayLength - 1 do + begin + v := Value.GetArrayElement(i); + Result.AsArray.Add(toJSon(v, index)); + end; + end; + + procedure ToClassRef; + begin + if TValueData(Value).FAsClass <> nil then + Result := TSuperObject.Create(string( + TValueData(Value).FAsClass.UnitName + '.' + + TValueData(Value).FAsClass.ClassName)) else + Result := nil; + end; + + procedure ToInterface; +{$IFNDEF VER210} + var + intf: IInterface; +{$ENDIF} + begin +{$IFDEF VER210} + if TValueData(Value).FHeapData <> nil then + TValueData(Value).FHeapData.QueryInterface(ISuperObject, Result) else + Result := nil; +{$ELSE} + if TValueData(Value).FValueData <> nil then + begin + intf := IInterface(PPointer(TValueData(Value).FValueData.GetReferenceToRawData)^); + if intf <> nil then + intf.QueryInterface(ISuperObject, Result) else + Result := nil; + end else + Result := nil; +{$ENDIF} + end; + +var + Serial: TSerialToJson; +begin + if not SerialToJson.TryGetValue(value.TypeInfo, Serial) then + case Value.Kind of + tkInt64: ToInt64; + tkChar: ToChar; + tkSet, tkInteger, tkEnumeration: ToInteger; + tkFloat: ToFloat; + tkString, tkLString, tkUString, tkWString: ToString; + tkClass: ToClass; + tkWChar: ToWChar; + tkVariant: ToVariant; + tkRecord: ToRecord; + tkArray: ToArray; + tkDynArray: ToDynArray; + tkClassRef: ToClassRef; + tkInterface: ToInterface; + else + result := nil; + end else + Result := Serial(Self, value, index); +end; + +{ TSuperObjectHelper } + +constructor TSuperObjectHelper.FromJson(const obj: ISuperObject; ctx: TSuperRttiContext = nil); +var + v: TValue; + ctxowned: Boolean; +begin + if ctx = nil then + begin + ctx := TSuperRttiContext.Create; + ctxowned := True; + end else + ctxowned := False; + try + v := Self; + if not ctx.FromJson(v.TypeInfo, obj, v) then + raise Exception.Create('Invalid object'); + finally + if ctxowned then + ctx.Free; + end; +end; + +constructor TSuperObjectHelper.FromJson(const str: string; ctx: TSuperRttiContext = nil); +begin + FromJson(SO(str), ctx); +end; + +function TSuperObjectHelper.ToJson(ctx: TSuperRttiContext = nil): ISuperObject; +var + v: TValue; + ctxowned: boolean; +begin + if ctx = nil then + begin + ctx := TSuperRttiContext.Create; + ctxowned := True; + end else + ctxowned := False; + try + v := Self; + Result := ctx.ToJson(v, SO); + finally + if ctxowned then + ctx.Free; + end; +end; + +{$ENDIF} + +{$IFDEF DEBUG} +initialization + +finalization + Assert(debugcount = 0, 'Memory leak'); +{$ENDIF} +end. + diff --git a/src/thirdparty/synacode.pas b/src/thirdparty/synacode.pas new file mode 100644 index 0000000..45f3c07 --- /dev/null +++ b/src/thirdparty/synacode.pas @@ -0,0 +1,1454 @@ +{==============================================================================| +| Project : Ararat Synapse | 002.002.000 | +|==============================================================================| +| Content: Coding and decoding support | +|==============================================================================| +| Copyright (c)1999-2007, Lukas Gebauer | +| All rights reserved. | +| | +| Redistribution and use in source and binary forms, with or without | +| modification, are permitted provided that the following conditions are met: | +| | +| Redistributions of source code must retain the above copyright notice, this | +| list of conditions and the following disclaimer. | +| | +| Redistributions in binary form must reproduce the above copyright notice, | +| this list of conditions and the following disclaimer in the documentation | +| and/or other materials provided with the distribution. | +| | +| Neither the name of Lukas Gebauer nor the names of its contributors may | +| be used to endorse or promote products derived from this software without | +| specific prior written permission. | +| | +| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | +| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | +| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | +| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | +| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | +| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | +| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | +| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | +| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | +| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | +| DAMAGE. | +|==============================================================================| +| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| +| Portions created by Lukas Gebauer are Copyright (c)2000-2007. | +| All Rights Reserved. | +|==============================================================================| +| Contributor(s): | +|==============================================================================| +| History: see HISTORY.HTM from distribution package | +| (Found at URL: http://www.ararat.cz/synapse/) | +|==============================================================================} + +{:@abstract(Various encoding and decoding support)} +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} +{$Q-} +{$R-} +{$H+} + +unit synacode; + +interface + +uses + SysUtils; + +type + TSpecials = set of AnsiChar; + +const + + SpecialChar: TSpecials = + ['=', '(', ')', '[', ']', '<', '>', ':', ';', ',', '@', '/', '?', '\', + '"', '_']; + NonAsciiChar: TSpecials = + [Char(0)..Char(31), Char(127)..Char(255)]; + URLFullSpecialChar: TSpecials = + [';', '/', '?', ':', '@', '=', '&', '#', '+']; + URLSpecialChar: TSpecials = + [#$00..#$20, '_', '<', '>', '"', '%', '{', '}', '|', '\', '^', '~', '[', ']', + '`', #$7F..#$FF]; + TableBase64 = + 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/='; + TableBase64mod = + 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+,='; + TableUU = + '`!"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_'; + TableXX = + '+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'; + ReTablebase64 = + #$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$3E +#$40 + +#$40 +#$40 +#$3F +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 +#$3A +#$3B +#$3C + +#$3D +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$00 +#$01 +#$02 +#$03 + +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A +#$0B +#$0C +#$0D +#$0E +#$0F + +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 +#$19 +#$40 +#$40 + +#$40 +#$40 +#$40 +#$40 +#$1A +#$1B +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 + +#$22 +#$23 +#$24 +#$25 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D + +#$2E +#$2F +#$30 +#$31 +#$32 +#$33 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; + ReTableUU = + #$01 +#$02 +#$03 +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A +#$0B +#$0C + +#$0D +#$0E +#$0F +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 + +#$19 +#$1A +#$1B +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 +#$22 +#$23 +#$24 + +#$25 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D +#$2E +#$2F +#$30 + +#$31 +#$32 +#$33 +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 +#$3A +#$3B +#$3C + +#$3D +#$3E +#$3F +#$00 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 + +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 + +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; + ReTableXX = + #$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$00 +#$40 + +#$01 +#$40 +#$40 +#$02 +#$03 +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A + +#$0B +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$0C +#$0D +#$0E +#$0F + +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 +#$19 +#$1A +#$1B + +#$1C +#$1D +#$1E +#$1F +#$20 +#$21 +#$22 +#$23 +#$24 +#$25 +#$40 +#$40 + +#$40 +#$40 +#$40 +#$40 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D + +#$2E +#$2F +#$30 +#$31 +#$32 +#$33 +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 + +#$3A +#$3B +#$3C +#$3D +#$3E +#$3F +#$40 +#$40 +#$40 +#$40 +#$40 +#$40; + +{:Decodes triplet encoding with a given character delimiter. It is used for + decoding quoted-printable or URL encoding.} +function DecodeTriplet(const Value: AnsiString; Delimiter: AnsiChar): AnsiString; + +{:Decodes a string from quoted printable form. (also decodes triplet sequences + like '=7F')} +function DecodeQuotedPrintable(const Value: AnsiString): AnsiString; + +{:Decodes a string of URL encoding. (also decodes triplet sequences like '%7F')} +function DecodeURL(const Value: AnsiString): AnsiString; + +{:Performs triplet encoding with a given character delimiter. Used for encoding + quoted-printable or URL encoding.} +function EncodeTriplet(const Value: AnsiString; Delimiter: AnsiChar; + Specials: TSpecials): AnsiString; + +{:Encodes a string to triplet quoted printable form. All @link(NonAsciiChar) + are encoded.} +function EncodeQuotedPrintable(const Value: AnsiString): AnsiString; + +{:Encodes a string to triplet quoted printable form. All @link(NonAsciiChar) and + @link(SpecialChar) are encoded.} +function EncodeSafeQuotedPrintable(const Value: AnsiString): AnsiString; + +{:Encodes a string to URL format. Used for encoding data from a form field in + HTTP, etc. (Encodes all critical characters including characters used as URL + delimiters ('/',':', etc.)} +function EncodeURLElement(const Value: AnsiString): AnsiString; + +{:Encodes a string to URL format. Used to encode critical characters in all + URLs.} +function EncodeURL(const Value: AnsiString): AnsiString; + +{:Decode 4to3 encoding with given table. If some element is not found in table, + first item from table is used. This is good for buggy coded items by Microsoft + Outlook. This software sometimes using wrong table for UUcode, where is used + ' ' instead '`'.} +function Decode4to3(const Value, Table: AnsiString): AnsiString; + +{:Decode 4to3 encoding with given REVERSE table. Using this function with +reverse table is much faster then @link(Decode4to3). This function is used +internally for Base64, UU or XX decoding.} +function Decode4to3Ex(const Value, Table: AnsiString): AnsiString; + +{:Encode by system 3to4 (used by Base64, UU coding, etc) by given table.} +function Encode3to4(const Value, Table: AnsiString): AnsiString; + +{:Decode string from base64 format.} +function DecodeBase64(const Value: AnsiString): AnsiString; + +{:Encodes a string to base64 format.} +function EncodeBase64(const Value: AnsiString): AnsiString; + +{:Decode string from modified base64 format. (used in IMAP, for example.)} +function DecodeBase64mod(const Value: AnsiString): AnsiString; + +{:Encodes a string to modified base64 format. (used in IMAP, for example.)} +function EncodeBase64mod(const Value: AnsiString): AnsiString; + +{:Decodes a string from UUcode format.} +function DecodeUU(const Value: AnsiString): AnsiString; + +{:encode UUcode. it encode only datas, you must also add header and footer for + proper encode.} +function EncodeUU(const Value: AnsiString): AnsiString; + +{:Decodes a string from XXcode format.} +function DecodeXX(const Value: AnsiString): AnsiString; + +{:decode line with Yenc code. This code is sometimes used in newsgroups.} +function DecodeYEnc(const Value: AnsiString): AnsiString; + +{:Returns a new CRC32 value after adding a new byte of data.} +function UpdateCrc32(Value: Byte; Crc32: Integer): Integer; + +{:return CRC32 from a value string.} +function Crc32(const Value: AnsiString): Integer; + +{:Returns a new CRC16 value after adding a new byte of data.} +function UpdateCrc16(Value: Byte; Crc16: Word): Word; + +{:return CRC16 from a value string.} +function Crc16(const Value: AnsiString): Word; + +{:Returns a binary string with a RSA-MD5 hashing of "Value" string.} +function MD5(const Value: AnsiString): AnsiString; + +{:Returns a binary string with HMAC-MD5 hash.} +function HMAC_MD5(Text, Key: AnsiString): AnsiString; + +{:Returns a binary string with a RSA-MD5 hashing of string what is constructed + by repeating "value" until length is "Len".} +function MD5LongHash(const Value: AnsiString; Len: integer): AnsiString; + +{:Returns a binary string with a SHA-1 hashing of "Value" string.} +function SHA1(const Value: AnsiString): AnsiString; + +{:Returns a binary string with HMAC-SHA1 hash.} +function HMAC_SHA1(Text, Key: AnsiString): AnsiString; + +{:Returns a binary string with a SHA-1 hashing of string what is constructed + by repeating "value" until length is "Len".} +function SHA1LongHash(const Value: AnsiString; Len: integer): AnsiString; + +{:Returns a binary string with a RSA-MD4 hashing of "Value" string.} +function MD4(const Value: AnsiString): AnsiString; + +implementation + +const + + Crc32Tab: array[0..255] of Integer = ( + Integer($00000000), Integer($77073096), Integer($EE0E612C), Integer($990951BA), + Integer($076DC419), Integer($706AF48F), Integer($E963A535), Integer($9E6495A3), + Integer($0EDB8832), Integer($79DCB8A4), Integer($E0D5E91E), Integer($97D2D988), + Integer($09B64C2B), Integer($7EB17CBD), Integer($E7B82D07), Integer($90BF1D91), + Integer($1DB71064), Integer($6AB020F2), Integer($F3B97148), Integer($84BE41DE), + Integer($1ADAD47D), Integer($6DDDE4EB), Integer($F4D4B551), Integer($83D385C7), + Integer($136C9856), Integer($646BA8C0), Integer($FD62F97A), Integer($8A65C9EC), + Integer($14015C4F), Integer($63066CD9), Integer($FA0F3D63), Integer($8D080DF5), + Integer($3B6E20C8), Integer($4C69105E), Integer($D56041E4), Integer($A2677172), + Integer($3C03E4D1), Integer($4B04D447), Integer($D20D85FD), Integer($A50AB56B), + Integer($35B5A8FA), Integer($42B2986C), Integer($DBBBC9D6), Integer($ACBCF940), + Integer($32D86CE3), Integer($45DF5C75), Integer($DCD60DCF), Integer($ABD13D59), + Integer($26D930AC), Integer($51DE003A), Integer($C8D75180), Integer($BFD06116), + Integer($21B4F4B5), Integer($56B3C423), Integer($CFBA9599), Integer($B8BDA50F), + Integer($2802B89E), Integer($5F058808), Integer($C60CD9B2), Integer($B10BE924), + Integer($2F6F7C87), Integer($58684C11), Integer($C1611DAB), Integer($B6662D3D), + Integer($76DC4190), Integer($01DB7106), Integer($98D220BC), Integer($EFD5102A), + Integer($71B18589), Integer($06B6B51F), Integer($9FBFE4A5), Integer($E8B8D433), + Integer($7807C9A2), Integer($0F00F934), Integer($9609A88E), Integer($E10E9818), + Integer($7F6A0DBB), Integer($086D3D2D), Integer($91646C97), Integer($E6635C01), + Integer($6B6B51F4), Integer($1C6C6162), Integer($856530D8), Integer($F262004E), + Integer($6C0695ED), Integer($1B01A57B), Integer($8208F4C1), Integer($F50FC457), + Integer($65B0D9C6), Integer($12B7E950), Integer($8BBEB8EA), Integer($FCB9887C), + Integer($62DD1DDF), Integer($15DA2D49), Integer($8CD37CF3), Integer($FBD44C65), + Integer($4DB26158), Integer($3AB551CE), Integer($A3BC0074), Integer($D4BB30E2), + Integer($4ADFA541), Integer($3DD895D7), Integer($A4D1C46D), Integer($D3D6F4FB), + Integer($4369E96A), Integer($346ED9FC), Integer($AD678846), Integer($DA60B8D0), + Integer($44042D73), Integer($33031DE5), Integer($AA0A4C5F), Integer($DD0D7CC9), + Integer($5005713C), Integer($270241AA), Integer($BE0B1010), Integer($C90C2086), + Integer($5768B525), Integer($206F85B3), Integer($B966D409), Integer($CE61E49F), + Integer($5EDEF90E), Integer($29D9C998), Integer($B0D09822), Integer($C7D7A8B4), + Integer($59B33D17), Integer($2EB40D81), Integer($B7BD5C3B), Integer($C0BA6CAD), + Integer($EDB88320), Integer($9ABFB3B6), Integer($03B6E20C), Integer($74B1D29A), + Integer($EAD54739), Integer($9DD277AF), Integer($04DB2615), Integer($73DC1683), + Integer($E3630B12), Integer($94643B84), Integer($0D6D6A3E), Integer($7A6A5AA8), + Integer($E40ECF0B), Integer($9309FF9D), Integer($0A00AE27), Integer($7D079EB1), + Integer($F00F9344), Integer($8708A3D2), Integer($1E01F268), Integer($6906C2FE), + Integer($F762575D), Integer($806567CB), Integer($196C3671), Integer($6E6B06E7), + Integer($FED41B76), Integer($89D32BE0), Integer($10DA7A5A), Integer($67DD4ACC), + Integer($F9B9DF6F), Integer($8EBEEFF9), Integer($17B7BE43), Integer($60B08ED5), + Integer($D6D6A3E8), Integer($A1D1937E), Integer($38D8C2C4), Integer($4FDFF252), + Integer($D1BB67F1), Integer($A6BC5767), Integer($3FB506DD), Integer($48B2364B), + Integer($D80D2BDA), Integer($AF0A1B4C), Integer($36034AF6), Integer($41047A60), + Integer($DF60EFC3), Integer($A867DF55), Integer($316E8EEF), Integer($4669BE79), + Integer($CB61B38C), Integer($BC66831A), Integer($256FD2A0), Integer($5268E236), + Integer($CC0C7795), Integer($BB0B4703), Integer($220216B9), Integer($5505262F), + Integer($C5BA3BBE), Integer($B2BD0B28), Integer($2BB45A92), Integer($5CB36A04), + Integer($C2D7FFA7), Integer($B5D0CF31), Integer($2CD99E8B), Integer($5BDEAE1D), + Integer($9B64C2B0), Integer($EC63F226), Integer($756AA39C), Integer($026D930A), + Integer($9C0906A9), Integer($EB0E363F), Integer($72076785), Integer($05005713), + Integer($95BF4A82), Integer($E2B87A14), Integer($7BB12BAE), Integer($0CB61B38), + Integer($92D28E9B), Integer($E5D5BE0D), Integer($7CDCEFB7), Integer($0BDBDF21), + Integer($86D3D2D4), Integer($F1D4E242), Integer($68DDB3F8), Integer($1FDA836E), + Integer($81BE16CD), Integer($F6B9265B), Integer($6FB077E1), Integer($18B74777), + Integer($88085AE6), Integer($FF0F6A70), Integer($66063BCA), Integer($11010B5C), + Integer($8F659EFF), Integer($F862AE69), Integer($616BFFD3), Integer($166CCF45), + Integer($A00AE278), Integer($D70DD2EE), Integer($4E048354), Integer($3903B3C2), + Integer($A7672661), Integer($D06016F7), Integer($4969474D), Integer($3E6E77DB), + Integer($AED16A4A), Integer($D9D65ADC), Integer($40DF0B66), Integer($37D83BF0), + Integer($A9BCAE53), Integer($DEBB9EC5), Integer($47B2CF7F), Integer($30B5FFE9), + Integer($BDBDF21C), Integer($CABAC28A), Integer($53B39330), Integer($24B4A3A6), + Integer($BAD03605), Integer($CDD70693), Integer($54DE5729), Integer($23D967BF), + Integer($B3667A2E), Integer($C4614AB8), Integer($5D681B02), Integer($2A6F2B94), + Integer($B40BBE37), Integer($C30C8EA1), Integer($5A05DF1B), Integer($2D02EF8D) + ); + + Crc16Tab: array[0..255] of Word = ( + $0000, $1189, $2312, $329B, $4624, $57AD, $6536, $74BF, + $8C48, $9DC1, $AF5A, $BED3, $CA6C, $DBE5, $E97E, $F8F7, + $1081, $0108, $3393, $221A, $56A5, $472C, $75B7, $643E, + $9CC9, $8D40, $BFDB, $AE52, $DAED, $CB64, $F9FF, $E876, + $2102, $308B, $0210, $1399, $6726, $76AF, $4434, $55BD, + $AD4A, $BCC3, $8E58, $9FD1, $EB6E, $FAE7, $C87C, $D9F5, + $3183, $200A, $1291, $0318, $77A7, $662E, $54B5, $453C, + $BDCB, $AC42, $9ED9, $8F50, $FBEF, $EA66, $D8FD, $C974, + $4204, $538D, $6116, $709F, $0420, $15A9, $2732, $36BB, + $CE4C, $DFC5, $ED5E, $FCD7, $8868, $99E1, $AB7A, $BAF3, + $5285, $430C, $7197, $601E, $14A1, $0528, $37B3, $263A, + $DECD, $CF44, $FDDF, $EC56, $98E9, $8960, $BBFB, $AA72, + $6306, $728F, $4014, $519D, $2522, $34AB, $0630, $17B9, + $EF4E, $FEC7, $CC5C, $DDD5, $A96A, $B8E3, $8A78, $9BF1, + $7387, $620E, $5095, $411C, $35A3, $242A, $16B1, $0738, + $FFCF, $EE46, $DCDD, $CD54, $B9EB, $A862, $9AF9, $8B70, + $8408, $9581, $A71A, $B693, $C22C, $D3A5, $E13E, $F0B7, + $0840, $19C9, $2B52, $3ADB, $4E64, $5FED, $6D76, $7CFF, + $9489, $8500, $B79B, $A612, $D2AD, $C324, $F1BF, $E036, + $18C1, $0948, $3BD3, $2A5A, $5EE5, $4F6C, $7DF7, $6C7E, + $A50A, $B483, $8618, $9791, $E32E, $F2A7, $C03C, $D1B5, + $2942, $38CB, $0A50, $1BD9, $6F66, $7EEF, $4C74, $5DFD, + $B58B, $A402, $9699, $8710, $F3AF, $E226, $D0BD, $C134, + $39C3, $284A, $1AD1, $0B58, $7FE7, $6E6E, $5CF5, $4D7C, + $C60C, $D785, $E51E, $F497, $8028, $91A1, $A33A, $B2B3, + $4A44, $5BCD, $6956, $78DF, $0C60, $1DE9, $2F72, $3EFB, + $D68D, $C704, $F59F, $E416, $90A9, $8120, $B3BB, $A232, + $5AC5, $4B4C, $79D7, $685E, $1CE1, $0D68, $3FF3, $2E7A, + $E70E, $F687, $C41C, $D595, $A12A, $B0A3, $8238, $93B1, + $6B46, $7ACF, $4854, $59DD, $2D62, $3CEB, $0E70, $1FF9, + $F78F, $E606, $D49D, $C514, $B1AB, $A022, $92B9, $8330, + $7BC7, $6A4E, $58D5, $495C, $3DE3, $2C6A, $1EF1, $0F78 + ); + +procedure ArrByteToLong(var ArByte: Array of byte; var ArLong: Array of Integer); +{$IFDEF CIL} +var + n: integer; +{$ENDIF} +begin + if (High(ArByte) + 1) > ((High(ArLong) + 1) * 4) then + Exit; + {$IFDEF CIL} + for n := 0 to ((high(ArByte) + 1) div 4) - 1 do + ArLong[n] := ArByte[n * 4 + 0] + + (ArByte[n * 4 + 1] shl 8) + + (ArByte[n * 4 + 2] shl 16) + + (ArByte[n * 4 + 3] shl 24); + {$ELSE} + Move(ArByte[0], ArLong[0], High(ArByte) + 1); + {$ENDIF} +end; + +procedure ArrLongToByte(var ArLong: Array of Integer; var ArByte: Array of byte); +{$IFDEF CIL} +var + n: integer; +{$ENDIF} +begin + if (High(ArByte) + 1) < ((High(ArLong) + 1) * 4) then + Exit; + {$IFDEF CIL} + for n := 0 to high(ArLong) do + begin + ArByte[n * 4 + 0] := ArLong[n] and $000000FF; + ArByte[n * 4 + 1] := (ArLong[n] shr 8) and $000000FF; + ArByte[n * 4 + 2] := (ArLong[n] shr 16) and $000000FF; + ArByte[n * 4 + 3] := (ArLong[n] shr 24) and $000000FF; + end; + {$ELSE} + Move(ArLong[0], ArByte[0], High(ArByte) + 1); + {$ENDIF} +end; + +type + TMDCtx = record + State: array[0..3] of Integer; + Count: array[0..1] of Integer; + BufAnsiChar: array[0..63] of Byte; + BufLong: array[0..15] of Integer; + end; + TSHA1Ctx= record + Hi, Lo: integer; + Buffer: array[0..63] of byte; + Index: integer; + Hash: array[0..4] of Integer; + HashByte: array[0..19] of byte; + end; + + TMDTransform = procedure(var Buf: array of LongInt; const Data: array of LongInt); + +{==============================================================================} + +function DecodeTriplet(const Value: AnsiString; Delimiter: AnsiChar): AnsiString; +var + x, l, lv: Integer; + c: AnsiChar; + b: Byte; + bad: Boolean; +begin + lv := Length(Value); + SetLength(Result, lv); + x := 1; + l := 1; + while x <= lv do + begin + c := Value[x]; + Inc(x); + if c <> Delimiter then + begin + Result[l] := c; + Inc(l); + end + else + if x < lv then + begin + Case Value[x] Of + #13: + if (Value[x + 1] = #10) then + Inc(x, 2) + else + Inc(x); + #10: + if (Value[x + 1] = #13) then + Inc(x, 2) + else + Inc(x); + else + begin + bad := False; + Case Value[x] Of + '0'..'9': b := (Byte(Value[x]) - 48) Shl 4; + 'a'..'f', 'A'..'F': b := ((Byte(Value[x]) And 7) + 9) shl 4; + else + begin + b := 0; + bad := True; + end; + end; + Case Value[x + 1] Of + '0'..'9': b := b Or (Byte(Value[x + 1]) - 48); + 'a'..'f', 'A'..'F': b := b Or ((Byte(Value[x + 1]) And 7) + 9); + else + bad := True; + end; + if bad then + begin + Result[l] := c; + Inc(l); + end + else + begin + Inc(x, 2); + Result[l] := AnsiChar(b); + Inc(l); + end; + end; + end; + end + else + break; + end; + Dec(l); + SetLength(Result, l); +end; + +{==============================================================================} + +function DecodeQuotedPrintable(const Value: AnsiString): AnsiString; +begin + Result := DecodeTriplet(Value, '='); +end; + +{==============================================================================} + +function DecodeURL(const Value: AnsiString): AnsiString; +begin + Result := DecodeTriplet(Value, '%'); +end; + +{==============================================================================} + +function EncodeTriplet(const Value: AnsiString; Delimiter: AnsiChar; + Specials: TSpecials): AnsiString; +var + n, l: Integer; + s: AnsiString; + c: AnsiChar; +begin + SetLength(Result, Length(Value) * 3); + l := 1; + for n := 1 to Length(Value) do + begin + c := Value[n]; + if c in Specials then + begin + Result[l] := Delimiter; + Inc(l); + s := IntToHex(Ord(c), 2); + Result[l] := s[1]; + Inc(l); + Result[l] := s[2]; + Inc(l); + end + else + begin + Result[l] := c; + Inc(l); + end; + end; + Dec(l); + SetLength(Result, l); +end; + +{==============================================================================} + +function EncodeQuotedPrintable(const Value: AnsiString): AnsiString; +begin + Result := EncodeTriplet(Value, '=', ['='] + NonAsciiChar); +end; + +{==============================================================================} + +function EncodeSafeQuotedPrintable(const Value: AnsiString): AnsiString; +begin + Result := EncodeTriplet(Value, '=', SpecialChar + NonAsciiChar); +end; + +{==============================================================================} + +function EncodeURLElement(const Value: AnsiString): AnsiString; +begin + Result := EncodeTriplet(Value, '%', URLSpecialChar + URLFullSpecialChar); +end; + +{==============================================================================} + +function EncodeURL(const Value: AnsiString): AnsiString; +begin + Result := EncodeTriplet(Value, '%', URLSpecialChar); +end; + +{==============================================================================} + +function Decode4to3(const Value, Table: AnsiString): AnsiString; +var + x, y, n, l: Integer; + d: array[0..3] of Byte; +begin + SetLength(Result, Length(Value)); + x := 1; + l := 1; + while x <= Length(Value) do + begin + for n := 0 to 3 do + begin + if x > Length(Value) then + d[n] := 64 + else + begin + y := Pos(Value[x], Table); + if y < 1 then + y := 1; + d[n] := y - 1; + end; + Inc(x); + end; + Result[l] := AnsiChar((D[0] and $3F) shl 2 + (D[1] and $30) shr 4); + Inc(l); + if d[2] <> 64 then + begin + Result[l] := AnsiChar((D[1] and $0F) shl 4 + (D[2] and $3C) shr 2); + Inc(l); + if d[3] <> 64 then + begin + Result[l] := AnsiChar((D[2] and $03) shl 6 + (D[3] and $3F)); + Inc(l); + end; + end; + end; + Dec(l); + SetLength(Result, l); +end; + +{==============================================================================} +function Decode4to3Ex(const Value, Table: AnsiString): AnsiString; +var + x, y, lv: Integer; + d: integer; + dl: integer; + c: byte; + p: integer; +begin + lv := Length(Value); + SetLength(Result, lv); + x := 1; + dl := 4; + d := 0; + p := 1; + while x <= lv do + begin + y := Ord(Value[x]); + if y in [33..127] then + c := Ord(Table[y - 32]) + else + c := 64; + Inc(x); + if c > 63 then + continue; + d := (d shl 6) or c; + dec(dl); + if dl <> 0 then + continue; + Result[p] := AnsiChar((d shr 16) and $ff); + inc(p); + Result[p] := AnsiChar((d shr 8) and $ff); + inc(p); + Result[p] := AnsiChar(d and $ff); + inc(p); + d := 0; + dl := 4; + end; + case dl of + 1: + begin + d := d shr 2; + Result[p] := AnsiChar((d shr 8) and $ff); + inc(p); + Result[p] := AnsiChar(d and $ff); + inc(p); + end; + 2: + begin + d := d shr 4; + Result[p] := AnsiChar(d and $ff); + inc(p); + end; + end; + SetLength(Result, p - 1); +end; + +{==============================================================================} + +function Encode3to4(const Value, Table: AnsiString): AnsiString; +var + c: Byte; + n, l: Integer; + Count: Integer; + DOut: array[0..3] of Byte; +begin + setlength(Result, ((Length(Value) + 2) div 3) * 4); + l := 1; + Count := 1; + while Count <= Length(Value) do + begin + c := Ord(Value[Count]); + Inc(Count); + DOut[0] := (c and $FC) shr 2; + DOut[1] := (c and $03) shl 4; + if Count <= Length(Value) then + begin + c := Ord(Value[Count]); + Inc(Count); + DOut[1] := DOut[1] + (c and $F0) shr 4; + DOut[2] := (c and $0F) shl 2; + if Count <= Length(Value) then + begin + c := Ord(Value[Count]); + Inc(Count); + DOut[2] := DOut[2] + (c and $C0) shr 6; + DOut[3] := (c and $3F); + end + else + begin + DOut[3] := $40; + end; + end + else + begin + DOut[2] := $40; + DOut[3] := $40; + end; + for n := 0 to 3 do + begin + if (DOut[n] + 1) <= Length(Table) then + begin + Result[l] := Table[DOut[n] + 1]; + Inc(l); + end; + end; + end; + SetLength(Result, l - 1); +end; + +{==============================================================================} + +function DecodeBase64(const Value: AnsiString): AnsiString; +begin + Result := Decode4to3Ex(Value, ReTableBase64); +end; + +{==============================================================================} + +function EncodeBase64(const Value: AnsiString): AnsiString; +begin + Result := Encode3to4(Value, TableBase64); +end; + +{==============================================================================} + +function DecodeBase64mod(const Value: AnsiString): AnsiString; +begin + Result := Decode4to3(Value, TableBase64mod); +end; + +{==============================================================================} + +function EncodeBase64mod(const Value: AnsiString): AnsiString; +begin + Result := Encode3to4(Value, TableBase64mod); +end; + +{==============================================================================} + +function DecodeUU(const Value: AnsiString): AnsiString; +var + s: AnsiString; + uut: AnsiString; + x: Integer; +begin + Result := ''; + uut := TableUU; + s := trim(UpperCase(Value)); + if s = '' then Exit; + if Pos('BEGIN', s) = 1 then + Exit; + if Pos('END', s) = 1 then + Exit; + if Pos('TABLE', s) = 1 then + Exit; //ignore Table yet (set custom UUT) + //begin decoding + x := Pos(Value[1], uut) - 1; + case (x mod 3) of + 0: x :=(x div 3)* 4; + 1: x :=((x div 3) * 4) + 2; + 2: x :=((x div 3) * 4) + 3; + end; + //x - lenght UU line + s := Copy(Value, 2, x); + if s = '' then + Exit; + s := s + StringOfChar(' ', x - length(s)); + Result := Decode4to3(s, uut); +end; + +{==============================================================================} + +function EncodeUU(const Value: AnsiString): AnsiString; +begin + Result := ''; + if Length(Value) < Length(TableUU) then + Result := TableUU[Length(Value) + 1] + Encode3to4(Value, TableUU); +end; + +{==============================================================================} + +function DecodeXX(const Value: AnsiString): AnsiString; +var + s: AnsiString; + x: Integer; +begin + Result := ''; + s := trim(UpperCase(Value)); + if s = '' then + Exit; + if Pos('BEGIN', s) = 1 then + Exit; + if Pos('END', s) = 1 then + Exit; + //begin decoding + x := Pos(Value[1], TableXX) - 1; + case (x mod 3) of + 0: x :=(x div 3)* 4; + 1: x :=((x div 3) * 4) + 2; + 2: x :=((x div 3) * 4) + 3; + end; + //x - lenght XX line + s := Copy(Value, 2, x); + if s = '' then + Exit; + s := s + StringOfChar(' ', x - length(s)); + Result := Decode4to3(s, TableXX); +end; + +{==============================================================================} + +function DecodeYEnc(const Value: AnsiString): AnsiString; +var + C : Byte; + i: integer; +begin + Result := ''; + i := 1; + while i <= Length(Value) do + begin + c := Ord(Value[i]); + Inc(i); + if c = Ord('=') then + begin + c := Ord(Value[i]); + Inc(i); + Dec(c, 64); + end; + Dec(C, 42); + Result := Result + AnsiChar(C); + end; +end; + +{==============================================================================} + +function UpdateCrc32(Value: Byte; Crc32: Integer): Integer; +begin + Result := (Crc32 shr 8) + xor crc32tab[Byte(Value xor (Crc32 and Integer($000000FF)))]; +end; + +{==============================================================================} + +function Crc32(const Value: AnsiString): Integer; +var + n: Integer; +begin + Result := Integer($FFFFFFFF); + for n := 1 to Length(Value) do + Result := UpdateCrc32(Ord(Value[n]), Result); + Result := not Result; +end; + +{==============================================================================} + +function UpdateCrc16(Value: Byte; Crc16: Word): Word; +begin + Result := ((Crc16 shr 8) and $00FF) xor + crc16tab[Byte(Crc16 xor (Word(Value)) and $00FF)]; +end; + +{==============================================================================} + +function Crc16(const Value: AnsiString): Word; +var + n: Integer; +begin + Result := $FFFF; + for n := 1 to Length(Value) do + Result := UpdateCrc16(Ord(Value[n]), Result); +end; + +{==============================================================================} + +procedure MDInit(var MDContext: TMDCtx); +var + n: integer; +begin + MDContext.Count[0] := 0; + MDContext.Count[1] := 0; + for n := 0 to high(MDContext.BufAnsiChar) do + MDContext.BufAnsiChar[n] := 0; + for n := 0 to high(MDContext.BufLong) do + MDContext.BufLong[n] := 0; + MDContext.State[0] := Integer($67452301); + MDContext.State[1] := Integer($EFCDAB89); + MDContext.State[2] := Integer($98BADCFE); + MDContext.State[3] := Integer($10325476); +end; + +procedure MD5Transform(var Buf: array of LongInt; const Data: array of LongInt); +var + A, B, C, D: LongInt; + + procedure Round1(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); + begin + Inc(W, (Z xor (X and (Y xor Z))) + Data); + W := (W shl S) or (W shr (32 - S)); + Inc(W, X); + end; + + procedure Round2(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); + begin + Inc(W, (Y xor (Z and (X xor Y))) + Data); + W := (W shl S) or (W shr (32 - S)); + Inc(W, X); + end; + + procedure Round3(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); + begin + Inc(W, (X xor Y xor Z) + Data); + W := (W shl S) or (W shr (32 - S)); + Inc(W, X); + end; + + procedure Round4(var W: LongInt; X, Y, Z, Data: LongInt; S: Byte); + begin + Inc(W, (Y xor (X or not Z)) + Data); + W := (W shl S) or (W shr (32 - S)); + Inc(W, X); + end; +begin + A := Buf[0]; + B := Buf[1]; + C := Buf[2]; + D := Buf[3]; + + Round1(A, B, C, D, Data[0] + Longint($D76AA478), 7); + Round1(D, A, B, C, Data[1] + Longint($E8C7B756), 12); + Round1(C, D, A, B, Data[2] + Longint($242070DB), 17); + Round1(B, C, D, A, Data[3] + Longint($C1BDCEEE), 22); + Round1(A, B, C, D, Data[4] + Longint($F57C0FAF), 7); + Round1(D, A, B, C, Data[5] + Longint($4787C62A), 12); + Round1(C, D, A, B, Data[6] + Longint($A8304613), 17); + Round1(B, C, D, A, Data[7] + Longint($FD469501), 22); + Round1(A, B, C, D, Data[8] + Longint($698098D8), 7); + Round1(D, A, B, C, Data[9] + Longint($8B44F7AF), 12); + Round1(C, D, A, B, Data[10] + Longint($FFFF5BB1), 17); + Round1(B, C, D, A, Data[11] + Longint($895CD7BE), 22); + Round1(A, B, C, D, Data[12] + Longint($6B901122), 7); + Round1(D, A, B, C, Data[13] + Longint($FD987193), 12); + Round1(C, D, A, B, Data[14] + Longint($A679438E), 17); + Round1(B, C, D, A, Data[15] + Longint($49B40821), 22); + + Round2(A, B, C, D, Data[1] + Longint($F61E2562), 5); + Round2(D, A, B, C, Data[6] + Longint($C040B340), 9); + Round2(C, D, A, B, Data[11] + Longint($265E5A51), 14); + Round2(B, C, D, A, Data[0] + Longint($E9B6C7AA), 20); + Round2(A, B, C, D, Data[5] + Longint($D62F105D), 5); + Round2(D, A, B, C, Data[10] + Longint($02441453), 9); + Round2(C, D, A, B, Data[15] + Longint($D8A1E681), 14); + Round2(B, C, D, A, Data[4] + Longint($E7D3FBC8), 20); + Round2(A, B, C, D, Data[9] + Longint($21E1CDE6), 5); + Round2(D, A, B, C, Data[14] + Longint($C33707D6), 9); + Round2(C, D, A, B, Data[3] + Longint($F4D50D87), 14); + Round2(B, C, D, A, Data[8] + Longint($455A14ED), 20); + Round2(A, B, C, D, Data[13] + Longint($A9E3E905), 5); + Round2(D, A, B, C, Data[2] + Longint($FCEFA3F8), 9); + Round2(C, D, A, B, Data[7] + Longint($676F02D9), 14); + Round2(B, C, D, A, Data[12] + Longint($8D2A4C8A), 20); + + Round3(A, B, C, D, Data[5] + Longint($FFFA3942), 4); + Round3(D, A, B, C, Data[8] + Longint($8771F681), 11); + Round3(C, D, A, B, Data[11] + Longint($6D9D6122), 16); + Round3(B, C, D, A, Data[14] + Longint($FDE5380C), 23); + Round3(A, B, C, D, Data[1] + Longint($A4BEEA44), 4); + Round3(D, A, B, C, Data[4] + Longint($4BDECFA9), 11); + Round3(C, D, A, B, Data[7] + Longint($F6BB4B60), 16); + Round3(B, C, D, A, Data[10] + Longint($BEBFBC70), 23); + Round3(A, B, C, D, Data[13] + Longint($289B7EC6), 4); + Round3(D, A, B, C, Data[0] + Longint($EAA127FA), 11); + Round3(C, D, A, B, Data[3] + Longint($D4EF3085), 16); + Round3(B, C, D, A, Data[6] + Longint($04881D05), 23); + Round3(A, B, C, D, Data[9] + Longint($D9D4D039), 4); + Round3(D, A, B, C, Data[12] + Longint($E6DB99E5), 11); + Round3(C, D, A, B, Data[15] + Longint($1FA27CF8), 16); + Round3(B, C, D, A, Data[2] + Longint($C4AC5665), 23); + + Round4(A, B, C, D, Data[0] + Longint($F4292244), 6); + Round4(D, A, B, C, Data[7] + Longint($432AFF97), 10); + Round4(C, D, A, B, Data[14] + Longint($AB9423A7), 15); + Round4(B, C, D, A, Data[5] + Longint($FC93A039), 21); + Round4(A, B, C, D, Data[12] + Longint($655B59C3), 6); + Round4(D, A, B, C, Data[3] + Longint($8F0CCC92), 10); + Round4(C, D, A, B, Data[10] + Longint($FFEFF47D), 15); + Round4(B, C, D, A, Data[1] + Longint($85845DD1), 21); + Round4(A, B, C, D, Data[8] + Longint($6FA87E4F), 6); + Round4(D, A, B, C, Data[15] + Longint($FE2CE6E0), 10); + Round4(C, D, A, B, Data[6] + Longint($A3014314), 15); + Round4(B, C, D, A, Data[13] + Longint($4E0811A1), 21); + Round4(A, B, C, D, Data[4] + Longint($F7537E82), 6); + Round4(D, A, B, C, Data[11] + Longint($BD3AF235), 10); + Round4(C, D, A, B, Data[2] + Longint($2AD7D2BB), 15); + Round4(B, C, D, A, Data[9] + Longint($EB86D391), 21); + + Inc(Buf[0], A); + Inc(Buf[1], B); + Inc(Buf[2], C); + Inc(Buf[3], D); +end; + +//fixed by James McAdams +procedure MDUpdate(var MDContext: TMDCtx; const Data: AnsiString; transform: TMDTransform); +var + Index, partLen, InputLen, I: integer; +{$IFDEF CIL} + n: integer; +{$ENDIF} +begin + InputLen := Length(Data); + with MDContext do + begin + Index := (Count[0] shr 3) and $3F; + Inc(Count[0], InputLen shl 3); + if Count[0] < (InputLen shl 3) then + Inc(Count[1]); + Inc(Count[1], InputLen shr 29); + partLen := 64 - Index; + if InputLen >= partLen then + begin + ArrLongToByte(BufLong, BufAnsiChar); + {$IFDEF CIL} + for n := 1 to partLen do + BufAnsiChar[index - 1 + n] := Ord(Data[n]); + {$ELSE} + Move(Data[1], BufAnsiChar[Index], partLen); + {$ENDIF} + ArrByteToLong(BufAnsiChar, BufLong); + Transform(State, Buflong); + I := partLen; + while I + 63 < InputLen do + begin + ArrLongToByte(BufLong, BufAnsiChar); + {$IFDEF CIL} + for n := 1 to 64 do + BufAnsiChar[n - 1] := Ord(Data[i + n]); + {$ELSE} + Move(Data[I+1], BufAnsiChar, 64); + {$ENDIF} + ArrByteToLong(BufAnsiChar, BufLong); + Transform(State, Buflong); + inc(I, 64); + end; + Index := 0; + end + else + I := 0; + ArrLongToByte(BufLong, BufAnsiChar); + {$IFDEF CIL} + for n := 1 to InputLen-I do + BufAnsiChar[Index + n - 1] := Ord(Data[i + n]); + {$ELSE} + Move(Data[I+1], BufAnsiChar[Index], InputLen-I); + {$ENDIF} + ArrByteToLong(BufAnsiChar, BufLong); + end +end; + +function MDFinal(var MDContext: TMDCtx; transform: TMDTransform): AnsiString; +var + Cnt: Word; + P: Byte; + digest: array[0..15] of Byte; + i: Integer; + n: integer; +begin + for I := 0 to 15 do + Digest[I] := I + 1; + with MDContext do + begin + Cnt := (Count[0] shr 3) and $3F; + P := Cnt; + BufAnsiChar[P] := $80; + Inc(P); + Cnt := 64 - 1 - Cnt; + if Cnt < 8 then + begin + for n := 0 to cnt - 1 do + BufAnsiChar[P + n] := 0; + ArrByteToLong(BufAnsiChar, BufLong); +// FillChar(BufAnsiChar[P], Cnt, #0); + Transform(State, BufLong); + ArrLongToByte(BufLong, BufAnsiChar); + for n := 0 to 55 do + BufAnsiChar[n] := 0; + ArrByteToLong(BufAnsiChar, BufLong); +// FillChar(BufAnsiChar, 56, #0); + end + else + begin + for n := 0 to Cnt - 8 - 1 do + BufAnsiChar[p + n] := 0; + ArrByteToLong(BufAnsiChar, BufLong); +// FillChar(BufAnsiChar[P], Cnt - 8, #0); + end; + BufLong[14] := Count[0]; + BufLong[15] := Count[1]; + Transform(State, BufLong); + ArrLongToByte(State, Digest); +// Move(State, Digest, 16); + Result := ''; + for i := 0 to 15 do + Result := Result + AnsiChar(digest[i]); + end; +// FillChar(MD5Context, SizeOf(TMD5Ctx), #0) +end; + +{==============================================================================} + +function MD5(const Value: AnsiString): AnsiString; +var + MDContext: TMDCtx; +begin + MDInit(MDContext); + MDUpdate(MDContext, Value, @MD5Transform); + Result := MDFinal(MDContext, @MD5Transform); +end; + +{==============================================================================} + +function HMAC_MD5(Text, Key: AnsiString): AnsiString; +var + ipad, opad, s: AnsiString; + n: Integer; + MDContext: TMDCtx; +begin + if Length(Key) > 64 then + Key := md5(Key); + ipad := StringOfChar(#$36, 64); + opad := StringOfChar(#$5C, 64); + for n := 1 to Length(Key) do + begin + ipad[n] := AnsiChar(Byte(ipad[n]) xor Byte(Key[n])); + opad[n] := AnsiChar(Byte(opad[n]) xor Byte(Key[n])); + end; + MDInit(MDContext); + MDUpdate(MDContext, ipad, @MD5Transform); + MDUpdate(MDContext, Text, @MD5Transform); + s := MDFinal(MDContext, @MD5Transform); + MDInit(MDContext); + MDUpdate(MDContext, opad, @MD5Transform); + MDUpdate(MDContext, s, @MD5Transform); + Result := MDFinal(MDContext, @MD5Transform); +end; + +{==============================================================================} + +function MD5LongHash(const Value: AnsiString; Len: integer): AnsiString; +var + cnt, rest: integer; + l: integer; + n: integer; + MDContext: TMDCtx; +begin + l := length(Value); + cnt := Len div l; + rest := Len mod l; + MDInit(MDContext); + for n := 1 to cnt do + MDUpdate(MDContext, Value, @MD5Transform); + if rest > 0 then + MDUpdate(MDContext, Copy(Value, 1, rest), @MD5Transform); + Result := MDFinal(MDContext, @MD5Transform); +end; + +{==============================================================================} +// SHA1 is based on sources by Dave Barton (davebarton@bigfoot.com) + +procedure SHA1init( var SHA1Context: TSHA1Ctx ); +var + n: integer; +begin + SHA1Context.Hi := 0; + SHA1Context.Lo := 0; + SHA1Context.Index := 0; + for n := 0 to High(SHA1Context.Buffer) do + SHA1Context.Buffer[n] := 0; + for n := 0 to High(SHA1Context.HashByte) do + SHA1Context.HashByte[n] := 0; +// FillChar(SHA1Context, SizeOf(TSHA1Ctx), #0); + SHA1Context.Hash[0] := integer($67452301); + SHA1Context.Hash[1] := integer($EFCDAB89); + SHA1Context.Hash[2] := integer($98BADCFE); + SHA1Context.Hash[3] := integer($10325476); + SHA1Context.Hash[4] := integer($C3D2E1F0); +end; + +//****************************************************************************** +function RB(A: integer): integer; +begin + Result := (A shr 24) or ((A shr 8) and $FF00) or ((A shl 8) and $FF0000) or (A shl 24); +end; + +procedure SHA1Compress(var Data: TSHA1Ctx); +var + A, B, C, D, E, T: integer; + W: array[0..79] of integer; + i: integer; + n: integer; + + function F1(x, y, z: integer): integer; + begin + Result := z xor (x and (y xor z)); + end; + function F2(x, y, z: integer): integer; + begin + Result := x xor y xor z; + end; + function F3(x, y, z: integer): integer; + begin + Result := (x and y) or (z and (x or y)); + end; + function LRot32(X: integer; c: integer): integer; + begin + result := (x shl c) or (x shr (32 - c)); + end; +begin + ArrByteToLong(Data.Buffer, W); +// Move(Data.Buffer, W, Sizeof(Data.Buffer)); + for i := 0 to 15 do + W[i] := RB(W[i]); + for i := 16 to 79 do + W[i] := LRot32(W[i-3] xor W[i-8] xor W[i-14] xor W[i-16], 1); + A := Data.Hash[0]; + B := Data.Hash[1]; + C := Data.Hash[2]; + D := Data.Hash[3]; + E := Data.Hash[4]; + for i := 0 to 19 do + begin + T := LRot32(A, 5) + F1(B, C, D) + E + W[i] + integer($5A827999); + E := D; + D := C; + C := LRot32(B, 30); + B := A; + A := T; + end; + for i := 20 to 39 do + begin + T := LRot32(A, 5) + F2(B, C, D) + E + W[i] + integer($6ED9EBA1); + E := D; + D := C; + C := LRot32(B, 30); + B := A; + A := T; + end; + for i := 40 to 59 do + begin + T := LRot32(A, 5) + F3(B, C, D) + E + W[i] + integer($8F1BBCDC); + E := D; + D := C; + C := LRot32(B, 30); + B := A; + A := T; + end; + for i := 60 to 79 do + begin + T := LRot32(A, 5) + F2(B, C, D) + E + W[i] + integer($CA62C1D6); + E := D; + D := C; + C := LRot32(B, 30); + B := A; + A := T; + end; + Data.Hash[0] := Data.Hash[0] + A; + Data.Hash[1] := Data.Hash[1] + B; + Data.Hash[2] := Data.Hash[2] + C; + Data.Hash[3] := Data.Hash[3] + D; + Data.Hash[4] := Data.Hash[4] + E; + for n := 0 to high(w) do + w[n] := 0; +// FillChar(W, Sizeof(W), 0); + for n := 0 to high(Data.Buffer) do + Data.Buffer[n] := 0; +// FillChar(Data.Buffer, Sizeof(Data.Buffer), 0); +end; + +//****************************************************************************** +procedure SHA1Update(var Context: TSHA1Ctx; const Data: AnsiString); +var + Len: integer; + n: integer; + i, k: integer; +begin + Len := Length(data); + for k := 0 to 7 do + begin + i := Context.Lo; + Inc(Context.Lo, Len); + if Context.Lo < i then + Inc(Context.Hi); + end; + for n := 1 to len do + begin + Context.Buffer[Context.Index] := byte(Data[n]); + Inc(Context.Index); + if Context.Index = 64 then + begin + Context.Index := 0; + SHA1Compress(Context); + end; + end; +end; + +//****************************************************************************** +function SHA1Final(var Context: TSHA1Ctx): AnsiString; +type + Pinteger = ^integer; +var + i: integer; + procedure ItoArr(var Ar: Array of byte; I, value: Integer); + begin + Ar[i + 0] := Value and $000000FF; + Ar[i + 1] := (Value shr 8) and $000000FF; + Ar[i + 2] := (Value shr 16) and $000000FF; + Ar[i + 3] := (Value shr 24) and $000000FF; + end; +begin + Context.Buffer[Context.Index] := $80; + if Context.Index >= 56 then + SHA1Compress(Context); + ItoArr(Context.Buffer, 56, RB(Context.Hi)); + ItoArr(Context.Buffer, 60, RB(Context.Lo)); +// Pinteger(@Context.Buffer[56])^ := RB(Context.Hi); +// Pinteger(@Context.Buffer[60])^ := RB(Context.Lo); + SHA1Compress(Context); + Context.Hash[0] := RB(Context.Hash[0]); + Context.Hash[1] := RB(Context.Hash[1]); + Context.Hash[2] := RB(Context.Hash[2]); + Context.Hash[3] := RB(Context.Hash[3]); + Context.Hash[4] := RB(Context.Hash[4]); + ArrLongToByte(Context.Hash, Context.HashByte); + Result := ''; + for i := 0 to 19 do + Result := Result + AnsiChar(Context.HashByte[i]); +end; + +function SHA1(const Value: AnsiString): AnsiString; +var + SHA1Context: TSHA1Ctx; +begin + SHA1Init(SHA1Context); + SHA1Update(SHA1Context, Value); + Result := SHA1Final(SHA1Context); +end; + +{==============================================================================} + +function HMAC_SHA1(Text, Key: AnsiString): AnsiString; +var + ipad, opad, s: AnsiString; + n: Integer; + SHA1Context: TSHA1Ctx; +begin + if Length(Key) > 64 then + Key := SHA1(Key); + ipad := StringOfChar(#$36, 64); + opad := StringOfChar(#$5C, 64); + for n := 1 to Length(Key) do + begin + ipad[n] := AnsiChar(Byte(ipad[n]) xor Byte(Key[n])); + opad[n] := AnsiChar(Byte(opad[n]) xor Byte(Key[n])); + end; + SHA1Init(SHA1Context); + SHA1Update(SHA1Context, ipad); + SHA1Update(SHA1Context, Text); + s := SHA1Final(SHA1Context); + SHA1Init(SHA1Context); + SHA1Update(SHA1Context, opad); + SHA1Update(SHA1Context, s); + Result := SHA1Final(SHA1Context); +end; + +{==============================================================================} + +function SHA1LongHash(const Value: AnsiString; Len: integer): AnsiString; +var + cnt, rest: integer; + l: integer; + n: integer; + SHA1Context: TSHA1Ctx; +begin + l := length(Value); + cnt := Len div l; + rest := Len mod l; + SHA1Init(SHA1Context); + for n := 1 to cnt do + SHA1Update(SHA1Context, Value); + if rest > 0 then + SHA1Update(SHA1Context, Copy(Value, 1, rest)); + Result := SHA1Final(SHA1Context); +end; + +{==============================================================================} + +procedure MD4Transform(var Buf: array of LongInt; const Data: array of LongInt); +var + A, B, C, D: LongInt; + function LRot32(a, b: longint): longint; + begin + Result:= (a shl b) or (a shr (32 - b)); + end; +begin + A := Buf[0]; + B := Buf[1]; + C := Buf[2]; + D := Buf[3]; + + A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 0], 3); + D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 1], 7); + C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 2], 11); + B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 3], 19); + A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 4], 3); + D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 5], 7); + C:= LRot32(C + (B xor (D and (A xor B))) + Data[ 6], 11); + B:= LRot32(B + (A xor (C and (D xor A))) + Data[ 7], 19); + A:= LRot32(A + (D xor (B and (C xor D))) + Data[ 8], 3); + D:= LRot32(D + (C xor (A and (B xor C))) + Data[ 9], 7); + C:= LRot32(C + (B xor (D and (A xor B))) + Data[10], 11); + B:= LRot32(B + (A xor (C and (D xor A))) + Data[11], 19); + A:= LRot32(A + (D xor (B and (C xor D))) + Data[12], 3); + D:= LRot32(D + (C xor (A and (B xor C))) + Data[13], 7); + C:= LRot32(C + (B xor (D and (A xor B))) + Data[14], 11); + B:= LRot32(B + (A xor (C and (D xor A))) + Data[15], 19); + + A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 0] + longint($5a827999), 3); + D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 4] + longint($5a827999), 5); + C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 8] + longint($5a827999), 9); + B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[12] + longint($5a827999), 13); + A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 1] + longint($5a827999), 3); + D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 5] + longint($5a827999), 5); + C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[ 9] + longint($5a827999), 9); + B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[13] + longint($5a827999), 13); + A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 2] + longint($5a827999), 3); + D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 6] + longint($5a827999), 5); + C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[10] + longint($5a827999), 9); + B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[14] + longint($5a827999), 13); + A:= LRot32(A + ((B and C) or (B and D) or (C and D)) + Data[ 3] + longint($5a827999), 3); + D:= LRot32(D + ((A and B) or (A and C) or (B and C)) + Data[ 7] + longint($5a827999), 5); + C:= LRot32(C + ((D and A) or (D and B) or (A and B)) + Data[11] + longint($5a827999), 9); + B:= LRot32(B + ((C and D) or (C and A) or (D and A)) + Data[15] + longint($5a827999), 13); + + A:= LRot32(A + (B xor C xor D) + Data[ 0] + longint($6ed9eba1), 3); + D:= LRot32(D + (A xor B xor C) + Data[ 8] + longint($6ed9eba1), 9); + C:= LRot32(C + (D xor A xor B) + Data[ 4] + longint($6ed9eba1), 11); + B:= LRot32(B + (C xor D xor A) + Data[12] + longint($6ed9eba1), 15); + A:= LRot32(A + (B xor C xor D) + Data[ 2] + longint($6ed9eba1), 3); + D:= LRot32(D + (A xor B xor C) + Data[10] + longint($6ed9eba1), 9); + C:= LRot32(C + (D xor A xor B) + Data[ 6] + longint($6ed9eba1), 11); + B:= LRot32(B + (C xor D xor A) + Data[14] + longint($6ed9eba1), 15); + A:= LRot32(A + (B xor C xor D) + Data[ 1] + longint($6ed9eba1), 3); + D:= LRot32(D + (A xor B xor C) + Data[ 9] + longint($6ed9eba1), 9); + C:= LRot32(C + (D xor A xor B) + Data[ 5] + longint($6ed9eba1), 11); + B:= LRot32(B + (C xor D xor A) + Data[13] + longint($6ed9eba1), 15); + A:= LRot32(A + (B xor C xor D) + Data[ 3] + longint($6ed9eba1), 3); + D:= LRot32(D + (A xor B xor C) + Data[11] + longint($6ed9eba1), 9); + C:= LRot32(C + (D xor A xor B) + Data[ 7] + longint($6ed9eba1), 11); + B:= LRot32(B + (C xor D xor A) + Data[15] + longint($6ed9eba1), 15); + + Inc(Buf[0], A); + Inc(Buf[1], B); + Inc(Buf[2], C); + Inc(Buf[3], D); +end; + +{==============================================================================} + +function MD4(const Value: AnsiString): AnsiString; +var + MDContext: TMDCtx; +begin + MDInit(MDContext); + MDUpdate(MDContext, Value, @MD4Transform); + Result := MDFinal(MDContext, @MD4Transform); +end; + +{==============================================================================} + + +end. diff --git a/src/thirdparty/uAuthentication.dfm b/src/thirdparty/uAuthentication.dfm new file mode 100644 index 0000000..b93ca48 --- /dev/null +++ b/src/thirdparty/uAuthentication.dfm @@ -0,0 +1,63 @@ +object PasswordDlg: TPasswordDlg + Left = 245 + Top = 108 + BorderStyle = bsDialog + Caption = 'Authentication' + ClientHeight = 128 + ClientWidth = 233 + Color = clBtnFace + ParentFont = True + OldCreateOrder = True + Position = poScreenCenter + PixelsPerInch = 96 + TextHeight = 13 + object Label1: TLabel + Left = 8 + Top = 49 + Width = 46 + Height = 13 + Caption = 'Password' + end + object Label2: TLabel + Left = 8 + Top = 3 + Width = 48 + Height = 13 + Caption = 'Username' + end + object edtPassword: TEdit + Left = 24 + Top = 68 + Width = 201 + Height = 21 + PasswordChar = '*' + TabOrder = 1 + end + object OKBtn: TButton + Left = 62 + Top = 95 + Width = 75 + Height = 25 + Caption = 'OK' + Default = True + ModalResult = 1 + TabOrder = 2 + end + object CancelBtn: TButton + Left = 150 + Top = 95 + Width = 75 + Height = 25 + Cancel = True + Caption = 'Cancel' + ModalResult = 2 + TabOrder = 3 + end + object edtusername: TEdit + Left = 24 + Top = 22 + Width = 201 + Height = 21 + TabOrder = 0 + end +end diff --git a/src/thirdparty/uAuthentication.pas b/src/thirdparty/uAuthentication.pas new file mode 100644 index 0000000..1c8492f --- /dev/null +++ b/src/thirdparty/uAuthentication.pas @@ -0,0 +1,30 @@ +unit uAuthentication; + +interface + +uses Windows, SysUtils, Classes, Graphics, Forms, Controls, StdCtrls, + Buttons; + +type + TPasswordDlg = class(TForm) + Label1: TLabel; + edtPassword: TEdit; + OKBtn: TButton; + CancelBtn: TButton; + Label2: TLabel; + edtusername: TEdit; + private + { Déclarations privées } + public + { Déclarations publiques } + end; + +var + PasswordDlg: TPasswordDlg; + +implementation + +{$R *.dfm} + +end. + diff --git a/src/thirdparty/unitObjectCache.pas b/src/thirdparty/unitObjectCache.pas new file mode 100644 index 0000000..c03f0b4 --- /dev/null +++ b/src/thirdparty/unitObjectCache.pas @@ -0,0 +1,1057 @@ +(*======================================================================* + | unitObjectCache | + | | + | Object caching & association classes: | + | | + | TObjectCache Implements a flexible cache of objects | + | TClassAssociations Associates pairs of classes | + | TClassStringAssociations Associates a string/class pairs | + | TObjectProcessor Process a list of objects in a | + | background thread. | + | | + | The contents of this file are subject to the Mozilla Public License | + | Version 1.1 (the "License"); you may not use this file except in | + | compliance with the License. You may obtain a copy of the License | + | at http://www.mozilla.org/MPL/ | + | | + | Software distributed under the License is distributed on an "AS IS" | + | basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See | + | the License for the specific language governing rights and | + | limitations under the License. | + | | + | Copyright © Colin Wilson 2003 All Rights Reserved + | | + | Version Date By Description | + | ------- ---------- ---- ------------------------------------------| + | 1.0 10/12/2003 CPWW Original | + *======================================================================*) + + +unit unitObjectCache; + +interface + +uses Windows, Classes, SysUtils, ConTnrs, SyncObjs; + +type +TObjectCacheProc = procedure (obj : TObject; idx, param : Integer; var continue : boolean) of object; + +//--------------------------------------------------------------- +TObjectCache = class +private + fOrigCapacity : Integer; + fObjects : TObjectList; + function GetOwnsObjects: boolean; + procedure SetOwnsObjects(const Value: boolean); + function GetCapacity: Integer; + procedure SetCapacity(const Value: Integer); + function GetCount: Integer; +protected + function CanRemove (AObject : TObject) : boolean; virtual; + function Matches (ObjA, ObjB : TObject) : boolean; virtual; +public + constructor Create (ACapacity : Integer; OwnsObjects : boolean); + destructor Destroy; override; + function IndexOfObject (AObject : TObject) : Integer; + procedure Add (AObject : TObject); virtual; + procedure Clear; + function ForEach (proc : TObjectCacheProc; param : Integer) : TObject; + function ForEachIdx (proc : TObjectCacheProc; param : Integer) : Integer; + procedure BringToFrontObject (idx : Integer); + function ObjectAt (idx : Integer) : TObject; + + procedure Remove (AObject : TObject); + function Extract (AObject : TObject) : TObject; + + procedure Push (AObject : TObject); + function Pop : TObject; + + property OwnsObjects : boolean read GetOwnsObjects write SetOwnsObjects; + property Capacity : Integer read GetCapacity write SetCapacity; + property Count : Integer read GetCount; +end; + +//--------------------------------------------------------------- +TClassAssociation = class +private + fClassA, fClassB : TClass; +public + constructor Create (AClassA, AClassB : TClass); + + property ClassA : TClass read fClassA; + property ClassB : TClass read fClassB; +end; + +//--------------------------------------------------------------- +TClassAssociations = class +private + fAssociations : TObjectList; + function GetCount: Integer; + function GetAssociation(idx: Integer): TClassAssociation; + function GetIndexOf(classA, classB: TClass): Integer; + function GetIndexOfClassA(classA: TClass): Integer; + function GetIndexOfClassB(classB: TClass): Integer; +protected + property Association [idx : Integer] : TClassAssociation read GetAssociation; + property Count : Integer read GetCount; + property IndexOf [classA, classB : TClass] : Integer read GetIndexOf; + property IndexOfClassA [classA : TClass] : Integer read GetIndexOfClassA; + property IndexOfClassB [classB : TClass] : Integer read GetIndexOfClassB; +public + constructor Create; + destructor Destroy; override; + + procedure Associate (classA, classB : TClass); + procedure DisAssociate (classA, classB : TClass); + + function FindClassBFor (classA : TClass) : TClass; + function FindClassAFor (classB : TClass) : TClass; +end; + +//--------------------------------------------------------------- +TClassStringAssociations = class +private + fAssociations : TStringList; + function GetIndexOf(const st: string; cls: TClass): Integer; + function GetCount: Integer; + function GetString(idx: Integer): string; + function GetClass(idx: Integer): TClass; +protected + property IndexOf [const st : string; cls : TClass] : Integer read GetIndexOf; +public + constructor Create; + destructor Destroy; override; + + procedure Associate (const st : string; cls : TClass); + procedure DisAssociate (const st : string; cls : TClass); + + function FindStringFor (cls : TClass) : string; + function FindClassFor (const st : string) : TClass; + + property Count : Integer read GetCount; + property Strings [idx : Integer] : string read GetString; + property Classes [idx : Integer] : TClass read GetClass; +end; + +TObjectProcessorState = (opsIdle, opsBusy); +//--------------------------------------------------------------- +TObjectProcessor = class (TThread) +private + fSync : TCriticalSection; + fSignal : TEvent; + fObjects : TObjectList; + fState : TObjectProcessorState; + procedure SetOwnsObjects(const Value: boolean); + function GetOwnsObjects: boolean; + function GetCount: Integer; + +protected + procedure Execute; override; + + procedure Reset (obj : TObject); virtual; + procedure Process (obj : TObject); virtual; + procedure ObjectsProcessed; virtual; +public + constructor Create; + destructor Destroy; override; + procedure Clear; + procedure Terminate; + procedure AddObjectToQueue (obj : TObject); + + property OwnsObjects : boolean read GetOwnsObjects write SetOwnsObjects; + property State : TObjectProcessorState read fState; + property Count : Integer read GetCount; +end; + +TLog = class +private + fLock : TCriticalSection; + fStrings : TStrings; + fLocked : boolean; + fInLock : boolean; + fCapacity: Integer; + procedure Init; + procedure Lock; + procedure LimitCapacity; + function GetStrings(idx: Integer): string; + procedure SetCapacity(const Value: Integer); + +public + destructor Destroy; override; + function LockGetCount : Integer; + procedure Add (const st : string); + procedure Clear; + procedure Unlock; + + property Capacity : Integer read fCapacity write SetCapacity; + property Strings [idx : Integer] : string read GetStrings; + +end; + +implementation + +{ TObjectCache } + +(*----------------------------------------------------------------------* + | TObjectCache.Add | + | | + | Add an object to the cache. | + | | + | Note that the cache capacity will automatically be increased if | + | it is full, and no objects can be removed (see the CanRemove method) | + | | + | Parameters: | + | AObject: TObject The object to add | + *----------------------------------------------------------------------*) +procedure TObjectCache.Add(AObject: TObject); +var + idx, c : Integer; + b : boolean; +begin + idx := IndexOfObject (AObject); + if idx = 0 then // Already in the cache at the front + begin + if OwnsObjects then + AObject.Free; + Exit + end; + + if idx = -1 then + begin // Not already in cache. Add it. + b := False; + c := fObjects.Count; + while c >= fOrigCapacity do + begin // There's not room. Remove old objects (if we're allowed) + repeat // Try to get back to the original capacity if it's been + Dec (c); // exceeded. + if CanRemove (fObjects [c]) then + begin + fObjects.Delete(c); + b := True + end + until b or (c = 0); + end; + + if b then // Shrink the cache if it's bulged. + if fObjects.Capacity > fOrigCapacity then + if fObjects.Count < fOrigCapacity then + fObjects.Capacity := fOrigCapacity; + + if fObjects.Capacity = fObjects.Count then // Bulge the cache + fObjects.Capacity := fObjects.Capacity + 1; + + fObjects.Insert (0, AObject) + end + else // The object was already in the cache. So bring it to + begin // the front + BringToFrontObject (idx); + if OwnsObjects then + AObject.Free + end +end; + +(*----------------------------------------------------------------------* + | procedure TObjectCache.BringToFrontObject | + | | + | Bring object 'idx' to the front of the cache. | + | | + | Parameters: | + | idx: Integer // Index of the object to bring to the front. | + *----------------------------------------------------------------------*) +procedure TObjectCache.BringToFrontObject(idx: Integer); +var + b : boolean; + obj : TObject; +begin + if (idx > 0) then + begin + obj := fObjects [idx]; + b := OwnsObjects; + OwnsObjects := False; // Temporarily turn off 'owns objects' so we + try // can delete and reinsert safely. + fObjects.Delete (idx); + fObjects.Insert (0, obj) + finally + OwnsObjects := b + end + end +end; + +(*----------------------------------------------------------------------* + | TObjectCache.CanRemove | + | | + | Override this to prevent objects from being removed from the cache | + | - maybe because another reference to the object still exists. | + | | + | Parameters: | + | AObject: TObject The object to test | + | | + | The function returns True if the object can be safely removed. | + *----------------------------------------------------------------------*) +function TObjectCache.CanRemove(AObject: TObject) : boolean; +begin + result := True +end; + +(*----------------------------------------------------------------------* + | procedure TObjectCache.Clear | + | | + | Clear the cache - or as much of it as can safely be cleared. | + *----------------------------------------------------------------------*) +procedure TObjectCache.Clear; +var + i : Integer; +begin + i := 0; + while i < fObjects.Count do + if CanRemove (fObjects [i]) then + fObjects.Delete(i) + else + Inc (i) +end; + +(*----------------------------------------------------------------------* + | constructor TObjectCache.Create | + *----------------------------------------------------------------------*) +constructor TObjectCache.Create(ACapacity : Integer; OwnsObjects : boolean); +begin + fObjects := TObjectList.Create (OwnsObjects); + fOrigCapacity := ACapacity; + fObjects.Capacity := ACapacity; +end; + +(*----------------------------------------------------------------------* + | destructor TObjectCache.Destroy | + *----------------------------------------------------------------------*) +destructor TObjectCache.Destroy; +begin + fObjects.Free; + + inherited; +end; + +(*----------------------------------------------------------------------* + | function TObjectCache.Extract | + | | + | Extract an object from the cache. | + | | + | Parameters: | + | AObject: TObject The object to extract | + | | + | The function returns the extracted object. nb. Even if OwnsObjects | + | true, the object is *not* deleted | + *----------------------------------------------------------------------*) +function TObjectCache.Extract(AObject: TObject) : TObject; +begin + result := fObjects.Extract(AObject) +end; + +(*----------------------------------------------------------------------* + | function TObjectCache.ForEach | + | | + | Call 'proc' for each object in the cache | + | | + | Parameters: | + | proc: TObjectCacheProc procedure to call | + | param : Integer User parameter to pass to the procedure | + | | + | The function returns the object that caused 'proc' to return with | + | 'continue=False'. You can use this eg. to search the cache. | + *----------------------------------------------------------------------*) +function TObjectCache.ForEach(proc: TObjectCacheProc; param : Integer) : TObject; +var + i : Integer; + continue : boolean; +begin + i := 0; + continue := True; + + while continue and (i < fObjects.Count) do + begin + proc (fObjects [i], i, param, continue); + if continue then + Inc (i) + end; + + if not continue then + result := fObjects [i] + else + result := Nil +end; + +(*----------------------------------------------------------------------* + | function TObjectCache.ForEachIdx | + | | + | Call 'proc' for each object in the cache. nb. this differs from | + | ForEach only in the return value. | + | | + | Parameters: | + | proc: TObjectCacheProc procedure to call | + | param : Integer User parameter to pass to the procedure | + | | + | The function returns the index of the object that caused 'proc' | + | to return with 'continue=False'. You can use this eg. to search the | + | cache. | + *----------------------------------------------------------------------*) +function TObjectCache.ForEachIdx(proc: TObjectCacheProc; + param: Integer): Integer; +var + i : Integer; + continue : boolean; +begin + i := 0; + continue := True; + + while continue and (i < fObjects.Count) do + begin + proc (fObjects [i], i, param, continue); + if continue then + Inc (i) + end; + + if not continue then + result := i + else + result := -1 +end; + +(*----------------------------------------------------------------------* + | function TObjectCache.GetCapacity | + | | + | Return the (preferred) capacity of the cache. | + *----------------------------------------------------------------------*) +function TObjectCache.GetCapacity: Integer; +begin + result := fOrigCapacity +end; + +(*----------------------------------------------------------------------* + | function TObjectCache.GetCount | + | | + | Returns the number of cached objects | + *----------------------------------------------------------------------*) +function TObjectCache.GetCount: Integer; +begin + result := fObjects.Count; +end; + +(*----------------------------------------------------------------------* + | function TObjectCache.GetOwnsObjects | + | | + | Returns the 'OwnsObjects' state of the cache. | + *----------------------------------------------------------------------*) +function TObjectCache.GetOwnsObjects: boolean; +begin + result := fObjects.OwnsObjects; +end; + +(*----------------------------------------------------------------------* + | function TObjectCache.IndexOfObject | + | | + | Returns the index of an object in the cache | + *----------------------------------------------------------------------*) +function TObjectCache.IndexOfObject(AObject: TObject): Integer; +var + i, c : Integer; +begin + result := -1; + c := fObjects.Count; + for i := 0 to c - 1 do + if Matches (fObjects [i], AObject) then + begin + result := i; + break + end; +end; + +(*----------------------------------------------------------------------* + | function TObjectCache.Matches | + | | + | Return 'True' if ObjA matches ObB. Override this to provide more | + | complicated matching of objects. | + *----------------------------------------------------------------------*) +function TObjectCache.Matches(ObjA, ObjB: TObject): boolean; +begin + result := ObjA = ObjB; +end; + +(*----------------------------------------------------------------------* + | function TObjectCache.ObjectAt | + | | + | Return the idx'th object in the cache | + *----------------------------------------------------------------------*) +function TObjectCache.ObjectAt(idx: Integer): TObject; +begin + result := fObjects [idx] +end; + +(*----------------------------------------------------------------------* + | procedure TObjectCache.Remove | + | | + | Remove an object from the cache. nb. Even if OwnsObjects is True | + | the object isn't deleted. | + *----------------------------------------------------------------------*) +function TObjectCache.Pop: TObject; +begin + if Count > 0 then + begin + result := fObjects [0]; + Extract (result) + end + else + result := Nil +end; + +(*----------------------------------------------------------------------* + | TObjectCache.Push | + | | + | Alias for 'Add' - see above. | + *----------------------------------------------------------------------*) +procedure TObjectCache.Push(AObject: TObject); +begin + Add (AObject); +end; + +(*----------------------------------------------------------------------* + | procedure TObjectCache.Remove | + | | + | Remove an object from the cache | + *----------------------------------------------------------------------*) +procedure TObjectCache.Remove(AObject: TObject); +begin + if (fObjects.Count > 0) and CanRemove (AObject) then + fObjects.Remove(AObject) +end; + +(*----------------------------------------------------------------------* + | prcoedure TObjectCache.SetCapacity | + | | + | Set the (preferred) capacity of the cache | + *----------------------------------------------------------------------*) +procedure TObjectCache.SetCapacity(const Value: Integer); +begin + if Value <> fOrigCapacity then + begin + while fObjects.Count > Value do + fObjects.Delete(fObjects.Count - 1); + fObjects.Capacity := Value; + fOrigCapacity := Value + end +end; + +(*----------------------------------------------------------------------* + | procedure TObjectCache.SetOwnsObjects | + | | + | If 'OwnsObjects' is true, the object cache assumes responsibility | + | for deleting objects added to it (with Add or Push). Whenever | + | objects are removed from the cache, either with 'Remove' or because | + | the cache overflowed, the get deleted (freed). | + *----------------------------------------------------------------------*) +procedure TObjectCache.SetOwnsObjects(const Value: boolean); +begin + fObjects.OwnsObjects := Value +end; + +{ TClassAssociations } + +// TClassAssociations allows you to associate a class with another class. +// eg. you could associate a TGraphicsForm with TGraphic, etc. +// +// TClassAssociations support inheritance, so as TIcon derives from +// TGraphic, then TGraphicsForm will be returned for TIcon - unless a +// separate TIconForm is registered for TIcon. + +(*----------------------------------------------------------------------* + | TClassAssociations.Associate | + | | + | Associate ClassA with ClassB | + | | + | Parameters: | + | classA, classB: TClass The classes to associate | + *----------------------------------------------------------------------*) +procedure TClassAssociations.Associate(classA, classB: TClass); +var + i : Integer; +begin + i := IndexOf [classA, classB]; + + if i = -1 then + fAssociations.Insert(0, TClassAssociation.Create(classA, classB)); +end; + +(*----------------------------------------------------------------------* + | constructor TClassAssociations.Create | + *----------------------------------------------------------------------*) +constructor TClassAssociations.Create; +begin + fAssociations := TObjectList.Create; +end; + +(*----------------------------------------------------------------------* + | destructor TClassAssociations.Destroy | + *----------------------------------------------------------------------*) +destructor TClassAssociations.Destroy; +begin + fAssociations.Free; + inherited; +end; + +(*----------------------------------------------------------------------* + | procedure TClassAssociations.DisAssociate | + | | + | Remove the association between classA and classB | + *----------------------------------------------------------------------*) +procedure TClassAssociations.DisAssociate(classA, classB: TClass); +var + idx : Integer; +begin + idx := IndexOf [classA, classB]; + if idx >= 0 then + fAssociations.Delete(idx); +end; + +(*----------------------------------------------------------------------* + | TClassAssociations.FindClassAFor | + | | + | eg. FindClassAFor (TGraphicsForm) will return TGraphic. Note that | + | this way round there is no inheritance. There's either an | + | association or there's not. | + | | + | Parameters: | + | classB: TClass The ClassB to find. | + | | + | The function returns the classA that matches classB | + *----------------------------------------------------------------------*) +function TClassAssociations.FindClassAFor(classB: TClass): TClass; +var + idx : Integer; +begin + idx := IndexOfClassB [classB]; + if idx >= 0 then + result := Association [idx].ClassA + else + result := Nil +end; + +(*----------------------------------------------------------------------* + | function TClassAssociations.FindClassBFor | + | | + | eg. FindClassAFor (TGraphic) will return TGraphicForm. | + | | + | nb. this supports inheritance, so as TIcon derives from TGraphic, | + | TGraphicsForm will be returned for TIcon - unless a separate | + | TIconForm is registered for TIcon. | + | | + | Parameters: | + | classA: TClass The ClassA to find | + | | + | The function returns the classB that matches classA. If no match is | + | found, classA's Ancestor classes are searched too. | + *----------------------------------------------------------------------*) +function TClassAssociations.FindClassBFor(classA: TClass): TClass; +var + idx : Integer; +begin + idx := IndexOfClassA [classA]; + if idx >= 0 then + result := Association [idx].ClassB + else + result := Nil +end; + +(*----------------------------------------------------------------------* + | function TClassAssociations.GetAssociation | + | | + | 'Get' method for Association property | + *----------------------------------------------------------------------*) +function TClassAssociations.GetAssociation( + idx: Integer): TClassAssociation; +begin + result := TClassAssociation (fAssociations [idx]); +end; + +(*----------------------------------------------------------------------* + | function TClassAssociations.GetCount | + | | + | 'Get' method for Count property | + *----------------------------------------------------------------------*) +function TClassAssociations.GetCount: Integer; +begin + result := fAssociations.Count; +end; + +function TClassAssociations.GetIndexOf(classA, classB: TClass): Integer; +var + i : Integer; + ass : TClassAssociation; +begin + result := -1; + + for i := 0 to Count - 1 do + begin + ass := Association [i]; + if (ass.ClassA = classA) and (ass.ClassB = classB) then + begin + result := i; + break + end + end +end; + +function TClassAssociations.GetIndexOfClassA(classA: TClass): Integer; +var + i : Integer; + ass : TClassAssociation; +begin + result := -1; + + while (result = -1) and Assigned (classA) do + begin + for i := 0 to Count - 1 do + begin + ass := Association [i]; + if ass.ClassA = classA then + begin + result := i; + break + end + end; + + if result = -1 then + classA := classA.ClassParent + end +end; + +function TClassAssociations.GetIndexOfClassB(classB: TClass): Integer; +var + i : Integer; + ass : TClassAssociation; +begin + result := -1; + + for i := 0 to Count - 1 do + begin + ass := Association [i]; + if ass.ClassB = classB then + begin + result := i; + break + end + end +end; + +{ TClassAssociation } + +constructor TClassAssociation.Create(AClassA, AClassB: TClass); +begin + fClassA := AClassA; + fClassB := AClassB +end; + +{ TClassStringAssociations } + +procedure TClassStringAssociations.Associate(const st: string; cls: TClass); +var + i : Integer; +begin + i := IndexOf [st, cls]; + + if i = -1 then + fAssociations.InsertObject (0, st, TObject (cls)) +end; + +constructor TClassStringAssociations.Create; +begin + fAssociations := TStringList.Create; +end; + +destructor TClassStringAssociations.Destroy; +begin + fAssociations.Free; + + inherited; +end; + +procedure TClassStringAssociations.DisAssociate(const st: string; + cls: TClass); +var + idx : Integer; +begin + idx := IndexOf [st, cls]; + if idx >= 0 then + fAssociations.Delete(idx); +end; + +function TClassStringAssociations.FindClassFor(const st: string): TClass; +var + idx : Integer; +begin + idx := fAssociations.IndexOf (st); + if idx >= 0 then + result := TClass (fAssociations.Objects [idx]) + else + result := Nil +end; + +function TClassStringAssociations.FindStringFor(cls: TClass): string; +var + i : Integer; +begin + result := ''; + for i := 0 to Count - 1 do + if TClass (fAssociations.Objects [i]) = cls then + begin + result := fAssociations [i]; + break + end +end; + +function TClassStringAssociations.GetClass(idx: Integer): TClass; +begin + result := TClass (fAssociations.Objects [idx]) +end; + +function TClassStringAssociations.GetCount: Integer; +begin + result := fAssociations.Count +end; + +function TClassStringAssociations.GetIndexOf(const st: string; + cls: TClass): Integer; +var + i : Integer; +begin + result := -1; + for i := 0 to Count - 1 do + if (fAssociations.Objects [i] = TObject (cls)) and SameText (st, fAssociations [i]) then + begin + result := i; + break + end +end; + +function TClassStringAssociations.GetString(idx: Integer): string; +begin + result := fAssociations [idx]; +end; + +{ TObjectProcessor } + +procedure TObjectProcessor.AddObjectToQueue(obj: TObject); +begin + fSync.Enter; + try + fObjects.Add(obj); + if fState = opsIdle then + fSignal.SetEvent; + finally + fSync.Leave + end +end; + +procedure TObjectProcessor.Clear; +var + i : Integer; +begin + fSync.Enter; + try + for i := 0 to fObjects.Count - 1 do + Reset (fObjects [i]); + fObjects.Clear; + finally + fSync.Leave + end +end; + +constructor TObjectProcessor.Create; +begin + fSync := TCriticalSection.Create; + fSignal := TEvent.Create (Nil, false, false, ''); + fObjects := TObjectList.Create; + fObjects.OwnsObjects := False; + + inherited Create (false); +end; + +destructor TObjectProcessor.Destroy; +begin + fSync.Free; + fSignal.Free; + + inherited; +end; + +procedure TObjectProcessor.Execute; +begin + while not Terminated do + begin + try + if fObjects.Count = 0 then + fSignal.WaitFor(INFINITE); + + fState := opsBusy; + try + while not Terminated and (fObjects.Count > 0) do + begin + fSync.Enter; + try + if fObjects.Count > 0 then + begin + Process (fObjects [0]); + fObjects.Delete(0) + end + finally + fSync.Leave + end; + end; + if not Terminated then + ObjectsProcessed; + finally + fState := opsIdle + end + except + try + Clear + except + end + end + end +end; + +function TObjectProcessor.GetCount: Integer; +begin + result := fObjects.Count +end; + +function TObjectProcessor.GetOwnsObjects: boolean; +begin + result := fObjects.OwnsObjects +end; + +procedure TObjectProcessor.ObjectsProcessed; +begin +// Stub - called when a batch of objects has been processed +end; + +procedure TObjectProcessor.Process(obj: TObject); +begin +// Stub - called to process each object +end; + +procedure TObjectProcessor.Reset(obj: TObject); +begin +// Stub - called when un-processed objects are removed from the queue (by Clear) +end; + +procedure TObjectProcessor.SetOwnsObjects(const Value: boolean); +begin + fObjects.OwnsObjects := Value +end; + +procedure TObjectProcessor.Terminate; +begin + Clear; + inherited Terminate; + fSignal.SetEvent; + WaitFor +end; + +{ TLog } + +procedure TLog.Add(const st: string); +begin + Lock; + try + fStrings.Add(st); + LimitCapacity + finally + Unlock + end +end; + +procedure TLog.Clear; +begin + Lock; + try + fStrings.Clear + finally + Unlock + end +end; + +destructor TLog.Destroy; +begin + fLock.Free; + fStrings.Free; + + inherited; +end; + +function TLog.GetStrings(idx: Integer): string; +begin + if not fLocked then + raise Exception.Create ('Must call LockGetCount'); + result := fStrings [idx]; +end; + +procedure TLog.Init; +begin + if not Assigned (fStrings) then + fStrings := TStringList.Create; + + if not Assigned (fLock) then + fLock := TCriticalSection.Create; +end; + +procedure TLog.LimitCapacity; +var + needLock : boolean; +begin + if fCapacity < 1 then + Exit; + + needLock := not fInLock; + + if needLock then + Lock; + + try + while fStrings.Count > fCapacity do + fStrings.Delete(0); + finally + if needLock then + Unlock + end +end; + +procedure TLog.Lock; +begin + Init; + fLock.Enter; + fInLock := True; +end; + +function TLog.LockGetCount: Integer; +begin + Lock; + fLocked := True; + result := fStrings.Count +end; + +procedure TLog.SetCapacity(const Value: Integer); +begin + if Value <> fCapacity then + begin + fCapacity := Value; + LimitCapacity + end +end; + +procedure TLog.Unlock; +begin + fLock.Leave; + fLocked := False; + fInLock := False; +end; + +end.